Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp

gdbinit

@@ -148,11 +148,6 @@ define nextframe
   output $vmdl
   newline
   set $vmsp=$vmsp-1
-  sputs "el:\t"
-  output $vmsp
-  sputs "\t"
-  gwrite *$vmsp
-  set $vmsp=$vmsp-1
   set $vmnlocs=(int)$vmbp->nlocs
   while $vmnlocs > 0
     sputs "loc #"

libguile/chars.c

@@ -1,4 +1,4 @@
-/*	Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/*	Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -24,6 +24,8 @@
 
 #include <ctype.h>
 #include <limits.h>
+#include <unicase.h>
+
 #include "libguile/_scm.h"
 #include "libguile/validate.h"
 
@@ -55,7 +57,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr, 
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
+	     "Return @code{#t} iff @var{x} is less than @var{y} in the Unicode sequence,\n"
 	     "else @code{#f}.")
 #define FUNC_NAME s_scm_char_less_p
 {
@@ -68,7 +70,7 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
 SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
              (SCM x, SCM y),
 	     "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
-	     "ASCII sequence, else @code{#f}.")
+	     "Unicode sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_leq_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -79,7 +81,7 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
+	     "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n"
 	     "sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_gr_p
 {
@@ -92,7 +94,7 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
 SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
              (SCM x, SCM y),
 	     "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
-	     "ASCII sequence, else @code{#f}.")
+	     "Unicode sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_geq_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -104,7 +106,7 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
 SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
              (SCM x, SCM y),
 	     "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
-	     "case, else @code{#f}.")
+	     "case, else @code{#f}.  Case is locale free and not context sensitive.")
 #define FUNC_NAME s_scm_char_ci_eq_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -115,8 +117,9 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
+	     "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
-	     "ignoring case, else @code{#f}.")
+	     "than the Unicode uppercase form @var{y} in the Unicode sequence,\n"
+	     "else @code{#f}.")
 #define FUNC_NAME s_scm_char_ci_less_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -127,8 +130,9 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
+	     "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
-	     "ASCII sequence ignoring case, else @code{#f}.")
+	     "than or equal to the Unicode uppercase form of @var{y} in the\n"
+	     "Unicode  sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_ci_leq_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -139,8 +143,9 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
+	     "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
-	     "sequence ignoring case, else @code{#f}.")
+	     "than the Unicode uppercase form of @var{y} in the Unicode\n"
+	     "sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_ci_gr_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -151,8 +156,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
 
 SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
              (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
+	     "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
-	     "ASCII sequence ignoring case, else @code{#f}.")
+	     "than or equal to the Unicode uppercase form of @var{y} in the\n"
+	     "Unicode sequence, else @code{#f}.")
 #define FUNC_NAME s_scm_char_ci_geq_p
 {
   SCM_VALIDATE_CHAR (1, x);
@@ -233,7 +239,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
 #define FUNC_NAME s_scm_char_to_integer
 {
   SCM_VALIDATE_CHAR (1, chr);
-  return scm_from_ulong (SCM_CHAR(chr));
+  return scm_from_uint32 (SCM_CHAR(chr));
 }
 #undef FUNC_NAME
 
@@ -244,7 +250,15 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
 	    "Return the character at position @var{n} in the ASCII sequence.")
 #define FUNC_NAME s_scm_integer_to_char
 {
-  return SCM_MAKE_CHAR (scm_to_uchar (n));
+  scm_t_wchar cn;
+
+  cn = scm_to_wchar (n);
+
+  /* Avoid the surrogates.  */
+  if (!SCM_IS_UNICODE_CHAR (cn))
+    scm_out_of_range (FUNC_NAME, n);
+
+  return SCM_MAKE_CHAR (cn);
 }
 #undef FUNC_NAME
 
@@ -255,7 +269,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
 #define FUNC_NAME s_scm_char_upcase
 {
   SCM_VALIDATE_CHAR (1, chr);
-  return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr)));
+  return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr)));
 }
 #undef FUNC_NAME
 
@@ -266,7 +280,7 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
 #define FUNC_NAME s_scm_char_downcase
 {
   SCM_VALIDATE_CHAR (1, chr);
-  return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr)));
+  return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr)));
 }
 #undef FUNC_NAME
 
@@ -279,80 +293,121 @@ TODO: change name  to scm_i_.. ? --hwn
 */
 
 
-int
+scm_t_wchar
-scm_c_upcase (unsigned int c)
+scm_c_upcase (scm_t_wchar c)
 {
-  if (c <= UCHAR_MAX)
+  return uc_toupper (c);
-    return toupper (c);
-  else
-    return c;
 }
 
 
-int
+scm_t_wchar
-scm_c_downcase (unsigned int c)
+scm_c_downcase (scm_t_wchar c)
 {
-  if (c <= UCHAR_MAX)
+  return uc_tolower (c);
-    return tolower (c);
-  else
-    return c;
 }
 
+
 
-#ifdef _DCC
+/* There are a few sets of character names: R5RS, Guile
-# define ASCII
+   extensions for control characters, and leftover Guile extensions.
-#else
+   They are listed in order of precedence.  */
-# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
-#  define EBCDIC
-# endif /*  (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
-# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
-#  define ASCII
-# endif /*  (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
-#endif /* def _DCC */
 
+const char *const scm_r5rs_charnames[] = 
+  {
+    "space", "newline"
+  };
 
-#ifdef EBCDIC
+const scm_t_uint32 const scm_r5rs_charnums[] = 
-char *const scm_charnames[] =
+  {
+    0x20, 0x0A
+  };
+
+const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *);
+
+/* The abbreviated names for control characters.  */
+const char *const scm_C0_control_charnames[] = 
+  {
+    /* C0 controls */
+    "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
+    "bs",  "ht",  "lf",  "vt",  "ff",  "cr",  "so",  "si",
+    "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", 
+    "can", "em",  "sub", "esc", "fs",  "gs",  "rs",  "us",
+    "sp", "del"
+  };
+
+const scm_t_uint32 const scm_C0_control_charnums[] = 
+  {
+    0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
+    0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+    0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
+    0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
+    0x20, 0x7f
+  };
+
+int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof (char *);
+
+const char *const scm_alt_charnames[] = 
+  {
+    "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
+  };
+  
+const scm_t_uint32 const scm_alt_charnums[] = 
+  {
+    0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
+  };
+
+const int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *);
+
+/* Returns the string charname for a character if it exists, or NULL
+   otherwise.  */
+const char *
+scm_i_charname (SCM chr)
 {
-  "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
+  int c;
-   0   , 0   , "smm", "vt", "ff", "cr", "so", "si",
+  scm_t_uint32 i = SCM_CHAR (chr);
-  "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
-  "can", "em", "cc", 0   , "ifs", "igs", "irs", "ius",
-   "ds", "sos", "fs", 0   , "byp", "lf", "eob", "pre",
-   0   , 0   , "sm", 0   , 0   , "enq", "ack", "bel",
-   0   , 0   , "syn", 0   , "pn", "rs", "uc", "eot",
-   0   , 0   , 0   , 0   , "dc4", "nak", 0   , "sub",
-   "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
 
-const char scm_charnums[] =
+  for (c = 0; c < scm_n_r5rs_charnames; c++)
-"\000\001\002\003\004\005\006\007\
+    if (scm_r5rs_charnums[c] == i)
-\010\011\012\013\014\015\016\017\
+      return scm_r5rs_charnames[c];
-\020\021\022\023\024\025\026\027\
+
-\030\031\032\033\034\035\036\037\
+  for (c = 0; c < scm_n_C0_control_charnames; c++)
-\040\041\042\043\044\045\046\047\
+    if (scm_C0_control_charnums[c] == i)
-\050\051\052\053\054\055\056\057\
+      return scm_C0_control_charnames[c];
-\060\061\062\063\064\065\066\067\
+
-\070\071\072\073\074\075\076\077\
+  for (c = 0; c < scm_n_alt_charnames; c++)
- \n\t\b\r\f\0";
+    if (scm_alt_charnums[c] == i)
-#endif /* def EBCDIC */
+      return scm_alt_charnames[i];
-#ifdef ASCII
+
-char *const scm_charnames[] =
+  return NULL;
+}
+
+/* Return a character from a string charname.  */
+SCM
+scm_i_charname_to_char (const char *charname, size_t charname_len)
 {
-  "nul","soh","stx","etx","eot","enq","ack","bel",
+  int c;
-   "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
-  "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
-  "can", "em","sub","esc", "fs", "gs", "rs", "us",
-  "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
-const char scm_charnums[] =
-"\000\001\002\003\004\005\006\007\
-\010\011\012\013\014\015\016\017\
-\020\021\022\023\024\025\026\027\
-\030\031\032\033\034\035\036\037\
-  \n\t\b\r\f\0\177";
-#endif /* def ASCII */
 
-int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
+  /* The R5RS charnames.  These are supposed to be case
+     insensitive. */
+  for (c = 0; c < scm_n_r5rs_charnames; c++)
+    if ((strlen (scm_r5rs_charnames[c]) == charname_len)
+	&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
+      return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
 
+  /* Then come the controls.  These are not case sensitive.  */
+  for (c = 0; c < scm_n_C0_control_charnames; c++)
+    if ((strlen (scm_C0_control_charnames[c]) == charname_len)
+	&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
+      return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);
+
+  /* Lastly are some old names carried over for compatibility.  */
+  for (c = 0; c < scm_n_alt_charnames; c++)
+    if ((strlen (scm_alt_charnames[c]) == charname_len)
+	&& (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
+      return SCM_MAKE_CHAR (scm_alt_charnums[c]);
+  
+  return SCM_BOOL_F;
+}
 
 
 

libguile/chars.h

@@ -3,7 +3,7 @@
 #ifndef SCM_CHARS_H
 #define SCM_CHARS_H
 
-/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -28,15 +28,24 @@
 
 /* Immediate Characters
  */
+
+#ifndef SCM_WCHAR_DEFINED
+typedef scm_t_int32 scm_t_wchar;
+#define SCM_WCHAR_DEFINED
+#endif
+
 #define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
-#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x))
+#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
-#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char)
 
-
+#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x);                        \
+      _x < 0                                                            \
+        ? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char)   \
+        : SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);})
 
-SCM_API char *const scm_charnames[];
+#define SCM_CODEPOINT_MAX (0x10ffff)
-SCM_API int scm_n_charnames;
+#define SCM_IS_UNICODE_CHAR(c)                                          \
-SCM_API const char scm_charnums[];
+  ((scm_t_wchar)(c)<=0xd7ff ||                                          \
+   ((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX))
 
 
 
@@ -61,8 +70,11 @@ SCM_API SCM scm_char_to_integer (SCM chr);
 SCM_API SCM scm_integer_to_char (SCM n);
 SCM_API SCM scm_char_upcase (SCM chr);
 SCM_API SCM scm_char_downcase (SCM chr);
-SCM_API int scm_c_upcase (unsigned int c);
+SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
-SCM_API int scm_c_downcase (unsigned int c);
+SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
+SCM_INTERNAL const char *scm_i_charname (SCM chr);
+SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname, 
+                                         size_t charname_len);
 SCM_INTERNAL void scm_init_chars (void);
 
 #endif  /* SCM_CHARS_H */

libguile/frames.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -222,16 +222,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
-	    (SCM frame),
-	    "")
-#define FUNC_NAME s_scm_vm_frame_external_link
-{
-  SCM_VALIDATE_VM_FRAME (1, frame);
-  return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
 	    (SCM frame),
 	    "")

libguile/frames.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -30,12 +30,11 @@
 /* VM Frame Layout
    ---------------
 
-   |                  | <- fp + bp->nargs + bp->nlocs + 4
+   |                  | <- fp + bp->nargs + bp->nlocs + 3
    +------------------+    = SCM_FRAME_UPPER_ADDRESS (fp)
    | Return address   |
    | MV return address|
-   | Dynamic link     |
+   | Dynamic link     | <- fp + bp->nargs + bp->blocs
-   | External link    | <- fp + bp->nargs + bp->nlocs
    | Local variable 1 |    = SCM_FRAME_DATA_ADDRESS (fp)
    | Local variable 0 | <- fp + bp->nargs
    | Argument 1       |
@@ -51,21 +50,20 @@
 #define SCM_FRAME_DATA_ADDRESS(fp)				\
   (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs	\
       + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_FRAME_UPPER_ADDRESS(fp)	(SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_UPPER_ADDRESS(fp)	(SCM_FRAME_DATA_ADDRESS (fp) + 3)
 #define SCM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
 
 #define SCM_FRAME_BYTE_CAST(x)		((scm_byte_t *) SCM_UNPACK (x))
 #define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))
 
 #define SCM_FRAME_RETURN_ADDRESS(fp)				\
-  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
-#define SCM_FRAME_MV_RETURN_ADDRESS(fp)				\
   (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_MV_RETURN_ADDRESS(fp)				\
+  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
 #define SCM_FRAME_DYNAMIC_LINK(fp)				\
-  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
 #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl)		\
-  ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
+  ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
-#define SCM_FRAME_EXTERNAL_LINK(fp)	(SCM_FRAME_DATA_ADDRESS (fp)[0])
 #define SCM_FRAME_VARIABLE(fp,i)	fp[i]
 #define SCM_FRAME_PROGRAM(fp)		fp[-1]
 
@@ -106,7 +104,6 @@ SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
 SCM_API SCM scm_vm_frame_return_address (SCM frame);
 SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
 SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-SCM_API SCM scm_vm_frame_external_link (SCM frame);
 SCM_API SCM scm_vm_frame_stack (SCM frame);
 
 SCM_API SCM scm_c_vm_frame_prev (SCM frame);

libguile/numbers.c

@@ -5863,6 +5863,14 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max)
 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
 #include "libguile/conv-uinteger.i.c"
 
+#define TYPE                     scm_t_wchar
+#define TYPE_MIN                 (scm_t_int32)-1
+#define TYPE_MAX                 (scm_t_int32)0x10ffff
+#define SIZEOF_TYPE              4
+#define SCM_TO_TYPE_PROTO(arg)   scm_to_wchar (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
+#include "libguile/conv-integer.i.c"
+
 #if SCM_HAVE_T_INT64
 
 #define TYPE                     scm_t_int64

libguile/numbers.h

@@ -3,7 +3,7 @@
 #ifndef SCM_NUMBERS_H
 #define SCM_NUMBERS_H
 
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -174,6 +174,11 @@ typedef struct scm_t_complex
   double imag;
 } scm_t_complex;
 
+#ifndef SCM_WCHAR_DEFINED
+typedef scm_t_int32 scm_t_wchar;
+#define SCM_WCHAR_DEFINED
+#endif
+
 
 
 SCM_API SCM scm_exact_p (SCM x);
@@ -322,6 +327,9 @@ SCM_API SCM          scm_from_int32  (scm_t_int32 x);
 SCM_API scm_t_uint32 scm_to_uint32   (SCM x);
 SCM_API SCM          scm_from_uint32 (scm_t_uint32 x);
 
+SCM_API scm_t_wchar  scm_to_wchar    (SCM x);
+SCM_API SCM          scm_from_wchar  (scm_t_wchar x);
+
 #if SCM_HAVE_T_INT64
 
 SCM_API scm_t_int64  scm_to_int64    (SCM x);

libguile/objcodes.c

@@ -50,7 +50,7 @@
 
 /* The objcode magic header.  */
 #define OBJCODE_COOKIE						\
-  "GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
+  "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
 
 /* The length of the header must be a multiple of 8 bytes.  */
 verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0);

libguile/objcodes.h

@@ -25,11 +25,11 @@
 struct scm_objcode {
   scm_t_uint8 nargs;
   scm_t_uint8 nrest;
-  scm_t_uint8 nlocs;
+  scm_t_uint16 nlocs;
-  scm_t_uint8 nexts;
   scm_t_uint32 len;             /* the maximum index of base[] */
   scm_t_uint32 metalen;         /* well, i lie. this many bytes at the end of
                                    base[] for metadata */
+  scm_t_uint32 unused;          /* pad so that `base' is 8-byte aligned */
   scm_t_uint8 base[0];
 };
 
@@ -49,7 +49,6 @@ SCM_API scm_t_bits scm_tc16_objcode;
 #define SCM_OBJCODE_NARGS(x)	(SCM_OBJCODE_DATA (x)->nargs)
 #define SCM_OBJCODE_NREST(x)	(SCM_OBJCODE_DATA (x)->nrest)
 #define SCM_OBJCODE_NLOCS(x)	(SCM_OBJCODE_DATA (x)->nlocs)
-#define SCM_OBJCODE_NEXTS(x)	(SCM_OBJCODE_DATA (x)->nexts)
 #define SCM_OBJCODE_BASE(x)	(SCM_OBJCODE_DATA (x)->base)
 
 #define SCM_OBJCODE_IS_MMAP(x)	(SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)

libguile/print.c

@@ -23,6 +23,7 @@
 #endif
 
 #include <errno.h>
+#include <unictype.h>
 
 #include "libguile/_scm.h"
 #include "libguile/chars.h"
@@ -436,21 +437,39 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
     case scm_tc3_imm24:
       if (SCM_CHARP (exp))
 	{
-	  long i = SCM_CHAR (exp);
+	  scm_t_wchar i = SCM_CHAR (exp);
+          const char *name;
 
 	  if (SCM_WRITINGP (pstate))
 	    {
 	      scm_puts ("#\\", port);
-	      if ((i >= 0) && (i <= ' ') && scm_charnames[i])
+	      name = scm_i_charname (exp);
-		scm_puts (scm_charnames[i], port);
+	      if (name != NULL)
-#ifndef EBCDIC
+		scm_puts (name, port);
-	      else if (i == '\177')
+	      else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L
-		scm_puts (scm_charnames[scm_n_charnames - 1], port);
+                                                         | UC_CATEGORY_MASK_M 
-#endif
+                                                         | UC_CATEGORY_MASK_N 
-	      else if (i < 0 || i > '\177')
+                                                         | UC_CATEGORY_MASK_P 
-		scm_intprint (i, 8, port);
+                                                         | UC_CATEGORY_MASK_S))
-	      else
+                /* Print the character if is graphic character.  */
-		scm_putc (i, port);
+                {
+                  if (i<256)
+                    {
+                      /* Character is graphic.  Print it.  */
+                      scm_putc (i, port);
+                    }
+                  else
+                    {
+                      /* Character is graphic but unrepresentable in
+                         this port's encoding.  */
+                      scm_intprint (i, 8, port);
+                    }
+                }
+              else
+                {
+                  /* Character is a non-graphical character.  */
+                  scm_intprint (i, 8, port);
+                }
 	    }
 	  else
 	    scm_putc (i, port);

