From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Aug 2001 01:27:17 +0000 (+0000)
Subject: Implement primitive to allow linking variables that have different
X-Git-Tag: 20090517-FFI~2613
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6f60945a6b97a46f88bb79d85c6e719d3bd972bb;p=mit-scheme.git

Implement primitive to allow linking variables that have different
names.  (Previously, linked variables were required to have the same
name.)  This requires a major redesign of the cache data structures,
and since the garbage collector knows about these structures, all of
the garbage-collector files are affected too.  The new data structures
have slightly different space requirements: a cache with no references
uses one word less than previously, while a cache with references uses
three words more than previously (independent of the number of
references).

This change requires Runtime 14.190 or later.
---

diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c
index de44a953c..6a7b45de9 100644
--- a/v7/src/microcode/bchdmp.c
+++ b/v7/src/microcode/bchdmp.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: bchdmp.c,v 9.88 2001/02/12 22:32:32 cph Exp $
+$Id: bchdmp.c,v 9.89 2001/08/07 01:25:20 cph Exp $
 
 Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
@@ -840,7 +841,7 @@ DEFUN (dump_loop, (scan, free_ptr, new_address_ptr),
 	    case REFERENCE_LINKAGE_KIND:
 	    case ASSIGNMENT_LINKAGE_KIND:
 	      {
-		/* `count' typeless pointers to quads follow. */
+		/* `count' typeless pointers to hunk3s follow. */
 		unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
 		scan += 1;
 		while (count > 0)
@@ -857,11 +858,10 @@ DEFUN (dump_loop, (scan, free_ptr, new_address_ptr),
 			(*free++) = (old_start[0]);
 			(*free++) = (old_start[1]);
 			(*free++) = (old_start[2]);
-			(*free++) = (old_start[3]);
 			MAYBE_DUMP_FREE (free);
 			(*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
 			(*old_start) = (MAKE_BROKEN_HEART (new_address));
-			new_address += 4;
+			new_address += 3;
 		      }
 		    count -= 1;
 		  }
diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c
index 2e7bbb342..71f662061 100644
--- a/v7/src/microcode/bchgcl.c
+++ b/v7/src/microcode/bchgcl.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: bchgcl.c,v 9.52 2001/02/12 22:32:20 cph Exp $
+$Id: bchgcl.c,v 9.53 2001/08/07 01:25:26 cph Exp $
 
 Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This is the main GC loop for bchscheme.  */
@@ -460,7 +461,7 @@ DEFUN (gc_loop,
 	    case REFERENCE_LINKAGE_KIND:
 	    case ASSIGNMENT_LINKAGE_KIND:
 	      {
-		/* `count' typeless pointers to quads follow. */
+		/* `count' typeless pointers to hunk3s follow. */
 		unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
 		scan += 1;
 		while (count > 0)
@@ -478,11 +479,10 @@ DEFUN (gc_loop,
 			(*free++) = (old_start[0]);
 			(*free++) = (old_start[1]);
 			(*free++) = (old_start[2]);
-			(*free++) = (old_start[3]);
 			MAYBE_DUMP_FREE (free);
 			(*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
 			(*old_start) = (MAKE_BROKEN_HEART (new_address));
-			new_address += 4;
+			new_address += 3;
 		      }
 		    count -= 1;
 		  }
diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c
index 1b0415f37..a119d0dc8 100644
--- a/v7/src/microcode/bintopsb.c
+++ b/v7/src/microcode/bintopsb.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: bintopsb.c,v 9.72 2000/12/05 21:23:43 cph Exp $
+$Id: bintopsb.c,v 9.73 2001/08/07 01:25:37 cph Exp $
 
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This File contains the code to translate internal format binary
@@ -718,7 +719,7 @@ DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
     }									\
 } while (0)
 
-#define DO_RAW_QUAD(Code, Rel, Fre, Scn, Obj, FObj) do			\
+#define DO_RAW_TRIPLE(Code, Rel, Fre, Scn, Obj, FObj) do		\
 {									\
   Old_Address += (Rel);							\
   Old_Contents = (* Old_Address);					\
@@ -731,7 +732,6 @@ DEFUN (print_a_flonum, (src), SCHEME_OBJECT * src)
       (Mem_Base [(Fre)++]) = Old_Contents;				\
       (Mem_Base [(Fre)++]) = (*Old_Address++);				\
       (Mem_Base [(Fre)++]) = (*Old_Address++);				\
-      (Mem_Base [(Fre)++]) = (*Old_Address++);				\
     }									\
 } while (0)
 
@@ -1312,7 +1312,7 @@ DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
 	      *Area += 1;
 	      while (--count >= 0)
 	      {
-		DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_QUAD);
+		DO_RAW_POINTER (Mem_Base[*Area], *Area, DO_RAW_TRIPLE);
 		*Area += 1;
 	      }
 	      break;
@@ -1701,12 +1701,12 @@ DEFUN (print_objects, (from, to),
 		     ((long) count));
 	    while (--count >= 0)
 	    {
-	      unsigned long the_quad = ((unsigned long) *from++);
+	      unsigned long the_triple = ((unsigned long) *from++);
 
 	      fprintf (portable_file, "%02x %lx %lx\n",
 		       TC_C_COMPILED_TAG,
-		       ((long) C_COMPILED_RAW_QUAD),
-		       the_quad);
+		       ((long) C_COMPILED_RAW_TRIPLE),
+		       the_triple);
 	    }
 	    break;
 	  }
diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c
index 8f9bc5838..f9d7650ca 100644
--- a/v7/src/microcode/cmpint.c
+++ b/v7/src/microcode/cmpint.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: cmpint.c,v 1.93 2001/07/31 03:11:12 cph Exp $
+$Id: cmpint.c,v 1.94 2001/08/07 01:25:51 cph Exp $
 
 Copyright (c) 1989-2001 Massachusetts Institute of Technology
 
@@ -1427,11 +1427,13 @@ DEFNX (comutil_operator_lookup_trap,
        long ignore_4)
 {
   SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+  SCHEME_OBJECT cache = (tramp_data[0]);
+  SCHEME_OBJECT block = (tramp_data[1]);
+  unsigned long offset = (OBJECT_DATUM (tramp_data[2]));
   SCHEME_OBJECT true_operator;
   long code
-    = (compiler_operator_reference_trap ((tramp_data[0]), (&true_operator)));
-  SCHEME_OBJECT * cache_cell
-    = (MEMORY_LOC ((tramp_data[1]), (OBJECT_DATUM (tramp_data[2]))));
+    = (compiler_operator_reference_trap (cache, (&true_operator)));
+  SCHEME_OBJECT * cache_cell = (MEMORY_LOC (block, offset));
   long nargs;
 
   EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
@@ -1442,13 +1444,13 @@ DEFNX (comutil_operator_lookup_trap,
     SCHEME_OBJECT trampoline;
 
     /* This could be done by bumping tramp_data to the entry point.
-	 It would probably be better.  */
+       It would probably be better.  */
     EXTRACT_EXECUTE_CACHE_ADDRESS (trampoline, cache_cell);
     STACK_PUSH (ENTRY_TO_OBJECT (SCHEME_ADDR_TO_ADDR (trampoline)));
     /* Next three for debugger.  */
     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
-    STACK_PUSH (compiled_block_environment (tramp_data[1]));
-    STACK_PUSH (compiler_var_error (tramp_data[0]));
+    STACK_PUSH (compiled_block_environment (block));
+    STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
     Store_Expression (SHARP_F);
     Store_Return (RC_COMP_OP_REF_TRAP_RESTART);
     Save_Cont ();
@@ -1776,27 +1778,29 @@ DEFUN_VOID (comp_interrupt_restart)
 
 SCHEME_UTILITY utility_result
 DEFNX (comutil_assignment_trap,
-       (return_address_raw, extension_addr_raw, value, ignore_4),
+       (return_address_raw, cache_addr_raw, value, ignore_4),
        SCHEME_ADDR return_address_raw AND
-       SCHEME_ADDR extension_addr_raw AND
+       SCHEME_ADDR cache_addr_raw AND
        SCHEME_OBJECT value AND
        long ignore_4)
 {
   instruction * return_address
     = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));
-  SCHEME_OBJECT extension
+  SCHEME_OBJECT cache
     = (MAKE_POINTER_OBJECT
-       (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw))));
-  long code = (compiler_assignment_trap (extension, value, (&Val)));
+       (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw))));
+  long code = (compiler_assignment_trap (cache, value, (&Val)));
   if (code == PRIM_DONE)
     RETURN_TO_SCHEME (return_address);
   else
     {
       SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address));
