From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 3 Sep 2008 06:08:19 +0000 (+0000)
Subject: Implement LIST-PARSER-VALS-REF and LIST-PARSER-VALS-LENGTH.
X-Git-Tag: 20090517-FFI~184
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b2c0dbfb82e39bbe3a703914115141e3840dcc0;p=mit-scheme.git

Implement LIST-PARSER-VALS-REF and LIST-PARSER-VALS-LENGTH.
---

diff --git a/v7/src/runtime/list-parser.scm b/v7/src/runtime/list-parser.scm
index c5685b040..469520e62 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.2 2008/09/03 05:53:44 cph Exp $
+$Id: list-parser.scm,v 1.3 2008/09/03 06:08:16 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -360,7 +360,7 @@ USA.
 	      names)))
 
 (define name-counters)
-
+
 (define (join-vals vals1 vals2)
   `(CONS ,vals1 ,vals2))
 
@@ -384,6 +384,32 @@ USA.
 			  k))))
 	(k items))))
 
+(define (list-parser-vals-length vals)
+  (if (pair? vals)
+      (let loop ((vals vals))
+	(if (eq? (car vals) single-val-marker)
+	    1
+	    (+ (loop (car vals))
+	       (loop (cdr vals)))))
+      0))
+
+(define (list-parser-vals-ref vals index)
+  (if (not (pair? vals))
+      (error:bad-range-argument index 'LIST-PARSER-VALS-REF))
+  (let loop ((vals vals) (i 0) (stack '()))
+    (if (eq? (car vals) single-val-marker)
+	(if (< i index)
+	    (begin
+	      (if (not (pair? stack))
+		  (error:bad-range-argument index 'LIST-PARSER-VALS-REF))
+	      (loop (car stack)
+		    (+ i 1)
+		    (cdr stack)))
+	    (cdr vals))
+	(loop (car vals)
+	      i
+	      (cons (cdr vals) stack)))))
+
 (define single-val-marker
   '|#[(runtime list-parser)single-val-marker]|)
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 9d488f386..5575a5524 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.671 2008/09/03 05:53:47 cph Exp $
+$Id: runtime.pkg,v 14.672 2008/09/03 06:08:19 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -5282,6 +5282,8 @@ USA.
   (export ()
 	  list-parser
 	  list-parser-vals->list
+	  list-parser-vals-length
+	  list-parser-vals-ref
 	  wrap-list-parser))
 
 (define-package (runtime postgresql)