From d0511f3d47ade41a687d7b42c8149e7262842459 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 7 Mar 2003 18:34:43 +0000
Subject: [PATCH] Implement RECORD-KEYWORD-CONSTRUCTOR.

---
 v7/src/runtime/record.scm  | 48 ++++++++++++++++++++++++++++----------
 v7/src/runtime/runtime.pkg |  3 ++-
 2 files changed, 38 insertions(+), 13 deletions(-)

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 63a3a840e..8b04ce058 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.32 2003/03/07 05:48:28 cph Exp $
+$Id: record.scm,v 1.33 2003/03/07 18:32:38 cph Exp $
 
 Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology
 Copyright 1997,2002,2003 Massachusetts Institute of Technology
@@ -284,13 +284,12 @@ USA.
 			    (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)))
+	      field-names)))
     (letrec
 	((constructor
 	  (lambda field-values
@@ -299,16 +298,41 @@ USA.
 		     (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))))
+	      (let ((record (%copy-default-record record-type)))
+		(do ((indexes indexes (cdr indexes))
+		     (values field-values (cdr values)))
+		    ((not (pair? indexes))
+		     (if (not (null? values))
+			 (lose)))
+		  (if (not (pair? values))
+		      (lose))
+		  (%record-set! record (car indexes) (car values)))
 		record)))))
       constructor)))
+
+(define (record-keyword-constructor record-type)
+  (letrec
+      ((constructor
+	(lambda keyword-list
+	  (let* ((record (%copy-default-record record-type))
+		 (seen? (make-vector (%record-length record) #f)))
+	    (do ((kl keyword-list (cddr kl)))
+		((not (and (pair? kl)
+			   (symbol? (car kl))
+			   (pair? (cdr kl))))
+		 (if (not (null? kl))
+		     (error:wrong-type-argument keyword-list "keyword list"
+						constructor)))
+	      (let ((i (record-type-field-index record-type (car kl) #t)))
+		(if (not (vector-ref seen? i))
+		    (begin
+		      (%record-set! record i (cadr kl))
+		      (vector-set! seen? i #t)))))
+	    record))))
+    constructor))
+
+(define-integrable (%copy-default-record record-type)
+  (%copy-record (%record-type-default-record record-type)))
 
 (define (record? object)
   (and (%record? object)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7569b6e9b..144b67e02 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.431 2003/03/07 05:48:36 cph Exp $
+$Id: runtime.pkg,v 14.432 2003/03/07 18:34:43 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -2677,6 +2677,7 @@ USA.
 	  record-constructor
 	  record-copy
 	  record-description
+	  record-keyword-constructor
 	  record-modifier
 	  record-predicate
 	  record-type-default-values
-- 
2.25.1