libguile/programs.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -36,7 +36,7 @@ scm_t_bits scm_tc16_program;
 static SCM write_program = SCM_BOOL_F;
 
 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
-	    (SCM objcode, SCM objtable, SCM external),
+	    (SCM objcode, SCM objtable, SCM free_variables),
 	    "")
 #define FUNC_NAME s_scm_make_program
 {
@@ -45,18 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
     objtable = SCM_BOOL_F;
   else if (scm_is_true (objtable))
     SCM_VALIDATE_VECTOR (2, objtable);
-  if (SCM_UNLIKELY (SCM_UNBNDP (external)))
+  if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
-    external = SCM_EOL;
+    free_variables = SCM_BOOL_F;
-  else
+  else if (free_variables != SCM_BOOL_F)
-    /* FIXME: currently this test is quite expensive (can be 2-3% of total
+    SCM_VALIDATE_VECTOR (3, free_variables);
-       execution time in programs that make many closures). We could remove it,
-       yes, but we'd get much better gains if we used some other method, like
-       just capturing the variables that we need instead of all heap-allocated
-       variables. Dunno. Keeping the check for now, as it's a user-callable
-       function, and inlining the op in the vm's make-closure operation. */
-    SCM_VALIDATE_LIST (3, external);
 
-  SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
+  SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
 }
 #undef FUNC_NAME
 
@@ -65,8 +59,8 @@ program_mark (SCM obj)
 {
   if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
     scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
-  if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
+  if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
-    scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
+    scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
   return SCM_PROGRAM_OBJCODE (obj);
 }
 
@@ -151,10 +145,9 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
   SCM_VALIDATE_PROGRAM (1, program);
 
   p = SCM_PROGRAM_DATA (program);
-  return scm_list_4 (SCM_I_MAKINUM (p->nargs),
+  return scm_list_3 (SCM_I_MAKINUM (p->nargs),
 		     SCM_I_MAKINUM (p->nrest),
-		     SCM_I_MAKINUM (p->nlocs),
+		     SCM_I_MAKINUM (p->nlocs));
-		     SCM_I_MAKINUM (p->nexts));
 }
 #undef FUNC_NAME
 
@@ -191,7 +184,7 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 
   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
   if (scm_is_true (metaobj))
-    return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
+    return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
   else
     return SCM_BOOL_F;
 }
@@ -300,26 +293,13 @@ scm_c_program_source (SCM program, size_t ip)
   return source; /* (addr . (filename . (line . column))) */
 }
 
-SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
 	    (SCM program),
 	    "")
-#define FUNC_NAME s_scm_program_external
+#define FUNC_NAME s_scm_program_free_variables
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_PROGRAM_EXTERNALS (program);
+  return SCM_PROGRAM_FREE_VARIABLES (program);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
-	    (SCM program, SCM external),
-	    "Modify the list of closure variables of @var{program} (for "
-	    "debugging purposes).")
-#define FUNC_NAME s_scm_program_external_set_x
-{
-  SCM_VALIDATE_PROGRAM (1, program);
-  SCM_VALIDATE_LIST (2, external);
-  SCM_PROGRAM_EXTERNALS (program) = external;
-  return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 

libguile/programs.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -35,12 +35,12 @@ SCM_API scm_t_bits scm_tc16_program;
 #define SCM_PROGRAM_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_program, x))
 #define SCM_PROGRAM_OBJCODE(x)	(SCM_SMOB_OBJECT (x))
 #define SCM_PROGRAM_OBJTABLE(x)	(SCM_SMOB_OBJECT_2 (x))
-#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
 #define SCM_PROGRAM_DATA(x)	(SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
 #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
 #define SCM_PROGRAM_IS_BOOT(x)	(SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
 
-SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
 
 SCM_API SCM scm_program_p (SCM obj);
 SCM_API SCM scm_program_base (SCM program);
@@ -53,8 +53,7 @@ SCM_API SCM scm_program_properties (SCM program);
 SCM_API SCM scm_program_name (SCM program);
 SCM_API SCM scm_program_objects (SCM program);
 SCM_API SCM scm_program_module (SCM program);
-SCM_API SCM scm_program_external (SCM program);
+SCM_API SCM scm_program_free_variables (SCM program);
-SCM_API SCM scm_program_external_set_x (SCM program, SCM external);
 SCM_API SCM scm_program_objcode (SCM program);
 
 SCM_API SCM scm_c_program_source (SCM program, size_t ip);

libguile/read.c

@@ -801,7 +801,7 @@ static SCM
 scm_read_character (int chr, SCM port)
 #define FUNC_NAME "scm_lreadr"
 {
-  unsigned c;
+  SCM ch;
   char charname[READER_CHAR_NAME_MAX_SIZE];
   size_t charname_len;
 
@@ -834,10 +834,9 @@ scm_read_character (int chr, SCM port)
 	return SCM_MAKE_CHAR (SCM_I_INUM (p));
     }
 
-  for (c = 0; c < scm_n_charnames; c++)
+  ch = scm_i_charname_to_char (charname, charname_len);
-    if (scm_charnames[c]
+  if (scm_is_true (ch))
-	&& (!strncasecmp (scm_charnames[c], charname, charname_len)))
+    return ch;
-      return SCM_MAKE_CHAR (scm_charnums[c]);
 
  char_error:
   scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",

libguile/vm-engine.c

@@ -21,14 +21,14 @@
 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
 #define VM_USE_HOOKS		0	/* Various hooks */
 #define VM_USE_CLOCK		0	/* Bogoclock */
-#define VM_CHECK_EXTERNAL	1	/* Check external link */
 #define VM_CHECK_OBJECT         1       /* Check object table */
+#define VM_CHECK_FREE_VARIABLES 1       /* Check free variable access */
 #define VM_PUSH_DEBUG_FRAMES    0       /* Push frames onto the evaluator debug stack */
 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
 #define VM_USE_HOOKS		1
 #define VM_USE_CLOCK		1
-#define VM_CHECK_EXTERNAL	1
 #define VM_CHECK_OBJECT         1
+#define VM_CHECK_FREE_VARIABLES 1
 #define VM_PUSH_DEBUG_FRAMES    1
 #else
 #error unknown debug engine VM_ENGINE
@@ -47,7 +47,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 
   /* Cache variables */
   struct scm_objcode *bp = NULL;	/* program base pointer */
-  SCM external = SCM_EOL;		/* external environment */
+  SCM *free_vars = NULL;                /* free variables */
+  size_t free_vars_count = 0;           /* length of FREE_VARS */
   SCM *objects = NULL;			/* constant objects */
   size_t object_count = 0;              /* length of OBJECTS */
   SCM *stack_base = vp->stack_base;	/* stack base address */
@@ -226,16 +227,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
     goto vm_error;
 #endif
 
-#if VM_CHECK_EXTERNAL
+#if VM_CHECK_OBJECT
-  vm_error_external:
+  vm_error_object:
-    err_msg  = scm_from_locale_string ("VM: Invalid external access");
+    err_msg = scm_from_locale_string ("VM: Invalid object table access");
     finish_args = SCM_EOL;
     goto vm_error;
 #endif
 
-#if VM_CHECK_OBJECT
+#if VM_CHECK_FREE_VARIABLES
-  vm_error_object:
+  vm_error_free_variable:
-    err_msg = scm_from_locale_string ("VM: Invalid object table access");
+    err_msg = scm_from_locale_string ("VM: Invalid free variable access");
     finish_args = SCM_EOL;
     goto vm_error;
 #endif
@@ -252,8 +253,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
 
 #undef VM_USE_HOOKS
 #undef VM_USE_CLOCK
-#undef VM_CHECK_EXTERNAL
 #undef VM_CHECK_OBJECT
+#undef VM_CHECK_FREE_VARIABLE
 #undef VM_PUSH_DEBUG_FRAMES
 
 /*

libguile/vm-engine.h

@@ -117,26 +117,36 @@
   vp->fp = fp;					\
 }
 
+/* FIXME */
+#define ASSERT_VARIABLE(x)                                              \
+  do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); }           \
+  } while (0)
+#define ASSERT_BOUND_VARIABLE(x)                                        \
+  do { ASSERT_VARIABLE (x);                                             \
+    if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED)                          \
+      { SYNC_REGISTER (); abort(); }                                    \
+  } while (0)
+
 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
 #define CHECK_IP() \
   do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_ALIGNED_PROCEDURE() \
+  do { if ((scm_t_bits)bp % 8) abort (); } while (0)
 #define ASSERT_BOUND(x) \
   do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
   } while (0)
 #else
 #define CHECK_IP()
+#define ASSERT_ALIGNED_PROCEDURE()
 #define ASSERT_BOUND(x)
 #endif
 
-/* Get a local copy of the program's "object table" (i.e. the vector of
+/* Cache the object table and free variables.  */
-   external bindings that are referenced by the program), initialized by
-   `load-program'.  */
-/* XXX:  We could instead use the "simple vector macros", thus not having to
-   call `scm_vector_writable_elements ()' and the likes.  */
 #define CACHE_PROGRAM()							\
 {									\
   if (bp != SCM_PROGRAM_DATA (program)) {                               \
     bp = SCM_PROGRAM_DATA (program);					\
+    ASSERT_ALIGNED_PROCEDURE ();                                        \
     if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
       objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
       object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
@@ -145,6 +155,19 @@
       object_count = 0;                                                 \
     }                                                                   \
   }                                                                     \
+  {                                                                     \
+    SCM c = SCM_PROGRAM_FREE_VARIABLES (program);                       \
+    if (SCM_I_IS_VECTOR (c))                                            \
+      {                                                                 \
+        free_vars = SCM_I_VECTOR_WELTS (c);                             \
+        free_vars_count = SCM_I_VECTOR_LENGTH (c);                      \
+      }                                                                 \
+    else                                                                \
+      {                                                                 \
+        free_vars = NULL;                                               \
+        free_vars_count = 0;                                            \
+      }                                                                 \
+  }                                                                     \
 }
 
 #define SYNC_BEFORE_GC()			\
@@ -162,14 +185,6 @@
  * Error check
  */
 
-#undef CHECK_EXTERNAL
-#if VM_CHECK_EXTERNAL
-#define CHECK_EXTERNAL(e) \
-  do { if (SCM_UNLIKELY (!SCM_CONSP (e))) goto vm_error_external; } while (0)
-#else
-#define CHECK_EXTERNAL(e)
-#endif
-
 /* Accesses to a program's object table.  */
 #if VM_CHECK_OBJECT
 #define CHECK_OBJECT(_num) \
@@ -178,6 +193,13 @@
 #define CHECK_OBJECT(_num)
 #endif
 
+#if VM_CHECK_FREE_VARIABLES
+#define CHECK_FREE_VARIABLE(_num) \
+  do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto vm_error_free_variable; } while (0)
+#else
+#define CHECK_FREE_VARIABLE(_num)
+#endif
+
 
 /*
  * Hooks
@@ -376,7 +398,7 @@ do {						\
   /* New registers */                           \
   fp = sp - bp->nargs + 1;                      \
   data = SCM_FRAME_DATA_ADDRESS (fp);           \
-  sp = data + 3;                                \
+  sp = data + 2;                                \
   CHECK_OVERFLOW ();				\
   stack_base = sp;				\
   ip = bp->base;				\
@@ -386,23 +408,11 @@ do {						\
     data[-i] = SCM_UNDEFINED;                   \
 						\
   /* Set frame data */				\
-  data[3] = (SCM)ra;                            \
+  data[2] = (SCM)ra;                            \
-  data[2] = 0x0;                                \
+  data[1] = 0x0;                                \
-  data[1] = (SCM)dl;                            \
+  data[0] = (SCM)dl;                            \
-                                                \
-  /* Postpone initializing external vars,       \
-     because if the CONS causes a GC, we        \
-     want the stack marker to see the data      \
-     array formatted as expected. */            \
-  data[0] = SCM_UNDEFINED;                      \
-  external = SCM_PROGRAM_EXTERNALS (fp[-1]);    \
-  for (i = 0; i < bp->nexts; i++)               \
-    CONS (external, SCM_UNDEFINED, external);   \
-  data[0] = external;                           \
 }
 
-#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
-
 /*
   Local Variables:
   c-file-style: "gnu"

libguile/vm-i-loader.c

@@ -20,7 +20,7 @@
 
 /* This file is included in vm_engine.c */
 
-VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
+VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer")
 {
   size_t len;
 
@@ -38,7 +38,7 @@ VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
     SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
 }
 
-VM_DEFINE_LOADER (60, load_integer, "load-integer")
+VM_DEFINE_LOADER (81, load_integer, "load-integer")
 {
   size_t len;
 
@@ -56,7 +56,7 @@ VM_DEFINE_LOADER (60, load_integer, "load-integer")
     SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
 }
 
-VM_DEFINE_LOADER (61, load_number, "load-number")
+VM_DEFINE_LOADER (82, load_number, "load-number")
 {
   size_t len;
 
@@ -69,7 +69,7 @@ VM_DEFINE_LOADER (61, load_number, "load-number")
   NEXT;
 }
 
-VM_DEFINE_LOADER (62, load_string, "load-string")
+VM_DEFINE_LOADER (83, load_string, "load-string")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -80,7 +80,7 @@ VM_DEFINE_LOADER (62, load_string, "load-string")
   NEXT;
 }
 
-VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
+VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -90,7 +90,7 @@ VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
   NEXT;
 }
 
-VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
+VM_DEFINE_LOADER (85, load_keyword, "load-keyword")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -100,7 +100,7 @@ VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
   NEXT;
 }
 
-VM_DEFINE_LOADER (65, load_program, "load-program")
+VM_DEFINE_LOADER (86, load_program, "load-program")
 {
   scm_t_uint32 len;
   SCM objs, objcode;
@@ -114,14 +114,14 @@ VM_DEFINE_LOADER (65, load_program, "load-program")
   objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
   len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
 
-  PUSH (scm_make_program (objcode, objs, SCM_EOL));
+  PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));
 
   ip += len;
 
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
 {
   SCM what;
   POP (what);
@@ -130,7 +130,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
   NEXT;
 }
 
-VM_DEFINE_LOADER (67, define, "define")
+VM_DEFINE_LOADER (88, define, "define")
 {
   SCM sym;
   size_t len;
@@ -145,7 +145,7 @@ VM_DEFINE_LOADER (67, define, "define")
   NEXT;
 }
 
-VM_DEFINE_LOADER (68, load_array, "load-array")
+VM_DEFINE_LOADER (89, load_array, "load-array")
 {
   SCM type, shape;
   size_t len;
@@ -163,7 +163,7 @@ VM_DEFINE_LOADER (68, load_array, "load-array")
   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
   (interactive "")
   (save-excursion
-    (let ((counter 59)) (goto-char (point-min))
+    (let ((counter 79)) (goto-char (point-min))
       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
         (replace-match
          (number-to-string (setq counter (1+ counter)))

libguile/vm-i-scheme.c

@@ -29,43 +29,43 @@
 
 #define RETURN(x)	do { *sp = x; NEXT; } while (0)
 
-VM_DEFINE_FUNCTION (80, not, "not", 1)
+VM_DEFINE_FUNCTION (100, not, "not", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (SCM_FALSEP (x)));
 }
 
-VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
+VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (!SCM_FALSEP (x)));
 }
 
-VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
+VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
 {
   ARGS2 (x, y);
   RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
 }
 
-VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
+VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
 {
   ARGS2 (x, y);
   RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
 }
 
-VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
+VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (SCM_NULLP (x)));
 }
 
-VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
+VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (!SCM_NULLP (x)));
 }
 
-VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
 {
   ARGS2 (x, y);
   if (SCM_EQ_P (x, y))
@@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
   RETURN (scm_eqv_p (x, y));
 }
 
-VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
+VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
 {
   ARGS2 (x, y);
   if (SCM_EQ_P (x, y))
@@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
   RETURN (scm_equal_p (x, y));
 }
 
-VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (SCM_CONSP (x)));
 }
 
-VM_DEFINE_FUNCTION (89, listp, "list?", 1)
+VM_DEFINE_FUNCTION (109, listp, "list?", 1)
 {
   ARGS1 (x);
   RETURN (SCM_BOOL (scm_ilength (x) >= 0));
@@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (89, listp, "list?", 1)
  * Basic data
  */
 
-VM_DEFINE_FUNCTION (90, cons, "cons", 2)
+VM_DEFINE_FUNCTION (110, cons, "cons", 2)
 {
   ARGS2 (x, y);
   CONS (x, x, y);
@@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2)
       goto vm_error_not_a_pair;                 \
     }
   
-VM_DEFINE_FUNCTION (91, car, "car", 1)
+VM_DEFINE_FUNCTION (111, car, "car", 1)
 {
   ARGS1 (x);
   VM_VALIDATE_CONS (x);
   RETURN (SCM_CAR (x));
 }
 
-VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (112, cdr, "cdr", 1)
 {
   ARGS1 (x);
   VM_VALIDATE_CONS (x);
   RETURN (SCM_CDR (x));
 }
 
-VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
 {
   SCM x, y;
   POP (y);
@@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0)
+VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
 {
   SCM x, y;
   POP (y);
@@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0)
   RETURN (srel (x, y));                                         \
 }
 
-VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
+VM_DEFINE_FUNCTION (115, ee, "ee?", 2)
 {
   REL (==, scm_num_eq_p);
 }
 
-VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
+VM_DEFINE_FUNCTION (116, lt, "lt?", 2)
 {
   REL (<, scm_less_p);
 }
 
-VM_DEFINE_FUNCTION (97, le, "le?", 2)
+VM_DEFINE_FUNCTION (117, le, "le?", 2)
 {
   REL (<=, scm_leq_p);
 }
 
-VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
+VM_DEFINE_FUNCTION (118, gt, "gt?", 2)
 {
   REL (>, scm_gr_p);
 }
 
-VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
+VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
 {
   REL (>=, scm_geq_p);
 }
@@ -210,45 +210,45 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
   RETURN (SFUNC (x, y));				\
 }
 
-VM_DEFINE_FUNCTION (100, add, "add", 2)
+VM_DEFINE_FUNCTION (120, add, "add", 2)
 {
   FUNC2 (+, scm_sum);
 }
 
-VM_DEFINE_FUNCTION (101, sub, "sub", 2)
+VM_DEFINE_FUNCTION (121, sub, "sub", 2)
 {
   FUNC2 (-, scm_difference);
 }
 
-VM_DEFINE_FUNCTION (102, mul, "mul", 2)
+VM_DEFINE_FUNCTION (122, mul, "mul", 2)
 {
   ARGS2 (x, y);
   SYNC_REGISTER ();
   RETURN (scm_product (x, y));
 }
 
-VM_DEFINE_FUNCTION (103, div, "div", 2)
+VM_DEFINE_FUNCTION (123, div, "div", 2)
 {
   ARGS2 (x, y);
   SYNC_REGISTER ();
   RETURN (scm_divide (x, y));
 }
 
-VM_DEFINE_FUNCTION (104, quo, "quo", 2)
+VM_DEFINE_FUNCTION (124, quo, "quo", 2)
 {
   ARGS2 (x, y);
   SYNC_REGISTER ();
   RETURN (scm_quotient (x, y));
 }
 
-VM_DEFINE_FUNCTION (105, rem, "rem", 2)
+VM_DEFINE_FUNCTION (125, rem, "rem", 2)
 {
   ARGS2 (x, y);
   SYNC_REGISTER ();
   RETURN (scm_remainder (x, y));
 }
 
-VM_DEFINE_FUNCTION (106, mod, "mod", 2)
+VM_DEFINE_FUNCTION (126, mod, "mod", 2)
 {
   ARGS2 (x, y);
   SYNC_REGISTER ();
@@ -259,7 +259,7 @@ VM_DEFINE_FUNCTION (106, mod, "mod", 2)
 /*
  * GOOPS support
  */
-VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
 {
   size_t slot;
   ARGS2 (instance, idx);
@@ -267,7 +267,7 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 }
 
-VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0)
 {
   SCM instance, idx, val;
   size_t slot;
@@ -279,7 +279,7 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
   NEXT;
 }
 
-VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
 {
   long i = 0;
   ARGS2 (vect, idx);
@@ -292,7 +292,7 @@ VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2)
     RETURN (scm_vector_ref (vect, idx));
 }
 
-VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
 {
   long i = 0;
   SCM vect, idx, val;
@@ -325,21 +325,21 @@ VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0)
   }                                                                     \
 }
 
-VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3)
 BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3)
 BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3)
 BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3)
 BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3)
 BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3)
 BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3)
 BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3)
+VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3)
 BV_REF_WITH_ENDIANNESS (f64, ieee_double)
 
 #undef BV_REF_WITH_ENDIANNESS
@@ -392,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
     RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx));           \
 }
 
-VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2)
 BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2)
+VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2)
 BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2)
+VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2)
 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2)
+VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2)
+VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
 /* FIXME: u32 is always a fixnum on 64-bit builds */
 BV_INT_REF (u32, uint32, 4)
-VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2)
+VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
 BV_INT_REF (s32, int32, 4)
-VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2)
+VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
 BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2)
+VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
 BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2)
+VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2)
 BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2)
+VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2)
 BV_FLOAT_REF (f64, ieee_double, double, 8)
 
 #undef BV_FIXABLE_INT_REF
@@ -433,21 +433,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
   }                                                                     \
 }
 
-VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0)
 BV_SET_WITH_ENDIANNESS (f64, ieee_double)
 
 #undef BV_SET_WITH_ENDIANNESS
@@ -500,26 +500,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
   NEXT;                                                                 \
 }
 
-VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0)
 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0)
 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
 /* FIXME: u32 is always a fixnum on 64-bit builds */
 BV_INT_SET (u32, uint32, 4)
-VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
 BV_INT_SET (s32, int32, 4)
-VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
 BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
 BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
 BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
 BV_FLOAT_SET (f64, ieee_double, double, 8)
 
 #undef BV_FIXABLE_INT_SET