+      SCHEME_OBJECT block = (compiled_entry_to_block (sra));
       STACK_PUSH (sra);
       STACK_PUSH (value);
-      STACK_PUSH (compiled_block_environment (compiled_entry_to_block (sra)));
-      STACK_PUSH (compiler_var_error (extension));
+      STACK_PUSH (compiled_block_environment (block));
+      STACK_PUSH
+	(compiler_var_error (cache, block, CACHE_REFERENCES_ASSIGNMENT));
       Store_Expression (SHARP_F);
       Store_Return (RC_COMP_ASSIGNMENT_TRAP_RESTART);
       Save_Cont ();
@@ -1827,28 +1831,27 @@ DEFUN_VOID (comp_assignment_trap_restart)
 
 SCHEME_UTILITY utility_result
 DEFNX (comutil_cache_lookup_apply,
-       (extension_addr_raw, block_address_raw, nactuals, ignore_4),
-       SCHEME_ADDR extension_addr_raw AND
+       (cache_addr_raw, block_address_raw, nactuals, ignore_4),
+       SCHEME_ADDR cache_addr_raw AND
        SCHEME_ADDR block_address_raw AND
        long nactuals AND
        long ignore_4)
 {
-  SCHEME_OBJECT extension
+  SCHEME_OBJECT cache
     = (MAKE_POINTER_OBJECT
-       (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw))));
+       (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw))));
   SCHEME_OBJECT value;
-  long code = (compiler_lookup_trap (extension, (&value)));
+  long code = (compiler_lookup_trap (cache, (&value)));
   if (code == PRIM_DONE)
     return (comutil_apply (value, nactuals, 0, 0));
   {
     SCHEME_OBJECT block
       = (MAKE_CC_BLOCK (SCHEME_ADDR_TO_ADDR (block_address_raw)));
-    SCHEME_OBJECT environment = (compiled_block_environment (block));
-    SCHEME_OBJECT name = (compiler_var_error (extension));
     STACK_PUSH (block);
     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
-    STACK_PUSH (environment);
-    STACK_PUSH (name);
+    STACK_PUSH (compiled_block_environment (block));
+    STACK_PUSH
+      (compiler_var_error (cache, block, CACHE_REFERENCES_OPERATOR));
     Store_Expression (SHARP_F);
     Store_Return (RC_COMP_CACHE_REF_APPLY_RESTART);
     Save_Cont ();
@@ -1890,28 +1893,29 @@ DEFUN_VOID (comp_cache_lookup_apply_restart)
 #define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup)	\
 SCHEME_UTILITY utility_result						\
 DEFNX (name,								\
-       (return_address_raw, extension_addr_raw, ignore_3, ignore_4),	\
+       (return_address_raw, cache_addr_raw, ignore_3, ignore_4),	\
        SCHEME_ADDR return_address_raw AND				\
-       SCHEME_ADDR extension_addr_raw AND				\
+       SCHEME_ADDR cache_addr_raw AND					\
        long ignore_3 AND						\
        long ignore_4)							\
 {									\
   instruction * return_address						\
     = ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));	\
