291 lines
7.3 KiB
Scheme
291 lines
7.3 KiB
Scheme
;;; Random useful utilities.
|
|
;;; Copyright (c) 1993 by Olin Shivers.
|
|
|
|
(define (del elt lis)
|
|
(letrec ((del (lambda (lis)
|
|
(if (pair? lis)
|
|
(let* ((head (car lis))
|
|
(tail (cdr lis))
|
|
(new-tail (del tail)))
|
|
(if (equal? head elt) new-tail
|
|
(if (eq? tail new-tail) lis
|
|
(cons head new-tail))))
|
|
'()))))
|
|
(del lis)))
|
|
|
|
(define (delete pred lis)
|
|
(filter (lambda (x) (not (pred x))) lis))
|
|
|
|
(define (index str c . maybe-start)
|
|
(let ((start (max 0 (:optional maybe-start 0)))
|
|
(len (string-length str)))
|
|
(do ((i start (+ 1 i)))
|
|
((or (>= i len)
|
|
(char=? c (string-ref str i)))
|
|
(and (< i len) i)))))
|
|
|
|
(define (rindex str c . maybe-start)
|
|
(let* ((len (string-length str))
|
|
(start (min (:optional maybe-start len)
|
|
len)))
|
|
(do ((i (- start 1) (- i 1)))
|
|
((or (< i 0)
|
|
(char=? c (string-ref str i)))
|
|
(and (>= i 0) i)))))
|
|
|
|
;;; (f (f (f zero x1) x2) x3)
|
|
;;; [Richard's does (f x3 (f x2 (f x1 zero)))
|
|
(define (reduce f zero l)
|
|
(letrec ((lp (lambda (val rest)
|
|
(if (pair? rest) (lp (f val (car rest)) (cdr rest))
|
|
val))))
|
|
(lp zero l)))
|
|
|
|
(define (fold kons knil lis)
|
|
(let lp ((lis lis) (ans knil))
|
|
(if (pair? lis)
|
|
(lp (cdr lis) (kons (car lis) ans))
|
|
ans)))
|
|
|
|
(define (fold-right kons knil lis)
|
|
(let recur ((lis lis))
|
|
(if (pair? lis)
|
|
(let ((head (car lis))) ; Won't need LIS after RECUR call.
|
|
(kons head (recur (cdr lis))))
|
|
knil)))
|
|
|
|
(define (filter pred list)
|
|
(letrec ((filter (lambda (list)
|
|
(if (pair? list)
|
|
(let* ((head (car list))
|
|
(tail (cdr list))
|
|
(new-tail (filter tail)))
|
|
(if (pred head)
|
|
(if (eq? tail new-tail) list
|
|
(cons head new-tail))
|
|
new-tail))
|
|
'()))))
|
|
(filter list)))
|
|
|
|
(define (first pred list)
|
|
(letrec ((lp (lambda (list)
|
|
(and (pair? list)
|
|
(let ((head (car list)))
|
|
(if (pred head) head
|
|
(lp (cdr list))))))))
|
|
(lp list)))
|
|
|
|
(define any first)
|
|
|
|
;;; Returns the first true value produced by PRED, not the list element
|
|
;;; that satisfied PRED.
|
|
|
|
(define (first? pred list)
|
|
(letrec ((lp (lambda (list)
|
|
(and (pair? list)
|
|
(or (pred (car list))
|
|
(lp (cdr list)))))))
|
|
(lp list)))
|
|
|
|
(define any? first?)
|
|
|
|
|
|
(define (every pred list)
|
|
(or (not (pair? list))
|
|
(let lp ((head (car list)) (tail (cdr list)))
|
|
(if (pair? tail)
|
|
(and (pred head) (lp (car tail) (cdr tail)))
|
|
(pred head))))) ; Tail-call the last PRED call.
|
|
|
|
|
|
(define (every? pred list)
|
|
(letrec ((lp (lambda (list)
|
|
(or (not (pair? list))
|
|
(and (pred (car list))
|
|
(lp (cdr list)))))))
|
|
(lp list)))
|
|
|
|
(define (mapv f v)
|
|
(let* ((len (vector-length v))
|
|
(ans (make-vector len)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) ans)
|
|
(vector-set! ans i (f (vector-ref v i))))))
|
|
|
|
(define (mapv! f v)
|
|
(let ((len (vector-length v)))
|
|
(do ((i 0 (+ i 1)))
|
|
((= i len) v)
|
|
(vector-set! v i (f (vector-ref v i))))))
|
|
|
|
(define (vector-every? pred v)
|
|
(let lp ((i (- (vector-length v) 1)))
|
|
(or (< i 0)
|
|
(and (pred (vector-ref v i))
|
|
(lp (- i 1))))))
|
|
|
|
(define (copy-vector v)
|
|
(let* ((len (vector-length v))
|
|
(ans (make-vector len)))
|
|
(do ((i (- len 1) (- i 1)))
|
|
((< i 0) ans)
|
|
(vector-set! ans i (vector-ref v i)))))
|
|
|
|
(define (initialize-vector len init)
|
|
(let ((v (make-vector len)))
|
|
(do ((i (- len 1) (- i 1)))
|
|
((< i 0) v)
|
|
(vector-set! v i (init i)))))
|
|
|
|
(define (vector-append . vecs)
|
|
(let* ((vlen (fold (lambda (v len) (+ (vector-length v) len)) 0 vecs))
|
|
(ans (make-vector vlen)))
|
|
(let lp1 ((vecs vecs) (to 0))
|
|
(if (pair? vecs)
|
|
(let* ((vec (car vecs))
|
|
(len (vector-length vec)))
|
|
(let lp2 ((from 0) (to to))
|
|
(cond ((< from len)
|
|
(vector-set! ans to (vector-ref vec from))
|
|
(lp2 (+ from 1) (+ to 1)))
|
|
(else (lp1 (cdr vecs) to)))))))
|
|
ans))
|
|
|
|
|
|
(define (vfold kons knil v)
|
|
(let ((len (vector-length v)))
|
|
(do ((i 0 (+ i 1))
|
|
(ans knil (kons (vector-ref v i) ans)))
|
|
((>= i len) ans))))
|
|
|
|
(define (vfold-right kons knil v)
|
|
(do ((i (- (vector-length v) 1) (- i 1))
|
|
(ans knil (kons (vector-ref v i) ans)))
|
|
((< i 0) ans)))
|
|
|
|
|
|
;;; We loophole the call to ERROR -- the point is that perhaps the
|
|
;;; user will interact with a breakpoint, and proceed with a new
|
|
;;; value, which we will then pass to a new invocation of CHECK-ARG
|
|
;;; for approval.
|
|
(define (check-arg pred val caller)
|
|
(if (pred val) val
|
|
(check-arg pred (error "Bad argument" val pred caller) caller)))
|
|
|
|
(define (conjoin f g)
|
|
(lambda args (and (apply f args) (apply g args))))
|
|
|
|
(define (disjoin f g)
|
|
(lambda args (or (apply f args) (apply g args))))
|
|
|
|
(define (negate f) (lambda args (not (apply f args))))
|
|
|
|
(define (compose f g)
|
|
(lambda args (call-with-values (lambda () (apply g args)) f)))
|
|
|
|
|
|
(define (reverse! lis)
|
|
(let lp ((lis lis) (prev '()))
|
|
(if (not (pair? lis)) prev
|
|
(let ((tail (cdr lis)))
|
|
(set-cdr! lis prev)
|
|
(lp tail lis)))))
|
|
|
|
(define call/cc call-with-current-continuation)
|
|
|
|
(define (deposit-bit-field bits mask field)
|
|
(bitwise-ior (bitwise-and field mask)
|
|
(bitwise-and bits (bitwise-not mask))))
|
|
|
|
|
|
(define (nth lis i)
|
|
(if (< i 0) (error "nth: illegal list index" i)
|
|
(let lp ((l lis) (i i))
|
|
(if (pair? l)
|
|
(if (zero? i) (car l)
|
|
(lp (cdr l) (- i 1)))
|
|
(error "nth: index too large" lis i)))))
|
|
|
|
|
|
(define (deprecated-proc proc name . maybe-preferred-msg)
|
|
(let ((warned? #f))
|
|
(lambda args
|
|
(cond ((not warned?)
|
|
(set! warned? #t)
|
|
(apply warn
|
|
"Deprecated procedure (may not be supported in a future release)"
|
|
name
|
|
maybe-preferred-msg)))
|
|
(apply proc args))))
|
|
|
|
|
|
(define (real->exact-integer x)
|
|
(let ((f (round x)))
|
|
(if (inexact? f) (inexact->exact f) f)))
|
|
|
|
|
|
;;; Copy string SOURCE into TARGET[start,...]
|
|
|
|
(define (string-replace! target start source)
|
|
(let ((len (string-length source)))
|
|
(do ((i (+ start len -1) (- i 1))
|
|
(j (- len 1) (- j 1)))
|
|
((< j 0) target)
|
|
(string-set! target i (string-ref source j)))))
|
|
|
|
|
|
;;; Copy SOURCE[source-start, source-end) into TARGET[start,)
|
|
|
|
(define (substring-replace! target start source source-start source-end)
|
|
(do ((i (+ start (- source-end source-start) -1) (- i 1))
|
|
(j (- source-end 1) (- j 1)))
|
|
((< j source-start) target)
|
|
(string-set! target i (string-ref source j))))
|
|
|
|
|
|
;;; Compute (... (f (f (f zero c0) c1) c2) ...)
|
|
|
|
(define (string-reduce f zero s)
|
|
(let ((len (string-length s)))
|
|
(let lp ((v zero) (i 0))
|
|
(if (= i len)
|
|
v
|
|
(lp (f v (string-ref s i)) (+ i 1))))))
|
|
;----------------
|
|
; A record type whose only purpose is to run some code when we start up an
|
|
; image.
|
|
|
|
(define-record-type reinitializer :reinitializer
|
|
(make-reinitializer thunk)
|
|
reinitializer?
|
|
(thunk reinitializer-thunk))
|
|
|
|
(define-record-discloser :reinitializer
|
|
(lambda (r)
|
|
(list 'reinitializer (reinitializer-thunk r))))
|
|
|
|
(define-record-resumer :reinitializer
|
|
(lambda (r)
|
|
((reinitializer-thunk r))))
|
|
|
|
;--------------
|
|
; Run thunk1 until thunk2 escapes
|
|
; This is *extremly* low level
|
|
; Don't use unless you know what you are doing
|
|
|
|
(define (run-as-long-as thunk1 thunk2 . name)
|
|
(let ((thread (make-placeholder)))
|
|
(apply spawn (lambda ()
|
|
(placeholder-set! thread (current-thread))
|
|
(thunk1))
|
|
name)
|
|
(dynamic-wind
|
|
(lambda () #t)
|
|
thunk2
|
|
(lambda ()
|
|
(remove-thread-from-queues! (placeholder-value thread))
|
|
(kill-thread! (placeholder-value thread))
|
|
(make-ready (placeholder-value thread))))))
|
|
|
|
|
|
|