Revamp the record abstraction. Record types now have a "default

record" that can be used as a template to speed up record
construction, and to hold default slot values.  Eliminate optional
print-method argument to MAKE-RECORD-TYPE, replacing it with an
optional default-values argument.  Tune record constructors to be very
fast for those cases where it is easy to do so.  Change RECORD-COPY to
COPY-RECORD.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 8373df0bdd898fc634039f60be00d04c7ebe26b6..554448aff73c40017f505319d0499969c4fc9b09 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.42 2003/02/14 18:28:32 cph Exp $
+$Id: defstr.scm,v 14.43 2003/03/07 05:47:31 cph Exp $
 
-Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
+Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -798,24 +800,6 @@ differences:
                                          ,@list-cons))
            ((LIST)
             `(,(absolute 'CONS* context) ,@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 (pair? arguments)
-             (begin
-               (if (not (pair? (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))))
 \f
 (define (constructor-definition/boa structure name lambda-list)
   (make-constructor structure name lambda-list
@@ -870,7 +854,7 @@ differences:
     (if copier-name
        `((DEFINE ,copier-name
            ,(absolute (case (structure/type structure)
-                        ((RECORD) 'RECORD-COPY)
+                        ((RECORD) 'COPY-RECORD)
                         ((VECTOR) 'VECTOR-COPY)
                         ((LIST) 'LIST-COPY))
                       (structure/context structure))))
@@ -919,12 +903,13 @@ differences:
            (context (structure/context structure)))
        (if (eq? type 'RECORD)
            `((DEFINE ,type-name
-               (,(absolute 'MAKE-RECORD-TYPE context)
-                ',name ',field-names
-                ,@(let ((expression (structure/print-procedure structure)))
-                    (if (not expression)
-                        `()
-                        `(,(close expression context)))))))
+               (,(absolute 'MAKE-RECORD-TYPE context) ',name ',field-names))
+             ,@(let ((expression (structure/print-procedure structure)))
+                 (if expression
+                     `((,(absolute 'SET-RECORD-TYPE-UNPARSER-METHOD! context)
+                        ,type-name
+                        ,(close expression context)))
+                     `())))
            (let ((type-expression
                   `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
                     ',type
@@ -934,7 +919,7 @@ differences:
                     ,(close (structure/print-procedure structure) context))))
              (if type-name
                  `((DEFINE ,type-name ,type-expression))
-                 `((NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
+                 `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context)
                     ,(close (structure/tag-expression structure) context)
                     ,type-expression))))))
       '()))
\ No newline at end of file

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index ce06ddd1cc28940b2c8958bcd57733c5372fca71..faabef5577ef806056dec94c680d036be6ee2ce5 100644 (file)
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.26 2003/02/14 18:28:33 cph Exp $
+$Id: port.scm,v 1.27 2003/03/07 05:47:41 cph Exp $
 
-Copyright (c) 1991-2002 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -235,7 +236,7 @@ USA.
      port)))
 
 (define (port/copy port state)
-  (let ((port (record-copy port)))
+  (let ((port (copy-record port)))
     (set-port/state! port state)
     (set-port/thread-mutex! port (make-thread-mutex))
     port))

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index c95c2d6c1b8a7693b933a6dd85b5980eb6814a44..63a3a840e01330b59e51f163ce00e13f12780da0 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.31 2003/02/14 18:28:33 cph Exp $
+$Id: record.scm,v 1.32 2003/03/07 05:48:28 cph Exp $
 
-Copyright (c) 1989-1999, 2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology
+Copyright 1997,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -30,7 +31,7 @@ USA.
 ;;; conforms to R4RS proposal
 
 (declare (usual-integrations))
-\f
+
 (define-primitives
   (%record? 1)
   (%record -1)
@@ -39,27 +40,24 @@ USA.
   (%record-set! 3)
   (primitive-object-ref 2)
   (primitive-object-set! 3)
-  (primitive-object-set-type 2))
-
-(define (%make-record length #!optional object)
-  (if (not (exact-integer? length))
-      (error:wrong-type-argument length "exact integer" '%MAKE-RECORD))
-  (if (not (> length 0))
-      (error:bad-range-argument length '%MAKE-RECORD))
-  (object-new-type
-   (ucode-type record)
-   ((ucode-primitive vector-cons) length
-                                 (if (default-object? object) #f object))))
-
-(define (%record-copy record)
+  (primitive-object-set-type 2)
+  (vector-cons 2))
+
+(define-integrable (%make-record length object)
+  (object-new-type (ucode-type record) (vector-cons length object)))
+
+(define-integrable (%record-tag record)
+  (%record-ref record 0))
+
+(define-integrable (%tagged-record? tag object)
+  (and (%record? object)
+       (eq? (%record-tag object) tag)))
+
+(define (%copy-record record)
   (let ((length (%record-length record)))
-    (let ((result (object-new-type (ucode-type record) (make-vector length))))
-      ;; Clobber RESULT's length field with that of RECORD, since
-      ;; there is important information in the type of that field that
-      ;; is not preserved by %RECORD-LENGTH.
-      (primitive-object-set! result 0 (primitive-object-ref record 0))
-      (do ((index 0 (+ index 1)))
-         ((= index length))
+    (let ((result (%make-record length #f)))
+      (do ((index 0 (fix:+ index 1)))
+         ((fix:= index length))
        (%record-set! result index (%record-ref record index)))
       result)))
 \f
@@ -68,16 +66,21 @@ USA.
 (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)))
+  (let* ((type
+         (%record #f
+                  "record-type"
+                  '#(RECORD-TYPE-NAME
+                     RECORD-TYPE-FIELD-NAMES
+                     RECORD-TYPE-DISPATCH-TAG
+                     RECORD-TYPE-DEFAULT-RECORD)
+                  #f
+                  #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)
+    (let ((default-record (%copy-record type)))
+      (%record-set! type 4 default-record)
+      (%record-set! default-record 4 default-record)))
   (initialize-structure-type-type!))
 
 (define (initialize-record-procedures!)
@@ -89,13 +92,13 @@ USA.
        (let ((tag (cadr tags)))
          (cond ((record-type? (dispatch-tag-contents tag))
                 (standard-unparser-method
-                 (record-type-name (dispatch-tag-contents tag))
+                 (%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))))
+                    (display (%record-type-name type) port))))
                ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
                 (standard-unparser-method 'DISPATCH-TAG
                   (lambda (tag port)
@@ -114,7 +117,7 @@ USA.
       generic
       (if (record-type? (dispatch-tag-contents (car tags)))
          (lambda (record)
-           (let ((type (record-type-descriptor record)))
+           (let ((type (%record-type-descriptor record)))
              (map (lambda (field-name)
                     `(,field-name
                       ,((record-accessor type field-name) record)))
@@ -126,136 +129,250 @@ USA.
                  (loop (fix:- i 1)
                        (cons (list i (%record-ref record i)) d)))))))))
 \f
