From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 17 Jan 2017 21:16:18 +0000 (-0800)
Subject: Implement get-keyword-values.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~121
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8d472fb85b0e9ffc60096665b13c70c9429a807a;p=mit-scheme.git

Implement get-keyword-values.
---

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index 7fa192d84..898609dce 100644
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -1383,7 +1383,7 @@ USA.
 (define-guarantee unique-keyword-list "unique keyword list")
 
 (define (get-keyword-value klist key #!optional default-value)
-  (let ((lose (lambda () (error:not-keyword-list klist 'GET-KEYWORD-VALUE))))
+  (let ((lose (lambda () (error:not-a keyword-list? klist 'get-keyword-value))))
     (let loop ((klist klist))
       (if (pair? klist)
 	  (begin
@@ -1397,6 +1397,23 @@ USA.
 		(lose))
 	    default-value)))))
 
+(define (get-keyword-values klist key)
+  (let ((lose
+	 (lambda () (error:not-a keyword-list? klist 'get-keyword-values))))
+    (let loop ((klist klist) (values values))
+      (if (pair? klist)
+	  (begin
+	    (if (not (pair? (cdr klist)))
+		(lose))
+	    (loop (cdr (cdr list))
+		  (if (eq? (car klist) key)
+		      (cons (car (cdr klist)) values)
+		      values)))
+	  (begin
+	    (if (not (null? klist))
+		(lose))
+	    (reverse! values))))))
+
 (define (keyword-list->alist klist)
   (let loop ((klist klist))
     (if (pair? klist)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c954da260..9f5c1f712 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2891,6 +2891,7 @@ USA.
 	  fourth
 	  general-car-cdr
 	  get-keyword-value
+	  get-keyword-values
 	  guarantee-list->length
 	  guarantee-list-of-type
 	  guarantee-list-of-type->length