-  SCHEME_OBJECT extension						\
+  SCHEME_OBJECT cache							\
     = (MAKE_POINTER_OBJECT						\
-       (TC_QUAD, (SCHEME_ADDR_TO_ADDR (extension_addr_raw))));		\
-  long code = (c_trap (extension, (&Val)));				\
+       (CACHE_TYPE, (SCHEME_ADDR_TO_ADDR (cache_addr_raw))));		\
+  long code = (c_trap (cache, (&Val)));					\
   if (code == PRIM_DONE)						\
     RETURN_TO_SCHEME (return_address);					\
   else									\
     {									\
       SCHEME_OBJECT sra = (ENTRY_TO_OBJECT (return_address));		\
+      SCHEME_OBJECT block = (compiled_entry_to_block (sra));		\
       STACK_PUSH (sra);							\
+      STACK_PUSH (compiled_block_environment (block));			\
       STACK_PUSH							\
-	(compiled_block_environment					\
-	 (compiled_entry_to_block (sra)));				\
-      STACK_PUSH (compiler_var_error (extension));			\
+	(compiler_var_error						\
+	 (cache, block, CACHE_REFERENCES_LOOKUP));			\
       Store_Expression (SHARP_F);					\
       Store_Return (ret_code);						\
       Save_Cont ();							\
diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c
index 70402768d..d1b14c0ca 100644
--- a/v7/src/microcode/fasdump.c
+++ b/v7/src/microcode/fasdump.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: fasdump.c,v 9.64 2000/12/05 21:23:44 cph Exp $
+$Id: fasdump.c,v 9.65 2001/08/07 01:25:59 cph Exp $
 
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This file contains code for fasdump and dump-band. */
@@ -236,7 +237,7 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode)
 	    {
 	      Temp = (* Scan);
 	      DUMP_RAW_POINTER (Fasdump_Setup_Pointer
-				(TRANSPORT_RAW_QUADRUPLE (),
+				(TRANSPORT_RAW_TRIPLE (),
 				 RAW_BH (false, continue)));
 	    }
 	    Scan -= 1;
diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c
index 9cf356dd1..4d40fba68 100644
--- a/v7/src/microcode/fasload.c
+++ b/v7/src/microcode/fasload.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: fasload.c,v 9.89 2001/07/31 03:11:26 cph Exp $
+$Id: fasload.c,v 9.90 2001/08/07 01:26:05 cph Exp $
 
 Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
@@ -465,9 +465,8 @@ DEFUN (Relocate_Block, (Scan, Stop_At),
 	  case REFERENCE_LINKAGE_KIND:
 	  case ASSIGNMENT_LINKAGE_KIND:
 	  {
-	    /* Assumes that all others are objects of type TC_QUAD without
-	       their type codes.
-	       */
+	    /* Assumes that all others are objects of type TC_HUNK3
+	       without their type codes.  */
 
 	    fast long count;
 
diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h
index f48920f61..840271110 100644
--- a/v7/src/microcode/gccode.h
+++ b/v7/src/microcode/gccode.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: gccode.h,v 9.57 2000/12/05 21:23:44 cph Exp $
+$Id: gccode.h,v 9.58 2001/08/07 01:26:09 cph Exp $
 
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This file contains the macros for use in code which does GC-like
@@ -351,25 +352,22 @@ extern SCHEME_OBJECT * gc_objects_referencing_end;
   Pointer_End ();							\
 }
 
-#define TRANSPORT_QUADRUPLE_INTERNAL()					\
+#define TRANSPORT_RAW_TRIPLE()						\
 {									\
-  TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
   TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
   TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
   TRANSPORT_ONE_THING ((*To++) = (*Old));				\
+  RAW_POINTER_END ();							\
 }
 
 #define Transport_Quadruple()						\
 {									\
-  TRANSPORT_QUADRUPLE_INTERNAL ();					\
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
+  TRANSPORT_ONE_THING ((*To++) = (*Old++));				\
+  TRANSPORT_ONE_THING ((*To++) = (*Old));				\
   Pointer_End ();							\
 }
-
-#define TRANSPORT_RAW_QUADRUPLE()					\
-{									\
-  TRANSPORT_QUADRUPLE_INTERNAL ();					\
-  RAW_POINTER_END ();							\
-}
 
 #ifndef In_Fasdump
 
diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c
index 7b73df934..6e2a11abe 100644
--- a/v7/src/microcode/gcloop.c
+++ b/v7/src/microcode/gcloop.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: gcloop.c,v 9.47 2000/12/05 21:23:44 cph Exp $
+$Id: gcloop.c,v 9.48 2001/08/07 01:26:14 cph Exp $
 
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* 
@@ -175,7 +176,7 @@ DEFUN (GCLoop,
 	    {
 	      Temp = (* Scan);
 	      GC_RAW_POINTER (Setup_Internal (true,
-					      TRANSPORT_RAW_QUADRUPLE (),
+					      TRANSPORT_RAW_TRIPLE (),
 					      RAW_BH (true, continue)));
 	    }
 	    Scan -= 1;
diff --git a/v7/src/microcode/lookprm.c b/v7/src/microcode/lookprm.c
index d98643aec..9a40a66bf 100644
--- a/v7/src/microcode/lookprm.c
+++ b/v7/src/microcode/lookprm.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: lookprm.c,v 1.14 2001/08/02 04:30:03 cph Exp $
+$Id: lookprm.c,v 1.15 2001/08/07 01:26:22 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -168,7 +168,26 @@ If SYMBOL is already bound in ENV1, the existing binding is modified.")
   CHECK_ARG (1, ENVIRONMENT_P);
   CHECK_ARG (2, ENVIRONMENT_P);
   CHECK_ARG (3, SYMBOL_P);
-  STD_LOOKUP (link_variable ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
+  STD_LOOKUP
+    (link_variables ((ARG_REF (1)), (ARG_REF (3)),
+		     (ARG_REF (2)), (ARG_REF (3))));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("LINK-VARIABLES", Prim_link_variables, 4, 4,
+		  "(TARGET-ENV TARGET-NAME SOURCE-ENV SOURCE-NAME)\n
+Define a new binding for TARGET-NAME in TARGET-ENV, which shares its\n
+value cell with the binding for SOURCE-NAME in SOURCE-ENV.\n
+SOURCE-NAME must be bound in SOURCE-ENV.")
+{
+  PRIMITIVE_HEADER (4);
+  CHECK_ARG (1, ENVIRONMENT_P);
+  CHECK_ARG (2, SYMBOL_P);
+  CHECK_ARG (3, ENVIRONMENT_P);
+  CHECK_ARG (4, SYMBOL_P);
+  STD_LOOKUP
+    (link_variables ((ARG_REF (1)), (ARG_REF (2)),
+		     (ARG_REF (3)), (ARG_REF (4))));
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
 
diff --git a/v7/src/microcode/lookup.c b/v7/src/microcode/lookup.c
index e5b208be0..3710a9397 100644
--- a/v7/src/microcode/lookup.c
+++ b/v7/src/microcode/lookup.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: lookup.c,v 9.63 2001/08/04 02:46:14 cph Exp $
+$Id: lookup.c,v 9.64 2001/08/07 01:26:29 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -46,11 +46,12 @@ extern SCHEME_OBJECT compiled_block_environment
 #  define SPACE_PER_UUO_LINK 10
 #endif
 
-/* Cache objects are 4-tuples.  */
-#define SPACE_PER_CACHE 4
+/* Cache objects are 3-tuples.  */
+#define SPACE_PER_CACHE 3
 
-/* Each reference uses a pair and a weak pair.  */
-#define SPACE_PER_REFERENCE 4
+/* Each reference uses a pair and a weak pair, and potentially two
+   more pairs if the reference introduces a new name.  */
+#define SPACE_PER_REFERENCE 8
 
 #define RETURN_IF_ERROR(expression)					\
 {									\
@@ -88,6 +89,32 @@ extern SCHEME_OBJECT compiled_block_environment
    : (value))
 
 #define EXTERNAL_UNASSIGNED_OBJECT (Get_Fixed_Obj_Slot (Non_Object))
+
+#define WALK_REFERENCES(refs_pointer, ref_var, body)			\
+{									\
+  SCHEME_OBJECT * WR_palist = (refs_pointer);				\
+  while (PAIR_P (*WR_palist))						\
+    {									\
+      SCHEME_OBJECT * WR_prefs						\
+	= (PAIR_CDR_LOC (PAIR_CAR (*WR_palist)));			\
+      while (PAIR_P (*WR_prefs))					\
+	{								\
+	  SCHEME_OBJECT ref_var = (PAIR_CAR (*WR_prefs));		\
+	  if ((GET_CACHE_REFERENCE_BLOCK (ref_var))			\
+	      == SHARP_F)						\
+	    (*WR_prefs) = (PAIR_CDR (*WR_prefs));			\
+	  else								\
+	    {								\
+	      body;							\
+	      WR_prefs = (PAIR_CDR_LOC (*WR_prefs));			\
+	    }								\
+	}								\
+      if (PAIR_P (PAIR_CDR (PAIR_CAR (*WR_palist))))			\
+	WR_palist = (PAIR_CDR_LOC (*WR_palist));			\
+      else								\
+	(*WR_palist) = (PAIR_CDR (*WR_palist));				\
+    }									\
+}
 
 /***** Forward References *****/
 
@@ -99,32 +126,34 @@ static long assign_variable_cache
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *, int);
 static long update_uuo_links
   (SCHEME_OBJECT, SCHEME_OBJECT);
+static long guarantee_extension_space
+  (SCHEME_OBJECT);
 static long allocate_frame_extension
   (unsigned long, SCHEME_OBJECT, SCHEME_OBJECT *);
-static int unbind_extension_variable
-  (SCHEME_OBJECT, SCHEME_OBJECT);
+static void move_all_references
+  (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int);
+static long unbind_cached_variable
+  (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
+static void unbind_variable_1
+  (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
 static long add_cache_reference
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
-static long add_reference
-  (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, unsigned long);
-static long install_cache
+static void add_reference
+  (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
+static void install_cache
   (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long, unsigned int);
-static long install_operator_cache
+static void install_operator_cache
   (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
-static long update_cache_for_define
-  (SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
-static long update_cache_for_unbind
-  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
+static unsigned long update_cache_refs_space
+  (SCHEME_OBJECT, SCHEME_OBJECT);
 static long update_cache_references
-  (SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT, SCHEME_OBJECT);
-static void split_cache_references
-  (SCHEME_OBJECT, unsigned int, SCHEME_OBJECT, SCHEME_OBJECT **);
-static int environment_ancestor_or_self_p
+  (SCHEME_OBJECT, SCHEME_OBJECT *, SCHEME_OBJECT);
+static unsigned long ref_pairs_to_move
+  (SCHEME_OBJECT *, SCHEME_OBJECT, unsigned long *);
+static void move_ref_pairs
+  (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int, SCHEME_OBJECT);
+static int move_ref_pair_p
   (SCHEME_OBJECT, SCHEME_OBJECT);
-static long move_cache_references
-  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT **);
-static void move_cache_references_1
-  (SCHEME_OBJECT, SCHEME_OBJECT **, unsigned int);
 static SCHEME_OBJECT * find_binding_cell
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
 static SCHEME_OBJECT * scan_frame
@@ -133,17 +162,16 @@ static SCHEME_OBJECT * scan_procedure_bindings
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, int);
 static unsigned long count_references
   (SCHEME_OBJECT *);
-static SCHEME_OBJECT * find_tail_holder
-  (SCHEME_OBJECT *);
+static SCHEME_OBJECT * find_references_named
+  (SCHEME_OBJECT *, SCHEME_OBJECT);
 static void update_assignment_references
   (SCHEME_OBJECT);
 static long guarantee_cache
-  (SCHEME_OBJECT *, SCHEME_OBJECT);
-static long update_clone
+  (SCHEME_OBJECT *);
+static void update_clone
   (SCHEME_OBJECT);
 static long make_cache
-  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT,
-   SCHEME_OBJECT *);
+  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
 static long make_cache_reference
   (SCHEME_OBJECT, unsigned long, SCHEME_OBJECT *);
 
@@ -367,22 +395,20 @@ assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value,
 static long
 update_uuo_links (SCHEME_OBJECT cache, SCHEME_OBJECT new_value)
 {
-  RETURN_IF_ERROR (update_clone (cache));
   GC_CHECK
-    ((count_references (GET_CACHE_OPERATOR_REFERENCES (cache)))
-     * SPACE_PER_UUO_LINK);
+    (((count_references (GET_CACHE_OPERATOR_REFERENCES (cache)))
+      * SPACE_PER_UUO_LINK)
+     + SPACE_PER_CACHE);
   SET_CACHE_VALUE (cache, new_value);
-  {
-    SCHEME_OBJECT operators = (* (GET_CACHE_OPERATOR_REFERENCES (cache)));
-    while (PAIR_P (operators))
-      {
-	SCHEME_OBJECT reference = (PAIR_CAR (operators));
-	SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference));
-	unsigned long offset = (GET_CACHE_REFERENCE_OFFSET (reference));
-	DIE_IF_ERROR (install_operator_cache (cache, block, offset));
-	operators = (PAIR_CDR (operators));
-      }
-  }
+  update_clone (cache);
+  WALK_REFERENCES
+    ((GET_CACHE_OPERATOR_REFERENCES (cache)),
+     reference,
+     {
+       install_operator_cache (cache,
+			       (GET_CACHE_REFERENCE_BLOCK (reference)),
+			       (GET_CACHE_REFERENCE_OFFSET (reference)));
+     });
   return (PRIM_DONE);
 }
 
@@ -401,6 +427,51 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
       return (assign_variable_end (cell, value, (&old_value), 1));
   }
 
+  /* At this point, we know that environment can't be the global
+     environment, because scan_frame would have returned a non-null
+     pointer for the global environment.  */
+
+  RETURN_IF_ERROR (guarantee_extension_space (environment));
+
+  /* If this binding shadows another binding, we'll have to recache
+     any references to the other binding, because some of them might
+     now refer to the new binding instead.  */
+  {
+    SCHEME_OBJECT * shadowed_cell
+      = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0));
+    SCHEME_OBJECT old_cache
+      = (((shadowed_cell != 0)
+	  && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED))
+	 ? (GET_TRAP_CACHE (*shadowed_cell))
+	 : SHARP_F);
+    unsigned long length = (GET_EXTENDED_FRAME_LENGTH (environment));
+    SCHEME_OBJECT pair;
+
+    /* Make sure there is enough space available to move any
+       references that need moving.  */
+    GC_CHECK
+      (2
+       + ((old_cache != SHARP_F)
+	  ? (update_cache_refs_space (old_cache, environment))
+	  : 0));
+
+    /* Create the binding.  */
+    pair = (cons (symbol, value));
+    ((GET_EXTENDED_FRAME_BINDINGS (environment)) [length]) = pair;
+    SET_EXTENDED_FRAME_LENGTH (environment, (length + 1));
+
+    /* Move any references that need moving.  */
+    return
+      ((old_cache != SHARP_F)
+       ? (update_cache_references
+	  (old_cache, (PAIR_CDR_LOC (pair)), environment))
+       : PRIM_DONE);
+  }
+}
+
+static long
+guarantee_extension_space (SCHEME_OBJECT environment)
+{
   if (EXTENDED_FRAME_P (environment))
     /* Guarantee that there is room in the extension for a binding.  */
     {
@@ -430,23 +501,7 @@ define_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
 				   (&extension)));
       SET_FRAME_EXTENSION (environment, extension);
     }
