Commit 75f66e6b authored by Vladimir Sedach's avatar Vladimir Sedach

Full multiple values implementation. Works correctly but produces ugly code....

Full multiple values implementation. Works correctly but produces ugly code. This is here for later use, but will be rolled back in the next patch.
parent 220a9f60
......@@ -115,6 +115,16 @@ block.")
(defvar *current-block-tag* nil
"Name of the lexically enclosing block, if any.")
(defvar *returning-multiple-values* nil
"Does the function being compiled return multiple values? If so, the
value of this variable is the gensym that will hold the MV array.")
(defvar values-thrown? nil
"To be used with *dynamic-return-tags*")
(defun mv-return-arr ()
(or *returning-multiple-values*
(setf *returning-multiple-values* (ps-gensym "__mv_return_array"))))
(defvar *special-variables* ()
"Special variables declared during any Parenscript run. Re-bind this if you want to clear the list.")
......
......@@ -112,23 +112,29 @@ Syntax of key spec:
(defun compile-function-body (args body)
(with-declaration-effects (body body)
(let* ((in-function-scope? t)
(*vars-needing-to-be-declared* ())
(*used-up-names* ())
(let* ((in-function-scope? t)
(*returning-multiple-values* nil)
(*vars-needing-to-be-declared* ())
(*used-up-names* ())
(*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*))
(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)))))
(*loop-scope-lexicals* ())
(*loop-scope-lexicals-captured* ()))
(cdr
(wrap-for-dynamic-return
*function-block-names*
(compile-statement
`(return-from %function (progn ,@collapsed-body)))))))
(var-decls
(compile-statement
`(progn
......@@ -141,7 +147,10 @@ Syntax of key spec:
(append (intersection (flatten body) *loop-scope-lexicals*)
*loop-scope-lexicals-captured*)))
`(ps-js:block ,@(reverse (cdr var-decls))
,@(cdr (wrap-for-dynamic-return *function-block-names* body))))))
,@(awhen *returning-multiple-values*
(list (compile-statement `(var ,it #1=(@ arguments callee __ps_mv)))
(compile-statement `(delete #1#))))
,@body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; lambda
......
......@@ -119,23 +119,27 @@
(car form)
'(with label let flet labels macrolet symbol-macrolet progn)))
(pop form))))
(with-ps-gensyms (mv prev-mv)
`(let (,prev-mv)
(,(or progn-form 'progn)
,@(when progn-form (butlast form))
(setf ,prev-mv (@ arguments :callee :mv))
(try
(progn
(setf (@ arguments :callee :mv) t)
(let ((,(car vars) ,(if progn-form (car (last form)) form))
(,mv (if (objectp (@ arguments :callee :mv))
(@ arguments :callee :mv)
(make-array ,(1- (length vars))))))
(destructuring-bind ,(cdr vars) ,mv
,@body)))
(:finally (if (undefined ,prev-mv)
(delete (@ arguments :callee :mv))
(setf (@ arguments :callee :mv) ,prev-mv)))))))))
(if progn-form
`(,progn-form
,@(butlast form)
(multiple-value-bind ,vars
,@(last form)
,@body))
;; assume function call
(with-ps-gensyms (funobj prev-mv mv)
`(let ((,funobj ,(car form))
,prev-mv)
(progn
(setf ,prev-mv (@ ,funobj __ps_mv))
(try
(let ((,mv []))
(setf (@ ,funobj __ps_mv) ,mv)
(let ((,(car vars) (,funobj ,@(cdr form))))
(destructuring-bind (&optional ,@(cdr vars)) ,mv
,@body)))
(:finally (if (undefined ,prev-mv)
(delete (@ ,funobj __ps_mv))
(setf (@ ,funobj __ps_mv) ,prev-mv))))))))))
;;; conditionals
......
......@@ -132,31 +132,33 @@
(aif (loop for (tag . thrown?) in *dynamic-return-tags*
when (and thrown? (member tag handled-tags))
collect tag)
`(ps-js:block
(ps-js:try
,body
:catch
(err
,(compile-statement
`(progn
(cond
,@(loop for tag in it collect
`((and err (eql ',tag (getprop err :ps-block-tag)))
;; FIXME make this a multiple-value return
(when (and (@ arguments :callee :caller)
(defined (@ arguments :callee :caller :mv)))
(setf (@ arguments :callee :caller :mv)
(getprop err :ps-return-mv-rest)))
(return-from ,tag (getprop err :ps-return-value))))
(t (throw err))))))
:finally nil))
body))
(with-ps-gensyms (_ps_err mvs i)
(flet ((make-catch-clause (tag)
`((and ,_ps_err (eql ',tag (getprop ,_ps_err :ps-block-tag)))
,@(when values-thrown?
`((let ((,mvs (getprop ,_ps_err :ps-return-mv-rest)))
(when ,mvs
(dotimes (,i (length ,mvs))
(setf (aref ,(mv-return-arr) ,i)
(aref ,mvs ,i)))))))
(return-from ,tag (getprop ,_ps_err :ps-return-value)))))
`(ps-js:block
(ps-js:try
,body
:catch (,_ps_err
,(compile-statement
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err))))))
:finally nil))))
body))
(define-statement-operator block (name &rest body)
(if in-function-scope?
(let* ((name (or name 'nilBlock))
(in-loop-scope? (if name in-loop-scope? nil))
(*dynamic-return-tags* (cons (cons name nil) *dynamic-return-tags*))
(values-thrown? nil)
(*current-block-tag* name)
(compiled-body (wrap-for-dynamic-return
(list name)
......@@ -167,36 +169,60 @@
(ps-compile (with-lambda-scope `(block ,name ,@body)))))
(defun return-exp (tag &optional (value nil value?) rest-values)
(symbol-macrolet
((cvalue (when value? (list (compile-expression value))))
(crest (mapcar #'compile-expression rest-values)))
(acond ((eql tag *current-block-tag*) ;; fixme: multiple values
(if value?
`(ps-js:block ,@cvalue ,@crest (ps-js:break ,tag))
`(ps-js:break ,tag)))
(flet ((ret1only ()
(if value?
(let ((form (compile-expression value)))
(if (and (listp form) (eq 'ps-js:funcall (car form)))
(let ((value (if (eq (car value) 'funcall)
(cdr value)
value)))
(compile-statement
(with-ps-gensyms (funobj result)
`(let ((,funobj ,(car value)))
(setf (@ ,funobj __ps_mv) ,(mv-return-arr))
;; need a var because of inf. recursion
(let ((,result (funcall ,funobj ,@(cdr value))))
(unwind-protect
(return-from ,tag ,result)
(delete (@ ,funobj __ps_mv))))))))
`(ps-js:return ,form)))
`(ps-js:return)))
(fill-mv ()
(let ((values-array (mv-return-arr)))
`((setf ,values-array (or ,values-array []))
,@(loop for i from 0 for x in rest-values collect
`(setf (aref ,values-array ,i) ,x))))))
(acond ((eql tag *current-block-tag*)
(compile-statement
(if value?
`(progn ,value
,@(when rest-values (fill-mv))
(break ,tag))
`(break ,tag))))
((or (eql '%function tag)
(member tag *function-block-names*))
(if rest-values
(with-ps-gensyms (val1 valrest)
(with-ps-gensyms (val1)
(compile-statement
`(let ((,val1 ,value)
(,valrest (list ,@rest-values)))
(when (defined (@ arguments :callee :caller :mv))
(setf (@ arguments :callee :caller :mv) ,valrest))
`(let ((,val1 ,value))
,@(fill-mv)
(return-from ,tag ,val1))))
`(ps-js:return ,@cvalue)))
(ret1only)))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
(ps-compile `(throw (create
:ps-block-tag ',tag
:ps-return-value ,value
,@(when rest-values
`(:ps-return-mv-rest (list ,@rest-values)))))))
(ps-compile
`(throw (create
:ps-block-tag ',tag
:ps-return-value ,value
,@(when rest-values
(setf values-thrown? t)
`(:ps-return-mv-rest (list ,@rest-values)))))))
(t
(warn "Returning from unknown block ~A" tag)
`(ps-js:return ,@cvalue))))) ;; for backwards-compatibility
(ret1only))))) ;; for backwards-compatibility
(defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
"Heuristic that tries not to expressionize deeply nested if expressions."
(cond ((< 1 score) nil)
((and (listp exp) (eq (car exp) 'quote))
t)
......@@ -254,8 +280,9 @@
,@(when in-case? `((t (return-from ,tag nil))))))
(if
(if (and (try-expressionizing-if? form)
(let ((used-up-names *used-up-names*)
(*lambda-wrappable-statements* ()))
(not (find 'values (flatten form)))
(let ((used-up-names *used-up-names*)
(*lambda-wrappable-statements* ()))
(handler-case (compile-expression form)
(compile-expression-error ()
(setf *used-up-names* used-up-names)
......
......@@ -325,7 +325,7 @@
(values 1 2 3))
(multiple-value-bind (a b c) (foo)
(list a b c)))
'(1 2 3)) ;; cl-js doesn't define callee.caller - fixme
'(1 2 3))
(test-js-eval dynamic-extent-function-return-values
(progn (defun foo ()
......@@ -333,7 +333,7 @@
(return-from foo (values 1 2 3)))))
(multiple-value-bind (a b c) (foo)
(list a b c)))
'(1 2 3)) ;; cl-js doesn't define callee.caller - fixme
'(1 2 3))
(test-js-eval plus-not-associative
(let ((str "a")
......@@ -456,3 +456,18 @@
((t) 3)
(otherwise 7)))
6)
(test-js-eval multiple-value-call-twice
(progn
(defun foo (x &optional y z)
(if z
(values x y z)
(values x y)))
(defun bar ()
(foo 1 2 3)
(foo 4 5))
(multiple-value-bind (a b c) (bar)
(list a b c)))
'(4 5 :undefined))
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