| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168 |
- ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
- ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
- ; This is file util.scm.
- ;;;; Utilities
- (define (unspecific) (if #f #f))
- (define (reduce cons nil list) ;used by length, append, etc.
- (if (null? list)
- nil
- (cons (car list) (reduce cons nil (cdr list)))))
- (define (filter pred lst)
- (reduce (lambda (x rest)
- (if (pred x) (cons x rest) rest))
- '()
- lst))
- ; Position of an object within a list
- (define (pos pred)
- (lambda (thing l)
- (let loop ((i 0) (l l))
- (cond ((null? l) #f)
- ((pred thing (car l)) i)
- (else (loop (+ i 1) (cdr l)))))))
- (define posq (pos eq?))
- (define posv (pos eqv?))
- (define posqual (pos equal?))
- ; Is pred true of any element of l?
- (define (any pred l)
- ;; (reduce or #f l), sort of
- (if (null? l)
- #f
- (or (pred (car l))
- (any pred (cdr l)))))
- ; Is pred true of every element of l?
- (define (every pred l)
- ;; (reduce and #t l), sort of
- (if (null? l)
- #t
- (and (pred (car l)) (every pred (cdr l)))))
- (define (sublist l start end)
- (if (> start 0)
- (sublist (cdr l) (- start 1) (- end 1))
- (let recur ((l l) (end end))
- (if (= end 0)
- '()
- (cons (car l) (recur (cdr l) (- end 1)))))))
- (define (last x)
- (if (null? (cdr x))
- (car x)
- (last (cdr x))))
- (define (insert x l <)
- (cond ((null? l) (list x))
- ((< x (car l)) (cons x l))
- (else (cons (car l) (insert x (cdr l) <)))))
- (define (symbol-append . syms)
- (string->symbol (apply string-append
- (map symbol->string syms))))
- ;----------------
- ; Variations on a theme.
- ;
- ; FOLD is a tail-recursive version of REDUCE.
- (define (fold folder list accumulator)
- (do ((list list (cdr list))
- (accum accumulator (folder (car list) accum)))
- ((null? list)
- accum)))
- (define (fold->2 folder list acc0 acc1)
- (let loop ((list list) (acc0 acc0) (acc1 acc1))
- (if (null? list)
- (values acc0 acc1)
- (call-with-values
- (lambda ()
- (folder (car list) acc0 acc1))
- (lambda (acc0 acc1)
- (loop (cdr list) acc0 acc1))))))
- (define (fold->3 folder list acc0 acc1 acc2)
- (let loop ((list list) (acc0 acc0) (acc1 acc1) (acc2 acc2))
- (if (null? list)
- (values acc0 acc1 acc2)
- (call-with-values
- (lambda ()
- (folder (car list) acc0 acc1 acc2))
- (lambda (acc0 acc1 acc2)
- (loop (cdr list) acc0 acc1 acc2))))))
- ;----------------
- ; A version of LET and LET* which allows clauses that return multiple values.
- ;
- ; There is another copy of this in big/mvlet.scm.
- ;
- ; MV = multiple-value
- ;
- ; (mvlet (<clause> ...) <body>)
- ; (mvlet* (<clause> ...) <body>)
- ;
- ; <clause> ::= (<ids> <expression>)
- ; <ids> ::= <id> | (<id> ...) | (<id> ... . <id>)
- ;
- ; A clause of the form (<id> <exp>) is like a normal LET clause. There is no
- ; clause equivalent to
- ; (call-with-values (lambda () <expression>)
- ; (lambda <id> <body>))
- (define-syntax mvlet
- (syntax-rules ()
- ((mvlet () body ...)
- (let () body ...))
- ((mvlet (clause ...) body ...)
- (mvlet-helper (clause ...) () (body ...)))))
- (define-syntax mvlet-helper
- (syntax-rules ()
- ((mvlet-helper () clauses (body ...))
- (let clauses body ...))
- ((mvlet-helper (((var . more-vars) val) more ...) clauses body)
- (copy-vars (var . more-vars) () val (more ...) clauses body))
- ((mvlet-helper ((var val) more ...) clauses body)
- (mvlet-helper (more ...) ((var val) . clauses) body))))
- (define-syntax copy-vars
- (syntax-rules ()
- ((copy-vars (var . more-vars) (copies ...)
- val more clauses body)
- (copy-vars more-vars (copies ... x)
- val more ((var x) . clauses) body))
- ((copy-vars () copies val more clauses body)
- (call-with-values
- (lambda () val)
- (lambda copies
- (mvlet-helper more clauses body))))
- ((copy-vars last (copies ...) val more clauses body)
- (call-with-values
- (lambda () val)
- (lambda (copies ... . lastx)
- (mvlet-helper more ((last lastx) . clauses) body))))))
- (define-syntax mvlet*
- (syntax-rules ()
- ((mvlet* () body ...)
- (let () body ...))
- ((mvlet* (((vars ...) val) clause ...) body ...)
- (call-with-values
- (lambda () val)
- (lambda (vars ...)
- (mvlet (clause ...) body ...))))
- ((mvlet* ((var val) clause ...) body ...)
- (let ((var val)) (mvlet (clause ...) body ...)))))
|
