summaryrefslogtreecommitdiffstats
path: root/comlist.scm
diff options
context:
space:
mode:
Diffstat (limited to 'comlist.scm')
-rw-r--r--comlist.scm375
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??)