14
14
(in-package "COMPILER")
16
;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB'
17
;;; (Closure Boundary), 'LB' (Level Boundary) or 'UNWIND-PROTECT'.
18
;;; 'CB' will be pushed on *tags* when the compiler begins to process
20
;;; 'LB' will be pushed on *tags* when *level* is incremented.
21
;;; 'UNWIND-PROTECT' is pushed when entering an unwind-protect.
22
16
;;; A dummy variable is created to hold the tag identifier and one tag
23
17
;;; structure (containing reference to such variable) is created for each
24
18
;;; label in the body.
177
171
(defun c1go (args)
178
172
(check-args-number 'GO args 1 1)
179
(unless (or (symbolp (car args)) (integerp (car args)))
180
(cmperr "The tag name ~s is not a symbol nor an integer." (car args)))
181
(do ((tags *tags* (cdr tags))
183
(ccb) (clb) (unw) (tag) (var))
184
((endp tags) (cmperr "The tag ~s is undefined." name))
185
(declare (type var var))
186
(setq tag (car tags))
190
(UNWIND-PROTECT (setq unw T))
191
(T (when (eql (tag-name tag) name)
192
(setq var (tag-var tag))
193
(cond (ccb (setf (tag-ref-ccb tag) t
195
(var-kind var) 'CLOSURE))
196
(clb (setf (tag-ref-clb tag) t
198
(var-kind var) 'LEXICAL))
199
(unw (unless (var-kind var)
200
(setf (var-kind var) :OBJECT))))
203
(return (add-to-read-nodes var (make-c1form* 'GO :args tag
173
(let ((name (first args)))
174
(unless (or (symbolp name) (integerp name))
175
(cmperr "The tag name ~s is not a symbol nor an integer." name))
176
(multiple-value-bind (tag ccb clb unw)
177
(cmp-env-search-tag name)
179
(cmperr "Undefined tag ~A" name))
180
(setq var (tag-var tag))
181
(cond (ccb (setf (tag-ref-ccb tag) t
183
(var-kind var) 'CLOSURE))
184
(clb (setf (tag-ref-clb tag) t
186
(var-kind var) 'LEXICAL))
187
(unw (unless (var-kind var)
188
(setf (var-kind var) :OBJECT))))
191
(add-to-read-nodes var (make-c1form* 'GO :args tag (or ccb clb unw))))))
207
193
(defun c2go (tag nonlocal)