-
-  /* Create the binding.  */
-  GC_CHECK (2);
-  {
-    SCHEME_OBJECT pair = (cons (symbol, value));
-    unsigned long length = (GET_EXTENDED_FRAME_LENGTH (environment));
-    ((GET_EXTENDED_FRAME_BINDINGS (environment)) [length]) = pair;
-    SET_EXTENDED_FRAME_LENGTH (environment, (length + 1));
-
-    /* If this binding shadows another binding, we'll have to
-       recache any references to the other binding, because some of
-       them might now refer to the new binding instead.  */
-    return
-      ((PROCEDURE_FRAME_P (environment))
-       ? (update_cache_for_define ((PAIR_CDR_LOC (pair)), environment, symbol))
-       : PRIM_DONE);
-  }
+  return (PRIM_DONE);
 }
 
 static long
@@ -467,17 +522,18 @@ allocate_frame_extension (unsigned long length, SCHEME_OBJECT procedure,
 }
 
 long
-link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source,
-	       SCHEME_OBJECT symbol)
+link_variables (SCHEME_OBJECT target_environment, SCHEME_OBJECT target_symbol,
+		SCHEME_OBJECT source_environment, SCHEME_OBJECT source_symbol)
 {
   SCHEME_OBJECT * source_cell;
   trap_kind_t source_kind;
   SCHEME_OBJECT * target_cell;
   
-  if (! ((ENVIRONMENT_P (target)) && (ENVIRONMENT_P (source))))
+  if (! ((ENVIRONMENT_P (target_environment))
+	 && (ENVIRONMENT_P (source_environment))))
     return (ERR_BAD_FRAME);
 
-  source_cell = (find_binding_cell (source, symbol, 0));
+  source_cell = (find_binding_cell (source_environment, source_symbol, 0));
   if (source_cell == 0)
     return (ERR_UNBOUND_VARIABLE);
 
@@ -485,7 +541,7 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source,
   if (source_kind == TRAP_UNBOUND)
     return (ERR_UNBOUND_VARIABLE);
 
-  target_cell = (scan_frame (target, symbol, 1));
+  target_cell = (scan_frame (target_environment, target_symbol, 1));
   if ((target_cell != 0)
       && ((get_trap_kind (*target_cell)) == TRAP_COMPILER_CACHED))
     {
@@ -493,16 +549,19 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source,
       if (source_kind == TRAP_COMPILER_CACHED)
 	{
 	  SCHEME_OBJECT source_cache = (GET_TRAP_CACHE (*source_cell));
-	  SCHEME_OBJECT * tail_holders [3];
-	  (tail_holders[CACHE_REFERENCES_LOOKUP])
-	    = (GET_CACHE_LOOKUP_REFERENCES (source_cache));
-	  (tail_holders[CACHE_REFERENCES_ASSIGNMENT])
-	    = (GET_CACHE_ASSIGNMENT_REFERENCES (source_cache));
-	  (tail_holders[CACHE_REFERENCES_OPERATOR])
-	    = (GET_CACHE_OPERATOR_REFERENCES (source_cache));
-	  RETURN_IF_ERROR
-	    (move_cache_references (source_cache, target_cache, tail_holders));
+	  GC_CHECK
+	    (((count_references (GET_CACHE_OPERATOR_REFERENCES (target_cache)))
+	      * SPACE_PER_UUO_LINK)
+	     + (2 * SPACE_PER_CACHE));
 	  SET_CACHE_VALUE (target_cache, (GET_CACHE_VALUE (source_cache)));
+	  move_all_references
+	    (source_cache, target_cache, CACHE_REFERENCES_LOOKUP);
+	  move_all_references
+	    (source_cache, target_cache, CACHE_REFERENCES_ASSIGNMENT);
+	  move_all_references
+	    (source_cache, target_cache, CACHE_REFERENCES_OPERATOR);
+	  update_clone (source_cache);
+	  update_clone (target_cache);
 	}
       else
 	SET_CACHE_VALUE (target_cache, (*source_cell));
@@ -510,8 +569,29 @@ link_variable (SCHEME_OBJECT target, SCHEME_OBJECT source,
       return (PRIM_DONE);
     }
 
-  RETURN_IF_ERROR (guarantee_cache (source_cell, symbol));
-  return (define_variable (target, symbol, (*source_cell)));
+  RETURN_IF_ERROR (guarantee_cache (source_cell));
+  return (define_variable (target_environment, target_symbol, (*source_cell)));
+}
+
+static void
+move_all_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache,
+		     unsigned int reference_kind)
+{
+  SCHEME_OBJECT * palist = (GET_CACHE_REFERENCES (to_cache, reference_kind));
+  {
+    SCHEME_OBJECT * pf = (GET_CACHE_REFERENCES (from_cache, reference_kind));
+    (*palist) = (*pf);
+    (*pf) = EMPTY_LIST;
+  }
+  WALK_REFERENCES
+    (palist,
+     reference,
+     {
+       install_cache (to_cache,
+		      (GET_CACHE_REFERENCE_BLOCK (reference)),
+		      (GET_CACHE_REFERENCE_OFFSET (reference)),
+		      reference_kind);
+     });
 }
 
 long
@@ -528,8 +608,7 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
 
     case NON_TRAP_KIND:
     case TRAP_UNASSIGNED:
-      if (!unbind_extension_variable (frame, symbol))
-	(*cell) = UNBOUND_OBJECT;
+      unbind_variable_1 (cell, frame, symbol);
       (*value_ret) = SHARP_T;
       return (PRIM_DONE);
 
@@ -546,10 +625,8 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
 	  case TRAP_UNASSIGNED:
 	    if (PROCEDURE_FRAME_P (frame))
 	      {
-		if (!unbind_extension_variable (frame, symbol))
-		  (*cell) = UNBOUND_OBJECT;
 		RETURN_IF_ERROR
-		  (update_cache_for_unbind (cache, frame, symbol));
+		  (unbind_cached_variable (cell, frame, symbol));
 	      }
 	    else
 	      {
@@ -567,9 +644,27 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
       return (ERR_ILLEGAL_REFERENCE_TRAP);
     }
 }
