guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, elisp, updated. release_1-9-1-66-gc808


From: Daniel Kraft
Subject: [Guile-commits] GNU Guile branch, elisp, updated. release_1-9-1-66-gc808c92
Date: Fri, 31 Jul 2009 16:01:05 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c808c926fd35aeb5a3fd7768ea50edc060d48420

The branch, elisp has been updated
       via  c808c926fd35aeb5a3fd7768ea50edc060d48420 (commit)
       via  a43df0ae471ef9003d15e422d9ee8f9f6cfe6bb1 (commit)
       via  4b856371b3e85cd82f6d637f72bc610d0158b5de (commit)
       via  2e4c3227ce1374dd53abd3c7c5797cc64329de91 (commit)
       via  f4aa0f104b3347c21093b837046022fb7bb6a2ff (commit)
       via  904a78f11d2d11a58d5df365a44c4fbbd4c96df3 (commit)
       via  77332b21a01fac906ae4707426e00f01e62c0415 (commit)
       via  e5dc27b86d0eaa470f92cdaa9f4ed2a961338c49 (commit)
       via  28b119ee3da0f4b14cb87e638794d22843778cda (commit)
       via  9efc2d1404aa7705f38aa1ceaebf4c4893e68b83 (commit)
       via  9557ecc6620c83a9254649e63248ce997d749cde (commit)
       via  cb8ab66c6657a61797399e5f63c7942ae7cd20e3 (commit)
       via  74deff3c431245b282903d46eb7e571ace8759f3 (commit)
       via  d95eb7f49f721306ffeb0020724093929cb0e206 (commit)
       via  51e9ba2f38675ce5fd161b7df15470abaaf60e0e (commit)
       via  80545853d544f347ae991a476d78ccbf4d305ec7 (commit)
       via  ccf77d955c875ce95473098af96da9e1bec0b7eb (commit)
       via  476e35728136b2d504855f3e2e4922ed72a41101 (commit)
       via  57ab0671d71bd6e485784f46b6dea4708661082d (commit)
       via  20d47c3915c1b910e683d4b010b91c48047d6251 (commit)
       via  66d3e9a32c2da4eedb3f316e0dcffe92e6631f87 (commit)
       via  8d90b356560b9cf54300ff9eabf4675acb650e03 (commit)
       via  a5cfddd560ca21205c8b0417413253d94f3e9b93 (commit)
      from  bfd472a7d3ede320b55b7653e30ca37eba4d464a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit c808c926fd35aeb5a3fd7768ea50edc060d48420
Author: Daniel Kraft <address@hidden>
Date:   Fri Jul 31 18:00:01 2009 +0200

    Compiler option to always bind certain symbols lexically.
    Affects so far let-bound symbols, lambda arguments to come in the future.
    
    * module/language/elisp/README: Document it.
    * module/language/elisp/compile-tree-il.scm: Add :always-lexical option.
    * test-suite/tests/elisp-compiler.test: Test it.

commit a43df0ae471ef9003d15e422d9ee8f9f6cfe6bb1
Merge: bfd472a7d3ede320b55b7653e30ca37eba4d464a 
4b856371b3e85cd82f6d637f72bc610d0158b5de
Author: Daniel Kraft <address@hidden>
Date:   Fri Jul 31 17:18:34 2009 +0200

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

-----------------------------------------------------------------------

Summary of changes:
 gdbinit                                         |    5 -
 libguile/chars.c                                |  217 ++++++----
 libguile/chars.h                                |   30 +-
 libguile/frames.c                               |   12 +-
 libguile/frames.h                               |   19 +-
 libguile/numbers.c                              |    8 +
 libguile/numbers.h                              |   10 +-
 libguile/objcodes.c                             |    2 +-
 libguile/objcodes.h                             |    5 +-
 libguile/print.c                                |   41 ++-
 libguile/programs.c                             |   52 +--
 libguile/programs.h                             |    9 +-
 libguile/read.c                                 |    9 +-
 libguile/vm-engine.c                            |   21 +-
 libguile/vm-engine.h                            |   68 ++--
 libguile/vm-i-loader.c                          |   24 +-
 libguile/vm-i-scheme.c                          |  136 +++---
 libguile/vm-i-system.c                          |  364 ++++++++++-------
 libguile/vm.c                                   |   57 +--
 module/Makefile.am                              |    1 +
 module/ice-9/psyntax-pp.scm                     |    3 +-
 module/ice-9/psyntax.scm                        |    6 +-
 module/language/assembly.scm                    |   36 ++-
 module/language/assembly/compile-bytecode.scm   |   19 +-
 module/language/assembly/decompile-bytecode.scm |   12 +-
 module/language/assembly/disassemble.scm        |   40 +-
 module/language/elisp/README                    |   12 +-
 module/language/elisp/compile-tree-il.scm       |  112 +++--
 module/language/glil.scm                        |   54 +--
 module/language/glil/compile-assembly.scm       |  195 +++++----
 module/language/glil/decompile-assembly.scm     |   20 +-
 module/language/objcode/spec.scm                |   17 +-
 module/language/tree-il.scm                     |   49 +++-
 module/language/tree-il/analyze.scm             |  511 +++++++++++++++--------
 module/language/tree-il/compile-glil.scm        |  180 +++++----
 module/scripts/compile.scm                      |   34 ++-
 module/system/base/compile.scm                  |   11 +
 module/system/base/message.scm                  |  102 +++++
 module/system/repl/command.scm                  |    1 -
 module/system/vm/frame.scm                      |   47 +--
 module/system/vm/program.scm                    |   17 +-
 module/system/vm/trace.scm                      |    5 +-
 test-suite/tests/asm-to-bytecode.test           |   88 +++--
 test-suite/tests/elisp-compiler.test            |   24 +-
 test-suite/tests/tree-il.test                   |  319 ++++++++++-----
 45 files changed, 1865 insertions(+), 1139 deletions(-)
 create mode 100644 module/system/base/message.scm

diff --git a/gdbinit b/gdbinit
index 381cf84..b66e3e2 100644
--- a/gdbinit
+++ b/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 #"
diff --git a/libguile/chars.c b/libguile/chars.c
index ca47c0d..5a53c45 100644
--- a/libguile/chars.c
+++ b/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"
-            "ignoring case, else @code{#f}.")
+            "Return @code{#t} iff the Unicode uppercase form of @var{x} is 
less\n"
+            "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"
-            "ASCII sequence ignoring case, else @code{#f}.")
+            "Return @code{#t} iff the Unicode uppercase form of @var{x} is 
less\n"
+            "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"
-            "sequence ignoring case, else @code{#f}.")
+            "Return @code{#t} iff the Unicode uppercase form of @var{x} is 
greater\n"
+            "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"
-            "ASCII sequence ignoring case, else @code{#f}.")
+            "Return @code{#t} iff the Unicode uppercase form of @var{x} is 
greater\n"
+            "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_c_upcase (unsigned int c)
+scm_t_wchar
+scm_c_upcase (scm_t_wchar c)
 {
-  if (c <= UCHAR_MAX)
-    return toupper (c);
-  else
-    return c;
+  return uc_toupper (c);
 }
 
 