-(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-tag
-                 (->string type-name)
-                 (list-copy field-names)
-                 #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 (make-record-type type-name field-names #!optional default-values)
+  (let ((caller 'MAKE-RECORD-TYPE))
+    (guarantee-list-of-unique-symbols field-names caller)
+    (let* ((names (list->vector field-names))
+          (n (vector-length names))
+          (default-record (%make-record (fix:+ 1 n) #f))
+          (record-type
+           (%record record-type-type-tag
+                    (->string type-name)
+                    names
+                    #f
+                    default-record))
+          (tag (make-dispatch-tag record-type)))
+      (%record-set! record-type 3 tag)
+      (%record-set! default-record 0 tag)
+      (if (not (default-object? default-values))
+         (%set-record-type-default-values! record-type default-values caller))
+      record-type)))
 
 (define (record-type? object)
-  (and (%record? object)
-       (eq? (%record-ref object 0) record-type-type-tag)))
+  (%tagged-record? record-type-type-tag object))
+
+(define-integrable (%record-type-descriptor record)
+  (dispatch-tag-contents (%record-tag record)))
+
+(define-integrable (%record-type-name record-type)
+  (%record-ref record-type 1))
+
+(define-integrable (%record-type-field-names record-type)
+  (%record-ref record-type 2))
+
+(define-integrable (%record-type-dispatch-tag record-type)
+  (%record-ref record-type 3))
 
+(define-integrable (%record-type-default-record record-type)
+  (%record-ref record-type 4))
+
+(define-integrable (%record-type-n-fields record-type)
+  (vector-length (%record-type-field-names record-type)))
+
+(define-integrable (%record-type-length record-type)
+  (%record-length (%record-type-default-record record-type)))
+\f
 (define (record-type-name record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-NAME)
-  (%record-ref record-type 1))
+  (%record-type-name record-type))
 
 (define (record-type-field-names record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
-  (%record-ref record-type 2))
+  ;; Can't use VECTOR->LIST here because it isn't available at cold load.
+  (let ((v (%record-type-field-names record-type)))
+    (subvector->list v 0 (vector-length v))))
+
+(define (record-type-default-values record-type)
+  (guarantee-record-type record-type 'RECORD-TYPE-DEFAULT-VALUES)
+  (let* ((default-record (%record-type-default-record record-type))
+        (n (%record-length default-record))
+        (v (make-vector (fix:- n 1))))
+    (do ((i 1 (fix:+ i 1)))
+       ((not (fix:< i n)))
+      (vector-set! v (fix:- i 1) (%record-ref default-record i)))
+    v))
+
+(define (set-record-type-default-values! record-type default-values)
+  (let ((caller 'SET-RECORD-TYPE-DEFAULT-VALUES!))
+    (guarantee-record-type record-type caller)
+    (%set-record-type-default-values! record-type default-values caller)))
+
+(define (%set-record-type-default-values! record-type default-values caller)
+  (if (not (fix:= (guarantee-list->length default-values caller)
+                 (%record-type-n-fields record-type)))
+      (error:bad-range-argument default-values caller))
+  (let ((default-record (%record-type-default-record record-type)))
+    (do ((values default-values (cdr values))
+        (i 1 (fix:+ i 1)))
+       ((not (pair? values)))
+      (%record-set! default-record i (car values)))))
 
 (define (record-type-dispatch-tag record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG)
-  (%record-ref record-type 3))
+  (%record-type-dispatch-tag record-type))
 
-(define (set-record-type-unparser-method! record-type method)
-  (set! deferred-unparser-methods
-       (cons (cons record-type method) deferred-unparser-methods))
-  unspecific)
+(define set-record-type-unparser-method!
+  (named-lambda (set-record-type-unparser-method!/booting 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!))
-  (let ((tag (record-type-dispatch-tag record-type)))
-    (remove-generic-procedure-generators unparse-record
-                                        (list (make-dispatch-tag #f) tag))
-    (add-generic-procedure-generator unparse-record
-      (lambda (generic tags)
-       generic
-       (and (eq? (cadr tags) tag) method)))))
+(define set-record-type-unparser-method!/after-boot
+  (named-lambda (set-record-type-unparser-method! record-type method)
+    (if (not (or (not method) (procedure? method)))
+       (error:wrong-type-argument method "unparser method"
+                                  'SET-RECORD-TYPE-UNPARSER-METHOD!))
+    (let ((tag (record-type-dispatch-tag record-type)))
+      (remove-generic-procedure-generators unparse-record
+                                          (list (make-dispatch-tag #f) tag))
+      (add-generic-procedure-generator unparse-record
+       (lambda (generic tags)
+         generic
+         (and (eq? (cadr tags) tag) method))))))
 \f
 (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))
-       (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))))
-      (let ((number-of-inits (length field-names))
-           (indexes
-            (map (lambda (field-name)
-                   (record-type-field-index record-type
-                                            field-name
-                                            'RECORD-CONSTRUCTOR))
-                 field-names)))
-       (lambda field-values
-         (if (not (= (length field-values) number-of-inits))
-             (error "wrong number of arguments to record constructor"
-                    field-values record-type field-names))
-         (let ((record
-                (object-new-type (ucode-type record)
-                                 (make-vector record-length))))
-           (%record-set! record 0 tag)
-           (do ((indexes indexes (cdr indexes))
-                (field-values field-values (cdr field-values)))
-               ((null? indexes))
-             (%record-set! record (car indexes) (car field-values)))
-           record))))))
-
+  (if (or (default-object? field-names)
+         (equal? field-names (record-type-field-names record-type)))
+      (%record-constructor-default-names record-type)
+      (begin
+       (guarantee-list field-names 'RECORD-CONSTRUCTOR)
+       (%record-constructor-given-names record-type field-names))))
+
+(define %record-constructor-default-names
+  (let-syntax
+      ((expand-cases
+       (sc-macro-transformer
+        (lambda (form environment)
+          (let ((tag (close-syntax (list-ref form 1) environment))
+                (n-fields (close-syntax (list-ref form 2) environment))
+                (limit (close-syntax (list-ref form 3) environment))
+                (default (close-syntax (list-ref form 4) environment))
+                (make-name
+                 (lambda (i)
+                   (intern (string-append "v" (number->string i))))))
+            (let loop ((i 0) (names '()))
+              (if (fix:< i limit)
+                  `(IF (FIX:= ,n-fields ,i)
+                       (LAMBDA (,@names) (%RECORD ,tag ,@names))
+                       ,(loop (fix:+ i 1)
+                              (append names (list (make-name i)))))
+                  default)))))))
+    (lambda (record-type)
+      (let ((tag (%record-type-dispatch-tag record-type))
+           (n-fields (%record-type-n-fields record-type)))
+       (expand-cases tag n-fields 16
+         (let ((length (fix:+ 1 n-fields)))
+           (letrec
+               ((constructor
+                 (lambda field-values
+                   (let ((record (%make-record length #f))
+                         (lose
+                          (lambda ()
+                            (error:wrong-number-of-arguments constructor
+                                                             n-fields
+                                                             field-values))))
+                     (%record-set! record 0 tag)
+                     (let loop ((i 1) (values field-values))
+                       (if (fix:< i length)
+                           (begin
+                             (if (not (pair? values)) (lose))
+                             (%record-set! record i (car values))
+                             (loop (cdr values) (fix:+ i 1)))
+                           (if (not (null? values)) (lose))))
+                     record))))
+             constructor)))))))
+
+(define (%record-constructor-given-names record-type field-names)
+  (let ((indexes
+        (map (lambda (field-name)
+               (record-type-field-index record-type field-name #t))
+             field-names))
+       (template (%record-type-default-record record-type)))
+    (letrec
+       ((constructor
+         (lambda field-values
+           (let ((lose
+                  (lambda ()
+                    (error:wrong-number-of-arguments constructor
+                                                     (length indexes)
+                                                     field-values))))
+             (let ((record (%copy-record template)))
+               (let loop ((indexes indexes) (values field-values))
+                 (if (pair? indexes)
+                     (begin
+                       (if (not (pair? values)) (lose))
+                       (%record-set! record (car indexes) (car values))
+                       (loop (cdr indexes) (cdr values)))
+                     (if (not (null? values)) (lose))))
+               record)))))
+      constructor)))
+\f
 (define (record? object)
   (and (%record? object)
-       (dispatch-tag? (%record-ref object 0))
-       (record-type? (dispatch-tag-contents (%record-ref object 0)))))
+       (dispatch-tag? (%record-tag object))
+       (record-type? (dispatch-tag-contents (%record-tag object)))))
 
 (define (record-type-descriptor record)
   (guarantee-record record 'RECORD-TYPE-DESCRIPTOR)
-  (dispatch-tag-contents (%record-ref record 0)))
+  (%record-type-descriptor record))
 
-(define (record-copy record)
-  (guarantee-record record 'RECORD-COPY)
-  (%record-copy record))
+(define (copy-record record)
+  (guarantee-record record 'COPY-RECORD)
+  (%copy-record record))
 
 (define (record-predicate record-type)
   (guarantee-record-type record-type 'RECORD-PREDICATE)
   (let ((tag (record-type-dispatch-tag record-type)))
     (lambda (object)
-      (and (%record? object)
-          (eq? (%record-ref object 0) tag)))))
+      (%tagged-record? tag object))))
 
 (define (record-accessor record-type field-name)
   (guarantee-record-type record-type 'RECORD-ACCESSOR)
   (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 tag type-name procedure-name)
-      (%record-ref record index))))
+       (index (record-type-field-index record-type field-name #t)))
+    (letrec ((accessor
+             (lambda (record)
+               (if (not (%tagged-record? tag record))
+                   (error:not-tagged-record record record-type accessor))
+               (%record-ref record index))))
+      accessor)))
 
 (define (record-modifier record-type field-name)
   (guarantee-record-type record-type 'RECORD-MODIFIER)
   (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 tag type-name procedure-name)
-      (%record-set! record index field-value))))
-
-(define record-updater
-  record-modifier)
+       (index (record-type-field-index record-type field-name #t)))
+    (letrec ((modifier
+             (lambda (record field-value)
+               (if (not (%tagged-record? tag record))
+                   (error:not-tagged-record record record-type modifier))
+               (%record-set! record index field-value))))
+      modifier)))
+
+(define (error:not-tagged-record record record-type modifier)
+  (error:wrong-type-argument record
+                            (string-append "record of type "
+                                           (%record-type-name record-type))
+                            modifier))
 \f
-(define (record-type-field-index record-type field-name error?)
-  (let loop ((field-names (record-type-field-names record-type)) (index 1))
-    (cond ((null? field-names)
-          (and error?
-               (record-type-field-index
-                record-type
-                (error:no-such-slot record-type field-name)
-                error?)))
-         ((eq? field-name (car field-names)) index)
-         (else (loop (cdr field-names) (+ index 1))))))
+(define record-copy copy-record)
+(define record-updater record-modifier)
+
+(define (record-type-field-index record-type name error?)
+  ;; Can't use VECTOR->LIST here because it isn't available at cold load.
+  (let* ((names (%record-type-field-names record-type))
+        (n (vector-length names)))
+    (let loop ((i 0))
+      (if (fix:< i n)
+         (if (eq? (vector-ref names i) name)
+             (fix:+ i 1)
+             (loop (fix:+ i 1)))
+         (and error?
+              (record-type-field-index record-type
+                                       (error:no-such-slot record-type name)
+                                       error?))))))
 
 (define (->string object)
   (if (string? object)
@@ -267,28 +384,21 @@ USA.
       (error:wrong-type-argument object "list of unique symbols" procedure)))
 
 (define (list-of-unique-symbols? object)
-  (and (list? object)
+  (and (list-of-type? object symbol?)
        (let loop ((elements object))
-        (or (null? elements)
-            (and (symbol? (car elements))
-                 (not (memq (car elements) (cdr elements)))
-                 (loop (cdr elements)))))))
+        (if (pair? elements)
+            (if (memq (car elements) (cdr elements))
+                #f
+                (loop (cdr elements)))
+            #t))))
 
 (define-integrable (guarantee-record-type record-type procedure)
   (if (not (record-type? record-type))
       (error:wrong-type-argument record-type "record type" procedure)))
 
-(define-integrable (guarantee-record-of-type record tag type-name
-                                            procedure-name)
-  (if (not (and (%record? record)
-               (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)
+(define-integrable (guarantee-record record caller)
   (if (not (record? record))
-      (error:wrong-type-argument record "record" procedure-name)))
+      (error:wrong-type-argument record "record" caller)))
 \f
 ;;;; Runtime support for DEFINE-STRUCTURE
 
@@ -331,27 +441,23 @@ USA.
         (structure-type/unparser-method structure-type))))
 
 (define (named-structure? object)
-  (cond ((record? object)
-        true)
+  (cond ((record? object) #t)
        ((vector? object)
-        (and (not (zero? (vector-length object)))
+        (and (not (fix:= (vector-length object) 0))
              (tag->structure-type (vector-ref object 0) 'VECTOR)))
-       ((pair? object)
-        (tag->structure-type (car object) 'LIST))
-       (else
-        false)))
+       ((pair? object) (tag->structure-type (car object) 'LIST))
+       (else #f)))
 
 (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)))))
+        => (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))))
@@ -368,52 +474,48 @@ USA.
 ;;;; 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))))))
+  (receive (tag index type-name accessor-name)
+      (accessor-parameters tag field-name 'VECTOR 'ACCESSOR)
+    (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))))))
+  (receive (tag index type-name accessor-name)
+      (accessor-parameters tag field-name 'VECTOR 'MODIFIER)
+    (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))))))
+  (receive (tag index type-name accessor-name)
+      (accessor-parameters tag field-name 'LIST 'ACCESSOR)
+    (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))))))
+  (receive (tag index type-name accessor-name)
+      (accessor-parameters tag field-name 'LIST 'MODIFIER)
+    (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)))))
 \f
 (define-integrable (check-vector structure tag index type accessor-name)
   (if (not (and (vector? structure)
@@ -467,19 +569,19 @@ USA.
        (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)
+  (if (pair? argument-list)
       (let ((alist
             (map (lambda (entry) (cons (car entry) (cdr entry)))
                  default-alist)))
        (let loop ((arguments argument-list))
-         (if (not (null? arguments))
+         (if (pair? arguments)
              (begin
-               (if (null? (cdr arguments))
+               (if (not (pair? (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
+       (map cdr alist))
+      (map cdr default-alist)))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index ea9d539ad5983874b57a10ab4cdbb94fde8b734f..7569b6e9b5b3c99ee64711a49edcd44442bd53cf 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.430 2003/02/28 04:40:19 cph Exp $
+$Id: runtime.pkg,v 14.431 2003/03/07 05:48:36 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -2039,6 +2039,11 @@ USA.
          for-each
          fourth
          general-car-cdr
+         guarantee-alist
+         guarantee-list
+         guarantee-list->length
+         guarantee-list-of-type
+         guarantee-list-of-type->length
          guarantee-pair
          keep-matching-items
          last-pair
@@ -2050,6 +2055,7 @@ USA.
          list-deletor!
          list-head
          list-of-type?
+         list-of-type?->length
          list-ref
          list-search-negative
          list-search-positive
@@ -2057,9 +2063,10 @@ USA.
          list-transform-negative
          list-transform-positive
          list?
-         make-list
+         list?->length
          make-circular-list
          make-initialized-list
+         make-list
          map
          map*
          mapcan
@@ -2644,18 +2651,24 @@ USA.
   (files "record")
   (parent (runtime))
   (export ()
+         %copy-record
          %make-record
          %record
-         %record-copy
          %record-length
          %record-ref
          %record-set!
+         %record-tag
          %record?
+         copy-record
          define-structure/keyword-parser
          define-structure/list-accessor
          define-structure/list-modifier
          define-structure/vector-accessor
          define-structure/vector-modifier
+         guarantee-list-of-unique-symbols
+         guarantee-record
+         guarantee-record-type
+         list-of-unique-symbols?
          make-define-structure-type
          make-record-type
          named-structure/description
@@ -2666,6 +2679,7 @@ USA.
          record-description
          record-modifier
          record-predicate
+         record-type-default-values
          record-type-descriptor
          record-type-dispatch-tag
          record-type-field-names
@@ -2673,6 +2687,7 @@ USA.
          record-type?
          record-updater
          record?
+         set-record-type-default-values!
          set-record-type-unparser-method!
          unparse-record)
   (export (runtime record-slot-access)