From 6eaa591e425e335d92c16f0d08da0b56920c1375 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 12 Jan 2002 02:56:35 +0000
Subject: [PATCH] Move runtime support for DEFINE-STRUCTURE into "record.scm",
 in order to simplify the boot sequence.  This allows "defstr.scm" to move
 late into the boot sequence and to use the record abstraction without
 complicated tricks.

---
 v7/src/runtime/defstr.scm  | 350 +++++++++----------------------------
 v7/src/runtime/make.scm    |   6 +-
 v7/src/runtime/record.scm  | 206 +++++++++++++++++++++-
 v7/src/runtime/runtime.pkg |  24 +--
 4 files changed, 299 insertions(+), 287 deletions(-)

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index cf83a725b..9a9884d87 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.36 2001/12/23 17:20:59 cph Exp $
+$Id: defstr.scm,v 14.37 2002/01/12 02:56:14 cph Exp $
 
-Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -364,75 +364,87 @@ differences:
 
 ;;;; Descriptive Structure
 
-(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/safe-accessors?)
-(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 SAFE-ACCESSORS? 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/safe-accessors?
-	(record-accessor structure-rtd 'SAFE-ACCESSORS?))
-  (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!))
+(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 SAFE-ACCESSORS? 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/safe-accessors?
+  (record-accessor structure-rtd 'SAFE-ACCESSORS?))
+
+(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 slot-assoc
+  (association-procedure eq? slot/name))
 
 ;;;; Code Generation
 
@@ -556,24 +568,6 @@ differences:
 	     `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons))
 	    ((LIST)
 	     `(,(absolute 'CONS*) ,@list-cons))))))))
-
-(define (define-structure/keyword-parser argument-list default-alist)
-  (if (null? argument-list)
-      (map cdr default-alist)
-      (let ((alist
-	     (map (lambda (entry) (cons (car entry) (cdr entry)))
-		  default-alist)))
-	(let loop ((arguments argument-list))
-	  (if (not (null? arguments))
-	      (begin
-		(if (null? (cdr arguments))
-		    (error "Keyword list does not have even length:"
-			   argument-list))
-		(set-cdr! (or (assq (car arguments) alist)
-			      (error "Unknown keyword:" (car arguments)))
-			  (cadr arguments))
-		(loop (cddr arguments)))))
-	(map cdr alist))))
 
 (define (constructor-definition/boa structure name lambda-list)
   (make-constructor structure name lambda-list
@@ -691,180 +685,4 @@ differences:
 		      (NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
 		       ,(structure/tag-expression structure)
 		       ,type-expression)))))))
-      '()))
-
-;;;; Exported type structure
-
-(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)))
-    (and structure-type
-	 (structure-type/unparser-method structure-type))))
-
-(define (named-structure? object)
-  (cond ((record? object)
-	 true)
-	((vector? object)
-	 (and (not (zero? (vector-length object)))
-	      (tag->structure-type (vector-ref object 0) 'VECTOR)))
-	((pair? object)
-	 (tag->structure-type (car object) 'LIST))
-	(else
-	 false)))
-
-(define (named-structure/description structure)
-  (cond ((record? structure)
-	 (record-description structure))
-	((named-structure? structure)
-	 =>
-	 (lambda (type)
-	   (let ((accessor (if (pair? structure) list-ref vector-ref)))
-	     (map (lambda (field-name index)
-		    `(,field-name ,(accessor structure index)))
-		  (structure-type/field-names type)
-		  (structure-type/field-indexes type)))))
-	(else
-	 (error:wrong-type-argument structure "named structure"
-				    'NAMED-STRUCTURE/DESCRIPTION))))
-
-(define (tag->structure-type tag type)
-  (if (structure-type? tag)
-      (and (eq? (structure-type/type tag) type)
-	   tag)
-      (let ((structure-type (named-structure/get-tag-description tag)))
-	(and (structure-type? structure-type)
-	     (eq? (structure-type/type structure-type) type)
-	     structure-type))))
-
-;;;; Support for safe accessors
-
-(define (define-structure/vector-accessor tag field-name)
-  (call-with-values
-      (lambda () (accessor-parameters tag field-name 'VECTOR 'ACCESSOR))
-    (lambda (tag index type-name accessor-name)
-      (if tag
-	  (lambda (structure)
-	    (check-vector structure tag index type-name accessor-name)
-	    (vector-ref structure index))
-	  (lambda (structure)
-	    (check-vector-untagged structure index type-name accessor-name)
-	    (vector-ref structure index))))))
-
-(define (define-structure/vector-modifier tag field-name)
-  (call-with-values
-      (lambda () (accessor-parameters tag field-name 'VECTOR 'MODIFIER))
-    (lambda (tag index type-name accessor-name)
-      (if tag
-	  (lambda (structure value)
-	    (check-vector structure tag index type-name accessor-name)
-	    (vector-set! structure index value))
-	  (lambda (structure value)
-	    (check-vector-untagged structure index type-name accessor-name)
-	    (vector-set! structure index value))))))
-
-(define (define-structure/list-accessor tag field-name)
-  (call-with-values
-      (lambda () (accessor-parameters tag field-name 'LIST 'ACCESSOR))
-    (lambda (tag index type-name accessor-name)
-      (if tag
-	  (lambda (structure)
-	    (check-list structure tag index type-name accessor-name)
-	    (list-ref structure index))
-	  (lambda (structure)
-	    (check-list-untagged structure index type-name accessor-name)
-	    (list-ref structure index))))))
-
-(define (define-structure/list-modifier tag field-name)
-  (call-with-values
-      (lambda () (accessor-parameters tag field-name 'LIST 'MODIFIER))
-    (lambda (tag index type-name accessor-name)
-      (if tag
-	  (lambda (structure value)
-	    (check-list structure tag index type-name accessor-name)
-	    (set-car! (list-tail structure index) value))
-	  (lambda (structure value)
-	    (check-list-untagged structure index type-name accessor-name)
-	    (set-car! (list-tail structure index) value))))))
-
-(define-integrable (check-vector structure tag index type accessor-name)
-  (if (not (and (vector? structure)
-		(fix:> (vector-length structure) index)
-		(eq? tag (vector-ref structure 0))))
-      (error:wrong-type-argument structure type accessor-name)))
-
-(define-integrable (check-vector-untagged structure index type accessor-name)
-  (if (not (and (vector? structure)
-		(fix:> (vector-length structure) index)))
-      (error:wrong-type-argument structure type accessor-name)))
-
-(define-integrable (check-list structure tag index type accessor-name)
-  (if (not (and (list-to-index? structure index)
-		(eq? tag (car structure))))
-      (error:wrong-type-argument structure type accessor-name)))
-
-(define-integrable (check-list-untagged structure index type accessor-name)
-  (if (not (list-to-index? structure index))
-      (error:wrong-type-argument structure type accessor-name)))
-
-(define (list-to-index? object index)
-  (and (pair? object)
-       (or (fix:= 0 index)
-	   (list-to-index? (cdr object) (fix:- index 1)))))
-
-(define (accessor-parameters tag field-name structure-type accessor-type)
-  (if (exact-nonnegative-integer? tag)
-      (values #f
-	      tag
-	      (string-append (symbol->string structure-type)
-			     " of length >= "
-			     (number->string (+ tag 1)))
-	      `(,accessor-type ,tag ',field-name))
-      (let ((type (tag->structure-type tag structure-type)))
-	(if (not type)
-	    (error:wrong-type-argument tag "structure tag" accessor-type))
-	(values tag
-		(structure-type/field-index type field-name)
-		(structure-type/name type)
-		`(,accessor-type ,type ',field-name)))))
-
-(define (structure-type/field-index type name)
-  (let loop
-      ((names (structure-type/field-names type))
-       (indexes (structure-type/field-indexes type)))
-    (if (pair? names)
-	(if (eq? name (car names))
-	    (car indexes)
-	    (loop (cdr names) (cdr indexes)))
-	(error:bad-range-argument name 'STRUCTURE-TYPE/FIELD-INDEX))))
\ No newline at end of file
+      '()))
\ No newline at end of file
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index ff583c257..ad5ebbb2c 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.82 2001/12/23 17:20:59 cph Exp $
+$Id: make.scm,v 14.83 2002/01/12 02:56:18 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -358,8 +358,7 @@ USA.
 	 ("random" . (RUNTIME RANDOM-NUMBER))
 	 ("gentag" . (RUNTIME GENERIC-PROCEDURE))
 	 ("poplat" . (RUNTIME POPULATION))
-	 ("record" . (RUNTIME RECORD))
-	 ("defstr" . (RUNTIME DEFSTRUCT))))
+	 ("record" . (RUNTIME RECORD))))
       (files2
        '(("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
@@ -383,7 +382,6 @@ USA.
 		      #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
   (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! #t)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 400ad749b..2ee12e3d9 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.28 1999/01/02 06:11:34 cph Exp $
+$Id: record.scm,v 1.29 2002/01/12 02:56:22 cph Exp $
 
-Copyright (c) 1989-1999 Massachusetts Institute of Technology
+Copyright (c) 1989-1999, 2002 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Records
@@ -73,7 +74,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		  #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)))
+    (%record-set! type 3 record-type-type-tag))
+  (initialize-structure-type-type!))
 
 (define (initialize-record-procedures!)
   (set! unparse-record (make-generic-procedure 2 'UNPARSE-RECORD))
@@ -283,4 +285,198 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define-integrable (guarantee-record record procedure-name)
   (if (not (record? record))
-      (error:wrong-type-argument record "record" procedure-name)))
\ No newline at end of file
+      (error:wrong-type-argument record "record" procedure-name)))
+
+;;;; Runtime support for DEFINE-STRUCTURE
+
+(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)))
+    (and structure-type
+	 (structure-type/unparser-method structure-type))))
+
+(define (named-structure? object)
+  (cond ((record? object)
+	 true)
+	((vector? object)
+	 (and (not (zero? (vector-length object)))
+	      (tag->structure-type (vector-ref object 0) 'VECTOR)))
+	((pair? object)
+	 (tag->structure-type (car object) 'LIST))
+	(else
+	 false)))
+
+(define (named-structure/description structure)
+  (cond ((record? structure)
+	 (record-description structure))
+	((named-structure? structure)
+	 =>
+	 (lambda (type)
+	   (let ((accessor (if (pair? structure) list-ref vector-ref)))
+	     (map (lambda (field-name index)
+		    `(,field-name ,(accessor structure index)))
+		  (structure-type/field-names type)
+		  (structure-type/field-indexes type)))))
+	(else
+	 (error:wrong-type-argument structure "named structure"
+				    'NAMED-STRUCTURE/DESCRIPTION))))
+
+(define (tag->structure-type tag type)
+  (if (structure-type? tag)
+      (and (eq? (structure-type/type tag) type)
+	   tag)
+      (let ((structure-type (named-structure/get-tag-description tag)))
+	(and (structure-type? structure-type)
+	     (eq? (structure-type/type structure-type) type)
+	     structure-type))))
+
+;;;; Support for safe accessors
+
+(define (define-structure/vector-accessor tag field-name)
+  (call-with-values
+      (lambda () (accessor-parameters tag field-name 'VECTOR 'ACCESSOR))
+    (lambda (tag index type-name accessor-name)
+      (if tag
+	  (lambda (structure)
+	    (check-vector structure tag index type-name accessor-name)
+	    (vector-ref structure index))
+	  (lambda (structure)
+	    (check-vector-untagged structure index type-name accessor-name)
+	    (vector-ref structure index))))))
+
+(define (define-structure/vector-modifier tag field-name)
+  (call-with-values
+      (lambda () (accessor-parameters tag field-name 'VECTOR 'MODIFIER))
+    (lambda (tag index type-name accessor-name)
+      (if tag
+	  (lambda (structure value)
+	    (check-vector structure tag index type-name accessor-name)
+	    (vector-set! structure index value))
+	  (lambda (structure value)
+	    (check-vector-untagged structure index type-name accessor-name)
+	    (vector-set! structure index value))))))
+
+(define (define-structure/list-accessor tag field-name)
+  (call-with-values
+      (lambda () (accessor-parameters tag field-name 'LIST 'ACCESSOR))
+    (lambda (tag index type-name accessor-name)
+      (if tag
+	  (lambda (structure)
+	    (check-list structure tag index type-name accessor-name)
+	    (list-ref structure index))
+	  (lambda (structure)
+	    (check-list-untagged structure index type-name accessor-name)
+	    (list-ref structure index))))))
+
+(define (define-structure/list-modifier tag field-name)
+  (call-with-values
+      (lambda () (accessor-parameters tag field-name 'LIST 'MODIFIER))
+    (lambda (tag index type-name accessor-name)
+      (if tag
+	  (lambda (structure value)
+	    (check-list structure tag index type-name accessor-name)
+	    (set-car! (list-tail structure index) value))
+	  (lambda (structure value)
+	    (check-list-untagged structure index type-name accessor-name)
+	    (set-car! (list-tail structure index) value))))))
+
+(define-integrable (check-vector structure tag index type accessor-name)
+  (if (not (and (vector? structure)
+		(fix:> (vector-length structure) index)
+		(eq? tag (vector-ref structure 0))))
+      (error:wrong-type-argument structure type accessor-name)))
+
+(define-integrable (check-vector-untagged structure index type accessor-name)
+  (if (not (and (vector? structure)
+		(fix:> (vector-length structure) index)))
+      (error:wrong-type-argument structure type accessor-name)))
+
+(define-integrable (check-list structure tag index type accessor-name)
+  (if (not (and (list-to-index? structure index)
+		(eq? tag (car structure))))
+      (error:wrong-type-argument structure type accessor-name)))
+
+(define-integrable (check-list-untagged structure index type accessor-name)
+  (if (not (list-to-index? structure index))
+      (error:wrong-type-argument structure type accessor-name)))
+
+(define (list-to-index? object index)
+  (and (pair? object)
+       (or (fix:= 0 index)
+	   (list-to-index? (cdr object) (fix:- index 1)))))
+
+(define (accessor-parameters tag field-name structure-type accessor-type)
+  (if (exact-nonnegative-integer? tag)
+      (values #f
+	      tag
+	      (string-append (symbol->string structure-type)
+			     " of length >= "
+			     (number->string (+ tag 1)))
+	      `(,accessor-type ,tag ',field-name))
+      (let ((type (tag->structure-type tag structure-type)))
+	(if (not type)
+	    (error:wrong-type-argument tag "structure tag" accessor-type))
+	(values tag
+		(structure-type/field-index type field-name)
+		(structure-type/name type)
+		`(,accessor-type ,type ',field-name)))))
+
+(define (structure-type/field-index type name)
+  (let loop
+      ((names (structure-type/field-names type))
+       (indexes (structure-type/field-indexes type)))
+    (if (pair? names)
+	(if (eq? name (car names))
+	    (car indexes)
+	    (loop (cdr names) (cdr indexes)))
+	(error:bad-range-argument name 'STRUCTURE-TYPE/FIELD-INDEX))))
+
+(define (define-structure/keyword-parser argument-list default-alist)
+  (if (null? argument-list)
+      (map cdr default-alist)
+      (let ((alist
+	     (map (lambda (entry) (cons (car entry) (cdr entry)))
+		  default-alist)))
+	(let loop ((arguments argument-list))
+	  (if (not (null? arguments))
+	      (begin
+		(if (null? (cdr arguments))
+		    (error "Keyword list does not have even length:"
+			   argument-list))
+		(set-cdr! (or (assq (car arguments) alist)
+			      (error "Unknown keyword:" (car arguments)))
+			  (cadr arguments))
+		(loop (cddr arguments)))))
+	(map cdr alist))))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f66c25f66..9152595de 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.405 2002/01/07 03:38:41 cph Exp $
+$Id: runtime.pkg,v 14.406 2002/01/12 02:56:35 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -1241,17 +1241,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   (files "defstr")
   (parent (runtime))
   (export ()
-	  define-structure
-	  define-structure/keyword-parser
-	  define-structure/list-accessor
-	  define-structure/list-modifier
-	  define-structure/vector-accessor
-	  define-structure/vector-modifier
-	  make-define-structure-type
-	  named-structure/description
-	  named-structure?)
-  (export (runtime unparser)
-	  structure-tag/unparser-method))
+	  define-structure))
 
 (define-package (runtime directory)
   (parent (runtime))
@@ -2657,7 +2647,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  %record-ref
 	  %record-set!
 	  %record?
+	  define-structure/keyword-parser
+	  define-structure/list-accessor
+	  define-structure/list-modifier
+	  define-structure/vector-accessor
+	  define-structure/vector-modifier
+	  make-define-structure-type
 	  make-record-type
+	  named-structure/description
+	  named-structure?
 	  record-accessor
 	  record-constructor
 	  record-copy
@@ -2675,6 +2673,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 	  unparse-record)
   (export (runtime record-slot-access)
 	  record-type-field-index)
+  (export (runtime unparser)
+	  structure-tag/unparser-method)
   (initialization (initialize-package!)))
 
 (define-package (runtime reference-trap)
-- 
2.25.1