Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / language / ecmascript / compile-tree-il.scm

diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index 7a96d07..2fe0d92 100644 (file)
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -25,20 +25,14 @@
   #:use-module (srfi srfi-1)
   #:export (compile-tree-il))
 
-(define-syntax ->
-  (syntax-rules ()
-    ((_ (type arg ...))
-     `(type ,arg ...))))
+(define-syntax-rule (-> (type arg ...))
+  `(type ,arg ...))
 
-(define-syntax @implv
-  (syntax-rules ()
-    ((_ sym)
-     (-> (@ '(language ecmascript impl) 'sym)))))
+(define-syntax-rule (@implv sym)
+  (-> (@ '(language ecmascript impl) 'sym)))
 
-(define-syntax @impl
-  (syntax-rules ()
-    ((_ sym arg ...)
-     (-> (call (@implv sym) arg ...)))))
+(define-syntax-rule (@impl sym arg ...)
+  (-> (call (@implv sym) arg ...)))
 
 (define (empty-lexical-environment)
   '())
@@ -67,16 +61,34 @@
 ;; for emacs:
 ;; (put 'pmatch/source 'scheme-indent-function 1)
 
-(define-syntax pmatch/source
-  (syntax-rules ()
-    ((_ x clause ...)
-     (let ((x x))
-       (let ((res (pmatch x
-                    clause ...)))
-         (let ((loc (location x)))
-           (if loc
-               (set-source-properties! res (location x))))
-         res)))))
+(define-syntax-rule (pmatch/source x clause ...)
+  (let ((x x))
+    (let ((res (pmatch x
+                 clause ...)))
+      (let ((loc (location x)))
+        (if loc
+            (set-source-properties! res (location x))))
+      res)))
+
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+  (-> (abort (or (current-return-tag) (error "return outside function"))
+             (list expr)
+             (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+  (let ((tag (gensym "return")))
+    (parameterize ((current-return-tag
+                    (-> (lexical 'return tag))))
+      (-> (let '(return) (list tag)
+               (list (-> (primcall 'make-prompt-tag)))
+               (-> (prompt (current-return-tag)
+                           (body-thunk)
+                           (let ((val (gensym "val")))
+                             (-> (lambda-case
+                                  `(((k val) #f #f #f () (,(gensym) ,val))
+                                    ,(-> (lexical 'val val)))))))))))))
 
 (define (comp x e)
   (let ((l (location x)))
@@ -338,7 +350,9 @@
          `(lambda ()
             (lambda-case
              ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
-              ,(comp-body e body formals syms))))))
+              ,(with-return-prompt
+                (lambda ()
+                  (comp-body e body formals syms))))))))
       ((call/this ,obj ,prop . ,args)
        (@impl call/this*
               obj
@@ -360,8 +374,7 @@
        `(call ,(comp proc e)                
               ,@(map (lambda (x) (comp x e)) args)))
       ((return ,expr)
-       (-> (call (-> (primitive 'return))
-                 (comp expr e))))
+       (return (comp expr e)))
       ((array . ,args)
        `(call ,(@implv new-array)
               ,@(map (lambda (x) (comp x e)) args)))