@@ -531,7 +531,7 @@ BV_FLOAT_SET (f64, ieee_double, double, 8)
   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
   (interactive "")
   (save-excursion
-    (let ((counter 79)) (goto-char (point-min))
+    (let ((counter 99)) (goto-char (point-min))
       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
         (replace-match
          (number-to-string (setq counter (1+ counter)))

libguile/vm-i-system.c

@@ -145,7 +145,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
 {
   scm_t_uint64 v = 0;
   v += FETCH ();
@@ -160,7 +160,7 @@ VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1)
+VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
 {
   scm_t_uint64 v = 0;
   v += FETCH ();
@@ -175,13 +175,26 @@ VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
 {
   PUSH (SCM_MAKE_CHAR (FETCH ()));
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
+{
+  scm_t_wchar v = 0;
+  v += FETCH ();
+  v <<= 8; v += FETCH ();
+  v <<= 8; v += FETCH ();
+  v <<= 8; v += FETCH ();
+  PUSH (SCM_MAKE_CHAR (v));
+  NEXT;
+}
+
+
+
+VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
 {
   unsigned h = FETCH ();
   unsigned l = FETCH ();
@@ -190,7 +203,7 @@ VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
 {
   unsigned h = FETCH ();
   unsigned l = FETCH ();
@@ -208,19 +221,19 @@ VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
 {
   POP_LIST_MARK ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
 {
   POP_CONS_MARK ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
 {
   POP_LIST_MARK ();
   SYNC_REGISTER ();
@@ -228,7 +241,7 @@ VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
 {
   SCM l;
   POP (l);
@@ -254,9 +267,11 @@ VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
 #define VARIABLE_SET(v,o)	SCM_VARIABLE_SET (v, o)
 #define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
 
+#define FREE_VARIABLE_REF(i)	free_vars[i]
+
 /* ref */
 
-VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
 {
   register unsigned objnum = FETCH ();
   CHECK_OBJECT (objnum);
@@ -264,29 +279,35 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
+/* FIXME: necessary? elt 255 of the vector could be a vector... */
+VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
+{
+  unsigned int objnum = FETCH ();
+  objnum <<= 8;
+  objnum += FETCH ();
+  CHECK_OBJECT (objnum);
+  PUSH (OBJECT_REF (objnum));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
 {
   PUSH (LOCAL_REF (FETCH ()));
   ASSERT_BOUND (*sp);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
 {
-  unsigned int i;
+  unsigned int i = FETCH ();
-  SCM e = external;
+  i <<= 8;
-  for (i = FETCH (); i; i--)
+  i += FETCH ();
-    {
+  PUSH (LOCAL_REF (i));
-      CHECK_EXTERNAL(e);
-      e = SCM_CDR (e);
-    }
-  CHECK_EXTERNAL(e);
-  PUSH (SCM_CAR (e));
   ASSERT_BOUND (*sp);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
 {
   SCM x = *sp;
 
@@ -305,7 +326,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
 {
   unsigned objnum = FETCH ();
   SCM what;
@@ -328,38 +349,58 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+{
+  SCM what;
+  unsigned int objnum = FETCH ();
+  objnum <<= 8;
+  objnum += FETCH ();
+  CHECK_OBJECT (objnum);
+  what = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (what)) 
+    {
+      SYNC_REGISTER ();
+      what = resolve_variable (what, scm_program_module (program));
+      if (!VARIABLE_BOUNDP (what))
+        {
+          finish_args = scm_list_1 (what);
+          goto vm_error_unbound;
+        }
+      OBJECT_SET (objnum, what);
+    }
+
+  PUSH (VARIABLE_REF (what));
+  NEXT;
+}
+
 /* set */
 
-VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
 {
   LOCAL_SET (FETCH (), *sp);
   DROP ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
 {
-  unsigned int i;
+  unsigned int i = FETCH ();
-  SCM e = external;
+  i <<= 8;
-  for (i = FETCH (); i; i--)
+  i += FETCH ();
-    {
+  LOCAL_SET (i, *sp);
-      CHECK_EXTERNAL(e);
-      e = SCM_CDR (e);
-    }
-  CHECK_EXTERNAL(e);
-  SCM_SETCAR (e, *sp);
   DROP ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
 {
   VARIABLE_SET (sp[0], sp[-1]);
   DROPN (2);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
 {
   unsigned objnum = FETCH ();
   SCM what;
@@ -378,12 +419,33 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+{
+  SCM what;
+  unsigned int objnum = FETCH ();
+  objnum <<= 8;
+  objnum += FETCH ();
+  CHECK_OBJECT (objnum);
+  what = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (what)) 
+    {
+      SYNC_BEFORE_GC ();
+      what = resolve_variable (what, scm_program_module (program));
+      OBJECT_SET (objnum, what);
+    }
+
+  VARIABLE_SET (what, *sp);
+  DROP ();
+  NEXT;
+}
+
 
 /*
  * branch and jump
  */
 
-/* offset must be a signed short!!! */
+/* offset must be a signed 16 bit int!!! */
 #define FETCH_OFFSET(offset)                    \
 {						\
   int h = FETCH ();				\
@@ -393,51 +455,51 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
 
 #define BR(p)					\
 {						\
-  signed short offset;                          \
+  scm_t_int16 offset;                           \
   FETCH_OFFSET (offset);                        \
   if (p)					\
-    ip += offset;				\
+    ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);      \
   NULLSTACK (1);				\
   DROP ();					\
   NEXT;						\
 }
 
-VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
 {
-  int h = FETCH ();
+  scm_t_int16 offset;
-  int l = FETCH ();
+  FETCH_OFFSET (offset);
-  ip += (signed short) (h << 8) + l;
+  ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
 {
   BR (!SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
 {
   BR (SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
 {
   sp--; /* underflow? */
   BR (SCM_EQ_P (sp[0], sp[1]));
 }
 
-VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
 {
   sp--; /* underflow? */
   BR (!SCM_EQ_P (sp[0], sp[1]));
 }
 
-VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
 {
   BR (SCM_NULLP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
 {
   BR (!SCM_NULLP (*sp));
 }
@@ -447,15 +509,7 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
  * Subprogram call
  */
 
-VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
-{
-  SYNC_BEFORE_GC ();
-  SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
-                SCM_PROGRAM_OBJTABLE (*sp), external);
-  NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
 {
   SCM x;
   nargs = FETCH ();
@@ -576,7 +630,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
   goto vm_error_wrong_type_apply;
 }
 
-VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
 {
   register SCM x;
   nargs = FETCH ();
@@ -603,12 +657,6 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
       sp -= 2;
       NULLSTACK (bp->nargs + 1);
 
-      /* Freshen the externals */
-      external = SCM_PROGRAM_EXTERNALS (x);
-      for (i = 0; i < bp->nexts; i++)
-        CONS (external, SCM_UNDEFINED, external);
-      SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
-
       /* Init locals to valid SCM values */
       for (i = 0; i < bp->nlocs; i++)
 	LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
@@ -657,7 +705,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
          sure we have space for the locals now */
       data = SCM_FRAME_DATA_ADDRESS (fp);
       ip = bp->base;
-      stack_base = data + 3;
+      stack_base = data + 2;
       sp = stack_base;
       CHECK_OVERFLOW ();
 
@@ -672,17 +720,9 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
         data[-i] = SCM_UNDEFINED;
       
       /* Set frame data */
-      data[3] = (SCM)ra;
+      data[2] = (SCM)ra;
-      data[2] = (SCM)mvra;
+      data[1] = (SCM)mvra;
-      data[1] = (SCM)dl;
+      data[0] = (SCM)dl;
-
-      /* Postpone initializing external vars, because if the CONS causes a GC,
-         we want the stack marker to see the data array formatted as expected. */
-      data[0] = SCM_UNDEFINED;
-      external = SCM_PROGRAM_EXTERNALS (fp[-1]);
-      for (i = 0; i < bp->nexts; i++)
-        CONS (external, SCM_UNDEFINED, external);
-      data[0] = external;
 
       ENTER_HOOK ();
       APPLY_HOOK ();
@@ -770,7 +810,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
   goto vm_error_wrong_type_apply;
 }
 
-VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
 {
   SCM x;
   POP (x);
@@ -779,7 +819,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
   goto vm_goto_args;
 }
 
-VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
 {
   SCM x;
   POP (x);
@@ -788,13 +828,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
   goto vm_call;
 }
 
-VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
 {
   SCM x;
-  signed short offset;
+  scm_t_int16 offset;
+  scm_t_uint8 *mvra;
   
   nargs = FETCH ();
   FETCH_OFFSET (offset);
+  mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
 
   x = sp[-nargs];
 
@@ -807,7 +849,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
       CACHE_PROGRAM ();
       INIT_ARGS ();
       NEW_FRAME ();
-      SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+      SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
       ENTER_HOOK ();
       APPLY_HOOK ();
       NEXT;
@@ -832,7 +874,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
           len = scm_length (values);
           PUSH_LIST (values, SCM_NULLP);
           PUSH (len);
-          ip += offset;
+          ip = mvra;
         }
       NEXT;
     }
@@ -849,7 +891,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
   goto vm_error_wrong_type_apply;
 }
 
-VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
 {
   int len;
   SCM ls;
@@ -868,7 +910,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
   goto vm_call;
 }
 
-VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
 {
   int len;
   SCM ls;
@@ -887,7 +929,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
   goto vm_goto_args;
 }
 
-VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
 {
   int first;
   SCM proc, cont;
@@ -921,7 +963,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
     }
 }
 
-VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
 {
   int first;
   SCM proc, cont;
@@ -953,7 +995,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
     }
 }
 
-VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
 {
  vm_return:
   EXIT_HOOK ();
@@ -966,12 +1008,12 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
 
     POP (ret);
     ASSERT (sp == stack_base);
-    ASSERT (stack_base == data + 3);
+    ASSERT (stack_base == data + 2);
 
     /* Restore registers */
     sp = SCM_FRAME_LOWER_ADDRESS (fp);
-    ip = SCM_FRAME_BYTE_CAST (data[3]);
+    ip = SCM_FRAME_BYTE_CAST (data[2]);
-    fp = SCM_FRAME_STACK_CAST (data[1]);
+    fp = SCM_FRAME_STACK_CAST (data[0]);
     {
 #ifdef VM_ENABLE_STACK_NULLING
       int nullcount = stack_base - sp;
@@ -987,12 +1029,11 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
   /* Restore the last program */
   program = SCM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
-  CACHE_EXTERNAL ();
   CHECK_IP ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
 {
   /* nvalues declared at top level, because for some reason gcc seems to think
      that perhaps it might be used without declaration. Fooey to that, I say. */
@@ -1004,16 +1045,16 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
   RETURN_HOOK ();
 
   data = SCM_FRAME_DATA_ADDRESS (fp);
-  ASSERT (stack_base == data + 3);
+  ASSERT (stack_base == data + 2);
 
-  /* data[2] is the mv return address */
+  /* data[1] is the mv return address */
-  if (nvalues != 1 && data[2]) 
+  if (nvalues != 1 && data[1]) 
     {
       int i;
       /* Restore registers */
       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
-      ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
+      ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
-      fp = SCM_FRAME_STACK_CAST (data[1]);
+      fp = SCM_FRAME_STACK_CAST (data[0]);
         
       /* Push return values, and the number of values */
       for (i = 0; i < nvalues; i++)
@@ -1032,8 +1073,8 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
          continuation.) */
       /* Restore registers */
       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
-      ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
+      ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
-      fp = SCM_FRAME_STACK_CAST (data[1]);
+      fp = SCM_FRAME_STACK_CAST (data[0]);
         
       /* Push first value */
       *++sp = stack_base[1];
@@ -1048,12 +1089,11 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
   /* Restore the last program */
   program = SCM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
-  CACHE_EXTERNAL ();
   CHECK_IP ();
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
 {
   SCM l;
 
@@ -1076,7 +1116,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
   goto vm_return_values;
 }
 
-VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
 {
   SCM x;
   int nbinds, rest;
@@ -1099,62 +1139,100 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (52, long_object_ref, "long-object-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
 {
-  unsigned int objnum = FETCH ();
+  SCM val;
-  objnum <<= 8;
+  POP (val);
-  objnum += FETCH ();
+  SYNC_BEFORE_GC ();
-  CHECK_OBJECT (objnum);
+  LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
-  PUSH (OBJECT_REF (objnum));
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (53, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+/* for letrec:
+   (let ((a *undef*) (b *undef*) ...)
+     (set! a (lambda () (b ...)))
+     ...)
+ */
+VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
 {
-  SCM what;
+  SYNC_BEFORE_GC ();
-  unsigned int objnum = FETCH ();
+  LOCAL_SET (FETCH (),
-  objnum <<= 8;
+             scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
-  objnum += FETCH ();
-  CHECK_OBJECT (objnum);
-  what = OBJECT_REF (objnum);
-
-  if (!SCM_VARIABLEP (what)) 
-    {
-      SYNC_REGISTER ();
-      what = resolve_variable (what, scm_program_module (program));
-      if (!VARIABLE_BOUNDP (what))
-        {
-          finish_args = scm_list_1 (what);
-          goto vm_error_unbound;
-        }
-      OBJECT_SET (objnum, what);
-    }
-
-  PUSH (VARIABLE_REF (what));
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
 {
-  SCM what;
+  SCM v = LOCAL_REF (FETCH ());
-  unsigned int objnum = FETCH ();
+  ASSERT_BOUND_VARIABLE (v);
-  objnum <<= 8;
+  PUSH (VARIABLE_REF (v));
-  objnum += FETCH ();
-  CHECK_OBJECT (objnum);
-  what = OBJECT_REF (objnum);
-
-  if (!SCM_VARIABLEP (what)) 
-    {
-      SYNC_BEFORE_GC ();
-      what = resolve_variable (what, scm_program_module (program));
-      OBJECT_SET (objnum, what);
-    }
-
-  VARIABLE_SET (what, *sp);
-  DROP ();
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+{
+  SCM v, val;
+  v = LOCAL_REF (FETCH ());
+  POP (val);
+  ASSERT_VARIABLE (v);
+  VARIABLE_SET (v, val);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
+{
+  scm_t_uint8 idx = FETCH ();
+  
+  CHECK_FREE_VARIABLE (idx);
+  PUSH (FREE_VARIABLE_REF (idx));
+  NEXT;
+}
+
+/* no free-set -- if a var is assigned, it should be in a box */
+
+VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+{
+  SCM v;
+  scm_t_uint8 idx = FETCH ();
+  CHECK_FREE_VARIABLE (idx);
+  v = FREE_VARIABLE_REF (idx);
+  ASSERT_BOUND_VARIABLE (v);
+  PUSH (VARIABLE_REF (v));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
+{
+  SCM v, val;
+  scm_t_uint8 idx = FETCH ();
+  POP (val);
+  CHECK_FREE_VARIABLE (idx);
+  v = FREE_VARIABLE_REF (idx);
+  ASSERT_BOUND_VARIABLE (v);
+  VARIABLE_SET (v, val);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
+{
+  SCM vect;
+  POP (vect);
+  SYNC_BEFORE_GC ();
+  /* fixme underflow */
+  SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
+                SCM_PROGRAM_OBJTABLE (*sp), vect);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
+{
+  SYNC_BEFORE_GC ();
+  /* fixme underflow */
+  PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
+  NEXT;
+}
+
+
 /*
 (defun renumber-ops ()
   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"

libguile/vm.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -220,46 +220,35 @@ static SCM sym_vm_run;
 static SCM sym_vm_error;
 static SCM sym_debug;
 
-static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
-{
-  scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
-  memcpy (new_bytes, bytes, len);
-  return scm_take_u8vector (new_bytes, len);
-}
-
-/* Dummy structure to guarantee 32-bit alignment.  */
-struct t_32bit_aligned
-{
-  scm_t_int32 dummy;
-  scm_t_uint8 bytes[18];
-};
-
 static SCM
 really_make_boot_program (long nargs)
 {
   SCM u8vec;
-  struct t_32bit_aligned bytes =
+  /* Make sure "bytes" is 64-bit aligned.  */
-    {
+  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
-      .dummy = 0,
+                         scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
-      .bytes = { 0, 0, 0, 0,
+                         scm_op_halt };
-		 0, 0, 0, 0,
+  struct scm_objcode *bp;
-		 0, 0, 0, 0,
-		 scm_op_mv_call, 0, 0, 1,
-		 scm_op_make_int8_1, scm_op_halt }
-    };
-
   SCM ret;
 
-  /* Set length in current endianness, no meta.  */
-  ((scm_t_uint32 *) bytes.bytes)[1] = 6;
-
   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
     abort ();
-  bytes.bytes[13] = (scm_byte_t) nargs;
+  text[1] = (scm_t_uint8)nargs;
 
-  u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes));
+  bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
+                      "make-u8vector");
+  memcpy (bp->base, text, sizeof (text));
+  bp->nargs = 0;
+  bp->nrest = 0;
+  bp->nlocs = 0;
+  bp->len = sizeof(text);
+  bp->metalen = 0;
+  bp->unused = 0;
+
+  u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
+                             sizeof (struct scm_objcode) + sizeof (text));
   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
-                          SCM_BOOL_F, SCM_EOL);
+                          SCM_BOOL_F, SCM_BOOL_F);
   SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
 
   return ret;
@@ -325,7 +314,7 @@ resolve_variable (SCM what, SCM program_module)
 }
   
 
-#define VM_DEFAULT_STACK_SIZE	(16 * 1024)
+#define VM_DEFAULT_STACK_SIZE	(64 * 1024)
 
 #define VM_NAME   vm_regular_engine
 #define FUNC_NAME "vm-regular-engine"
@@ -663,7 +652,7 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
 SCM scm_load_compiled_with_vm (SCM file)
 {
   SCM program = scm_make_program (scm_load_objcode (file),
-                                  SCM_BOOL_F, SCM_EOL);
+                                  SCM_BOOL_F, SCM_BOOL_F);
   
   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 }

module/Makefile.am

@@ -34,6 +34,7 @@ SOURCES =								\
   ice-9/psyntax-pp.scm 							\
   system/base/pmatch.scm system/base/syntax.scm				\
   system/base/compile.scm system/base/language.scm			\
+  system/base/message.scm						\
 									\
   language/tree-il.scm							\
   language/ghil.scm language/glil.scm language/assembly.scm		\

module/ice-9/psyntax-pp.scm

@@ -54,7 +54,8 @@
                (let ((id293 (if (syntax-object?99 id292)
                               (syntax-object-expression100 id292)
                               id292)))
-                 (gensym (symbol->string id293)))))
+                 (gensym
+                   (string-append (symbol->string id293) " ")))))
            (strip161
              (lambda (x294 w295)
                (if (memq (quote top) (wrap-marks118 w295))

module/ice-9/psyntax.scm

@@ -1,6 +1,6 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;; 	Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -529,10 +529,10 @@
                  `(letrec ,(map list vars val-exps) ,body-exp)
                  src))))))
 
-;; FIXME: wingo: use make-lexical ?
+;; FIXME: use a faster gensym
 (define-syntax build-lexical-var
   (syntax-rules ()
-    ((_ src id) (gensym (symbol->string id)))))
+    ((_ src id) (gensym (string-append (symbol->string id) " ")))))
 
 (define-structure (syntax-object expression wrap module))
 

module/language/assembly.scm

@@ -24,12 +24,12 @@
   #:use-module (system vm instruction)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export (byte-length
-            addr+ align-program align-code
+            addr+ align-program align-code align-block
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
-;; nargs, nrest, nlocs, nexts, len, metalen
+;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 1 1 4 4))
+(define *program-header-len* (+ 1 1 2 4 4 4))
 
 ;; lengths are encoded in 3 bytes
 (define *len-len* 3)
@@ -54,7 +54,7 @@
      (+ 1 *len-len* (bytevector-length bv)))
     ((define ,str)
      (+ 1 *len-len* (string-length str)))
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (+ 1 (instruction-length inst)))
@@ -63,17 +63,24 @@
 
 (define *program-alignment* 8)
 
+(define *block-alignment* 8)
+
 (define (addr+ addr code)
   (fold (lambda (x len) (+ (byte-length x) len))
         addr
         code))
 
+(define (code-alignment addr alignment header-len)
+  (make-list (modulo (- alignment
+                        (modulo (+ addr header-len) alignment))
+                     alignment)
+             '(nop)))
+
+(define (align-block addr)
+  (code-alignment addr *block-alignment* 0))
 
 (define (align-code code addr alignment header-len)
-  `(,@(make-list (modulo (- alignment
+  `(,@(code-alignment addr alignment header-len)
-                            (modulo (+ addr header-len) alignment))
-                         alignment)
-                 '(nop))
     ,code))
 
 (define (align-program prog addr)
@@ -110,7 +117,7 @@
 	((null? x) `(make-eol))
 	((and (integer? x) (exact? x))
 	 (cond ((and (<= -128 x) (< x 128))
-		`(make-int8 ,(modulo x 256)))
+		(assembly-pack `(make-int8 ,(modulo x 256))))
 	       ((and (<= -32768 x) (< x 32768))
 		(let ((n (if (< x 0) (+ x 65536) x)))
 		  `(make-int16 ,(quotient n 256) ,(modulo n 256))))
@@ -125,7 +132,11 @@
                                   (bytevector-s64-set! bv 0 x (endianness big))
                                   bv))))
 	       (else #f)))
-	((char? x) `(make-char8 ,(char->integer x)))
+	((char? x)
+         (cond ((<= (char->integer x) #xff)
+                `(make-char8 ,(char->integer x)))
+               (else
+                `(make-char32 ,(char->integer x)))))
 	(else #f)))
 
 (define (assembly->object code)
@@ -151,6 +162,11 @@
       (endianness big)))
     ((make-char8 ,n)
      (integer->char n))
+    ((make-char32 ,n1 ,n2 ,n3 ,n4)
+     (integer->char (+ (* n1 #x1000000)
+                       (* n2 #x10000)
+                       (* n3 #x100)
+                       n4)))
     ((load-string ,s) s)
     ((load-symbol ,s) (string->symbol s))
     ((load-keyword ,s) (symbol->keyword (string->symbol s)))

module/language/assembly/compile-bytecode.scm

@@ -77,10 +77,19 @@
     ;; Ew!
     (for-each write-byte (bytevector->u8-list bv)))
   (define (write-break label)
-    (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
+    (let ((offset (- (assq-ref labels label)
+                     (logand (+ (get-addr) 2) (lognot #x7)))))
+      (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
+            ((>= offset (ash 1 18)) (error "jump too far forward" offset))
+            ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
+            (else (write-uint16-be (ash offset -3))))))
   
   (let ((inst (car asm))
         (args (cdr asm))
+        (write-uint16 (case byte-order
+                        ((1234) write-uint16-le)
+                        ((4321) write-uint16-be)
+                        (else (error "unknown endianness" byte-order))))
         (write-uint32 (case byte-order
                         ((1234) write-uint32-le)
                         ((4321) write-uint32-be)
@@ -89,14 +98,13 @@
           (len (instruction-length inst)))
       (write-byte opcode)
       (pmatch asm
-        ((load-program ,nargs ,nrest ,nlocs ,nexts
+        ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
-                       ,labels ,length ,meta . ,code)
          (write-byte nargs)
          (write-byte nrest)
-         (write-byte nlocs)
+         (write-uint16 nlocs)
-         (write-byte nexts)
          (write-uint32 length)
          (write-uint32 (if meta (1- (byte-length meta)) 0))
+         (write-uint32 0) ; padding
          (letrec ((i 0)
                   (write (lambda (x) (set! i (1+ i)) (write-byte x)))
                   (get-addr (lambda () i)))
@@ -114,6 +122,7 @@
                ;; meets the alignment requirements of `scm_objcode'.  See
                ;; `scm_c_make_objcode_slice ()'.
                (write-bytecode meta write get-addr '()))))
+        ((make-char32 ,x) (write-uint32-be x))
         ((load-unsigned-integer ,str) (write-loader str))
         ((load-integer ,str) (write-loader str))
         ((load-number ,str) (write-loader str))

module/language/assembly/decompile-bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -48,17 +48,21 @@
         x
         (- x (ash 1 16)))))
 
+;; FIXME: this is a little-endian disassembly!!!
 (define (decode-load-program pop)
-  (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
+  (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
+         (nlocs (+ nlocs0 (ash nlocs1 8)))
          (a (pop)) (b (pop)) (c (pop)) (d (pop))
          (e (pop)) (f (pop)) (g (pop)) (h (pop))
          (len (+ a (ash b 8) (ash c 16) (ash d 24)))
          (metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
          (totlen (+ len metalen))
+         (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
          (labels '())
          (i 0))
     (define (ensure-label rel1 rel2)
-      (let ((where (+ i (bytes->s16 rel1 rel2))))
+      (let ((where (+ (logand i (lognot #x7))
+                      (* (bytes->s16 rel1 rel2) 8))))
         (or (assv-ref labels where)
             (begin
               (let ((l (gensym ":L")))
@@ -74,7 +78,7 @@
       (cond ((> i len)
              (error "error decoding program -- read too many bytes" out))
             ((= i len)
-             `(load-program ,nargs ,nrest ,nlocs ,nexts
+             `(load-program ,nargs ,nrest ,nlocs 
                             ,(map (lambda (x) (cons (cdr x) (car x)))
                                   (reverse labels))
                             ,len

module/language/assembly/disassemble.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -35,12 +35,11 @@
 
 (define (disassemble-load-program asm env)
   (pmatch asm
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
      (let ((objs  (and env (assq-ref env 'objects)))
+           (free-vars (and env (assq-ref env 'free-vars)))
            (meta  (and env (assq-ref env 'meta)))
-           (exts  (and env (assq-ref env 'exts)))
            (blocs (and env (assq-ref env 'blocs)))
-           (bexts (and env (assq-ref env 'bexts)))
            (srcs  (and env (assq-ref env 'sources))))
        (let lp ((pos 0) (code code) (programs '()))
          (cond
@@ -63,13 +62,13 @@
                       (acons sym asm programs))))
                (else
                 (print-info pos asm
-                            (code-annotation end asm objs nargs blocs bexts
+                            (code-annotation end asm objs nargs blocs
                                              labels)
                             (and=> (and srcs (assq end srcs)) source->string))
                 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
                  
-       (if (pair? exts)
+       (if (pair? free-vars)
-           (disassemble-externals exts))
+           (disassemble-free-vars free-vars))
        (if meta
            (disassemble-meta meta))
 
@@ -92,13 +91,12 @@
 	((= n len) (newline))
       (print-info n (vector-ref objs n) #f #f))))
 
-(define (disassemble-externals exts)
+(define (disassemble-free-vars free-vars)
-  (display "Externals:\n\n")
+  (display "Free variables:\n\n")
-  (let ((len (length exts)))
+  (let ((i 0))
-    (do ((n 0 (1+ n))
+    (cond ((< i (vector-length free-vars))
-	 (l exts (cdr l)))
+           (print-info i (vector-ref free-vars i) #f #f)
-	((null? l) (newline))
+           (lp (1+ i))))))
-      (print-info n (car l) #f #f))))
 
 (define-macro (unless test . body)
   `(if (not ,test) (begin ,@body)))
@@ -122,7 +120,7 @@
 (define (make-int16 byte1 byte2)
   (+ (* byte1 256) byte2))
 
-(define (code-annotation end-addr code objs nargs blocs bexts labels)
+(define (code-annotation end-addr code objs nargs blocs labels)
   (let* ((code (assembly-unpack code))
          (inst (car code))
          (args (cdr code)))
@@ -133,7 +131,7 @@
        (list "-> ~A" (assq-ref labels (car args))))
       ((object-ref)
        (and objs (list "~s" (vector-ref objs (car args)))))
-      ((local-ref local-set)
+      ((local-ref local-boxed-ref local-set local-boxed-set)
        (and blocs
             (let lp ((bindings (list-ref blocs (car args))))
               (and (pair? bindings)
@@ -143,13 +141,9 @@
                          (list "`~a'~@[ (arg)~]"
                                (binding:name b) (< (binding:index b) nargs))
                          (lp (cdr bindings))))))))
-      ((external-ref external-set)
+      ((free-ref free-boxed-ref free-boxed-set)
-       (and bexts
+       ;; FIXME: we can do better than this
-            (if (< (car args) (length bexts))
+       (list "(closure variable)"))
-                (let ((b (list-ref bexts (car args))))
-                  (list "`~a'~@[ (arg)~]"
-                        (binding:name b) (< (binding:index b) nargs)))
-                (list "(closure variable)"))))
       ((toplevel-ref toplevel-set)
        (and objs
             (let ((v (vector-ref objs (car args))))

module/language/glil.scm

@@ -1,6 +1,6 @@
 ;;; Guile Low Intermediate Language
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -24,9 +24,9 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export
   (<glil-program> make-glil-program glil-program?
-   glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
+   glil-program-nargs glil-program-nrest glil-program-nlocs
-   glil-program-meta glil-program-body glil-program-closure-level
+   glil-program-meta glil-program-body
-
+   
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
 
@@ -43,11 +43,8 @@
    <glil-const> make-glil-const glil-const?
    glil-const-obj
 
-   <glil-local> make-glil-local glil-local?
+   <glil-lexical> make-glil-lexical glil-lexical?
-   glil-local-op glil-local-index
+   glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
-
-   <glil-external> make-glil-external glil-external?
-   glil-external-op glil-external-depth glil-external-index
 
    <glil-toplevel> make-glil-toplevel glil-toplevel?
    glil-toplevel-op glil-toplevel-name
@@ -74,7 +71,7 @@
 
 (define-type (<glil> #:printer print-glil)
   ;; Meta operations
-  (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
+  (<glil-program> nargs nrest nlocs meta body)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)
@@ -83,8 +80,7 @@
   (<glil-void>)
   (<glil-const> obj)
   ;; Variables
-  (<glil-local> op index)
+  (<glil-lexical> local? boxed? op index)
-  (<glil-external> op depth index)
   (<glil-toplevel> op name)
   (<glil-module> op mod name public?)
   ;; Controls
@@ -93,35 +89,19 @@
   (<glil-call> inst nargs)
   (<glil-mv-call> nargs ra))
 
-(define (compute-closure-level body)
-  (fold (lambda (x ret)
-          (record-case x
-            ((<glil-program> closure-level) (max ret closure-level))
-            ((<glil-external> depth) (max ret depth))
-            (else ret)))
-        0 body))
-
-(define %make-glil-program make-glil-program)
-(define (make-glil-program . args)
-  (let ((prog (apply %make-glil-program args)))
-    (if (not (glil-program-closure-level prog))
-        (set! (glil-program-closure-level prog)
-              (compute-closure-level (glil-program-body prog))))
-    prog))
-
 
+
 (define (parse-glil x)
   (pmatch x
-    ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
+    ((program ,nargs ,nrest ,nlocs ,meta . ,body)
-     (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+     (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
     ((bind . ,vars) (make-glil-bind vars))
     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
     ((unbind) (make-glil-unbind))
     ((source ,props) (make-glil-source props))
     ((void) (make-glil-void))
     ((const ,obj) (make-glil-const obj))
-    ((local ,op ,index) (make-glil-local op index))
+    ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
-    ((external ,op ,depth ,index) (make-glil-external op depth index))
     ((toplevel ,op ,name) (make-glil-toplevel op name))
     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
@@ -134,8 +114,8 @@
 (define (unparse-glil glil)
   (record-case glil
     ;; meta
-    ((<glil-program> nargs nrest nlocs nexts meta body)
+    ((<glil-program> nargs nrest nlocs meta body)
-     `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+     `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
     ((<glil-bind> vars) `(bind ,@vars))
     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
     ((<glil-unbind>) `(unbind))
@@ -144,10 +124,8 @@
     ((<glil-void>) `(void))
     ((<glil-const> obj) `(const ,obj))
     ;; variables
-    ((<glil-local> op index)
+    ((<glil-lexical> local? boxed? op index)
-     `(local ,op ,index))
+     `(lexical ,local? ,boxed? ,op ,index))
-    ((<glil-external> op depth index)
-     `(external ,op ,depth ,index))
     ((<glil-toplevel> op name)
      `(toplevel ,op ,name))
     ((<glil-module> op mod name public?)

module/language/glil/compile-assembly.scm

@@ -72,14 +72,14 @@
   (if (and (null? bindings) (null? sources) (null? tail))
       #f
       (compile-assembly
-       (make-glil-program 0 0 0 0 '()
+       (make-glil-program 0 0 0 '()
                           (list
                            (make-glil-const `(,bindings ,sources ,@tail))
                            (make-glil-call 'return 1))))))
 
 ;; A functional stack of names of live variables.
-(define (make-open-binding name ext? index)
+(define (make-open-binding name boxed? index)
-  (list name ext? index))
+  (list name boxed? index))
 (define (make-closed-binding open-binding start end)
   (make-binding (car open-binding) (cadr open-binding)
                 (caddr open-binding) start end))
@@ -89,8 +89,8 @@
           (map
            (lambda (v)
              (pmatch v
-               ((,name local ,i) (make-open-binding name #f i))
+               ((,name ,boxed? ,i)
-               ((,name external ,i) (make-open-binding name #t i))
+                (make-open-binding name boxed? i))
                (else (error "unknown binding type" v))))
            vars)
           (car bindings))
@@ -128,74 +128,77 @@
 
 (define (compile-assembly glil)
   (receive (code . _)
-      (glil->assembly glil '() '(()) '() '() #f -1)
+      (glil->assembly glil #t '(()) '() '() #f -1)
     (car code)))
 (define (make-object-table objects)
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
-(define (glil->assembly glil nexts-stack bindings
+(define (glil->assembly glil toplevel? bindings
                         source-alist label-alist object-alist addr)
   (define (emit-code x)
-    (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+    (values x bindings source-alist label-alist object-alist))
   (define (emit-code/object x object-alist)
-    (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+    (values x bindings source-alist label-alist object-alist))
 
   (record-case glil
-    ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
+    ((<glil-program> nargs nrest nlocs meta body)
-     (let ((toplevel? (null? nexts-stack)))
+     (define (process-body)
-       (define (process-body)
+       (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
-         (let ((nexts-stack (cons nexts nexts-stack)))
+                (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
-           (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+         (cond
-                    (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+          ((null? body)
-             (cond
+           (values (reverse code)
-              ((null? body)
+                   (close-all-bindings bindings addr)
-               (values (reverse code)
+                   (limn-sources (reverse! source-alist))
-                       (close-all-bindings bindings addr)
+                   (reverse label-alist)
-                       (limn-sources (reverse! source-alist))
+                   (and object-alist (map car (reverse object-alist)))
-                       (reverse label-alist)
+                   addr))
-                       (and object-alist (map car (reverse object-alist)))
+          (else
-                       addr))
+           (receive (subcode bindings source-alist label-alist object-alist)
-              (else
+               (glil->assembly (car body) #f bindings
-               (receive (subcode bindings source-alist label-alist object-alist)
+                               source-alist label-alist object-alist addr)
-                   (glil->assembly (car body) nexts-stack bindings
+             (lp (cdr body) (append (reverse subcode) code)
-                                   source-alist label-alist object-alist addr)
+                 bindings source-alist label-alist object-alist
-                 (lp (cdr body) (append (reverse subcode) code)
+                 (addr+ addr subcode)))))))
-                     bindings source-alist label-alist object-alist
-                     (addr+ addr subcode))))))))
 
-       (receive (code bindings sources labels objects len)
+     (receive (code bindings sources labels objects len)
-           (process-body)
+         (process-body)
-         (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
+       (let* ((meta (make-meta bindings sources meta))
-                                    ,len
+              (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
-                                    ,(make-meta bindings sources meta)
+              (prog `(load-program ,nargs ,nrest ,nlocs ,labels
-                                    . ,code)))
+                                  ,(+ len meta-pad)
-           (cond
+                                  ,meta
-            (toplevel?
+                                  ,@code
-             ;; toplevel bytecode isn't loaded by the vm, no way to do
+                                  ,@(if meta
-             ;; object table or closure capture (not in the bytecode,
+                                        (make-list meta-pad '(nop))
-             ;; anyway)
+                                        '()))))
-             (emit-code (align-program prog addr)))
+         (cond
-            (else
+          (toplevel?
-             (let ((table (dump-object (make-object-table objects) addr))
+           ;; toplevel bytecode isn't loaded by the vm, no way to do
-                   (closure (if (> closure-level 0) '((make-closure)) '())))
+           ;; object table or closure capture (not in the bytecode,
-               (cond
+           ;; anyway)
-                (object-alist
+           (emit-code (align-program prog addr)))
-                 ;; if we are being compiled from something with an object
+          (else
-                 ;; table, cache the program there
+           (let ((table (make-object-table objects)))
-                 (receive (i object-alist)
+             (cond
-                     (object-index-and-alist (make-subprogram table prog)
+              (object-alist
-                                             object-alist)
+               ;; if we are being compiled from something with an object
-                   (emit-code/object `(,(if (< i 256)
+               ;; table, cache the program there
-                                            `(object-ref ,i)
+               (receive (i object-alist)
-                                            `(long-object-ref ,(quotient i 256)
+                   (object-index-and-alist (make-subprogram table prog)
-                                                              ,(modulo i 256)))
+                                           object-alist)
-                                       ,@closure)
+                 (emit-code/object `(,(if (< i 256)
-                                     object-alist)))
+                                          `(object-ref ,i)
-                (else
+                                          `(long-object-ref ,(quotient i 256)
-                 ;; otherwise emit a load directly
+                                                            ,(modulo i 256))))
-                 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
+                                   object-alist)))
-                                      ,@closure)))))))))))
+              (else
+               ;; otherwise emit a load directly
+               (let ((table-code (dump-object table addr)))
+                 (emit-code
+                  `(,@table-code
+                    ,@(align-program prog (addr+ addr table-code)))))))))))))
     
     ((<glil-bind> vars)
      (values '()
@@ -244,19 +247,45 @@
                                                   ,(modulo i 256))))
                            object-alist)))))
 
-    ((<glil-local> op index)
+    ((<glil-lexical> local? boxed? op index)
-     (emit-code (if (eq? op 'ref)
+     (emit-code
-                    `((local-ref ,index))
+      (if local?
-                    `((local-set ,index)))))
+          (if (< index 256)
-
+              `((,(case op
-    ((<glil-external> op depth index)
+                    ((ref) (if boxed? 'local-boxed-ref 'local-ref))
-     (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
+                    ((set) (if boxed? 'local-boxed-set 'local-set))
-                  (if (> d 0)
+                    ((box) 'box)
-                      (lp (1- d) (+ n (car stack)) (cdr stack))
+                    ((empty-box) 'empty-box)
-                      (if (eq? op 'ref)
+                    (else (error "what" op)))
-                          `((external-ref ,(+ n index)))
+                 ,index))
-                          `((external-set ,(+ n index))))))))
+              (let ((a (quotient i 256))
-
+                    (b (modulo i 256)))
+               `((,(case op
+                     ((ref)
+                      (if boxed?
+                          `((long-local-ref ,a ,b)
+                            (variable-ref))
+                          `((long-local-ref ,a ,b))))
+                     ((set)
+                      (if boxed?
+                          `((long-local-ref ,a ,b)
+                            (variable-set))
+                          `((long-local-set ,a ,b))))
+                     ((box)
+                      `((make-variable)
+                        (variable-set)
+                        (long-local-set ,a ,b)))
+                     ((empty-box)
+                      `((make-variable)
+                        (long-local-set ,a ,b)))
+                     (else (error "what" op)))
+                  ,index))))
+          `((,(case op
+                ((ref) (if boxed? 'free-boxed-ref 'free-ref))
+                ((set) (if boxed? 'free-boxed-set (error "what." glil)))
+                (else (error "what" op)))
+             ,index)))))
+    
     ((<glil-toplevel> op name)
      (case op
        ((ref set)
@@ -311,11 +340,12 @@
           (error "unknown module var kind" op key)))))
 
     ((<glil-label> label)
-     (values '()
+     (let ((code (align-block addr)))
-             bindings
+       (values code
-             source-alist
+               bindings
-             (acons label addr label-alist)
+               source-alist
-             object-alist))
+               (acons label (addr+ addr code) label-alist)
+               object-alist)))
 
     ((<glil-branch> inst label)
      (emit-code `((,inst ,label))))
@@ -348,9 +378,10 @@
    ((object->assembly x) => list)
    ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
    ((subprogram? x)
-    `(,@(subprogram-table x)
+    (let ((table-code (dump-object (subprogram-table x) addr)))
-      ,@(align-program (subprogram-prog x)
+      `(,@table-code
-                       (addr+ addr (subprogram-table x)))))
+        ,@(align-program (subprogram-prog x)
+                         (addr+ addr table-code)))))
    ((number? x)
     `((load-number ,(number->string x))))
    ((string? x)

module/language/glil/decompile-assembly.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,8 +31,8 @@
 
 (define (decompile-toplevel x)
   (pmatch x
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
-     (decompile-load-program nargs nrest nlocs nexts
+     (decompile-load-program nargs nrest nlocs
                              (decompile-meta meta)
                              body labels #f))
     (else
@@ -56,7 +56,7 @@
           ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
           (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
 
-(define (decompile-load-program nargs nrest nlocs nexts meta body labels
+(define (decompile-load-program nargs nrest nlocs meta body labels
                                 objects)
   (let ((glil-labels (sort (map (lambda (x)
                                   (cons (cdr x) (make-glil-label (car x))))
@@ -100,19 +100,11 @@
       (cond
        ((null? in)
         (or (null? stack) (error "leftover stack insts" stack body))
-        (make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
+        (make-glil-program nargs nrest nlocs props (reverse out) #f))
        ((pop-bindings! pos)
         => (lambda (bindings)
              (lp in stack
-                 (cons (make-glil-bind
+                 (cons (make-glil-bind bindings)
-                        (map (lambda (x)
-                               (let ((name (binding:name x))
-                                     (i (binding:index x)))
-                                 (cond
-                                  ((binding:extp x) `(,name external ,i))
-                                  ((< i nargs) `(,name argument ,i))
-                                  (else `(,name local ,(- i nargs))))))
-                             bindings))
                        out)
                  pos)))
        ((pop-unbindings! pos)

module/language/objcode/spec.scm

@@ -1,6 +1,6 @@
 ;;; Guile Lowlevel Intermediate Language
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,7 +31,7 @@
   (if env (car env) (current-module)))
 
 (define (objcode-env-externals env)
-  (if env (cdr env) '()))
+  (and env (vector? (cdr env)) (cdr env)))
 
 (define (objcode->value x e opts)
   (let ((thunk (make-program x #f (objcode-env-externals e))))
@@ -66,23 +66,16 @@
    ((program? x)
     (let ((objs  (program-objects x))
           (meta  (program-meta x))
-          (exts  (program-external x))
+          (free-vars  (program-free-variables x))
           (binds (program-bindings x))
           (srcs  (program-sources x))
           (nargs (arity:nargs (program-arity x))))
-      (let ((blocs (and binds
+      (let ((blocs (and binds (collapse-locals binds))))
-                        (collapse-locals
-                         (append (list-head binds nargs)
-                                 (filter (lambda (x) (not (binding:extp x)))
-                                         (list-tail binds nargs))))))
-            (bexts (and binds
-                        (filter binding:extp binds))))
         (values (program-objcode x)
                 `((objects . ,objs)
                   (meta    . ,(and meta (meta)))
-                  (exts    . ,exts)
+                  (free-vars . ,free-vars)
                   (blocs   . ,blocs)
-                  (bexts   . ,bexts)
                   (sources . ,srcs))))))
    ((objcode? x)
     (values x #f))

module/language/tree-il.scm

@@ -17,6 +17,7 @@
 
 
 (define-module (language tree-il)
+  #:use-module (srfi srfi-1)
   #:use-module (system base pmatch)
   #:use-module (system base syntax)
   #:export (tree-il-src
@@ -38,11 +39,12 @@
             <let> let? make-let let-src let-names let-vars let-vals let-body
             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
             <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
-            
+
             parse-tree-il
             unparse-tree-il
             tree-il->scheme
 
+            tree-il-fold
             post-order!
             pre-order!))
 
@@ -258,6 +260,51 @@
      `(call-with-values (lambda () ,(tree-il->scheme exp))
         (lambda ,vars ,(tree-il->scheme body))))))
 
+
+(define (tree-il-fold leaf down up seed tree)
+  "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
+into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
+invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
+and SEED is the current result, intially seeded with SEED.
+
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+  (let loop ((tree   tree)
+             (result seed))
+    (if (or (null? tree) (pair? tree))
+        (fold loop result tree)
+        (record-case tree
+          ((<lexical-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<module-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<toplevel-set> exp)
+           (up tree (loop exp (down tree result))))
+          ((<toplevel-define> exp)
+           (up tree (loop exp (down tree result))))
+          ((<conditional> test then else)
+           (up tree (loop else
+                          (loop then
+                                (loop test (down tree result))))))
+          ((<application> proc args)
+           (up tree (loop (cons proc args) (down tree result))))
+          ((<sequence> exps)
+           (up tree (loop exps (down tree result))))
+          ((<lambda> body)
+           (up tree (loop body (down tree result))))
+          ((<let> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<letrec> vals body)
+           (up tree (loop body
+                          (loop vals
+                                (down tree result)))))
+          ((<let-values> body)
+           (up tree (loop body (down tree result))))
+          (else
+           (leaf tree result))))))
+
 (define (post-order! f x)
   (let lp ((x x))
     (record-case x

module/language/tree-il/analyze.scm

@@ -19,14 +19,40 @@
 ;;; Code:
 
 (define-module (language tree-il analyze)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (system base syntax)
+  #:use-module (system base message)
   #:use-module (language tree-il)
-  #:export (analyze-lexicals))
+  #:export (analyze-lexicals
+            report-unused-variables))
 
-;; allocation: the process of assigning a type and index to each var
+;; Allocation is the process of assigning storage locations for lexical
-;; a var is external if it is heaps; assigning index is easy
+;; variables. A lexical variable has a distinct "address", or storage
-;; args are assigned in order
+;; location, for each procedure in which it is referenced.
-;; locals are indexed as their linear position in the binding path
+;;
+;; A variable is "local", i.e., allocated on the stack, if it is
+;; referenced from within the procedure that defined it. Otherwise it is
+;; a "closure" variable. For example:
+;;
+;;    (lambda (a) a) ; a will be local
+;; `a' is local to the procedure.
+;;
+;;    (lambda (a) (lambda () a))
+;; `a' is local to the outer procedure, but a closure variable with
+;; respect to the inner procedure.
+;;
+;; If a variable is ever assigned, it needs to be heap-allocated
+;; ("boxed"). This is so that closures and continuations capture the
+;; variable's identity, not just one of the values it may have over the
+;; course of program execution. If the variable is never assigned, there
+;; is no distinction between value and identity, so closing over its
+;; identity (whether through closures or continuations) can make a copy
+;; of its value instead.
+;;
+;; Local variables are stored on the stack within a procedure's call
+;; frame. Their index into the stack is determined from their linear
+;; postion within a procedure's binding path:
 ;; (let (0 1)
 ;;   (let (2 3) ...)
 ;;   (let (2) ...))
@@ -48,49 +74,67 @@
 ;; case. A proper solution would be some sort of liveness analysis, and
 ;; not our linear allocation algorithm.
 ;;
-;; allocation:
+;; Closure variables are captured when a closure is created, and stored
-;;  sym -> (local . index) | (heap level . index)
+;; in a vector. Each closure variable has a unique index into that
-;;  lambda -> (nlocs . nexts)
+;; vector.
+;;
+;;
+;; The return value of `analyze-lexicals' is a hash table, the
+;; "allocation".
+;;
+;; The allocation maps gensyms -- recall that each lexically bound
+;; variable has a unique gensym -- to storage locations ("addresses").
+;; Since one gensym may have many storage locations, if it is referenced
+;; in many procedures, it is a two-level map.
+;;
+;; The allocation also stored information on how many local variables
+;; need to be allocated for each procedure, and information on what free
+;; variables to capture from its lexical parent procedure.
+;;
+;; That is:
+;;
+;;  sym -> {lambda -> address}
+;;  lambda -> (nlocs . free-locs)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define (make-hashq k v)
+  (let ((res (make-hash-table)))
+    (hashq-set! res k v)
+    res))
 
 (define (analyze-lexicals x)
-  ;; parents: lambda -> parent
+  ;; bound-vars: lambda -> (sym ...)
-  ;;  useful when we see a closed-over var, so we can calculate its
+  ;;  all identifiers bound within a lambda
-  ;;  coordinates (depth and index).
+  ;; free-vars: lambda -> (sym ...)
-  ;; bindings: lambda -> (sym ...)
+  ;;  all identifiers referenced in a lambda, but not bound
-  ;;  useful for two reasons: one, so we know how much space to allocate
+  ;;  NB, this includes identifiers referenced by contained lambdas
-  ;;  when we go into a lambda; and two, so that we know when to stop,
+  ;; assigned: sym -> #t
-  ;;  when looking for closed-over vars.
+  ;;  variables that are assigned
-  ;; heaps: sym -> lambda
-  ;;  allows us to heapify vars in an O(1) fashion
   ;; refcounts: sym -> count
-  ;;  allows us to detect the or-expansion an O(1) time
+  ;;  allows us to detect the or-expansion in O(1) time
-
+  
-  (define (find-heap sym parent)
+  ;; returns variables referenced in expr
-    ;; fixme: check displaced lexicals here?
+  (define (analyze! x proc)
-    (if (memq sym (hashq-ref bindings parent))
+    (define (step y) (analyze! y proc))
-        parent
+    (define (recur x new-proc) (analyze! x new-proc))
-        (find-heap sym (hashq-ref parents parent))))
-
-  (define (analyze! x parent level)
-    (define (step y) (analyze! y parent level))
-    (define (recur x parent) (analyze! x parent (1+ level)))
     (record-case x
       ((<application> proc args)
-       (step proc) (for-each step args))
+       (apply lset-union eq? (step proc) (map step args)))
 
       ((<conditional> test then else)
-       (step test) (step then) (step else))
+       (lset-union eq? (step test) (step then) (step else)))
 
       ((<lexical-ref> name gensym)
        (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
-       (if (and (not (memq gensym (hashq-ref bindings parent)))
+       (list gensym))
-                (not (hashq-ref heaps gensym)))
-           (hashq-set! heaps gensym (find-heap gensym parent))))
       
       ((<lexical-set> name gensym exp)
-       (step exp)
+       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
-       (if (not (hashq-ref heaps gensym))
+       (hashq-set! assigned gensym #t)
-           (hashq-set! heaps gensym (find-heap gensym parent))))
+       (lset-adjoin eq? (step exp) gensym))
       
       ((<module-set> mod name public? exp)
        (step exp))
@@ -102,157 +146,292 @@
        (step exp))
       
       ((<sequence> exps)
-       (for-each step exps))
+       (apply lset-union eq? (map step exps)))
       
       ((<lambda> vars meta body)
-       (hashq-set! parents x parent)
+       (let ((locally-bound (let rev* ((vars vars) (out '()))
-       (hashq-set! bindings x
+                              (cond ((null? vars) out)
-                   (let rev* ((vars vars) (out '()))
+                                    ((pair? vars) (rev* (cdr vars)
-                     (cond ((null? vars) out)
+                                                        (cons (car vars) out)))
-                           ((pair? vars) (rev* (cdr vars)
+                                    (else (cons vars out))))))
-                                               (cons (car vars) out)))
+         (hashq-set! bound-vars x locally-bound)
-                           (else (cons vars out)))))
+         (let* ((referenced (recur body x))
-       (recur body x)
+                (free (lset-difference eq? referenced locally-bound))
-       (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
+                (all-bound (reverse! (hashq-ref bound-vars x))))
-
+           (hashq-set! bound-vars x all-bound)
+           (hashq-set! free-vars x free)
+           free)))
+      
       ((<let> vars vals body)
-       (for-each step vals)
+       (hashq-set! bound-vars proc
-       (hashq-set! bindings parent
+                   (append (reverse vars) (hashq-ref bound-vars proc)))
-                   (append (reverse vars) (hashq-ref bindings parent)))
+       (lset-difference eq?
-       (step body))
+                        (apply lset-union eq? (step body) (map step vals))
+                        vars))
       
       ((<letrec> vars vals body)
-       (hashq-set! bindings parent
+       (hashq-set! bound-vars proc
-                   (append (reverse vars) (hashq-ref bindings parent)))
+                   (append (reverse vars) (hashq-ref bound-vars proc)))
-       (for-each step vals)
+       (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
-       (step body))
+       (lset-difference eq?
-
+                        (apply lset-union eq? (step body) (map step vals))
+                        vars))
+      
       ((<let-values> vars exp body)
-       (hashq-set! bindings parent
+       (hashq-set! bound-vars proc
-                   (let lp ((out (hashq-ref bindings parent)) (in vars))
+                   (let lp ((out (hashq-ref bound-vars proc)) (in vars))
                      (if (pair? in)
                          (lp (cons (car in) out) (cdr in))
                          (if (null? in) out (cons in out)))))
-       (step exp)
+       (lset-difference eq?
-       (step body))
+                        (lset-union eq? (step exp) (step body))
+                        vars))
+      
+      (else '())))
+  
+  (define (allocate! x proc n)
+    (define (recur y) (allocate! y proc n))
+    (record-case x
+      ((<application> proc args)
+       (apply max (recur proc) (map recur args)))
 
-      (else #f)))
+      ((<conditional> test then else)
+       (max (recur test) (recur then) (recur else)))
 
-    (define (allocate-heap! binder)
+      ((<lexical-set> name gensym exp)
-      (hashq-set! heap-indexes binder
+       (recur exp))
-                  (1+ (hashq-ref heap-indexes binder -1))))
+      
+      ((<module-set> mod name public? exp)
+       (recur exp))
+      
+      ((<toplevel-set> name exp)
+       (recur exp))
+      
+      ((<toplevel-define> name exp)
+       (recur exp))
+      
+      ((<sequence> exps)
+       (apply max (map recur exps)))
+      
+      ((<lambda> vars meta body)
+       ;; allocate closure vars in order
+       (let lp ((c (hashq-ref free-vars x)) (n 0))
+         (if (pair? c)
+             (begin
+               (hashq-set! (hashq-ref allocation (car c))
+                           x
+                           `(#f ,(hashq-ref assigned (car c)) . ,n))
+               (lp (cdr c) (1+ n)))))
+      
+       (let ((nlocs
+              (let lp ((vars vars) (n 0))
+                (if (not (null? vars))
+                    ;; allocate args
+                    (let ((v (if (pair? vars) (car vars) vars)))
+                      (hashq-set! allocation v
+                                  (make-hashq
+                                   x `(#t ,(hashq-ref assigned v) . ,n)))
+                      (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+                    ;; allocate body, return number of additional locals
+                    (- (allocate! body x n) n))))
+             (free-addresses
+              (map (lambda (v)
+                     (hashq-ref (hashq-ref allocation v) proc))
+                   (hashq-ref free-vars x))))
+         ;; set procedure allocations
+         (hashq-set! allocation x (cons nlocs free-addresses)))
+       n)
 
-    (define (allocate! x level n)
+      ((<let> vars vals body)
-      (define (recur y) (allocate! y level n))
+       (let ((nmax (apply max (map recur vals))))
-      (record-case x
+         (cond
-        ((<application> proc args)
+          ;; the `or' hack
-         (apply max (recur proc) (map recur args)))
+          ((and (conditional? body)
-
+                (= (length vars) 1)
-        ((<conditional> test then else)
+                (let ((v (car vars)))
-         (max (recur test) (recur then) (recur else)))
+                  (and (not (hashq-ref assigned v))
-
+                       (= (hashq-ref refcounts v 0) 2)
-        ((<lexical-set> name gensym exp)
+                       (lexical-ref? (conditional-test body))
-         (recur exp))
+                       (eq? (lexical-ref-gensym (conditional-test body)) v)
-        
+                       (lexical-ref? (conditional-then body))
-        ((<module-set> mod name public? exp)
+                       (eq? (lexical-ref-gensym (conditional-then body)) v))))
-         (recur exp))
+           (hashq-set! allocation (car vars)
-        
+                       (make-hashq proc `(#t #f . ,n)))
-        ((<toplevel-set> name exp)
+           ;; the 1+ for this var
-         (recur exp))
+           (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
-        
+          (else
-        ((<toplevel-define> name exp)
-         (recur exp))
-        
-        ((<sequence> exps)
-         (apply max (map recur exps)))
-        
-        ((<lambda> vars meta body)
-         (let lp ((vars vars) (n 0))
-           (if (null? vars)
-               (hashq-set! allocation x
-                           (let ((nlocs (- (allocate! body (1+ level) n) n)))
-                             (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
-               (let ((v (if (pair? vars) (car vars) vars)))
-                 (let ((binder (hashq-ref heaps v)))
-                   (hashq-set!
-                    allocation v
-                    (if binder
-                        (cons* 'heap (1+ level) (allocate-heap! binder))
-                        (cons 'stack n))))
-                 (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
-         n)
-
-        ((<let> vars vals body)
-         (let ((nmax (apply max (map recur vals))))
-           (cond
-            ;; the `or' hack
-            ((and (conditional? body)
-                  (= (length vars) 1)
-                  (let ((v (car vars)))
-                    (and (not (hashq-ref heaps v))
-                         (= (hashq-ref refcounts v 0) 2)
-                         (lexical-ref? (conditional-test body))
-                         (eq? (lexical-ref-gensym (conditional-test body)) v)
-                         (lexical-ref? (conditional-then body))
-                         (eq? (lexical-ref-gensym (conditional-then body)) v))))
-             (hashq-set! allocation (car vars) (cons 'stack n))
-             ;; the 1+ for this var
-             (max nmax (1+ n) (allocate! (conditional-else body) level n)))
-            (else
-             (let lp ((vars vars) (n n))
-               (if (null? vars)
-                   (max nmax (allocate! body level n))
-                   (let ((v (car vars)))
-                     (let ((binder (hashq-ref heaps v)))
-                       (hashq-set!
-                        allocation v
-                        (if binder
-                            (cons* 'heap level (allocate-heap! binder))
-                            (cons 'stack n)))
-                       (lp (cdr vars) (if binder n (1+ n)))))))))))
-        
-        ((<letrec> vars vals body)
-         (let lp ((vars vars) (n n))
-           (if (null? vars)
-               (let ((nmax (apply max
-                                  (map (lambda (x)
-                                         (allocate! x level n))
-                                       vals))))
-                 (max nmax (allocate! body level n)))
-               (let ((v (car vars)))
-                 (let ((binder (hashq-ref heaps v)))
-                   (hashq-set!
-                    allocation v
-                    (if binder
-                        (cons* 'heap level (allocate-heap! binder))
-                        (cons 'stack n)))
-                   (lp (cdr vars) (if binder n (1+ n))))))))
-
-        ((<let-values> vars exp body)
-         (let ((nmax (recur exp)))
            (let lp ((vars vars) (n n))
              (if (null? vars)
-                 (max nmax (allocate! body level n))
+                 (max nmax (allocate! body proc n))
-                 (let ((v (if (pair? vars) (car vars) vars)))
+                 (let ((v (car vars)))
-                   (let ((binder (hashq-ref heaps v)))
+                   (hashq-set!
-                     (hashq-set!
+                    allocation v
-                      allocation v
+                    (make-hashq proc
-                      (if binder
+                                `(#t ,(hashq-ref assigned v) . ,n)))
-                          (cons* 'heap level (allocate-heap! binder))
+                   (lp (cdr vars) (1+ n)))))))))
-                          (cons 'stack n)))
+      
-                     (lp (if (pair? vars) (cdr vars) '())
+      ((<letrec> vars vals body)
-                         (if binder n (1+ n)))))))))
+       (let lp ((vars vars) (n n))
-        
+         (if (null? vars)
-        (else n)))
+             (let ((nmax (apply max
+                                (map (lambda (x)
+                                       (allocate! x proc n))
+                                     vals))))
+               (max nmax (allocate! body proc n)))
+             (let ((v (car vars)))
+               (hashq-set!
+                allocation v
+                (make-hashq proc
+                            `(#t ,(hashq-ref assigned v) . ,n)))
+               (lp (cdr vars) (1+ n))))))
 
-  (define parents (make-hash-table))
+      ((<let-values> vars exp body)
-  (define bindings (make-hash-table))
+       (let ((nmax (recur exp)))
-  (define heaps (make-hash-table))
+         (let lp ((vars vars) (n n))
+           (if (null? vars)
+               (max nmax (allocate! body proc n))
+               (let ((v (if (pair? vars) (car vars) vars)))
+                 (let ((v (car vars)))
+                   (hashq-set!
+                    allocation v
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr vars) (1+ n))))))))
+      
+      (else n)))
+
+  (define bound-vars (make-hash-table))
+  (define free-vars (make-hash-table))
+  (define assigned (make-hash-table))
   (define refcounts (make-hash-table))
+  
   (define allocation (make-hash-table))
-  (define heap-indexes (make-hash-table))
+  
-
+  (analyze! x #f)
-  (analyze! x #f -1)
+  (allocate! x #f 0)
-  (allocate! x -1 0)
 
   allocation)
+
+
+;;;
+;;; Unused variable analysis.
+;;;
+
+;; <binding-info> records are used during tree traversals in
+;; `report-unused-variables'.  They contain a list of the local vars
+;; currently in scope, a list of locals vars that have been referenced, and a
+;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+(define-record-type <binding-info>
+  (make-binding-info vars refs locs)
+  binding-info?
+  (vars binding-info-vars)  ;; ((GENSYM NAME LOCATION) ...)
+  (refs binding-info-refs)  ;; (GENSYM ...)
+  (locs binding-info-locs)) ;; (LOCATION ...)
+
+(define (report-unused-variables tree)
+  "Report about unused variables in TREE.  Return TREE."
+
+  (define (dotless-list lst)
+    ;; If LST is a dotted list, return a proper list equal to LST except that
+    ;; the very last element is a pair; otherwise return LST.
+    (let loop ((lst    lst)
+               (result '()))
+      (cond ((null? lst)
+             (reverse result))
+            ((pair? lst)
+             (loop (cdr lst) (cons (car lst) result)))
+            (else
+             (loop '() (cons lst result))))))
+
+  (tree-il-fold (lambda (x info)
+                  ;; X is a leaf: extend INFO's refs accordingly.
+                  (let ((refs (binding-info-refs info))
+                        (vars (binding-info-vars info))
+                        (locs (binding-info-locs info)))
+                    (record-case x
+                      ((<lexical-ref> gensym)
+                       (make-binding-info vars (cons gensym refs) locs))
+                      (else info))))
+
+                (lambda (x info)
+                  ;; Going down into X: extend INFO's variable list
+                  ;; accordingly.
+                  (let ((refs (binding-info-refs info))
+                        (vars (binding-info-vars info))
+                        (locs (binding-info-locs info))
+                        (src  (tree-il-src x)))
+                    (define (extend inner-vars inner-names)
+                      (append (map (lambda (var name)
+                                     (list var name src))
+                                   inner-vars
+                                   inner-names)
+                              vars))
+                    (record-case x
+                      ((<lexical-set> gensym)
+                       (make-binding-info vars (cons gensym refs)
+                                          (cons src locs)))
+                      ((<lambda> vars names)
+                       (let ((vars  (dotless-list vars))
+                             (names (dotless-list names)))
+                         (make-binding-info (extend vars names) refs
+                                            (cons src locs))))
+                      ((<let> vars names)
+                       (make-binding-info (extend vars names) refs
+                                          (cons src locs)))
+                      ((<letrec> vars names)
+                       (make-binding-info (extend vars names) refs
+                                          (cons src locs)))
+                      ((<let-values> vars names)
+                       (make-binding-info (extend vars names) refs
+                                          (cons src locs)))
+                      (else info))))
+
+                (lambda (x info)
+                  ;; Leaving X's scope: shrink INFO's variable list
+                  ;; accordingly and reported unused nested variables.
+                  (let ((refs (binding-info-refs info))
+                        (vars (binding-info-vars info))
+                        (locs (binding-info-locs info)))
+                    (define (shrink inner-vars refs)
+                      (for-each (lambda (var)
+                                  (let ((gensym (car var)))
+                                    ;; Don't report lambda parameters as
+                                    ;; unused.
+                                    (if (and (not (memq gensym refs))
+                                             (not (and (lambda? x)
+                                                       (memq gensym
+                                                             inner-vars))))
+                                        (let ((name (cadr var))
+                                              ;; We can get approximate
+                                              ;; source location by going up
+                                              ;; the LOCS location stack.
+                                              (loc  (or (caddr var)
+                                                        (find pair? locs))))
+                                          (warning 'unused-variable loc name)))))
+                                (filter (lambda (var)
+                                          (memq (car var) inner-vars))
+                                        vars))
+                      (fold alist-delete vars inner-vars))
+
+                    ;; For simplicity, we leave REFS untouched, i.e., with
+                    ;; names of variables that are now going out of scope.
+                    ;; It doesn't hurt as these are unique names, it just
+                    ;; makes REFS unnecessarily fat.
+                    (record-case x
+                      ((<lambda> vars)
+                       (let ((vars (dotless-list vars)))
+                         (make-binding-info (shrink vars refs) refs
+                                            (cdr locs))))
+                      ((<let> vars)
+                       (make-binding-info (shrink vars refs) refs
+                                          (cdr locs)))
+                      ((<letrec> vars)
+                       (make-binding-info (shrink vars refs) refs
+                                          (cdr locs)))
+                      ((<let-values> vars)
+                       (make-binding-info (shrink vars refs) refs
+                                          (cdr locs)))
+                      (else info))))
+                (make-binding-info '() '() '())
+                tree)
+  tree)

module/language/tree-il/compile-glil.scm

@@ -20,6 +20,8 @@
 
 (define-module (language tree-il compile-glil)
   #:use-module (system base syntax)
+  #:use-module (system base pmatch)
+  #:use-module (system base message)
   #:use-module (ice-9 receive)
   #:use-module (language glil)
   #:use-module (system vm instruction)
@@ -34,18 +36,37 @@
 ;; basic degenerate-case reduction
 
 ;; allocation:
-;;  sym -> (local . index) | (heap level . index)
+;;  sym -> {lambda -> address}
-;;  lambda -> (nlocs . nexts)
+;;  lambda -> (nlocs . closure-vars)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
 
 (define *comp-module* (make-fluid))
 
+(define %warning-passes
+  `((unused-variable . ,report-unused-variables)))
+
 (define (compile-glil x e opts)
+  (define warnings
+    (or (and=> (memq #:warnings opts) cadr)
+        '()))
+
   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
          (x (optimize! x e opts))
          (allocation (analyze-lexicals x)))
+
+    ;; Go throught the warning passes.
+    (for-each (lambda (kind)
+                (let ((warn (assoc-ref %warning-passes kind)))
+                  (and (procedure? warn)
+                       (warn x))))
+              warnings)
+
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()
-        (values (flatten-lambda x -1 allocation)
+        (values (flatten-lambda x allocation)
                 (and e (cons (car e) (cddr e)))
                 e)))))
 
@@ -131,20 +152,19 @@
 
 (define (make-label) (gensym ":L"))
 
-(define (vars->bind-list ids vars allocation)
+(define (vars->bind-list ids vars allocation proc)
   (map (lambda (id v)
-         (let ((loc (hashq-ref allocation v)))
+         (pmatch (hashq-ref (hashq-ref allocation v) proc)
-           (case (car loc)
+           ((#t ,boxed? . ,n)
-             ((stack) (list id 'local (cdr loc)))
+            (list id boxed? n))
-             ((heap)  (list id 'external (cddr loc)))
+           (,x (error "badness" x))))
-             (else (error "badness" id v loc)))))
        ids
        vars))
 
-(define (emit-bindings src ids vars allocation emit-code)
+(define (emit-bindings src ids vars allocation proc emit-code)
   (if (pair? vars)
       (emit-code src (make-glil-bind
-                      (vars->bind-list ids vars allocation)))))
+                      (vars->bind-list ids vars allocation proc)))))
 
 (define (with-output-to-code proc)
   (let ((out '()))
@@ -155,7 +175,7 @@
     (proc emit-code)
     (reverse out)))
 
-(define (flatten-lambda x level allocation)
+(define (flatten-lambda x allocation)
   (receive (ids vars nargs nrest)
       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
                (oids '()) (ovars '()) (n 0))
@@ -166,31 +186,27 @@
                 (else (values (reverse (cons ids oids))
                               (reverse (cons vars ovars))
                               (1+ n) 1))))
-    (let ((nlocs (car (hashq-ref allocation x)))
+    (let ((nlocs (car (hashq-ref allocation x))))
-          (nexts (cdr (hashq-ref allocation x))))
       (make-glil-program
-       nargs nrest nlocs nexts (lambda-meta x)
+       nargs nrest nlocs (lambda-meta x)
        (with-output-to-code
         (lambda (emit-code)
           ;; write bindings and source debugging info
-          (emit-bindings #f ids vars allocation emit-code)
+          (emit-bindings #f ids vars allocation x emit-code)
           (if (lambda-src x)
               (emit-code #f (make-glil-source (lambda-src x))))
-
+          ;; box args if necessary
-          ;; copy args to the heap if necessary
+          (for-each
-          (let lp ((in vars) (n 0))
+           (lambda (v)
-            (if (not (null? in))
+             (pmatch (hashq-ref (hashq-ref allocation v) x)
-                (let ((loc (hashq-ref allocation (car in))))
+               ((#t #t . ,n)
-                  (case (car loc)
+                (emit-code #f (make-glil-lexical #t #f 'ref n))
-                    ((heap)
+                (emit-code #f (make-glil-lexical #t #t 'box n)))))
-                     (emit-code #f (make-glil-local 'ref n))
+           vars)
-                     (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
-                  (lp (cdr in) (1+ n)))))
-
           ;; and here, here, dear reader: we compile.
-          (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+          (flatten (lambda-body x) allocation x emit-code)))))))
 
-(define (flatten x level allocation emit-code)
+(define (flatten x allocation proc emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
@@ -424,27 +440,21 @@
       ((<lexical-ref> src name gensym)
        (case context
          ((push vals tail)
-          (let ((loc (hashq-ref allocation gensym)))
+          (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
-            (case (car loc)
+            ((,local? ,boxed? . ,index)
-              ((stack)
+             (emit-code src (make-glil-lexical local? boxed? 'ref index)))
-               (emit-code src (make-glil-local 'ref (cdr loc))))
+            (,loc
-              ((heap)
+             (error "badness" x loc)))))
-               (emit-code src (make-glil-external
+       (case context
-                               'ref (- level (cadr loc)) (cddr loc))))
+         ((tail) (emit-code #f (make-glil-call 'return 1)))))
-              (else (error "badness" x loc)))
+      
-            (if (eq? context 'tail)
-                (emit-code #f (make-glil-call 'return 1)))))))
-
       ((<lexical-set> src name gensym exp)
        (comp-push exp)
-       (let ((loc (hashq-ref allocation gensym)))
+       (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
-         (case (car loc)
+         ((,local? ,boxed? . ,index)
-           ((stack)
+          (emit-code src (make-glil-lexical local? boxed? 'set index)))
-            (emit-code src (make-glil-local 'set (cdr loc))))
+         (,loc
-           ((heap)
+          (error "badness" x loc)))
-            (emit-code src (make-glil-external
-                            'set (- level (cadr loc)) (cddr loc))))
-           (else (error "badness" x loc))))
        (case context
          ((push vals)
           (emit-code #f (make-glil-void)))
@@ -495,39 +505,52 @@
           (emit-code #f (make-glil-call 'return 1)))))
 
       ((<lambda>)
-       (case context
+       (let ((free-locs (cdr (hashq-ref allocation x))))
-         ((push vals)
+         (case context
-          (emit-code #f (flatten-lambda x level allocation)))
+           ((push vals tail)
-         ((tail)
+            (emit-code #f (flatten-lambda x allocation))
-          (emit-code #f (flatten-lambda x level allocation))
+            (if (not (null? free-locs))
-          (emit-code #f (make-glil-call 'return 1)))))
+                (begin
-
+                  (for-each
+                   (lambda (loc)
+                     (pmatch loc
+                       ((,local? ,boxed? . ,n)
+                        (emit-code #f (make-glil-lexical local? #f 'ref n)))
+                       (else (error "what" x loc))))
+                   free-locs)
+                  (emit-code #f (make-glil-call 'vector (length free-locs)))
+                  (emit-code #f (make-glil-call 'make-closure 2))))
+            (if (eq? context 'tail)
+                (emit-code #f (make-glil-call 'return 1)))))))
+      
       ((<let> src names vars vals body)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation emit-code)
+       (emit-bindings src names vars allocation proc emit-code)
        (for-each (lambda (v)
-                   (let ((loc (hashq-ref allocation v)))
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
-                     (case (car loc)
+                     ((#t #f . ,n)
-                       ((stack)
+                      (emit-code src (make-glil-lexical #t #f 'set n)))
-                        (emit-code src (make-glil-local 'set (cdr loc))))
+                     ((#t #t . ,n)
-                       ((heap)
+                      (emit-code src (make-glil-lexical #t #t 'box n)))
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
+                     (,loc (error "badness" x loc))))
-                       (else (error "badness" x loc)))))
                  (reverse vars))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src names vars vals body)
-       (for-each comp-push vals)
-       (emit-bindings src names vars allocation emit-code)
        (for-each (lambda (v)
-                   (let ((loc (hashq-ref allocation v)))
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
-                     (case (car loc)
+                     ((#t #t . ,n)
-                       ((stack)
+                      (emit-code src (make-glil-lexical #t #t 'empty-box n)))
-                        (emit-code src (make-glil-local 'set (cdr loc))))
+                     (,loc (error "badness" x loc))))
-                       ((heap)
+                 vars)
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
+       (for-each comp-push vals)
-                       (else (error "badness" x loc)))))
+       (emit-bindings src names vars allocation proc emit-code)
+       (for-each (lambda (v)
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'set n)))
+                     (,loc (error "badness" x loc))))
                  (reverse vars))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
@@ -548,16 +571,15 @@
              (emit-code #f (make-glil-const 1))
              (emit-label MV)
              (emit-code src (make-glil-mv-bind
-                             (vars->bind-list names vars allocation)
+                             (vars->bind-list names vars allocation proc)
                              rest?))
              (for-each (lambda (v)
-                         (let ((loc (hashq-ref allocation v)))
+                         (pmatch (hashq-ref (hashq-ref allocation v) proc)
-                           (case (car loc)
+                           ((#t #f . ,n)
-                             ((stack)
+                            (emit-code src (make-glil-lexical #t #f 'set n)))
-                              (emit-code src (make-glil-local 'set (cdr loc))))
+                           ((#t #t . ,n)
-                             ((heap)
+                            (emit-code src (make-glil-lexical #t #t 'box n)))
-                              (emit-code src (make-glil-external 'set 0 (cddr loc))))
+                           (,loc (error "badness" x loc))))
-                             (else (error "badness" x loc)))))
                        (reverse vars))
              (comp-tail body)
              (emit-code #f (make-glil-unbind))))))))))

module/scripts/compile.scm

@@ -30,9 +30,11 @@
 
 (define-module (scripts compile)
   #:use-module ((system base compile) #:select (compile-file))
+  #:use-module (system base message)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-13)
   #:use-module (srfi srfi-37)
+  #:use-module (ice-9 format)
   #:export (compile))
 
 
@@ -58,6 +60,17 @@
 		      (fail "`-o' option cannot be specified more than once")
 		      (alist-cons 'output-file arg result))))
 
+        (option '(#\W "warn") #t #f
+                (lambda (opt name arg result)
+                  (if (string=? arg "help")
+                      (begin
+                        (show-warning-help)
+                        (exit 0))
+                      (let ((warnings (assoc-ref result 'warnings)))
+                        (alist-cons 'warnings
+                                    (cons (string->symbol arg) warnings)
+                                    (alist-delete 'warnings result))))))
+
 	(option '(#\O "optimize") #f #f
 		(lambda (opt name arg result)
 		  (alist-cons 'optimize? #t result)))
@@ -86,13 +99,27 @@ options."
 
 	     ;; default option values
              '((input-files)
-	       (load-path))))
+	       (load-path)
+               (warnings unsupported-warning))))
+
+(define (show-warning-help)
+  (format #t "The available warning types are:~%~%")
+  (for-each (lambda (wt)
+              (format #t "  ~22A ~A~%"
+                      (format #f "`~A'" (warning-type-name wt))
+                      (warning-type-description wt)))
+            %warning-types)
+  (format #t "~%"))
 
 
 (define (compile . args)
   (let* ((options         (parse-args args))
          (help?           (assoc-ref options 'help?))
-         (compile-opts    (if (assoc-ref options 'optimize?) '(#:O) '()))
+         (compile-opts    (let ((o `(#:warnings
+                                     ,(assoc-ref options 'warnings))))
+                            (if (assoc-ref options 'optimize?)
+                                (cons #:O o)
+                                o)))
          (from            (or (assoc-ref options 'from) 'scheme))
          (to              (or (assoc-ref options 'to) 'objcode))
 	 (input-files     (assoc-ref options 'input-files))
@@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object.
   -L, --load-path=DIR  add DIR to the front of the module load path
   -o, --output=OFILE   write output to OFILE
 
+  -W, --warn=WARNING   emit warnings of type WARNING; use `--warn=help'
+                       for a list of available warnings
+
   -f, --from=LANG      specify a source language other than `scheme'
   -t, --to=LANG        specify a target language other than `objcode'
 

module/system/base/compile.scm

@@ -21,6 +21,7 @@
 (define-module (system base compile)
   #:use-module (system base syntax)
   #:use-module (system base language)
+  #:use-module (system base message)
   #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
   #:use-module (ice-9 regex)
   #:use-module (ice-9 optargs)
@@ -213,6 +214,16 @@
                   (from (current-language))
                   (to 'value)
                   (opts '()))
+
+  (let ((warnings (memq #:warnings opts)))
+    (if (pair? warnings)
+        (let ((warnings (cadr warnings)))
+          ;; Sanity-check the requested warnings.
+          (for-each (lambda (w)
+                      (or (lookup-warning-type w)
+                          (warning 'unsupported-warning #f w)))
+                    warnings))))
+
   (receive (exp env cenv)
       (compile-fold (compile-passes from to opts) x env opts)
     exp))

module/system/base/message.scm

@@ -0,0 +1,102 @@
+;;; User interface messages
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; This module provide a simple interface to send messages to the user.
+;;; TODO: Internationalize messages.
+;;;
+;;; Code:
+
+(define-module (system base message)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:export (*current-warning-port* warning
+
+            warning-type? warning-type-name warning-type-description
+            warning-type-printer lookup-warning-type
+
+            %warning-types))
+
+
+;;;
+;;; Source location
+;;;
+
+(define (location-string loc)
+  (if (pair? loc)
+      (format #f "~a:~a:~a"
+              (or (assoc-ref loc 'filename) "<stdin>")
+              (1+ (assoc-ref loc 'line))
+              (assoc-ref loc 'column))
+      "<unknown-location>"))
+
+
+;;;
+;;; Warnings
+;;;
+
+(define *current-warning-port*
+  ;; The port where warnings are sent.
+  (make-fluid))
+
+(fluid-set! *current-warning-port* (current-error-port))
+
+(define-record-type <warning-type>
+  (make-warning-type name description printer)
+  warning-type?
+  (name         warning-type-name)
+  (description  warning-type-description)
+  (printer      warning-type-printer))
+
+(define %warning-types
+  ;; List of know warning types.
+  (map (lambda (args)
+         (apply make-warning-type args))
+
+       `((unsupported-warning ;; a "meta warning"
+          "warn about unknown warning types"
+          ,(lambda (port unused name)
+             (format port "warning: unknown warning type `~A'~%"
+                     name)))
+
+         (unused-variable
+          "report unused variables"
+          ,(lambda (port loc name)
+             (format port "~A: warning: unused variable `~A'~%"
+                     loc name))))))
+
+(define (lookup-warning-type name)
+  "Return the warning type NAME or `#f' if not found."
+  (find (lambda (wt)
+          (eq? name (warning-type-name wt)))
+        %warning-types))
+
+(define (warning type location . args)
+  "Emit a warning of type TYPE for source location LOCATION (a source
+property alist) using the data in ARGS."
+  (let ((wt   (lookup-warning-type type))
+        (port (fluid-ref *current-warning-port*)))
+    (if (warning-type? wt)
+        (apply (warning-type-printer wt)
+               port (location-string location)
+               args)
+        (format port "~A: unknown warning type `~A': ~A~%"
+                (location-string location) type args))))
+
+;;; message.scm ends here

module/system/repl/command.scm

@@ -386,7 +386,6 @@ Trace execution.
 
   -s    Display stack
   -l    Display local variables
-  -e    Display external variables
   -b    Bytecode level trace"
   (apply vm-trace (repl-vm repl)
          (repl-compile repl (repl-parse repl form))

module/system/vm/frame.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 ;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -27,20 +27,20 @@
             vm-frame-program
             vm-frame-local-ref vm-frame-local-set!
             vm-frame-return-address vm-frame-mv-return-address
-            vm-frame-dynamic-link vm-frame-external-link
+            vm-frame-dynamic-link
             vm-frame-stack
 
 
             vm-frame-number vm-frame-address
-           make-frame-chain
+            make-frame-chain
-           print-frame print-frame-chain-as-backtrace
+            print-frame print-frame-chain-as-backtrace
-           frame-arguments frame-local-variables frame-external-variables
+            frame-arguments frame-local-variables
-           frame-environment
+            frame-environment
-           frame-variable-exists? frame-variable-ref frame-variable-set!
+            frame-variable-exists? frame-variable-ref frame-variable-set!
-           frame-object-name
+            frame-object-name
-           frame-local-ref frame-external-link frame-local-set!
+            frame-local-ref frame-local-set!
-           frame-return-address frame-program
+            frame-return-address frame-program
-           frame-dynamic-link heap-frame?))
+            frame-dynamic-link heap-frame?))
 
 (load-extension "libguile" "scm_init_frames")
 
@@ -158,24 +158,19 @@
 	 (l '() (cons (frame-local-ref frame n) l)))
 	((< n 0) l))))
 
-(define (frame-external-variables frame)
-  (frame-external-link frame))
-
-(define (frame-external-ref frame index)
-  (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
-  (list-set! (frame-external-link frame) index val))
-
 (define (frame-binding-ref frame binding)
-  (if (binding:extp binding)
+  (let ((x (frame-local-ref frame (binding:index binding))))
-    (frame-external-ref frame (binding:index binding))
+    (if (and (binding:boxed? binding) (variable? x))
-    (frame-local-ref frame (binding:index binding))))
+        (variable-ref x)
+        x)))
 
 (define (frame-binding-set! frame binding val)
-  (if (binding:extp binding)
+  (if (binding:boxed? binding)
-    (frame-external-set! frame (binding:index binding) val)
+      (let ((v (frame-local-ref frame binding)))
-    (frame-local-set! frame (binding:index binding) val)))
+        (if (variable? v)
+            (variable-set! v val)
+            (frame-local-set! frame binding (make-variable val))))
+      (frame-local-set! frame binding val)))
 
 ;; FIXME handle #f program-bindings return
 (define (frame-bindings frame addr)

module/system/vm/program.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM program functions
 
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -21,9 +21,9 @@
 (define-module (system vm program)
   #:export (make-program
 
-            arity:nargs arity:nrest arity:nlocs arity:nexts
+            arity:nargs arity:nrest arity:nlocs
 
-            make-binding binding:name binding:extp binding:index
+            make-binding binding:name binding:boxed? binding:index
             binding:start binding:end
 
             source:addr source:line source:column source:file
@@ -31,21 +31,20 @@
             program-properties program-property program-documentation
             program-name program-arguments
            
-            program-arity program-external-set! program-meta
+            program-arity program-meta
             program-objcode program? program-objects
-            program-module program-base program-external))
+            program-module program-base program-free-variables))
 
 (load-extension "libguile" "scm_init_programs")
 
 (define arity:nargs car)
 (define arity:nrest cadr)
 (define arity:nlocs caddr)
-(define arity:nexts cadddr)
 
-(define (make-binding name extp index start end)
+(define (make-binding name boxed? index start end)
-  (list name extp index start end))
+  (list name boxed? index start end))
 (define (binding:name b) (list-ref b 0))
-(define (binding:extp b) (list-ref b 1))
+(define (binding:boxed? b) (list-ref b 1))
 (define (binding:index b) (list-ref b 2))
 (define (binding:start b) (list-ref b 3))
 (define (binding:end b) (list-ref b 4))

module/system/vm/trace.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM tracer
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -54,8 +54,7 @@
       ((null? opts) (newline))
     (case (car opts)
       ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
-      ((:l) (puts (vm-fetch-locals vm)))
+      ((:l) (puts (vm-fetch-locals vm))))))
-      ((:e) (puts (vm-fetch-externals vm))))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

test-suite/tests/asm-to-bytecode.test

@@ -20,16 +20,28 @@
   #:use-module (system vm instruction)
   #:use-module (language assembly compile-bytecode))
 
+(define (->u8-list sym val)
+  (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
+                           (uint32 4 ,bytevector-u32-native-set!))
+                         sym)))
+    (or entry (error "unknown sym" sym))
+    (let ((bv (make-bytevector (car entry))))
+      ((cadr entry) bv 0 val)
+      (bytevector->u8-list bv))))
+
 (define (munge-bytecode v)
-  (let ((newv (make-u8vector (vector-length v))))
+  (let lp ((i 0) (out '()))
-    (let lp ((i 0))
+    (if (= i (vector-length v))
-      (if (= i (vector-length v))
+        (list->u8vector (reverse out))
-          newv
+        (let ((x (vector-ref v i)))
-          (let ((x (vector-ref v i)))
+          (cond
-            (u8vector-set! newv i (if (symbol? x)
+           ((symbol? x)
-                                      (instruction->opcode x)
+            (lp (1+ i) (cons (instruction->opcode x) out)))
-                                      x))
+           ((integer? x)
-            (lp (1+ i)))))))
+            (lp (1+ i) (cons x out)))
+           ((pair? x)
+            (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
+           (else (error "bad test bytecode" x)))))))
 
 (define (comp-test x y)
   (let* ((y (munge-bytecode y))
@@ -46,13 +58,6 @@
               (lambda ()
                 (equal? v y)))))
 
-(define (u32->u8-list x)
-  ;; Return a 4 uint8 list corresponding to the host's native representation
-  ;; of X, a uint32.
-  (let ((bv (make-bytevector 4)))
-    (bytevector-u32-native-set! bv 0 x)
-    (bytevector->u8-list bv)))
-
 
 (with-test-prefix "compiler"
   (with-test-prefix "asm-to-bytecode"
@@ -85,29 +90,34 @@
                (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
                        (char->integer #\x)))
 
-    (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
+    (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
-               (list->vector
+               #(load-program
-                `(load-program
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  3 2 1 0            ;; nargs, nrest, nlocs, nexts
+                 (uint32 3)     ;; len
-                  ,@(u32->u8-list 3) ;; len
+                 (uint32 0)     ;; metalen
-                  ,@(u32->u8-list 0) ;; metalen
+                 (uint32 0)     ;; padding
-                  make-int8 3
+                 make-int8 3
-                  return)))
+                 return))
 
-    (comp-test '(load-program 3 2 1 0 () 3
+    ;; the nops are to pad meta to an 8-byte alignment. not strictly
-                              (load-program 3 2 1 0 () 3
+    ;; necessary for this test, but representative of the common case.
+    (comp-test '(load-program 3 2 1 () 8
+                              (load-program 3 2 1 () 3
                                             #f
                                             (make-int8 3) (return))
-                              (make-int8 3) (return))
+                              (make-int8 3) (return)
-               (list->vector
+                              (nop) (nop) (nop) (nop) (nop))
-                `(load-program
+               #(load-program
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  ,@(u32->u8-list 3)        ;; len
+                 (uint32 8)     ;; len
-                  ,@(u32->u8-list (+ 3 12)) ;; metalen
+                 (uint32 19)    ;; metalen
-                  make-int8 3
+                 (uint32 0)     ;; padding
-                  return
+                 make-int8 3
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
+                 return
-                  ,@(u32->u8-list 3)        ;; len
+                 nop nop nop nop nop
-                  ,@(u32->u8-list 0)        ;; metalen
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  make-int8 3
+                 (uint32 3)     ;; len
-                  return)))))
+                 (uint32 0)     ;; metalen
+                 (uint32 0)     ;; padding
+                 make-int8 3
+                 return))))

test-suite/tests/tree-il.test

@@ -21,8 +21,10 @@
   #:use-module (test-suite lib)
   #:use-module (system base compile)
   #:use-module (system base pmatch)
+  #:use-module (system base message)
   #:use-module (language tree-il)
-  #:use-module (language glil))
+  #:use-module (language glil)
+  #:use-module (srfi srfi-13))
 
 ;; Of course, the GLIL that is emitted depends on the source info of the
 ;; input. Here we're not concerned about that, so we strip source
@@ -64,21 +66,21 @@
 (with-test-prefix "void"
   (assert-tree-il->glil
    (void)
-   (program 0 0 0 0 () (void) (call return 1)))
+   (program 0 0 0 () (void) (call return 1)))
   (assert-tree-il->glil
    (begin (void) (const 1))
-   (program 0 0 0 0 () (const 1) (call return 1)))
+   (program 0 0 0 () (const 1) (call return 1)))
   (assert-tree-il->glil
    (apply (primitive +) (void) (const 1))
-   (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+   (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
 
 (with-test-prefix "application"
   (assert-tree-il->glil
    (apply (toplevel foo) (const 1))
-   (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
+   (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
   (assert-tree-il->glil/pmatch
    (begin (apply (toplevel foo) (const 1)) (void))
-   (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+   (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2)
             (label ,l3) (mv-bind () #f) (unbind)
             (label ,l4)
@@ -86,26 +88,26 @@
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel bar)))
-   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+   (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
             (call goto/args 1))))
 
 (with-test-prefix "conditional"
   (assert-tree-il->glil/pmatch
    (if (const #t) (const 1) (const 2))
-   (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+   (program 0 0 0 () (const #t) (branch br-if-not ,l1)
             (const 1) (call return 1)
             (label ,l2) (const 2) (call return 1))
    (eq? l1 l2))
   
   (assert-tree-il->glil/pmatch
    (begin (if (const #t) (const 1) (const 2)) (const #f))
-   (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+   (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
             (label ,l3) (label ,l4) (const #f) (call return 1))
    (eq? l1 l3) (eq? l2 l4))
 
   (assert-tree-il->glil/pmatch
    (apply (primitive null?) (if (const #t) (const 1) (const 2)))
-   (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+   (program 0 0 0 () (const #t) (branch br-if-not ,l1)
             (const 1) (branch br ,l2)
                     (label ,l3) (const 2) (label ,l4)
                     (call null? 1) (call return 1))
@@ -114,279 +116,281 @@
 (with-test-prefix "primitive-ref"
   (assert-tree-il->glil
    (primitive +)
-   (program 0 0 0 0 () (toplevel ref +) (call return 1)))
+   (program 0 0 0 () (toplevel ref +) (call return 1)))
 
   (assert-tree-il->glil
    (begin (primitive +) (const #f))
-   (program 0 0 0 0 () (const #f) (call return 1)))
+   (program 0 0 0 () (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (primitive +))
-   (program 0 0 0 0 () (toplevel ref +) (call null? 1)
+   (program 0 0 0 () (toplevel ref +) (call null? 1)
             (call return 1))))
 
 (with-test-prefix "lexical refs"
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (lexical x y))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
-            (local ref 0) (call return 1)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (const #f) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
-            (local ref 0) (call null? 1) (call return 1)
+            (lexical #t #f ref 0) (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "lexical sets"
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
-   (program 0 0 0 1 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (external set 0 0) (void) (call return 1)
+            (const 2) (lexical #t #t set 0) (void) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
-   (program 0 0 0 1 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (external set 0 0) (const #f) (call return 1)
+            (const 2) (lexical #t #t set 0) (const #f) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
      (apply (primitive null?) (set! (lexical x y) (const 2))))
-   (program 0 0 0 1 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+            (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "module refs"
   (assert-tree-il->glil
    (@ (foo) bar)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module public ref (foo) bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (@ (foo) bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module public ref (foo) bar) (call drop 1)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (@ (foo) bar))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module public ref (foo) bar)
             (call null? 1) (call return 1)))
 
   (assert-tree-il->glil
    (@@ (foo) bar)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module private ref (foo) bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (@@ (foo) bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module private ref (foo) bar) (call drop 1)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (@@ (foo) bar))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module private ref (foo) bar)
             (call null? 1) (call return 1))))
 
 (with-test-prefix "module sets"
   (assert-tree-il->glil
    (set! (@ (foo) bar) (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module public set (foo) bar)
             (void) (call return 1)))
 
   (assert-tree-il->glil
    (begin (set! (@ (foo) bar) (const 2)) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module public set (foo) bar)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module public set (foo) bar)
             (void) (call null? 1) (call return 1)))
 
   (assert-tree-il->glil
    (set! (@@ (foo) bar) (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module private set (foo) bar)
             (void) (call return 1)))
 
   (assert-tree-il->glil
    (begin (set! (@@ (foo) bar) (const 2)) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module private set (foo) bar)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (module private set (foo) bar)
             (void) (call null? 1) (call return 1))))
 
 (with-test-prefix "toplevel refs"
   (assert-tree-il->glil
    (toplevel bar)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (toplevel bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref bar) (call drop 1)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (toplevel bar))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref bar)
             (call null? 1) (call return 1))))
 
 (with-test-prefix "toplevel sets"
   (assert-tree-il->glil
    (set! (toplevel bar) (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel set bar)
             (void) (call return 1)))
 
   (assert-tree-il->glil
    (begin (set! (toplevel bar) (const 2)) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel set bar)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (set! (toplevel bar) (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel set bar)
             (void) (call null? 1) (call return 1))))
 
 (with-test-prefix "toplevel defines"
   (assert-tree-il->glil
    (define bar (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel define bar)
             (void) (call return 1)))
 
   (assert-tree-il->glil
    (begin (define bar (const 2)) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel define bar)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (define bar (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel define bar)
             (void) (call null? 1) (call return 1))))
 
 (with-test-prefix "constants"
   (assert-tree-il->glil
    (const 2)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (call return 1)))
 
   (assert-tree-il->glil
    (begin (const 2) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (call null? 1) (call return 1))))
 
 (with-test-prefix "lambda"
   (assert-tree-il->glil
    (lambda (x) (y) () (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 1 0 0 0 ()
+            (program 1 0 0 ()
-                     (bind (x local 0))
+                     (bind (x #f 0))
                      (const 2) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x x1) (y y1) () (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 2 0 0 0 ()
+            (program 2 0 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
                      (const 2) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda x y () (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 1 1 0 0 ()
+            (program 1 1 0 ()
-                     (bind (x local 0))
+                     (bind (x #f 0))
                      (const 2) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
                      (const 2) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (lexical x y))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
-                     (local ref 0) (call return 1))
+                     (lexical #t #f ref 0) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x . x1) (y . y1) () (lexical x1 y1))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
-                     (bind (x local 0) (x1 local 1))
+                     (bind (x #f 0) (x1 #f 1))
-                     (local ref 1) (call return 1))
+                     (lexical #t #f ref 1) (call return 1))
             (call return 1)))
 
   (assert-tree-il->glil
    (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
-            (program 1 0 0 1 ()
+            (program 1 0 0 ()
-                     (bind (x external 0))
+                     (bind (x #f 0))
-                     (local ref 0) (external set 0 0)
+                     (program 1 0 0 ()
-                     (program 1 0 0 0 ()
+                              (bind (y #f 0))
-                              (bind (y local 0))
+                              (lexical #f #f ref 0) (call return 1))
-                              (external ref 1 0) (call return 1))
+                     (lexical #t #f ref 0)
+                     (call vector 1)
+                     (call make-closure 2)
                      (call return 1))
             (call return 1))))
 
 (with-test-prefix "sequence"
   (assert-tree-il->glil
    (begin (begin (const 2) (const #f)) (const #t))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const #t) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (begin (const #f) (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (call null? 1) (call return 1))))
 
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
@@ -398,13 +402,13 @@
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical a b))))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
-            (local ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 0)) (local set 0)
+            (const 2) (bind (a #f 0)) (lexical #t #f set 0)
-            (local ref 0) (call return 1)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)
             (unbind))
    (eq? l1 l2))
@@ -415,13 +419,13 @@
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical x y))))
-   (program 0 0 2 0 ()
+   (program 0 0 2 ()
-            (const 1) (bind (x local 0)) (local set 0)
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
-            (local ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 1)) (local set 1)
+            (const 2) (bind (a #f 1)) (lexical #t #f set 1)
-            (local ref 0) (call return 1)
+            (lexical #t #f ref 0) (call return 1)
             (unbind)
             (unbind))
    (eq? l1 l2)))
@@ -429,10 +433,10 @@
 (with-test-prefix "apply"
   (assert-tree-il->glil
    (apply (primitive @apply) (toplevel foo) (toplevel bar))
-   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+   (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
   (assert-tree-il->glil/pmatch
    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
             (label ,l4)
@@ -440,7 +444,7 @@
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref foo)
             (toplevel ref bar) (toplevel ref baz) (call apply 2)
             (call goto/args 1))))
@@ -448,10 +452,10 @@
 (with-test-prefix "call/cc"
   (assert-tree-il->glil
    (apply (primitive @call-with-current-continuation) (toplevel foo))
-   (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+   (program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
   (assert-tree-il->glil/pmatch
    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
             (label ,l4)
@@ -460,8 +464,121 @@
   (assert-tree-il->glil
    (apply (toplevel foo)
           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref foo)
             (toplevel ref bar) (call call/cc 1)
             (call goto/args 1))))
 
+
+(with-test-prefix "tree-il-fold"
+
+  (pass-if "empty tree"
+    (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+      (and (eq? mark
+                (tree-il-fold (lambda (x y) (set! leaf? #t) y)
+                              (lambda (x y) (set! down? #t) y)
+                              (lambda (x y) (set! up? #t) y)
+                              mark
+                              '()))
+           (not leaf?)
+           (not up?)
+           (not down?))))
+
+  (pass-if "lambda and application"
+    (let* ((leaves '()) (ups '()) (downs '())
+           (result (tree-il-fold (lambda (x y)
+                                   (set! leaves (cons x leaves))
+                                   (1+ y))
+                                 (lambda (x y)
+                                   (set! downs (cons x downs))
+                                   (1+ y))
+                                 (lambda (x y)
+                                   (set! ups (cons x ups))
+                                   (1+ y))
+                                 0
+                                 (parse-tree-il
+                                  '(lambda (x y) (x1 y1)
+                                     (apply (toplevel +)
+                                            (lexical x x1)
+                                            (lexical y y1)))))))
+      (and (equal? (map strip-source leaves)
+                   (list (make-lexical-ref #f 'y 'y1)
+                         (make-lexical-ref #f 'x 'x1)
+                         (make-toplevel-ref #f '+)))
+           (= (length downs) 2)
+           (equal? (reverse (map strip-source ups))
+                   (map strip-source downs))))))
+
+
+;;;
+;;; Warnings.
+;;;
+
+;; Make sure we get English messages.
+(setlocale LC_ALL "C")
+
+(define (call-with-warnings thunk)
+  (let ((port (open-output-string)))
+    (with-fluid* *current-warning-port* port
+      thunk)
+    (let ((warnings (get-output-string port)))
+      (string-tokenize warnings
+                       (char-set-complement (char-set #\newline))))))
+
+(define %opts-w-unused
+  '(#:warnings (unused-variable)))
+
+
+(with-test-prefix "warnings"
+
+   (pass-if "unknown warning type"
+     (let ((w (call-with-warnings
+                (lambda ()
+                  (compile #t #:opts '(#:warnings (does-not-exist)))))))
+       (and (= (length w) 1)
+            (number? (string-contains (car w) "unknown warning")))))
+
+   (with-test-prefix "unused-variable"
+
+     (pass-if "quiet"
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(lambda (x y) (+ x y))
+                           #:opts %opts-w-unused)))))
+
+     (pass-if "let/unused"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(lambda (x)
+                                (let ((y (+ x 2)))
+                                  x))
+                             #:opts %opts-w-unused)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w) "unused variable `y'")))))
+
+     (pass-if "shadowed variable"
+       (let ((w (call-with-warnings
+                  (lambda ()
+                    (compile '(lambda (x)
+                                (let ((y x))
+                                  (let ((y (+ x 2)))
+                                    (+ x y))))
+                             #:opts %opts-w-unused)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w) "unused variable `y'")))))
+
+     (pass-if "letrec"
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(lambda ()
+                              (letrec ((x (lambda () (y)))
+                                       (y (lambda () (x))))
+                                y))
+                           #:opts %opts-w-unused)))))
+
+     (pass-if "unused argument"
+       ;; Unused arguments should not be reported.
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '(lambda (x y z) #t)
+                           #:opts %opts-w-unused)))))))