From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Sep 2008 05:53:47 +0000 (+0000)
Subject: Implement WRAP-LIST-PARSER.  Implement VALUES parser expression.
X-Git-Tag: 20090517-FFI~185
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=47cc4a8b84dc4112d98edcf01dcfbfce3736609a;p=mit-scheme.git

Implement WRAP-LIST-PARSER.  Implement VALUES parser expression.
---

diff --git a/v7/src/runtime/list-parser.scm b/v7/src/runtime/list-parser.scm
index 886129200..c5685b040 100644
--- a/v7/src/runtime/list-parser.scm
+++ b/v7/src/runtime/list-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list-parser.scm,v 1.1 2008/09/03 02:49:06 cph Exp $
+$Id: list-parser.scm,v 1.2 2008/09/03 05:53:44 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -96,6 +96,16 @@ USA.
       `(IF ,(make-test items)
 	   ,(make-body items lose)
 	   (,lose)))))
+
+(define (wrap-list-parser parser)
+  (lambda (items)
+    (parser items
+	    (lambda (items vals lose)
+	      (if (null? items)
+		  (list-parser-vals->list vals)
+		  (lose)))
+	    (lambda ()
+	      #f))))
 
 (define-pattern-compiler '(MATCH-NULL)
   (lambda (pattern env items win lose)
@@ -151,6 +161,21 @@ USA.
 			 ',datum))))
 	      (lambda (items lose)
 		`(,win (CDR ,items) ,(null-vals) ,lose)))))
+
+(define-pattern-compiler '(VALUES * EXPRESSION)
+  (lambda (pattern env items win lose)
+    `(,win ,items
+	   ,(let ((vals
+		   (map (lambda (expr)
+			  (single-val (close-syntax expr env)))
+			(cdr pattern))))
+	      (if (pair? vals)
+		  (let loop ((vals vals))
+		    (if (pair? (cdr vals))
+			(join-vals (car vals) (loop (cdr vals)))
+			(car vals)))
+		  (null-vals)))
+	   ,lose)))
 
 (define-pattern-compiler '(LIST * FORM)
   (lambda (pattern env items win lose)
@@ -169,7 +194,7 @@ USA.
 					     (,win (CDR ,items) ,vals ,lose)
 					     (,lose))))))
 				 lose)))))
-
+
 (define-pattern-compiler '(SEXP EXPRESSION)
   (lambda (pattern env items win lose)
     `(,(close-syntax (cadr pattern) env) ,items ,win ,lose)))
@@ -184,7 +209,7 @@ USA.
 			vals
 			`(,win ,items ,(null-vals) ,lose)))
 		     lose)))
-
+
 (define-pattern-compiler '(? * FORM)
   (lambda (pattern env items win lose)
     (compile-pattern `(SEQ ,@(cdr pattern))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index fdfda1851..9d488f386 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.670 2008/09/03 02:49:09 cph Exp $
+$Id: runtime.pkg,v 14.671 2008/09/03 05:53:47 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -5281,7 +5281,8 @@ USA.
   (parent (runtime))
   (export ()
 	  list-parser
-	  list-parser-vals->list))
+	  list-parser-vals->list
+	  wrap-list-parser))
 
 (define-package (runtime postgresql)
   (file-case options