smalltalk-tng
view r1/macros.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | |
| children |
line source
1 (keyword-style '#:none)
3 (define-syntax compile-if
4 (syntax-rules ()
5 ((_ #f tb fb) fb)
6 ((_ #t tb fb) tb)
7 ((_ #f tb) 'conditionally-compiled-away)
8 ((_ #t tb) tb)))
10 (compile-if #t
11 (begin
12 (define-syntax begin/debug-indent
13 (syntax-rules ()
14 ((_ body ...)
15 (fluid-let ((*debug-indent* (+ *debug-indent* 2)))
16 (begin body ...)))))
18 (define-syntax debug
19 (syntax-rules (-->)
20 ((_ level --> l2 exp ...)
21 (when (>= *debug-level* level)
22 (let ((old-level *debug-level*))
23 (set! *debug-level* l2)
24 (if (positive? *debug-indent*)
25 (display (make-string *debug-indent* #\space)))
26 (display exp) ...
27 (newline)
28 (set! *debug-level* old-level))))
29 ((_ level exp ...)
30 (when (>= *debug-level* level)
31 (if (positive? *debug-indent*)
32 (display (make-string *debug-indent* #\space)))
33 (display exp) ...
34 (newline))))))
36 (begin
37 (define-syntax begin/debug-indent
38 (syntax-rules ()
39 ((_ body ...)
40 (begin body ...))))
42 (define-syntax debug
43 (syntax-rules (-->)
44 ((_ level --> l2 exp ...)
45 'conditionally-compiled-away)
46 ((_ level exp ...)
47 'conditionally-compiled-away)))))
49 (define-syntax send
50 (syntax-rules ()
51 ((_ selector arg ...)
52 (send/previous-method #f 'selector (vector arg ...)))))
54 (define-syntax push!
55 (syntax-rules ()
56 ((_ variable value)
57 (set! variable (cons value variable)))))
59 (define-syntax let*-structure
60 (syntax-rules ()
61 ;; minor optimisation - removes a layer of (let)
62 ((_ () body)
63 body)
65 ((_ () body ...)
66 (let () body ...))
68 ((_ ((pattern value) more ...) body ...)
69 (let ((temp value))
70 (let*-structure "ONE" pattern temp (more ...) (begin body ...))))
72 ((_ "ONE" () value more continuation)
73 (if (null? value)
74 (let*-structure more continuation)
75 (error "Pattern mismatch" () value)))
77 ((_ "ONE" (left . right) value more continuation)
78 (let ((l (car value))
79 (r (cdr value)))
80 (let*-structure "ONE" left l () (let*-structure "ONE" right r more continuation))))
82 ((_ "ONE" var value more continuation)
83 (let ((var value))
84 (let*-structure more continuation)))))