|
1 (keyword-style '#:none) |
|
2 |
|
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))) |
|
9 |
|
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 ...))))) |
|
17 |
|
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)))))) |
|
35 |
|
36 (begin |
|
37 (define-syntax begin/debug-indent |
|
38 (syntax-rules () |
|
39 ((_ body ...) |
|
40 (begin body ...)))) |
|
41 |
|
42 (define-syntax debug |
|
43 (syntax-rules (-->) |
|
44 ((_ level --> l2 exp ...) |
|
45 'conditionally-compiled-away) |
|
46 ((_ level exp ...) |
|
47 'conditionally-compiled-away))))) |
|
48 |
|
49 (define-syntax send |
|
50 (syntax-rules () |
|
51 ((_ selector arg ...) |
|
52 (send/previous-method #f 'selector (vector arg ...))))) |
|
53 |
|
54 (define-syntax push! |
|
55 (syntax-rules () |
|
56 ((_ variable value) |
|
57 (set! variable (cons value variable))))) |
|
58 |
|
59 (define-syntax let*-structure |
|
60 (syntax-rules () |
|
61 ;; minor optimisation - removes a layer of (let) |
|
62 ((_ () body) |
|
63 body) |
|
64 |
|
65 ((_ () body ...) |
|
66 (let () body ...)) |
|
67 |
|
68 ((_ ((pattern value) more ...) body ...) |
|
69 (let ((temp value)) |
|
70 (let*-structure "ONE" pattern temp (more ...) (begin body ...)))) |
|
71 |
|
72 ((_ "ONE" () value more continuation) |
|
73 (if (null? value) |
|
74 (let*-structure more continuation) |
|
75 (error "Pattern mismatch" () value))) |
|
76 |
|
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)))) |
|
81 |
|
82 ((_ "ONE" var value more continuation) |
|
83 (let ((var value)) |
|
84 (let*-structure more continuation))))) |