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
|
(export '(identity constantly complement tagbody go block return-from
defconstant))
(defun identity (x)
x)
(defun constantly (c)
(lambda (x)
(declare (ignore x))
c))
(defun complement (function)
(lambda (x) (not (funcall function x))))
(defmacro defconstant (name value &optional documentation)
`(setq ,name ,value))
;; FIXME: Should be (EVAL-WHEN (:compile-toplevel) ...).
(unless (boundp '+block-mapping-sym+)
(defconstant +block-mapping-sym+ (gensym "BLOCK-NAME")))
(defmacro #.+block-mapping-sym+ () nil)
(defmacro block (block-name &body body)
(let ((catch-tag (gensym)))
`(macrolet ((,+block-mapping-sym+ ()
`(quote ,(acons ',block-name
',catch-tag
(,+block-mapping-sym+)))))
(catch ',catch-tag
,@body))))
(defmacro return-from (block-name &optional value &environment env)
`(throw ',(cdr (assoc block-name (cadr (macroexpand `(,+block-mapping-sym+)
env))))
,value))
;; FIXME: Should be (EVAL-WHEN (:compile-toplevel) ...).
(unless (boundp '+go-tag-function-mapping-sym+)
(defconstant +go-tag-function-mapping-sym+ (gensym "GO-FUNCTION"))
(defconstant +go-tag-catch-tag-mapping-sym+ (gensym "GO-CATCH-TAG")))
(defmacro #.+go-tag-function-mapping-sym+ () nil)
(defmacro #.+go-tag-catch-tag-mapping-sym+ () nil)
;; FIXME: Implement TAGBODY and GO.
(defmacro go (tag &environment env)
`(throw ',(cdr (assoc tag (cadr (macroexpand `(,+go-tag-catch-tag-mapping-sym+)
env))))
(function ,(cdr (assoc tag (cadr (macroexpand `(,+go-tag-function-mapping-sym+)
env)))))))
(defmacro tagbody (&body body)
;;(declare (optimize debug))
(let* (labels-and-catch-tags
labels-and-functions
(catch-tag (gensym))
(block-name (gensym))
(return-value-sym (gensym))
(end-marker (gensym))
(sections
(mapcon (let (current-label
accumulated-clauses
current-function)
(lambda (clause-and-rest)
(let ((clause (car clause-and-rest))
(rest (cdr clause-and-rest)))
(cond
((atom clause)
(when current-function
(push (cons current-label current-function)
labels-and-functions)
(push (cons current-label catch-tag)
labels-and-catch-tags))
(let ((old-function current-function))
(setq current-label clause
current-function (gensym))
(prog1
`((,old-function ()
,@(nreverse accumulated-clauses)
,(if rest `#',current-function `nil))
,@(when (endp rest)
`(,current-function ()
',end-marker)))
(setq accumulated-clauses nil))))
(t (push clause accumulated-clauses)
(if (endp rest)
(progn
(when current-function
(push (cons current-label current-function)
labels-and-functions)
(push (cons current-label catch-tag)
labels-and-catch-tags))
`((,current-function ()
,@(nreverse accumulated-clauses)
',end-marker)))
nil))))))
body)))
`(macrolet ((,+go-tag-catch-tag-mapping-sym+ ()
(list 'quote
(list* ,@(mapcar (lambda (x) (list 'quote x))
labels-and-catch-tags)
(,+go-tag-catch-tag-mapping-sym+))))
(,+go-tag-function-mapping-sym+ ()
(list 'quote
(list* ,@(mapcar (lambda (x) (list 'quote x))
labels-and-functions)
(,+go-tag-function-mapping-sym+)))))
(labels (,@(rest sections))
(block ,block-name
(let (,return-value-sym)
(%loop
(setq ,return-value-sym
(catch ',catch-tag
(if ,return-value-sym
(funcall ,return-value-sym)
(progn ,@(cddr (first sections))))))
(when (eq ,return-value-sym ',end-marker)
(return-from ,block-name nil)))))))))
|
