source: project/release/4/miscmacros/trunk/miscmacros.scm @ 30673

Last change on this file since 30673 was 30673, checked in by Alaric Snell-Pym, 6 years ago

Added (cond-list (<cond> <expr>)...) macro

File size: 8.3 KB
Line 
1;;;; miscmacros.scm
2
3(module miscmacros
4  (modify-location
5   let/cc until
6   repeat while repeat* if* while*
7   dotimes push! pop! inc! dec! exchange! modify!
8   begin0
9   define-optionals define-parameter define-enum
10   ignore-values ignore-errors
11   ecase
12   define-syntax-rule
13   cond-list)
14
15  (import scheme)
16  ;; No effect -- caller must import these manually.
17  (import (only chicken
18                when unless handle-exceptions let-optionals make-parameter
19                add1 sub1))
20
21;;; Modify locations, T-like:
22
23;; syntax-case implementation -- unused
24;;   (define-syntax (modify-location x)
25;;     (syntax-case x ()
26;;       ((_ (loc ...) proc)
27;;        (with-syntax (((tmp ...) (generate-temporaries #'(loc ...))))
28;;          #'(let ((tmp loc) ...)
29;;              (proc (lambda () (tmp ...))
30;;                    (lambda (x) (set! (tmp ...) x)))) ) )
31;;       ((_ loc proc)
32;;        #'(proc (lambda () loc)
33;;                (lambda (x) (set! loc x)) ) ) ) )
34
35  (define-syntax modify-location
36    (lambda (f r c)
37      (##sys#check-syntax 'modify-location f '(_ _ _))
38      (let ((loc (cadr f))
39            (proc (caddr f))
40            (%lambda (r 'lambda))
41            (%set! (r 'set!))
42            (%let (r 'let))
43            (x (r 'x)))                 ; a temporary
44        (if (atom? loc)
45            `(,proc (,%lambda () ,loc)
46                    (,%lambda (,x) (,%set! ,loc ,x)))
47            (let ((tmps (map (lambda _ (r (gensym))) loc)))
48              `(,%let ,(map list tmps loc)
49                      (,proc (,%lambda () ,tmps)
50                             (,%lambda (,x) (,%set! ,tmps ,x)))))))))
51
52;; evaluates body with an explicit exit continuation
53;;
54  (define-syntax let/cc
55    (syntax-rules ()
56      ((let/cc k e0 e1 ...)
57       (call-with-current-continuation
58        (lambda (k) e0 e1 ...)))))
59
60;; loop while expression false
61;;
62  (define-syntax until
63    (syntax-rules ()
64      ((until test body ...)
65       (let loop ()
66         (unless test
67           body ...
68           (loop))))))
69
70  (define-syntax repeat
71    (syntax-rules ()
72      ((repeat n body ...)
73       (let loop ((i n))
74         (when (< 0 i)
75           body ...
76           (loop (sub1 i)))))))
77
78  (define-syntax while
79    (syntax-rules ()
80      ((while test body ...)
81       (let loop ()
82         (if test
83             (begin
84               body ...
85               (loop)))))))
86
87;; repeat*, if*, while*: versions which break hygiene to assign to 'it'
88(define-syntax repeat*
89  (lambda (f r c)
90    (##sys#check-syntax 'repeat* f '(_ _ . _))
91    (let ((loop (r 'loop))
92          (n (cadr f))
93          (body (cddr f)))
94      `(,(r 'let) ,loop ((it ,n))
95        (,(r 'when) (,(r '<) 0 it)
96         ,@body
97         (,loop (,(r '-) it 1)))))))
98
99(define-syntax if*
100  (lambda (f r c)
101    (##sys#check-syntax 'if* f '(_ _ _ . _))
102    (let ((x (cadr f))
103          (y (caddr f))
104          (z (cdddr f))
105          (var (r 'var)))
106      `(,(r 'let) ((,var ,x))
107        (,(r 'if) ,var
108         (,(r 'let) ((it ,var))
109          ,y)
110         ,@z)))))
111
112(define-syntax while*
113  (lambda (f r c)
114    (##sys#check-syntax 'while* f '(_ _ . _))
115    (let ((test (cadr f))
116          (body (cddr f)))
117      `(,(r 'let) ,(r 'loop) ()
118        (,(r 'if*) ,test
119         (,(r 'begin)
120          ,@body
121          (,(r 'loop)) ))))))
122
123;; repeat body n times, w/ countup n bound to v
124  (define-syntax dotimes
125    (syntax-rules ()
126      ((dotimes (v n) body ...)
127       (dotimes (v n (begin)) body ...))
128      ((dotimes (v n f) body ...)
129       (let loop ((v 0) (nv n))
130         (if (< v nv)
131             (begin
132               body ...
133               (loop (add1 v) nv))
134             f)))))
135
136  (define-syntax push!
137    (syntax-rules ()
138      ((push! x loc)
139       (modify-location loc
140                        (lambda (get set)
141                          (set (cons x (get))))))))
142
143  (define-syntax pop!
144    (syntax-rules ()
145      ((pop! loc)
146       (modify-location loc
147                        (lambda (get set)
148                          (let* ((var (get))
149                                 (var2 (car var)))
150                            (set (cdr var))
151                            var2))))))
152
153  (define-syntax inc!
154    (syntax-rules ()
155      ((inc! loc val)
156       (modify-location loc
157                        (lambda (get set)
158                          (let ((new (+ (get) val)))
159                            (set new)
160                            new))))
161      ((inc! loc) (inc! loc 1))))
162
163  (define-syntax dec!
164    (syntax-rules ()
165      ((dec! loc val)
166       (modify-location loc
167                        (lambda (get set)
168                          (let ((new (- (get) val)))
169                            (set new)
170                            new))))
171      ((dec! loc) (dec! loc 1))))
172
173  (define-syntax exchange!
174    (syntax-rules ()
175      ((exchange! x y)
176       (modify-location
177        x
178        (lambda (get1 set1)
179          (modify-location
180           y
181           (lambda (get2 set2)
182             (let ((tmp (get1)))
183               (set1 (get2))
184               (set2 tmp)))))))))
185
186  (define-syntax modify!
187    (syntax-rules ()
188      ((modify! loc proc)
189       (modify-location loc
190                        (lambda (get set)
191                          (set (proc (get))))))))
192
193  (define-syntax begin0
194    (syntax-rules ()
195      ((_ e0 e1 ...)
196       (##sys#call-with-values
197        (lambda () e0)
198        (lambda var
199          (begin
200            e1 ...
201            (apply ##sys#values var)))))))
202
203  (define-syntax define-optionals
204    (lambda (f r c)
205      (let ((vars (cadr f))
206            (args (caddr f)))
207        (##sys#check-syntax 'define-optionals f '(_ #(#(_ 2 2) 1) _))
208        `(,(r 'begin)
209          ,@(map (lambda (b) `(,(r 'define) ,(car b) #f)) vars)
210          ,(let ([aliases (map (lambda (b) (r (car b))) vars)])
211             `(,(r 'let-optionals) ,args
212               ,(map (lambda (b a) (cons a (cdr b))) vars aliases)
213               ,@(map (lambda (b a) `(,(r 'set!) ,(car b) ,a)) vars aliases) ) ) ))) )
214
215  (define-syntax define-parameter
216    (syntax-rules ()
217      ((define-parameter name value guard)
218       (define name (make-parameter value guard)))
219      ((define-parameter name value)
220       (define name (make-parameter value)))
221      ((define-parameter name)
222       (define name (make-parameter (void))))))
223
224  (define-syntax ignore-values
225    (syntax-rules ()
226      ((ignore-values exp)
227       (##sys#call-with-values (lambda () exp)
228                               (lambda _ (##sys#void))))))
229
230  (define-syntax ignore-errors
231    (syntax-rules ()
232      ((ignore-errors body ...)
233       (handle-exceptions _ #f body ...))))
234
235;;; The following is courtesy of Alex Shinn:
236
237  (define-syntax define-enum
238    (lambda (f r c)
239      (define (enumerate vars)
240        (let loop ((n 0) (enums '()) (vars vars))
241          (if (null? vars)
242              (reverse enums)
243              (let ((n (if (pair? (car vars))
244                           (cadar vars)
245                           n)))
246                (loop (+ n 1)
247                      (cons n enums)
248                      (cdr vars))))))
249      (##sys#check-syntax 'define-enum f '(_ _ _ . _))
250      (let ((->int (cadr f))
251            (->sym (caddr f))
252            (vars (cdddr f)))
253        (let ((ints (enumerate vars))
254              (vars (map (lambda (v) (if (pair? v) (car v) v)) vars)))
255          `(,(r 'begin)
256            ,@(map (lambda (x i)
257                     `(,(r 'define-constant) ,x ,i))
258                   vars ints)
259            (,(r 'define) (,->int ,(r 'sym))
260             (,(r 'case) ,(r 'sym)
261              ,@(map (lambda (x i)
262                       `((,x) ,i))
263                     vars ints)
264              (,(r 'else) #f)))
265            (,(r 'define) (,->sym ,(r 'int))
266             (,(r 'case) ,(r 'int)
267              ,@(map (lambda (x i)
268                       `((,i) ',x))
269                     vars ints)
270              (,(r 'else) #f))))))))
271
272(define-syntax define-syntax-rule
273  (er-macro-transformer
274   (lambda (x r c)
275     (if (or (not (pair? (cdr x)))
276             (not (pair? (cadr x)))
277             (not (symbol? (caadr x))))
278         (syntax-error "invalid argument syntax")
279         (let ((name (caadr x))
280               (args (cdadr x)))
281           `(,(r 'define-syntax) ,name
282             (,(r 'syntax-rules) ()
283              ((_ . ,(cdadr x)) ,@(cddr x)))))))))
284
285(define-syntax-rule (ecase val clauses ...)
286  (case val
287    clauses ...
288    (else (error "no valid case" val))))
289
290(define-syntax cond-list
291  (syntax-rules ()
292    ((cond-list) (list))
293    ((cond-list (c e) rest ...)
294     (let ((tail (cond-list rest ...)))
295       (if c
296           (cons e tail)
297           tail)))))
298
299)
Note: See TracBrowser for help on using the repository browser.