Commit 3c8c6bed authored by Jason Miller's avatar Jason Miller
Browse files

Improve multiple-value support

Previously multiple-values were very fragile.

Examples of things that didn't work, but now do:

  (multiple-value-bind (x y) (values 1 2) y)

  (defun foo () (values 1 2))
  (defun bar () foo)
  (multiple-value-bind (x y) (bar) y)

Biggest downside of this change is that every return statement must be
prefixed by a clearing of the MV register.
parent b51f35a7
......@@ -163,23 +163,22 @@
,@(last form)
;; assume function call
(with-ps-gensyms (prev-mv)
(let* ((fun-exp (car form))
(funobj (if (symbolp fun-exp)
(ps-gensym "funobj"))))
`(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp)))
(,prev-mv (if (undefined __PS_MV_REG)
(setf __PS_MV_REG undefined)
(let ((,(car vars) (,funobj ,@(cdr form))))
(destructuring-bind (&optional ,@(cdr vars))
(if (eql ,funobj (@ __PS_MV_REG :tag))
(@ __PS_MV_REG :values)
(:finally (setf __PS_MV_REG ,prev-mv)))))))))
(setf __PS_MV_REG (list))
(let ((,(car vars) ,form))
(destructuring-bind (&optional ,@(cdr vars))
(defpsmacro multiple-value-list (form)
(with-ps-gensyms (first rest)
`(let* ((,first
(setf __PS_MV_REG (list))
(,rest (chain __PS_MV_REG (slice))))
(chain ,rest (unshift ,first))
;;; conditionals
......@@ -459,10 +458,11 @@ lambda-list::=
(:finally ,cleanup-form)))
(defpsmacro prog1 (first &rest others)
(with-ps-gensyms (val)
`(let ((,val ,first))
(with-ps-gensyms (val vals)
(let* ((,val (multiple-value-list first)))
(defpsmacro prog2 (first second &rest others)
`(progn ,first (prog1 ,second ,@others)))
......@@ -133,10 +133,9 @@
`(ps-js:block ,@(compile-progn body)))
(defun fill-mv-reg (values)
`(setf __PS_MV_REG (create :tag (@ arguments callee)
:values ,values)))
`(setf __PS_MV_REG (list ,@values)))
(defvar suppress-values? nil)
(defvar *ignore-values* nil)
(defun wrap-for-dynamic-return (handled-tags body)
(aif (loop for (tag . thrown?) in *dynamic-return-tags*
......@@ -151,11 +150,10 @@
:catch (,_ps_err
,(let ((suppress-values? nil))
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err)))))))
(t (throw ,_ps_err))))))
:finally nil))))
......@@ -174,50 +172,44 @@
(ps-compile (with-lambda-scope `(block ,name ,@body)))))
(defun return-exp (tag &optional (value nil value?))
(let (rest-values)
(when (and (consp value) (eq 'values (car value))) ; multiple value return?
(setf rest-values (cddr value) value (cadr value)))
(flet ((ret1only ()
(let ((ret `(ps-js:return
,@(when value?
(list (compile-expression value))))))
(if suppress-values?
`(ps-js:block (ps-js:= __PS_MV_REG {})
(fill-mv ()
(fill-mv-reg `(list ,@rest-values))))
(acond ((eql tag *current-block-tag*)
(if value?
`(progn ,value
,@(when rest-values (list (fill-mv)))
(break ,tag))
`(break ,tag))))
((or (eql '%function tag)
(member tag *function-block-names*))
(if rest-values
(let* ((cvalue (compile-expression value))
(val1 (unless (or (constantp cvalue)
(symbolp cvalue))
(ps-gensym "VAL1_"))))
(let ((suppress-values? nil))
`(let ,(when val1 `((,val1 ,value)))
(return-from ,tag ,(or val1 value))))))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
`(throw (create
(flet ((ret1only ()
(let* ((ret-expr (when value?
(list (compile-expression value))))
(or *ignore-values*
(and value? (consp value) (eql (car value) 'values)))))
`(ps-js:return ,@ret-expr))
((not value?)
(ps-js:= __PS_MV_REG [])
(ps-js:= __PS_MV_REG [])
(ps-js:return ,@ret-expr)))))))
(acond ((eql tag *current-block-tag*)
(if value?
`(progn ,value
(break ,tag))
`(break ,tag))))
((or (eql '%function tag)
(member tag *function-block-names*))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
'(ps-js:= __PS_MV_REG [])
(throw (create
:__ps_block_tag ',tag
:__ps_value1 ,value
,@(when rest-values
`(:__ps_values (list ,@rest-values)))))))
(warn "Returning from unknown block ~A" tag)
(ret1only)))))) ;; for backwards-compatibility
:__ps_values __PS_MV_REG)))))
(warn "Returning from unknown block ~A" tag)
(ret1only))))) ;; for backwards-compatibility
(defvar *suppress-deprecation* nil
"Temporarily turns off deprecation warnings so that the compiler can
......@@ -322,16 +314,26 @@ Parenscript now implements implicit return, update your code! Things like (lambd
(define-statement-operator return-from (tag &optional result)
(if tag
(let ((form (ps-macroexpand result)))
(if (or (atom form) (eq 'values (car form)))
(if (or (atom form) #+(or)(eq 'values (car form)))
(return-exp tag form)
(expressionize-result tag form)))
(ps-compile `(return-from nilBlock ,result))))
(define-expression-operator values (&optional main &rest additional)
(when main
(ps-compile (if additional
`(prog1 ,main ,@additional)
(define-expression-operator values (&rest forms)
(with-ps-gensyms (val)
(let ((*ignore-values* t))
`(let ((,val ,(car forms)))
(setf __PS_MV_REG (list ,@(cdr forms)))
(define-expression-operator values-list (item)
(with-ps-gensyms (result firstval)
`(let ((,result (chain ,item (slice))))
(setf ,firstval (chain ,result (shift)))
(setf __PS_MV_REG ,result)
(define-statement-operator throw (&rest args)
`(ps-js:throw ,@(mapcar #'compile-expression args)))
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