From 6c473e8acce39b6d1f53ba79ad425c466392c009 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 6 Mar 2003 15:28:48 +0000
Subject: [PATCH] Change LIST?, ALIST?, and LIST-OF-TYPE? to return the length
 of the list when true.  New procedures GUARANTEE-LIST, GUARANTEE-ALIST, and
 GUARANTEE-LIST-OF-TYPE.  Replace GUARANTEE-INDEX/LIST with
 GUARANTEE-INDEX-FIXNUM.

---
 v7/src/runtime/list.scm | 71 +++++++++++++++++++++--------------------
 1 file changed, 37 insertions(+), 34 deletions(-)

diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index 7ba844323..ba463a625 100644
--- a/v7/src/runtime/list.scm
+++ b/v7/src/runtime/list.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list.scm,v 14.34 2003/02/14 18:28:33 cph Exp $
+$Id: list.scm,v 14.35 2003/03/06 15:28:48 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1995,1996,2000 Massachusetts Institute of Technology
@@ -74,7 +74,7 @@ USA.
 	this-element)))
 
 (define (make-list length #!optional value)
-  (guarantee-index/list length 'MAKE-LIST)
+  (guarantee-index-fixnum length 'MAKE-LIST)
   (let ((value (if (default-object? value) '() value)))
     (let loop ((n length) (result '()))
       (if (fix:zero? n)
@@ -90,7 +90,7 @@ USA.
   items)
 
 (define (make-circular-list length #!optional value)
-  (guarantee-index/list length 'MAKE-CIRCULAR-LIST)
+  (guarantee-index-fixnum length 'MAKE-CIRCULAR-LIST)
   (if (not (fix:zero? length))
       (let ((value (if (default-object? value) '() value)))
 	(let ((last (cons value '())))
@@ -103,7 +103,7 @@ USA.
       '()))
 
 (define (make-initialized-list length initialization)
-  (guarantee-index/list length 'MAKE-INITIALIZED-LIST)
+  (guarantee-index-fixnum length 'MAKE-INITIALIZED-LIST)
   (let loop ((index (- length 1)) (result '()))
     (if (negative? index)
 	result
@@ -136,7 +136,7 @@ USA.
     (car tail)))
 
 (define (list-tail list index)
-  (guarantee-index/list index 'LIST-TAIL)
+  (guarantee-index-fixnum index 'LIST-TAIL)
   (let loop ((list list) (index* index))
     (if (fix:zero? index*)
 	list
@@ -146,7 +146,7 @@ USA.
 	  (loop (cdr list) (fix:- index* 1))))))
 
 (define (list-head list index)
-  (guarantee-index/list index 'LIST-HEAD)
+  (guarantee-index-fixnum index 'LIST-HEAD)
   (let loop ((list list) (index* index))
     (if (fix:zero? index*)
 	'()
@@ -159,38 +159,48 @@ USA.
   (list-head (list-tail list start) (- end start)))
 
 (define (list? object)
-  (let loop ((l1 object) (l2 object))
+  (let loop ((l1 object) (l2 object) (length 0))
     (if (pair? l1)
 	(let ((l1 (cdr l1)))
 	  (and (not (eq? l1 l2))
 	       (if (pair? l1)
-		   (loop (cdr l1) (cdr l2))
-		   (null? l1))))
-	(null? l1))))
-
-(define (alist? object)
-  (let loop ((l1 object) (l2 object))
-    (if (pair? l1)
-	(and (pair? (car l1))
-	     (let ((l1 (cdr l1)))
-	       (and (not (eq? l1 l2))
-		    (if (pair? l1)
-			(and (pair? (car l1))
-			     (loop (cdr l1) (cdr l2)))
-			(null? l1)))))
-	(null? l1))))
+		   (loop (cdr l1) (cdr l2) (fix:+ length 2))
+		   (and (null? l1)
+			(fix:+ length 1)))))
+	(and (null? l1)
+	     length))))
 
 (define (list-of-type? object predicate)
-  (let loop ((l1 object) (l2 object))
+  (let loop ((l1 object) (l2 object) (length 0))
     (if (pair? l1)
 	(and (predicate (car l1))
 	     (let ((l1 (cdr l1)))
 	       (and (not (eq? l1 l2))
 		    (if (pair? l1)
 			(and (predicate (car l1))
-			     (loop (cdr l1) (cdr l2)))
-			(null? l1)))))
-	(null? l1))))
+			     (loop (cdr l1) (cdr l2) (fix:+ length 2)))
+			(and (null? l1)
+			     (fix:+ length 1))))))
+	(and (null? l1)
+	     length))))
+
+(define (guarantee-list object caller)
+  (let ((n (list? object)))
+    (if (not n)
+	(error:wrong-type-argument object "list" caller))
+    n))
+
+(define (guarantee-list-of-type object predicate description caller)
+  (let ((n (list-of-type? object predicate)))
+    (if (not n)
+	(error:wrong-type-argument object description caller))
+    n))
+
+(define (alist? object)
+  (list-of-type? object pair?))
+
+(define (guarantee-alist object caller)
+  (guarantee-list-of-type object pair? "association list" caller))
 
 (define (list-copy items)
   (let ((lose (lambda () (error:wrong-type-argument items "list" 'LIST-COPY))))
@@ -966,11 +976,4 @@ USA.
 
 (define-integrable (guarantee-pair object procedure)
   (if (not (pair? object))
-      (error:wrong-type-argument object "pair" procedure)))
-
-(define-integrable (guarantee-index/list object procedure)
-  (if (not (index-fixnum? object))
-      (guarantee-index/list/fail object procedure)))
-
-(define (guarantee-index/list/fail object procedure)
-  (error:wrong-type-argument object "valid list index" procedure))
\ No newline at end of file
+      (error:wrong-type-argument object "pair" procedure)))
\ No newline at end of file
-- 
2.25.1