-int
-scm_c_downcase (unsigned int c)
+scm_t_wchar
+scm_c_downcase (scm_t_wchar c)
 {
-  if (c <= UCHAR_MAX)
-    return tolower (c);
-  else
-    return c;
+  return uc_tolower (c);
 }
 
+
 
-#ifdef _DCC
-# define ASCII
-#else
-# 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 */
+/* There are a few sets of character names: R5RS, Guile
+   extensions for control characters, and leftover Guile extensions.
+   They are listed in order of precedence.  */
+
+const char *const scm_r5rs_charnames[] = 
+  {
+    "space", "newline"
+  };
+
+const scm_t_uint32 const scm_r5rs_charnums[] = 
+  {
+    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)
+{
+  int c;
+  scm_t_uint32 i = SCM_CHAR (chr);
 
+  for (c = 0; c < scm_n_r5rs_charnames; c++)
+    if (scm_r5rs_charnums[c] == i)
+      return scm_r5rs_charnames[c];
 
-#ifdef EBCDIC
-char *const scm_charnames[] =
-{
-  "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
-   0   , 0   , "smm", "vt", "ff", "cr", "so", "si",
-  "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[] =
-"\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\
-\040\041\042\043\044\045\046\047\
-\050\051\052\053\054\055\056\057\
-\060\061\062\063\064\065\066\067\
-\070\071\072\073\074\075\076\077\
- \n\t\b\r\f\0";
-#endif /* def EBCDIC */
-#ifdef ASCII
-char *const scm_charnames[] =
-{
-  "nul","soh","stx","etx","eot","enq","ack","bel",
-   "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 *);
+  for (c = 0; c < scm_n_C0_control_charnames; c++)
+    if (scm_C0_control_charnums[c] == i)
+      return scm_C0_control_charnames[c];
+
+  for (c = 0; c < scm_n_alt_charnames; c++)
+    if (scm_alt_charnums[c] == i)
+      return scm_alt_charnames[i];
 
+  return NULL;
+}
+
+/* Return a character from a string charname.  */
+SCM
+scm_i_charname_to_char (const char *charname, size_t charname_len)
+{
+  int c;
+
+  /* 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;
+}
 
 
 
diff --git a/libguile/chars.h b/libguile/chars.h
index 88dde4b..e68f06d 100644
--- a/libguile/chars.h
+++ b/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_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), 
scm_tc8_char)
+#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
 
-
+#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[];
-SCM_API int scm_n_charnames;
-SCM_API const char scm_charnums[];
+#define SCM_CODEPOINT_MAX (0x10ffff)
+#define SCM_IS_UNICODE_CHAR(c)                                          \
+  ((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 int scm_c_downcase (unsigned int c);
+SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar 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 */
diff --git a/libguile/frames.c b/libguile/frames.c
index 76552f5..e89184d 100644
--- a/libguile/frames.c
+++ b/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),
            "")
diff --git a/libguile/frames.h b/libguile/frames.h
index 99623fb..1b3153a 100644
--- a/libguile/frames.h
+++ b/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     |
-   | External link    | <- fp + bp->nargs + bp->nlocs
+   | Dynamic link     | <- fp + bp->nargs + bp->blocs
    | 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);
-#define SCM_FRAME_EXTERNAL_LINK(fp)    (SCM_FRAME_DATA_ADDRESS (fp)[0])
+  ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
 #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);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index c7e0981..5f56b7a 100644
--- a/libguile/numbers.c
+++ b/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
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 5bad447..f30f7d0 100644
--- a/libguile/numbers.h
+++ b/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);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index a210553..91691a7 100644
--- a/libguile/objcodes.c
+++ b/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);
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index e9b1cdb..2bb4e60 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -25,11 +25,11 @@
 struct scm_objcode {
   scm_t_uint8 nargs;
   scm_t_uint8 nrest;
-  scm_t_uint8 nlocs;
-  scm_t_uint8 nexts;
+  scm_t_uint16 nlocs;
   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)
diff --git a/libguile/print.c b/libguile/print.c
index 6c44d59..1a5aebe 100644
--- a/libguile/print.c
+++ b/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])
-               scm_puts (scm_charnames[i], port);
-#ifndef EBCDIC
-             else if (i == '\177')
-               scm_puts (scm_charnames[scm_n_charnames - 1], port);
-#endif
-             else if (i < 0 || i > '\177')
-               scm_intprint (i, 8, port);
-             else
-               scm_putc (i, port);
+             name = scm_i_charname (exp);
+             if (name != NULL)
+               scm_puts (name, port);
+             else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L
+                                                         | UC_CATEGORY_MASK_M 
+                                                         | UC_CATEGORY_MASK_N 
+                                                         | UC_CATEGORY_MASK_P 
+                                                         | UC_CATEGORY_MASK_S))
+                /* Print the character if is graphic character.  */
+                {
+                  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);
diff --git a/libguile/programs.c b/libguile/programs.c
index 892b677..5c43ac5 100644
--- a/libguile/programs.c
+++ b/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)))
-    external = SCM_EOL;
-  else
-    /* FIXME: currently this test is quite expensive (can be 2-3% of total
-       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);
+  if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
+    free_variables = SCM_BOOL_F;
+  else if (free_variables != SCM_BOOL_F)
+    SCM_VALIDATE_VECTOR (3, free_variables);
+
+  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)))
-    scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
+  if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (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->nexts));
+                    SCM_I_MAKINUM (p->nlocs));
 }
 #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
-{
-  SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_PROGRAM_EXTERNALS (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
+#define FUNC_NAME s_scm_program_free_variables
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  SCM_VALIDATE_LIST (2, external);
-  SCM_PROGRAM_EXTERNALS (program) = external;
-  return SCM_UNSPECIFIED;
+  return SCM_PROGRAM_FREE_VARIABLES (program);
 }
 #undef FUNC_NAME
 
diff --git a/libguile/programs.h b/libguile/programs.h
index 16a1550..040e8ea 100644
--- a/libguile/programs.h
+++ b/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_external_set_x (SCM program, SCM external);
+SCM_API SCM scm_program_free_variables (SCM program);
 SCM_API SCM scm_program_objcode (SCM program);
 
 SCM_API SCM scm_c_program_source (SCM program, size_t ip);
diff --git a/libguile/read.c b/libguile/read.c
index bd028ea..2140fed 100644
--- a/libguile/read.c
+++ b/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++)
-    if (scm_charnames[c]
-       && (!strncasecmp (scm_charnames[c], charname, charname_len)))
-      return SCM_MAKE_CHAR (scm_charnums[c]);
+  ch = scm_i_charname_to_char (charname, charname_len);
+  if (scm_is_true (ch))
+    return ch;
 
  char_error:
   scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 90cf697..98a6e49 100644
--- a/libguile/vm-engine.c
+++ b/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
-  vm_error_external:
-    err_msg  = scm_from_locale_string ("VM: Invalid external access");
+#if VM_CHECK_OBJECT
+  vm_error_object:
+    err_msg = scm_from_locale_string ("VM: Invalid object table access");
     finish_args = SCM_EOL;
     goto vm_error;
 #endif
 
-#if VM_CHECK_OBJECT
-  vm_error_object:
-    err_msg = scm_from_locale_string ("VM: Invalid object table access");
+#if VM_CHECK_FREE_VARIABLES
+  vm_error_free_variable:
+    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
 
 /*
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index d684979..c0f772f 100644
--- a/libguile/vm-engine.h
+++ b/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
-   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.  */
+/* Cache the object table and free variables.  */
 #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] = 0x0;                                \
