blob: fe407a2986f590ddd2bf4587634335fca8318a52 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
;;; (boudin util) --- utility functions
(define-library (boudin util)
(import (scheme base)
(scheme case-lambda)
(scheme eval))
(export identity
o
constantly
assoc-ref
slurp
eval/q
intersperse
string-intersperse)
(begin
(define (identity x) x)
(define (o . procs) ; stole from chicken core
(if (null? procs)
identity
(let loop ((procs procs))
(let ((h (car procs))
(t (cdr procs)))
(if (null? t)
h
(lambda (x) (h ((loop t) x))))))))
(define (constantly x)
(lambda _ x))
(define assoc-ref
(case-lambda
((key alist)
(assoc-ref alist
key
(lambda () (error "Unrecognized key." key))))
((key alist failure)
(cond ((assoc key alist) => cdr)
(else (failure))))))
(define slurp
(case-lambda
(() (slurp (current-input-port)))
((port)
(let loop ((ch (read-char))
(acc '()))
(if (eof-object? ch)
(list->string (reverse acc))
(loop (read-char) (cons ch acc)))))))
(define (eval/q form env) ; this is probably a bad idea
(eval (list 'quasiquote form) env))
(define (intersperse xs delim)
(if (null? xs)
'()
(let loop ((acc (list (car xs)))
(rest (cdr xs)))
(if (null? rest)
(reverse acc)
(loop (cons (car rest) (cons delim acc))
(cdr rest))))))
(define (string-intersperse ss delim)
(apply string-append (intersperse ss delim)))
(define index
(case-lambda
((xs needle)
(index xs needle eq? (constantly #f)))
((xs needle comparator)
(index xs needle comparator (constantly #f)))
((xs needle comparator fail)
(let loop ((i 0)
(xs xs))
(cond
((null? xs) (fail))
((comparator (car xs) needle) i)
(else (loop (+ i 1) (cdr xs))))))))
(define (string-index str ch)
(index (string->list str) ch))
))
|