+
+static long
+unbind_cached_variable (SCHEME_OBJECT * cell, SCHEME_OBJECT frame,
+			SCHEME_OBJECT symbol)
+{
+  SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell));
+  SCHEME_OBJECT * shadowed_cell
+    = (find_binding_cell ((GET_FRAME_PARENT (frame)), symbol, 0));
+  SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT;
+  GC_CHECK (update_cache_refs_space (cache, frame));
+  unbind_variable_1 (cell, frame, symbol);
+  return
+    (update_cache_references
+     (cache,
+      ((shadowed_cell == 0) ? (&dummy_cell) : shadowed_cell),
+      frame));
+}
 
-static int
-unbind_extension_variable (SCHEME_OBJECT frame, SCHEME_OBJECT symbol)
+static void
+unbind_variable_1 (SCHEME_OBJECT * cell,
+		   SCHEME_OBJECT frame, SCHEME_OBJECT symbol)
 {
   if ((PROCEDURE_FRAME_P (frame)) && (EXTENDED_FRAME_P (frame)))
     {
@@ -584,12 +679,12 @@ unbind_extension_variable (SCHEME_OBJECT frame, SCHEME_OBJECT symbol)
 		(start[index]) = (start [length - 1]);
 	      SET_EXTENDED_FRAME_LENGTH (frame, (length - 1));
 	      (start [length - 1]) = SHARP_F;
-	      return (1);
+	      return;
 	    }
 	  index += 1;
 	}
     }
-  return (0);
+  (*cell) = UNBOUND_OBJECT;
 }
 
 /***** Interface to compiled code.  *****/
@@ -635,9 +730,17 @@ compiler_cache_global_operator (SCHEME_OBJECT name, SCHEME_OBJECT block,
 }
 
 SCHEME_OBJECT
-compiler_var_error (SCHEME_OBJECT cache)
+compiler_var_error (SCHEME_OBJECT cache, SCHEME_OBJECT block,
+		    unsigned int reference_kind)
 {
-  return (GET_CACHE_NAME (cache));
+  WALK_REFERENCES
+    ((GET_CACHE_REFERENCES (cache, reference_kind)),
+     reference,
+     {
+       if ((GET_CACHE_REFERENCE_BLOCK (reference)) == block)
+	 return (PAIR_CAR (PAIR_CAR (*WR_palist)));
+     });
+  return (SHARP_F);
 }
 
 long
@@ -757,54 +860,66 @@ add_cache_reference (SCHEME_OBJECT environment, SCHEME_OBJECT symbol,
      consistent, so we do a GC check in advance to guarantee that all
      of the allocations will finish.  */
   GC_CHECK ((2 * SPACE_PER_CACHE) + SPACE_PER_REFERENCE + SPACE_PER_UUO_LINK);
-  RETURN_IF_ERROR (guarantee_cache (cell, symbol));
+  DIE_IF_ERROR (guarantee_cache (cell));
   {
     SCHEME_OBJECT cache = (GET_TRAP_CACHE (*cell));
-    RETURN_IF_ERROR (add_reference (cache, reference_kind, block, offset));
-    RETURN_IF_ERROR (update_clone (cache));
-    return (install_cache (cache, block, offset, reference_kind));
+    add_reference
+      ((GET_CACHE_REFERENCES (cache, reference_kind)), symbol, block, offset);
+    update_clone (cache);
+    install_cache (cache, block, offset, reference_kind);
   }
+  return (PRIM_DONE);
 }
 
 /* Add a new cached reference to the cached reference list pointed at
    by slot.  Attempt to reuse pairs which have been "emptied" by the
    garbage collector.  */
 
-static long
-add_reference (SCHEME_OBJECT cache, unsigned int reference_kind,
-	       SCHEME_OBJECT block, unsigned long offset)
+static void
+add_reference (SCHEME_OBJECT * palist,
+	       SCHEME_OBJECT symbol, SCHEME_OBJECT block, unsigned long offset)
 {
-  SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind));
-  while (PAIR_P (*holder))
+  while (PAIR_P (*palist))
     {
-      SCHEME_OBJECT reference = (PAIR_CAR (*holder));
-      if ((GET_CACHE_REFERENCE_BLOCK (reference)) == SHARP_F)
+      if ((PAIR_CAR (PAIR_CAR (*palist))) == symbol)
 	{
-	  SET_CACHE_REFERENCE_BLOCK (reference, block);
-	  SET_CACHE_REFERENCE_OFFSET (reference, offset);
-	  return (PRIM_DONE);
+	  SCHEME_OBJECT * prefs = (PAIR_CDR_LOC (PAIR_CAR (*palist)));
+	  while (PAIR_P (*prefs))
+	    {
+	      if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (*prefs))) == SHARP_F)
+		{
+		  SET_CACHE_REFERENCE_BLOCK ((PAIR_CAR (*prefs)), block);
+		  SET_CACHE_REFERENCE_OFFSET ((PAIR_CAR (*prefs)), offset);
+		  return;
+		}
+	      prefs = (PAIR_CDR_LOC (*prefs));
+	    }
+	  {
+	    SCHEME_OBJECT reference;
+	    DIE_IF_ERROR (make_cache_reference (block, offset, (&reference)));
+	    (*prefs) = (cons (reference, EMPTY_LIST));
+	  }
+	  return;
 	}
-      holder = (PAIR_CDR_LOC (*holder));
+      palist = (PAIR_CDR_LOC (*palist));
     }
   {
     SCHEME_OBJECT reference;
-    RETURN_IF_ERROR (make_cache_reference (block, offset, (&reference)));
-    GC_CHECK (2);
-    (*holder) = (cons (reference, EMPTY_LIST));
+    DIE_IF_ERROR (make_cache_reference (block, offset, (&reference)));
+    (*palist)
+      = (cons ((cons (symbol, (cons (reference, EMPTY_LIST)))), EMPTY_LIST));
   }
-  return (PRIM_DONE);
 }
 
-static long
-install_cache (SCHEME_OBJECT cache,
-	       SCHEME_OBJECT block, unsigned long offset,
+static void
+install_cache (SCHEME_OBJECT cache, SCHEME_OBJECT block, unsigned long offset,
 	       unsigned int reference_kind)
 {
   switch (reference_kind)
     {
     case CACHE_REFERENCES_LOOKUP:
       store_variable_cache (cache, block, offset);
-      return (PRIM_DONE);
+      break;
 
     case CACHE_REFERENCES_ASSIGNMENT:
       store_variable_cache
@@ -813,136 +928,150 @@ install_cache (SCHEME_OBJECT cache,
 	  : cache),
 	 block,
 	 offset);
-      return (PRIM_DONE);
+      break;
 
     case CACHE_REFERENCES_OPERATOR:
-      return (install_operator_cache (cache, block, offset));
+      install_operator_cache (cache, block, offset);
+      break;
 
     default:
       abort ();
-      return (0);
+      break;
     }
 }
 
-static long
+static void
 install_operator_cache (SCHEME_OBJECT cache,
 			SCHEME_OBJECT block, unsigned long offset)
 {
   SCHEME_OBJECT value = (GET_CACHE_VALUE (cache));
-  return
+  DIE_IF_ERROR
     ((REFERENCE_TRAP_P (value))
      ? (make_fake_uuo_link (cache, block, offset))
      : (make_uuo_link (value, cache, block, offset)));
 }
 