-  data[1] = (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;                           \
+  data[2] = (SCM)ra;                            \
+  data[1] = 0x0;                                \
+  data[0] = (SCM)dl;                            \
 }
 
-#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
-
 /*
   Local Variables:
   c-file-style: "gnu"
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 86d0fc4..9ae49ed 100644
--- a/libguile/vm-i-loader.c
+++ b/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)))
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 42f8bac..dce9b5f 100644
--- a/libguile/vm-i-scheme.c
+++ b/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)))
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 03d0c17..5a4809d 100644
--- a/libguile/vm-i-system.c
+++ b/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;
-  SCM e = external;
-  for (i = FETCH (); i; i--)
-    {
-      CHECK_EXTERNAL(e);
-      e = SCM_CDR (e);
-    }
-  CHECK_EXTERNAL(e);
-  PUSH (SCM_CAR (e));
+  unsigned int i = FETCH ();
+  i <<= 8;
+  i += FETCH ();
+  PUSH (LOCAL_REF (i));
   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;
-  SCM e = external;
-  for (i = FETCH (); i; i--)
-    {
-      CHECK_EXTERNAL(e);
-      e = SCM_CDR (e);
-    }
-  CHECK_EXTERNAL(e);
-  SCM_SETCAR (e, *sp);
+  unsigned int i = FETCH ();
+  i <<= 8;
+  i += FETCH ();
+  LOCAL_SET (i, *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 ();
-  int l = FETCH ();
-  ip += (signed short) (h << 8) + l;
+  scm_t_int16 offset;
+  FETCH_OFFSET (offset);
+  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)
-{
-  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)
+VM_DEFINE_INSTRUCTION (43, 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)mvra;
-      data[1] = (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;
+      data[2] = (SCM)ra;
+      data[1] = (SCM)mvra;
+      data[0] = (SCM)dl;
 
       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]);
-    fp = SCM_FRAME_STACK_CAST (data[1]);
+    ip = SCM_FRAME_BYTE_CAST (data[2]);
+    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 */
-  if (nvalues != 1 && data[2]) 
+  /* data[1] is the mv return address */
+  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 */
-      fp = SCM_FRAME_STACK_CAST (data[1]);
+      ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
+      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 */
-      fp = SCM_FRAME_STACK_CAST (data[1]);
+      ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
+      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 ();
-  objnum <<= 8;
-  objnum += FETCH ();
-  CHECK_OBJECT (objnum);
-  PUSH (OBJECT_REF (objnum));
+  SCM val;
+  POP (val);
+  SYNC_BEFORE_GC ();
+  LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
   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;
-  unsigned int objnum = FETCH ();
-  objnum <<= 8;
-  objnum += FETCH ();
-  CHECK_OBJECT (objnum);
-  what = OBJECT_REF (objnum);
+  SYNC_BEFORE_GC ();
+  LOCAL_SET (FETCH (),
+             scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
+  NEXT;
+}
 
-  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);
-    }
+VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+{
+  SCM v = LOCAL_REF (FETCH ());
+  ASSERT_BOUND_VARIABLE (v);
+  PUSH (VARIABLE_REF (v));
+  NEXT;
+}
 
-  PUSH (VARIABLE_REF (what));
+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 (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
 {
-  SCM what;
-  unsigned int objnum = FETCH ();
-  objnum <<= 8;
-  objnum += FETCH ();
-  CHECK_OBJECT (objnum);
-  what = OBJECT_REF (objnum);
+  scm_t_uint8 idx = FETCH ();
+  
+  CHECK_FREE_VARIABLE (idx);
+  PUSH (FREE_VARIABLE_REF (idx));
+  NEXT;
+}
 
-  if (!SCM_VARIABLEP (what)) 
-    {
-      SYNC_BEFORE_GC ();
-      what = resolve_variable (what, scm_program_module (program));
-      OBJECT_SET (objnum, what);
-    }
+/* no free-set -- if a var is assigned, it should be in a box */
 
-  VARIABLE_SET (what, *sp);
-  DROP ();
+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"
diff --git a/libguile/vm.c b/libguile/vm.c
index f753ea2..cc5e4f9 100644
--- a/libguile/vm.c
+++ b/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 =
-    {
-      .dummy = 0,
-      .bytes = { 0, 0, 0, 0,
-                0, 0, 0, 0,
-                0, 0, 0, 0,
-                scm_op_mv_call, 0, 0, 1,
-                scm_op_make_int8_1, scm_op_halt }
-    };
-
+  /* Make sure "bytes" is 64-bit aligned.  */
+  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
+                         scm_op_make_int8_1, scm_op_nop, scm_op_nop, 
scm_op_nop,
+                         scm_op_halt };
+  struct scm_objcode *bp;
   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;
-
-  u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes));
+  text[1] = (scm_t_uint8)nargs;
+
+  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);
 }
