fixed RETURN-FROM for FLET/LABELS and added a test case for correct handling of RETUR...

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 96bd5b6..ada104e 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -647,8 +647,11 @@
 
 (define-compilation flet (definitions &rest body)
   (let* ((fnames (mapcar #'car definitions))
-         (fbody  (mapcar #'cdr definitions))
-         (cfuncs (mapcar #'compile-function-definition fbody))
+         (cfuncs (mapcar (lambda (def)
+                           (compile-lambda (cadr def)
+                                           `((block ,(car def)
+                                               ,@(cddr def)))))
+                         definitions))
          (*environment*
           (extend-lexenv (mapcar #'make-function-binding fnames)
                          *environment*
@@ -669,7 +672,8 @@
     (js!selfcall
       (mapconcat (lambda (func)
                   (code "var " (translate-function (car func))
-                         " = " (compile-lambda (cadr func) (cddr func))
+                         " = " (compile-lambda (cadr func)
+                                               `((block ,(car func) ,@(cddr func))))
                          ";" *newline*))
                 definitions)
       (ls-compile-block body t))))

diff --git a/tests/return-from.lisp b/tests/return-from.lisp
new file mode 100644 (file)
index 0000000..0d423ff
--- /dev/null
+++ b/tests/return-from.lisp
@@ -0,0 +1,20 @@
+(test (equal (flet ((foo () (return-from foo 42)))
+               (foo))
+             42))
+
+(test (equal (let ((out (list)))
+               (labels ((zfoo (n rf i)
+                          (if (> n 0)
+                              (progn
+                                (push (lambda () (return-from zfoo n)) rf)
+                                (push n out)
+                                (zfoo (1- n) rf i)
+                                (push (- n) out))
+                              (progn
+                                (push 999 out)
+                                (funcall (nth i (reverse rf)))
+                                (push -999 out)))))
+                 (let ((rf (list)))
+                   (zfoo 5 rf 3)
+                   out)))
+             '(-5 -4 -3 999 1 2 3 4 5)))