From 5a0b7f2b07309fb122742b648af7b9578b1cd29f Mon Sep 17 00:00:00 2001
From: =?utf8?q?David=20V=C3=A1zquez?= <davazp@gmail.com>
Date: Wed, 1 May 2013 13:44:15 +0100
Subject: [PATCH] Fixes #64 issue on nested scoping in non local exists

---
 jscl.lisp          |    3 +--
 src/compiler.lisp  |   45 +++++++++++++++++++++++++++------------------
 tests/control.lisp |   23 +++++++++++++++++++++++
 3 files changed, 51 insertions(+), 20 deletions(-)
 create mode 100644 tests/control.lisp

diff --git a/jscl.lisp b/jscl.lisp
index 792461f..86e27a5 100644
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -73,8 +73,7 @@
   (setq *literal-table* nil)
   (setq *variable-counter* 0
         *gensym-counter* 0
-        *literal-counter* 0
-        *block-counter* 0)
+        *literal-counter* 0)
   (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
     (write-string (read-whole-file (source-pathname "prelude.js")) out)
     (dolist (input *source*)
diff --git a/src/compiler.lisp b/src/compiler.lisp
index 8105748..b6eca08 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -799,11 +799,15 @@
         (let*-binding-wrapper specials body)))))
 
 
-(defvar *block-counter* 0)
-
 (define-compilation block (name &rest body)
-  (let* ((tr (incf *block-counter*))
-         (b (make-binding :name name :type 'block :value tr)))
+  ;; We use Javascript exceptions to implement non local control
+  ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
+  ;; generated object to identify the block. The instance of a empty
+  ;; array is used to distinguish between nested dynamic Javascript
+  ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
+  ;; futher details.
+  (let* ((idvar (gvarname name))
+         (b (make-binding :name name :type 'block :value idvar)))
     (when *multiple-value-p*
       (push 'multiple-value (binding-declarations b)))
     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
@@ -811,10 +815,11 @@
       (if (member 'used (binding-declarations b))
           (js!selfcall
             "try {" *newline*
+            "var " idvar " = [];" *newline*
             (indent cbody)
             "}" *newline*
             "catch (cf){" *newline*
-            "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
+            "    if (cf.type == 'block' && cf.id == " idvar ")" *newline*
             (if *multiple-value-p*
                 "        return values.apply(this, forcemv(cf.values));"
                 "        return cf.values;")
@@ -830,6 +835,10 @@
     (when (null b)
       (error (concat "Unknown block `" (symbol-name name) "'.")))
     (push 'used (binding-declarations b))
+    ;; The binding value is the name of a variable, whose value is the
+    ;; unique identifier of the block as exception. We can't use the
+    ;; variable name itself, because it could not to be unique, so we
+    ;; capture it in a closure.
     (js!selfcall
       (when multiple-value-p (code "var values = mv;" *newline*))
       "throw ({"
@@ -865,19 +874,16 @@
     "message: 'Throw uncatched.'"
     "})"))
 
-
-(defvar *tagbody-counter* 0)
-(defvar *go-tag-counter* 0)
-
 (defun go-tag-p (x)
   (or (integerp x) (symbolp x)))
 
 (defun declare-tagbody-tags (tbidx body)
-  (let ((bindings
-         (mapcar (lambda (label)
-                   (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
-                     (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
-                 (remove-if-not #'go-tag-p body))))
+  (let* ((go-tag-counter 0)
+         (bindings
+          (mapcar (lambda (label)
+                    (let ((tagidx (integer-to-string (incf go-tag-counter))))
+                      (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
+                  (remove-if-not #'go-tag-p body))))
     (extend-lexenv bindings *environment* 'gotag)))
 
 (define-compilation tagbody (&rest body)
@@ -890,18 +896,21 @@
   (unless (go-tag-p (car body))
     (push (gensym "START") body))
   ;; Tagbody compilation
-  (let ((tbidx *tagbody-counter*))
+  (let ((branch (gvarname 'branch))
+        (tbidx (gvarname 'tbidx)))
     (let ((*environment* (declare-tagbody-tags tbidx body))
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
         (setq initag (second (binding-value b))))
       (js!selfcall
-        "var tagbody_" tbidx " = " initag ";" *newline*
+        ;; TAGBODY branch to take
+        "var " branch " = " initag ";" *newline*
+        "var " tbidx " = [];" *newline*
         "tbloop:" *newline*
         "while (true) {" *newline*
         (indent "try {" *newline*
                 (indent (let ((content ""))
-                          (code "switch(tagbody_" tbidx "){" *newline*
+                          (code "switch(" branch "){" *newline*
                                 "case " initag ":" *newline*
                                 (dolist (form (cdr body) content)
                                   (concatf content
@@ -915,7 +924,7 @@
                 "}" *newline*
                 "catch (jump) {" *newline*
                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
-                "        tagbody_" tbidx " = jump.label;" *newline*
+                "        " branch " = jump.label;" *newline*
                 "    else" *newline*
                 "        throw(jump);" *newline*
                 "}" *newline*)
diff --git a/tests/control.lisp b/tests/control.lisp
new file mode 100644
index 0000000..7fc4055
--- /dev/null
+++ b/tests/control.lisp
@@ -0,0 +1,23 @@
+
+;;; Returning from a "dynamically" nested non local exists
+
+(defun foo (x)
+  (when x (funcall x))
+  (foo (lambda () (return-from foo 1)))
+  (return-from foo 2))
+
+(test (= (foo nil) 1))
+
+(defun foo-2 (x)
+  (let (value)
+    (tagbody
+       (when x (funcall x))
+       (foo-2 (lambda () (go exit-2)))
+       (go end)
+     exit-2
+       (setq value t)
+     end)
+    value))
+
+(test (foo-2 nil))
+
-- 
1.7.10.4