diff --git a/module/Makefile.am b/module/Makefile.am
index a904a8f..2971fc6 100644
--- a/module/Makefile.am
+++ b/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            \
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 113269b..de0db95 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/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))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index f1f6e9a..6ecf24e 100644
--- a/module/ice-9/psyntax.scm
+++ b/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))
 
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 6ccac99..2427c42 100644
--- a/module/language/assembly.scm
+++ b/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
-(define *program-header-len* (+ 1 1 1 1 4 4))
+;; nargs, nrest, nlocs, len, metalen, padding
+(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
-                            (modulo (+ addr header-len) alignment))
-                         alignment)
-                 '(nop))
+  `(,@(code-alignment addr alignment header-len)
     ,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)))
diff --git a/module/language/assembly/compile-bytecode.scm 
b/module/language/assembly/compile-bytecode.scm
index 4b9f7b7..bed0fb2 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/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
-                       ,labels ,length ,meta . ,code)
+        ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
          (write-byte nargs)
          (write-byte nrest)
-         (write-byte nlocs)
-         (write-byte nexts)
+         (write-uint16 nlocs)
          (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))
diff --git a/module/language/assembly/decompile-bytecode.scm 
b/module/language/assembly/decompile-bytecode.scm
index fdf27ec..0e34ab4 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/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
diff --git a/module/language/assembly/disassemble.scm 
b/module/language/assembly/disassemble.scm
index 0a35050..d41c816 100644
--- a/module/language/assembly/disassemble.scm
+++ b/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)
-           (disassemble-externals exts))
+       (if (pair? free-vars)
+           (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)
-  (display "Externals:\n\n")
-  (let ((len (length exts)))
-    (do ((n 0 (1+ n))
-        (l exts (cdr l)))
-       ((null? l) (newline))
-      (print-info n (car l) #f #f))))
+(define (disassemble-free-vars free-vars)
+  (display "Free variables:\n\n")
+  (let ((i 0))
+    (cond ((< i (vector-length free-vars))
+           (print-info i (vector-ref free-vars i) #f #f)
+           (lp (1+ i))))))
 
 (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'address@hidden (arg)~]"
                                (binding:name b) (< (binding:index b) nargs))
                          (lp (cdr bindings))))))))
-      ((external-ref external-set)
-       (and bexts
-            (if (< (car args) (length bexts))
-                (let ((b (list-ref bexts (car args))))
-                  (list "`~a'address@hidden (arg)~]"
-                        (binding:name b) (< (binding:index b) nargs)))
-                (list "(closure variable)"))))
+      ((free-ref free-boxed-ref free-boxed-set)
+       ;; FIXME: we can do better than this
+       (list "(closure variable)"))
       ((toplevel-ref toplevel-set)
        (and objs
             (let ((v (vector-ref objs (car args))))
diff --git a/module/language/elisp/README b/module/language/elisp/README
index 004fd97..be625ff 100644
--- a/module/language/elisp/README
+++ b/module/language/elisp/README
@@ -32,17 +32,18 @@ Especially still missing:
 
 Other ideas and things to think about:
   * %nil vs. #f/'() handling in Guile
-  * compiler options for all lexical binding
 
 Compiler options implemented:
   * #:disable-void-check ['all / '(sym1 sym2 sym3)] to disable the check
     for void value on access either completely or for some symbols
+  * #:always-lexical (usable same as disable-void-check) to always bind
+    certain or all symbols lexically (including lambda arguments)
 
 Extensions over original elisp:
   * guile-ref, guile-primitive
   * flet and flet*
   * lexical-let and lexical-let*
-  * without-void-checks
+  * without-void-checks, with-always-lexical
 
 
 Details to the implemented extensions
@@ -105,3 +106,10 @@ in the lexical scope of this construct:
 
 (without-void-checks all body...) or
 (without-void-checks (sym1 sym2 ...) body...
+
+with-always-lexical:
+--------------------
+
+As without-void-checks but adds to list of symbols that should always be bound
+lexically.  This lexical binding includes lambda arguments (if the symbols
+match up with the list), which can not be bound lexically otherwise.
diff --git a/module/language/elisp/compile-tree-il.scm 
b/module/language/elisp/compile-tree-il.scm
index 42daaf1..14059e6 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -28,7 +28,8 @@
 
 
 ; Certain common parameters (like the bindings data structure or compiler
-; options) are not always passed around but accessed using fluids.
+; options) are not always passed around but accessed using fluids to simulate
+; dynamic binding (hey, this is about elisp).
 
 ; The bindings data structure to keep track of symbol binding related data.
 (define bindings-data (make-fluid))
@@ -36,6 +37,10 @@
 ; Store for which symbols (or all/none) void checks are disabled.
 (define disable-void-check (make-fluid))
 
+; Store which symbols (or all/none) should always be bound lexically, even
+; with ordinary let and as lambda arguments.
+(define always-lexical (make-fluid))
+
 
 ; Find the source properties of some parsed expression if there are any
 ; associated with it.
@@ -195,12 +200,15 @@
 ; A symbol will be bound lexically if and only if:
 ; We're processing a lexical-let (i.e. module is 'lexical), OR
 ; we're processing a value-slot binding AND
-;   the symbol is already lexically bound.
+;   the symbol is already lexically bound or it is always lexical.
 
 (define (bind-lexically? sym module)
   (or (eq? module 'lexical)
       (and (equal? module value-slot)
-           (get-lexical-binding (fluid-ref bindings-data) sym))))
+           (let ((always (fluid-ref always-lexical)))
+             (or (eq? always 'all)
+                 (memq sym always)
+                 (get-lexical-binding (fluid-ref bindings-data) sym))))))
 
 (define (split-let-bindings bindings module)
   (let iterate ((tail bindings)
@@ -354,9 +362,9 @@
 
 (define (compile-lambda loc args body)
   (if (not (list? args))
-    (error "expected list for argument-list" args))
+    (report-error loc "expected list for argument-list" args))
   (if (null? body)
-    (error "function body might not be empty"))
+    (report-error loc "function body might not be empty"))
   (with-dynamic-bindings (fluid-ref bindings-data) args
     (lambda ()
       (call-with-values
@@ -500,10 +508,32 @@
                 (compile-expr (cadr head))
                 (process-backquote loc head))
               processed-tail))))
-      (error "non-pair expression contains unquotes" expr))
+      (report-error loc "non-pair expression contains unquotes" expr))
     (make-const loc expr)))
 
 
+; Temporarily update a list of symbols that are handled specially (disabled
+; void check or always lexical) for compiling body.
+; We need to handle special cases for already all / set to all and the like.
+
+(define (with-added-symbols loc fluid syms body)
+  (if (null? body)
+    (report-error loc "symbol-list construct has empty body"))
+  (if (not (or (eq? syms 'all)
+               (and (list? syms) (and-map symbol? syms))))
+    (report-error loc "invalid symbol list" syms))
+  (let ((old (fluid-ref fluid))
+        (make-body (lambda ()
+                     (make-sequence loc (map compile-expr body)))))
+    (if (eq? old 'all)
+      (make-body)
+      (let ((new (if (eq? syms 'all)
+                   'all
+                   (append syms old))))
+        (with-fluids ((fluid new))
+          (make-body))))))
+
+
 ; Compile a symbol expression.  This is a variable reference or maybe some
 ; special value like nil.
 
@@ -610,22 +640,14 @@
                                            (not (null? body))))
      (generate-let* loc function-slot bindings body))
 
