~ chicken-core (chicken-5) 8f79e95e7a50a216f1c46e472263d566ef06de66

commit 8f79e95e7a50a216f1c46e472263d566ef06de66
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu May 20 17:50:28 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu May 20 17:50:28 2010 +0200

    added ##sys#parse-keyword-argument-list

diff --git a/expand.scm b/expand.scm
index 043a6f3a..13e4ee7d 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1922,3 +1922,73 @@
       (set-module-sexports! mod sexports))))
 
 (define ##sys#module-table '())
+
+
+;;; Procedure to pre-parse keyword argument lists
+
+(define ##sys#parse-keyword-argument-list
+  (let ((reverse reverse)
+	(string-append string-append))
+    (lambda (arglist k+d k #!key (rename identity) (warn? #t) location)
+      (let ((%let (rename 'let)))
+	(define (warn msg . args)
+	  (when warn?
+	    (apply
+	     ##sys#warn
+	     (if location
+		 (string-append 
+		  "(" (##sys#symbol->string location) ") "
+		  msg)
+		 msg)
+	     args)))
+	(define (kw->sym kw) 
+	  (##sys#string->symbol (##sys#symbol->string kw)))
+	(let loop ((args arglist) (bindings '()))
+	  (cond ((null? args)
+		 `(,%let ,(map cdr (reverse bindings))
+			 (,%let	; bind variables with names of keyword args
+			  ,(let loop ((k+d k+d)) ; in case defaults refer to them
+			     (if (null? k+d) 
+				 '()
+				 (let* ((x (car k+d))
+					(kw (car x))
+					(def (cdr x)))
+				   (cond ((assq kw bindings) =>
+					  (lambda (a)
+					    (cons (list (kw->sym kw) (cadr a))
+						  (loop (cdr k+d)))))
+					 (else 
+					  (cons (list (kw->sym kw) def)
+						(loop (cdr k+d))))))))
+			  ,(k (let loop ((k+d k+d))
+				(if (null? k+d) 
+				    '()
+				    (let* ((x (car k+d))
+					   (kw (car x)))
+				      (cond ((assq kw bindings) => 
+					     (lambda (a)
+					       (cons (cadr a) (loop (cdr k+d)))))
+					    (else
+					     (cons (kw->sym kw)
+						   (loop (cdr k+d))))))))))))
+		((not (pair? args))
+		 (warn "invalid argument list syntax" arglist)
+		 #f)
+		(else
+		 (let ((arg (car args))
+		       (rest (cdr args)))
+		   (cond ((keyword? arg)
+			  (cond ((assq arg k+d) =>
+				 (lambda (a)
+				   (cond ((not (pair? rest))
+					  (warn "missing keyword argument value" arg arglist)
+					  #f)
+					 (else
+					  (let ((tmp (gensym arg)))
+					    (loop 
+					     (cdr rest) 
+					     (cons (list arg tmp (car rest)) bindings)))))))
+				(else
+				 (warn "unrecognized keyword argument" arg arglist)
+				 #f)))
+			 (else #f))))))))))