Add support for keyword lists.

diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index 6c07684673504af848cf04c0f3c18beac00588b4..a733ad8b859fa06a0f30ab00b26ce64ea2ac7450 100644 (file)
--- a/v7/src/runtime/list.scm
+++ b/v7/src/runtime/list.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list.scm,v 14.41 2004/11/17 05:24:11 cph Exp $
+$Id: list.scm,v 14.42 2004/11/17 05:42:14 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1995,1996,2000 Massachusetts Institute of Technology
@@ -999,6 +999,55 @@ USA.
          ((null? alist) alist)
          (else (lose)))))
 \f
+;;;; Keyword lists
+
+(define (keyword-list? object)
+  (let loop ((l1 object) (l2 object))
+    (if (pair? l1)
+       (and (symbol? (car l1))
+            (pair? (cdr l1))
+            (not (eq? (cdr l1) l2))
+            (loop (cdr (cdr l1)) (cdr l1)))
+       (null? l1))))
+
+(define (guarantee-keyword-list object caller)
+  (if (not (keyword-list? object))
+      (error:not-keyword-list object caller)))
+
+(define (error:not-keyword-list object caller)
+  (error:wrong-type-argument object "keyword list" caller))
+
+(define (restricted-keyword-list? object keywords)
+  (let loop ((l1 object) (l2 object))
+    (if (pair? l1)
+       (and (memq (car l1) keywords)
+            (pair? (cdr l1))
+            (not (eq? (cdr l1) l2))
+            (loop (cdr (cdr l1)) (cdr l1)))
+       (null? l1))))
+
+(define (guarantee-restricted-keyword-list object caller)
+  (if (not (restricted-keyword-list? object))
+      (error:not-restricted-keyword-list object caller)))
+
+(define (error:not-restricted-keyword-list object caller)
+  (error:wrong-type-argument object "restricted keyword list" caller))
+
+(define (get-keyword-value klist key default)
+  (let ((lose (lambda () (error:not-keyword-list klist 'GET-KEYWORD-VALUE))))
+    (let loop ((klist klist))
+      (if (pair? klist)
+         (begin
+           (if (not (pair? (cdr klist)))
+               (lose))
+           (if (eq? (car klist) key)
+               (cadr klist)
+               (loop (cddr klist))))
+         (begin
+           (if (not (null? klist))
+               (lose))
+           default)))))
+\f
 ;;;; Lastness and Segments
 
 (define (last-pair list)

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 6eaa2e13986f9af25a5e2c089f7d50baf7ed8fad..23a738a06eab71947fa572319f95109cfa0c5350 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.47 2003/04/25 03:27:55 cph Exp $
+$Id: record.scm,v 1.48 2004/11/17 05:42:22 cph Exp $
 
 Copyright 1989,1990,1991,1993,1994,1996 Massachusetts Institute of Technology
-Copyright 1997,2002,2003 Massachusetts Institute of Technology
+Copyright 1997,2002,2003,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -362,8 +362,7 @@ USA.
                             (symbol? (car kl))
                             (pair? (cdr kl))))
                   (if (not (null? kl))
-                      (error:wrong-type-argument keyword-list "keyword list"
-                                                 constructor)))
+                      (error:not-keyword-list keyword-list constructor)))
                (let ((i (record-type-field-index record-type (car kl) #t)))
                  (if (not (vector-ref seen? i))
                      (begin
@@ -601,7 +600,7 @@ USA.
            (do ((args arguments (cddr args)))
                ((not (pair? args)))
              (if (not (pair? (cdr args)))
-                 (error "Keyword list does not have even length:" arguments))
+                 (error:not-keyword-list arguments #f))
              (let ((field-name (car args)))
                (let loop ((i 0))
                  (if (not (fix:< i n))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 128d5c4c76d3d6ca6ef8fe5726ae2f69edf18c5b..3874e9a25f1f332d4101fb8078de768e177f2286 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.510 2004/11/17 05:24:31 cph Exp $
+$Id: runtime.pkg,v 14.511 2004/11/17 05:42:33 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -2111,8 +2111,10 @@ USA.
          delv!
          eighth
          error:not-alist
+         error:not-keyword-list
          error:not-list
          error:not-pair
+         error:not-restricted-keyword-list
          error:not-weak-list
          except-last-pair
          except-last-pair!
@@ -2125,14 +2127,18 @@ USA.
          for-each
          fourth
          general-car-cdr
+         get-keyword-value
          guarantee-alist
+         guarantee-keyword-list
          guarantee-list
          guarantee-list->length
          guarantee-list-of-type
          guarantee-list-of-type->length
          guarantee-pair
+         guarantee-restricted-keyword-list
          guarantee-weak-list
          keep-matching-items
+         keyword-list?
          last-pair
          length
          list
@@ -2163,6 +2169,7 @@ USA.
          pair?
          reduce
          reduce-right
+         restricted-keyword-list?
          reverse
          reverse!
          reverse*