From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Apr 1996 04:27:22 +0000 (+0000)
Subject: Integrate generic procedure mechanism into the runtime system.  This
X-Git-Tag: 20090517-FFI~5568
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=67f5a6809575a57dc9527236cb40a05c57a62703;p=mit-scheme.git

Integrate generic procedure mechanism into the runtime system.  This
mechanism implements a generic procedure call with good performance,
but does not define an associated class structure as is common in
object-oriented programming systems.  It is, however, sufficiently
general to allow such systems to be implemented on top of it, and even
to share objects between different systems if the systems cooperate
slightly.

Much of the change here is to reorganize the cold-load sequence so
that it is possible to bootstrap the runtime system.
---

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index f51503ca3..f0ca3663b 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.29 1995/07/10 21:15:01 adams Exp $
+$Id: defstr.scm,v 14.30 1996/04/24 04:22:19 cph Exp $
 
-Copyright (c) 1988-1995 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -82,8 +82,7 @@ differences:
 
 |#
 
-(define (initialize-package!)
-  (set! slot-assoc (association-procedure eq? slot/name))
+(define (initialize-define-structure-macro!)
   (syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE
     transform/define-structure))
 
@@ -107,12 +106,12 @@ differences:
 		  (+ index 1)))
 	  ((null? slots))
 	(set-slot/index! (car slots) index))
-      `(BEGIN ,@(constructor-definitions structure)
+      `(BEGIN ,@(type-definitions structure)
+	      ,@(constructor-definitions structure)
 	      ,@(accessor-definitions structure)
 	      ,@(modifier-definitions structure)
 	      ,@(predicate-definitions structure)
-	      ,@(copier-definitions structure)
-	      ,@(type-definitions structure)))))
+	      ,@(copier-definitions structure)))))
 
 ;;;; Parse Options
 
@@ -308,7 +307,8 @@ differences:
 				   ((eq? type 'RECORD)
 				    false)
 				   (else
-				    (make-default-defstruct-unparser-text name))))
+				    (make-default-defstruct-unparser-text
+				     name))))
 			type
 			named?
 			(and named? type-name)
@@ -365,81 +365,81 @@ differences:
 
 ;;;; Descriptive Structure
 