-/* update_cache_for_define is invoked when a new binding is created.
-   It recaches (at the definition point) all the references that need
-   to point to the new cell.  update_cache_for_unbind is called when a
-   binding is removed.  It recaches references from the cache of the
-   now unbound variable.  Both procedures call
-   update_cache_references, which does the following:
-
-   First, split_cache_references is called to split all references
-   into those that need to be updated and those that do not.  This is
-   done by modifying the references list so that all those that need
-   updating are at the end, so that when we subsequently proceed, we
-   can just clip the list and install the tail in the new location.
-   split_cache_references also counts how many entries are affected,
-   so the total amount of space needed can be computed.
-
-   Second, after checking that there is enough space to proceed, the
-   references are moved to their new locations. */
-
-static long
-update_cache_for_define (SCHEME_OBJECT * new_cell,
-			 SCHEME_OBJECT environment, SCHEME_OBJECT symbol)
-{
-  SCHEME_OBJECT * shadowed_cell
-    = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0));
-  return
-    (((shadowed_cell != 0)
-      && ((get_trap_kind (*shadowed_cell)) == TRAP_COMPILER_CACHED))
-     ? (update_cache_references
-	((GET_TRAP_CACHE (*shadowed_cell)), new_cell, environment, symbol))
-     : PRIM_DONE);
-}
-
-static long
-update_cache_for_unbind (SCHEME_OBJECT old_cache,
-			 SCHEME_OBJECT environment, SCHEME_OBJECT symbol)
+static unsigned long
+update_cache_refs_space (SCHEME_OBJECT from_cache, SCHEME_OBJECT environment)
 {
-  SCHEME_OBJECT * shadowed_cell
-    = (find_binding_cell ((GET_FRAME_PARENT (environment)), symbol, 0));
-  SCHEME_OBJECT dummy_cell = UNBOUND_OBJECT;
+  unsigned long n_names = 0;
+  unsigned long n_lookups
+    = (ref_pairs_to_move ((GET_CACHE_LOOKUP_REFERENCES (from_cache)),
+			  environment, (&n_names)));
+  unsigned long n_assignments
+    = (ref_pairs_to_move ((GET_CACHE_ASSIGNMENT_REFERENCES (from_cache)),
+			  environment, (&n_names)));
+  unsigned long n_operators
+    = (ref_pairs_to_move ((GET_CACHE_OPERATOR_REFERENCES (from_cache)),
+			  environment, (&n_names)));
+
+  /* No references need to be updated.  */
+  if ((n_lookups == 0) && (n_assignments == 0) && (n_operators == 0))
+    return (PRIM_DONE);
 
   return
-    (update_cache_references (old_cache,
-			      ((shadowed_cell == 0)
-			       ? (&dummy_cell)
-			       : shadowed_cell),
-			      environment, symbol));
+    ((n_operators * SPACE_PER_UUO_LINK)
+     + (n_names * 4)
+     + (3 * SPACE_PER_CACHE));
 }
 
 static long
 update_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT * to_cell,
-			 SCHEME_OBJECT environment, SCHEME_OBJECT symbol)
+			 SCHEME_OBJECT environment)
 {
-  SCHEME_OBJECT * tail_holders [3];
-
-  /* Split the references lists.  */
-  split_cache_references
-    (from_cache, CACHE_REFERENCES_LOOKUP, environment, tail_holders);
-  split_cache_references
-    (from_cache, CACHE_REFERENCES_ASSIGNMENT, environment, tail_holders);
-  split_cache_references
-    (from_cache, CACHE_REFERENCES_OPERATOR, environment, tail_holders);
-
-  /* Return if there are no references that need to be updated.  */
-  if ((!PAIR_P (* (tail_holders[CACHE_REFERENCES_LOOKUP])))
-      && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_ASSIGNMENT])))
-      && (!PAIR_P (* (tail_holders[CACHE_REFERENCES_OPERATOR]))))
-    return (PRIM_DONE);
-
-  RETURN_IF_ERROR (guarantee_cache (to_cell, symbol));
+  DIE_IF_ERROR (guarantee_cache (to_cell));
+  {
+    SCHEME_OBJECT to_cache = (GET_TRAP_CACHE (*to_cell));
+    move_ref_pairs
+      (from_cache, to_cache, CACHE_REFERENCES_LOOKUP, environment);
+    move_ref_pairs
+      (from_cache, to_cache, CACHE_REFERENCES_ASSIGNMENT, environment);
+    move_ref_pairs
+      (from_cache, to_cache, CACHE_REFERENCES_OPERATOR, environment);
+    update_clone (to_cache);
+  }
+  update_clone (from_cache);
+  return (PRIM_DONE);
+}
 
-  return
-    (move_cache_references
-     (from_cache, (GET_TRAP_CACHE (*to_cell)), tail_holders));
+static unsigned long
+ref_pairs_to_move (SCHEME_OBJECT * palist, SCHEME_OBJECT environment,
+		   unsigned long * n_names_ret)
+{
+  unsigned long n_refs = 0;
+  while (PAIR_P (*palist))
+    {
+      int any_moved_p = 0;
+      SCHEME_OBJECT * prefs = (PAIR_CDR_LOC (PAIR_CAR (*palist)));
+      while (PAIR_P (*prefs))
+	if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (*prefs))) == SHARP_F)
+	  (*prefs) = (PAIR_CDR (*prefs));
+	else
+	  {
+	    if (move_ref_pair_p ((*prefs), environment))
+	      {
+		n_refs += 1;
+		any_moved_p = 1;
+	      }
+	    prefs = (PAIR_CDR_LOC (*prefs));
+	  }
+      if (any_moved_p)
+	(*n_names_ret) += 1;
+      palist = (PAIR_CDR_LOC (*palist));
+    }
+  return (n_refs);
 }
 
 static void
-split_cache_references (SCHEME_OBJECT cache,
-			unsigned int reference_kind,
-			SCHEME_OBJECT environment,
-			SCHEME_OBJECT ** tail_holders)
+move_ref_pairs (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache,
+		unsigned int reference_kind, SCHEME_OBJECT environment)
 {
-  SCHEME_OBJECT * holder = (GET_CACHE_REFERENCES (cache, reference_kind));
-  SCHEME_OBJECT references_to_move = EMPTY_LIST;
-  while (PAIR_P (*holder))
+  SCHEME_OBJECT * from_palist
+    = (GET_CACHE_REFERENCES (from_cache, reference_kind));
+  SCHEME_OBJECT * to_palist
+    = (GET_CACHE_REFERENCES (to_cache, reference_kind));
+  while (PAIR_P (*from_palist))
     {
-      SCHEME_OBJECT p = (*holder);
-      SCHEME_OBJECT reference = (PAIR_CAR (p));
-      SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference));
-      if (block == SHARP_F)
-	(*holder) = (PAIR_CDR (p));
-      else if (environment_ancestor_or_self_p
-	       (environment, (compiled_block_environment (block))))
-	{
-	  (*holder) = (PAIR_CDR (p));
-	  SET_PAIR_CDR (p, references_to_move);
-	  references_to_move = p;
-	}
+      SCHEME_OBJECT * from_prefs = (PAIR_CDR_LOC (PAIR_CAR (*from_palist)));
+      SCHEME_OBJECT symbol = (PAIR_CAR (PAIR_CAR (*from_palist)));
+      SCHEME_OBJECT * to_prefs = (find_references_named (to_palist, symbol));
+      while (PAIR_P (*from_prefs))
+	if (move_ref_pair_p ((*from_prefs), environment))
+	  {
+	    SCHEME_OBJECT p = (*from_prefs);
+	    (*from_prefs) = (PAIR_CDR (p));
+	    if (to_prefs == 0)
+	      {
+		SCHEME_OBJECT p2;
+		SET_PAIR_CDR (p, EMPTY_LIST);
+		p2 = (cons ((cons (symbol, p)), (*to_palist)));
+		(*to_palist) = p2;
+	      }
+	    else
+	      {
+		SET_PAIR_CDR (p, (*to_prefs));
+		(*to_prefs) = p;
+	      }
+	    install_cache (to_cache,
+			   (GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (p))),
+			   (GET_CACHE_REFERENCE_OFFSET (PAIR_CAR (p))),
+			   reference_kind);
+	  }
+	else
+	  from_prefs = (PAIR_CDR_LOC (*from_prefs));
+      if (PAIR_P (PAIR_CDR (PAIR_CAR (*from_palist))))
+	from_palist = (PAIR_CDR_LOC (*from_palist));
       else
-	holder = (PAIR_CDR_LOC (p));
+	(*from_palist) = (PAIR_CDR (*from_palist));
     }
-  (*holder) = references_to_move;
-  (tail_holders[reference_kind]) = holder;
 }
 
 static int
-environment_ancestor_or_self_p (SCHEME_OBJECT ancestor,
-				SCHEME_OBJECT descendant)
+move_ref_pair_p (SCHEME_OBJECT ref_pair, SCHEME_OBJECT ancestor)
 {
+  SCHEME_OBJECT descendant
+    = (compiled_block_environment
+       (GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (ref_pair))));
   while (PROCEDURE_FRAME_P (descendant))
     {
       if (descendant == ancestor)
@@ -951,41 +1080,6 @@ environment_ancestor_or_self_p (SCHEME_OBJECT ancestor,
     }
   return (descendant == ancestor);
 }
