1 files changed, 181 insertions, 194 deletions

diff --git a/comlist.scm b/comlist.scm
index 8ecf525..008a2b0 100644
--- a/comlist.scm
+++ b/comlist.scm
@@ -1,9 +1,10 @@
 ;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
-; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
+; Copyright (C) 1991, 1993, 1995, 2001 Aubrey Jaffer.
+; Copyright (C) 2000 Colin Walters
 ;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
 ;
 ;1.  Any copy made of this software must include this copyright notice
 ;in full.
@@ -22,6 +23,10 @@
 
 ;;;; LIST FUNCTIONS FROM COMMON LISP
 
+;;; Some tail-recursive optimizations made by
+;;; Colin Walters <walters@cis.ohio-state.edu>
+;;; AGJ restored order July 2001.
+
 ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
 (define (comlist:make-list k . init)
   (set! init (if (pair? init) (car init)))
@@ -31,23 +36,34 @@
 
 (define (comlist:copy-list lst) (append lst '()))
 
-(define (comlist:adjoin e l) (if (memv e l) l (cons e l)))
-
-(define (comlist:union l1 l2)
-  (cond ((null? l1) l2)
-	((null? l2) l1)
-	(else (comlist:union (cdr l1) (comlist:adjoin (car l1) l2)))))
-
-(define (comlist:intersection l1 l2)
-  (cond ((null? l1) l1)
-	((null? l2) l2)
-	((memv (car l1) l2) (cons (car l1) (comlist:intersection (cdr l1) l2)))
-	(else (comlist:intersection (cdr l1) l2))))
+(define (comlist:adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
+
+(define (comlist:union lst1 lst2)
+  (define ans (if (null? lst1) lst2 lst1))
+  (cond ((null? lst2) lst1)
+	(else (for-each (lambda (elt) (set! ans (comlist:adjoin elt ans)))
+			lst2)
+	      ans)))
+
+(define (comlist:intersection lst1 lst2)
+  (if (null? lst2)
+      lst2
+      (let build-intersection ((lst1 lst1)
+			       (result '()))
+	(cond ((null? lst1) (reverse result))
+	      ((memv (car lst1) lst2)
+	       (build-intersection (cdr lst1) (cons (car lst1) result)))
+	      (else
+	       (build-intersection (cdr lst1) result))))))
 
-(define (comlist:set-difference l1 l2)
-  (cond ((null? l1) l1)
-	((memv (car l1) l2) (comlist:set-difference (cdr l1) l2))
-	(else (cons (car l1) (comlist:set-difference (cdr l1) l2)))))
+(define (comlist:set-difference lst1 lst2)
+  (if (null? lst2)
+      lst1
+      (let build-difference ((lst1 lst1)
+			     (result '()))
+	(cond ((null? lst1) (reverse result))
+	      ((memv (car lst1) lst2) (build-difference (cdr lst1) result))
+	      (else (build-difference (cdr lst1) (cons (car lst1) result)))))))
 
 (define (comlist:position obj lst)
   (letrec ((pos (lambda (n lst)
@@ -56,64 +72,107 @@
 			(else (pos (+ 1 n) (cdr lst)))))))
     (pos 0 lst)))
 
-(define (comlist:reduce-init p init l)
-  (if (null? l)
+(define (comlist:reduce-init pred? init lst)
+  (if (null? lst)
       init
-      (comlist:reduce-init p (p init (car l)) (cdr l))))
+      (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst))))
 
-(define (comlist:reduce p l)
-  (cond ((null? l) l)
-	((null? (cdr l)) (car l))
-	(else (comlist:reduce-init p (car l) (cdr l)))))
+(define (comlist:reduce pred? lst)
+  (cond ((null? lst) lst)
+	((null? (cdr lst)) (car lst))
+	(else (comlist:reduce-init pred? (car lst) (cdr lst)))))
 
-(define (comlist:some pred l . rest)
+(define (comlist:some pred lst . rest)
   (cond ((null? rest)
-	 (let mapf ((l l))
-	   (and (not (null? l))
-		(or (pred (car l)) (mapf (cdr l))))))
-	(else (let mapf ((l l) (rest rest))
-		(and (not (null? l))
-		     (or (apply pred (car l) (map car rest))
-			 (mapf (cdr l) (map cdr rest))))))))
-
-(define (comlist:every pred l . rest)
+	 (let mapf ((lst lst))
+	   (and (not (null? lst))
+		(or (pred (car lst)) (mapf (cdr lst))))))
+	(else (let mapf ((lst lst) (rest rest))
+		(and (not (null? lst))
+		     (or (apply pred (car lst) (map car rest))
+			 (mapf (cdr lst) (map cdr rest))))))))
+
+(define (comlist:every pred lst . rest)
   (cond ((null? rest)
-	 (let mapf ((l l))
-	   (or (null? l)
-	       (and (pred (car l)) (mapf (cdr l))))))
-	(else (let mapf ((l l) (rest rest))
-		(or (null? l)
-		    (and (apply pred (car l) (map car rest))
-			 (mapf (cdr l) (map cdr rest))))))))
+	 (let mapf ((lst lst))
+	   (or (null? lst)
+	       (and (pred (car lst)) (mapf (cdr lst))))))
+	(else (let mapf ((lst lst) (rest rest))
+		(or (null? lst)
+		    (and (apply pred (car lst) (map car rest))
+			 (mapf (cdr lst) (map cdr rest))))))))
 
 (define (comlist:notany pred . ls) (not (apply comlist:some pred ls)))
 
 (define (comlist:notevery pred . ls) (not (apply comlist:every pred ls)))
 
-(define (comlist:find-if t l)
-  (cond ((null? l) #f)
-	((t (car l)) (car l))
-	(else (comlist:find-if t (cdr l)))))
-
-(define (comlist:member-if t l)
-  (cond ((null? l) #f)
-	((t (car l)) l)
-	(else (comlist:member-if t (cdr l)))))
-
-(define (comlist:remove p l)
-  (cond ((null? l) l)
-	((eqv? p (car l)) (comlist:remove p (cdr l)))
-	(else (cons (car l) (comlist:remove p (cdr l))))))
-
-(define (comlist:remove-if p l)
-  (cond ((null? l) l)
-	((p (car l)) (comlist:remove-if p (cdr l)))
-	(else (cons (car l) (comlist:remove-if p (cdr l))))))
+(define (comlist:list-of?? predicate . bound)
+  (define (errout) (apply slib:error 'list-of?? predicate bound))
+  (case (length bound)
+    ((0)
+     (lambda (obj)
+       (and (list? obj)
+	    (every predicate obj))))
+    ((1)
+     (set! bound (car bound))
+     (cond ((negative? bound)
+	    (set! bound (- bound))
+	    (lambda (obj)
+	      (and (list? obj)
+		   (<= bound (length obj))
+		   (every predicate obj))))
+	   (else
+	    (lambda (obj)
+	      (and (list? obj)
+		   (<= (length obj) bound)
+		   (every predicate obj))))))
+    ((2)
+     (let ((low (car bound))
+	   (high (cadr bound)))
+       (cond ((or (negative? low) (negative? high)) (errout))
+	     ((< high low)
+	      (set! high (car bound))
+	      (set! low (cadr bound))))
+       (lambda (obj)
+	 (and (list? obj)
+	      (<= low (length obj) high)
+	      (every predicate obj)))))
+    (else (errout))))
+
+(define (comlist:find-if pred? lst)
+  (cond ((null? lst) #f)
+	((pred? (car lst)) (car lst))
+	(else (comlist:find-if pred? (cdr lst)))))
 
-(define (comlist:remove-if-not p l)
-  (cond ((null? l) l)
-	((p (car l)) (cons (car l) (comlist:remove-if-not p (cdr l))))
-	(else (comlist:remove-if-not p (cdr l)))))
+(define (comlist:member-if pred? lst)
+  (cond ((null? lst) #f)
+	((pred? (car lst)) lst)
+	(else (comlist:member-if pred? (cdr lst)))))
+
+(define (comlist:remove pred? lst)
+  (define head (list '*head*))
+  (let remove ((lst lst)
+	       (tail head))
+    (cond ((null? lst))
+	  ((eqv? pred? (car lst)) (remove (cdr lst) tail))
+	  (else
+	   (set-cdr! tail (list (car lst)))
+	   (remove (cdr lst) (cdr tail)))))
+  (cdr head))
+
+(define (comlist:remove-if pred? lst)
+  (let remove-if ((lst lst)
+		  (result '()))
+    (cond ((null? lst) (reverse result))
+	  ((pred? (car lst)) (remove-if (cdr lst) result))
+	  (else (remove-if (cdr lst) (cons (car lst) result))))))
+
+(define (comlist:remove-if-not pred? lst)
+  (let remove-if-not ((lst lst)
+		      (result '()))
+    (cond ((null? lst) (reverse result))
+	  ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
+	  (else (remove-if-not (cdr lst) result)))))
 
 (define comlist:nconc
   (if (provided? 'rev2-procedures) append!
@@ -141,26 +200,36 @@
   (comlist:nthcdr (- (length lst) n) lst))
 
 (define (comlist:butlast lst n)
-  (letrec ((l (- (length lst) n))
-	   (bl (lambda (lst n)
-		 (cond ((null? lst) lst)
-		       ((positive? n)
-			(cons (car lst) (bl (cdr lst) (+ -1 n))))
-		       (else '())))))
+  (letrec
+      ((len (- (length lst) n))
+       (bl (lambda (lst n)
+	     (let build-until-zero ((lst lst)
+				    (n n)
+				    (result '()))
+	       (cond ((null? lst) (reverse result))
+		     ((positive? n)
+		      (build-until-zero
+		       (cdr lst) (- n 1) (cons (car lst) result)))
+		     (else (reverse result)))))))
     (bl lst (if (negative? n)
 		(slib:error "negative argument to butlast" n)
-		l))))
+		len))))
 
 (define (comlist:nthcdr n lst)
   (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
 
 (define (comlist:butnthcdr n lst)
-  (letrec ((bn (lambda (lst n)
-		 (cond ((null? lst) lst)
-		       ((positive? n)
-			(cons (car lst) (bn (cdr lst) (+ -1 n))))
-		       (else '())))))
-    (bn lst (if (negative? n)
+  (letrec
+      ((bl (lambda (lst n)
+	     (let build-until-zero ((lst lst)
+				    (n n)
+				    (result '()))
+	       (cond ((null? lst) (reverse result))
+		     ((positive? n)
+		      (build-until-zero
+		       (cdr lst) (- n 1) (cons (car lst) result)))
+		     (else (reverse result)))))))
+    (bl lst (if (negative? n)
 		(slib:error "negative argument to butnthcdr" n)
 		n))))
 
@@ -186,129 +255,46 @@
 (define (comlist:remove-duplicates lst)
   (letrec ((rem-dup
 	    (lambda (lst nlst)
-	      (cond ((null? lst) nlst)
+	      (cond ((null? lst) (reverse nlst))
 		    ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
 		    (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
     (rem-dup lst '())))
 
-(define (comlist:list* x . y)
-  (define (list*1 x)
-    (if (null? (cdr x))
-	(car x)
-	(cons (car x) (list*1 (cdr x)))))
-  (if (null? y)
-      x
-      (cons x (list*1 y))))
-
-(define (comlist:atom? a)
-  (not (pair? a)))
-
-(define (type-of obj)
-  (cond
-   ((null? obj)		'null)
-   ((boolean? obj)	'boolean)
-   ((char? obj)		'char)
-   ((number? obj)	'number)
-   ((string? obj)	'string)
-   ((symbol? obj)	'symbol)
-   ((input-port? obj)	'port)
-   ((output-port? obj)	'port)
-   ((procedure? obj)	'procedure)
-   ((eof-object? obj)	'eof-object)
-   ((list? obj)		'list)
-   ((pair? obj)		'pair)
-   ((and (provided? 'array) (array? obj))	'array)
-   ((and (provided? 'record) (record? obj))	'record)
-   ((vector? obj)	'vector)
-   (else		'?)))
-
-(define (coerce obj result-type)
-  (define (err) (slib:error 'coerce "couldn't" obj '-> result-type))
-  (define obj-type (type-of obj))
-  (cond
-   ((eq? obj-type result-type) obj)
-   (else
-    (case obj-type
-      ((char)   (case result-type
-		  ((number integer) (char->integer obj))
-		  ((string) (string obj))
-		  ((symbol) (string->symbol (string obj)))
-		  ((list)   (list obj))
-		  ((vector) (vector obj))
-		  (else     (err))))
-      ((number) (case result-type
-		  ((char)   (integer->char obj))
-		  ((atom)   obj)
-		  ((integer) obj)
-		  ((string) (number->string obj))
-		  ((symbol) (string->symbol (number->string obj)))
-		  ((list)   (string->list (number->string obj)))
-		  ((vector) (list->vector (string->list (number->string obj))))
-		  (else     (err))))
-      ((string) (case result-type
-		  ((char)   (if (= 1 (string-length obj)) (string-ref obj 0)
-				(err)))
-		  ((atom)   (or (string->number obj) (string->symbol obj)))
-		  ((number integer) (or (string->number obj) (err)))
-		  ((symbol) (string->symbol obj))
-		  ((list)   (string->list obj))
-		  ((vector) (list->vector (string->list obj)))
-		  (else     (err))))
-      ((symbol) (case result-type
-		  ((char)   (coerce (symbol->string obj) 'char))
-		  ((number integer) (coerce (symbol->string obj) 'number))
-		  ((string) (symbol->string obj))
-		  ((atom)   obj)
-		  ((list)   (string->list (symbol->string obj)))
-		  ((vector) (list->vector (string->list (symbol->string obj))))
-		  (else     (err))))
-      ((list)   (case result-type
-		  ((char)   (if (and (= 1 (length obj))
-				     (char? (car obj)))
-				(car obj)
-				(err)))
-		  ((number integer)
-		   (or (string->number (list->string obj)) (err)))
-		  ((string) (list->string obj))
-		  ((symbol) (string->symbol (list->string obj)))
-		  ((vector) (list->vector obj))
-		  (else     (err))))
-      ((vector) (case result-type
-		  ((char)   (if (and (= 1 (vector-length obj))
-				     (char? (vector-ref obj 0)))
-				(vector-ref obj 0)
-				(err)))
-		  ((number integer)
-		   (or (string->number (coerce obj string)) (err)))
-		  ((string) (list->string (vector->list obj)))
-		  ((symbol) (string->symbol (coerce obj string)))
-		  ((list)   (list->vector obj))
-		  (else     (err))))
-      (else (err))))))
-
-(define (comlist:delete obj list)
-  (let delete ((list list))
-    (cond ((null? list) '())
-	  ((equal? obj (car list)) (delete (cdr list)))
+(define (comlist:list* obj1 . obj2)
+  (define (list*1 obj)
+    (if (null? (cdr obj))
+	(car obj)
+	(cons (car obj) (list*1 (cdr obj)))))
+  (if (null? obj2)
+      obj1
+      (cons obj1 (list*1 obj2))))
+
+(define (comlist:atom? obj)
+  (not (pair? obj)))
+
+(define (comlist:delete obj lst)
+  (let delete ((lst lst))
+    (cond ((null? lst) '())
+	  ((equal? obj (car lst)) (delete (cdr lst)))
 	  (else
-	   (set-cdr! list (delete (cdr list)))
-	   list))))
+	   (set-cdr! lst (delete (cdr lst)))
+	   lst))))
 
-(define (comlist:delete-if pred list)
-  (let delete-if ((list list))
-    (cond ((null? list) '())
-	  ((pred (car list)) (delete-if (cdr list)))
+(define (comlist:delete-if pred lst)
+  (let delete-if ((lst lst))
+    (cond ((null? lst) '())
+	  ((pred (car lst)) (delete-if (cdr lst)))
 	  (else
-	   (set-cdr! list (delete-if (cdr list)))
-	   list))))
+	   (set-cdr! lst (delete-if (cdr lst)))
+	   lst))))
 
-(define (comlist:delete-if-not pred list)
-  (let delete-if ((list list))
-    (cond ((null? list) '())
-	  ((not (pred (car list))) (delete-if (cdr list)))
+(define (comlist:delete-if-not pred lst)
+  (let delete-if ((lst lst))
+    (cond ((null? lst) '())
+	  ((not (pred (car lst))) (delete-if (cdr lst)))
 	  (else
-	   (set-cdr! list (delete-if (cdr list)))
-	   list))))
+	   (set-cdr! lst (delete-if (cdr lst)))
+	   lst))))
 
 ;;; exports
 
@@ -348,3 +334,4 @@
 (define atom comlist:atom?)
 (define atom? comlist:atom?)
 (define list* comlist:list*)
+(define list-of?? comlist:list-of??)