From: David Vázquez <davazp@gmail.com>
Date: Fri, 5 Jul 2013 01:32:55 +0000 (+0200)
Subject: Migrate TAGBODY
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=18c8e6a2d7bdc53f5a95c1a29b8913ee66a415d6;p=jscl.git

Migrate TAGBODY
---

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))