Verified Commit 762c048d authored by Vladimir Sedach's avatar Vladimir Sedach
Browse files

Initial merge of Jason Miller's multiple value implementation

parents 4207b3b0 3c8c6bed
...@@ -163,15 +163,13 @@ of (declare ...) forms, and the remaining body." ...@@ -163,15 +163,13 @@ of (declare ...) forms, and the remaining body."
(*current-block-tag* nil) (*current-block-tag* nil)
(*vars-needing-to-be-declared* ()) (*vars-needing-to-be-declared* ())
(*used-up-names* ()) (*used-up-names* ())
(returning-values? nil)
(*enclosing-function-arguments* (*enclosing-function-arguments*
(append args *enclosing-function-arguments*)) (append args *enclosing-function-arguments*))
(*enclosing-lexicals* (*enclosing-lexicals*
(set-difference *enclosing-lexicals* args)) (set-difference *enclosing-lexicals* args))
(collapsed-body (collapsed-body
(collapse-function-return-blocks body)) (collapse-function-return-blocks body))
(suppress-values?
;; probably buggy; this should be done after macroexpansion
(tree-find 'values collapsed-body))
(*dynamic-return-tags* (*dynamic-return-tags*
(append (mapcar (lambda (x) (cons x nil)) (append (mapcar (lambda (x) (cons x nil))
*function-block-names*) *function-block-names*)
......
...@@ -200,13 +200,12 @@ ...@@ -200,13 +200,12 @@
;;; multiple values ;;; multiple values
(defpsmacro multiple-value-bind (vars form &body body) (defpsmacro multiple-value-bind (vars form &body body)
(let* ((form (ps-macroexpand form)) (let* ((form (ps-macroexpand form))
(progn-form (progn-form (when (and (consp form)
(when (and (consp form) (member (car form)
(member '(with label let flet labels
(car form) macrolet symbol-macrolet progn)))
'(with label let flet labels macrolet symbol-macrolet progn))) (pop form))))
(pop form))))
(if progn-form (if progn-form
`(,progn-form `(,progn-form
,@(butlast form) ,@(butlast form)
...@@ -214,23 +213,21 @@ ...@@ -214,23 +213,21 @@
,@(last form) ,@(last form)
,@body)) ,@body))
;; assume function call ;; assume function call
(with-ps-gensyms (prev-mv) `(progn
(let* ((fun-exp (car form)) (setf __PS_MV_REG '())
(funobj (if (symbolp fun-exp) (let ((,(car vars) ,form))
fun-exp (destructuring-bind (&optional ,@(cdr vars))
(ps-gensym 'funobj)))) __PS_MV_REG
`(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp))) ,@body))))))
(,prev-mv (if (undefined __PS_MV_REG)
(setf __PS_MV_REG undefined) (defpsmacro multiple-value-list (form)
__PS_MV_REG))) (with-ps-gensyms (first-value values-list)
(try `(let* ((,first-value (progn
(let ((,(car vars) (,funobj ,@(cdr form)))) (setf __PS_MV_REG '())
(destructuring-bind (&optional ,@(cdr vars)) ,form))
(if (eql ,funobj (@ __PS_MV_REG :tag)) (,values-list (funcall (getprop __PS_MV_REG 'slice))))
(@ __PS_MV_REG :values) (funcall (getprop ,values-list 'unshift) ,first-value)
(list)) ,values-list)))
,@body))
(:finally (setf __PS_MV_REG ,prev-mv)))))))))
;;; conditionals ;;; conditionals
...@@ -509,9 +506,9 @@ lambda-list::= ...@@ -509,9 +506,9 @@ lambda-list::=
(defpsmacro prog1 (first &rest others) (defpsmacro prog1 (first &rest others)
(with-ps-gensyms (val) (with-ps-gensyms (val)
`(let ((,val ,first)) `(let ((,val (multiple-value-list ,first)))
,@others ,@others
,val))) (values-list ,val))))
(defpsmacro prog2 (first second &rest others) (defpsmacro prog2 (first second &rest others)
`(progn ,first (prog1 ,second ,@others))) `(progn ,first (prog1 ,second ,@others)))
......
...@@ -170,11 +170,7 @@ ...@@ -170,11 +170,7 @@
(define-statement-operator progn (&rest body) (define-statement-operator progn (&rest body)
`(ps-js:block ,@(compile-progn body))) `(ps-js:block ,@(compile-progn body)))
(defun fill-mv-reg (values) (defvar returning-values? nil)
`(setf __PS_MV_REG (create :tag (@ arguments callee)
:values ,values)))
(defvar suppress-values? nil)
(defun wrap-for-dynamic-return (handled-tags body) (defun wrap-for-dynamic-return (handled-tags body)
(aif (loop for (tag . thrown?) in *dynamic-return-tags* (aif (loop for (tag . thrown?) in *dynamic-return-tags*
...@@ -182,18 +178,18 @@ ...@@ -182,18 +178,18 @@
collect tag) collect tag)
(with-ps-gensyms (_ps_err) (with-ps-gensyms (_ps_err)
(flet ((make-catch-clause (tag) (flet ((make-catch-clause (tag)
`((and ,_ps_err (eql ',tag (getprop ,_ps_err :__ps_block_tag))) `((and ,_ps_err (eql ',tag
,(fill-mv-reg `(getprop ,_ps_err :__ps_values)) (getprop ,_ps_err :__ps_block_tag)))
(return-from ,tag (getprop ,_ps_err :__ps_value1))))) (return-from ,tag
(values-list (getprop ,_ps_err :__ps_values))))))
`(ps-js:block `(ps-js:block
(ps-js:try (ps-js:try
,body ,body
:catch (,_ps_err :catch (,_ps_err
,(let ((suppress-values? nil)) ,(compile-statement
(compile-statement `(progn (cond
`(progn (cond ,@(mapcar #'make-catch-clause it)
,@(mapcar #'make-catch-clause it) (t (throw ,_ps_err))))))
(t (throw ,_ps_err)))))))
:finally nil)))) :finally nil))))
body)) body))
...@@ -213,51 +209,47 @@ ...@@ -213,51 +209,47 @@
compiled-body)) compiled-body))
(ps-compile (with-lambda-scope `(block ,name ,@body))))) (ps-compile (with-lambda-scope `(block ,name ,@body)))))
(define-expression-operator values (&rest forms)
(ps-compile
(with-ps-gensyms (val)
`(let ((,val ,(car forms)))
(setf __PS_MV_REG (list ,@(cdr forms)))
,val))))
(define-expression-operator values-list (list)
(ps-compile
(with-ps-gensyms (values-list firstval)
`(let ((,values-list (funcall (getprop ,list 'slice))))
(setf ,firstval (funcall (getprop ,values-list 'shift))
__PS_MV_REG ,values-list)
,firstval))))
(defun return-exp (tag &optional (value nil value?)) (defun return-exp (tag &optional (value nil value?))
(let (rest-values) (acond
(when (and (consp value) (eq 'values (car value))) ; multiple value return? ((eql tag *current-block-tag*)
(setf rest-values (cddr value) value (cadr value))) (compile-statement
(flet ((ret1only () `(progn
(let ((ret `(ps-js:return ,@(unless returning-values? '((setf __PS_MV_REG '())))
,@(when value? ,@(when value? (list value))
(list (compile-expression value)))))) (break ,tag))))
(if suppress-values? ((assoc tag *dynamic-return-tags*)
`(ps-js:block (ps-js:= __PS_MV_REG {}) (setf (cdr it) t)
,ret) (ps-compile
ret))) `(progn
(fill-mv () ,@(unless returning-values? '((setf __PS_MV_REG '())))
(fill-mv-reg `(list ,@rest-values)))) (throw (create
(acond ((eql tag *current-block-tag*) :__ps_block_tag ',tag
(compile-statement :__ps_values (multiple-value-list ,value))))))
(if value? (t
`(progn ,value (unless (or (eql '%function tag)
,@(when rest-values (list (fill-mv))) (member tag *function-block-names*))
(break ,tag)) (warn "Returning from unknown block ~A" tag))
`(break ,tag)))) (let ((X (when value? (list (compile-expression value)))))
((or (eql '%function tag) (if returning-values?
(member tag *function-block-names*)) `(ps-js:return ,@X)
(if rest-values `(ps-js:block
(let* ((cvalue (compile-expression value)) (ps-js:= __PS_MV_REG [])
(val1 (unless (or (constantp cvalue) (ps-js:return ,@X)))))))
(symbolp cvalue))
(ps-gensym 'val1_))))
(let ((suppress-values? nil))
(compile-statement
`(let ,(when val1 `((,val1 ,value)))
,(fill-mv)
(return-from ,tag ,(or val1 value))))))
(ret1only)))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
(ps-compile
`(throw (create
:__ps_block_tag ',tag
:__ps_value1 ,value
,@(when rest-values
`(:__ps_values (list ,@rest-values)))))))
(t
(warn "Returning from unknown block ~A" tag)
(ret1only)))))) ;; for backwards-compatibility
(defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker (defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
"Heuristic that tries not to expressionize deeply nested if expressions." "Heuristic that tries not to expressionize deeply nested if expressions."
...@@ -340,16 +332,27 @@ ...@@ -340,16 +332,27 @@
`(if ,(second form) `(if ,(second form)
(return-from ,tag ,(third form)) (return-from ,tag ,(third form))
,@(when (or in-case? (fourth form)) ,@(when (or in-case? (fourth form))
`((return-from ,tag ,(fourth form))))))) `((return-from ,tag ,(fourth form)))))))
(block (block
(let* ((tag¹ (or (cadr form) 'nilBlock)) (let* ((tag (or (cadr form) 'nilBlock))
  • Changing the superscript to subscript makes this fail when the input encoding is latin-1; this means it fails at least on lispworks. Lispworks can read a header when compiling files to fix lispworks, or we could change it back to a subscript which creates a valid latin-1 interpretation of the file.

Please register or sign in to reply
(*function-block-names* (cons tag¹ *function-block-names*)) (*function-block-names* (cons tag *function-block-names*))
(*dynamic-return-tags* (cons (cons tag¹ nil) (*dynamic-return-tags* (cons (cons tag nil)
*dynamic-return-tags*))) *dynamic-return-tags*)))
(return-from return-result-of (return-from return-result-of
(wrap-for-dynamic-return (wrap-for-dynamic-return
(list tag¹) (list tag)
(ps-compile `(return-from ,tag (progn ,@(cddr form)))))))) (ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
(values
(with-ps-gensyms (val)
`(let ((,val ,(cadr form)))
(setf __PS_MV_REG (list ,@(cddr form)))
(return-from ,tag ,val t))))
(values-list
(with-ps-gensyms (values-list firstval)
`(let ((,values-list (funcall (getprop ,(cadr form) 'slice))))
(setf ,firstval (funcall (getprop ,values-list 'shift))
__PS_MV_REG ,values-list)
(return-from ,tag ,firstval t))))
(return-from ;; this will go away someday (return-from ;; this will go away someday
(unless tag (unless tag
(warn 'simple-style-warning (warn 'simple-style-warning
...@@ -364,19 +367,14 @@ Parenscript now implements implicit return, update your code! Things like (lambd ...@@ -364,19 +367,14 @@ Parenscript now implements implicit return, update your code! Things like (lambd
`(ps-js:block ,(compile-statement form) ,(return-exp tag))) `(ps-js:block ,(compile-statement form) ,(return-exp tag)))
(t (compile-statement form)))))))) (t (compile-statement form))))))))
(define-statement-operator return-from (tag &optional result) (define-statement-operator return-from (tag &optional
result returning-values?)
(setq tag (or tag 'nilBlock)) (setq tag (or tag 'nilBlock))
(let ((form (ps-macroexpand result))) (let ((form (ps-macroexpand result)))
(if (or (atom form) (eq 'values (car form))) (if (atom form)
(return-exp tag form) (return-exp tag form)
(return-result-of tag form)))) (return-result-of tag form))))
(define-expression-operator values (&optional main &rest additional)
(when main
(ps-compile (if additional
`(prog1 ,main ,@additional)
main))))
(define-statement-operator throw (&rest args) (define-statement-operator throw (&rest args)
`(ps-js:throw ,@(mapcar #'compile-expression args))) `(ps-js:throw ,@(mapcar #'compile-expression args)))
...@@ -684,7 +682,7 @@ and :execute. The code in BODY is assumed to be Common Lisp code ...@@ -684,7 +682,7 @@ and :execute. The code in BODY is assumed to be Common Lisp code
in :compile-toplevel and :load-toplevel sitations, and Parenscript in :compile-toplevel and :load-toplevel sitations, and Parenscript
code in :execute." code in :execute."
(when (and (member :compile-toplevel situation-list) (when (and (member :compile-toplevel situation-list)
(member *compilation-level* '(:toplevel :inside-toplevel-form))) (member *compilation-level* '(:toplevel :inside-toplevel-form)))
(eval `(progn ,@body))) (eval `(progn ,@body)))
(if (member :execute situation-list) (if (member :execute situation-list)
(ps-compile `(progn ,@body)) (ps-compile `(progn ,@body))
......
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