diff options
author | Andy Wingo <wingo@pobox.com> | 2017-02-28 20:42:45 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-02-28 21:01:33 +0100 |
commit | 89ececea95bb4180384e897c0259a5128ed2fc15 (patch) | |
tree | c71fd3da394883223e49b268f4d24fe81ebec951 | |
parent | f428e93ee7a4be76341444b228585755807b282f (diff) | |
download | guile-89ececea95bb4180384e897c0259a5128ed2fc15.tar.gz |
Better errors for odd-length keyword args
* libguile/vm-i-system.c (bind-kwargs):
* libguile/vm.c (vm_error_kwargs_missing_value):
* libguile/eval.c (error_missing_value)
(prepare_boot_closure_env_for_apply): Adapt to mirror VM behavior.
* libguile/keywords.c (scm_c_bind_keyword_arguments): Likewise.
* module/ice-9/eval.scm (primitive-eval): Update to error on (foo #:kw)
with a "Keyword argument has no value" instead of the horrible "odd
argument list length". Also adapts to the expected args format for
the keyword-argument-error exception printer in all cases. Matches
1.8 optargs behavior also.
* test-suite/standalone/test-scm-c-bind-keyword-arguments.c (test_missing_value):
(missing_value_error_handler): Update test.
* test-suite/tests/optargs.test: Add tests.
-rw-r--r-- | libguile/eval.c | 64 | ||||
-rw-r--r-- | libguile/keywords.c | 24 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 9 | ||||
-rw-r--r-- | libguile/vm.c | 8 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 89 | ||||
-rw-r--r-- | test-suite/standalone/test-scm-c-bind-keyword-arguments.c | 22 | ||||
-rw-r--r-- | test-suite/tests/00-repl-server.test | 1 | ||||
-rw-r--r-- | test-suite/tests/optargs.test | 16 |
8 files changed, 142 insertions, 91 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index 815f7c7a7..82dcbdd07 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -162,6 +162,13 @@ static void error_used_before_defined (void) "Variable used before given a value", SCM_EOL, SCM_BOOL_F); } +static void error_missing_value (SCM proc, SCM kw) +{ + scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, + scm_from_locale_string ("Keyword argument has no value"), SCM_EOL, + scm_list_1 (kw)); +} + static void error_invalid_keyword (SCM proc, SCM obj) { scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, @@ -867,38 +874,49 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { int imax = i - 1; int kw_start_idx = i; - SCM walk, k, v; + SCM walk, k; for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) if (SCM_I_INUM (CDAR (walk)) > imax) imax = SCM_I_INUM (CDAR (walk)); for (; i <= imax; i++) env = scm_cons (SCM_UNDEFINED, env); - if (scm_is_pair (args) && scm_is_pair (CDR (args))) - for (; scm_is_pair (args) && scm_is_pair (CDR (args)); - args = CDR (args)) - { - k = CAR (args); v = CADR (args); - if (!scm_is_keyword (k)) + while (scm_is_pair (args)) + { + k = CAR (args); + args = CDR (args); + if (!scm_is_keyword (k)) + { + if (scm_is_true (rest)) + continue; + else + break; + } + for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) + if (scm_is_eq (k, CAAR (walk))) { - if (scm_is_true (rest)) - continue; + /* Well... ok, list-set! isn't the nicest interface, but + hey. */ + int iset = imax - SCM_I_INUM (CDAR (walk)); + if (scm_is_pair (args)) + { + SCM v = CAR (args); + args = CDR (args); + scm_list_set_x (env, SCM_I_MAKINUM (iset), v); + break; + } else - break; + error_missing_value (proc, k); } - for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) - if (scm_is_eq (k, CAAR (walk))) - { - /* Well... ok, list-set! isn't the nicest interface, but - hey. */ - int iset = imax - SCM_I_INUM (CDAR (walk)); - scm_list_set_x (env, SCM_I_MAKINUM (iset), v); - args = CDR (args); - break; - } - if (scm_is_null (walk) && scm_is_false (aok)) - error_unrecognized_keyword (proc, k); - } + if (scm_is_null (walk)) + { + if (scm_is_false (aok)) + error_unrecognized_keyword (proc, k); + /* Advance past argument of unknown keyword. */ + if (scm_is_pair (args)) + args = CDR (args); + } + } if (scm_is_pair (args) && scm_is_false (rest)) error_invalid_keyword (proc, CAR (args)); diff --git a/libguile/keywords.c b/libguile/keywords.c index f7a395da3..dc4e41a70 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -134,18 +134,12 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, { va_list va; - if (SCM_UNLIKELY (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS) - && scm_ilength (rest) % 2 != 0)) - scm_error (scm_keyword_argument_error, - subr, "Odd length of keyword argument list", - SCM_EOL, SCM_BOOL_F); - while (scm_is_pair (rest)) { SCM kw_or_arg = SCM_CAR (rest); SCM tail = SCM_CDR (rest); - if (scm_is_keyword (kw_or_arg) && scm_is_pair (tail)) + if (scm_is_keyword (kw_or_arg)) { SCM kw; SCM *arg_p; @@ -163,6 +157,11 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, scm_from_latin1_string ("Unrecognized keyword"), SCM_EOL, scm_list_1 (kw_or_arg)); + + /* Advance REST. Advance past the argument of an + unrecognized keyword, but don't error if such a + keyword has no argument. */ + rest = scm_is_pair (tail) ? SCM_CDR (tail) : tail; break; } arg_p = va_arg (va, SCM *); @@ -170,14 +169,19 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, { /* We found the matching keyword. Store the associated value and break out of the loop. */ + if (!scm_is_pair (tail)) + scm_error_scm (scm_keyword_argument_error, + scm_from_locale_string (subr), + scm_from_latin1_string + ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (kw)); *arg_p = SCM_CAR (tail); + /* Advance REST. */ + rest = SCM_CDR (tail); break; } } va_end (va); - - /* Advance REST. */ - rest = SCM_CDR (tail); } else { diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5057fb02b..936f1ee36 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -658,15 +658,11 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) nkw += FETCH (); kw_and_rest_flags = FETCH (); - VM_ASSERT ((kw_and_rest_flags & F_REST) - || ((sp - (fp - 1) - nkw) % 2) == 0, - vm_error_kwargs_length_not_even (program)) - CHECK_OBJECT (idx); kw = OBJECT_REF (idx); /* Switch NKW to be a negative index below SP. */ - for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) + for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw <= 0; nkw++) { SCM walk; @@ -677,6 +673,9 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) { SCM si = SCM_CDAR (walk); + VM_ASSERT (nkw != 0 + || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), + vm_error_kwargs_missing_value (program, sp[nkw])); LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), sp[nkw + 1]); break; diff --git a/libguile/vm.c b/libguile/vm.c index 03263ac87..80bd6d0b4 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -384,7 +384,7 @@ static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN; static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN; static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN; static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN; -static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN; +static void vm_error_kwargs_missing_value (SCM proc, SCM kw) SCM_NORETURN; static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN; static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN; static void vm_error_too_many_args (int nargs) SCM_NORETURN; @@ -462,11 +462,11 @@ vm_error_apply_to_non_list (SCM x) } static void -vm_error_kwargs_length_not_even (SCM proc) +vm_error_kwargs_missing_value (SCM proc, SCM kw) { scm_error_scm (sym_keyword_argument_error, proc, - scm_from_latin1_string ("Odd length of keyword argument list"), - SCM_EOL, SCM_BOOL_F); + scm_from_latin1_string ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (kw)); } static void diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index c9711134c..56d7a5815 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -338,43 +338,58 @@ env)))) ;; Now scan args for keywords. (let lp ((args args)) - (if (and (pair? args) (pair? (cdr args)) - (keyword? (car args))) - (let ((kw-pair (assq (car args) kw)) - (v (cadr args))) - (if kw-pair - ;; Found a known keyword; set its value. - (list-set! env - (- imax (cdr kw-pair)) v) - ;; Unknown keyword. - (if (not aok) - (scm-error - 'keyword-argument-error - "eval" "Unrecognized keyword" - '() (list (car args))))) - (lp (cddr args))) - (if (pair? args) - (if rest? - ;; Be lenient parsing rest args. - (lp (cdr args)) - (scm-error 'keyword-argument-error - "eval" "Invalid keyword" - '() (list (car args)))) - ;; Finished parsing keywords. Fill in - ;; uninitialized kwargs by evalling init - ;; expressions in their appropriate - ;; environment. - (let lp ((i (- imax kw-base)) - (inits inits)) - (if (pair? inits) - (let ((tail (list-tail env i))) - (if (eq? (car tail) unbound-arg) - (set-car! tail - (eval (car inits) - (cdr tail)))) - (lp (1- i) (cdr inits))) - ;; Finally, eval the body. - (eval body env)))))))))))))))) + (cond + ((pair? args) + (cond + ((keyword? (car args)) + (let ((k (car args)) + (args (cdr args))) + (cond + ((assq k kw) + => (lambda (kw-pair) + ;; Found a known keyword; set its value. + (if (pair? args) + (let ((v (car args)) + (args (cdr args))) + (list-set! env + (- imax (cdr kw-pair)) + v) + (lp args)) + (scm-error 'keyword-argument-error + "eval" + "Keyword argument has no value" + '() (list k))))) + ;; Otherwise unknown keyword. + (aok + (lp (if (pair? args) (cdr args) args))) + (else + (scm-error 'keyword-argument-error + "eval" "Unrecognized keyword" + '() (list k)))))) + (rest? + ;; Be lenient parsing rest args. + (lp (cdr args))) + (else + (scm-error 'keyword-argument-error + "eval" "Invalid keyword" + '() (list (car args)))))) + (else + ;; Finished parsing keywords. Fill in + ;; uninitialized kwargs by evalling init + ;; expressions in their appropriate + ;; environment. + (let lp ((i (- imax kw-base)) + (inits inits)) + (if (pair? inits) + (let ((tail (list-tail env i))) + (if (eq? (car tail) unbound-arg) + (set-car! tail + (eval (car inits) + (cdr tail)))) + (lp (1- i) (cdr inits))) + ;; Finally, eval the body. + (eval body env))))) + ))))))))))) ;; The "engine". EXP is a memoized expression. (define (eval exp env) diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index f4cd53d84..90bcf2baf 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -94,33 +94,31 @@ invalid_keyword_error_handler (void *data, SCM key, SCM args) } static SCM -test_odd_length (void *data) +test_missing_value (void *data) { SCM k_foo = scm_from_utf8_keyword ("foo"); - SCM k_bar = scm_from_utf8_keyword ("bar"); - SCM arg_foo, arg_bar; + SCM arg_foo; scm_c_bind_keyword_arguments ("test", - scm_list_n (k_foo, SCM_EOL, - SCM_INUM0, + scm_list_n (k_foo, SCM_UNDEFINED), SCM_ALLOW_OTHER_KEYS, k_foo, &arg_foo, - k_bar, &arg_bar, SCM_UNDEFINED); assert (0); } static SCM -odd_length_error_handler (void *data, SCM key, SCM args) +missing_value_error_handler (void *data, SCM key, SCM args) { SCM expected_args = scm_list_n (scm_from_utf8_string ("test"), - scm_from_utf8_string ("Odd length of keyword argument list"), - SCM_EOL, SCM_BOOL_F, + scm_from_utf8_string ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("foo")), SCM_UNDEFINED); assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + scm_write (args, scm_current_output_port ()); assert (scm_is_true (scm_equal_p (args, expected_args))); return SCM_BOOL_T; @@ -214,10 +212,10 @@ test_scm_c_bind_keyword_arguments () test_invalid_keyword, NULL, invalid_keyword_error_handler, NULL); - /* Test odd length error. */ + /* Test missing value error. */ scm_internal_catch (SCM_BOOL_T, - test_odd_length, NULL, - odd_length_error_handler, NULL); + test_missing_value, NULL, + missing_value_error_handler, NULL); } static void diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index 4b5ec0cb3..6b7cc39ef 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -99,6 +99,7 @@ reached." ;;; Since we call 'primitive-fork', these tests must run before any ;;; tests that create threads. +#; (with-test-prefix "repl-server" (pass-if-equal "simple expression" diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 047417b4c..9590f414c 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -154,6 +154,14 @@ (lambda (key proc fmt args data) data))) + (pass-if-equal "missing argument" '("Keyword argument has no value" #:x) + (catch 'keyword-argument-error + (lambda () + (let ((f (lambda* (#:key x) x))) + (f #:x))) + (lambda (key proc fmt args data) + (cons fmt data)))) + (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () @@ -178,6 +186,14 @@ (lambda (key proc fmt args data) data))) + (pass-if-equal "missing argument" + '("Keyword argument has no value" #:encoding) + (catch 'keyword-argument-error + (lambda () + (open-file "/dev/null" "r" #:encoding)) + (lambda (key proc fmt args data) + (cons fmt data)))) + (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () |