blob: 6ec8496d9d6edc24061f28f5b0f71a30e9d6063d (
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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BASE.plt - common routines that are shared by all other bzlib modules
;;
;; in a way, base.plt is the most fundamental module of the whole bzlib stack
;; and as such it also is the lowest level code. We are not likely to
;; fix the code any time soon, and hence any of the functions here are
;; explicitly likely to be obsoleted or moved elsewhere.
;;
;; Proceed with caution.
;;
;;
;; Bonzai Lab, LLC. All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; base.ss - basic functionalities that do not belong anywhere else.
;; yc 9/8/2009 - first version
;; yc 9/25/2009 - moved assert! & let/assert! to assert.ss
;; yc 1/12/2010 - add let*/if
;; yc 2/5/2010 - add define-case-test & case/equal? & case/string-ci=?
;; yc 2/13/2010 - add isa/c
(require (for-syntax scheme/base)
scheme/list
scheme/port
mzlib/etc
mzlib/trace
scheme/contract
scheme/function
)
(define-syntax (trace-lambda stx)
(syntax-case stx ()
((~ args exp exp2 ...)
#'(letrec ((func
(lambda args exp exp2 ...)))
(trace func)
func))))
(define-syntax (if-it stx)
(syntax-case stx ()
[(src-if-it test then else)
(syntax-case (datum->syntax (syntax src-if-it) 'it) ()
[it (syntax (let ([it test]) (if it then else)))])]))
(define-syntax (when-it stx)
(syntax-case stx ()
((~ test? exp exp2 ...)
(with-syntax ((it (datum->syntax #'~ 'it)))
#'(let ((it test?)) (when it exp exp2 ...))))))
(define-syntax (cond-it stx)
(syntax-case stx (else)
((cond-it (else exp exp2 ...))
#'(begin exp exp2 ...))
((cond-it (test? exp exp2 ...))
(with-syntax ((it (datum->syntax #'cond-it 'it)))
#'(let ((it test?)) (when it exp exp2 ...))))
((cond-it (test? exp exp2 ...) cond cond2 ...)
(with-syntax ((it (datum->syntax #'cond-it 'it)))
#'(let ((it test?))
(if it (begin exp exp2 ...)
(cond-it cond cond2 ...)))))))
(define-syntax while
(syntax-rules ()
((while test exp exp2 ...)
(let loop ()
(when test
exp exp2 ...
(loop))))
))
(define-syntax let*/if
(syntax-rules ()
((~ ((arg val)) exp exp2 ...)
(let ((arg val))
(if (not arg)
#f
(begin exp exp2 ...))))
((~ ((arg val) (arg-rest val-rest) ...) exp exp2 ...)
(let ((arg val))
(if (not arg)
#f
(let*/if ((arg-rest val-rest) ...) exp exp2 ...))))))
(define-syntax case/pred?
(syntax-rules (else)
((~ pred? (else exp exp2 ...))
(begin exp exp2 ...))
((~ pred? ((d d2 ...) exp exp2 ...))
(when (ormap pred? (list d d2 ...))
exp exp2 ...))
((~ pred? ((d d2 ...) exp exp2 ...) rest ...)
(if (ormap pred? (list d d2 ...))
(begin exp exp2 ...)
(case/pred? pred? rest ...)))))
(define-syntax define-case/test?
(syntax-rules ()
((~ name test?)
(define-syntax name
(syntax-rules ()
((~ v clause clause2 (... ...))
(case/pred? (curry test? v) clause clause2 (... ...)))))
)))
(define-case/test? case/equal? equal?)
(define-case/test? case/string-ci=? string-ci=?)
;;|#
;; (trace load-proc)
;; a generic version of apply & keyword-apply that requires
;; no sorting of the parameter args...
(define (apply* proc . args)
(define (filter-kws args (acc '()))
(cond ((null? args) (reverse acc))
((keyword? (car args))
(filter-kws (cdr args) (cons (car args) acc)))
(else
(filter-kws (cdr args) acc))))
(define (filter-kw-vals args (acc '()))
(cond ((null? args) (reverse acc))
((keyword? (car args))
(if (null? (cdr args)) ;; this is wrong!!!
(error 'kw-apply "keyword ~a not followed by a value" (car args))
(filter-kw-vals (cddr args) (cons (cadr args) acc))))
(else
(filter-kw-vals (cdr args) acc))))
(define (filter-non-kw-vals args (acc '()))
(cond ((null? args) (reverse acc))
((keyword? (car args))
(if (null? (cdr args))
(error 'kw-apply "keyword ~a not followed by a value" (car args))
(filter-non-kw-vals (cddr args) acc)))
(else
(filter-non-kw-vals (cdr args) (cons (car args) acc)))))
(define (sorted-kw+args args)
(let ((kw+args (sort (map (lambda (kw vals)
(cons kw vals))
(filter-kws args)
(filter-kw-vals args))
(lambda (kv kv1)
(keyword<? (car kv) (car kv1))))))
(values (map car kw+args) (map cdr kw+args))))
(define (normalize-args args)
(cond ((list? (last args))
(apply list* args))
(else (error 'apply* "Expect last arg as a list, given ~a" (last args)))))
(let ((args (normalize-args args)))
(let-values (((kws vals)
(sorted-kw+args args)))
(keyword-apply proc kws vals
(filter-non-kw-vals args)))))
(define (value-or v (default #f))
(if (not v) default v))
(define (null-or v (default #f))
(if (null? v) default v))
(define (thunk? p)
(and (procedure? p)
(let ((a (procedure-arity p)))
(cond ((arity-at-least? a)
(= (arity-at-least-value a) 0))
((number? a) (= a 0))
((list? a) (member 0 a))))))
;; isa/c
;; this is useful but I did not include it until a bit too late... hmm...
(define isa/c (-> any/c any))
(define (typeof/c contract)
(-> contract any))
(provide (all-from-out mzlib/etc
scheme/function
)
trace-lambda
if-it
when-it
cond-it
while
let*/if
case/pred?
define-case/test?
case/equal?
case/string-ci=?
isa/c
typeof/c
)
(provide/contract
(apply* (->* (procedure?)
()
#:rest (listof any/c)
any))
(value-or (->* (any/c)
(any/c)
any))
(null-or (->* (any/c)
(any/c)
any))
(thunk? (-> any/c boolean?))
)
|
