From: Joe Marshall <eval.apply@gmail.com>
Date: Sat, 25 Jun 2011 22:51:30 +0000 (-0700)
Subject: %make-record now takes a tag and length.  Other returned record fields will be #f.
X-Git-Tag: release-9.2.0~358
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=256e7627ac6c2112581ecd3e8ae18d17c4fb5d8f;p=mit-scheme.git

%make-record now takes a tag and length.  Other returned record fields will be #f.
---

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 7d6abc60d..9cef57d83 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -43,9 +43,11 @@ USA.
   (primitive-object-set-type 2)
   (vector-cons 2))
 
-(define-integrable (%make-record length object)
-  ((ucode-primitive object-set-type) (ucode-type record)
-				     (vector-cons length object)))
+(define-integrable (%make-record tag length)
+  (let ((record ((ucode-primitive object-set-type)
+		 (ucode-type record) (vector-cons length #f))))
+    (%record-set! record 0 tag)
+    record))
 
 (define-integrable (%record-tag record)
   (%record-ref record 0))
@@ -56,8 +58,8 @@ USA.
 
 (define (%copy-record record)
   (let ((length (%record-length record)))
-    (let ((result (%make-record length #f)))
-      (do ((index 0 (fix:+ index 1)))
+    (let ((result (%make-record (%record-tag record) length)))
+      (do ((index 1 (fix:+ index 1)))
 	  ((fix:= index length))
 	(%record-set! result index (%record-ref record index)))
       result)))
@@ -351,13 +353,12 @@ USA.
 	    (letrec
 		((constructor
 		  (lambda field-values
-		    (let ((record (%make-record reclen #f))
+		    (let ((record (%make-record tag reclen))
 			  (lose
 			   (lambda ()
 			     (error:wrong-number-of-arguments constructor
 							      n-fields
 							      field-values))))
-		      (%record-set! record 0 tag)
 		      (do ((i 1 (fix:+ i 1))
 			   (vals field-values (cdr vals)))
 			  ((not (fix:< i reclen))
@@ -400,8 +401,8 @@ USA.
 						      (length indexes)
 						      field-values))))
 	      (let ((record
-		     (%make-record (%record-type-length record-type) #f)))
-		(%record-set! record 0 (%record-type-dispatch-tag record-type))
+		     (%make-record (%record-type-dispatch-tag record-type)
+				   (%record-type-length record-type))))
 		(do ((indexes indexes (cdr indexes))
 		     (values field-values (cdr values)))
 		    ((not (pair? indexes))
@@ -424,9 +425,8 @@ USA.
       ((constructor
 	(lambda keyword-list
 	  (let ((n (%record-type-length record-type)))
-	    (let ((record (%make-record n #f))
+	    (let ((record (%make-record (%record-type-dispatch-tag record-type) n))
 		  (seen? (vector-cons n #f)))
-	      (%record-set! record 0 (%record-type-dispatch-tag record-type))
 	      (do ((kl keyword-list (cddr kl)))
 		  ((not (and (pair? kl)
 			     (symbol? (car kl))