Change both records and named structures to store default values as

thunks in the type structure, which are then called when needed.

Introduce new procedures to get the default value for a slot, given
the type descriptor, and use them as needed in DEFINE-STRUCTURE,
rather than just inserting the default-init expression.

Put back the UNPARSER-METHOD argument to MAKE-RECORD-TYPE, and use it
in DEFINE-STRUCTURE.

Once again, use RECORD-KEYWORD-CONSTRUCTOR in DEFINE-STRUCTURE, this
time with better results.

diff --git a/v7/src/edwin/clscon.scm b/v7/src/edwin/clscon.scm
index d19ddc2ab164c02888eda8dd724f6756ad99aa42..01bb0411b780cb71370dadbd6040f242657605bd 100644 (file)
--- a/v7/src/edwin/clscon.scm
+++ b/v7/src/edwin/clscon.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: clscon.scm,v 1.11 2003/02/14 18:28:11 cph Exp $
+$Id: clscon.scm,v 1.12 2003/03/11 05:01:21 cph Exp $
 
-Copyright 1986-1999, 2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1993,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -55,6 +55,7 @@ USA.
                                            name
                                            (map car transforms)
                                            (map cdr transforms)
+                                           #f
                                            (unparser/standard-method name)))
               class))))
       (if (not entry)

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 281f8ef52af4c9134b426d39cd9587d6c1c0fe90..d2dc2e770a1200c7d53de659a9a80d76c4dac3d3 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.48 2003/03/08 04:53:58 cph Exp $
+$Id: defstr.scm,v 14.49 2003/03/11 05:00:41 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology
@@ -74,7 +74,7 @@ differences:
 * The INCLUDE option is not implemented.
 
 |#
-\f
+
 (define-expander 'DEFINE-STRUCTURE system-global-environment
   (lambda (form environment closing-environment)
     (if (not (and (pair? (cdr form)) (list? (cddr form))))
@@ -545,12 +545,6 @@ differences:
                (else
                 (error "Unrecognized structure slot option:" option))))))
        (make-slot name default type read-only?)))))
-
-(define (get-slot-default slot structure)
-  (make-syntactic-closure
-      (parser-context/environment (structure/context structure))
-      (map slot/name (structure/slots structure))
-    (slot/default slot)))
 \f
 ;;;; Descriptive Structure
 
