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
|
(defmacro tagbody (. forms)
(when forms
(let* ((tb-id (gensym "tb-id-"))
(next-var (gensym "next-"))
(bblocks (partition forms (op where [orf symbolp integerp chrp])))
(start-lbl (if bblocks [[orf symbolp integerp chrp] (caar bblocks)])))
(unless start-lbl
(push (gensym "entry-") (car bblocks)))
(if (and (not start-lbl) (not (cdr bblocks)))
^(progn nil ,*forms nil)
(let* ((lbls [mapcar car bblocks])
(forms [mapcar cdr bblocks])
(threaded-1 (mapcar (op member-if true) (conses forms)))
(threaded-2 [apply nconc forms])
(codes [mapcar car threaded-1]))
(ignore threaded-2)
(unless (eql (length (uniq lbls)) (length lbls))
(throwf 'eval-error "~s: duplicate labels occur" 'tagbody))
(let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-"))
(,next-var 0))
(sys:for-op ()
(,next-var)
((set ,next-var
(block* ,tb-id
(sys:switch ,next-var #(,*codes))
nil)))))))
^(macrolet ((go (:form form label)
(let ((index (posql label ',lbls)))
(if index ^(return* ,',tb-id ,index) form))))
,basic-code)))))))
(defmacro go (label)
(if [[orf symbolp integerp chrp] label]
(throwf 'eval-error "~s: no ~s label visible" 'go label)
(throwf 'eval-error "~s: ~s isn't a symbol, integer or character" 'go label)))
(defmacro prog (vars . body)
^(block nil
(let ,vars (tagbody ,*body))))
(defmacro prog* (vars . body)
^(block nil
(let* ,vars (tagbody ,*body))))
|