From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 8 Mar 2003 04:53:58 +0000 (+0000)
Subject: Revert earlier change to use RECORD-KEYWORD-CONSTRUCTOR, because it
X-Git-Tag: 20090517-FFI~1973
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d332404ba266d611cf4c1e940ea51f72e86d7cd2;p=mit-scheme.git

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 a7ce37649..281f8ef52 100644
--- 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))))))))
 
 (define (constructor-definition/boa structure name lambda-list)
   (make-constructor structure name lambda-list