Commit ae093417 authored by Vladimir Sedach's avatar Vladimir Sedach

Made return-from and statement expressionization work better.

parent abc59cee
......@@ -27,6 +27,9 @@
"public" "short" "static" "super" "synchronized" "throws" "transient"
"volatile" "{}" "true" "false" "null" "undefined"))
(defvar *lambda-wrappable-statements* ;; break, return, continue not included
'(throw switch for for-in while try block))
(defun reserved-symbol? (symbol)
(find (string-downcase (string symbol)) *reserved-symbol-names* :test #'string=))
......@@ -44,15 +47,18 @@
,@body)))))
(defmacro define-expression-operator (name lambda-list &body body)
`(%define-special-operator *special-expression-operators* ,name ,lambda-list ,@body))
`(%define-special-operator *special-expression-operators*
,name ,lambda-list ,@body))
(defmacro define-statement-operator (name lambda-list &body body)
`(%define-special-operator *special-statement-operators* ,name ,lambda-list ,@body))
`(%define-special-operator *special-statement-operators*
,name ,lambda-list ,@body))
(defun special-form? (form)
(and (consp form)
(symbolp (car form))
(or (gethash (car form) *special-expression-operators*) (gethash (car form) *special-statement-operators*))))
(or (gethash (car form) *special-expression-operators*)
(gethash (car form) *special-statement-operators*))))
;;; scoping and lexical environment
......@@ -79,9 +85,8 @@ lexical block.")
(defvar *enclosing-lexicals* ())
(defvar *enclosing-function-arguments* ())
(defvar *function-block-names* ())
(defvar *lexical-extent-return-tags* ())
(defvar *dynamic-extent-return-tags* ())
(defvar *tags-that-return-throws-to*)
(defvar *dynamic-return-tags* ())
(defvar *current-block-tag* nil)
(defvar *special-variables* ())
......@@ -203,12 +208,16 @@ form, FORM, returns the new value for *compilation-level*."
(format stream "The Parenscript form ~A cannot be compiled into an expression." (error-form condition)))))
(defun compile-special-form (form)
(apply (if compile-expression?
(or (gethash (car form) *special-expression-operators*)
(error 'compile-expression-error :form form))
(or (gethash (car form) *special-statement-operators*)
(gethash (car form) *special-expression-operators*)))
(cdr form)))
(let* ((op (car form))
(statement-impl (gethash op *special-statement-operators*))
(expression-impl (gethash op *special-expression-operators*)))
(cond ((not compile-expression?)
(apply (or statement-impl expression-impl) (cdr form)))
(expression-impl
(apply expression-impl (cdr form)))
((member op *lambda-wrappable-statements*)
(compile-expression `((lambda () ,form))))
(t (error 'compile-expression-error :form form)))))
(defun ps-compile (form)
(typecase form
......
......@@ -113,32 +113,42 @@ Syntax of key spec:
(defun compile-function-body (args body)
(with-declaration-effects (body body)
(let* ((*enclosing-lexical-block-declarations* ())
(*enclosing-function-arguments* (append args *enclosing-function-arguments*))
(*enclosing-lexicals* (set-difference *enclosing-lexicals* args))
(body (let ((in-loop-scope? nil)
(*loop-scope-lexicals* ())
(*loop-scope-lexicals-captured* ()))
(compile-statement `(return-from %function-body
(progn ,@(collapse-function-return-blocks body))))))
(var-decls (compile-statement
`(progn ,@(mapcar (lambda (var) `(var ,var))
(remove-duplicates *enclosing-lexical-block-declarations*))))))
(*enclosing-function-arguments*
(append args *enclosing-function-arguments*))
(*enclosing-lexicals*
(set-difference *enclosing-lexicals* args))
(collapsed-body (collapse-function-return-blocks body))
(*dynamic-return-tags* (append (mapcar (lambda (x) (cons x nil))
*function-block-names*)
*dynamic-return-tags*))
(body
(let ((in-loop-scope? nil)
(*loop-scope-lexicals* ())
(*loop-scope-lexicals-captured* ()))
(compile-statement
`(return-from %function (progn ,@collapsed-body)))))
(var-decls
(compile-statement
`(progn
,@(mapcar
(lambda (var)
`(var ,var))
(remove-duplicates *enclosing-lexical-block-declarations*))))))
(when in-loop-scope? ;; this is probably broken when it comes to let-renaming
(setf *loop-scope-lexicals-captured* (append (intersection (flatten body) *loop-scope-lexicals*)
*loop-scope-lexicals-captured*)))
`(ps-js:block ,@(cdr var-decls) ,@(cdr body)))))
(setf *loop-scope-lexicals-captured*
(append (intersection (flatten body) *loop-scope-lexicals*)
*loop-scope-lexicals-captured*)))
`(ps-js:block ,@(cdr var-decls)
,@(cdr (wrap-for-dynamic-return *function-block-names* body))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; lambda
(define-expression-operator lambda (lambda-list &rest body)
(multiple-value-bind (effective-args effective-body) (parse-extended-function lambda-list body)
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body)
`(ps-js:lambda ,effective-args
,(let ((*function-block-names* nil)
(*dynamic-extent-return-tags* (append *function-block-names*
*lexical-extent-return-tags*
*dynamic-extent-return-tags*))
(*lexical-extent-return-tags* ()))
,(let ((*function-block-names* ()))
(compile-function-body effective-args effective-body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -146,15 +156,11 @@ Syntax of key spec:
(defun compile-named-function-body (name lambda-list body)
(let ((*enclosing-lexicals* (cons name *enclosing-lexicals*))
(*function-block-names* (list name))
(*lexical-extent-return-tags* ())
(*dynamic-extent-return-tags* ())
(*tags-that-return-throws-to* ()))
(*function-block-names* (list name)))
(multiple-value-bind (effective-args effective-body docstring)
(parse-extended-function lambda-list body)
(values effective-args
(wrap-block-for-dynamic-return name
(compile-function-body effective-args effective-body))
(compile-function-body effective-args effective-body)
docstring))))
(define-statement-operator defun% (name lambda-list &rest body)
......@@ -168,38 +174,46 @@ Syntax of key spec:
(defun collect-function-names (fn-defs)
(loop for (fn-name) in fn-defs
collect fn-name
collect (if (or (member fn-name *enclosing-lexicals*) (lookup-macro-def fn-name *symbol-macro-env*))
collect (if (or (member fn-name *enclosing-lexicals*)
(lookup-macro-def fn-name *symbol-macro-env*))
(ps-gensym (string fn-name))
fn-name)))
(define-expression-operator flet (fn-defs &rest body)
(let* ((fn-renames (collect-function-names fn-defs))
(let* ((fn-renames (collect-function-names fn-defs))
;; the function definitions need to be compiled with previous lexical bindings
(fn-defs (loop for (fn-name . (args . body)) in fn-defs collect
(progn (when compile-expression?
(push (getf fn-renames fn-name) *enclosing-lexical-block-declarations*))
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf fn-renames fn-name)
(multiple-value-bind (args1 body-block)
(compile-named-function-body fn-name args body)
`(ps-js:lambda ,args1 ,body-block))))))
(fn-defs
(loop for (fn-name . (args . body)) in fn-defs collect
(progn (when compile-expression?
(push (getf fn-renames fn-name)
*enclosing-lexical-block-declarations*))
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf fn-renames fn-name)
(multiple-value-bind (args1 body-block)
(compile-named-function-body fn-name args body)
`(ps-js:lambda ,args1 ,body-block))))))
;; the flet body needs to be compiled with the extended lexical environment
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals* (when in-loop-scope? (append fn-renames *loop-scope-lexicals*)))
(*local-function-names* (append fn-renames *local-function-names*)))
(*enclosing-lexicals*
(append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals*
(when in-loop-scope? (append fn-renames *loop-scope-lexicals*)))
(*local-function-names*
(append fn-renames *local-function-names*)))
`(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
,@fn-defs
,@(compile-progn body))))
(define-expression-operator labels (fn-defs &rest body)
(let* ((fn-renames (collect-function-names fn-defs))
(*local-function-names* (append fn-renames *local-function-names*))
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals* (when in-loop-scope? (append fn-renames *loop-scope-lexicals*))))
(let* ((fn-renames (collect-function-names fn-defs))
(*local-function-names* (append fn-renames *local-function-names*))
(*enclosing-lexicals* (append fn-renames *enclosing-lexicals*))
(*loop-scope-lexicals* (when in-loop-scope?
(append fn-renames *loop-scope-lexicals*))))
`(,(if compile-expression? 'ps-js:|,| 'ps-js:block)
,@(loop for (fn-name . (args . body)) in fn-defs collect
(progn (when compile-expression?
(push (getf *local-function-names* fn-name) *enclosing-lexical-block-declarations*))
(push (getf *local-function-names* fn-name)
*enclosing-lexical-block-declarations*))
(list (if compile-expression? 'ps-js:= 'ps-js:var)
(getf *local-function-names* fn-name)
(let ((*function-block-names* (list fn-name)))
......
......@@ -333,5 +333,5 @@
,@(finally loop))
,(aif (default-accum-var loop) it nil))))
(if (default-accum-var loop)
`((lambda () ,full))
`((lambda () ,full)) ;; this needs to be generalized
full)))
......@@ -29,6 +29,7 @@
(define-statement-operator continue (&optional label)
`(ps-js:continue ,label))
;; todo: write CL equivalent
(define-statement-operator switch (test-expr &rest clauses)
`(ps-js:switch ,(compile-expression test-expr)
,@(loop for (val . body) in clauses collect
......@@ -108,9 +109,9 @@
(define-statement-operator for (init-forms cond-forms step-forms &body body)
(let ((init-forms (make-for-vars/inits init-forms)))
`(ps-js:for ,init-forms
,(mapcar #'compile-expression cond-forms)
,(mapcar #'compile-expression step-forms)
,(compile-loop-body (mapcar #'car init-forms) body))))
,(mapcar #'compile-expression cond-forms)
,(mapcar #'compile-expression step-forms)
,(compile-loop-body (mapcar #'car init-forms) body))))
(define-statement-operator for-in ((var object) &rest body)
`(ps-js:for-in ,(compile-expression var)
......
This diff is collapsed.
......@@ -29,7 +29,7 @@
(test-js-eval empty-array
(array)
(js-array (make-array 0 :adjustable t)))
(jsarray '()))
(test-js-eval funargs-let1
((lambda (x)
......@@ -101,7 +101,13 @@
(one-plus (if false 1 (loop for i from 0 to 10 sum i))))
56)
;;; broken
(test-js-eval case-return-break1-broken-return
(progn (defun foo (x y)
(case x
("bar" (if y (return-from foo 1)))
("baz" 2)))
(list (foo "bar" t) (foo "bar" nil) (foo "baz" nil)))
(jsarray '(1 :undefined 2)))
(test-js-eval funcall-loop-doing
((lambda (x) x)
......@@ -112,19 +118,19 @@
((lambda () (1+ (block nil (return 4) (+ 1 2)))))
5)
(test-js-eval block-dynamic-return
(block nil (return 4) (+ 1 2))
4)
(test-js-eval block-lambda-dynamic-return
(block nil ((lambda () (return 4))) (+ 1 2))
4)
(test-js-eval block-dynamic-setf
(progn (defvar foo (block nil (return 4) (+ 1 2)))
foo)
4)
(test-js-eval block-dynamic-return1
(progn (defvar foo ((lambda ()
(block nil
((lambda () (return 6)))
(+ 1 2)))))
foo)
6)
(test-js-eval block-lambda-dynamic-setf
(progn (defvar foo (block nil ((lambda () (return 4))) (+ 1 2)))
foo)
......@@ -133,3 +139,29 @@
(test-js-eval block-lambda-dynamic-lambda
((lambda () (block nil ((lambda () (return 4))) (+ 1 2))))
4)
(test-js-eval return-from-flet
(progn (defun foo ()
(flet ((bar () (return-from foo 42)))
(bar)))
(foo))
42)
(test-js-eval plus-block
(1+ (block nil (return 4) (+ 1 2)))
5)
;;; broken
(test-js-eval block-dynamic-return
(block nil (return 4) (+ 1 2))
4)
(test-js-eval block-lambda-dynamic-return
(block nil ((lambda () (return 4))) (+ 1 2))
4)
(test-js-eval dolist-return
(dolist (x '(5 2 3))
(return (1+ x)))
6)
\ No newline at end of file
......@@ -2340,6 +2340,42 @@ a === b;")
blee();
};")
(test-ps-js block-return-from1
(lambda ()
(block scope
(foo)
(when (bar)
(return-from scope))
(blee))
(+ 1 2))
"(function () {
scope: {
foo();
if (bar()) {
break scope;
};
blee();
};
return 1 + 2;
});")
(test-ps-js block-return-from2
(lambda ()
(bar 5)
(block scope
(foo)
(when (bar)
(return-from scope 6))
(blee)))
"(function () {
bar(5);
foo();
if (bar()) {
return 6;
};
return blee();
});")
(test-ps-js let-funcall
(let ((x foo))
(funcall x)
......@@ -2603,11 +2639,11 @@ foo = 3;")
};")
(test-ps-js dynamic-extent-function-return
(defun foo () ((lambda () (return-from foo))))
(defun foo () ((lambda () (return-from foo 6))))
"function foo() {
try {
return (function () {
throw { 'ps-block-tag' : 'foo', 'ps-return-value' : null };
throw { 'ps-block-tag' : 'foo', 'ps-return-value' : 6 };
})();
} catch (err) {
if (err && 'foo' === err['ps-block-tag']) {
......@@ -2618,22 +2654,41 @@ foo = 3;")
};
};")
(test-ps-js block-dynamic-return ;; FIXME!!
(block nil ((lambda () (return))) (+ 1 2))
"nilBlock: {
(test-ps-js block-dynamic-return
(var foo ((lambda ()
(block nil
((lambda () (return 6)))
(+ 1 2)))))
"var foo = (function () {
try {
(function () {
throw { 'ps-block-tag' : 'nilBlock', 'ps-return-value' : null };
throw { 'ps-block-tag' : 'nilBlock', 'ps-return-value' : 6 };
})();
1 + 2;
return 1 + 2;
} catch (err) {
if (err && 'nilBlock' === err['ps-block-tag']) {
err['ps-return-value'];
return err['ps-return-value'];
} else {
throw err;
};
};
};")
})();")
(test-ps-js block-dynamic-return1
(var foo ((lambda ()
(block nil
((lambda () (return 6)))
(+ 1 2))
(foobar 1 2))))
"var foo = (function () {
nilBlock: {
(function () {
break nilBlock;
})();
1 + 2;
};
return foobar(1, 2);
})();")
(test-ps-js iteration-lambda-capture-no-need
(dolist (x y) (lambda (x) (1+ x))) ;; there's really no need to create a 'with' scope in this case
......@@ -2892,3 +2947,29 @@ function (x) {
return 1;
};
});")
(test-ps-js trivial-expression-switch
(foobar (case x (1 2)))
"foobar((function () {
switch (x) {
case 1:
return 2;
};
})());")
(test-ps-js trivial-expression-while
(foobar (while (< 0 x) (decf x)))
"foobar((function () {
while (0 < x) {
--x;
};
})());")
(test-ps-js funcall-block-expression-loop-lambda
(foobar (loop for i from 0 to 10 do (1+ i)))
"foobar((function () {
for (var i = 0; i <= 10; i += 1) {
i + 1;
};
return null;
})());")
......@@ -3,7 +3,7 @@
(defpackage #:ps-test
(:use #:cl #:parenscript #:eos)
(:export #:run-tests #:interface-function #:test-js-eval))
(:export #:run-tests #:interface-function #:test-js-eval #:jsarray))
(defpackage #:ps-eval-tests
(:use #:cl #:eos #:ps-test #:cl-js))
......@@ -45,6 +45,10 @@
,js-result
,result)))))))
(defun jsarray (contents)
(cl-js:js-array
(make-array (length contents) :initial-contents contents :adjustable t)))
(def-suite output-tests)
(def-suite package-system-tests)
(def-suite eval-tests)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment