Revert earlier change to use RECORD-KEYWORD-CONSTRUCTOR, because it

doesn't handle default values right.

Actually, I don't think it can do so, because DEFINE-STRUCTURE has
default expressions rather than default values; the expressions are
intended to be evaluated within the context of the constructor.  I
think this is a design flaw, but I'm not yet sure whether it is OK to
fix the design.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index a7ce376494fbeaffdbb17b89266e4ddc9d5874a4..281f8ef52af4c9134b426d39cd9587d6c1c0fe90 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.47 2003/03/08 02:52:33 cph Exp $
+$Id: defstr.scm,v 14.48 2003/03/08 04:53:58 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,1997,2000 Massachusetts Institute of Technology
@@ -703,30 +703,28 @@ differences:
          ,@slot-names)))))
 
 (define (constructor-definition/keyword structure name)
-  (if (eq? (structure/type structure) 'RECORD)
+  (make-constructor structure name 'KEYWORD-LIST
+    (lambda (tag-expression)
       (let ((context (structure/context structure)))
-       `(DEFINE ,name
-          (,(absolute 'RECORD-KEYWORD-CONSTRUCTOR context)
-          ,(close (structure/tag-expression structure) context))))
-      (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)
-               ((VECTOR)
-                `(,(absolute 'APPLY context) ,(absolute 'VECTOR context)
-                                             ,@list-cons))
-               ((LIST)
-                `(,(absolute 'CONS* context) ,@list-cons)))))))))
+       (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))))))))
 \f
 (define (constructor-definition/boa structure name lambda-list)
   (make-constructor structure name lambda-list