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."
(*current-block-tag* nil)
(*vars-needing-to-be-declared* ())
(*used-up-names* ())
(returning-values? nil)
(append args *enclosing-function-arguments*))
(set-difference *enclosing-lexicals* args))
(collapse-function-return-blocks body))
;; probably buggy; this should be done after macroexpansion
(tree-find 'values collapsed-body))
(append (mapcar (lambda (x) (cons x nil))
......@@ -200,13 +200,12 @@
;;; multiple values
(defpsmacro multiple-value-bind (vars form &body body)
(let* ((form (ps-macroexpand form))
(when (and (consp form)
(car form)
'(with label let flet labels macrolet symbol-macrolet progn)))
(pop form))))
(let* ((form (ps-macroexpand form))
(progn-form (when (and (consp form)
(member (car form)
'(with label let flet labels
macrolet symbol-macrolet progn)))
(pop form))))
(if progn-form
,@(butlast form)
......@@ -214,23 +213,21 @@
,@(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 '())
(let ((,(car vars) ,form))
(destructuring-bind (&optional ,@(cdr vars))
(defpsmacro multiple-value-list (form)
(with-ps-gensyms (first-value values-list)
`(let* ((,first-value (progn
(setf __PS_MV_REG '())
(,values-list (funcall (getprop __PS_MV_REG 'slice))))
(funcall (getprop ,values-list 'unshift) ,first-value)
;;; conditionals
......@@ -509,9 +506,9 @@ lambda-list::=
(defpsmacro prog1 (first &rest others)
(with-ps-gensyms (val)
`(let ((,val ,first))
`(let ((,val (multiple-value-list ,first)))
(values-list ,val))))
(defpsmacro prog2 (first second &rest others)
`(progn ,first (prog1 ,second ,@others)))
......@@ -170,11 +170,7 @@
(define-statement-operator progn (&rest body)
`(ps-js:block ,@(compile-progn body)))
(defun fill-mv-reg (values)
`(setf __PS_MV_REG (create :tag (@ arguments callee)
:values ,values)))
(defvar suppress-values? nil)
(defvar returning-values? nil)
(defun wrap-for-dynamic-return (handled-tags body)
(aif (loop for (tag . thrown?) in *dynamic-return-tags*
......@@ -182,18 +178,18 @@
collect tag)
(with-ps-gensyms (_ps_err)
(flet ((make-catch-clause (tag)
`((and ,_ps_err (eql ',tag (getprop ,_ps_err :__ps_block_tag)))
,(fill-mv-reg `(getprop ,_ps_err :__ps_values))
(return-from ,tag (getprop ,_ps_err :__ps_value1)))))
`((and ,_ps_err (eql ',tag
(getprop ,_ps_err :__ps_block_tag)))
(return-from ,tag
(values-list (getprop ,_ps_err :__ps_values))))))
:catch (,_ps_err
,(let ((suppress-values? nil))
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err)))))))
:catch (,_ps_err
`(progn (cond
,@(mapcar #'make-catch-clause it)
(t (throw ,_ps_err))))))
:finally nil))))
......@@ -213,51 +209,47 @@
(ps-compile (with-lambda-scope `(block ,name ,@body)))))
(define-expression-operator values (&rest forms)
(with-ps-gensyms (val)
`(let ((,val ,(car forms)))
(setf __PS_MV_REG (list ,@(cdr forms)))
(define-expression-operator values-list (list)
(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)
(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
:__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
((eql tag *current-block-tag*)
,@(unless returning-values? '((setf __PS_MV_REG '())))
,@(when value? (list value))
(break ,tag))))
((assoc tag *dynamic-return-tags*)
(setf (cdr it) t)
,@(unless returning-values? '((setf __PS_MV_REG '())))
(throw (create
:__ps_block_tag ',tag
:__ps_values (multiple-value-list ,value))))))
(unless (or (eql '%function tag)
(member tag *function-block-names*))
(warn "Returning from unknown block ~A" tag))
(let ((X (when value? (list (compile-expression value)))))
(if returning-values?
`(ps-js:return ,@X)
(ps-js:= __PS_MV_REG [])
(ps-js:return ,@X)))))))
(defun try-expressionizing-if? (exp &optional (score 0)) ;; poor man's codewalker
"Heuristic that tries not to expressionize deeply nested if expressions."
......@@ -340,16 +332,27 @@
`(if ,(second form)
(return-from ,tag ,(third form))
,@(when (or in-case? (fourth form))
`((return-from ,tag ,(fourth form)))))))
`((return-from ,tag ,(fourth form)))))))
(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*))
(*dynamic-return-tags* (cons (cons tag¹ nil)
(let* ((tag (or (cadr form) 'nilBlock))
(*function-block-names* (cons tag *function-block-names*))
(*dynamic-return-tags* (cons (cons tag nil)
(return-from return-result-of
(list tag¹)
(list tag)
(ps-compile `(return-from ,tag (progn ,@(cddr form))))))))
(with-ps-gensyms (val)
`(let ((,val ,(cadr form)))
(setf __PS_MV_REG (list ,@(cddr form)))
(return-from ,tag ,val t))))
(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
(unless tag
(warn 'simple-style-warning
......@@ -364,19 +367,14 @@ Parenscript now implements implicit return, update your code! Things like (lambd
`(ps-js:block ,(compile-statement form) ,(return-exp tag)))
(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))
(let ((form (ps-macroexpand result)))
(if (or (atom form) (eq 'values (car form)))
(if (atom form)
(return-exp tag form)
(return-result-of tag form))))
(define-expression-operator values (&optional main &rest additional)
(when main
(ps-compile (if additional
`(prog1 ,main ,@additional)
(define-statement-operator throw (&rest 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
in :compile-toplevel and :load-toplevel sitations, and Parenscript
code in :execute."
(when (and (member :compile-toplevel situation-list)
(member *compilation-level* '(:toplevel :inside-toplevel-form)))
(member *compilation-level* '(:toplevel :inside-toplevel-form)))
(eval `(progn ,@body)))
(if (member :execute situation-list)
(ps-compile `(progn ,@body))
Supports Markdown
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