diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 2b4cc0649d..20029f0324 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -512,12 +512,17 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure bool aokp = false; T_sp unknown_keys = nil(); vm._stackPointer = sp; - SimpleVector_sp argstemp = SimpleVector_O::make(key_count, unbound()); + if ((lcc_nargs > more_start) && (((lcc_nargs - more_start) % 2) != 0)) { + T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); + throwOddKeywordsError(tclosure); + } + // The parameter slots are themselves the destination, so no scratch vector + // is needed. stackref 0 is the most recently pushed, so slot n is key n. + for (size_t i = 0; i < key_count; ++i) + vm.push(sp, unbound().raw_()); + // The slots are live roots now, so the GC scanner must see them. + vm._stackPointer = sp; if (lcc_nargs > more_start) { - if (((lcc_nargs - more_start) % 2) != 0) { - T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); - throwOddKeywordsError(tclosure); - } // We grab keyword arguments from the end to the beginning. // This means that earlier arguments are put in their variables // last, matching the CL semantics. @@ -536,8 +541,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure T_O* ckey = literals[key_id + key_literal_start]; if (key == ckey) { valid_key_p = true; - T_sp value((gctools::Tagged)(lcc_args[arg_index])); - (*argstemp)[key_id] = value; + *vm.stackref(sp, key_id) = lcc_args[arg_index]; break; } } @@ -551,13 +555,6 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); throwUnrecognizedKeywordArgumentError(tclosure, unknown_keys); } - // Finally, push keys to the stack. - for (size_t i = 0; i < key_count; ++i) { - size_t key_id = key_count - i - 1; - T_sp key((gctools::Tagged)literals[key_id + key_literal_start]); - T_sp value = (*argstemp)[key_id]; - vm.push(sp, value.raw_()); - } pc++; break; } @@ -1299,12 +1296,16 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi bool aokp = false; T_sp unknown_keys = nil(); vm._stackPointer = sp; - SimpleVector_sp argstemp = SimpleVector_O::make(key_count, unbound()); + if ((lcc_nargs > more_start) && (((lcc_nargs - more_start) % 2) != 0)) { + T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); + throwOddKeywordsError(tclosure); + } + // See the short-operand form above; the parameter slots are the destination. + for (size_t i = 0; i < key_count; ++i) + vm.push(sp, unbound().raw_()); + // The slots are live roots now, so the GC scanner must see them. + vm._stackPointer = sp; if (lcc_nargs > more_start) { - if (((lcc_nargs - more_start) % 2) != 0) { - T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); - throwOddKeywordsError(tclosure); - } // KLUDGE: We use a signed type so that if more_start is zero we don't // wrap arg_index around. There's probably a cleverer solution. ptrdiff_t arg_index; @@ -1320,8 +1321,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi T_O* ckey = literals[key_id + key_literal_start]; if (key == ckey) { valid_key_p = true; - T_sp value((gctools::Tagged)(lcc_args[arg_index])); - (*argstemp)[key_id] = value; + *vm.stackref(sp, key_id) = lcc_args[arg_index]; break; } } @@ -1335,8 +1335,6 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi T_sp tclosure((gctools::Tagged)gctools::tag_general(closure)); throwUnrecognizedKeywordArgumentError(tclosure, unknown_keys); } - for (size_t i = 0; i < key_count; ++i) - vm.push(sp, (*argstemp)[key_count - i - 1].raw_()); pc += 7; break; } diff --git a/src/lisp/regression-tests/misc.lisp b/src/lisp/regression-tests/misc.lisp index 118a1dc0e9..dc65e962a6 100644 --- a/src/lisp/regression-tests/misc.lisp +++ b/src/lisp/regression-tests/misc.lisp @@ -321,3 +321,46 @@ (test single-value-catch (let ((c (catch 'foo 4))) c) (4)) + +;;; parse-key-args in the bytecode VM writes each keyword argument straight into +;;; the callee's parameter slot. An off-by-one or reversed slot index there binds +;;; the wrong parameter with no error at all, so pin the identity for every shape. +(defun kwtest-3 (a &key x y z) (list a x y z)) + +(test-true keyword-parsing-slot-identity + (and (equal (kwtest-3 0) '(0 nil nil nil)) + (equal (kwtest-3 0 :x 1) '(0 1 nil nil)) + (equal (kwtest-3 0 :y 2) '(0 nil 2 nil)) + (equal (kwtest-3 0 :z 3) '(0 nil nil 3)) + (equal (kwtest-3 0 :x 1 :y 2 :z 3) '(0 1 2 3)) + (equal (kwtest-3 0 :z 3 :y 2 :x 1) '(0 1 2 3)) + (equal (kwtest-3 0 :y 2 :z 3 :x 1) '(0 1 2 3)) + (equal (kwtest-3 0 :x 1 :z 3) '(0 1 nil 3)))) + +;;; CLHS 3.4.1.4: when a keyword is repeated the leftmost pair wins. The VM gets +;;; this by scanning arguments right to left and overwriting. +(test-true keyword-parsing-duplicate-keywords + (and (equal (kwtest-3 0 :x 'first :x 'second) '(0 first nil nil)) + (equal (kwtest-3 0 :x 'a :x 'b :x 'c) '(0 a nil nil)) + (equal (kwtest-3 0 :x 'a :y 'p :x 'b) '(0 a p nil)))) + +(defun kwtest-aok (&key x &allow-other-keys) x) + +(test-true keyword-parsing-allow-other-keys + (and (eql 1 (kwtest-aok :x 1 :bogus 2)) + (equal (kwtest-3 0 :x 1 :allow-other-keys t :bogus 9) '(0 1 nil nil)) + (eq :errored (handler-case (progn (kwtest-3 0 :bogus 1) :no-error) + (error () :errored))) + (eq :errored (handler-case (progn (apply #'kwtest-3 0 '(:x)) :no-error) + (error () :errored))))) + +(defun kwtest-16 (&key a b c d e f g h i j k l m n o p) + (list a b c d e f g h i j k l m n o p)) + +;;; Many parameter slots, live across a collection. +(test-true keyword-parsing-many-keys-across-gc + (let ((expected '(1 nil nil nil nil nil nil nil + nil nil nil nil nil nil nil 16))) + (and (equal (kwtest-16 :a 1 :p 16) expected) + (progn (gctools:garbage-collect) + (equal (kwtest-16 :a 1 :p 16) expected)))))