author | Tony Garnock-Jones <tonyg@kcbbs.gen.nz> |
Thu, 31 Mar 2005 01:25:02 +1200 | |
changeset 0 | ea4e1a00864c |
permissions | -rw-r--r-- |
0
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
1 |
(keyword-style '#:none) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
2 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
3 |
(define-syntax compile-if |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
4 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
5 |
((_ #f tb fb) fb) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
6 |
((_ #t tb fb) tb) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
7 |
((_ #f tb) 'conditionally-compiled-away) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
8 |
((_ #t tb) tb))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
9 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
10 |
(compile-if #t |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
11 |
(begin |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
12 |
(define-syntax begin/debug-indent |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
13 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
14 |
((_ body ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
15 |
(fluid-let ((*debug-indent* (+ *debug-indent* 2))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
16 |
(begin body ...))))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
17 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
18 |
(define-syntax debug |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
19 |
(syntax-rules (-->) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
20 |
((_ level --> l2 exp ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
21 |
(when (>= *debug-level* level) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
22 |
(let ((old-level *debug-level*)) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
23 |
(set! *debug-level* l2) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
24 |
(if (positive? *debug-indent*) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
25 |
(display (make-string *debug-indent* #\space))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
26 |
(display exp) ... |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
27 |
(newline) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
28 |
(set! *debug-level* old-level)))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
29 |
((_ level exp ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
30 |
(when (>= *debug-level* level) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
31 |
(if (positive? *debug-indent*) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
32 |
(display (make-string *debug-indent* #\space))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
33 |
(display exp) ... |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
34 |
(newline)))))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
35 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
36 |
(begin |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
37 |
(define-syntax begin/debug-indent |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
38 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
39 |
((_ body ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
40 |
(begin body ...)))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
41 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
42 |
(define-syntax debug |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
43 |
(syntax-rules (-->) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
44 |
((_ level --> l2 exp ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
45 |
'conditionally-compiled-away) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
46 |
((_ level exp ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
47 |
'conditionally-compiled-away))))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
48 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
49 |
(define-syntax send |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
50 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
51 |
((_ selector arg ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
52 |
(send/previous-method #f 'selector (vector arg ...))))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
53 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
54 |
(define-syntax push! |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
55 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
56 |
((_ variable value) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
57 |
(set! variable (cons value variable))))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
58 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
59 |
(define-syntax let*-structure |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
60 |
(syntax-rules () |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
61 |
;; minor optimisation - removes a layer of (let) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
62 |
((_ () body) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
63 |
body) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
64 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
65 |
((_ () body ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
66 |
(let () body ...)) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
67 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
68 |
((_ ((pattern value) more ...) body ...) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
69 |
(let ((temp value)) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
70 |
(let*-structure "ONE" pattern temp (more ...) (begin body ...)))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
71 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
72 |
((_ "ONE" () value more continuation) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
73 |
(if (null? value) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
74 |
(let*-structure more continuation) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
75 |
(error "Pattern mismatch" () value))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
76 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
77 |
((_ "ONE" (left . right) value more continuation) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
78 |
(let ((l (car value)) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
79 |
(r (cdr value))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
80 |
(let*-structure "ONE" left l () (let*-structure "ONE" right r more continuation)))) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
81 |
|
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
82 |
((_ "ONE" var value more continuation) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
83 |
(let ((var value)) |
ea4e1a00864c
Initial version, from TLA arch@eighty-twenty.org--2004/smalltalk-tng--main--0--version-0
Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
parents:
diff
changeset
|
84 |
(let*-structure more continuation))))) |