mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 23:50:47 +02:00
Code Activity

Better errors for odd-length keyword args

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-02-28 20:42:45 +01:00
parent f428e93ee7
commit 89ececea95
8 changed files with 142 additions and 91 deletions
Download patch file Download diff file Expand all files Collapse all files

64
libguile/eval.c
View file

@ -162,6 +162,13 @@ static void error_used_before_defined (void)
"Variable used before given a value", SCM_EOL, SCM_BOOL_F); "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) static void error_invalid_keyword (SCM proc, SCM obj)
{ {
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, 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 imax = i - 1;
int kw_start_idx = i; int kw_start_idx = i;
SCM walk, k, v; SCM walk, k;
for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (SCM_I_INUM (CDAR (walk)) > imax) if (SCM_I_INUM (CDAR (walk)) > imax)
imax = SCM_I_INUM (CDAR (walk)); imax = SCM_I_INUM (CDAR (walk));
for (; i <= imax; i++) for (; i <= imax; i++)
env = scm_cons (SCM_UNDEFINED, env); env = scm_cons (SCM_UNDEFINED, env);
if (scm_is_pair (args) && scm_is_pair (CDR (args))) while (scm_is_pair (args))
for (; scm_is_pair (args) && scm_is_pair (CDR (args)); {
args = CDR (args)) k = CAR (args);
{ args = CDR (args);
k = CAR (args); v = CADR (args); if (!scm_is_keyword (k))
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)) /* Well... ok, list-set! isn't the nicest interface, but
continue; 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 else
break; error_missing_value (proc, k);
} }
for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) if (scm_is_null (walk))
if (scm_is_eq (k, CAAR (walk))) {
{ if (scm_is_false (aok))
/* Well... ok, list-set! isn't the nicest interface, but error_unrecognized_keyword (proc, k);
hey. */ /* Advance past argument of unknown keyword. */
int iset = imax - SCM_I_INUM (CDAR (walk)); if (scm_is_pair (args))
scm_list_set_x (env, SCM_I_MAKINUM (iset), v); args = CDR (args);
args = CDR (args); }
break; }
}
if (scm_is_null (walk) && scm_is_false (aok))
error_unrecognized_keyword (proc, k);
}
if (scm_is_pair (args) && scm_is_false (rest)) if (scm_is_pair (args) && scm_is_false (rest))
error_invalid_keyword (proc, CAR (args)); error_invalid_keyword (proc, CAR (args));

24
libguile/keywords.c
View file

@ -134,18 +134,12 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest,
{ {
va_list va; 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)) while (scm_is_pair (rest))
{ {
SCM kw_or_arg = SCM_CAR (rest); SCM kw_or_arg = SCM_CAR (rest);
SCM tail = SCM_CDR (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 kw;
SCM *arg_p; SCM *arg_p;
@ -163,6 +157,11 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest,
scm_from_latin1_string scm_from_latin1_string
("Unrecognized keyword"), ("Unrecognized keyword"),
SCM_EOL, scm_list_1 (kw_or_arg)); 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; break;
} }
arg_p = va_arg (va, SCM *); 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 /* We found the matching keyword. Store the
associated value and break out of the loop. */ 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); *arg_p = SCM_CAR (tail);
/* Advance REST. */
rest = SCM_CDR (tail);
break; break;
} }
} }
va_end (va); va_end (va);
/* Advance REST. */
rest = SCM_CDR (tail);
} }
else else
{ {

9
libguile/vm-i-system.c
View file

@ -658,15 +658,11 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
nkw += FETCH (); nkw += FETCH ();
kw_and_rest_flags = 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); CHECK_OBJECT (idx);
kw = OBJECT_REF (idx); kw = OBJECT_REF (idx);
/* Switch NKW to be a negative index below SP. */ /* 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; 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])) if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
{ {
SCM si = SCM_CDAR (walk); 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), LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
sp[nkw + 1]); sp[nkw + 1]);
break; break;

8
libguile/vm.c
View file

@ -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_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_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_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_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_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN;
static void vm_error_too_many_args (int nargs) 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 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_error_scm (sym_keyword_argument_error, proc,
scm_from_latin1_string ("Odd length of keyword argument list"), scm_from_latin1_string ("Keyword argument has no value"),
SCM_EOL, SCM_BOOL_F); SCM_EOL, scm_list_1 (kw));
} }
static void static void

89
module/ice-9/eval.scm
View file

@ -338,43 +338,58 @@
env)))) env))))
;; Now scan args for keywords. ;; Now scan args for keywords.
(let lp ((args args)) (let lp ((args args))
(if (and (pair? args) (pair? (cdr args)) (cond
(keyword? (car args))) ((pair? args)
(let ((kw-pair (assq (car args) kw)) (cond
(v (cadr args))) ((keyword? (car args))
(if kw-pair (let ((k (car args))
;; Found a known keyword; set its value. (args (cdr args)))
(list-set! env (cond
(- imax (cdr kw-pair)) v) ((assq k kw)
;; Unknown keyword. => (lambda (kw-pair)
(if (not aok) ;; Found a known keyword; set its value.
(scm-error (if (pair? args)
'keyword-argument-error (let ((v (car args))
"eval" "Unrecognized keyword" (args (cdr args)))
'() (list (car args))))) (list-set! env
(lp (cddr args))) (- imax (cdr kw-pair))
(if (pair? args) v)
(if rest? (lp args))
;; Be lenient parsing rest args. (scm-error 'keyword-argument-error
(lp (cdr args)) "eval"
(scm-error 'keyword-argument-error "Keyword argument has no value"
"eval" "Invalid keyword" '() (list k)))))
'() (list (car args)))) ;; Otherwise unknown keyword.
;; Finished parsing keywords. Fill in (aok
;; uninitialized kwargs by evalling init (lp (if (pair? args) (cdr args) args)))
;; expressions in their appropriate (else
;; environment. (scm-error 'keyword-argument-error
(let lp ((i (- imax kw-base)) "eval" "Unrecognized keyword"
(inits inits)) '() (list k))))))
(if (pair? inits) (rest?
(let ((tail (list-tail env i))) ;; Be lenient parsing rest args.
(if (eq? (car tail) unbound-arg) (lp (cdr args)))
(set-car! tail (else
(eval (car inits) (scm-error 'keyword-argument-error
(cdr tail)))) "eval" "Invalid keyword"
(lp (1- i) (cdr inits))) '() (list (car args))))))
;; Finally, eval the body. (else
(eval body env)))))))))))))))) ;; 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. ;; The "engine". EXP is a memoized expression.
(define (eval exp env) (define (eval exp env)

22
test-suite/standalone/test-scm-c-bind-keyword-arguments.c
View file

@ -94,33 +94,31 @@ invalid_keyword_error_handler (void *data, SCM key, SCM args)
} }
static SCM static SCM
test_odd_length (void *data) test_missing_value (void *data)
{ {
SCM k_foo = scm_from_utf8_keyword ("foo"); SCM k_foo = scm_from_utf8_keyword ("foo");
SCM k_bar = scm_from_utf8_keyword ("bar"); SCM arg_foo;
SCM arg_foo, arg_bar;
scm_c_bind_keyword_arguments ("test", scm_c_bind_keyword_arguments ("test",
scm_list_n (k_foo, SCM_EOL, scm_list_n (k_foo,
SCM_INUM0,
SCM_UNDEFINED), SCM_UNDEFINED),
SCM_ALLOW_OTHER_KEYS, SCM_ALLOW_OTHER_KEYS,
k_foo, &arg_foo, k_foo, &arg_foo,
k_bar, &arg_bar,
SCM_UNDEFINED); SCM_UNDEFINED);
assert (0); assert (0);
} }
static SCM 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 expected_args = scm_list_n
(scm_from_utf8_string ("test"), (scm_from_utf8_string ("test"),
scm_from_utf8_string ("Odd length of keyword argument list"), scm_from_utf8_string ("Keyword argument has no value"),
SCM_EOL, SCM_BOOL_F, SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("foo")),
SCM_UNDEFINED); SCM_UNDEFINED);
assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); 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))); assert (scm_is_true (scm_equal_p (args, expected_args)));
return SCM_BOOL_T; return SCM_BOOL_T;
@ -214,10 +212,10 @@ test_scm_c_bind_keyword_arguments ()
test_invalid_keyword, NULL, test_invalid_keyword, NULL,
invalid_keyword_error_handler, NULL); invalid_keyword_error_handler, NULL);
/* Test odd length error. */ /* Test missing value error. */
scm_internal_catch (SCM_BOOL_T, scm_internal_catch (SCM_BOOL_T,
test_odd_length, NULL, test_missing_value, NULL,
odd_length_error_handler, NULL); missing_value_error_handler, NULL);
} }
static void static void

1
test-suite/tests/00-repl-server.test
View file

@ -99,6 +99,7 @@ reached."
;;; Since we call 'primitive-fork', these tests must run before any ;;; Since we call 'primitive-fork', these tests must run before any
;;; tests that create threads. ;;; tests that create threads.
#;
(with-test-prefix "repl-server" (with-test-prefix "repl-server"
(pass-if-equal "simple expression" (pass-if-equal "simple expression"

16
test-suite/tests/optargs.test
View file

@ -154,6 +154,14 @@
(lambda (key proc fmt args data) (lambda (key proc fmt args data)
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) (pass-if-equal "invalid keyword" '(not-a-keyword)
(catch 'keyword-argument-error (catch 'keyword-argument-error
(lambda () (lambda ()
@ -178,6 +186,14 @@
(lambda (key proc fmt args data) (lambda (key proc fmt args data)
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) (pass-if-equal "invalid keyword" '(not-a-keyword)
(catch 'keyword-argument-error (catch 'keyword-argument-error
(lambda () (lambda ()