Commit b1ea49e1 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

cmp: fix evaluation order of multiple-value-setq with symbol-macrolet

If a variable which is set with multiple-value-setq is bound to a
symbol-macro, we need to handle the order of side-effects as in setf.

Previously, we were first evaluating the value generating form
of the multiple-value-setq before setting the places from the
symbol-macro. The correct order is to first evaluate the forms from
the symbol macro giving the places to set, then evaluate the value
generating form from the multiple-value-setq and then set the places
to the generated values.
parent 80c53f0e
......@@ -120,30 +120,41 @@
(unwind-exit 'VALUES)
(close-inline-blocks)))))
(defun c1multiple-value-setq (args &aux (vars nil) (temp-vars nil)
(late-bindings nil))
(defun c1multiple-value-setq (args &aux (vars nil) (value-bindings nil)
(storing-forms nil) (return-value nil))
(check-args-number 'MULTIPLE-VALUE-SETQ args 2 2)
(dolist (var (reverse (first args)))
;; check for symbol-macrolets and insert type checks if necessary
(cmpck (not (symbolp var)) "The variable ~s is not a symbol." var)
(let* ((var-or-form (chk-symbol-macrolet var))
(type t))
(unless (when (symbolp var-or-form)
(cmpck (constantp var-or-form)
"The constant ~s is being assigned a value." var-or-form)
(when (or (not (policy-type-assertions))
(trivial-type-p
(setf type (variable-type-in-env var-or-form))))
(push var-or-form vars)
t))
(let ((new-var (gensym)))
(push new-var vars)
(push new-var temp-vars)
(push `(setf ,var-or-form (checked-value ,type ,new-var)) late-bindings)))))
(if (symbolp var-or-form)
(progn
(cmpck (constantp var-or-form)
"The constant ~s is being assigned a value." var-or-form)
(setf return-value var-or-form)
(if (or (not (policy-type-assertions))
(trivial-type-p
(setf type (variable-type-in-env var-or-form))))
(push var-or-form vars)
(let ((new-var (gensym)))
(push new-var vars)
(push new-var value-bindings)
(push `(setf ,var-or-form (checked-value ,type ,new-var)) storing-forms))))
(multiple-value-bind (setf-vars setf-vals stores storing-form get-form)
(get-setf-expansion var-or-form *cmp-env*)
(push (first stores) vars)
(setf value-bindings (nconc (mapcar #'list setf-vars setf-vals)
stores
value-bindings))
(push storing-form storing-forms)
(setf return-value get-form)))))
(let ((value (second args)))
(cond (temp-vars
`(let* (,@temp-vars)
(cond (value-bindings
`(let* (,@value-bindings)
(multiple-value-setq ,vars ,value)
,@late-bindings))
,@storing-forms
,return-value))
((endp vars)
`(values ,value))
((= (length vars) 1)
......
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