-
-static long
-move_cache_references (SCHEME_OBJECT from_cache, SCHEME_OBJECT to_cache,
-		       SCHEME_OBJECT ** tail_holders)
-{
-  GC_CHECK
-    (((count_references (tail_holders[CACHE_REFERENCES_OPERATOR]))
-      * SPACE_PER_UUO_LINK)
-     + (2 * SPACE_PER_CACHE));
-  move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_LOOKUP);
-  move_cache_references_1
-    (to_cache, tail_holders, CACHE_REFERENCES_ASSIGNMENT);
-  move_cache_references_1 (to_cache, tail_holders, CACHE_REFERENCES_OPERATOR);
-  RETURN_IF_ERROR (update_clone (from_cache));
-  RETURN_IF_ERROR (update_clone (to_cache));
-  return (PRIM_DONE);
-}
-
-static void
-move_cache_references_1 (SCHEME_OBJECT cache, SCHEME_OBJECT ** tail_holders,
-			 unsigned int reference_kind)
-{
-  SCHEME_OBJECT tail = (* (tail_holders[reference_kind]));
-  (* (tail_holders[reference_kind])) = EMPTY_LIST;
-  (* (find_tail_holder (GET_CACHE_REFERENCES (cache, reference_kind)))) = tail;
-  while (PAIR_P (tail))
-    {
-      DIE_IF_ERROR
-	(install_cache (cache,
-			(GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (tail))),
-			(GET_CACHE_REFERENCE_OFFSET (PAIR_CAR (tail))),
-			reference_kind));
-      tail = (PAIR_CDR (tail));
-    }
-}
 
 /***** Utilities *****/
 
@@ -1074,64 +1168,45 @@ get_trap_kind (SCHEME_OBJECT object)
 }
 
 static unsigned long
-count_references (SCHEME_OBJECT * holder)
+count_references (SCHEME_OBJECT * palist)
 {
   unsigned long n_references = 0;
-  while (PAIR_P (*holder))
-    {
-      SCHEME_OBJECT reference = (PAIR_CAR (*holder));
-      SCHEME_OBJECT block = (GET_CACHE_REFERENCE_BLOCK (reference));
-      if (block == SHARP_F)
-	(*holder) = (PAIR_CDR (*holder));
-      else
-	{
-	  n_references += 1;
-	  holder = (PAIR_CDR_LOC (*holder));
-	}
-    }
+  WALK_REFERENCES (palist, reference, { n_references += 1; });
   return (n_references);
 }
 
 static SCHEME_OBJECT *
-find_tail_holder (SCHEME_OBJECT * holder)
+find_references_named (SCHEME_OBJECT * palist, SCHEME_OBJECT symbol)
 {
-  while (PAIR_P (*holder))
+  while (PAIR_P (*palist))
     {
-      SCHEME_OBJECT p = (*holder);
-      if ((GET_CACHE_REFERENCE_BLOCK (PAIR_CAR (p))) == SHARP_F)
-	(*holder) = (PAIR_CDR (p));
-      else
-	holder = (PAIR_CDR_LOC (p));
+      if ((PAIR_CAR (PAIR_CAR (*palist))) == symbol)
+	return (PAIR_CDR_LOC (PAIR_CAR (*palist)));
+      palist = (PAIR_CDR_LOC (*palist));
     }
-  return (holder);
+  return (0);
 }
 
 static void
 update_assignment_references (SCHEME_OBJECT cache)
 {
-  SCHEME_OBJECT * holder = (GET_CACHE_ASSIGNMENT_REFERENCES (cache));
   SCHEME_OBJECT reference_cache
     = (((GET_CACHE_CLONE (cache)) != SHARP_F)
        ? (GET_CACHE_CLONE (cache))
        : cache);
-  while (PAIR_P (*holder))
-    {
-      SCHEME_OBJECT reference = (PAIR_CAR (*holder));
-      if ((GET_CACHE_REFERENCE_BLOCK (reference)) == SHARP_F)
-	(*holder) = (PAIR_CDR (*holder));
-      else
-	{
-	  store_variable_cache
-	    (reference_cache,
-	     (GET_CACHE_REFERENCE_BLOCK (reference)),
-	     (GET_CACHE_REFERENCE_OFFSET (reference)));
-	  holder = (PAIR_CDR_LOC (*holder));
-	}
-    }
+  WALK_REFERENCES
+    ((GET_CACHE_ASSIGNMENT_REFERENCES (cache)),
+     reference,
+     {
+       store_variable_cache
+	 (reference_cache,
+	  (GET_CACHE_REFERENCE_BLOCK (reference)),
+	  (GET_CACHE_REFERENCE_OFFSET (reference)));
+     });
 }
 
 static long
-guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol)
+guarantee_cache (SCHEME_OBJECT * cell)
 {
   SCHEME_OBJECT references;
   SCHEME_OBJECT cache;
@@ -1145,8 +1220,7 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol)
   (*Free++) = EMPTY_LIST;
   (*Free++) = EMPTY_LIST;
 
-  RETURN_IF_ERROR
-    (make_cache ((*cell), symbol, SHARP_F, references, (&cache)));
+  RETURN_IF_ERROR (make_cache ((*cell), SHARP_F, references, (&cache)));
 
   GC_CHECK (2);
   (*Free++) = (LONG_TO_UNSIGNED_FIXNUM (TRAP_COMPILER_CACHED));
@@ -1155,7 +1229,7 @@ guarantee_cache (SCHEME_OBJECT * cell, SCHEME_OBJECT symbol)
   return (PRIM_DONE);
 }
 
-static long
+static void
 update_clone (SCHEME_OBJECT cache)
 {
   if ((PAIR_P (* (GET_CACHE_ASSIGNMENT_REFERENCES (cache))))
@@ -1164,9 +1238,8 @@ update_clone (SCHEME_OBJECT cache)
       if ((GET_CACHE_CLONE (cache)) == SHARP_F)
 	{
 	  SCHEME_OBJECT clone;
-	  RETURN_IF_ERROR
+	  DIE_IF_ERROR
 	    (make_cache (EXPENSIVE_OBJECT,
-			 (GET_CACHE_NAME (cache)),
 			 cache,
 			 (GET_CACHE_REFERENCES_OBJECT (cache)),
 			 (&clone)));
@@ -1182,19 +1255,17 @@ update_clone (SCHEME_OBJECT cache)
 	  update_assignment_references (cache);
 	}
     }
-  return (PRIM_DONE);
 }
 
 static long
-make_cache (SCHEME_OBJECT value, SCHEME_OBJECT symbol, SCHEME_OBJECT clone,
-	    SCHEME_OBJECT references, SCHEME_OBJECT * cache_ret)
+make_cache (SCHEME_OBJECT value, SCHEME_OBJECT clone, SCHEME_OBJECT references,
+	    SCHEME_OBJECT * cache_ret)
 {
-  GC_CHECK (4);
+  GC_CHECK (3);
   (*Free++) = value;
-  (*Free++) = symbol;
   (*Free++) = clone;
   (*Free++) = references;
-  (*cache_ret) = (MAKE_POINTER_OBJECT (CACHE_TYPE, (Free - 4)));
+  (*cache_ret) = (MAKE_POINTER_OBJECT (CACHE_TYPE, (Free - 3)));
   return (PRIM_DONE);
 }
 
diff --git a/v7/src/microcode/lookup.h b/v7/src/microcode/lookup.h
index bfe034858..48f78a4b9 100644
--- a/v7/src/microcode/lookup.h
+++ b/v7/src/microcode/lookup.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: lookup.h,v 9.54 2001/08/02 04:30:12 cph Exp $
+$Id: lookup.h,v 9.55 2001/08/07 01:26:36 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -41,8 +41,8 @@ extern long assign_variable
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
 extern long define_variable
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
-extern long link_variable
-  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
+extern long link_variables
+  (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT);
 extern long unbind_variable
   (SCHEME_OBJECT, SCHEME_OBJECT, SCHEME_OBJECT *);
 
