summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-16 22:32:54 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-16 22:32:54 +0100
commitff74e44ecba55f50b2c2c84bad2f13bed9489455 (patch)
tree005790d41437107aadd115332cb3038392378777
parent222831b443a14dd58ef646e8b313a38c38237f69 (diff)
downloadguile-ff74e44ecba55f50b2c2c84bad2f13bed9489455.tar.gz
with a rest arg, allow for keywords anywhere
* libguile/vm-i-system.c (br-if-nargs-gt): Fix variable declaration placement. (bind-kwargs): Patch mostly by Ludovic: it seems that in the mode in which we have rest args, the keywords can appear anywhere. Bummer. Change to allow for this. * module/ice-9/optargs.scm (parse-lambda-case): Same, add a permissive-keys clause that handles the case in which there's a rest argument.
-rw-r--r--libguile/vm-i-system.c68
-rw-r--r--module/ice-9/optargs.scm24
2 files changed, 63 insertions, 29 deletions
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8383a12af..205771924 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -537,9 +537,10 @@ VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
{
scm_t_ptrdiff n;
+ scm_t_int32 offset;
+
n = FETCH () << 8;
n += FETCH ();
- scm_t_int32 offset;
FETCH_OFFSET (offset);
if (sp - (fp - 1) > n)
ip += offset;
@@ -613,54 +614,65 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6,
NEXT;
}
+/* Flags that determine whether other keywords are allowed, and whether a
+ rest argument is expected. These values must match those used by the
+ glil->assembly compiler. */
+#define F_ALLOW_OTHER_KEYS 1
+#define F_REST 2
+
VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
{
scm_t_uint16 idx;
scm_t_ptrdiff nkw;
- int allow_other_keys_and_rest;
+ int kw_and_rest_flags;
SCM kw;
idx = FETCH () << 8;
idx += FETCH ();
+ /* XXX: We don't actually use NKW. */
nkw = FETCH () << 8;
nkw += FETCH ();
- allow_other_keys_and_rest = FETCH ();
+ kw_and_rest_flags = FETCH ();
- if (!(allow_other_keys_and_rest & 2)
- &&(sp - (fp - 1) - nkw) % 2)
+ if (!(kw_and_rest_flags & F_REST)
+ && ((sp - (fp - 1) - nkw) % 2))
goto vm_error_kwargs_length_not_even;
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 += 2)
+
+ /* Switch NKW to be a negative index below SP. */
+ for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
{
SCM walk;
- if (!scm_is_keyword (sp[nkw]))
- {
- if (allow_other_keys_and_rest & 2)
- /* reached the end of keywords, but we have a rest arg; just cut
- out */
- break;
- else
- goto vm_error_kwargs_invalid_keyword;
- }
- for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
- {
- if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
- {
- SCM si = SCM_CDAR (walk);
- LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
- sp[nkw + 1]);
- break;
- }
- }
- if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk))
- goto vm_error_kwargs_unrecognized_keyword;
+
+ if (scm_is_keyword (sp[nkw]))
+ {
+ for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
+ {
+ SCM si = SCM_CDAR (walk);
+ LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
+ sp[nkw + 1]);
+ break;
+ }
+ }
+ if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
+ goto vm_error_kwargs_unrecognized_keyword;
+
+ nkw++;
+ }
+ else if (!(kw_and_rest_flags & F_REST))
+ goto vm_error_kwargs_invalid_keyword;
}
NEXT;
}
+#undef F_ALLOW_OTHER_KEYS
+#undef F_REST
+
+
VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
{
scm_t_ptrdiff n;
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 22dfa9fa2..5ad9e8121 100644
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@@ -311,7 +311,7 @@
;; it has to be this way, vars are allocated in this order
(set-car! slots-tail args-tail)
(if (pair? kw-indices)
- (key slots (cdr slots-tail) args-tail inits)
+ (permissive-keys slots (cdr slots-tail) args-tail inits)
(rest-or-key slots (cdr slots-tail) '() inits #f)))
((pair? kw-indices)
;; fail early here, because once we're in keyword land we throw
@@ -322,6 +322,28 @@
#f) ;; fail
(else
slots)))
+ (define (permissive-keys slots slots-tail args-tail inits)
+ (cond
+ ((null? args-tail)
+ (if (null? inits)
+ slots
+ (begin
+ (if (eq? (car slots-tail) *uninitialized*)
+ (set-car! slots-tail (apply (car inits) slots)))
+ (permissive-keys slots (cdr slots-tail) '() (cdr inits)))))
+ ((not (keyword? (car args-tail)))
+ (permissive-keys slots slots-tail (cdr args-tail) inits))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ (assq-ref kw-indices (car args-tail)))
+ => (lambda (i)
+ (list-set! slots i (cadr args-tail))
+ (permissive-keys slots slots-tail (cddr args-tail) inits)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ allow-other-keys?)
+ (permissive-keys slots slots-tail (cddr args-tail) inits))
+ (else (error "unrecognized keyword" args-tail))))
(define (key slots slots-tail args-tail inits)
(cond
((null? args-tail)