From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Nov 2004 05:42:33 +0000 (+0000)
Subject: Add support for keyword lists.
X-Git-Tag: 20090517-FFI~1477
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5dcb309681b67d627a0a395fdcb499c0bc329370;p=mit-scheme.git

Add support for keyword lists.
---

diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index 6c0768467..a733ad8b8 100644
--- 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)))))
 
+;;;; 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)))))
+
 ;;;; Lastness and Segments
 
 (define (last-pair list)
diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 6eaa2e139..23a738a06 100644
--- 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 128d5c4c7..3874e9a25 100644
--- 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*