-(define structure-rtd
-  (make-record-type "structure"
-		    '(NAME
-		      CONC-NAME
-		      KEYWORD-CONSTRUCTORS
-		      BOA-CONSTRUCTORS
-		      COPIER-NAME
-		      PREDICATE-NAME
-		      PRINT-PROCEDURE
-		      TYPE
-		      NAMED?
-		      TYPE-NAME
-		      TAG-EXPRESSION
-		      OFFSET
-		      SLOTS)))
-
-(define make-structure
-  (record-constructor structure-rtd))
-
-(define structure?
-  (record-predicate structure-rtd))
-
-(define structure/name
-  (record-accessor structure-rtd 'NAME))
-
-(define structure/conc-name
-  (record-accessor structure-rtd 'CONC-NAME))
-
-(define structure/keyword-constructors
-  (record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
-
-(define structure/boa-constructors
-  (record-accessor structure-rtd 'BOA-CONSTRUCTORS))
-
-(define structure/copier-name
-  (record-accessor structure-rtd 'COPIER-NAME))
-
-(define structure/predicate-name
-  (record-accessor structure-rtd 'PREDICATE-NAME))
-
-(define structure/print-procedure
-  (record-accessor structure-rtd 'PRINT-PROCEDURE))
-
-(define structure/type
-  (record-accessor structure-rtd 'TYPE))
-
-(define structure/named?
-  (record-accessor structure-rtd 'NAMED?))
-
-(define structure/type-name
-  (record-accessor structure-rtd 'TYPE-NAME))
-
-(define structure/tag-expression
-  (record-accessor structure-rtd 'TAG-EXPRESSION))
-
-(define structure/offset
-  (record-accessor structure-rtd 'OFFSET))
-
-(define structure/slots
-  (record-accessor structure-rtd 'SLOTS))
-
-(define slot-rtd
-  (make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
-
-(define make-slot
-  (record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?)))
-
-(define slot/name (record-accessor slot-rtd 'NAME))
-(define slot/default (record-accessor slot-rtd 'DEFAULT))
-(define slot/type (record-accessor slot-rtd 'TYPE))
-(define slot/read-only? (record-accessor slot-rtd 'READ-ONLY?))
-(define slot/index (record-accessor slot-rtd 'INDEX))
-(define set-slot/index! (record-modifier slot-rtd 'INDEX))
-
+(define structure-rtd)
+(define make-structure)
+(define structure?)
+(define structure/name)
+(define structure/conc-name)
+(define structure/keyword-constructors)
+(define structure/boa-constructors)
+(define structure/copier-name)
+(define structure/predicate-name)
+(define structure/print-procedure)
+(define structure/type)
+(define structure/named?)
+(define structure/type-name)
+(define structure/tag-expression)
+(define structure/offset)
+(define structure/slots)
+
+(define slot-rtd)
+(define make-slot)
+(define slot/name)
+(define slot/default)
+(define slot/type)
+(define slot/read-only?)
+(define slot/index)
+(define set-slot/index!)
 (define slot-assoc)
+
+(define (initialize-structure-types!)
+  (set! structure-rtd
+	(make-record-type "structure"
+			  '(NAME
+			    CONC-NAME
+			    KEYWORD-CONSTRUCTORS
+			    BOA-CONSTRUCTORS
+			    COPIER-NAME
+			    PREDICATE-NAME
+			    PRINT-PROCEDURE
+			    TYPE
+			    NAMED?
+			    TYPE-NAME
+			    TAG-EXPRESSION
+			    OFFSET
+			    SLOTS)))
+  (set! make-structure (record-constructor structure-rtd))
+  (set! structure? (record-predicate structure-rtd))
+  (set! structure/name (record-accessor structure-rtd 'NAME))
+  (set! structure/conc-name (record-accessor structure-rtd 'CONC-NAME))
+  (set! structure/keyword-constructors
+	(record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
+  (set! structure/boa-constructors
+	(record-accessor structure-rtd 'BOA-CONSTRUCTORS))
+  (set! structure/copier-name (record-accessor structure-rtd 'COPIER-NAME))
+  (set! structure/predicate-name
+	(record-accessor structure-rtd 'PREDICATE-NAME))
+  (set! structure/print-procedure
+	(record-accessor structure-rtd 'PRINT-PROCEDURE))
+  (set! structure/type (record-accessor structure-rtd 'TYPE))
+  (set! structure/named? (record-accessor structure-rtd 'NAMED?))
+  (set! structure/type-name (record-accessor structure-rtd 'TYPE-NAME))
+  (set! structure/tag-expression
+	(record-accessor structure-rtd 'TAG-EXPRESSION))
+  (set! structure/offset (record-accessor structure-rtd 'OFFSET))
+  (set! structure/slots (record-accessor structure-rtd 'SLOTS))
+  (set! slot-rtd
+	(make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
+  (set! make-slot
+	(record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?)))
+  (set! slot/name (record-accessor slot-rtd 'NAME))
+  (set! slot/default (record-accessor slot-rtd 'DEFAULT))
+  (set! slot/type (record-accessor slot-rtd 'TYPE))
+  (set! slot/read-only? (record-accessor slot-rtd 'READ-ONLY?))
+  (set! slot/index (record-accessor slot-rtd 'INDEX))
+  (set! set-slot/index! (record-modifier slot-rtd 'INDEX))
+  (set! slot-assoc (association-procedure eq? slot/name))
+  (initialize-structure-type-type!))
 
 ;;;; Code Generation
 
@@ -511,20 +511,22 @@ differences:
 	 (map (lambda (slot)
 		(string->uninterned-symbol (symbol->string (slot/name slot))))
 	      (structure/slots structure))))
-    `(DEFINE (,name ,@slot-names)
-       (,(absolute
-	  (case (structure/type structure)
-	    ((RECORD) '%RECORD)
-	    ((VECTOR) 'VECTOR)
-	    ((LIST) 'LIST)))
-	,@(constructor-prefix-slots structure)
-	,@slot-names))))
+    (make-constructor structure name slot-names
+      (lambda (tag-expression)
+	`(,(absolute
+	    (case (structure/type structure)
+	      ((RECORD) '%RECORD)
+	      ((VECTOR) 'VECTOR)
+	      ((LIST) 'LIST)))
+	  ,@(constructor-prefix-slots structure tag-expression)
+	  ,@slot-names)))))
 
 (define (constructor-definition/keyword structure name)
   (let ((keyword-list (string->uninterned-symbol "keyword-list")))
-    `(DEFINE (,name . ,keyword-list)
-       ,(let ((list-cons
-	       `(,@(constructor-prefix-slots structure)
+    (make-constructor structure name keyword-list
+      (lambda (tag-expression)
+	(let ((list-cons
+	       `(,@(constructor-prefix-slots structure tag-expression)
 		 (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER)
 		  ,keyword-list
 		  (,(absolute 'LIST)
@@ -538,7 +540,7 @@ differences:
 	    ((VECTOR)
 	     `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons))
 	    ((LIST)
-	     `(,(absolute 'CONS*) ,@list-cons)))))))
+	     `(,(absolute 'CONS*) ,@list-cons))))))))
 
 (define (define-structure/keyword-parser argument-list default-alist)
   (if (null? argument-list)
@@ -559,38 +561,50 @@ differences:
 	(map cdr alist))))
 
 (define (constructor-definition/boa structure name lambda-list)
-  `(DEFINE (,name . ,lambda-list)
-     (,(absolute
-	(case (structure/type structure)
-	  ((RECORD) '%RECORD)
-	  ((VECTOR) 'VECTOR)
-	  ((LIST) 'LIST)))
-      ,@(constructor-prefix-slots structure)
-      ,@(parse-lambda-list lambda-list
-	  (lambda (required optional rest)
-	    (let ((name->slot
-		   (lambda (name)
-		     (or (slot-assoc name (structure/slots structure))
-			 (error "Not a defined structure slot:" name)))))
-	      (let ((required (map name->slot required))
-		    (optional (map name->slot optional))
-		    (rest (and rest (name->slot rest))))
-		(map (lambda (slot)
-		       (cond ((or (memq slot required)
-				  (eq? slot rest))
-			      (slot/name slot))
-			     ((memq slot optional)
-			      `(IF (DEFAULT-OBJECT? ,(slot/name slot))
-				   ,(slot/default slot)
-				   ,(slot/name slot)))
-			     (else
-			      (slot/default slot))))
-		     (structure/slots structure)))))))))
-
-(define (constructor-prefix-slots structure)
+  (make-constructor structure name lambda-list
+    (lambda (tag-expression)
+      `(,(absolute
+	  (case (structure/type structure)
+	    ((RECORD) '%RECORD)
+	    ((VECTOR) 'VECTOR)
+	    ((LIST) 'LIST)))
+	,@(constructor-prefix-slots structure tag-expression)
+	,@(parse-lambda-list lambda-list
+	    (lambda (required optional rest)
+	      (let ((name->slot
+		     (lambda (name)
+		       (or (slot-assoc name (structure/slots structure))
+			   (error "Not a defined structure slot:" name)))))
+		(let ((required (map name->slot required))
+		      (optional (map name->slot optional))
+		      (rest (and rest (name->slot rest))))
+		  (map (lambda (slot)
+			 (cond ((or (memq slot required)
+				    (eq? slot rest))
+				(slot/name slot))
+			       ((memq slot optional)
+				`(IF (DEFAULT-OBJECT? ,(slot/name slot))
+				     ,(slot/default slot)
+				     ,(slot/name slot)))
+			       (else
+				(slot/default slot))))
+		       (structure/slots structure))))))))))
+
+(define (make-constructor structure name arguments generate-body)
+  (let ((tag-expression (structure/tag-expression structure)))
+    (if (eq? (structure/type structure) 'RECORD)
+	(let ((tag (generate-uninterned-symbol 'TAG-)))
+	  `(DEFINE ,name
+	     (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
+	       (NAMED-LAMBDA (,name ,@arguments)
+		 ,(generate-body tag)))))
+	`(DEFINE (,name ,@arguments)
+	   ,(generate-body tag-expression)))))
+
+(define (constructor-prefix-slots structure tag-expression)
   (let ((offsets (make-list (structure/offset structure) false)))
     (if (structure/named? structure)
-	(cons (structure/tag-expression structure) offsets)
+	(cons tag-expression offsets)
 	offsets)))
 
 (define (copier-definitions structure)
@@ -609,24 +623,29 @@ differences:
     (if predicate-name
 	(let ((tag-expression (structure/tag-expression structure))
 	      (variable (string->uninterned-symbol "object")))
-	  `((DEFINE (,predicate-name ,variable)
-	      ,(case (structure/type structure)
-		 ((RECORD)
-		  `(AND (,(absolute '%RECORD?) ,variable)
-			(,(absolute 'EQ?)
-			 (,(absolute '%RECORD-REF) ,variable 0)
-			 ,tag-expression)))
-		 ((VECTOR)
-		  `(AND (,(absolute 'VECTOR?) ,variable)
-			(,(absolute 'NOT)
-			 (,(absolute 'ZERO?)
-			  (,(absolute 'VECTOR-LENGTH) ,variable)))
-			(,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
-					  ,tag-expression)))
-		 ((LIST)
-		  `(AND (,(absolute 'PAIR?) ,variable)
-			(,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
-					  ,tag-expression)))))))
+	  (case (structure/type structure)
+	    ((RECORD)
+	     (let ((tag (generate-uninterned-symbol 'TAG-)))
+	       `((DEFINE ,predicate-name
+		   (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
+		     (NAMED-LAMBDA (,predicate-name ,variable)
+		       (AND (,(absolute '%RECORD?) ,variable)
+			    (,(absolute 'EQ?)
+			     (,(absolute '%RECORD-REF) ,variable 0)
+			     ,tag))))))))
+	    ((VECTOR)
+	     `((DEFINE (,predicate-name ,variable)
+		 (AND (,(absolute 'VECTOR?) ,variable)
+		      (,(absolute 'NOT)
+		       (,(absolute 'ZERO?)
+			(,(absolute 'VECTOR-LENGTH) ,variable)))
+		      (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
+					,tag-expression)))))
+	    ((LIST)
+	     `((DEFINE (,predicate-name ,variable)
+		 (AND (,(absolute 'PAIR?) ,variable)
+		      (,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
+					,tag-expression)))))))
 	'())))
 
 (define (type-definitions structure)
@@ -659,33 +678,38 @@ differences:
 		       ,type-expression)))))))
       '()))
 
-(define structure-type-rtd
-  (make-record-type "structure-type"
-		    '(TYPE NAME FIELD-NAMES FIELD-INDEXES UNPARSER-METHOD)))
-
-(define make-define-structure-type
-  (record-constructor structure-type-rtd))
-
-(define structure-type?
-  (record-predicate structure-type-rtd))
-
-(define structure-type/type
-  (record-accessor structure-type-rtd 'TYPE))
-
-(define structure-type/name
-  (record-accessor structure-type-rtd 'NAME))
-
-(define structure-type/field-names
-  (record-accessor structure-type-rtd 'FIELD-NAMES))
-
-(define structure-type/field-indexes
-  (record-accessor structure-type-rtd 'FIELD-INDEXES))
-
-(define structure-type/unparser-method
-  (record-accessor structure-type-rtd 'UNPARSER-METHOD))
-
-(define set-structure-type/unparser-method!
-  (record-modifier structure-type-rtd 'UNPARSER-METHOD))
+(define structure-type-rtd)
+(define make-define-structure-type)
+(define structure-type?)
+(define structure-type/type)
+(define structure-type/name)
+(define structure-type/field-names)
+(define structure-type/field-indexes)
+(define structure-type/unparser-method)
+(define set-structure-type/unparser-method!)
+
+(define (initialize-structure-type-type!)
+  (set! structure-type-rtd
+	(make-record-type "structure-type"
+			  '(TYPE NAME FIELD-NAMES FIELD-INDEXES
+				 UNPARSER-METHOD)))
+  (set! make-define-structure-type
+	(record-constructor structure-type-rtd))
+  (set! structure-type?
+	(record-predicate structure-type-rtd))
+  (set! structure-type/type
+	(record-accessor structure-type-rtd 'TYPE))
+  (set! structure-type/name
+	(record-accessor structure-type-rtd 'NAME))
+  (set! structure-type/field-names
+	(record-accessor structure-type-rtd 'FIELD-NAMES))
+  (set! structure-type/field-indexes
+	(record-accessor structure-type-rtd 'FIELD-INDEXES))
+  (set! structure-type/unparser-method
+	(record-accessor structure-type-rtd 'UNPARSER-METHOD))
+  (set! set-structure-type/unparser-method!
+	(record-modifier structure-type-rtd 'UNPARSER-METHOD))
+  unspecific)
 
 (define (structure-tag/unparser-method tag type)
   (let ((structure-type (tag->structure-type tag type)))
diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm
index b0ce5a616..ac70fe01c 100644
--- a/v7/src/runtime/ed-ffi.scm
+++ b/v7/src/runtime/ed-ffi.scm
@@ -1,8 +1,8 @@
 #| -*- Scheme -*-
 
-$Id: ed-ffi.scm,v 1.15 1996/04/24 03:52:10 cph Exp $
+$Id: ed-ffi.scm,v 1.16 1996/04/24 04:27:22 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -114,10 +114,20 @@ MIT in each case. |#
 		syntax-table/system-internal)
     ("gdbm"	(runtime gdbm)
 		syntax-table/system-internal)
+    ("gencache"	(runtime generic-procedure)
+		syntax-table/system-internal)
+    ("geneqht"	(runtime generic-procedure)
+		syntax-table/system-internal)
+    ("generic"	(runtime generic-procedure)
+		syntax-table/system-internal)
     ("genio"	(runtime generic-i/o-port)
 		syntax-table/system-internal)
+    ("genmult"	(runtime generic-procedure multiplexer)
+		syntax-table/system-internal)
     ("gensym"	(runtime gensym)
 		syntax-table/system-internal)
+    ("gentag"	(runtime generic-procedure)
+		syntax-table/system-internal)
     ("global"	()
 		syntax-table/system-internal)
     ("graphics"	(runtime graphics)
@@ -210,6 +220,8 @@ MIT in each case. |#
 		syntax-table/system-internal)
     ("record"	(runtime record)
 		syntax-table/system-internal)
+    ("recslot"	(runtime record-slot-access)
+		syntax-table/system-internal)
     ("rep"	(runtime rep)
 		syntax-table/system-internal)
     ("savres"	(runtime save/restore)
@@ -256,6 +268,8 @@ MIT in each case. |#
 		syntax-table/system-internal)
     ("ttyio"	(runtime console-i/o-port)
 		syntax-table/system-internal)
+    ("tvector"	(runtime tagged-vector)
+		syntax-table/system-internal)
     ("udata"	()
 		syntax-table/system-internal)
     ("uenvir"	(runtime environment)
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 21b93cce7..7728f6a01 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.57 1995/04/13 22:24:53 cph Exp $
+$Id: make.scm,v 14.58 1996/04/24 04:23:54 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -342,11 +342,14 @@ MIT in each case. |#
 	 ("list" . (RUNTIME LIST))
 	 ("symbol" . ())
 	 ("uproc" . (RUNTIME PROCEDURE))
+	 ("fixart" . ())
+	 ("random" . (RUNTIME RANDOM-NUMBER))
+	 ("gentag" . (RUNTIME GENERIC-PROCEDURE))
 	 ("poplat" . (RUNTIME POPULATION))
-	 ("record" . (RUNTIME RECORD))))
+	 ("record" . (RUNTIME RECORD))
+	 ("defstr" . (RUNTIME DEFSTRUCT))))
       (files2
-       '(("defstr" . (RUNTIME DEFSTRUCT))
-	 ("prop1d" . (RUNTIME 1D-PROPERTY))
+       '(("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
       (load-files
@@ -362,9 +365,12 @@ MIT in each case. |#
 		      'CONSTANT-SPACE/BASE
 		      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
+		      #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
+  (package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
   (load-files files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
@@ -399,7 +405,6 @@ MIT in each case. |#
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t)
    (RUNTIME STATE-SPACE)
-   (RUNTIME MICROCODE-TABLES)
    (RUNTIME APPLY)
    (RUNTIME HASH)			; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
@@ -412,7 +417,6 @@ MIT in each case. |#
    (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
-   (RUNTIME RANDOM-NUMBER)
    ;; Microcode data structures
    (RUNTIME HISTORY)
    (RUNTIME LAMBDA-ABSTRACTION)
@@ -421,9 +425,20 @@ MIT in each case. |#
    (RUNTIME SCODE-WALKER)
    (RUNTIME CONTINUATION-PARSER)
    (RUNTIME PROGRAM-COPIER)
+   ;; Generic Procedures
+   ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER! #t)
+   ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS! #t)
+   ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES! #t)
+   ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE! #t)
+   ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE! #t)
    ;; Condition System
    (RUNTIME ERROR-HANDLER)
    (RUNTIME MICROCODE-ERRORS)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads
@@ -450,7 +465,7 @@ MIT in each case. |#
    (RUNTIME ILLEGAL-DEFINITIONS)
    (RUNTIME MACROS)
    (RUNTIME SYSTEM-MACROS)
-   (RUNTIME DEFSTRUCT)
+   ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index ab6f3ead8..1dadbcbf6 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.24 1995/11/01 01:05:28 cph Exp $
+$Id: packag.scm,v 14.25 1996/04/24 04:22:46 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -43,15 +43,14 @@ MIT in each case. |#
 ;;; record type, then build the record type and clobber it into the
 ;;; packages.  Thereafter, packages are constructed normally.
 
-(define package-rtd
-  false)
+(define package-tag #f)
 
 (define-integrable (make-package parent name environment)
-  (%record package-rtd parent '() name environment))
+  (%record package-tag parent '() name environment))
 
 (define (package? object)
   (and (%record? object)
-       (eq? (%record-ref object 0) package-rtd)))
+       (eq? (%record-ref object 0) package-tag)))
 
 (define-integrable (package/parent package)
   (%record-ref package 1))
@@ -74,16 +73,16 @@ MIT in each case. |#
 (define (finalize-package-record-type!)
   (let ((rtd
 	 (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT))))
-    (set! package-rtd rtd)
-    (let loop ((package system-global-package))
-      (%record-set! package 0 rtd)
-      (for-each loop (package/children package)))
-    (set-record-type-unparser-method!
-     rtd
-     (standard-unparser-method 'PACKAGE
-       (lambda (package port)
-	 (write-char #\space port)
-	 (write (package/name package) port))))))
+    (let ((tag (record-type-dispatch-tag rtd)))
+      (set! package-tag tag)
+      (let loop ((package system-global-package))
+	(%record-set! package 0 tag)
+	(for-each loop (package/children package))))
+    (set-record-type-unparser-method! rtd
+      (standard-unparser-method 'PACKAGE
+	(lambda (package port)
+	  (write-char #\space port)
+	  (write (package/name package) port))))))
 
 (define (package/child package name)
   (let loop ((children (package/children package)))
diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm
index 2c8eba137..e0107888b 100644
--- a/v7/src/runtime/pp.scm
+++ b/v7/src/runtime/pp.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: pp.scm,v 14.36 1995/08/06 15:53:07 adams Exp $
+$Id: pp.scm,v 14.37 1996/04/24 04:22:59 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,6 +38,11 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (define (initialize-package!)
+  (set! pp-description (make-generic-procedure 1 'PP-DESCRIPTION))
+  (set-generic-procedure-default-generator! pp-description
+    (lambda (generic tags)
+      generic tags
+      pp-description/default))
   (set! forced-indentation (special-printer kernel/forced-indentation))
   (set! pressured-indentation (special-printer kernel/pressured-indentation))
   (set! print-procedure (special-printer kernel/print-procedure))
@@ -59,7 +64,6 @@ MIT in each case. |#
   (set! dispatch-list code-dispatch-list)
   (set! dispatch-default print-combination)
   (set! cocked-object (generate-uninterned-symbol))
-  (set! hook/pp-description #f)
   unspecific)
 
 (define *pp-named-lambda->define?* false)
@@ -90,25 +94,24 @@ MIT in each case. |#
 	    (else
 	     (pretty-print object))))))
 
-(define (pp-description object)
-  (cond ((and hook/pp-description
-	      (hook/pp-description object)))
-	((named-structure? object)
+(define pp-description)
+
+(define (pp-description/default object)
+  (cond ((named-structure? object)
 	 (named-structure/description object))
 	((%record? object)		; unnamed record
 	 (let loop ((i (- (%record-length object) 1)) (d '()))
 	   (if (< i 0)
 	       d
-	       (loop (- i 1) (cons (list i (%record-ref object i)) d)))))
+	       (loop (- i 1)
+		     (cons (list i (%record-ref object i)) d)))))
 	((weak-pair? object)
-	 `((weak-car ,(weak-car object))
-	   (weak-cdr ,(weak-cdr object))))
+	 `((WEAK-CAR ,(weak-car object))
+	   (WEAK-CDR ,(weak-cdr object))))
 	((cell? object)
-	 `((contents ,(cell-contents object))))
+	 `((CONTENTS ,(cell-contents object))))
 	(else
 	 #f)))
-
-(define hook/pp-description)
 
 ;;; Controls the appearance of procedures in the CASE statement used
 ;;; to describe an arity dispatched procedure:
diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm
index 47831f926..e2a4d543e 100644
--- a/v7/src/runtime/random.scm
+++ b/v7/src/runtime/random.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: random.scm,v 14.13 1995/08/02 03:56:44 adams Exp $
+$Id: random.scm,v 14.14 1996/04/24 04:18:18 cph Exp $
 
 Copyright (c) 1993-95 Massachusetts Institute of Technology
 
@@ -59,20 +59,20 @@ MIT in each case. |#
 (define-integrable b. 4294967291. #|(exact->inexact b)|#)
 
 (define (random modulus #!optional state)
-  (if (not (and (real? modulus) (< 0 modulus)))
-      (error:wrong-type-argument modulus "positive real" 'RANDOM))
   (let ((element
 	 (flo:random-unit
 	  (guarantee-random-state (if (default-object? state) #f state)
 				  'RANDOM))))
     ;; Kludge: an exact integer modulus means that result is an exact
     ;; integer.  Otherwise, the result is a real number.
-    (cond ((flo:flonum? modulus)
+    (cond ((and (flo:flonum? modulus) (flo:< 0. modulus))
 	   (flo:* element modulus))
-	  ((exact-integer? modulus)
+	  ((and (int:integer? modulus) (int:< 0 modulus))
 	   (flo:truncate->exact (flo:* element (int:->flonum modulus))))
+	  ((and (real? modulus) (< 0 modulus))
+	   (* (inexact->exact element) modulus))
 	  (else
-	   (* (inexact->exact element) modulus)))))
+	   (error:wrong-type-argument modulus "positive real" 'RANDOM)))))
 
 (define (flo:random-unit state)
   (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
@@ -102,7 +102,7 @@ MIT in each case. |#
 
 (define (make-random-state #!optional state)
   (let ((state (if (default-object? state) #f state)))
-    (if (or (eq? #t state) (exact-integer? state))
+    (if (or (eq? #t state) (int:integer? state))
 	(initial-random-state
 	 (congruential-rng (+ (real-time-clock) 123456789)))
 	(copy-random-state
@@ -118,7 +118,7 @@ MIT in each case. |#
     (let fill ()
       (do ((i 0 (fix:+ i 1)))
 	  ((fix:= i r))
-	(flo:vector-set! seeds i (exact->inexact (generate-random-seed b))))
+	(flo:vector-set! seeds i (int:->flonum (generate-random-seed b))))
       ;; Disallow cases with all seeds either 0 or b-1, since they can
       ;; get locked in trivial cycles.
       (if (or (let loop ((i 0))
@@ -137,20 +137,34 @@ MIT in each case. |#
   (let ((a 16807 #|(expt 7 5)|#)
 	(m 2147483647 #|(- (expt 2 31) 1)|#))
     (let ((m-1 (- m 1)))
-      (let ((seed (+ (modulo seed m-1) 1)))
+      (let ((seed (+ (int:remainder seed m-1) 1)))
 	(lambda (b)
-	  (let ((n (modulo (* a seed) m)))
+	  (let ((n (int:remainder (* a seed) m)))
 	    (set! seed n)
-	    (quotient (* (- n 1) b) m-1)))))))
+	    (int:quotient (* (- n 1) b) m-1)))))))
+
+;;; The RANDOM-STATE data abstraction must be built by hand because
+;;; the random-number generator is needed in order to build the record
+;;; abstraction.
+
+(define-integrable (%make-random-state i b v)
+  (vector random-state-tag i b v))
+
+(define (random-state? object)
+  (and (vector? object)
+       (not (fix:= (vector-length object) 0))
+       (eq? (vector-ref object 0) random-state-tag)))
+
+(define random-state-tag
+  ((ucode-primitive string->symbol) "#[(runtime random-number)random-state]"))
+
+(define-integrable (random-state-index s) (vector-ref s 1))
+(define-integrable (set-random-state-index! s x) (vector-set! s 1 x))
+
+(define-integrable (random-state-borrow s) (vector-ref s 2))
+(define-integrable (set-random-state-borrow! s x) (vector-set! s 2 x))
 
-(define-structure (random-state
-		   (type vector)
-		   (named ((ucode-primitive string->symbol)
-			   "#[(runtime random-number)random-state]"))
-		   (constructor %make-random-state))
-  index
-  borrow
-  vector)
+(define-integrable (random-state-vector s) (vector-ref s 3))
 
 (define (copy-random-state state)
   (%make-random-state (random-state-index state)
@@ -180,4 +194,12 @@ MIT in each case. |#
 
 (define (initialize-package!)
   (set! *random-state* (make-random-state #t))
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+(define (finalize-random-state-type!)
+  (named-structure/set-tag-description! random-state-tag
+    (make-define-structure-type 'VECTOR
+				'RECORD-STATE
+				'(INDEX BORROW VECTOR)
+				'(1 2 3)
+				#f)))
\ No newline at end of file
diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 5bf3d407b..daa51b2ac 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.23 1994/09/01 22:39:01 adams Exp $
+$Id: record.scm,v 1.24 1996/04/24 04:23:11 cph Exp $
 
-Copyright (c) 1989-1994 Massachusetts Institute of Technology
+Copyright (c) 1989-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -49,30 +49,6 @@ MIT in each case. |#
   (primitive-object-set! 3)
   (primitive-object-set-type 2))
 
-(define record-type-type)
-(define record-type-population)
-(define record-type-initialization-hook)
-
-(define (initialize-package!)
-  (set! record-type-type
-	(let ((record-type-type
-	       (%record false
-			false
-			"record-type"
-			'(RECORD-TYPE-APPLICATION-METHOD
-			  RECORD-TYPE-NAME
-			  RECORD-TYPE-FIELD-NAMES
-			  RECORD-TYPE-METHODS
-			  RECORD-TYPE-CLASS-WRAPPER)
-			'()
-			false)))
-	  (%record-set! record-type-type 0 record-type-type)
-	  (%record-type-has-application-method! record-type-type)
-	  record-type-type))
-  (set! record-type-population (make-population))
-  (set! record-type-initialization-hook false)
-  (add-to-population! record-type-population record-type-type))
-
 (define-integrable (%record? object)
   (object-type? (ucode-type record) object))
 
@@ -81,9 +57,10 @@ MIT in each case. |#
       (error:wrong-type-argument length "exact integer" '%MAKE-RECORD))
   (if (not (> length 0))
       (error:bad-range-argument length '%MAKE-RECORD))
-  (if (default-object? object)
-      (object-new-type (ucode-type record) (make-vector length))
-      (object-new-type (ucode-type record) (make-vector length object))))
+  (object-new-type
+   (ucode-type record)
+   ((ucode-primitive vector-cons) length
+				  (if (default-object? object) #f object))))
 
 (define (%record-copy record)
   (let ((length (%record-length record)))
@@ -96,109 +73,121 @@ MIT in each case. |#
 	  ((= index length))
 	(%record-set! result index (%record-ref record index)))
       result)))
-
-(define (%record-application-method record)
-  ;; This procedure must match the code in "microcode/interp.c".
-  (let ((record-type (%record-ref record 0)))
-    (and (%record? record-type)
-	 (and (object-type? (ucode-type constant)
-			    (primitive-object-ref record-type 0))
-	      (>= (%record-length record-type) 2))
-	 (let ((method (%record-ref record-type 1)))
-	   (and (not (eq? method record))
-		method)))))
-
-(define (%record-type-has-application-method! record-type)
-  (primitive-object-set!
-   record-type
-   0
-   (primitive-object-set-type (ucode-type constant)
-			      (primitive-object-ref record-type 0))))
+
+(define record-type-type-tag)
+(define unparse-record)
+(define record-description)
+
+(define (initialize-record-type-type!)
+  (let ((type
+	 (%record #f
+		  "record-type"
+		  '(RECORD-TYPE-NAME
+		    RECORD-TYPE-FIELD-NAMES
+		    RECORD-TYPE-DISPATCH-TAG)
+		  #f)))
+    (set! record-type-type-tag (make-dispatch-tag type))
+    (%record-set! type 0 record-type-type-tag)
+    (%record-set! type 3 record-type-type-tag)))
+
+(define (initialize-record-procedures!)
+  (set! unparse-record (make-generic-procedure 2 'UNPARSE-RECORD))
+  (set-generic-procedure-default-generator! unparse-record
+    (let ((record-method (standard-unparser-method 'RECORD #f)))
+      (lambda (generic tags)
+	generic
+	(let ((tag (cadr tags)))
+	  (cond ((record-type? (dispatch-tag-contents tag))
+		 (standard-unparser-method
+		  (record-type-name (dispatch-tag-contents tag))
+		  #f))
+		((eq? tag record-type-type-tag)
+		 (standard-unparser-method 'TYPE
+		   (lambda (type port)
+		     (write-char #\space port)
+		     (display (record-type-name type) port))))
+		((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
+		 (standard-unparser-method 'DISPATCH-TAG
+		   (lambda (tag port)
+		     (write-char #\space port)
+		     (write (dispatch-tag-contents tag) port))))
+		(else record-method))))))
+  (set! set-record-type-unparser-method!
+	set-record-type-unparser-method!/after-boot)
+  (for-each (lambda (t.m)
+	      (set-record-type-unparser-method! (car t.m) (cdr t.m)))
+	    deferred-unparser-methods)
+  (set! deferred-unparser-methods)
+  (set! record-description (make-generic-procedure 1 'RECORD-DESCRIPTION))
+  (set-generic-procedure-default-generator! record-description
+    (lambda (generic tags)
+      generic
+      (if (record-type? (dispatch-tag-contents (car tags)))
+	  (lambda (record)
+	    (let ((type (record-type-descriptor record)))
+	      (map (lambda (field-name)
+		     `(,field-name
+		       ,((record-accessor type field-name) record)))
+		   (record-type-field-names type))))
+	  (lambda (record)
+	    (let loop ((i (fix:- (%record-length record) 1)) (d '()))
+	      (if (fix:< i 0)
+		  d
+		  (loop (fix:- i 1)
+			(cons (list i (%record-ref record i)) d)))))))))
 
 (define (make-record-type type-name field-names #!optional print-method)
   (guarantee-list-of-unique-symbols field-names 'MAKE-RECORD-TYPE)
   (let ((record-type
-	 (%record record-type-type
-		  false
+	 (%record record-type-type-tag
 		  (->string type-name)
 		  (list-copy field-names)
-		  '()
-		  false)))
-    (%record-type-has-application-method! record-type)
-    (add-to-population! record-type-population record-type)
-    (if record-type-initialization-hook
-	(record-type-initialization-hook record-type))
+		  #f)))
+    (%record-set! record-type 3 (make-dispatch-tag record-type))
     (if (not (default-object? print-method))
 	(set-record-type-unparser-method! record-type print-method))
     record-type))
 
 (define (record-type? object)
   (and (%record? object)
-       (eq? (%record-ref object 0) record-type-type)))
-
-(define (record-type-application-method record-type)
-  (guarantee-record-type record-type 'RECORD-TYPE-APPLICATION-METHOD)
-  (%record-ref record-type 1))
-
-(define (set-record-type-application-method! record-type method)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-APPLICATION-METHOD!)
-  (if (not (or (not method) (procedure? method)))
-      (error:wrong-type-argument method "application method"
-				 'SET-RECORD-TYPE-APPLICATION-METHOD!))
-  (%record-set! record-type 1 method))
+       (eq? (%record-ref object 0) record-type-type-tag)))
 
 (define (record-type-name record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-NAME)
-  (%record-type/name record-type))
-
-(define-integrable (%record-type/name record-type)
-  (%record-ref record-type 2))
+  (%record-ref record-type 1))
 
 (define (record-type-field-names record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
-  (list-copy (%record-type/field-names record-type)))
+  (%record-ref record-type 2))
 
-(define-integrable (%record-type/field-names record-type)
+(define (record-type-dispatch-tag record-type)
+  (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG)
   (%record-ref record-type 3))
 
-(define (record-type-unparser-method record-type)
-  (record-type-method record-type 'UNPARSER))
-
 (define (set-record-type-unparser-method! record-type method)
+  (set! deferred-unparser-methods
+	(cons (cons record-type method) deferred-unparser-methods))
+  unspecific)
+
+(define deferred-unparser-methods '())
+
+(define (set-record-type-unparser-method!/after-boot record-type method)
   (if (not (or (not method) (procedure? method)))
       (error:wrong-type-argument method "unparser method"
 				 'SET-RECORD-TYPE-UNPARSER-METHOD!))
-  (set-record-type-method! record-type 'UNPARSER method))
-
-(define (record-type-method record-type keyword)
-  (guarantee-record-type record-type 'RECORD-TYPE-METHOD)
-  (let ((entry (assq keyword (%record-ref record-type 4))))
-    (and entry
-	 (cdr entry))))
-
-(define (set-record-type-method! record-type keyword method)
-  (guarantee-record-type record-type 'SET-RECORD-TYPE-METHOD!)
-  (let ((methods (%record-ref record-type 4)))
-    (let ((entry (assq keyword methods)))
-      (if method
-	  (if entry
-	      (set-cdr! entry method)
-	      (%record-set! record-type 4
-			    (cons (cons keyword method) methods)))
-	  (if entry
-	      (%record-set! record-type 4 (delq! entry methods)))))))
-
-(define (record-type-field-index record-type field-name procedure-name)
-  (let loop ((field-names (%record-type/field-names record-type)) (index 1))
-    (if (null? field-names)
-	(error:bad-range-argument field-name procedure-name))
-    (if (eq? field-name (car field-names))
-	index
-	(loop (cdr field-names) (+ index 1)))))
+  (remove-generic-procedure-generators
+   unparse-record
+   (list (make-dispatch-tag #f) record-type))
+  (add-generic-procedure-generator unparse-record
+    (lambda (generic tags)
+      generic
+      (and (eq? (cadr tags) (record-type-dispatch-tag record-type))
+	   method))))
 
 (define (record-constructor record-type #!optional field-names)
   (guarantee-record-type record-type 'RECORD-CONSTRUCTOR)
-  (let ((all-field-names (%record-type/field-names record-type)))
+  (let ((all-field-names (record-type-field-names record-type))
+	(tag (record-type-dispatch-tag record-type)))
     (let ((field-names
 	   (if (default-object? field-names) all-field-names field-names))
 	  (record-length (+ 1 (length all-field-names))))
@@ -216,7 +205,7 @@ MIT in each case. |#
 	  (let ((record
 		 (object-new-type (ucode-type record)
 				  (make-vector record-length))))
-	    (%record-set! record 0 record-type)
+	    (%record-set! record 0 tag)
 	    (do ((indexes indexes (cdr indexes))
 		 (field-values field-values (cdr field-values)))
 		((null? indexes))
@@ -225,51 +214,55 @@ MIT in each case. |#
 
 (define (record? object)
   (and (%record? object)
-       (record-type? (%record-ref object 0))))
+       (dispatch-tag? (%record-ref object 0))
+       (record-type? (dispatch-tag-contents (%record-ref object 0)))))
 
 (define (record-type-descriptor record)
   (guarantee-record record 'RECORD-TYPE-DESCRIPTOR)
-  (%record-ref record 0))
+  (dispatch-tag-contents (%record-ref record 0)))
 
 (define (record-copy record)
   (guarantee-record record 'RECORD-COPY)
   (%record-copy record))
 
-(define (record-description record)
-  (let ((type (record-type-descriptor record)))
-    (let ((method (record-type-method type 'DESCRIPTION)))
-      (if method
-	  (method record)
-	  (map (lambda (field-name)
-		 `(,field-name ,((record-accessor type field-name) record)))
-	       (record-type-field-names type))))))
-
 (define (record-predicate record-type)
   (guarantee-record-type record-type 'RECORD-PREDICATE)
-  (lambda (object)
-    (and (%record? object)
-	 (eq? (%record-ref object 0) record-type))))
+  (let ((tag (record-type-dispatch-tag record-type)))
+    (lambda (object)
+      (and (%record? object)
+	   (eq? (%record-ref object 0) tag)))))
 
 (define (record-accessor record-type field-name)
   (guarantee-record-type record-type 'RECORD-ACCESSOR)
-  (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
+  (let ((tag (record-type-dispatch-tag record-type))
+	(type-name (record-type-name record-type))
+	(procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
 	(index
 	 (record-type-field-index record-type field-name 'RECORD-ACCESSOR)))
     (lambda (record)
-      (guarantee-record-of-type record record-type procedure-name)
+      (guarantee-record-of-type record tag type-name procedure-name)
       (%record-ref record index))))
 
 (define (record-modifier record-type field-name)
   (guarantee-record-type record-type 'RECORD-MODIFIER)
-  (let ((procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
+  (let ((tag (record-type-dispatch-tag record-type))
+	(type-name (record-type-name record-type))
+	(procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
 	(index
 	 (record-type-field-index record-type field-name 'RECORD-MODIFIER)))
     (lambda (record field-value)
-      (guarantee-record-of-type record record-type procedure-name)
+      (guarantee-record-of-type record tag type-name procedure-name)
       (%record-set! record index field-value))))
 
 (define record-updater
   record-modifier)
+
+(define (record-type-field-index record-type field-name error-name)
+  (let loop ((field-names (record-type-field-names record-type)) (index 1))
+    (cond ((null? field-names)
+	   (and error-name (error:bad-range-argument field-name error-name)))
+	  ((eq? field-name (car field-names)) index)
+	  (else (loop (cdr field-names) (+ index 1))))))
 
 (define (->string object)
   (if (string? object)
@@ -292,13 +285,13 @@ MIT in each case. |#
   (if (not (record-type? record-type))
       (error:wrong-type-argument record-type "record type" procedure)))
 
-(define-integrable (guarantee-record-of-type record record-type procedure-name)
+(define-integrable (guarantee-record-of-type record tag type-name
+					     procedure-name)
   (if (not (and (%record? record)
-		(eq? (%record-ref record 0) record-type)))
-      (error:wrong-type-argument
-       record
-       (string-append "record of type " (%record-type/name record-type))
-       procedure-name)))
+		(eq? (%record-ref record 0) tag)))
+      (error:wrong-type-argument record
+				 (string-append "record of type " type-name)
+				 procedure-name)))
 
 (define-integrable (guarantee-record record procedure-name)
   (if (not (record? record))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index eaac1ef3d..3fa03546e 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.268 1996/04/24 03:48:50 cph Exp $
+$Id: runtime.pkg,v 14.269 1996/04/24 04:17:28 cph Exp $
 
 Copyright (c) 1988-96 Massachusetts Institute of Technology
 
@@ -762,6 +762,8 @@ MIT in each case. |#
 	  add-primitive-gc-daemon!)
   (export (runtime hash-table)
 	  add-primitive-gc-daemon!)
+  (export (runtime generic-procedure eqht)
+	  add-primitive-gc-daemon!)
   (export (runtime interrupt-handler)
 	  trigger-gc-daemons!)
   (initialization (initialize-package!)))
@@ -1634,6 +1636,7 @@ MIT in each case. |#
 	  *pp-uninterned-symbols-by-name*
 	  make-pretty-printer-highlight
 	  pp
+	  pp-description
 	  pretty-print)
   (initialization (initialize-package!)))
 
@@ -1805,12 +1808,10 @@ MIT in each case. |#
   (export ()
 	  %make-record
 	  %record
-	  %record-application-method
 	  %record-copy
 	  %record-length
 	  %record-ref
 	  %record-set!
-	  %record-type-has-application-method!
 	  %record?
 	  make-record-type
 	  record-accessor
@@ -1819,18 +1820,17 @@ MIT in each case. |#
 	  record-description
 	  record-modifier
 	  record-predicate
-	  record-type-application-method
 	  record-type-descriptor
+	  record-type-dispatch-tag
 	  record-type-field-names
-	  record-type-method
 	  record-type-name
-	  record-type-unparser-method
 	  record-type?
 	  record-updater
 	  record?
-	  set-record-type-application-method!
-	  set-record-type-method!
-	  set-record-type-unparser-method!)
+	  set-record-type-unparser-method!
+	  unparse-record)
+  (export (runtime record-slot-access)
+	  record-type-field-index)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
@@ -3185,4 +3185,115 @@ MIT in each case. |#
 	  ordered-vector-matches
 	  ordered-vector-minimum-match
 	  search-ordered-subvector
-	  search-ordered-vector))
\ No newline at end of file
+	  search-ordered-vector))
+
+(define-package (runtime gdbm)
+  (file-case options
+    ((load) "gdbm")
+    (else))
+  (parent ())
+  (export ()
+	  gdbm-available?
+	  gdbm-close
+	  gdbm-delete
+	  gdbm-exists?
+	  gdbm-fetch
+	  gdbm-firstkey
+	  gdbm-nextkey
+	  gdbm-open
+	  gdbm-reorganize
+	  gdbm-setopt
+	  gdbm-store
+	  gdbm-sync
+	  gdbm-version
+	  gdbm_cachesize
+	  gdbm_fast
+	  gdbm_fastmode
+	  gdbm_insert
+	  gdbm_newdb
+	  gdbm_reader
+	  gdbm_replace
+	  gdbm_wrcreat
+	  gdbm_writer))
+
+(define-package (runtime generic-procedure)
+  (files "gentag" "gencache" "generic")
+  (parent ())
+  (export ()
+	  ;; tag.scm:
+	  dispatch-tag-contents
+	  dispatch-tag?
+	  guarantee-dispatch-tag
+	  make-dispatch-tag
+	  set-dispatch-tag-contents!
+
+	  ;; generic.scm:
+	  arity-max
+	  arity-min
+	  built-in-dispatch-tag
+	  built-in-dispatch-tags
+	  condition-type:no-applicable-methods
+	  dispatch-tag
+	  error:no-applicable-methods
+	  generic-procedure-applicable?
+	  generic-procedure-arity
+	  generic-procedure-name
+	  generic-procedure?
+	  guarantee-generic-procedure
+	  make-generic-procedure
+	  purge-generic-procedure-cache
+	  standard-generic-procedure-tag)
+  (export (runtime generic-procedure multiplexer)
+	  generic-procedure-generator
+	  set-generic-procedure-generator!))
+
+(define-package (runtime generic-procedure multiplexer)
+  (files "genmult")
+  (parent ())
+  (export ()
+	  add-generic-procedure-generator
+	  condition-type:extra-applicable-methods
+	  error:extra-applicable-methods
+	  generic-procedure-default-generator
+	  generic-procedure-generator-list
+	  remove-generic-procedure-generator
+	  remove-generic-procedure-generators
+	  set-generic-procedure-default-generator!))
+
+(define-package (runtime tagged-vector)
+  (files "tvector")
+  (parent ())
+  (export ()
+	  guarantee-tagged-vector
+	  make-tagged-vector
+	  record-slot-uninitialized
+	  set-tagged-vector-element!
+	  set-tagged-vector-tag!
+	  tagged-vector
+	  tagged-vector-element
+	  tagged-vector-element-initialized?
+	  tagged-vector-length
+	  tagged-vector-tag
+	  tagged-vector?))
+
+(define-package (runtime record-slot-access)
+  (files "recslot")
+  (parent ())
+  (export ()
+	  %record-accessor
+	  %record-accessor-generator
+	  %record-initpred
+	  %record-initpred-generator
+	  %record-modifier
+	  %record-modifier-generator
+	  %record-slot-index
+	  %record-slot-names))
+
+(define-package (runtime generic-procedure eqht)
+  (files "geneqht")
+  (parent ())
+  (export (runtime generic-procedure)
+	  eqht/for-each
+	  eqht/get
+	  eqht/put!
+	  make-eqht))
\ No newline at end of file
diff --git a/v7/src/runtime/unpars.scm b/v7/src/runtime/unpars.scm
index bfec4fc3c..962077cb4 100644
--- a/v7/src/runtime/unpars.scm
+++ b/v7/src/runtime/unpars.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: unpars.scm,v 14.44 1995/07/27 21:10:31 adams Exp $
+$Id: unpars.scm,v 14.45 1996/04/24 04:17:53 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -41,8 +41,6 @@ MIT in each case. |#
   (set! string-delimiters
 	(char-set-union char-set:not-graphic (char-set #\" #\\)))
   (set! hook/interned-symbol unparse-symbol)
-  (set! hook/record-unparser false)
-  (set! hook/unparse-record false)
   (set! hook/procedure-unparser false)
   (set! *unparser-radix* 10)
   (set! *unparser-list-breadth-limit* false)
@@ -320,7 +318,8 @@ MIT in each case. |#
   (cond ((not object) (*unparse-string "#f"))
 	((null? object) (*unparse-string "()"))
 	((eq? object #t) (*unparse-string "#t"))
-	((undefined-value? object) (*unparse-string "#[unspecified-return-value]"))
+	((undefined-value? object)
+	 (*unparse-string "#[unspecified-return-value]"))
 	((eq? object lambda-auxiliary-tag) (*unparse-string "#!aux"))
 	((eq? object lambda-optional-tag) (*unparse-string "#!optional"))
 	((eq? object lambda-rest-tag) (*unparse-string "#!rest"))
@@ -461,26 +460,9 @@ MIT in each case. |#
   (vector-ref vector index))
 
 (define (unparse/record record)
-  (let ((method
-	 (and hook/record-unparser
-	      (hook/record-unparser record))))
-    (cond (method
-	   (invoke-user-method method record))
-	  ((record? record)
-	   (let ((type (record-type-descriptor record)))
-	     (let ((method
-		    (or (record-type-unparser-method type)
-			hook/unparse-record)))
-	       (if method
-		   (invoke-user-method method record)
-		   (*unparse-with-brackets (record-type-name type)
-					   record
-					   #f)))))
-	  (else
-	   (unparse/default record)))))
-
-(define hook/record-unparser)
-(define hook/unparse-record)
+  (if *unparse-with-maximum-readability?*
+      (*unparse-readable-hash record)
+      (invoke-user-method unparse-record record)))
 
 (define (unparse/pair pair)
   (let ((prefix (unparse-list/prefix-pair? pair)))
@@ -569,9 +551,13 @@ MIT in each case. |#
   (let ((method
 	 (and hook/procedure-unparser
 	      (hook/procedure-unparser procedure))))
-    (if method
-	(invoke-user-method method procedure)
-	(usual-method))))
+    (cond (method (invoke-user-method method procedure))
+	  ((generic-procedure? procedure)
+	   (*unparse-with-brackets 'GENERIC-PROCEDURE procedure
+	     (let ((name (generic-procedure-name procedure)))
+	       (and name
+		    (lambda () (*unparse-object name))))))
+	  (else (usual-method)))))
 
 (define (unparse/compound-procedure procedure)
   (unparse-procedure procedure
diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index 5cc392acc..a255a0fb8 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.8 1995/02/14 01:06:18 cph Exp $
+$Id: uproc.scm,v 1.9 1996/04/24 04:23:19 cph Exp $
 
-Copyright (c) 1990-92 Massachusetts Institute of Technology
+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
@@ -79,17 +79,11 @@ MIT in each case. |#
 	  (else (error "not a procedure" procedure)))))
 
 (define (skip-entities object)
-  (cond ((%entity? object)
-	 (skip-entities (if (%entity-is-apply-hook? object)
-			    (apply-hook-procedure object)
-			    (entity-procedure object))))
-	((%record? object)
-	 (let ((method (%record-application-method object)))
-	   (if method
-	       (skip-entities method)
-	       object)))
-	(else
-	 object)))
+  (if (%entity? object)
+      (skip-entities (if (%entity-is-apply-hook? object)
+			 (apply-hook-procedure object)
+			 (entity-procedure object)))
+      object))
 
 (define (procedure-arity procedure)
   (let loop ((p procedure) (e 0))
@@ -291,7 +285,8 @@ MIT in each case. |#
   (system-pair-set-cdr! entity extra))
 
 (define (make-apply-hook procedure extra)
-  (make-entity (lambda args (apply procedure (cdr args)))
+  (make-entity (lambda (entity . args)
+		 (apply (apply-hook-procedure entity) args))
 	       (hunk3-cons apply-hook-tag procedure extra)))
 
 (define (apply-hook? object)
diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 55ac91f37..19bfb5741 100644
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.58 1995/07/27 21:03:12 adams Exp $
+$Id: make.scm,v 14.59 1996/04/24 04:17:40 cph Exp $
 
-Copyright (c) 1988-95 Massachusetts Institute of Technology
+Copyright (c) 1988-96 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -347,11 +347,14 @@ MIT in each case. |#
 	 ("list" . (RUNTIME LIST))
 	 ("symbol" . ())
 	 ("uproc" . (RUNTIME PROCEDURE))
+	 ("fixart" . ())
+	 ("random" . (RUNTIME RANDOM-NUMBER))
+	 ("gentag" . (RUNTIME GENERIC-PROCEDURE))
 	 ("poplat" . (RUNTIME POPULATION))
-	 ("record" . (RUNTIME RECORD))))
+	 ("record" . (RUNTIME RECORD))
+	 ("defstr" . (RUNTIME DEFSTRUCT))))
       (files2
-       '(("defstr" . (RUNTIME DEFSTRUCT))
-	 ("prop1d" . (RUNTIME 1D-PROPERTY))
+       '(("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))))
       (load-files
@@ -367,9 +370,12 @@ MIT in each case. |#
 		      'CONSTANT-SPACE/BASE
 		      constant-space/base)
   (package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE! true)
+  (package-initialize '(RUNTIME RANDOM-NUMBER) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS!
+		      #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE! true)
-  (package-initialize '(PACKAGE) 'FINALIZE-PACKAGE-RECORD-TYPE! true)
+  (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
+  (package-initialize '(RUNTIME DEFSTRUCT) 'INITIALIZE-STRUCTURE-TYPES! #t)
   (load-files files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! true)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! true)
@@ -404,7 +410,6 @@ MIT in each case. |#
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES! #t)
    (RUNTIME STATE-SPACE)
-   (RUNTIME MICROCODE-TABLES)
    (RUNTIME APPLY)
    (RUNTIME HASH)			; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
@@ -417,7 +422,6 @@ MIT in each case. |#
    (RUNTIME GENSYM)
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
-   (RUNTIME RANDOM-NUMBER)
    ;; Microcode data structures
    (RUNTIME HISTORY)
    (RUNTIME LAMBDA-ABSTRACTION)
@@ -426,9 +430,20 @@ MIT in each case. |#
    (RUNTIME SCODE-WALKER)
    (RUNTIME CONTINUATION-PARSER)
    (RUNTIME PROGRAM-COPIER)
+   ;; Generic Procedures
+   ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER! #t)
+   ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS! #t)
+   ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES! #t)
+   ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE! #t)
+   ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE! #t)
    ;; Condition System
    (RUNTIME ERROR-HANDLER)
    (RUNTIME MICROCODE-ERRORS)
+   ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads
@@ -455,7 +470,7 @@ MIT in each case. |#
    (RUNTIME ILLEGAL-DEFINITIONS)
    (RUNTIME MACROS)
    (RUNTIME SYSTEM-MACROS)
-   (RUNTIME DEFSTRUCT)
+   ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t)
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index cb12ac7b7..d7f13994f 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.269 1996/04/24 03:48:09 cph Exp $
+$Id: runtime.pkg,v 14.270 1996/04/24 04:17:17 cph Exp $
 
 Copyright (c) 1988-96 Massachusetts Institute of Technology
 
@@ -223,6 +223,8 @@ MIT in each case. |#
   (files "infstr" "infutl")
   (parent ())
   (export ()
+	  *save-uncompressed-files?*
+	  *uncompressed-file-lifetime*
 	  compiled-entry/block
 	  compiled-entry/dbg-object
 	  compiled-entry/offset
@@ -759,6 +761,8 @@ MIT in each case. |#
 	  add-primitive-gc-daemon!)
   (export (runtime hash-table)
 	  add-primitive-gc-daemon!)
+  (export (runtime generic-procedure eqht)
+	  add-primitive-gc-daemon!)
   (export (runtime interrupt-handler)
 	  trigger-gc-daemons!)
   (initialization (initialize-package!)))
@@ -1631,6 +1635,7 @@ MIT in each case. |#
 	  *pp-uninterned-symbols-by-name*
 	  make-pretty-printer-highlight
 	  pp
+	  pp-description
 	  pretty-print)
   (initialization (initialize-package!)))
 
@@ -1802,12 +1807,10 @@ MIT in each case. |#
   (export ()
 	  %make-record
 	  %record
-	  %record-application-method
 	  %record-copy
 	  %record-length
 	  %record-ref
 	  %record-set!
-	  %record-type-has-application-method!
 	  %record?
 	  make-record-type
 	  record-accessor
@@ -1816,18 +1819,17 @@ MIT in each case. |#
 	  record-description
 	  record-modifier
 	  record-predicate
-	  record-type-application-method
 	  record-type-descriptor
+	  record-type-dispatch-tag
 	  record-type-field-names
-	  record-type-method
 	  record-type-name
-	  record-type-unparser-method
 	  record-type?
 	  record-updater
 	  record?
-	  set-record-type-application-method!
-	  set-record-type-method!
-	  set-record-type-unparser-method!)
+	  set-record-type-unparser-method!
+	  unparse-record)
+  (export (runtime record-slot-access)
+	  record-type-field-index)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
@@ -3182,4 +3184,115 @@ MIT in each case. |#
 	  ordered-vector-matches
 	  ordered-vector-minimum-match
 	  search-ordered-subvector
-	  search-ordered-vector))
\ No newline at end of file
+	  search-ordered-vector))
+
+(define-package (runtime gdbm)
+  (file-case options
+    ((load) "gdbm")
+    (else))
+  (parent ())
+  (export ()
+	  gdbm-available?
+	  gdbm-close
+	  gdbm-delete
+	  gdbm-exists?
+	  gdbm-fetch
+	  gdbm-firstkey
+	  gdbm-nextkey
+	  gdbm-open
+	  gdbm-reorganize
+	  gdbm-setopt
+	  gdbm-store
+	  gdbm-sync
+	  gdbm-version
+	  gdbm_cachesize
+	  gdbm_fast
+	  gdbm_fastmode
+	  gdbm_insert
+	  gdbm_newdb
+	  gdbm_reader
+	  gdbm_replace
+	  gdbm_wrcreat
+	  gdbm_writer))
+
+(define-package (runtime generic-procedure)
+  (files "gentag" "gencache" "generic")
+  (parent ())
+  (export ()
+	  ;; tag.scm:
+	  dispatch-tag-contents
+	  dispatch-tag?
+	  guarantee-dispatch-tag
+	  make-dispatch-tag
+	  set-dispatch-tag-contents!
+
+	  ;; generic.scm:
+	  arity-max
+	  arity-min
+	  built-in-dispatch-tag
+	  built-in-dispatch-tags
+	  condition-type:no-applicable-methods
+	  dispatch-tag
+	  error:no-applicable-methods
+	  generic-procedure-applicable?
+	  generic-procedure-arity
+	  generic-procedure-name
+	  generic-procedure?
+	  guarantee-generic-procedure
+	  make-generic-procedure
+	  purge-generic-procedure-cache
+	  standard-generic-procedure-tag)
+  (export (runtime generic-procedure multiplexer)
+	  generic-procedure-generator
+	  set-generic-procedure-generator!))
+
+(define-package (runtime generic-procedure multiplexer)
+  (files "genmult")
+  (parent ())
+  (export ()
+	  add-generic-procedure-generator
+	  condition-type:extra-applicable-methods
+	  error:extra-applicable-methods
+	  generic-procedure-default-generator
+	  generic-procedure-generator-list
+	  remove-generic-procedure-generator
+	  remove-generic-procedure-generators
+	  set-generic-procedure-default-generator!))
+
+(define-package (runtime tagged-vector)
+  (files "tvector")
+  (parent ())
+  (export ()
+	  guarantee-tagged-vector
+	  make-tagged-vector
+	  record-slot-uninitialized
+	  set-tagged-vector-element!
+	  set-tagged-vector-tag!
+	  tagged-vector
+	  tagged-vector-element
+	  tagged-vector-element-initialized?
+	  tagged-vector-length
+	  tagged-vector-tag
+	  tagged-vector?))
+
+(define-package (runtime record-slot-access)
+  (files "recslot")
+  (parent ())
+  (export ()
+	  %record-accessor
+	  %record-accessor-generator
+	  %record-initpred
+	  %record-initpred-generator
+	  %record-modifier
+	  %record-modifier-generator
+	  %record-slot-index
+	  %record-slot-names))
+
+(define-package (runtime generic-procedure eqht)
+  (files "geneqht")
+  (parent ())
+  (export (runtime generic-procedure)
+	  eqht/for-each
+	  eqht/get
+	  eqht/put!
+	  make-eqht))
\ No newline at end of file