diff --git a/src/c/compiler.d b/src/c/compiler.d index 9653919f1..c4c5f58ab 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1490,40 +1490,34 @@ c_multiple_value_prog1(cl_object args, int flags) { static int -c_multiple_value_setq(cl_object args, int flags) { +c_multiple_value_setq(cl_object orig_args, int flags) { + cl_object args = orig_args; cl_object orig_vars; cl_object vars = Cnil; - cl_object temp_vars = Cnil; - cl_object late_assignment = Cnil; cl_object old_variables = ENV->variables; cl_index nvars = 0; /* Look for symbol macros, building the list of variables and the list of late assignments. */ for (orig_vars = pop(&args); !endp(orig_vars); ) { - cl_object aux, v = pop(&orig_vars); + cl_object v = pop(&orig_vars); if (!SYMBOLP(v)) FEillegal_variable_name(v); v = c_macro_expand1(v); if (!SYMBOLP(v)) { - aux = v; - v = @gensym(0); - temp_vars = CONS(v, temp_vars); - late_assignment = CONS(cl_list(3, @'setf', aux, v), - late_assignment); + /* If any of the places to be set is not a variable, + * transform MULTIPLE-VALUE-SETQ into (SETF (VALUES ...)) + */ + args = orig_args; + return compile_form(cl_listX(3, @'setf', + CONS(@'values', CAR(args)), + CDR(args)), + flags); } vars = CONS(v, vars); nvars++; } - if (!Null(temp_vars)) { - do { - compile_form(Cnil, FLAG_REG0); - c_bind(CAR(temp_vars), Cnil); - temp_vars = CDR(temp_vars); - } while (!Null(temp_vars)); - } - /* Compile values */ compile_form(pop(&args), FLAG_VALUES); if (args != Cnil) @@ -1537,10 +1531,7 @@ c_multiple_value_setq(cl_object args, int flags) { vars = cl_nreverse(vars); while (nvars--) { cl_object var = pop(&vars); - cl_fixnum ndx; - if (!SYMBOLP(var)) - FEillegal_variable_name(var); - ndx = c_var_ref(var,0); + cl_fixnum ndx = c_var_ref(var,0); if (ndx < 0) { /* Global variable */ if (var->symbol.stype == stp_constant) FEassignment_to_constant(var); @@ -1549,12 +1540,6 @@ c_multiple_value_setq(cl_object args, int flags) { asm_arg(ndx); } - /* Assign to symbol-macros */ - if (!Null(late_assignment)) { - asm_op(OP_PUSHVALUES); - compile_body(late_assignment, FLAG_VALUES); - asm_op(OP_POPVALUES); - } c_undo_bindings(old_variables); return FLAG_VALUES; diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 44a57c5d3..0f60fa91d 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -615,27 +615,28 @@ Returns the car of the old value in PLACE." ,store-form))))) (define-setf-expander values (&rest values &environment env) - (let ((vars '()) - (vals '()) - (stores '()) - (storing-form '()) - (get-form '())) - (dolist (item (nreverse values)) - (multiple-value-bind (v vr s sf gf) - (get-setf-expansion item) + (let ((all-vars '()) + (all-vals '()) + (all-stores '()) + (all-storing-forms '()) + (all-get-forms '())) + (dolist (item (reverse values)) + (multiple-value-bind (vars vals stores storing-form get-form) + (get-setf-expansion item env) ;; If a place has more than one store variable, the other ones ;; are set to nil. - (let ((extra (rest s))) + (let ((extra (rest stores))) (unless (endp extra) - (setf vars (append endp vars) - vals (append (make-list (length s)) vals) - s (list (first s))))) - (setf vars (append vr vars) - vals (append v vals) - stores (append s stores) - storing-form (cons sf storing-form) - get-form (cons gf get-form)))) - (values vars vals stores `(values ,@storing-form) `(values ,@get-form)))) + (setf all-vars (append extra all-vars) + all-vals (append (make-list (length extra)) all-vals) + all-stores (list (first stores))))) + (setf all-vars (append vars all-vars) + all-vals (append vals all-vals) + all-stores (append stores all-stores) + all-storing-forms (cons storing-form all-storing-forms) + all-get-forms (cons get-form all-get-forms)))) + (values all-vars all-vals all-stores `(values ,@all-storing-forms) + `(values ,@all-get-forms)))) #| ;;; Proposed extension: ; Expansion of (SETF (VALUES place1 ... placek) form)