From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 23 Apr 1996 20:38:03 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~5607
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e16ca1969c7532c29aea4c8756e9fd0d5527851b;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/microcode/prgdbm.c b/v7/src/microcode/prgdbm.c
new file mode 100644
index 000000000..aca93b88f
--- /dev/null
+++ b/v7/src/microcode/prgdbm.c
@@ -0,0 +1,264 @@
+/* -*-C-*-
+
+$Id: prgdbm.c,v 1.1 1996/04/23 20:36:48 cph Exp $
+
+Copyright (c) 1996 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Interface to the gdbm database library */
+
+#include "scheme.h"
+#include "prims.h"
+#include "os.h"
+#include <gdbm.h>
+
+/* Allocation Tables */
+
+struct allocation_table
+{
+  PTR * items;
+  int length;
+};
+
+static void
+DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
+{
+  (table -> length) = 0;
+}
+
+static unsigned int
+DEFUN (allocate_table_index, (table, item),
+       struct allocation_table * table AND
+       PTR item)
+{
+  unsigned int length = (table -> length);
+  unsigned int new_length;
+  PTR * items = (table -> items);
+  PTR * new_items;
+  PTR * scan;
+  PTR * end;
+  if (length == 0)
+    {
+      new_length = 4;
+      new_items = (OS_malloc ((sizeof (PTR)) * new_length));
+    }
+  else
+    {
+      scan = items;
+      end = (scan + length);
+      while (scan < end)
+	if ((*scan++) == 0)
+	  {
+	    (*--scan) = item;
+	    return (scan - items);
+	  }
+      new_length = (length * 2);
+      new_items = (OS_realloc (items, ((sizeof (PTR)) * new_length)));
+    }
+  scan = (new_items + length);
+  end = (new_items + new_length);
+  (*scan++) = item;
+  while (scan < end)
+    (*scan++) = 0;
+  (table -> items) = new_items;
+  (table -> length) = new_length;
+  return (length);
+}
+
+static PTR
+DEFUN (allocation_item_arg, (arg, table),
+       unsigned int arg AND
+       struct allocation_table * table)
+{
+  unsigned int index = (arg_ulong_index_integer (arg, (table -> length)));
+  PTR item = ((table -> items) [index]);
+  if (item == 0)
+    error_bad_range_arg (arg);
+  return (item);
+}
+
+static struct allocation_table dbf_table;
+
+#define DBF_VAL(dbf)							\
+  (ulong_to_integer (allocate_table_index ((&dbf_table), ((PTR) (dbf)))))
+
+#define DBF_ARG(arg)							\
+  ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table))))
+
+#define GDBM_ERROR_VAL()						\
+  (char_pointer_to_string ((unsigned char *) (gdbm_strerror (gdbm_errno))))
+
+#define VOID_GDBM_CALL(expression)					\
+  (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ()))
+
+static datum
+DEFUN (arg_datum, (arg), int arg)
+{
+  datum d;
+  CHECK_ARG (arg, STRING_P);
+  (d . dptr) = ((char *) (STRING_LOC ((ARG_REF (arg)), 0)));
+  (d . dsize) = (STRING_LENGTH (ARG_REF (arg)));
+  return (d);
+}
+
+static SCHEME_OBJECT
+DEFUN (datum_to_object, (d), datum d)
+{
+  if (d . dptr)
+    {
+      SCHEME_OBJECT result = (allocate_string (d . dsize));
+      CONST char * scan_d = (d . dptr);
+      CONST char * end_d = (scan_d + (d . dsize));
+      unsigned char * scan_result = (STRING_LOC (result, 0));
+      while (scan_d < end_d)
+	(*scan_result++) = ((unsigned char) (*scan_d++));
+      free (d . dptr);
+      return (result);
+    }
+  else
+    return (SHARP_F);
+}
+
+static void
+DEFUN (gdbm_fatal_error, (msg), char * msg)
+{
+  fprintf (stderr, "\ngdbm: %s\n", msg);
+  fflush (stderr);
+  error_external_return ();
+}
+
+DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0)
+{
+  static int initialization_done = 0;
+  PRIMITIVE_HEADER (4);
+  if (!initialization_done)
+    {
+      allocation_table_initialize (&dbf_table);
+      initialization_done = 1;
+    }
+  {
+    GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)),
+				(arg_integer (2)),
+				(arg_integer (3)),
+				(arg_integer (4)),
+				gdbm_fatal_error));
+    PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf)));
+  }
+}
+
+DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  gdbm_close (DBF_ARG (1));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0)
+{
+  PRIMITIVE_HEADER (4);
+  {
+    int result = (gdbm_store ((DBF_ARG (1)),
+			      (arg_datum (2)),
+			      (arg_datum (3)),
+			      (arg_integer (4))));
+    PRIMITIVE_RETURN
+      ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result)));
+  }
+}
+
+DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2)))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2)))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0)
+     ? SHARP_T
+     : (gdbm_errno == GDBM_ITEM_NOT_FOUND)
+     ? SHARP_F
+     : (GDBM_ERROR_VAL ()));
+}
+
+DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  PRIMITIVE_RETURN
+    (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2)))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0)
+{
+  PRIMITIVE_HEADER (1);
+  gdbm_sync (DBF_ARG (1));
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0)
+{
+  PRIMITIVE_HEADER (0);
+  PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) gdbm_version));
+}
+
+DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0)
+{
+  PRIMITIVE_HEADER (3);
+  {
+    int value = (arg_integer (3));
+    PRIMITIVE_RETURN
+      (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)),
+				    (arg_integer (2)),
+				    (&value),
+				    (sizeof (int)))));
+  }
+}
diff --git a/v7/src/runtime/gdbm.scm b/v7/src/runtime/gdbm.scm
new file mode 100644
index 000000000..da2e4075d
--- /dev/null
+++ b/v7/src/runtime/gdbm.scm
@@ -0,0 +1,143 @@
+#| -*-Scheme-*-
+
+$Id: gdbm.scm,v 1.1 1996/04/23 20:37:04 cph Exp $
+
+Copyright (c) 1996 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; gdbm Database Library Interface
+;;; package: (runtime gdbm)
+
+(declare (usual-integrations))
+
+(define (gdbm-available?)
+  (implemented-primitive-procedure? (ucode-primitive gdbm-open 4)))
+
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
+;; create the database.
+(define GDBM_READER  0)		;A reader.
+(define GDBM_WRITER  1)		;A writer.
+(define GDBM_WRCREAT 2)		;A writer.  Create the db if needed.
+(define GDBM_NEWDB   3)		;A writer.  Always create a new db.
+(define GDBM_FAST    16)	;Write fast! => No fsyncs.
+
+(define (gdbm-open filename block-size flags mode)
+  (let ((filename (->namestring (merge-pathnames filename))))
+    (without-interrupts
+     (lambda ()
+       (let ((descriptor
+	      (gdbm-error ((ucode-primitive gdbm-open 4)
+			   filename block-size flags mode))))
+	 (let ((gdbf (make-gdbf descriptor filename)))
+	   (add-to-protection-list! gdbf-list gdbf descriptor)
+	   gdbf))))))
+
+(define (gdbm-close gdbf)
+  (if (not (gdbf? gdbf))
+      (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE))
+  (let ((descriptor (gdbf-descriptor gdbf)))
+    (if descriptor
+	(without-interrupts
+	 (lambda ()
+	   ((ucode-primitive gdbm-close 1) descriptor)
+	   (remove-from-protection-list! gdbf-list gdbf)
+	   (set-gdbf-descriptor! gdbf #f))))))
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(define GDBM_INSERT  0)		;Never replace old data with new.
+(define GDBM_REPLACE 1)		;Always replace old data with new.
+
+(define (gdbm-store gdbf key datum flags)
+  (gdbm-error
+   ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE)
+				   key datum flags)))
+
+(define (gdbm-fetch gdbf key)
+  ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key))
+
+(define (gdbm-exists? gdbf key)
+  ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key))
+
+(define (gdbm-delete gdbf key)
+  (gdbm-error
+   ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key)))
+
+(define (gdbm-firstkey gdbf)
+  ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)))
+
+(define (gdbm-nextkey gdbf key)
+  ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key))
+
+(define (gdbm-reorganize gdbf)
+  (gdbm-error
+   ((ucode-primitive gdbm-reorganize 1)
+    (guarantee-gdbf gdbf 'GDBM-REORGANIZE))))
+
+(define (gdbm-sync gdbf)
+  ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC)))
+
+(define (gdbm-version)
+  ((ucode-primitive gdbm-version 0)))
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(define GDBM_CACHESIZE 1)       ;Set the cache size.
+(define GDBM_FASTMODE  2)       ;Toggle fast mode.
+
+(define (gdbm-setopt gdbf opt val)
+  (gdbm-error
+   ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT)
+				    opt val)))
+
+(define-structure (gdbf
+		   (print-procedure (standard-unparser-method 'GDBF
+				      (lambda (gdbf port)
+					(write-char #\space port)
+					(write (gdbf-filename gdbf) port)))))
+  descriptor
+  (filename #f read-only #t))
+
+(define (guarantee-gdbf gdbf procedure)
+  (if (gdbf? gdbf)
+      (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure))
+      (error:wrong-type-argument gdbf "gdbm handle" procedure)))
+
+(define (gdbm-error object)
+  (if (string? object) (error "gdbm error:" object))
+  object)
+
+(define gdbf-list)
+(define (initialize-package!)
+  (set! gdbf-list (make-protection-list))
+  (add-gc-daemon!
+   (lambda ()
+     (clean-lost-protected-objects gdbf-list (ucode-primitive gdbm-close 1))))
+  (add-event-receiver! event:after-restore
+		       (lambda () (drop-all-protected-objects gdbf-list))))
\ No newline at end of file
diff --git a/v7/src/runtime/gencache.scm b/v7/src/runtime/gencache.scm
new file mode 100644
index 000000000..c75def951
--- /dev/null
+++ b/v7/src/runtime/gencache.scm
@@ -0,0 +1,526 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: gencache.scm,v 1.1 1996/04/23 20:37:15 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Method Caches for Generic Dispatch
+
+;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
+;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
+;;; Functional Programming.  Parts of this code are based on the
+;;; September 16, 1992 PCL implementation.
+
+(declare (usual-integrations)
+	 (integrate-external "gentag"))
+
+(define-structure (cache (constructor %make-cache))
+  (tag-index 0)
+  (mask 0 read-only #t)
+  (limit 0 read-only #t)
+  (n-tags 0 read-only #t)
+  (tags '#() read-only #t)
+  (values '#() read-only #t)
+  (overflow '()))
+
+(define (new-cache n-tags)
+  (make-cache dispatch-tag-index-start n-tags 4))
+
+(define (make-cache tag-index n-tags length)
+  ;; LENGTH is assumed to be a power of two.
+  (%make-cache tag-index
+	       (fix:- length 1)
+	       (cond ((fix:<= length 4) 1)
+		     ((fix:<= length 16) 4)
+		     (else 6))
+	       n-tags
+	       (make-vector length (make-list n-tags #f))
+	       (make-vector length #f)
+	       '()))
+
+(define-integrable (cache-length cache)
+  (vector-length (cache-tags cache)))
+
+(define-integrable (cache-line-tags cache line)
+  (vector-ref (cache-tags cache) line))
+
+(define-integrable (set-cache-line-tags! cache line tags)
+  (vector-set! (cache-tags cache) line tags))
+
+(define-integrable (cache-line-value cache line)
+  (vector-ref (cache-values cache) line))
+
+(define-integrable (set-cache-line-value! cache line value)
+  (vector-set! (cache-values cache) line value))
+
+(define-integrable (cache-next-line cache line)
+  (if (fix:= (fix:+ line 1) (cache-length cache))
+      0
+      (fix:+ line 1)))
+
+(define-integrable (cache-line-separation cache line line*)
+  (let ((n (fix:- line* line)))
+    (if (fix:< n 0)
+	(fix:+ n (cache-length cache))
+	n)))
+
+(define (probe-cache cache tags)
+  (let ((line (compute-primary-cache-line cache tags)))
+    (and line
+	 (let ((limit (cache-limit cache)))
+	   (letrec
+	       ((search-lines
+		 (lambda (line i)
+		   (cond ((match (cache-line-tags cache line))
+			  (cache-line-value cache line))
+			 ((fix:= i limit)
+			  (search-overflow (cache-overflow cache)))
+			 (else
+			  (search-lines (cache-next-line cache line)
+					(fix:+ i 1))))))
+		(search-overflow
+		 (lambda (overflow)
+		   (and (not (null? overflow))
+			(if (match (caar overflow))
+			    (cdar overflow)
+			    (search-overflow (cdr overflow))))))
+		(match
+		 (lambda (tags*)
+		   (let loop ((w1 tags*) (w2 tags))
+		     (and (eq? (system-pair-car w1) (system-pair-car w2))
+			  (or (null? (system-pair-cdr w1))
+			      (loop (system-pair-cdr w1)
+				    (system-pair-cdr w2))))))))
+	     (search-lines line 0))))))
+
+(define (compute-primary-cache-line cache tags)
+  (let ((index (cache-tag-index cache))
+	(mask (cache-mask cache)))
+    (let loop ((tags tags) (line 0))
+      (cond ((null? tags)
+	     line)
+	    ((not (system-pair-car tags))
+	     #f)
+	    (else
+	     (loop (system-pair-cdr tags)
+		   (fix:and (fix:+ line
+				   (dispatch-tag-ref (system-pair-car tags)
+						     index))
+			    mask)))))))
+
+(define (cache-entry-reusable? tags tags*)
+  ;; True iff TAGS is (1) empty, (2) contains a tag that is invalid,
+  ;; or (3) has the same tags as TAGS*.
+  (or (not tags)
+      (let loop ((tags tags) (tags* tags*))
+	(or (null? tags)
+	    (not (system-pair-car tags))
+	    (and (eq? (system-pair-car tags) (system-pair-car tags*))
+		 (loop (system-pair-cdr tags) (system-pair-cdr tags*)))))))
+
+(define (cache-count cache)
+  (let ((length (cache-length cache)))
+    (do ((line 0 (fix:+ line 1))
+	 (count 0
+		(if (let ((tags (cache-line-tags cache line)))
+		      (and tags
+			   (let loop ((tags tags))
+			     (or (null? tags)
+				 (and (system-pair-car tags)
+				      (loop (system-pair-cdr tags)))))))
+		    (fix:+ count 1)
+		    count)))
+	((fix:= line length) count))))
+
+(declare (integrate-operator probe-cache-1))
+(define (probe-cache-1 cache w1)
+  (let ((line
+	 (fix:and (dispatch-tag-ref w1 (cache-tag-index cache))
+		  (cache-mask cache)))
+	(match
+	 (lambda (tags)
+	   (declare (integrate tags))
+	   (eq? w1 (system-pair-car tags)))))
+    (declare (integrate line))
+    (declare (integrate-operator match))
+    (if (match (cache-line-tags cache line))
+	(cache-line-value cache line)
+	(let ((limit (cache-limit cache)))
+	  (let search-lines ((line (cache-next-line cache line)) (i 0))
+	    (cond ((fix:= i limit)
+		   (let search-overflow ((entries (cache-overflow cache)))
+		     (and (not (null? entries))
+			  (if (match (caar entries))
+			      (cdar entries)
+			      (search-overflow (cdr entries))))))
+		  ((and (cache-line-tags cache line)
+			(match (cache-line-tags cache line)))
+		   (cache-line-value cache line))
+		  (else
+		   (search-lines (cache-next-line cache line)
+				 (fix:+ i 1)))))))))
+
+(declare (integrate-operator probe-cache-2))
+(define (probe-cache-2 cache w1 w2)
+  (let ((line
+	 (fix:and (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+			 (dispatch-tag-ref w2 (cache-tag-index cache)))
+		  (cache-mask cache)))
+	(match
+	 (lambda (tags)
+	   (declare (integrate tags))
+	   (and (eq? w1 (system-pair-car tags))
+		(eq? w2 (system-pair-car (system-pair-cdr tags)))))))
+    (declare (integrate line))
+    (declare (integrate-operator match))
+    (if (and (cache-line-tags cache line)
+	     (match (cache-line-tags cache line)))
+	(cache-line-value cache line)
+	(let ((limit (cache-limit cache)))
+	  (let search-lines ((line (cache-next-line cache line)) (i 0))
+	    (cond ((fix:= i limit)
+		   (let search-overflow ((entries (cache-overflow cache)))
+		     (and (not (null? entries))
+			  (if (match (caar entries))
+			      (cdar entries)
+			      (search-overflow (cdr entries))))))
+		  ((and (cache-line-tags cache line)
+			(match (cache-line-tags cache line)))
+		   (cache-line-value cache line))
+		  (else
+		   (search-lines (cache-next-line cache line)
+				 (fix:+ i 1)))))))))
+
+(declare (integrate-operator probe-cache-3))
+(define (probe-cache-3 cache w1 w2 w3)
+  (let ((line
+	 (fix:and
+	  (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+		 (fix:+ (dispatch-tag-ref w2 (cache-tag-index cache))
+			(dispatch-tag-ref w3 (cache-tag-index cache))))
+	  (cache-mask cache)))
+	(match
+	 (lambda (tags)
+	   (declare (integrate tags))
+	   (and (eq? w1 (system-pair-car tags))
+		(eq? w2 (system-pair-car (system-pair-cdr tags)))
+		(eq? w3 (system-pair-car
+			 (system-pair-cdr (system-pair-cdr tags))))))))
+    (declare (integrate line))
+    (declare (integrate-operator match))
+    (if (match (cache-line-tags cache line))
+	(cache-line-value cache line)
+	(let ((limit (cache-limit cache)))
+	  (let search-lines ((line (cache-next-line cache line)) (i 0))
+	    (cond ((fix:= i limit)
+		   (let search-overflow ((entries (cache-overflow cache)))
+		     (and (not (null? entries))
+			  (if (match (caar entries))
+			      (cdar entries)
+			      (search-overflow (cdr entries))))))
+		  ((and (cache-line-tags cache line)
+			(match (cache-line-tags cache line)))
+		   (cache-line-value cache line))
+		  (else
+		   (search-lines (cache-next-line cache line)
+				 (fix:+ i 1)))))))))
+
+(declare (integrate-operator probe-cache-4))
+(define (probe-cache-4 cache w1 w2 w3 w4)
+  (let ((line
+	 (fix:and
+	  (fix:+ (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
+			(dispatch-tag-ref w2 (cache-tag-index cache)))
+		 (fix:+ (dispatch-tag-ref w3 (cache-tag-index cache))
+			(dispatch-tag-ref w4 (cache-tag-index cache))))
+	  (cache-mask cache)))
+	(match
+	 (lambda (tags)
+	   (declare (integrate tags))
+	   (and (eq? w1 (system-pair-car tags))
+		(eq? w2 (system-pair-car (system-pair-cdr tags)))
+		(eq? w3 (system-pair-car
+			 (system-pair-cdr (system-pair-cdr tags))))
+		(eq? w4 (system-pair-car
+			 (system-pair-cdr
+			  (system-pair-cdr (system-pair-cdr tags)))))))))
+    (declare (integrate line))
+    (declare (integrate-operator match))
+    (if (match (cache-line-tags cache line))
+	(cache-line-value cache line)
+	(let ((limit (cache-limit cache)))
+	  (let search-lines ((line (cache-next-line cache line)) (i 0))
+	    (cond ((fix:= i limit)
+		   (let search-overflow ((entries (cache-overflow cache)))
+		     (and (not (null? entries))
+			  (if (match (caar entries))
+			      (cdar entries)
+			      (search-overflow (cdr entries))))))
+		  ((and (cache-line-tags cache line)
+			(match (cache-line-tags cache line)))
+		   (cache-line-value cache line))
+		  (else
+		   (search-lines (cache-next-line cache line)
+				 (fix:+ i 1)))))))))
+
+(define (fill-cache cache tags value)
+  ;; TAGS must be converted to a weak list since it will be stored in
+  ;; the cache, and we don't want the cache to prevent the tags from
+  ;; being GCed.
+  (let ((tags (list->weak-list tags)))
+    (or (fill-cache-if-possible cache tags value)
+	(and (< (cache-count cache) (* (cache-length cache) .8))
+	     (adjust-cache cache tags value))
+	(expand-cache cache tags value))))
+
+(define (fill-cache-if-possible cache tags value)
+  (let ((primary (compute-primary-cache-line cache tags)))
+    (if primary
+	(let ((free (find-free-cache-line cache primary tags)))
+	  (and free
+	       (begin
+		 (set-cache-line-tags! cache free tags)
+		 (set-cache-line-value! cache free value)
+		 cache)))
+	;; TAGS contains an invalid tag.  Do nothing and return CACHE
+	;; because the fill is no longer needed.  While other logic
+	;; tries to eliminate this case, it can still happen when one
+	;; of the tags is GCed during complex cache operations.
+	cache)))
+
+(define (adjust-cache cache tags value)
+  ;; Try to rehash the cache.  If that fails, try rehashing with
+  ;; different tag indexes.  Fail only when all of the tag indexes
+  ;; have been tried and none has worked.
+  (let ((length (cache-length cache)))
+    (let ((new-cache
+	   (make-cache (cache-tag-index cache)
+		       (cache-n-tags cache)
+		       length)))
+      (letrec
+	  ((fill-lines
+	    (lambda (line)
+	      (cond ((fix:= line length)
+		     (fill-overflow (cache-overflow cache)))
+		    ((try-entry (cache-line-tags cache line)
+				(cache-line-value cache line))
+		     (fill-lines (fix:+ line 1)))
+		    (else
+		     (try-next-tag-index)))))
+	   (fill-overflow
+	    (lambda (entries)
+	      (cond ((null? entries)
+		     (or (fill-cache-if-possible new-cache tags value)
+			 (try-next-tag-index)))
+		    ((try-entry (caar entries) (cdar entries))
+		     (fill-overflow (cdr entries)))
+		    (else
+		     (try-next-tag-index)))))
+	   (try-entry
+	    (lambda (tags* value)
+	      (or (cache-entry-reusable? tags* tags)
+		  (fill-cache-if-possible new-cache tags* value))))
+	   (try-next-tag-index
+	    (lambda ()
+	      (let ((index
+		     (next-dispatch-tag-index (cache-tag-index new-cache))))
+		(and index
+		     (begin
+		       (set-cache-tag-index! new-cache index)
+		       (fill-lines 0)))))))
+	(fill-lines 0)))))
+
+(define (expand-cache cache tags value)
+  ;; Create a new cache that is twice the length of CACHE, rehash the
+  ;; contents of CACHE into the new cache, and make the new entry.
+  ;; Permits overflows to occur in the new cache.
+  (let ((length (cache-length cache)))
+    (letrec
+	((fill-lines
+	  (lambda (new-cache line)
+	    (if (fix:= line length)
+		(fill-overflow new-cache (cache-overflow cache))
+		(fill-lines (maybe-do-fill new-cache
+					   (cache-line-tags cache line)
+					   (cache-line-value cache line))
+			    (fix:+ line 1)))))
+	 (fill-overflow
+	  (lambda (new-cache overflow)
+	    (if (null? overflow)
+		(do-fill new-cache tags value)
+		(fill-overflow (maybe-do-fill new-cache
+					      (caar overflow)
+					      (cdar overflow))
+			       (cdr overflow)))))
+	 (maybe-do-fill
+	  (lambda (cache tags* value)
+	    (if (cache-entry-reusable? tags* tags)
+		cache
+		(do-fill cache tags* value))))
+	 (do-fill
+	  (lambda (cache tags value)
+	    (let ((primary (compute-primary-cache-line cache tags)))
+	      (if primary
+		  (let ((free (find-free-cache-line cache primary tags)))
+		    (if free
+			(begin
+			  (set-cache-line-tags! cache free tags)
+			  (set-cache-line-value! cache free value)
+			  cache)
+			(or (adjust-cache cache tags value)
+			    (begin
+			      (set-cache-overflow!
+			       cache
+			       (cons (cons (cache-line-tags cache primary)
+					   (cache-line-value cache primary))
+				     (cache-overflow cache)))
+			      (set-cache-line-tags! cache primary tags)
+			      (set-cache-line-value! cache primary value)
+			      cache))))
+		  cache)))))
+      (fill-lines (make-cache (cache-tag-index cache)
+			      (cache-n-tags cache)
+			      (fix:+ length length))
+		  0))))
+
+(define (find-free-cache-line cache primary tags)
+  ;; This procedure searches CACHE for a free line to hold an entry
+  ;; with the given PRIMARY cache number and TAGS.  Since the entry
+  ;; can only be stored within (CACHE-LIMIT CACHE) lines of PRIMARY,
+  ;; we either have to find a free line within that limit, or we have
+  ;; to find a line with a larger primary which can be displaced to
+  ;; another free line within *its* limit.
+  (if (cache-entry-reusable? (cache-line-tags cache primary) tags)
+      primary
+      (let ((limit (cache-limit cache)))
+	;; Find a line for an entry whose primary cache number is P.
+	;; LINES is the sequence of entries that is waiting to be
+	;; displaced into the line if we find it.
+	(let pri-loop
+	    ((line (cache-next-line cache primary))
+	     (p primary)
+	     (tags tags)
+	     (lines '()))
+	  (let sec-loop
+	      ((line line)
+	       (nsep (cache-line-separation cache p line)))
+	    (cond ((fix:= line primary)
+		   ;; We've scanned through the entire cache without
+		   ;; finding a usable line.
+		   #f)
+		  ((let ((tags* (cache-line-tags cache line)))
+		     (and (not (cache-entry-reusable? tags* tags))
+			  (compute-primary-cache-line cache tags*)))
+		   =>
+		   (lambda (lp)
+		     (let ((osep (cache-line-separation cache lp line)))
+		       (cond ((fix:>= osep limit)
+			      ;; This line contains an entry that is
+			      ;; displaced to the limit.  [**** For
+			      ;; some reason I don't understand, this
+			      ;; terminates the search.]
+			      #f)
+			     ((or (fix:> nsep osep)
+				  (and (fix:= nsep osep)
+				       (= 0 (random 2))))
+			      ;; The entry we're trying to place is
+			      ;; further from its primary than the
+			      ;; entry currently stored in this line.
+			      ;; So now let's look for somewhere to
+			      ;; displace the entry in this line.
+			      (pri-loop (cache-next-line cache line)
+					lp
+					(cache-line-tags cache line)
+					(cons line lines)))
+			     (else
+			      (sec-loop (cache-next-line cache line)
+					(fix:+ nsep 1)))))))
+		  (else
+		   ;; Found a free line.  First perform all of the
+		   ;; entry displacements, then return the subsequent
+		   ;; free line.
+		   (without-interrupts
+		    (lambda ()
+		      (let loop ((free-line line) (lines lines))
+			(if (null? lines)
+			    (begin
+			      (set-cache-line-tags! cache free-line #f)
+			      (set-cache-line-value! cache free-line #f)
+			      free-line)
+			    (let ((line (car lines)))
+			      (set-cache-line-tags!
+			       cache
+			       free-line
+			       (cache-line-tags cache line))
+			      (set-cache-line-value!
+			       cache
+			       free-line
+			       (cache-line-value cache line))
+			      (loop line (cdr lines))))))))))))))
+
+(define (purge-cache-entries cache predicate)
+  (if (there-exists-a-cache-entry? cache predicate)
+      ;; Must rebuild cache since deletions are near-impossible.
+      (let loop
+	  ((cache (new-cache (cache-n-tags cache)))
+	   (alist (cache->alist cache)))
+	(if (null? alist)
+	    cache
+	    (loop (if (predicate (caar alist))
+		      cache
+		      (fill-cache cache (caar alist) (cdar alist)))
+		  (cdr alist))))
+      cache))
+
+(define (there-exists-a-cache-entry? cache predicate)
+  (let ((length (cache-length cache)))
+    (let loop ((line 0))
+      (and (not (fix:= line length))
+	   (let ((tags (cache-line-tags cache line)))
+	     (if (or (not tags)
+		     (not (system-pair-car tags)))
+		 (loop (fix:+ line 1))
+		 (or (predicate (weak-list->list tags))
+		     (loop (fix:+ line 1)))))))))
+
+(define (cache->alist cache)
+  (let ((length (cache-length cache)))
+    (do ((line 0 (fix:+ line 1))
+	 (alist '()
+		(let ((tags (cache-line-tags cache line)))
+		  (if (or (not tags)
+			  (not (system-pair-car tags)))
+		      alist
+		      (cons (cons (weak-list->list tags)
+				  (cache-line-value cache line))
+			    alist)))))
+	((fix:= line length) alist))))
\ No newline at end of file
diff --git a/v7/src/runtime/geneqht.scm b/v7/src/runtime/geneqht.scm
new file mode 100644
index 000000000..1af749b8f
--- /dev/null
+++ b/v7/src/runtime/geneqht.scm
@@ -0,0 +1,258 @@
+#| -*-Scheme-*-
+
+$Id: geneqht.scm,v 1.1 1996/04/23 20:37:27 cph Exp $
+
+Copyright (c) 1990-96 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; EQ?-Hash Tables for Generic Procedures
+
+(declare (usual-integrations))
+
+(define (make-eqht)
+  (let ((table (%make-eqht)))
+    (reset-table! table)
+    (record-address-hash-table! table)
+    table))
+
+(define (eqht/get table key default)
+  (let ((entries
+	 (vector-ref (table-buckets table) (compute-key-hash table key))))
+    (let loop ((entries entries))
+      (cond ((null? entries)
+	     default)
+	    ((eq? (system-pair-car (car entries)) key)
+	     (system-pair-cdr (car entries)))
+	    (else
+	     (loop (cdr entries)))))))
+
+(define (eqht/put! table key datum)
+  (let ((buckets (table-buckets table))
+	(hash (compute-key-hash table key)))
+    (let loop ((entries (vector-ref buckets hash)))
+      (cond ((null? entries)
+	     (without-interrupts
+	      (lambda ()
+		(vector-set! buckets
+			     hash
+			     (cons (weak-cons key datum)
+				   (vector-ref buckets hash)))
+		(if (> (let ((count (fix:+ (table-count table) 1)))
+			 (set-table-count! table count)
+			 count)
+		       (table-grow-size table))
+		    (grow-table! table)))))
+	    ((eq? (system-pair-car (car entries)) key)
+	     (system-pair-set-cdr! (car entries) datum))
+	    (else
+	     (loop (cdr entries)))))))
+
+(define (eqht/for-each table procedure)
+  (for-each-vector-element (table-buckets table)
+    (lambda (entries)
+      (for-each (lambda (entry)
+		  (if (system-pair-car entry)
+		      (procedure (system-pair-car entry)
+				 (system-pair-cdr entry))))
+		entries))))
+
+;;;; Address Hashing
+
+(define (compute-key-hash table key)
+  (let loop ()
+    (let ((hash (eq-hash-mod key (vector-length (table-buckets table)))))
+      (if (not (table-needs-rehash? table))
+	  hash
+	  (begin
+	    (without-interrupts (lambda () (rehash-table! table)))
+	    (loop))))))
+
+(define-integrable (eq-hash-mod key modulus)
+  (fix:remainder (let ((n
+			((ucode-primitive primitive-object-set-type)
+			 (ucode-type positive-fixnum)
+			 key)))
+		   (if (fix:< n 0)
+		       (fix:not n)
+		       n))
+		 modulus))
+
+(define (record-address-hash-table! table)
+  (set! address-hash-tables (weak-cons table address-hash-tables))
+  unspecific)
+
+(define (mark-address-hash-tables!)
+  (let loop ((previous #f) (tables address-hash-tables))
+    (cond ((null? tables)
+	   unspecific)
+	  ((system-pair-car tables)
+	   (set-table-needs-rehash?! (system-pair-car tables) #t)
+	   (loop tables (system-pair-cdr tables)))
+	  (else
+	   (if previous
+	       (system-pair-set-cdr! previous (system-pair-cdr tables))
+	       (set! address-hash-tables (system-pair-cdr tables)))
+	   (loop previous (system-pair-cdr tables))))))
+
+(define address-hash-tables)
+
+(define (initialize-address-hashing!)
+  (set! address-hash-tables '())
+  (add-primitive-gc-daemon! mark-address-hash-tables!))
+
+;;;; Resizing
+
+(define (grow-table! table)
+  (let loop ((size (table-grow-size table)))
+    (if (> (table-count table) size)
+	(loop (let ((size* (round->exact (* size 2.))))
+		(if (> size* size)
+		    size*
+		    (+ size 1))))
+	(new-size! table size))))
+
+(define (shrink-table! table)
+  (let loop ((size (table-grow-size table)))
+    (cond ((<= size minimum-size)
+	   (new-size! table minimum-size))
+	  ((< (table-count table) (compute-shrink-size size))
+	   (loop (decrement-size size)))
+	  (else
+	   (new-size! table size)))))
+
+(define (new-size! table size)
+  (set-table-grow-size! table size)
+  (let ((old-buckets (table-buckets table)))
+    (reset-table! table)
+    (rehash-table-from-old-buckets! table old-buckets)))
+
+(define (reset-table! table)
+  (set-table-shrink-size! table (compute-shrink-size (table-grow-size table)))
+  (let ((primes
+	 (let ((size (round->exact (table-grow-size table))))
+	   (let loop
+	       ((primes
+		 (if (< size (stream-car (table-primes table)))
+		     prime-numbers-stream
+		     (table-primes table))))
+	     (if (<= size (stream-car primes))
+		 primes
+		 (loop (stream-cdr primes)))))))
+    (set-table-primes! table primes)
+    (set-table-buckets! table (make-vector (stream-car primes) '()))))
+
+(define (compute-shrink-size size)
+  (if (<= size minimum-size)
+      0
+      (max 0 (decrement-size (decrement-size size)))))
+
+(define (decrement-size size)
+  (let ((size* (round->exact (/ size 2.))))
+    (if (< size* size)
+	size*
+	(- size 1))))
+
+;;;; Rehashing
+
+(define (rehash-table-from-old-buckets! table buckets)
+  (let ((n-buckets (vector-length buckets)))
+    (set-table-needs-rehash?! table #f)
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i n-buckets))
+      (let ((entries (vector-ref buckets i)))
+	(if (not (null? entries))
+	    (rehash-table-entries! table entries)))))
+  (maybe-shrink-table! table))
+
+(define (rehash-table-entries! table entries)
+  (let ((buckets (table-buckets table)))
+    (let ((n-buckets (vector-length buckets)))
+      (let loop ((entries entries))
+	(if (not (null? entries))
+	    (let ((rest (cdr entries)))
+	      (if (system-pair-car (car entries))
+		  (let ((hash
+			 (eq-hash-mod (system-pair-car (car entries))
+				      n-buckets)))
+		    (set-cdr! entries (vector-ref buckets hash))
+		    (vector-set! buckets hash entries))
+		  (set-table-count! table (fix:- (table-count table) 1)))
+	      (loop rest)))))))
+
+(define (maybe-shrink-table! table)
+  ;; Since the rehashing also deletes invalid entries, the count
+  ;; might have been reduced.  So check to see if it's necessary to
+  ;; shrink the table even further.
+  (if (< (table-count table) (table-shrink-size table))
+      (shrink-table! table)))
+
+(define (rehash-table! table)
+  (let ((entries (extract-table-entries! table)))
+    (set-table-needs-rehash?! table #f)
+    (rehash-table-entries! table entries))
+  (maybe-shrink-table! table))
+
+(define (extract-table-entries! table)
+  (let ((buckets (table-buckets table)))
+    (let ((n-buckets (vector-length buckets)))
+      (let ((entries '()))
+	(do ((i 0 (fix:+ i 1)))
+	    ((fix:= i n-buckets))
+	  (let ((bucket (vector-ref buckets i)))
+	    (if (not (null? bucket))
+		(begin
+		  (let loop ((bucket bucket))
+		    (if (null? (cdr bucket))
+			(set-cdr! bucket entries)
+			(loop (cdr bucket))))
+		  (set! entries bucket)
+		  (vector-set! buckets i '())))))
+	entries))))
+
+;;;; Miscellaneous
+
+(define-structure (eqht (constructor %make-eqht ()) (conc-name table-))
+  (count 0)
+  (grow-size minimum-size)
+  (shrink-size 0)
+  buckets
+  (primes prime-numbers-stream)
+  (needs-rehash? #f))
+
+(define-integrable minimum-size 4)
+
+(define-integrable (without-interrupts thunk)
+  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+    (thunk)
+    (set-interrupt-enables! interrupt-mask)
+    unspecific))
+
+(define-integrable (weak-cons car cdr)
+  (system-pair-cons (ucode-type weak-cons) car cdr))
\ No newline at end of file
diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm
new file mode 100644
index 000000000..26b23a81b
--- /dev/null
+++ b/v7/src/runtime/generic.scm
@@ -0,0 +1,432 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: generic.scm,v 1.1 1996/04/23 20:37:35 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Generic Procedures
+
+(declare (usual-integrations)
+	 (integrate-external "gentag" "gencache"))
+
+;;;; Generic Procedures
+
+(define (make-generic-procedure arity #!optional name tag generator)
+  (let ((name (if (default-object? name) #f name))
+	(tag (if (default-object? tag) #f tag))
+	(generator (if (default-object? generator) #f generator)))
+    (if (and name (not (symbol? name)))
+	(error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE))
+    (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE))
+    (if (not (or (and (exact-integer? arity)
+		      (> arity 0))
+		 (and (pair? arity)
+		      (exact-integer? (car arity))
+		      (> (car arity) 0)
+		      (or (not (cdr arity))
+			  (and (exact-integer? (cdr arity))
+			       (>= (cdr arity) (car arity)))))))
+	(error:wrong-type-argument arity "arity"
+				   'MAKE-GENERIC-PROCEDURE))
+    (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE)
+    (let ((record
+	   (make-generic-record (or tag standard-generic-procedure-tag)
+				(if (and (pair? arity)
+					 (eqv? (car arity) (cdr arity)))
+				    (car arity)
+				    arity)
+				generator
+				name)))
+      (let ((generic (compute-apply-generic record)))
+	(set-generic-record/procedure! record generic)
+	(eqht/put! generic-procedure-records generic record)
+	generic))))
+
+(define-structure (generic-record
+		   (conc-name generic-record/)
+		   (constructor make-generic-record
+				(tag arity generator name)))
+  (tag #f read-only #t)
+  (arity #f read-only #t)
+  (generator #f)
+  (name #f read-only #t)
+  (cache (new-cache (if (pair? arity) (car arity) arity)))
+  procedure)
+
+(define (generic-record/min-arity record)
+  (arity-min (generic-record/arity record)))
+
+(define (generic-record/max-arity record)
+  (arity-max (generic-record/arity record)))
+
+(define (arity-min arity)
+  (if (pair? arity) (car arity) arity))
+
+(define (arity-max arity)
+  (if (pair? arity) (cdr arity) arity))
+
+(define (generic-procedure? object)
+  (if (eqht/get generic-procedure-records object #f) #t #f))
+
+(define (generic-procedure-arity generic)
+  (generic-record/arity
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
+
+(define (generic-procedure-name generic)
+  (generic-record/name
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-NAME)))
+
+(define (generic-procedure-generator generic)
+  (generic-record/generator
+   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-GENERATOR)))
+
+(define (set-generic-procedure-generator! generic generator)
+  (let ((record
+	 (guarantee-generic-procedure generic
+				      'SET-GENERIC-PROCEDURE-GENERATOR!)))
+    (guarantee-generator generator 'SET-GENERIC-PROCEDURE-GENERATOR!)
+    (without-interrupts
+     (lambda ()
+       (set-generic-record/generator! record generator)
+       (%reset-generic-procedure-cache! record)))))
+
+(define (purge-generic-procedure-cache generic #!optional filter)
+  (let ((operator
+	 (if (or (default-object? filter)
+		 (eq? 'ALL-ENTRIES filter))
+	     (lambda (generic record)
+	       generic
+	       (%reset-generic-procedure-cache! record))
+	     (lambda (generic record)
+	       (%purge-generic-procedure-cache! generic record filter)))))
+    (if (eq? 'ALL-PROCEDURES generic)
+	(eqht/for-each generic-procedure-records operator)
+	(operator
+	 generic
+	 (guarantee-generic-procedure generic
+				      'PURGE-GENERIC-PROCEDURE-CACHE)))))
+
+(define (%reset-generic-procedure-cache! record)
+  (set-generic-record/cache! record
+			     (new-cache (generic-record/min-arity record))))
+
+(define (%purge-generic-procedure-cache! generic record filter)
+  ;; This might have interrupts locked for a long time, and thus is an
+  ;; argument for using something like a semaphore to control access.
+  (without-interrupts
+   (lambda ()
+     (set-generic-record/cache!
+      record
+      (purge-cache-entries (generic-record/cache record)
+			   (lambda (tags) (filter generic tags)))))))
+
+(define (guarantee-generic-procedure generic caller)
+  (or (eqht/get generic-procedure-records generic #f)
+      (error:wrong-type-argument generic "generic procedure" caller)))
+
+(define (guarantee-generator generator caller)
+  (if (not (or (not generator)
+	       (and (procedure? generator)
+		    (procedure-arity-valid? generator 2))))
+      (error:wrong-type-argument generator
+				 "generic procedure generator"
+				 caller)))
+
+;;;; Generic Procedure Application
+
+(define (compute-apply-generic record)
+  (let ((arity (generic-record/arity record)))
+    (cond ((pair? arity) (apply-generic record))
+	  ((= 1 arity) (apply-generic-1 record))
+	  ((= 2 arity) (apply-generic-2 record))
+	  ((= 3 arity) (apply-generic-3 record))
+	  ((= 4 arity) (apply-generic-4 record))
+	  (else (apply-generic record)))))
+
+(define (apply-generic record)
+  (let ((min-arity (generic-record/min-arity record))
+	(max-arity (generic-record/max-arity record)))
+    (let ((extra (and max-arity (- max-arity min-arity))))
+      (letrec
+	  ((generic
+	    (lambda args
+	      (let loop ((args* args) (n min-arity) (tags '()))
+		(if (fix:= n 0)
+		    (begin
+		      (if (and extra
+			       (let loop ((args* args*) (n extra))
+				 (and (not (null? args*))
+				      (or (fix:= n 0)
+					  (loop (cdr args*)
+						(fix:- n 1))))))
+			  (wna args))
+		      (let ((procedure
+			     (probe-cache (generic-record/cache record) tags)))
+			(if procedure
+			    (apply procedure args)
+			    (compute-method-and-store record args))))
+		    (begin
+		      (if (null? args*)
+			  (wna args))
+		      (loop (cdr args*)
+			    (fix:- n 1)
+			    (cons (dispatch-tag (car args*)) tags)))))))
+	   (wna
+	    (lambda (args)
+	      (error:wrong-number-of-arguments generic
+					       (generic-record/arity record)
+					       args))))
+	generic))))
+
+(define (generic-procedure-applicable? procedure arguments)
+  (let ((record
+	 (guarantee-generic-procedure procedure
+				      'GENERIC-PROCEDURE-APPLICABLE?))
+	(tags (map dispatch-tag arguments)))
+    (let ((generator (generic-record/generator record))
+	  (arity (generic-record/arity record))
+	  (n-args (length tags)))
+      (and generator
+	   (if (pair? arity)
+	       (let ((min-arity (arity-min arity))
+		     (max-arity (arity-max arity)))
+		 (if (fix:= n-args min-arity)
+		     (generator procedure tags)
+		     (and (fix:> n-args min-arity)
+			  (or (not max-arity)
+			      (fix:<= n-args max-arity))
+			  (generator procedure (list-head tags min-arity)))))
+	       (and (fix:= arity n-args)
+		    (generator procedure tags)))))))
+
+(define (apply-generic-1 record)
+  (lambda (a1)
+    (declare (integrate-operator dispatch-tag))
+    (let ((procedure
+	   (probe-cache-1 (generic-record/cache record)
+			  (dispatch-tag a1))))
+      (if procedure
+	  (procedure a1)
+	  (compute-method-and-store record (list a1))))))
+
+(define (apply-generic-2 record)
+  (lambda (a1 a2)
+    (declare (integrate-operator dispatch-tag))
+    (let ((procedure
+	   (probe-cache-2 (generic-record/cache record)
+			  (dispatch-tag a1)
+			  (dispatch-tag a2))))
+      (if procedure
+	  (procedure a1 a2)
+	  (compute-method-and-store record (list a1 a2))))))
+
+(define (apply-generic-3 record)
+  (lambda (a1 a2 a3)
+    (declare (integrate-operator dispatch-tag))
+    (let ((procedure
+	   (probe-cache-3 (generic-record/cache record)
+			  (dispatch-tag a1)
+			  (dispatch-tag a2)
+			  (dispatch-tag a3))))
+      (if procedure
+	  (procedure a1 a2 a3)
+	  (compute-method-and-store record (list a1 a2 a3))))))
+
+(define (apply-generic-4 record)
+  (lambda (a1 a2 a3 a4)
+    (declare (integrate-operator dispatch-tag))
+    (let ((procedure
+	   (probe-cache-4 (generic-record/cache record)
+			  (dispatch-tag a1)
+			  (dispatch-tag a2)
+			  (dispatch-tag a3)
+			  (dispatch-tag a4))))
+      (if procedure
+	  (procedure a1 a2 a3 a4)
+	  (compute-method-and-store record (list a1 a2 a3 a4))))))
+
+(define (compute-method-and-store record args)
+  (let ((tags (map dispatch-tag args)))
+    (let ((procedure
+	   (let ((generator (generic-record/generator record))
+		 (generic (generic-record/procedure record)))
+	     (or (and generator (generator generic tags))
+		 (error:no-applicable-methods generic args)))))
+      (without-interrupts
+       (lambda ()
+	 (set-generic-record/cache!
+	  record
+	  (fill-cache (generic-record/cache record) tags procedure))))
+      (apply procedure args))))
+
+;;;; Object Tags
+
+;;; We assume that most new data types will be constructed from tagged
+;;; vectors, and therefore we should optimize the path for such
+;;; structures as much as possible.
+
+(define (dispatch-tag object)
+  (declare (integrate object))
+  (declare (ignore-reference-traps (set microcode-type-tag-table
+					microcode-type-method-table)))
+  (if (and (%record? object)
+	   (%record? (%record-ref object 0))
+	   (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
+      (%record-ref object 0)
+      (or (vector-ref microcode-type-tag-table (object-type object))
+	  ((vector-ref microcode-type-method-table (object-type object))
+	   object))))
+
+(define (make-built-in-tag name)
+  (let ((entry (assq name built-in-tag-table)))
+    (if entry
+	(cdr entry)
+	(let ((tag (make-dispatch-tag name)))
+	  (set! built-in-tag-table (cons (cons name tag) built-in-tag-table))
+	  tag))))
+
+(define (built-in-dispatch-tags)
+  (map cdr built-in-tag-table))
+
+(define (built-in-dispatch-tag name)
+  (let ((entry (assq name built-in-tag-table)))
+    (and entry
+	 (cdr entry))))
+
+(define condition-type:no-applicable-methods)
+(define error:no-applicable-methods)
+
+(define (initialize-conditions!)
+  (set! condition-type:no-applicable-methods
+	(make-condition-type 'NO-APPLICABLE-METHODS condition-type:error
+	    '(OPERATOR OPERANDS)
+	  (lambda (condition port)
+	    (write-string "No applicable methods for " port)
+	    (write (access-condition condition 'OPERATOR) port)
+	    (write-string " with these arguments: " port)
+	    (write (access-condition condition 'OPERANDS) port)
+	    (write-string "." port))))
+  (set! error:no-applicable-methods
+	(condition-signaller condition-type:no-applicable-methods
+			     '(OPERATOR OPERANDS)
+			     standard-error-handler))
+  unspecific)
+
+;;;; Initialization
+
+(define standard-generic-procedure-tag)
+(define generic-procedure-records)
+(define built-in-tag-table)
+(define microcode-type-tag-table)
+(define microcode-type-method-table)
+
+(define (initialize-generic-procedures!)
+  (set! standard-generic-procedure-tag
+	(make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE))
+  (set! generic-procedure-records (make-eqht))
+
+  ;; Initialize the built-in tag tables.
+  (set! built-in-tag-table '())
+  (set! microcode-type-tag-table
+	(make-initialized-vector (microcode-type/code-limit)
+	  (lambda (code)
+	    (make-built-in-tag
+	     (or (microcode-type/code->name code) 'OBJECT)))))
+  (set! microcode-type-method-table
+	(make-vector (microcode-type/code-limit) #f))
+  (let ((assign-type
+	 (lambda (name get-method)
+	   (let ((code (microcode-type/name->code name)))
+	     (vector-set! microcode-type-method-table code
+			  (get-method
+			   (vector-ref microcode-type-tag-table code)))
+	     (vector-set! microcode-type-tag-table code #f)))))
+    (define-integrable (maybe-generic object default-tag)
+      (let ((record (eqht/get generic-procedure-records object #f)))
+	(if record
+	    (generic-record/tag record)
+	    default-tag)))
+    (let ((procedure-type
+	   (lambda (default-tag)
+	     (lambda (object)
+	       (maybe-generic object default-tag)))))
+      (assign-type 'EXTENDED-PROCEDURE procedure-type)
+      (assign-type 'PROCEDURE procedure-type))
+    (assign-type
+     'COMPILED-ENTRY
+     (let ((procedure-tag (make-built-in-tag 'COMPILED-PROCEDURE))
+	   (return-address-tag (make-built-in-tag 'COMPILED-RETURN-ADDRESS))
+	   (expression-tag (make-built-in-tag 'COMPILED-EXPRESSION)))
+       (lambda (default-tag)
+	 (lambda (object)
+	   (case (system-hunk3-cxr0
+		  ((ucode-primitive compiled-entry-kind 1) object))
+	     ((0) (maybe-generic object procedure-tag))
+	     ((1) return-address-tag)
+	     ((2) expression-tag)
+	     (else default-tag))))))
+    (let ((boolean-tag (make-built-in-tag 'BOOLEAN)))
+      (if (> microcode-id/version 11)
+	  (assign-type 'CONSTANT
+		       (lambda (default-tag)
+			 (lambda (object)
+			   (if (or (eq? #f object) (eq? #t object))
+			       boolean-tag
+			       default-tag))))
+	  (begin
+	    (assign-type 'FALSE
+			 (lambda (default-tag)
+			   (lambda (object)
+			     (if (eq? #f object)
+				 boolean-tag
+				 default-tag))))
+	    (assign-type 'CONSTANT
+			 (lambda (default-tag)
+			   (lambda (object)
+			     (if (eq? #t object)
+				 boolean-tag
+				 default-tag)))))))
+    (assign-type 'FLONUM
+		 (let ((flonum-vector-tag
+			(make-built-in-tag 'FLONUM-VECTOR)))
+		   (lambda (default-tag)
+		     (lambda (object)
+		       (if (fix:= 2 (system-vector-length object))
+			   default-tag
+			   flonum-vector-tag)))))
+    (assign-type 'RECORD
+		 (let ((dt-tag (make-built-in-tag 'DISPATCH-TAG)))
+		   (lambda (default-tag)
+		     (lambda (object)
+		       (if (eq? dispatch-tag-marker (%record-ref object 0))
+			   dt-tag
+			   default-tag)))))))
\ No newline at end of file
diff --git a/v7/src/runtime/genmult.scm b/v7/src/runtime/genmult.scm
new file mode 100644
index 000000000..598b5997f
--- /dev/null
+++ b/v7/src/runtime/genmult.scm
@@ -0,0 +1,189 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: genmult.scm,v 1.1 1996/04/23 20:37:42 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Multiplexed Generic Procedures
+
+;;; This code assumes that a non-multiplexed generic procedure
+;;; generator is equivalent to the same generator stored in a
+;;; multiplexer.  Multiplexers assume that each of their generators is
+;;; applicable to a particular set of objects, and that the set does
+;;; not intersect any of the sets handled by other generators stored
+;;; in the same multiplexer.  Combining these two assumptions means
+;;; that a non-multiplexed generator must follow the convention for
+;;; multiplexed generators, even though there is no reason to do so in
+;;; the absence of multiplexers.
+
+;;; This convention is encouraged by hiding the low-level procedures
+;;; that allow direct access to a generic procedure's generator, and
+;;; forcing the programmer to go through the multiplexing interface.
+;;; That way, multiplexing appears to be an integral part of the
+;;; generic-procedure interface.
+
+(declare (usual-integrations))
+
+(define (generic-procedure-generator-list generic)
+  (let ((m (generic-procedure-generator generic)))
+    (if m
+	(if (multiplexer? m)
+	    (list-copy (multiplexer-list m))
+	    (list m))
+	'())))
+
+(define (add-generic-procedure-generator generic generator)
+  (let ((m (generic-procedure-generator generic)))
+    (if (multiplexer? m)
+	(begin
+	  (purge-generic-procedure-cache generic)
+	  (add-generator m generator))
+	(add-generator (install-multiplexer generic) generator))))
+
+(define (remove-generic-procedure-generator generic generator)
+  (let ((m (generic-procedure-generator generic)))
+    (if (multiplexer? m)
+	(begin
+	  (purge-generic-procedure-cache generic)
+	  (set-multiplexer-list! m (delq! generator (multiplexer-list m)))
+	  (maybe-deinstall-multiplexer generic))
+	(if (eq? generator m)
+	    (set-generic-procedure-generator! generic #f)))))
+
+(define (remove-generic-procedure-generators generic tags)
+  (for-each (lambda (generator)
+	      (if (generator generic tags)
+		  (remove-generic-procedure-generator generic generator)))
+	    (generic-procedure-generator-list generic)))
+
+(define (generic-procedure-default-generator generic)
+  (let ((m (generic-procedure-generator generic)))
+    (and (multiplexer? m)
+	 (multiplexer-default m))))
+
+(define (set-generic-procedure-default-generator! generic generator)
+  (let ((m (generic-procedure-generator generic)))
+    (cond ((multiplexer? m)
+	   (purge-generic-procedure-cache generic)
+	   (set-multiplexer-default! m generator)
+	   (maybe-deinstall-multiplexer generic))
+	  (generator
+	   (set-multiplexer-default! (install-multiplexer generic)
+				     generator)))))
+
+(define (install-multiplexer generic)
+  (let ((m (make-multiplexer)))
+    (let ((g (generic-procedure-generator generic)))
+      (if g
+	  (add-generator m g)))
+    (set-generic-procedure-generator! generic m)
+    m))
+
+(define (add-generator m generator)
+  (set-multiplexer-list! m (cons generator (multiplexer-list m))))
+
+(define (maybe-deinstall-multiplexer generic)
+  (let* ((m (generic-procedure-generator generic))
+	 (generators (multiplexer-list m)))
+    (cond ((and (null? generators)
+		(not (multiplexer-default m)))
+	   (set-generic-procedure-generator! generic #f))
+	  ((and (null? (cdr generators))
+		(not (multiplexer-default m)))
+	   (set-generic-procedure-generator! generic (car generators))))))
+
+(define (make-multiplexer)
+  (make-entity (lambda (multiplexer generic tags)
+		 (multiplexer-dispatch multiplexer generic tags))
+	       (make-multiplexer-record '() #f)))
+
+(define (multiplexer? object)
+  (and (entity? object)
+       (multiplexer-record? (entity-extra object))))
+
+(define (multiplexer-list multiplexer)
+  (multiplexer-record/list (entity-extra multiplexer)))
+
+(define (set-multiplexer-list! multiplexer list)
+  (set-multiplexer-record/list! (entity-extra multiplexer) list))
+
+(define (multiplexer-default multiplexer)
+  (multiplexer-record/default (entity-extra multiplexer)))
+
+(define (set-multiplexer-default! multiplexer default)
+  (set-multiplexer-record/default! (entity-extra multiplexer) default))
+
+(define-structure (multiplexer-record (conc-name multiplexer-record/))
+  list
+  default)
+
+(define (multiplexer-dispatch multiplexer generic tags)
+  (let loop ((generators (multiplexer-list multiplexer)))
+    (if (null? generators)
+	(let ((default (multiplexer-default multiplexer)))
+	  (and default
+	       (default generic tags)))
+	(let ((procedure ((car generators) generic tags)))
+	  (cond ((not procedure)
+		 (loop (cdr generators)))
+		((there-exists? (cdr generators)
+		   (lambda (generator)
+		     (generator generic tags)))
+		 (lambda args
+		   (error:extra-applicable-methods generic args)))
+		(else procedure))))))
+
+(define multiplexer-tag)
+(define del-rassq)
+(define condition-type:extra-applicable-methods)
+(define error:extra-applicable-methods)
+
+(define (initialize-multiplexer!)
+  (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER))
+  (set! del-rassq (delete-association-procedure list-deletor eq? cdr))
+  unspecific)
+
+(define (initialize-conditions!)
+  (set! condition-type:extra-applicable-methods
+	(make-condition-type 'EXTRA-APPLICABLE-METHODS condition-type:error
+	    '(OPERATOR OPERANDS)
+	  (lambda (condition port)
+	    (write-string "Too many applicable methods for " port)
+	    (write (access-condition condition 'OPERATOR) port)
+	    (write-string " with these arguments: " port)
+	    (write (access-condition condition 'OPERANDS) port)
+	    (write-string "." port))))
+  (set! error:extra-applicable-methods
+	(condition-signaller condition-type:extra-applicable-methods
+			     '(OPERATOR OPERANDS)
+			     standard-error-handler))
+  unspecific)
\ No newline at end of file
diff --git a/v7/src/runtime/gentag.scm b/v7/src/runtime/gentag.scm
new file mode 100644
index 000000000..4879828fd
--- /dev/null
+++ b/v7/src/runtime/gentag.scm
@@ -0,0 +1,107 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: gentag.scm,v 1.1 1996/04/23 20:37:51 cph Exp $
+;;;
+;;; Copyright (c) 1993-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Tags for Generic Procedure Dispatch
+
+;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
+;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
+;;; Functional Programming.  Parts of this code are based on the
+;;; September 16, 1992 PCL implementation.
+
+(declare (usual-integrations))
+
+(define (make-dispatch-tag contents)
+  (let ((tag
+	 (object-new-type
+	  (ucode-type record)
+	  ((ucode-primitive vector-cons) dispatch-tag-index-end #f))))
+    (%record-set! tag 0 dispatch-tag-marker)
+    (%record-set! tag 1 contents)
+    (do ((i dispatch-tag-index-start (fix:+ i 1)))
+	((fix:= i dispatch-tag-index-end))
+      (%record-set! tag i (get-dispatch-tag-cache-number)))
+    tag))
+
+(define-integrable (dispatch-tag? object)
+  (and (%record? object)
+       (eq? dispatch-tag-marker (%record-ref object 0))))
+
+(define-integrable dispatch-tag-marker
+  ((ucode-primitive string->symbol) "#[dispatch-tag]"))
+
+(define-integrable dispatch-tag-index-start 2)
+(define-integrable dispatch-tag-index-end 10)
+(define-integrable dispatch-tag-ref %record-ref)
+(define-integrable dispatch-tag-set! %record-set!)
+
+(define (dispatch-tag-contents tag)
+  (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS)
+  (%record-ref tag 1))
+
+(define (set-dispatch-tag-contents! tag contents)
+  (guarantee-dispatch-tag tag 'SET-DISPATCH-TAG-CONTENTS!)
+  (%record-set! tag 1 contents))
+
+(define-integrable (guarantee-dispatch-tag tag caller)
+  (if (not (dispatch-tag? tag))
+      (error:wrong-type-argument tag "dispatch tag" caller)))
+
+(declare (integrate-operator next-dispatch-tag-index))
+(define (next-dispatch-tag-index index)
+  (and (fix:< (fix:+ index 1) dispatch-tag-index-end)
+       (fix:+ index 1)))
+
+(define-integrable dispatch-tag-cache-number-adds-ok
+  ;; This constant controls the number of non-zero bits tag cache
+  ;; numbers will have.
+  ;;
+  ;; The value of this constant is the number of tag cache numbers
+  ;; that can be added and still be certain the result will be a
+  ;; fixnum.  This is implicitly used by all the code that computes
+  ;; primary cache locations from multiple tags.
+  4)
+
+(define get-dispatch-tag-cache-number)
+
+(define (initialize-tag-constants!)
+  (set! get-dispatch-tag-cache-number
+	(let ((modulus
+	       (int:quotient
+		(let loop ((n 2)) (if (fix:fixnum? n) (loop (int:* n 2)) n))
+		dispatch-tag-cache-number-adds-ok))
+	      (state (make-random-state)))
+	  (lambda ()
+	    (random modulus state))))
+  unspecific)
\ No newline at end of file
diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm
new file mode 100644
index 000000000..c9ae17f46
--- /dev/null
+++ b/v7/src/runtime/recslot.scm
@@ -0,0 +1,106 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: recslot.scm,v 1.1 1996/04/23 20:37:58 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Record Slot Access
+
+(declare (usual-integrations))
+
+(define (%record-accessor-generator name)
+  (lambda (generic tags)
+    generic
+    (let ((index (%record-slot-index (%record (car tags)) name)))
+      (and index
+	   (%record-accessor index)))))
+
+(define (%record-modifier-generator name)
+  (lambda (generic tags)
+    generic
+    (let ((index (%record-slot-index (%record (car tags)) name)))
+      (and index
+	   (%record-modifier index)))))
+
+(define (%record-initpred-generator name)
+  (lambda (generic tags)
+    generic
+    (let ((index (%record-slot-index (%record (car tags)) name)))
+      (and index
+	   (%record-initpred index)))))
+
+(define-macro (generate-index-cases index limit expand-case)
+  `(CASE ,index
+     ,@(let loop ((i 1))
+	 (if (= i limit)
+	     `((ELSE (,expand-case ,index)))
+	     `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))
+
+(define (%record-accessor index)
+  (generate-index-cases index 16
+    (lambda (index)
+      (declare (integrate index))
+      (lambda (record) (%record-ref record index)))))
+
+(define (%record-modifier index)
+  (generate-index-cases index 16
+    (lambda (index)
+      (declare (integrate index))
+      (lambda (record value) (%record-set! record index value)))))
+
+(define (%record-initpred index)
+  (generate-index-cases index 16
+    (lambda (index)
+      (declare (integrate index))
+      (lambda (record)
+	(not (eq? record-slot-uninitialized (%record-ref record index)))))))
+
+(define %record-slot-index)
+(define %record-slot-names)
+
+(define (initialize-record-slot-access!)
+  (set! %record-slot-index (make-generic-procedure 2 '%RECORD-SLOT-INDEX))
+  (add-generic-procedure-generator %record-slot-index
+    (lambda (generic tags)
+      generic
+      (and (record-type? (dispatch-tag-contents (car tags)))
+	   (lambda (record name)
+	     (record-type-field-index (record-type-descriptor record)
+				      name
+				      #f)))))
+  (set! %record-slot-names (make-generic-procedure 1 '%RECORD-SLOT-NAMES))
+  (add-generic-procedure-generator %record-slot-names
+    (lambda (generic tags)
+      generic
+      (and (record-type? (dispatch-tag-contents (car tags)))
+	   (lambda (record)
+	     (record-type-field-names (record-type-descriptor record)))))))
\ No newline at end of file
diff --git a/v7/src/runtime/tvector.scm b/v7/src/runtime/tvector.scm
new file mode 100644
index 000000000..c81e6e818
--- /dev/null
+++ b/v7/src/runtime/tvector.scm
@@ -0,0 +1,106 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: tvector.scm,v 1.1 1996/04/23 20:38:03 cph Exp $
+;;;
+;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of Electrical
+;;; Engineering and Computer Science.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions
+;;; that they make, so that these may be included in future releases;
+;;; and (b) to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the
+;;; usual standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation
+;;; of this software will be error-free, and MIT is under no
+;;; obligation to provide any services, by way of maintenance, update,
+;;; or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the Massachusetts
+;;; Institute of Technology nor of any adaptation thereof in any
+;;; advertising, promotional, or sales literature without prior
+;;; written consent from MIT in each case.
+
+;;;; Tagged Vectors
+
+(declare (usual-integrations))
+
+;;; These procedures are optimized for safety.  Applications that need
+;;; speed are assumed to break this abstraction and use "%record"
+;;; calls to construct and access tagged vectors.
+
+(define (make-tagged-vector tag length)
+  (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
+  (guarantee-index-integer length 'MAKE-TAGGED-VECTOR)
+  (let ((result
+	 (object-new-type (ucode-type record)
+			  (make-vector (fix:+ length 1)
+				       record-slot-uninitialized))))
+    (%record-set! result 0 tag)
+    result))
+
+(define (tagged-vector tag . elements)
+  (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
+  (object-new-type (ucode-type record) (apply vector tag elements)))
+
+(define (tagged-vector? object)
+  (and (%record? object)
+       (dispatch-tag? (%record-ref object 0))))
+
+(define (tagged-vector-tag vector)
+  (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG)
+  (%record-ref vector 0))
+
+(define (set-tagged-vector-tag! vector tag)
+  (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!)
+  (guarantee-dispatch-tag tag 'SET-TAGGED-VECTOR-TAG!)
+  (%record-set! vector 0 tag))
+
+(define (tagged-vector-length vector)
+  (guarantee-tagged-vector vector 'TAGGED-VECTOR-LENGTH)
+  (fix:- (%record-length vector) 1))
+
+(define (tagged-vector-element vector index)
+  (guarantee-tagged-vector-ref vector index 'TAGGED-VECTOR-ELEMENT)
+  (%record-ref vector (fix:+ index 1)))
+
+(define (set-tagged-vector-element! vector index value)
+  (guarantee-tagged-vector-ref vector index 'SET-TAGGED-VECTOR-ELEMENT!)
+  (%record-set! vector (fix:+ index 1) value))
+
+(define (tagged-vector-element-initialized? vector index)
+  (guarantee-tagged-vector-ref vector index
+			       'TAGGED-VECTOR-ELEMENT-INITIALIZED?)
+  (not (eq? (%record-ref vector (fix:+ index 1)) record-slot-uninitialized)))
+
+(define (guarantee-tagged-vector vector caller)
+  (if (not (tagged-vector? vector))
+      (error:wrong-type-argument vector "tagged vector" caller)))
+
+(define (guarantee-tagged-vector-ref vector index caller)
+  (guarantee-tagged-vector vector caller)
+  (guarantee-index-integer index caller)
+  (if (not (fix:< index (fix:- (%record-length vector) 1)))
+      (error:bad-range-argument index caller)))
+
+(define (guarantee-index-integer index caller)
+  (if (not (and (fix:fixnum? index) (fix:>= index 0)))
+      (error:wrong-type-argument vector "non-negative fixnum" caller)))
+
+(define record-slot-uninitialized)
+
+(define (initialize-tagged-vector!)
+  (set! record-slot-uninitialized (intern "#[record-slot-uninitialized]"))
+  unspecific)
\ No newline at end of file