@@ -703,58 +697,69 @@ differences:
          ,@slot-names)))))
 
 (define (constructor-definition/keyword structure name)
-  (make-constructor structure name 'KEYWORD-LIST
-    (lambda (tag-expression)
-      (let ((context (structure/context structure)))
-       (let ((list-cons
-              `(,@(constructor-prefix-slots structure tag-expression)
-                (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context)
-                 KEYWORD-LIST
-                 (,(absolute 'LIST context)
-                  ,@(map (lambda (slot)
-                           `(,(absolute 'CONS context)
-                             ',(slot/name slot)
-                             ,(get-slot-default slot structure)))
-                         (structure/slots structure)))))))
-         (case (structure/type structure)
-           ((RECORD)
-            `(,(absolute 'APPLY context) ,(absolute '%RECORD context)
-                                         ,@list-cons))
-           ((VECTOR)
-            `(,(absolute 'APPLY context) ,(absolute 'VECTOR context)
-                                         ,@list-cons))
-           ((LIST)
-            `(,(absolute 'CONS* context) ,@list-cons))))))))
+  (let ((context (structure/context structure)))
+    (if (eq? (structure/type structure) 'RECORD)
+       `(DEFINE ,name
+          (,(absolute 'RECORD-KEYWORD-CONSTRUCTOR context)
+           ,(close (structure/tag-expression structure) context)))
+       (make-constructor structure name 'KEYWORD-LIST
+         (lambda (tag-expression)
+           (let ((list-cons
+                  `(,@(constructor-prefix-slots structure tag-expression)
+                    (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER context)
+                     ,tag-expression
+                     KEYWORD-LIST))))
+             (case (structure/type structure)
+               ((VECTOR)
+                `(,(absolute 'APPLY context) ,(absolute 'VECTOR context)
+                                             ,@list-cons))
+               ((LIST)
+                `(,(absolute 'CONS* context) ,@list-cons)))))))))
 \f
 (define (constructor-definition/boa structure name lambda-list)
   (make-constructor structure name lambda-list
     (lambda (tag-expression)
-      `(,(absolute (case (structure/type structure)
-                    ((RECORD) '%RECORD)
-                    ((VECTOR) 'VECTOR)
-                    ((LIST) 'LIST))
-                  (structure/context structure))
-       ,@(constructor-prefix-slots structure tag-expression)
-       ,@(call-with-values (lambda () (parse-mit-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))
-                                    ,(get-slot-default slot structure)
-                                    ,(slot/name slot)))
-                              (else
-                               (get-slot-default slot structure))))
-                      (structure/slots structure))))))))))
+      (let ((type (structure/type structure))
+           (context (structure/context structure)))
+       `(,(absolute (case type
+                      ((RECORD) '%RECORD)
+                      ((VECTOR) 'VECTOR)
+                      ((LIST) 'LIST))
+                    context)
+         ,@(constructor-prefix-slots structure tag-expression)
+         ,@(call-with-values (lambda () (parse-mit-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)
+                          (let ((name (slot/name slot)))
+                            (if (or (memq slot required)
+                                    (eq? slot rest))
+                                name
+                                (let ((dv
+                                       (if (eq? type 'RECORD)
+                                           `(,(absolute
+                                               'RECORD-TYPE-DEFAULT-VALUE
+                                               context)
+                                             ,(close (structure/tag-expression
+                                                      structure)
+                                                     context)
+                                             ',name)
+                                           `(,(absolute
+                                               'STRUCTURE-TAG/DEFAULT-VALUE
+                                               context)
+                                             ,tag-expression
+                                             ',type
+                                             ',name))))
+                                  (if (memq slot optional)
+                                      `(IF (DEFAULT-OBJECT? ,name) ,dv ,name)
+                                      dv)))))
+                        (structure/slots structure)))))))))))
 
 (define (make-constructor structure name lambda-list generate-body)
   (let* ((context (structure/context structure))
@@ -821,30 +826,33 @@ differences:
   (if (structure/tagged? structure)
       (let ((type (structure/type structure))
            (type-name (structure/type-descriptor structure))
-           (name
-            (symbol->string
-             (parser-context/name (structure/context structure))))
-           (field-names (map slot/name (structure/slots structure)))
-           (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 expression
-                     `((,(absolute 'SET-RECORD-TYPE-UNPARSER-METHOD! context)
-                        ,type-name
-                        ,(close expression context)))
-                     `())))
-           (let ((type-expression
-                  `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
-                    ',type
-                    ',name
-                    ',field-names
-                    ',(map slot/index (structure/slots structure))
-                    ,(close (structure/print-procedure structure) context))))
-             (if type-name
-                 `((DEFINE ,type-name ,type-expression))
-                 `((,(absolute 'NAMED-STRUCTURE/SET-TAG-DESCRIPTION! context)
-                    ,(close (structure/tag-expression structure) context)
-                    ,type-expression))))))
+           (slots (structure/slots structure))
+           (context (structure/context structure))
+           (print-procedure (structure/print-procedure structure)))
+       (let ((name (symbol->string (parser-context/name context)))
+             (field-names (map slot/name slots))
+             (inits
+              (map (lambda (slot)
+                     `(LAMBDA () ,(close (slot/default slot) context)))
+                   slots)))
+         (let ((type-expression
+                (if (eq? type 'RECORD)
+                    `(,(absolute 'MAKE-RECORD-TYPE context)
+                      ',name
+                      ',field-names
+                      (LIST ,@inits)
+                      ,(close print-procedure context))
+                    `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE context)
+                      ',type
+                      ',name
+                      ',field-names
+                      ',(map slot/index (structure/slots structure))
+                      (LIST ,@inits)
+                      ,(close print-procedure context)))))
+           (if type-name
+               `((DEFINE ,type-name ,type-expression))
+               `((,(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/random.scm b/v7/src/runtime/random.scm
index 917229407ff0ad619a57fc6088fb2e3d8174b41b..b168387c9b0536dd3c9212c61a09ccdccbc1cd95 100644 (file)
--- a/v7/src/runtime/random.scm
+++ b/v7/src/runtime/random.scm
@@ -1,8 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: random.scm,v 14.26 2003/02/14 18:28:33 cph Exp $
+$Id: random.scm,v 14.27 2003/03/11 05:00:48 cph Exp $
 
-Copyright (c) 1993-2001 Massachusetts Institute of Technology
+Copyright 1988,1989,1993,1994,1995,1996 Massachusetts Institute of Technology
+Copyright 1998,1999,2000,2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -170,7 +171,7 @@ USA.
 
 (define (random-state? object)
   (and (vector? object)
-       (not (fix:= (vector-length object) 0))
+       (fix:= (vector-length object) 4)
        (eq? (vector-ref object 0) random-state-tag)))
 
 (define-integrable random-state-tag
@@ -224,4 +225,5 @@ USA.
                                'RANDOM-STATE
                                '(INDEX BORROW VECTOR)
                                '(1 2 3)
+                               #f
                                (standard-unparser-method 'RANDOM-STATE #f))))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5182343011d29fae950a6c924cb2dcf4c4d17986..efe4853a8cc809258ba9c44c506edf64b0d70082 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.435 2003/03/08 02:26:01 cph Exp $
+$Id: runtime.pkg,v 14.436 2003/03/11 05:00:56 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -2683,7 +2683,8 @@ USA.
          record-keyword-constructor
          record-modifier
          record-predicate
-         record-type-default-values
+         record-type-default-inits
+         record-type-default-value
          record-type-descriptor
          record-type-dispatch-tag
          record-type-field-names
@@ -2691,8 +2692,9 @@ USA.
          record-type?
          record-updater
          record?
-         set-record-type-default-values!
+         set-record-type-default-inits!
          set-record-type-unparser-method!
+         structure-tag/default-value
          unparse-record)
   (export (runtime record-slot-access)
          record-type-field-index)