From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Sep 2008 07:00:25 +0000 (+0000)
Subject: Implement LIST->LIST-PARSER-VALS and MAP-LIST-PARSER-VALS.  Simplify
X-Git-Tag: 20090517-FFI~183
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e75fbe0c988f1ecf1f4bdf4793613a3ad7ece83c;p=mit-scheme.git

Implement LIST->LIST-PARSER-VALS and MAP-LIST-PARSER-VALS.  Simplify
implementation of LIST-PARSER-VALS->LIST.
---

diff --git a/v7/src/runtime/list-parser.scm b/v7/src/runtime/list-parser.scm
index 469520e62..63ef647a8 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.3 2008/09/03 06:08:16 cph Exp $
+$Id: list-parser.scm,v 1.4 2008/09/03 07:00:22 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -284,8 +284,9 @@ USA.
 		     (make-winner
 		      (lambda (items vals lose)
 			`(,win ,items
-			       (map ,(close-syntax (cadr pattern) env)
-				    (LIST-PARSER-VALS->LIST ,vals))
+			       (MAP-LIST-PARSER-VALS
+				,(close-syntax (cadr pattern) env)
+				,vals)
 			       ,lose)))
 		     lose)))
 
@@ -310,10 +311,17 @@ USA.
 		     items
 		     (make-winner
 		      (lambda (items vals lose)
-			`(,win ,items
-			       (APPLY ,(close-syntax (cadr pattern) env)
-				      (LIST-PARSER-VALS->LIST ,vals))
-			       ,lose)))
+			(make-let '(VALS)
+				  `(APPLY ,(close-syntax (cadr pattern) env)
+					  (LIST-PARSER-VALS->LIST ,vals))
+			  (lambda (vals)
+			    (fork-loser lose
+			      (lambda (lose)
+				`(IF ,vals
+				     (,win ,items
+					   (LIST->LIST-PARSER-VALS ,vals)
+					   ,lose)
+				     (,lose))))))))
 		     lose)))
 
 (define (make-winner procedure)
@@ -372,17 +380,35 @@ USA.
 
 ;; Needed at runtime by parsers:
 (define (list-parser-vals->list vals)
-  (let loop ((vals vals) (items '()) (k reverse!))
-    (if (pair? vals)
+  (if (pair? vals)
+      (let loop ((vals vals) (tail '()))
 	(if (eq? (car vals) single-val-marker)
-	    (k (cons (cdr vals) items))
+	    (cons (cdr vals) tail)
 	    (loop (car vals)
-		  items
-		  (lambda (items)
-		    (loop (cdr vals)
-			  items
-			  k))))
-	(k items))))
+		  (loop (cdr vals)
+			tail))))
+      '()))
+
+;; Needed at runtime by parsers:
+(define (list->list-parser-vals items)
+  (if (pair? items)
+      (let loop ((items items))
+	(if (pair? (cdr items))
+	    (cons (cons single-val-marker (car items))
+		  (loop (cdr items)))
+	    (cons single-val-marker (car items))))
+      '()))
+
+;; Needed at runtime by parsers:
+(define (map-list-parser-vals procedure vals)
+  (if (pair? vals)
+      (let loop ((vals vals))
+	(if (eq? (car vals) single-val-marker)
+	    (cons single-val-marker
+		  (procedure (cdr vals)))
+	    (cons (loop (car vals))
+		  (loop (cdr vals)))))
+      vals))
 
 (define (list-parser-vals-length vals)
   (if (pair? vals)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5575a5524..e6a578376 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.672 2008/09/03 06:08:19 cph Exp $
+$Id: runtime.pkg,v 14.673 2008/09/03 07:00:25 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -5280,10 +5280,12 @@ USA.
   (files "list-parser")
   (parent (runtime))
   (export ()
+	  list->list-parser-vals
 	  list-parser
 	  list-parser-vals->list
 	  list-parser-vals-length
 	  list-parser-vals-ref
+	  map-list-parser-vals
 	  wrap-list-parser))
 
 (define-package (runtime postgresql)