[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Better errors for odd-length keyword args
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Better errors for odd-length keyword args |
|
Date: |
Tue, 28 Feb 2017 15:02:55 -0500 (EST) |
wingo pushed a commit to branch stable-2.0
in repository guile.
commit 89ececea95bb4180384e897c0259a5128ed2fc15
Author: Andy Wingo <address@hidden>
Date: Tue Feb 28 20:42:45 2017 +0100
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.
---
libguile/eval.c | 64 ++++++++++------
libguile/keywords.c | 24 +++---
libguile/vm-i-system.c | 9 +--
libguile/vm.c | 8 +-
module/ice-9/eval.scm | 89 +++++++++++++---------
.../standalone/test-scm-c-bind-keyword-arguments.c | 22 +++---
test-suite/tests/00-repl-server.test | 1 +
test-suite/tests/optargs.test | 16 ++++
8 files changed, 142 insertions(+), 91 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 815f7c7..82dcbdd 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 f7a395d..dc4e41a 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 5057fb0..936f1ee 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 03263ac..80bd6d0 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 c971113..56d7a58 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 f4cd53d..90bcf2b 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 4b5ec0c..6b7cc39 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 047417b..9590f41 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 ()