Implement RECORD-KEYWORD-CONSTRUCTOR.

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 63a3a840e01330b59e51f163ce00e13f12780da0..8b04ce05801c096ff9fc6c198d10697ad5a3229a 100644 (file)
--- 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)))))))
-
+\f
 (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)))
 \f
 (define (record? object)
   (and (%record? object)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7569b6e9b5b3c99ee64711a49edcd44442bd53cf..144b67e026af3ffcaa1139c93931131dc4ea22aa 100644 (file)
--- 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