-    ; Temporarily disable void checks for certain symbols within the lexical
-    ; scope of without-void-checks.
+    ; Temporarily disable void checks or set symbols as always lexical only
+    ; for the lexical scope of a construct.
+
     ((without-void-checks ,syms . ,body)
-     (guard (and (list? body) (not (null? body))
-                 (or (eq? syms 'all)
-                     (and (list? syms) (and-map symbol? syms)))))
-     (let ((disabled (fluid-ref disable-void-check))
-           (make-body (lambda ()
-                        (make-sequence loc (map compile-expr body)))))
-       (if (eq? disabled 'all)
-         (make-body)
-         (let ((new-disabled (if (eq? syms 'all)
-                               'all
-                               (append syms disabled))))
-           (with-fluid* disable-void-check new-disabled make-body)))))
+     (with-added-symbols loc disable-void-check syms body))
 
+    ((with-always-lexical ,syms . ,body)
+     (with-added-symbols loc always-lexical syms body))
 
     ; guile-ref allows building TreeIL's module references from within
     ; elisp as a way to access data within
@@ -721,7 +743,7 @@
     ; just as with defvar/defconst.
     ((defun ,name ,args . ,body)
      (if (not (symbol? name))
-       (error "expected symbol as function name" name)
+       (report-error loc "expected symbol as function name" name)
        (make-sequence loc
          (list (set-variable! loc name function-slot
                               (compile-lambda loc args body))
@@ -731,10 +753,9 @@
     ; FIXME: Recursive macros don't work!
     ((defmacro ,name ,args . ,body)
      (if (not (symbol? name))
-       (error "expected symbol as macro name" name)
-       (let* ((tree-il (with-fluid* bindings-data (make-bindings)
-                         (lambda ()
-                           (compile-lambda loc args body))))
+       (report-error loc "expected symbol as macro name" name)
+       (let* ((tree-il (with-fluids ((bindings-data (make-bindings)))
+                         (compile-lambda loc args body)))
               (object (compile tree-il #:from 'tree-il #:to 'value)))
          (define-macro! loc name object)
          (make-const loc name))))
@@ -782,20 +803,27 @@
 ; Process the compiler options.
 ; FIXME: Why is '(()) passed as options by the REPL?
 
+(define (valid-symbol-list-arg? value)
+  (or (eq? value 'all)
+      (and (list? value) (and-map symbol? value))))
+
 (define (process-options! opt)
   (if (and (not (null? opt))
            (not (equal? opt '(()))))
     (if (null? (cdr opt))
-      (error "Invalid compiler options" opt)
+      (report-error #f "Invalid compiler options" opt)
       (let ((key (car opt))
             (value (cadr opt)))
         (case key
           ((#:disable-void-check)
-           (if (and (not (eq? value 'all))
-                    (not (and (list? value) (and-map symbol? value))))
-             (error "Invalid value for #:disable-void-check" value)
-             (fluid-set! disable-void-check value)))
-          (else (error "Invalid compiler option" key)))))))
+           (if (valid-symbol-list-arg? value)
+             (fluid-set! disable-void-check value)
+             (report-error #f "Invalid value for #:disable-void-check" value)))
+          ((#:always-lexical)
+           (if (valid-symbol-list-arg? value)
+             (fluid-set! always-lexical value)
+             (report-error #f "Invalid value for #:always-lexical" value)))
+          (else (report-error #f "Invalid compiler option" key)))))))
 
 
 ; Entry point for compilation to TreeIL.
@@ -805,16 +833,16 @@
 
 (define (compile-tree-il expr env opts)
   (values
-    (with-fluids* (list bindings-data disable-void-check)
-                  (list (make-bindings) '())
-      (lambda ()
-        (process-options! opts)
-        (let ((loc (location expr))
-              (compiled (compile-expr expr)))
-          (make-sequence loc
-            `(,@(map-fluids-needed (fluid-ref bindings-data)
-                                   (lambda (mod sym)
-                                     (generate-ensure-fluid loc sym mod)))
-              ,compiled)))))
+    (with-fluids ((bindings-data (make-bindings))
+                  (disable-void-check '())
+                  (always-lexical '()))
+      (process-options! opts)
+      (let ((loc (location expr))
+            (compiled (compile-expr expr)))
+        (make-sequence loc
+          `(,@(map-fluids-needed (fluid-ref bindings-data)
+                                 (lambda (mod sym)
+                                   (generate-ensure-fluid loc sym mod)))
+            ,compiled))))
     env
     env))
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 38b915f..0777073 100644
--- a/module/language/glil.scm
+++ b/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-meta glil-program-body glil-program-closure-level
-
+   glil-program-nargs glil-program-nrest glil-program-nlocs
+   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-local-op glil-local-index
-
-   <glil-external> make-glil-external glil-external?
-   glil-external-op glil-external-depth glil-external-index
+   <glil-lexical> make-glil-lexical glil-lexical?
+   glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-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-external> op depth index)
+  (<glil-lexical> local? boxed? op 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)
-     (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+    ((program ,nargs ,nrest ,nlocs ,meta . ,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))
-    ((external ,op ,depth ,index) (make-glil-external op depth index))
+    ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op 
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)
-     `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+    ((<glil-program> nargs nrest nlocs meta 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)
-     `(local ,op ,index))
-    ((<glil-external> op depth index)
-     `(external ,op ,depth ,index))
+    ((<glil-lexical> local? boxed? op index)
+     `(lexical ,local? ,boxed? ,op ,index))
     ((<glil-toplevel> op name)
      `(toplevel ,op ,name))
     ((<glil-module> op mod name public?)
diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index 0b92a4e..fa58057 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/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)
-  (list name ext? index))
+(define (make-open-binding name boxed? 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 external ,i) (make-open-binding name #t i))
+               ((,name ,boxed? ,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)
-     (let ((toplevel? (null? nexts-stack)))
-       (define (process-body)
-         (let ((nexts-stack (cons nexts nexts-stack)))
-           (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
-                    (label-alist '()) (object-alist (if toplevel? #f '())) 
(addr 0))
+    ((<glil-program> nargs nrest nlocs meta body)
+     (define (process-body)
+       (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+                (label-alist '()) (object-alist (if toplevel? #f '())) (addr 
0))
+         (cond
+          ((null? body)
+           (values (reverse code)
+                   (close-all-bindings bindings addr)
+                   (limn-sources (reverse! source-alist))
+                   (reverse label-alist)
+                   (and object-alist (map car (reverse object-alist)))
+                   addr))
+          (else
+           (receive (subcode bindings source-alist label-alist object-alist)
+               (glil->assembly (car body) #f bindings
+                               source-alist label-alist object-alist addr)
+             (lp (cdr body) (append (reverse subcode) code)
+                 bindings source-alist label-alist object-alist
+                 (addr+ addr subcode)))))))
+
+     (receive (code bindings sources labels objects len)
+         (process-body)
+       (let* ((meta (make-meta bindings sources meta))
+              (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
+              (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+                                  ,(+ len meta-pad)
+                                  ,meta
+                                  ,@code
+                                  ,@(if meta
+                                        (make-list meta-pad '(nop))
+                                        '()))))
+         (cond
+          (toplevel?
+           ;; toplevel bytecode isn't loaded by the vm, no way to do
+           ;; object table or closure capture (not in the bytecode,
+           ;; anyway)
+           (emit-code (align-program prog addr)))
+          (else
+           (let ((table (make-object-table objects)))
              (cond
-              ((null? body)
-               (values (reverse code)
-                       (close-all-bindings bindings addr)
-                       (limn-sources (reverse! source-alist))
-                       (reverse label-alist)
-                       (and object-alist (map car (reverse object-alist)))
-                       addr))
+              (object-alist
+               ;; if we are being compiled from something with an object
+               ;; table, cache the program there
+               (receive (i object-alist)
+                   (object-index-and-alist (make-subprogram table prog)
+                                           object-alist)
+                 (emit-code/object `(,(if (< i 256)
+                                          `(object-ref ,i)
+                                          `(long-object-ref ,(quotient i 256)
+                                                            ,(modulo i 256))))
+                                   object-alist)))
               (else
-               (receive (subcode bindings source-alist label-alist 
object-alist)
-                   (glil->assembly (car body) nexts-stack bindings
-                                   source-alist label-alist object-alist addr)
-                 (lp (cdr body) (append (reverse subcode) code)
-                     bindings source-alist label-alist object-alist
-                     (addr+ addr subcode))))))))
-
-       (receive (code bindings sources labels objects len)
-           (process-body)
-         (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
-                                    ,len
-                                    ,(make-meta bindings sources meta)
-                                    . ,code)))
-           (cond
-            (toplevel?
-             ;; toplevel bytecode isn't loaded by the vm, no way to do
-             ;; object table or closure capture (not in the bytecode,
-             ;; anyway)
-             (emit-code (align-program prog addr)))
-            (else
-             (let ((table (dump-object (make-object-table objects) addr))
-                   (closure (if (> closure-level 0) '((make-closure)) '())))
-               (cond
-                (object-alist
-                 ;; if we are being compiled from something with an object
-                 ;; table, cache the program there
-                 (receive (i object-alist)
-                     (object-index-and-alist (make-subprogram table prog)
-                                             object-alist)
-                   (emit-code/object `(,(if (< i 256)
-                                            `(object-ref ,i)
-                                            `(long-object-ref ,(quotient i 256)
-                                                              ,(modulo i 256)))
-                                       ,@closure)
-                                     object-alist)))
-                (else
-                 ;; otherwise emit a load directly
-                 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
-                                      ,@closure)))))))))))
+               ;; 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)
-     (emit-code (if (eq? op 'ref)
-                    `((local-ref ,index))
-                    `((local-set ,index)))))
-
-    ((<glil-external> op depth index)
-     (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
-                  (if (> d 0)
-                      (lp (1- d) (+ n (car stack)) (cdr stack))
-                      (if (eq? op 'ref)
-                          `((external-ref ,(+ n index)))
-                          `((external-set ,(+ n index))))))))
-
+    ((<glil-lexical> local? boxed? op index)
+     (emit-code
+      (if local?
+          (if (< index 256)
+              `((,(case op
+                    ((ref) (if boxed? 'local-boxed-ref 'local-ref))
+                    ((set) (if boxed? 'local-boxed-set 'local-set))
+                    ((box) 'box)
+                    ((empty-box) 'empty-box)
+                    (else (error "what" op)))
+                 ,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 '()
-             bindings
-             source-alist
-             (acons label addr label-alist)
-             object-alist))
+     (let ((code (align-block addr)))
+       (values code
+               bindings
+               source-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)
-      ,@(align-program (subprogram-prog x)
-                       (addr+ addr (subprogram-table x)))))
+    (let ((table-code (dump-object (subprogram-table x) addr)))
+      `(,@table-code
+        ,@(align-program (subprogram-prog x)
+                         (addr+ addr table-code)))))
    ((number? x)
     `((load-number ,(number->string x))))
    ((string? x)
diff --git a/module/language/glil/decompile-assembly.scm 
b/module/language/glil/decompile-assembly.scm
index 6c222ba..69aa1eb 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/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)
-     (decompile-load-program nargs nrest nlocs nexts
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
+     (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
-                        (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))
+                 (cons (make-glil-bind bindings)
                        out)
                  pos)))
        ((pop-unbindings! pos)
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 76c1cbc..4cb600f 100644
--- a/module/language/objcode/spec.scm
+++ b/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
-                        (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))))
+      (let ((blocs (and binds (collapse-locals 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))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 0f8448a..aec4eed 100644
--- a/module/language/tree-il.scm
+++ b/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
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 9768077..1b39b2d 100644
--- a/module/language/tree-il/analyze.scm
+++ b/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
-;; a var is external if it is heaps; assigning index is easy
-;; args are assigned in order
-;; locals are indexed as their linear position in the binding path
+;; Allocation is the process of assigning storage locations for lexical
+;; variables. A lexical variable has a distinct "address", or storage
+;; location, for each procedure in which it is referenced.
+;;
+;; 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:
-;;  sym -> (local . index) | (heap level . index)
-;;  lambda -> (nlocs . nexts)
+;; Closure variables are captured when a closure is created, and stored
+;; in a vector. Each closure variable has a unique index into that
+;; 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
-  ;;  useful when we see a closed-over var, so we can calculate its
-  ;;  coordinates (depth and index).
-  ;; bindings: lambda -> (sym ...)
-  ;;  useful for two reasons: one, so we know how much space to allocate
-  ;;  when we go into a lambda; and two, so that we know when to stop,
-  ;;  when looking for closed-over vars.
-  ;; heaps: sym -> lambda
-  ;;  allows us to heapify vars in an O(1) fashion
+  ;; bound-vars: lambda -> (sym ...)
+  ;;  all identifiers bound within a lambda
+  ;; free-vars: lambda -> (sym ...)
+  ;;  all identifiers referenced in a lambda, but not bound
+  ;;  NB, this includes identifiers referenced by contained lambdas
+  ;; assigned: sym -> #t
+  ;;  variables that are assigned
   ;; refcounts: sym -> count
-  ;;  allows us to detect the or-expansion an O(1) time
-
-  (define (find-heap sym parent)
-    ;; fixme: check displaced lexicals here?
-    (if (memq sym (hashq-ref bindings parent))
-        parent
-        (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)))
+  ;;  allows us to detect the or-expansion in O(1) time
+  
+  ;; returns variables referenced in expr
+  (define (analyze! x proc)
+    (define (step y) (analyze! y proc))
+    (define (recur x new-proc) (analyze! x new-proc))
     (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)))
-                (not (hashq-ref heaps gensym)))
-           (hashq-set! heaps gensym (find-heap gensym parent))))
+       (list gensym))
       
       ((<lexical-set> name gensym exp)
-       (step exp)
-       (if (not (hashq-ref heaps gensym))
-           (hashq-set! heaps gensym (find-heap gensym parent))))
+       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+       (hashq-set! assigned gensym #t)
+       (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)
-       (hashq-set! bindings x
-                   (let rev* ((vars vars) (out '()))
-                     (cond ((null? vars) out)
-                           ((pair? vars) (rev* (cdr vars)
-                                               (cons (car vars) out)))
-                           (else (cons vars out)))))
-       (recur body x)
-       (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
-
+       (let ((locally-bound (let rev* ((vars vars) (out '()))
+                              (cond ((null? vars) out)
+                                    ((pair? vars) (rev* (cdr vars)
+                                                        (cons (car vars) out)))
+                                    (else (cons vars out))))))
+         (hashq-set! bound-vars x locally-bound)
+         (let* ((referenced (recur body x))
+                (free (lset-difference eq? referenced locally-bound))
+                (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! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (step body))
+       (hashq-set! bound-vars proc
+                   (append (reverse vars) (hashq-ref bound-vars proc)))
+       (lset-difference eq?
+                        (apply lset-union eq? (step body) (map step vals))
+                        vars))
       
       ((<letrec> vars vals body)
-       (hashq-set! bindings parent
-                   (append (reverse vars) (hashq-ref bindings parent)))
-       (for-each step vals)
-       (step body))
-
+       (hashq-set! bound-vars proc
+                   (append (reverse vars) (hashq-ref bound-vars proc)))
+       (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
+       (lset-difference eq?
+                        (apply lset-union eq? (step body) (map step vals))
+                        vars))
+      
       ((<let-values> vars exp body)
-       (hashq-set! bindings parent
-                   (let lp ((out (hashq-ref bindings parent)) (in vars))
+       (hashq-set! bound-vars proc
+                   (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)
-       (step body))
-
-      (else #f)))
-
-    (define (allocate-heap! binder)
-      (hashq-set! heap-indexes binder
-                  (1+ (hashq-ref heap-indexes binder -1))))
+       (lset-difference eq?
+                        (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)))
 
-    (define (allocate! x level n)
-      (define (recur y) (allocate! y level n))
-      (record-case x
-        ((<application> proc args)
-         (apply max (recur proc) (map recur args)))
+      ((<conditional> test then else)
+       (max (recur test) (recur then) (recur else)))
 
-        ((<conditional> test then else)
-         (max (recur test) (recur then) (recur else)))
+      ((<lexical-set> name gensym exp)
+       (recur exp))
+      
+      ((<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)
 
-        ((<lexical-set> name gensym exp)
-         (recur exp))
-        
-        ((<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)
-         (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)))
+      ((<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 assigned 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)
+                       (make-hashq proc `(#t #f . ,n)))
+           ;; the 1+ for this var
+           (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
+          (else
+           (let lp ((vars vars) (n n))
+             (if (null? vars)
+                 (max nmax (allocate! body proc n))
+                 (let ((v (car vars)))
                    (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)
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr vars) (1+ n)))))))))
+      
+      ((<letrec> vars vals body)
+       (let lp ((vars vars) (n n))
+         (if (null? vars)
+             (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))))))
 
-        ((<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-values> vars exp body)
+       (let ((nmax (recur exp)))
          (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)))
+               (max nmax (allocate! body proc n))
+               (let ((v (if (pair? vars) (car vars) vars)))
+                 (let ((v (car vars)))
                    (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))
-                 (let ((v (if (pair? vars) (car vars) vars)))
-                   (let ((binder (hashq-ref heaps v)))
-                     (hashq-set!
-                      allocation v
-                      (if binder
-                          (cons* 'heap level (allocate-heap! binder))
-                          (cons 'stack n)))
-                     (lp (if (pair? vars) (cdr vars) '())
-                         (if binder n (1+ n)))))))))
-        
-        (else n)))
+                    (make-hashq proc
+                                `(#t ,(hashq-ref assigned v) . ,n)))
+                   (lp (cdr vars) (1+ n))))))))
+      
+      (else n)))
 
-  (define parents (make-hash-table))
-  (define bindings (make-hash-table))
-  (define heaps (make-hash-table))
+  (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 -1)
-  (allocate! x -1 0)
+  
+  (analyze! x #f)
+  (allocate! x #f 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)
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index e0df038..bf46997 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/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)
-;;  lambda -> (nlocs . nexts)
+;;  sym -> {lambda -> address}
+;;  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)))
-           (case (car loc)
-             ((stack) (list id 'local (cdr loc)))
-             ((heap)  (list id 'external (cddr loc)))
-             (else (error "badness" id v loc)))))
+         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+           ((#t ,boxed? . ,n)
+            (list id boxed? n))
+           (,x (error "badness" x))))
        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)))
-          (nexts (cdr (hashq-ref allocation x))))
+    (let ((nlocs (car (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))))
-
-          ;; copy args to the heap if necessary
-          (let lp ((in vars) (n 0))
-            (if (not (null? in))
-                (let ((loc (hashq-ref allocation (car in))))
-                  (case (car loc)
-                    ((heap)
-                     (emit-code #f (make-glil-local 'ref n))
-                     (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
-                  (lp (cdr in) (1+ n)))))
-
+          ;; box args if necessary
+          (for-each
+           (lambda (v)
+             (pmatch (hashq-ref (hashq-ref allocation v) x)
+               ((#t #t . ,n)
+                (emit-code #f (make-glil-lexical #t #f 'ref n))
+                (emit-code #f (make-glil-lexical #t #t 'box n)))))
+           vars)
           ;; 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)))
-            (case (car loc)
-              ((stack)
-               (emit-code src (make-glil-local 'ref (cdr loc))))
-              ((heap)
-               (emit-code src (make-glil-external
-                               'ref (- level (cadr loc)) (cddr loc))))
-              (else (error "badness" x loc)))
-            (if (eq? context 'tail)
-                (emit-code #f (make-glil-call 'return 1)))))))
-
+          (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+            ((,local? ,boxed? . ,index)
+             (emit-code src (make-glil-lexical local? boxed? 'ref index)))
+            (,loc
+             (error "badness" x loc)))))
+       (case 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)))
-         (case (car loc)
-           ((stack)
-            (emit-code src (make-glil-local 'set (cdr loc))))
-           ((heap)
-            (emit-code src (make-glil-external
-                            'set (- level (cadr loc)) (cddr loc))))
-           (else (error "badness" x loc))))
+       (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+         ((,local? ,boxed? . ,index)
+          (emit-code src (make-glil-lexical local? boxed? 'set index)))
+         (,loc
+          (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
-         ((push vals)
-          (emit-code #f (flatten-lambda x level allocation)))
-         ((tail)
-          (emit-code #f (flatten-lambda x level allocation))
-          (emit-code #f (make-glil-call 'return 1)))))
-
+       (let ((free-locs (cdr (hashq-ref allocation x))))
+         (case context
+           ((push vals tail)
+            (emit-code #f (flatten-lambda x allocation))
+            (if (not (null? free-locs))
+                (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)))
-                     (case (car loc)
-                       ((stack)
-                        (emit-code src (make-glil-local 'set (cdr loc))))
-                       ((heap)
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
-                       (else (error "badness" x loc)))))
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #f . ,n)
+                      (emit-code src (make-glil-lexical #t #f 'set n)))
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'box n)))
+                     (,loc (error "badness" x loc))))
                  (reverse vars))
        (comp-tail body)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src names vars vals body)
+       (for-each (lambda (v)
+                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                     ((#t #t . ,n)
+                      (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+                     (,loc (error "badness" x loc))))
+                 vars)
        (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)))
-                     (case (car loc)
-                       ((stack)
-                        (emit-code src (make-glil-local 'set (cdr loc))))
-                       ((heap)
-                        (emit-code src (make-glil-external 'set 0 (cddr loc))))
-                       (else (error "badness" x loc)))))
+                   (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)))
-                           (case (car loc)
-                             ((stack)
-                              (emit-code src (make-glil-local 'set (cdr loc))))
-                             ((heap)
-                              (emit-code src (make-glil-external 'set 0 (cddr 
loc))))
-                             (else (error "badness" x loc)))))
+                         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                           ((#t #f . ,n)
+                            (emit-code src (make-glil-lexical #t #f 'set n)))
+                           ((#t #t . ,n)
+                            (emit-code src (make-glil-lexical #t #t 'box n)))
+                           (,loc (error "badness" x loc))))
                        (reverse vars))
              (comp-tail body)
              (emit-code #f (make-glil-unbind))))))))))
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 311e35b..89d35bc 100644
--- a/module/scripts/compile.scm
+++ b/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'
 
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7e26609..8470f39 100644
--- a/module/system/base/compile.scm
+++ b/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))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
new file mode 100644
index 0000000..6b68c56
--- /dev/null
+++ b/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
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 6f45bd7..a99e1ba 100644
--- a/module/system/repl/command.scm
+++ b/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))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 33a1e1b..332cd61 100644
--- a/module/system/vm/frame.scm
+++ b/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  <address@hidden>
 ;;;
 ;;; 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
-           print-frame print-frame-chain-as-backtrace
-           frame-arguments frame-local-variables frame-external-variables
-           frame-environment
-           frame-variable-exists? frame-variable-ref frame-variable-set!
-           frame-object-name
-           frame-local-ref frame-external-link frame-local-set!
-           frame-return-address frame-program
-           frame-dynamic-link heap-frame?))
+            make-frame-chain
+            print-frame print-frame-chain-as-backtrace
+            frame-arguments frame-local-variables
+            frame-environment
+            frame-variable-exists? frame-variable-ref frame-variable-set!
+            frame-object-name
+            frame-local-ref frame-local-set!
+            frame-return-address frame-program
+            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)
-    (frame-external-ref frame (binding:index binding))
-    (frame-local-ref frame (binding:index binding))))
+  (let ((x (frame-local-ref frame (binding:index binding))))
+    (if (and (binding:boxed? binding) (variable? x))
+        (variable-ref x)
+        x)))
 
 (define (frame-binding-set! frame binding val)
-  (if (binding:extp binding)
-    (frame-external-set! frame (binding:index binding) val)
-    (frame-local-set! frame (binding:index binding) val)))
+  (if (binding:boxed? binding)
+      (let ((v (frame-local-ref frame binding)))
+        (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)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 9db4a75..755c606 100644
--- a/module/system/vm/program.scm
+++ b/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)
-  (list name extp index start end))
+(define (make-binding name boxed? 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))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 6ff09a7..d8165f2 100644
--- a/module/system/vm/trace.scm
+++ b/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)))
-      ((:e) (puts (vm-fetch-externals vm))))))
+      ((:l) (puts (vm-fetch-locals vm))))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)
diff --git a/test-suite/tests/asm-to-bytecode.test 
b/test-suite/tests/asm-to-bytecode.test
index 01ba846..33a2a45 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/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))
-      (if (= i (vector-length v))
-          newv
-          (let ((x (vector-ref v i)))
-            (u8vector-set! newv i (if (symbol? x)
-                                      (instruction->opcode x)
-                                      x))
-            (lp (1+ i)))))))
+  (let lp ((i 0) (out '()))
+    (if (= i (vector-length v))
+        (list->u8vector (reverse out))
+        (let ((x (vector-ref v i)))
+          (cond
+           ((symbol? x)
+            (lp (1+ i) (cons (instruction->opcode x) out)))
+           ((integer? x)
+            (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))
-               (list->vector
-                `(load-program
-                  3 2 1 0            ;; nargs, nrest, nlocs, nexts
-                  ,@(u32->u8-list 3) ;; len
-                  ,@(u32->u8-list 0) ;; metalen
-                  make-int8 3
-                  return)))
+    (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
+               #(load-program
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
+                 (uint32 3)     ;; len
+                 (uint32 0)     ;; metalen
+                 (uint32 0)     ;; padding
+                 make-int8 3
+                 return))
 
-    (comp-test '(load-program 3 2 1 0 () 3
-                              (load-program 3 2 1 0 () 3
+    ;; the nops are to pad meta to an 8-byte alignment. not strictly
+    ;; 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))
-               (list->vector
-                `(load-program
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
-                  ,@(u32->u8-list 3)        ;; len
-                  ,@(u32->u8-list (+ 3 12)) ;; metalen
-                  make-int8 3
-                  return
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
-                  ,@(u32->u8-list 3)        ;; len
-                  ,@(u32->u8-list 0)        ;; metalen
-                  make-int8 3
-                  return)))))
+                              (make-int8 3) (return)
+                              (nop) (nop) (nop) (nop) (nop))
+               #(load-program
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
+                 (uint32 8)     ;; len
+                 (uint32 19)    ;; metalen
+                 (uint32 0)     ;; padding
+                 make-int8 3
+                 return
+                 nop nop nop nop nop
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
+                 (uint32 3)     ;; len
+                 (uint32 0)     ;; metalen
+                 (uint32 0)     ;; padding
+                 make-int8 3
+                 return))))
diff --git a/test-suite/tests/elisp-compiler.test 
b/test-suite/tests/elisp-compiler.test
index 7e013b8..5a9f6fe 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -342,7 +342,29 @@
          (= (funcall c2) 1)
          (= (funcall c2) 2)
          (= (funcall c1) 4)
-         (= (funcall c2) 3))))
+         (= (funcall c2) 3)))
+
+  (pass-if "always lexical option (all)"
+    (progn (setq a 0)
+           (defun dyna () a)
+           (let ((a 1))
+             (and (= a 1) (= (dyna) 0))))
+    #:opts '(#:always-lexical all))
+  (pass-if "always lexical option (list)"
+    (progn (setq a 0 b 0)
+           (defun dyna () a)
+           (defun dynb () b)
+           (let ((a 1)
+                 (b 1))
+             (and (= a 1) (= (dyna) 0)
+                  (= b 1) (= (dynb) 1))))
+    #:opts '(#:always-lexical (a)))
+  (pass-if "with-always-lexical"
+    (progn (setq a 0)
+           (defun dyna () a)
+           (with-always-lexical (a)
+             (let ((a 1))
+               (and (= a 1) (= (dyna) 0)))))))
 
 (with-test-prefix/compile "defconst and defvar"
 
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ec410b5..896206b 100644
--- a/test-suite/tests/tree-il.test
+++ b/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 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (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 ()
-            (const 1) (bind (x local 0)) (local set 0)
+   (program 0 0 1 ()
+            (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 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (call null? 1) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (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 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (void) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (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 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (const #f) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (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 ()
-            (const 1) (bind (x external 0)) (external set 0 0)
-            (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (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 1 0 0 0 ()
-                     (bind (x local 0))
+   (program 0 0 0 ()
+            (program 1 0 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 2 0 0 0 ()
-                     (bind (x local 0) (x1 local 1))
+   (program 0 0 0 ()
+            (program 2 0 0 ()
+                     (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 1 1 0 0 ()
-                     (bind (x local 0))
+   (program 0 0 0 ()
+            (program 1 1 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 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
+   (program 0 0 0 ()
+            (program 2 1 0 ()
+                     (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 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
-                     (local ref 0) (call return 1))
+   (program 0 0 0 ()
+            (program 2 1 0 ()
+                     (bind (x #f 0) (x1 #f 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 2 1 0 0 ()
-                     (bind (x local 0) (x1 local 1))
-                     (local ref 1) (call return 1))
+   (program 0 0 0 ()
+            (program 2 1 0 ()
+                     (bind (x #f 0) (x1 #f 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 1 0 0 1 ()
-                     (bind (x external 0))
-                     (local ref 0) (external set 0 0)
-                     (program 1 0 0 0 ()
-                              (bind (y local 0))
-                              (external ref 1 0) (call return 1))
+   (program 0 0 0 ()
+            (program 1 0 0 ()
+                     (bind (x #f 0))
+                     (program 1 0 0 ()
+                              (bind (y #f 0))
+                              (lexical #f #f ref 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 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+   (program 0 0 1 ()
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 0)) (local set 0)
-            (local ref 0) (call return 1)
+            (const 2) (bind (a #f 0)) (lexical #t #f set 0)
+            (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 ()
-            (const 1) (bind (x local 0)) (local set 0)
-            (local ref 0) (branch br-if-not ,l1)
-            (local ref 0) (call return 1)
+   (program 0 0 2 ()
+            (const 1) (bind (x #f 0)) (lexical #t #f set 0)
+            (lexical #t #f ref 0) (branch br-if-not ,l1)
+            (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a local 1)) (local set 1)
-            (local ref 0) (call return 1)
+            (const 2) (bind (a #f 1)) (lexical #t #f set 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)))))))


hooks/post-receive
-- 
GNU Guile




reply via email to

[Prev in Thread] Current Thread [Next in Thread]