@@ -57,7 +57,8 @@ extern long compiler_cache_operator
 extern long compiler_cache_global_operator
   (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
 
-extern SCHEME_OBJECT compiler_var_error (SCHEME_OBJECT);
+extern SCHEME_OBJECT compiler_var_error
+  (SCHEME_OBJECT, SCHEME_OBJECT, unsigned int);
 
 extern long compiler_lookup_trap
   (SCHEME_OBJECT, SCHEME_OBJECT *);
diff --git a/v7/src/microcode/psbmap.h b/v7/src/microcode/psbmap.h
index 5e5a25d1f..7694a1534 100644
--- a/v7/src/microcode/psbmap.h
+++ b/v7/src/microcode/psbmap.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: psbmap.h,v 9.44 2000/12/05 21:23:48 cph Exp $
+$Id: psbmap.h,v 9.45 2001/08/07 01:26:41 cph Exp $
 
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This file contains macros and declarations for "bintopsb.c"
@@ -57,7 +58,7 @@ extern double
   EXFUN (frexp, (double, int *)),
   EXFUN (ldexp, (double, int));
 
-#define PORTABLE_VERSION	6
+#define PORTABLE_VERSION	7
 
 /* Number of objects which, when traced recursively, point at all other
    objects dumped.
@@ -167,7 +168,7 @@ static Boolean nmv_p = false;
 #define C_COMPILED_CLOSURE_HEADER		3
 #define C_COMPILED_MULTI_CLOSURE_HEADER		4
 #define C_COMPILED_LINKAGE_HEADER		5
-#define C_COMPILED_RAW_QUAD			6
+#define C_COMPILED_RAW_TRIPLE			6
 #define C_COMPILED_EXECUTE_ENTRY		7
 #define C_COMPILED_EXECUTE_ARITY		8
 
diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c
index e544e624a..3315c1652 100644
--- a/v7/src/microcode/psbtobin.c
+++ b/v7/src/microcode/psbtobin.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: psbtobin.c,v 9.58 2000/01/18 05:09:07 cph Exp $
+$Id: psbtobin.c,v 9.59 2001/08/07 01:26:49 cph Exp $
 
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This file contains the code to translate portable format binary
@@ -952,13 +953,13 @@ DEFUN (Read_Pointers_and_Relocate, (how_many, to),
 	    continue;
 	  }
 
-	  case C_COMPILED_RAW_QUAD:
+	  case C_COMPILED_RAW_TRIPLE:
 	  {
-	    long quad_datum;
+	    long triple_datum;
 
-	    VMS_BUG (quad_datum = 0);
-	    fscanf (portable_file, "%lx", &quad_datum);
-	    *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (quad_datum)));
+	    VMS_BUG (triple_datum = 0);
+	    fscanf (portable_file, "%lx", &triple_datum);
+	    *to++ = (ADDR_TO_SCHEME_ADDR (Relocate (triple_datum)));
 	    continue;
 	  }
 
diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c
index ba1d29228..499e2b997 100644
--- a/v7/src/microcode/purify.c
+++ b/v7/src/microcode/purify.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: purify.c,v 9.59 2000/12/05 21:23:48 cph Exp $
+$Id: purify.c,v 9.60 2001/08/07 01:27:03 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* This file contains the code that copies objects into pure
@@ -147,7 +148,7 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode),
 	    {
 	      Temp = (* Scan);
 	      PURIFY_RAW_POINTER (Setup_Internal (false,
-						  TRANSPORT_RAW_QUADRUPLE (),
+						  TRANSPORT_RAW_TRIPLE (),
 						  RAW_BH (false, continue)));
 	    }
 	    Scan -= 1;
diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h
index 4073e9072..9305634b3 100644
--- a/v7/src/microcode/sdata.h
+++ b/v7/src/microcode/sdata.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: sdata.h,v 9.37 2001/08/02 04:30:16 cph Exp $
+$Id: sdata.h,v 9.38 2001/08/07 01:27:09 cph Exp $
 
 Copyright (c) 1987-1989, 1999, 2001 Massachusetts Institute of Technology
 
@@ -425,47 +425,36 @@ USA.
 #define GET_TRAP_TAG(object)						\
   (MEMORY_REF ((object), TRAP_TAG))
 
-#define GET_TRAP_EXTENSION(object)					\
+#define GET_TRAP_CACHE(object)						\
   (MEMORY_REF ((object), TRAP_EXTRA))
 
-/* Traps can be extended for the use of the fast variable reference
-   mechanism in compiled code.  The following is the format of a trap
-   extension object.  */
-
-#define TRAP_EXTENSION_CELL			HUNK4_CXR0
-#define TRAP_EXTENSION_NAME			HUNK4_CXR1
-#define TRAP_EXTENSION_CLONE			HUNK4_CXR2
-#define TRAP_EXTENSION_REFERENCES		HUNK4_CXR3
+#define CACHE_CELL				HUNK3_CXR0
+#define CACHE_CLONE				HUNK3_CXR1
+#define CACHE_REFERENCES			HUNK3_CXR2
 
 #define CACHE_REFERENCES_LOOKUP			HUNK3_CXR0
 #define CACHE_REFERENCES_ASSIGNMENT		HUNK3_CXR1
 #define CACHE_REFERENCES_OPERATOR		HUNK3_CXR2
 
-#define GET_TRAP_CACHE GET_TRAP_EXTENSION
-
 
 #define GET_CACHE_VALUE(cache)						\
-  (MEMORY_REF ((cache), TRAP_EXTENSION_CELL))
+  (MEMORY_REF ((cache), CACHE_CELL))
 
 #define SET_CACHE_VALUE(cache, value)					\
-  MEMORY_SET ((cache), TRAP_EXTENSION_CELL, (value))
-
-#define GET_CACHE_NAME(cache)						\
-  (MEMORY_REF ((cache), TRAP_EXTENSION_NAME))
+  MEMORY_SET ((cache), CACHE_CELL, (value))
 
 #define GET_CACHE_CLONE(cache)						\
-  (MEMORY_REF ((cache), TRAP_EXTENSION_CLONE))
+  (MEMORY_REF ((cache), CACHE_CLONE))
 
 #define SET_CACHE_CLONE(cache, clone)					\
-  MEMORY_SET ((cache), TRAP_EXTENSION_CLONE, (clone))
+  MEMORY_SET ((cache), CACHE_CLONE, (clone))
 
 #define GET_CACHE_REFERENCES_OBJECT(cache)				\
-  (MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES))
+  (MEMORY_REF ((cache), CACHE_REFERENCES))
 
 
 #define GET_CACHE_REFERENCES(cache, kind)				\
-  (MEMORY_LOC ((MEMORY_REF ((cache), TRAP_EXTENSION_REFERENCES)),	\
-	       (kind)))
+  (MEMORY_LOC ((GET_CACHE_REFERENCES_OBJECT (cache)), (kind)))
 
 #define GET_CACHE_LOOKUP_REFERENCES(cache)				\
   (GET_CACHE_REFERENCES ((cache), CACHE_REFERENCES_LOOKUP))
diff --git a/v7/src/microcode/trap.h b/v7/src/microcode/trap.h
index f7ebc4965..5234adb2d 100644
--- a/v7/src/microcode/trap.h
+++ b/v7/src/microcode/trap.h
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: trap.h,v 9.47 2001/08/02 04:24:19 cph Exp $
+$Id: trap.h,v 9.48 2001/08/07 01:27:13 cph Exp $
 
 Copyright (c) 1987-1989, 1999-2001 Massachusetts Institute of Technology
 
@@ -67,8 +67,11 @@ typedef unsigned long trap_kind_t;
    a reference trap object.  */
 #define NON_TRAP_KIND				32
 
-/* These MUST be distinct */
-#define CACHE_TYPE				TC_QUAD
+/* The garbage collector knows that pointers of type CACHE_TYPE point
+   to three words of storage, because these pointers are embedded in
+   compiled-code linkage sections (TC_LINKAGE_SECTION) without types.
+   */
+#define CACHE_TYPE				TC_HUNK3
 #define CACHE_REFERENCES_TYPE			TC_HUNK3
 
 #if (SIZEOF_UNSIGNED_LONG == 4)	/* 32 bit objects */
diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h
index 0f1ce0be2..828a14f59 100644
--- a/v7/src/microcode/types.h
+++ b/v7/src/microcode/types.h
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: types.h,v 9.37 1999/01/02 06:06:43 cph Exp $
+$Id: types.h,v 9.38 2001/08/07 01:27:17 cph Exp $
 
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 */
 
 /* Type code definitions, numerical order */
@@ -79,7 +80,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #define TC_DISJUNCTION			0x35
 #define TC_CELL				0x36
 #define TC_WEAK_CONS			0x37
-#define TC_QUAD				0x38 /* TRAP */
+#define TC_QUAD				0x38
 #define TC_LINKAGE_SECTION		0x39
 #define TC_RATNUM			0x3A /* COMPILER_LINK */
 #define TC_STACK_ENVIRONMENT		0x3B