higher-order procedures."
(cons a d))
-;; internal helper, similar to (scsh utilities) check-arg.
-(define (check-arg-type pred arg caller)
- (if (pred arg)
- arg
- (scm-error 'wrong-type-arg caller
- "Wrong type argument: ~S" (list arg) '())))
+(define (wrong-type-arg caller arg)
+ (scm-error 'wrong-type-arg (symbol->string caller)
+ "Wrong type argument: ~S" (list arg) '()))
+
+(define-syntax-rule (check-arg pred arg caller)
+ (if (not (pred arg))
+ (wrong-type-arg 'caller arg)))
(define (out-of-range proc arg)
(scm-error 'out-of-range proc
"Return an N-element list, where each list element is produced by applying the
procedure INIT-PROC to the corresponding list index. The order in which
INIT-PROC is applied to the indices is not specified."
- (check-arg-type non-negative-integer? n "list-tabulate")
+ (check-arg non-negative-integer? n list-tabulate)
(let lp ((n n) (acc '()))
(if (<= n 0)
acc
elts)
(define* (iota count #:optional (start 0) (step 1))
- (check-arg-type non-negative-integer? count "iota")
+ (check-arg non-negative-integer? count iota)
(let lp ((n 0) (acc '()))
(if (= n count)
(reverse! acc)
(else
(and (elt= (car a) (car b))
(lp (cdr a) (cdr b)))))))
+
+ (check-arg procedure? elt= list=)
(or (null? rest)
(let lp ((lists rest))
(or (null? (cdr lists))
(define (fold kons knil list1 . rest)
"Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
that result. See the manual for details."
+ (check-arg procedure? kons fold)
(if (null? rest)
(let f ((knil knil) (list1 list1))
(if (null? list1)
(f (apply kons (append! cars (list knil))) cdrs))))))
(define (fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons fold-right)
(if (null? rest)
(let loop ((lst (reverse clist1))
(result knil))
(apply kons (append! (map car lists) (list result))))))))
(define (pair-fold kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold)
(if (null? rest)
(let f ((knil knil) (list1 clist1))
(if (null? list1)
(define (pair-fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold-right)
(if (null? rest)
(let f ((list1 clist1))
(if (null? list1)
(loop (cdr lst)
(cons (car lst) result)))))
+ (check-arg procedure? p unfold)
+ (check-arg procedure? f unfold)
+ (check-arg procedure? g unfold)
+ (check-arg procedure? tail-gen unfold)
(let loop ((seed seed)
(result '()))
(if (p seed)
(cons (f seed) result)))))
(define* (unfold-right p f g seed #:optional (tail '()))
+ (check-arg procedure? p unfold-right)
+ (check-arg procedure? f unfold-right)
+ (check-arg procedure? g unfold-right)
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
elements from LST, rather than one element and a given initial value.
If LST is empty, RIDENTITY is returned. If LST has just one element
then that's the return value."
+ (check-arg procedure? f reduce)
(if (null? lst)
ridentity
(fold f (car lst) (cdr lst))))
F is on two elements from LST, rather than one element and a given
initial value. If LST is empty, RIDENTITY is returned. If LST
has just one element then that's the return value."
+ (check-arg procedure? f reduce)
(if (null? lst)
ridentity
(fold-right f (last lst) (drop-right lst 1))))
(define map
(case-lambda
((f l)
+ (check-arg procedure? f map)
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
(if (pair? hare)
(if move?
(list l) #f)))))
((f l1 . rest)
+ (check-arg procedure? f map)
(let ((len (fold (lambda (ls len)
(let ((ls-len (length+ ls)))
(if len
(define for-each
(case-lambda
((f l)
+ (check-arg procedure? f for-each)
(let for-each1 ((hare l) (tortoise l) (move? #f))
(if (pair? hare)
(if move?
(list l) #f)))))
((f l1 . rest)
+ (check-arg procedure? f for-each)
(let ((len (fold (lambda (ls len)
(let ((ls-len (length+ ls)))
(if len
(define map! map)
(define (filter-map proc list1 . rest)
- "Apply PROC to to the elements of LIST1... and return a list of the
+ "Apply PROC to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
+ (check-arg procedure? proc filter-map)
(if (null? rest)
(let lp ((l list1)
(rl '()))
(lp (map cdr l) rl)))))))
(define (pair-for-each f clist1 . rest)
+ (check-arg procedure? f pair-for-each)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
(define (take-while pred ls)
"Return a new list which is the longest initial prefix of LS whose
elements all satisfy the predicate PRED."
+ (check-arg procedure? pred take-while)
(cond ((null? ls) '())
((not (pred (car ls))) '())
(else
(define (take-while! pred lst)
"Linear-update variant of `take-while'."
+ (check-arg procedure? pred take-while!)
(let loop ((prev #f)
(rest lst))
(cond ((null? rest)
(define (drop-while pred lst)
"Drop the longest initial prefix of LST whose elements all satisfy the
predicate PRED."
+ (check-arg procedure? pred drop-while)
(let loop ((lst lst))
(cond ((null? lst)
'())
(define (span pred lst)
"Return two values, the longest initial prefix of LST whose elements
all satisfy the predicate PRED, and the remainder of LST."
+ (check-arg procedure? pred span)
(let lp ((lst lst) (rl '()))
(if (and (not (null? lst))
(pred (car lst)))
(define (span! pred list)
"Linear-update variant of `span'."
+ (check-arg procedure? pred span!)
(let loop ((prev #f)
(rest list))
(cond ((null? rest)
(define (break pred clist)
"Return two values, the longest initial prefix of LST whose elements
all fail the predicate PRED, and the remainder of LST."
+ (check-arg procedure? pred break)
(let lp ((clist clist) (rl '()))
(if (or (null? clist)
(pred (car clist)))
(define (break! pred list)
"Linear-update variant of `break'."
+ (check-arg procedure? pred break!)
(let loop ((l list)
(prev #f))
(cond ((null? l)
(loop (cdr l) l)))))
(define (any pred ls . lists)
+ (check-arg procedure? pred any)
(if (null? lists)
(any1 pred ls)
(let lp ((lists (cons ls lists)))
(or (pred (car ls)) (lp (cdr ls)))))))
(define (every pred ls . lists)
+ (check-arg procedure? pred every)
(if (null? lists)
(every1 pred ls)
(let lp ((lists (cons ls lists)))
(define (list-index pred clist1 . rest)
"Return the index of the first set of elements, one from each of
CLIST1 ... CLISTN, that satisfies PRED."
+ (check-arg procedure? pred list-index)
(if (null? rest)
(let lp ((l clist1) (i 0))
(if (null? l)
(lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
(define* (alist-delete key alist #:optional (k= equal?))
+ (check-arg procedure? k= alist-delete)
(let lp ((a alist) (rl '()))
(if (null? a)
(reverse! rl)
(define* (member x ls #:optional (= equal?))
(cond
- ((eq? = eq?) (memq x ls))
+ ;; This might be performance-sensitive, so punt on the check here,
+ ;; relying on memq/memv to check that = is a procedure.
+ ((eq? = eq?) (memq x ls))
((eq? = eqv?) (memv x ls))
- (else (find-tail (lambda (y) (= x y)) ls))))
+ (else
+ (check-arg procedure? = member)
+ (find-tail (lambda (y) (= x y)) ls))))
;;; Set operations on lists
(define (lset<= = . rest)
+ (check-arg procedure? = lset<=)
(if (null? rest)
#t
(let lp ((f (car rest)) (r (cdr rest)))
(lp (car r) (cdr r)))))))
(define (lset= = . rest)
+ (check-arg procedure? = lset<=)
(if (null? rest)
#t
(let lp ((f (car rest)) (r (cdr rest)))
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
- (lambda (x y) (= y x))))
+ (begin
+ (check-arg procedure? = lset-adjoin)
+ (lambda (x y) (= y x)))))
(let lp ((ans list) (rest rest))
(if (null? rest)
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
- (lambda (x y) (= y x))))
+ (begin
+ (check-arg procedure? = lset-union)
+ (lambda (x y) (= y x)))))
(fold (lambda (lis ans) ; Compute ANS + LIS.
(cond ((null? lis) ans) ; Don't copy any lists
rest))
(define (lset-intersection = list1 . rest)
+ (check-arg procedure? = lset-intersection)
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
(lp (cdr l) acc)))))
(define (lset-difference = list1 . rest)
+ (check-arg procedure? = lset-difference)
(if (null? rest)
list1
(let lp ((l list1) (acc '()))
;(define (fold kons knil list1 . rest)
(define (lset-xor = . rest)
+ (check-arg procedure? = lset-xor)
(fold (lambda (lst res)
(let lp ((l lst) (acc '()))
(if (null? l)
rest))
(define (lset-diff+intersection = list1 . rest)
+ (check-arg procedure? = lset-diff+intersection)
(let lp ((l list1) (accd '()) (acci '()))
(if (null? l)
(values (reverse! accd) (reverse! acci))
(define (lset-union! = . rest)
+ (check-arg procedure? = lset-union!)
(apply lset-union = rest)) ; XXX:optimize
(define (lset-intersection! = list1 . rest)
+ (check-arg procedure? = lset-intersection!)
(apply lset-intersection = list1 rest)) ; XXX:optimize
(define (lset-xor! = . rest)
+ (check-arg procedure? = lset-xor!)
(apply lset-xor = rest)) ; XXX:optimize
(define (lset-diff+intersection! = list1 . rest)
+ (check-arg procedure? = lset-diff+intersection!)
(apply lset-diff+intersection = list1 rest)) ; XXX:optimize
;;; srfi-1.scm ends here