From: David Vázquez Date: Sat, 22 Feb 2014 01:50:58 +0000 (+0100) Subject: TAGBODY uses TagNLX object instead of plain object X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;h=08641896dd4b3023f018f63ed3cbaf305f9443fb;p=jscl.git TAGBODY uses TagNLX object instead of plain object --- diff --git a/src/compiler/compiler.lisp b/src/compiler/compiler.lisp index 6773974..e3bac18 100644 --- a/src/compiler/compiler.lisp +++ b/src/compiler/compiler.lisp @@ -860,26 +860,19 @@ 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 diff --git a/src/prelude.js b/src/prelude.js index d9df2da..1c0bf5b 100644 --- a/src/prelude.js +++ b/src/prelude.js @@ -165,3 +165,8 @@ function CatchNLX (id, values){ this.id = id; this.values = values; } + +function TagNLX (id, label){ + this.id = id; + this.label = label; +}