From 18c8e6a2d7bdc53f5a95c1a29b8913ee66a415d6 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Fri, 5 Jul 2013 03:32:55 +0200 Subject: [PATCH] Migrate TAGBODY --- src/compiler.lisp | 46 ++++++++++++++++++++-------------------------- 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/src/compiler.lisp b/src/compiler.lisp index bfa9abb..866cea2 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -848,34 +848,28 @@ initag) (let ((b (lookup-in-lexenv (first body) *environment* 'gotag))) (setq initag (second (binding-value b)))) - (js!selfcall + (js!selfcall* ;; TAGBODY branch to take - "var " branch " = " initag ";" - "var " tbidx " = [];" - "tbloop:" - "while (true) {" - `(code "try {" - ,(let ((content nil)) - `(code "switch(" ,branch "){" - "case " ,initag ":" - ,@(dolist (form (cdr body) (reverse content)) - (push (if (not (go-tag-p form)) - `(code ,(ls-compile form) ";" ) + `(var (,(make-symbol branch) ,initag)) + `(var (,(make-symbol tbidx) #())) + `(label tbloop + (while true + (try + (switch ,(make-symbol branch) + ,@(with-collect + (dolist (form (cdr body)) + (if (go-tag-p form) (let ((b (lookup-in-lexenv form *environment* 'gotag))) - `(code "case " ,(second (binding-value b)) ":" ))) - content)) - "default:" - " break tbloop;" - "}" )) - "}" - "catch (jump) {" - " if (jump.type == 'tagbody' && jump.id == " ,tbidx ")" - " " ,branch " = jump.label;" - " else" - " throw(jump);" - "}" ) - "}" - "return " (ls-compile nil) ";" )))) + (collect `(case ,(second (binding-value b))))) + (collect (ls-compile form))))) + default + (break tbloop))) + (catch (jump) + (if (and (== (get jump "type") "tagbody") + (== (get jump "id") ,(make-symbol tbidx))) + (= ,(make-symbol branch) (get jump "label")) + (throw jump))))) + `(return ,(ls-compile nil)))))) (define-compilation go (label) (let ((b (lookup-in-lexenv label *environment* 'gotag)) -- 1.7.10.4