(var (,idvar #()))
,cbody)
(catch (cf)
- (if (and (== (get cf "type") "block")
- (== (get cf "id") ,idvar))
+ (if (and (instanceof cf |BlockNLX|) (== (get cf "id") ,idvar))
,(if *multiple-value-p*
`(return (method-call |values| "apply" this (call |forcemv| (get cf "values"))))
`(return (get cf "values")))
;; capture it in a closure.
`(selfcall
,(when multiple-value-p `(var (|values| |mv|)))
- (throw
- (object
- "type" "block"
- "id" ,(binding-value b)
- "values" ,(convert value multiple-value-p)
- "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
+ (throw (new (call |BlockNLX|
+ ,(binding-value b)
+ ,(convert value multiple-value-p)
+ ,(symbol-name name)))))))
(define-compilation catch (id &rest body)
- `(selfcall
- (var (id ,(convert id)))
- (try
- ,(convert-block body t))
- (catch (|cf|)
- (if (and (== (get |cf| "type") "catch")
- (== (get |cf| "id") id))
- ,(if *multiple-value-p*
- `(return (method-call |values| "apply" this (call |forcemv| (get |cf| "values"))))
- `(return (method-call |pv| "apply" this (call |forcemv| (get |cf| "values")))))
- (throw |cf|)))))
+ (let ((values (if *multiple-value-p* '|values| '|pv|)))
+ `(selfcall
+ (var (id ,(convert id)))
+ (try
+ ,(convert-block body t))
+ (catch (cf)
+ (if (and (instanceof cf |CatchNLX|) (== (get cf "id") id))
+ (return (method-call ,values "apply" this (call |forcemv| (get cf "values"))))
+ (throw cf))))))
(define-compilation throw (id value)
`(selfcall
(var (|values| |mv|))
- (throw (object
- "type" "catch"
- "id" ,(convert id)
- "values" ,(convert value t)
- "message" "Throw uncatched."))))
+ (throw (new (call |CatchNLX| ,(convert id) ,(convert value t))))))
+
(defun go-tag-p (x)
(or (integerp x) (symbolp x)))
default
(break tbloop)))
(catch (jump)
- (if (and (== (get jump "type") "tagbody")
- (== (get jump "id") ,tbidx))
+ (if (and (instanceof jump |TagNLX|) (== (get jump "id") ,tbidx))
(= ,branch (get jump "label"))
(throw jump)))))
(return ,(convert nil))))))
(define-compilation go (label)
- (let ((b (lookup-in-lexenv label *environment* 'gotag))
- (n (cond
- ((symbolp label) (symbol-name label))
- ((integerp label) (integer-to-string label)))))
+ (let ((b (lookup-in-lexenv label *environment* 'gotag)))
(when (null b)
(error "Unknown tag `~S'" label))
`(selfcall
- (throw
- (object
- "type" "tagbody"
- "id" ,(first (binding-value b))
- "label" ,(second (binding-value b))
- "message" ,(concat "Attempt to GO to non-existing tag " n))))))
+ (throw (new (call |TagNLX|
+ ,(first (binding-value b))
+ ,(second (binding-value b))))))))
(define-compilation unwind-protect (form &rest clean-up)
`(selfcall