Revert most of previous change. Instead introduce new procedures

LIST?->LENGTH and LIST-OF-TYPE?->LENGTH (yes, I know these names suck;
I'm open to suggestions).  Also introduce corresponding GUARANTEE
procedures.

diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index ba463a6250634e5473f462dd6d774202c741eb90..23e719e313a4559e8d60c0ec9eede0eb8fe5bddc 100644 (file)
--- a/v7/src/runtime/list.scm
+++ b/v7/src/runtime/list.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list.scm,v 14.35 2003/03/06 15:28:48 cph Exp $
+$Id: list.scm,v 14.36 2003/03/07 05:42:38 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1994,1995,1996,2000 Massachusetts Institute of Technology
@@ -109,56 +109,44 @@ USA.
        result
        (loop (- index 1)
              (cons (initialization index) result)))))
-
-(define (length items)
-  (let ((lose
-        (lambda () (error:wrong-type-argument items "proper list" 'LENGTH))))
-    (let loop ((l1 items) (l2 items) (length 0))
-      (if (pair? l1)
-         (begin
-           (if (eq? (cdr l1) l2)
-               (lose))
-           (if (pair? (cdr l1))
-               (loop (cddr l1) (cdr l2) (fix:+ length 2))
-               (begin
-                 (if (not (null? (cdr l1)))
-                     (lose))
-                 (fix:+ length 1))))
-         (begin
-           (if (not (null? l1))
-               (lose))
-           length)))))
 \f
-(define (list-ref list index)
-  (let ((tail (list-tail list index)))
-    (if (not (pair? tail))
-       (error:bad-range-argument index 'LIST-REF))
-    (car tail)))
+(define (list? object)
+  (let loop ((l1 object) (l2 object))
+    (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 (list-tail list index)
-  (guarantee-index-fixnum index 'LIST-TAIL)
-  (let loop ((list list) (index* index))
-    (if (fix:zero? index*)
-       list
-       (begin
-         (if (not (pair? list))
-             (error:bad-range-argument index 'LIST-TAIL))
-         (loop (cdr list) (fix:- index* 1))))))
+(define (list-of-type? object predicate)
+  (let loop ((l1 object) (l2 object))
+    (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))))
 
-(define (list-head list index)
-  (guarantee-index-fixnum index 'LIST-HEAD)
-  (let loop ((list list) (index* index))
-    (if (fix:zero? index*)
-       '()
-       (begin
-         (if (not (pair? list))
-             (error:bad-range-argument index 'LIST-HEAD))
-         (cons (car list) (loop (cdr list) (fix:- index* 1)))))))
+(define (guarantee-list object caller)
+  (if (not (list? object))
+      (error:wrong-type-argument object "list" caller)))
 
-(define (sublist list start end)
-  (list-head (list-tail list start) (- end start)))
+(define (guarantee-list-of-type object predicate description caller)
+  (if (not (list-of-type? object predicate))
+      (error:wrong-type-argument object description caller)))
 
-(define (list? object)
+(define (alist? object)
+  (list-of-type? object pair?))
+
+(define (guarantee-alist object caller)
+  (guarantee-list-of-type object pair? "association list" caller))
+
+(define (list?->length object)
   (let loop ((l1 object) (l2 object) (length 0))
     (if (pair? l1)
        (let ((l1 (cdr l1)))
@@ -170,7 +158,7 @@ USA.
        (and (null? l1)
             length))))
 
-(define (list-of-type? object predicate)
+(define (list-of-type?->length object predicate)
   (let loop ((l1 object) (l2 object) (length 0))
     (if (pair? l1)
        (and (predicate (car l1))
@@ -184,24 +172,50 @@ USA.
        (and (null? l1)
             length))))
 
-(define (guarantee-list object caller)
-  (let ((n (list? object)))
+(define (guarantee-list->length object caller)
+  (let ((n (list?->length object)))
     (if (not n)
        (error:wrong-type-argument object "list" caller))
     n))
 
-(define (guarantee-list-of-type object predicate description caller)
+(define (guarantee-list-of-type->length 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 (length list)
+  (guarantee-list->length list 'LENGTH))
 \f
+(define (list-ref list index)
+  (let ((tail (list-tail list index)))
+    (if (not (pair? tail))
+       (error:bad-range-argument index 'LIST-REF))
+    (car tail)))
+
+(define (list-tail list index)
+  (guarantee-index-fixnum index 'LIST-TAIL)
+  (let loop ((list list) (index* index))
+    (if (fix:zero? index*)
+       list
+       (begin
+         (if (not (pair? list))
+             (error:bad-range-argument index 'LIST-TAIL))
+         (loop (cdr list) (fix:- index* 1))))))
+
+(define (list-head list index)
+  (guarantee-index-fixnum index 'LIST-HEAD)
+  (let loop ((list list) (index* index))
+    (if (fix:zero? index*)
+       '()
+       (begin
+         (if (not (pair? list))
+             (error:bad-range-argument index 'LIST-HEAD))
+         (cons (car list) (loop (cdr list) (fix:- index* 1)))))))
+
+(define (sublist list start end)
+  (list-head (list-tail list start) (- end start)))
+
 (define (list-copy items)
   (let ((lose (lambda () (error:wrong-type-argument items "list" 'LIST-COPY))))
     (cond ((pair? items)