* Re: case-lambda* question
2012-11-12 13:54 case-lambda* question Daniel Llorens
2012-11-13 2:46 ` Daniel Hartwig
@ 2013-01-14 10:39 ` Andy Wingo
2013-01-14 12:22 ` Ludovic Courtès
2013-01-15 12:01 ` Daniel Llorens
1 sibling, 2 replies; 13+ messages in thread
From: Andy Wingo @ 2013-01-14 10:39 UTC (permalink / raw)
To: Daniel Llorens; +Cc: guile-user
[-- Attachment #1: Type: text/plain, Size: 4452 bytes --]
Hi Daniel,
On Mon 12 Nov 2012 14:54, Daniel Llorens <daniel.llorens@bluewin.ch> writes:
> (define f
> (case-lambda*
> ((a b c #:key x) 3)
> ((a #:key x) 1)))
>
> scheme@(guile-user)> (g 0 #:x 1)
> $1 = 3
>
> The manual says
>
>> Also, for completeness. Guile defines case-lambda* as well, which is
>> like case-lambda, except with lambda* clauses. A case-lambda* clause
>> matches if the arguments fill the required arguments, but are not too
>> many for the optional and/or rest arguments.
>>
>> Keyword arguments are possible with case-lambda*, but they do not
>> contribute to the “matching” behavior. That is to say, case-lambda*
>> matches only on required, optional, and rest arguments, and on the
>> predicate; keyword arguments may be present but do not contribute to
I think this mention of a "predicate" probably refers to a brief time
when each clause could have a predicate to determine if it matched;
probably needs fixing. Fixed the docs.
>> the “success” of a match. In fact a bad keyword argument list may
>> cause an error to be raised.
>
> I see that it gives 3 because ‘a b c’ matches ‘0 #:x 1’, so it's
> counting #:x as an ‘argument’ by itself. This is not what I expected
> from the description above. I think that the description should make
> clear that each item in the arg list is counted as an argument for the
> purposes of matching.
>
> Moreover I think this behavior makes case-lambda* fairly useless, or
> even treacherous. I wonder what other people think.
So, the story here is fairly simple, but the result is complicated.
The principles are:
1. Case-lambda* clauses match in order. Order is significant.
2. Each clause is considered in isolation. If the clause's formal
arguments are compatible with the actual arguments, the clause is
chosen.
3. Keyword arguments are not checked for compatibility.
Commentary:
1. Straight-forward.
2. If you have some actual arguments ARGS... and a sequence of clauses
CLAUSE1 CLAUSE2... of the form (FORMALS BODY...), to see if CLAUSE1
applies, consider it in isolation:
((lambda* FORMALS1 BODY1...) ARGS...)
Does it apply? Then it will be chosen.
3. This rule is an exception to (2).
Rationale: At runtime we try to be fast. Calling functions with
keyword arguments doesn't allocate anything on the heap. Instead,
after required and optional arguments are bound, Guile shuffles up
the remaining arguments above the space reserved for the final
values of the keyword arguments, and then binds them in the order
they are passed to the function. This process is hairy and it's
not easy to "roll back" to the initial state of the function call
if a keyword does not match. Perhaps it is doable, but I was too
scared to fully implement it.
So, in your original example:
(define f
(case-lambda*
((a b c #:key x) 3)
((a #:key x) 1)))
(f 0 #:x 1)
Here we look at the first clause:
((lambda* (a b c #:key x) 3) 0 #:x 1)
Does it apply? Yes, yes it does: the 3 required arguments consume the
three arguments. So it is chosen, and this is correct, or at least
consistent with lambda*. (Required arguments are taken by position
only, regardless of what kind of object they are, even for keywords.
Optional arguments are the same, _except_ within a clause that also has
#:key arguments, in which case optionals are bound to positional
arguments only while the positional arguments are not keywords.)
Daniel Hartwig gives this second example, where the clauses are reversed:
(define f
(case-lambda*
((a #:key x) 1))
((a b c #:key x) 3))
(g 1 2 3)
Again, considering the first clause:
((lambda* (a #:key x) 3) 1 2 3)
Does it apply? It shouldn't: there are three positional arguments,
whereas only one is expected. However, Guile currently thinks that it
does, in the case-lambda* context, because it only checks that there is
at least one positional argument. This is probably a bug.
The attached patch fixes the problem. If there are no comments against
it, I will apply it to stable-2.0. It does introduce a slight
incompatibility, but I don't think there are many case-lambda* users,
and it makes cases work that previously failed to work.
Andy
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-case-lambda-clauses-fail-to-match-if-too-many-positi.patch --]
[-- Type: text/x-diff, Size: 28057 bytes --]
From 581f410fbd803721eb750ed8e7d6ec4cc4bcda79 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 14 Jan 2013 11:38:09 +0100
Subject: [PATCH] case-lambda* clauses fail to match if too many positionals
* doc/ref/api-procedures.texi (Case-lambda): Expand case-lambda*
documentation.
* module/ice-9/eval.scm (primitive-eval):
* libguile/eval.c (prepare_boot_closure_env_for_apply): Dispatch to the
next case-lambda clause if there are too many positionals.
* doc/ref/vm.texi (Function Prologue Instructions):
* libguile/vm-i-system.c (bind-optionals/shuffle-or-br): New
instruction, like bind-optionals/shuffle but can dispatch to the next
clause if there are too many positionals.
* module/language/assembly/disassemble.scm (code-annotation):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/compile-bytecode.scm (compile-bytecode): Add
case for bind-optionals/shuffle-or-br.
* module/language/glil/compile-assembly.scm (glil->assembly): If there
is an alternate, use bind-optionals/shuffle-or-br instead of
bind-optionals/shuffle.
* test-suite/tests/optargs.test ("case-lambda*"): Add tests.
---
doc/ref/api-procedures.texi | 61 +++++++++-
doc/ref/vm.texi | 8 +-
libguile/eval.c | 10 +-
libguile/vm-i-system.c | 58 +++++++++-
module/ice-9/eval.scm | 137 ++++++++++++-----------
module/language/assembly/compile-bytecode.scm | 13 ++-
module/language/assembly/decompile-bytecode.scm | 14 ++-
module/language/assembly/disassemble.scm | 4 +-
module/language/glil/compile-assembly.scm | 11 +-
test-suite/tests/optargs.test | 72 +++++++++++-
10 files changed, 308 insertions(+), 80 deletions(-)
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index e749fdc..bef3386 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -599,12 +599,61 @@ A @code{case-lambda*} clause matches if the arguments fill the
required arguments, but are not too many for the optional and/or rest
arguments.
-Keyword arguments are possible with @code{case-lambda*}, but they do
-not contribute to the ``matching'' behavior. That is to say,
-@code{case-lambda*} matches only on required, optional, and rest
-arguments, and on the predicate; keyword arguments may be present but
-do not contribute to the ``success'' of a match. In fact a bad keyword
-argument list may cause an error to be raised.
+Keyword arguments are possible with @code{case-lambda*} as well, but
+they do not contribute to the ``matching'' behavior, and their
+interactions with required, optional, and rest arguments can be
+surprising.
+
+For the purposes of @code{case-lambda*} (and of @code{case-lambda}, as a
+special case), a clause @dfn{matches} if it has enough required
+arguments, and not too many positional arguments. The required
+arguments are any arguments before the @code{#:optional}, @code{#:key},
+and @code{#:rest} arguments. @dfn{Positional} arguments are the
+required arguments, together with the optional arguments.
+
+In the absence of @code{#:key} or @code{#:rest} arguments, it's easy to
+see how there could be too many positional arguments: you pass 5
+arguments to a function that only takes 4 arguments, including optional
+arguments. If there is a @code{#:rest} argument, there can never be too
+many positional arguments: any application with enough required
+arguments for a clause will match that clause, even if there are also
+@code{#:key} arguments.
+
+Otherwise, for applications to a clause with @code{#:key} arguments (and
+without a @code{#:rest} argument), a clause will match there only if
+there are enough required arguments and if the next argument after
+binding required and optional arguments, if any, is a keyword. For
+efficiency reasons, Guile is currently unable to include keyword
+arguments in the matching algorithm. Clauses match on positional
+arguments only, not by comparing a given keyword to the available set of
+keyword arguments that a function has.
+
+Some examples follow.
+
+@example
+(define f
+ (case-lambda*
+ ((a #:optional b) 'clause-1)
+ ((a #:optional b #:key c) 'clause-2)
+ ((a #:key d) 'clause-3)
+ ((#:key e #:rest f) 'clause-4)))
+
+(f) @result{} clause-4
+(f 1) @result{} clause-1
+(f) @result{} clause-4
+(f #:e 10) clause-1
+(f 1 #:foo) clause-1
+(f 1 #:c 2) clause-2
+(f #:a #:b #:c #:d #:e) clause-4
+
+;; clause-2 will match anything that clause-3 would match.
+(f 1 #:d 2) @result{} error: bad keyword args in clause 2
+@end example
+
+Don't forget that the clauses are matched in order, and the first
+matching clause will be taken. This can result in a keyword being bound
+to a required argument, as in the case of @code{f #:e 10}.
+
@node Higher-Order Functions
@subsection Higher-Order Functions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 03356c7..9936ad9 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2008,2009,2010
+@c Copyright (C) 2008,2009,2010,2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -772,6 +772,7 @@ list. The list is then assigned to the @var{idx}th local variable.
@end deffn
@deffn Instruction bind-optionals/shuffle nreq nreq-and-opt ntotal
+@deffnx Instruction bind-optionals/shuffle-or-br nreq nreq-and-opt ntotal offset
Shuffle keyword arguments to the top of the stack, filling in the holes
with @code{SCM_UNDEFINED}. Each argument is encoded over two bytes.
@@ -783,6 +784,11 @@ the @var{nreq}th argument up to the @var{nreq-and-opt}th, and start
shuffling when it sees the first keyword argument or runs out of
positional arguments.
+@code{bind-optionals/shuffle-or-br} does the same, except that it checks
+if there are too many positional arguments before shuffling. If this is
+the case, it jumps to @var{offset}, encoded using the normal three-byte
+encoding.
+
Shuffling simply moves the keyword arguments past the total number of
arguments, @var{ntotal}, which includes keyword and rest arguments. The
free slots created by the shuffle are filled in with
diff --git a/libguile/eval.c b/libguile/eval.c
index c5b4580..0526f07 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -846,6 +846,14 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
env = scm_cons (args, env);
i++;
}
+ else if (scm_is_true (alt)
+ && scm_is_pair (args) && !scm_is_keyword (CAR (args)))
+ {
+ /* Too many positional args, no rest arg, and we have an
+ alternate clause. */
+ mx = alt;
+ goto loop;
+ }
/* Now fill in env with unbound values, limn the rest of the args for
keywords, and fill in unbound values with their inits. */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 40d26af..34545dd 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -634,6 +634,8 @@ VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6,
NEXT;
}
+/* See also bind-optionals/shuffle-or-br below. */
+
/* 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. */
@@ -1630,6 +1632,60 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
+/* Like bind-optionals/shuffle, but if there are too many positional
+ arguments, jumps to the next case-lambda clause. */
+VM_DEFINE_INSTRUCTION (94, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
+{
+ SCM *walk;
+ scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
+ scm_t_int32 offset;
+ nreq = FETCH () << 8;
+ nreq += FETCH ();
+ nreq_and_opt = FETCH () << 8;
+ nreq_and_opt += FETCH ();
+ ntotal = FETCH () << 8;
+ ntotal += FETCH ();
+ FETCH_OFFSET (offset);
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ walk = fp + nreq;
+ while (/* while we have args */
+ walk <= sp
+ /* and we still have positionals to fill */
+ && walk - fp < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (*walk))
+ /* bind this optional arg (by leaving it in place) */
+ walk++;
+ if (/* If we have filled all the positionals */
+ walk - fp == nreq_and_opt
+ /* and there are still more arguments */
+ && walk <= sp
+ /* and the next argument is not a keyword, */
+ && !scm_is_keyword (*walk))
+ {
+ /* Jump to the next case-lambda* clause. */
+ ip += offset;
+ }
+ else
+ {
+ /* Otherwise, finish as in bind-optionals/shuffle: shuffle up,
+ from walk to ntotal */
+ scm_t_ptrdiff nshuf = sp - walk + 1, i;
+ sp = (fp - 1) + ntotal + nshuf;
+ CHECK_OVERFLOW ();
+ for (i = 0; i < nshuf; i++)
+ sp[-i] = walk[nshuf-i-1];
+
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ while (walk <= (fp - 1) + ntotal)
+ *walk++ = SCM_UNDEFINED;
+ }
+
+ NEXT;
+}
+
/*
(defun renumber-ops ()
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 4054bd8..554c88e 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -298,72 +298,83 @@
(1- nopt) args (cdr inits))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
- ;; With keywords, we stop binding optionals at the first
- ;; keyword.
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
- (if (> nopt* 0)
- (if (or (null? args) (keyword? (car args)))
- (lp (cons (eval (car inits) env) env)
- (1- nopt*) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt*) (cdr args) (cdr inits)))
- ;; Finished with optionals.
- (let* ((aok (car kw))
- (kw (cdr kw))
- (kw-base (+ nopt nreq (if rest? 1 0)))
- (imax (let lp ((imax (1- kw-base)) (kw kw))
- (if (null? kw)
- imax
- (lp (max (cdar kw) imax)
- (cdr kw)))))
- ;; Fill in kwargs with "undefined" vals.
- (env (let lp ((i kw-base)
- ;; Also, here we bind the rest
- ;; arg, if any.
- (env (if rest? (cons args env) env)))
- (if (<= i imax)
- (lp (1+ i) (cons unbound-arg env))
- 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"
- '() #f)))
- (lp (cddr args)))
- (if (pair? args)
- (if rest?
- ;; Be lenient parsing rest args.
- (lp (cdr args))
- (scm-error 'keyword-argument-error
- "eval" "Invalid keyword"
- '() #f))
- ;; 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
+ ;; With keywords, we stop binding optionals at the
+ ;; first keyword.
+ ((> nopt* 0)
+ (if (or (null? args) (keyword? (car args)))
+ (lp (cons (eval (car inits) env) env)
+ (1- nopt*) args (cdr inits))
+ (lp (cons (car args) env)
+ (1- nopt*) (cdr args) (cdr inits))))
+ ;; Finished with optionals.
+ ((and alt (pair? args) (not (keyword? (car args)))
+ (not rest?))
+ ;; Too many positional args, no #:rest arg,
+ ;; and we have an alternate.
+ (apply alt-proc %args))
+ (else
+ (let* ((aok (car kw))
+ (kw (cdr kw))
+ (kw-base (+ nopt nreq (if rest? 1 0)))
+ (imax (let lp ((imax (1- kw-base)) (kw kw))
+ (if (null? kw)
+ imax
+ (lp (max (cdar kw) imax)
+ (cdr kw)))))
+ ;; Fill in kwargs with "undefined" vals.
+ (env (let lp ((i kw-base)
+ ;; Also, here we bind the rest
+ ;; arg, if any.
+ (env (if rest?
+ (cons args env)
+ env)))
+ (if (<= i imax)
+ (lp (1+ i) (cons unbound-arg env))
+ 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"
+ '() #f)))
+ (lp (cddr args)))
+ (if (pair? args)
+ (if rest?
+ ;; Be lenient parsing rest args.
+ (lp (cdr args))
+ (scm-error 'keyword-argument-error
+ "eval" "Invalid keyword"
+ '() #f))
+ ;; 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/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 85805a5..181fb06 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -136,6 +136,17 @@
((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+ ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
+ ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+ ,ntotal-hi ,ntotal-lo
+ ,l)
+ (write-byte nreq-hi)
+ (write-byte nreq-lo)
+ (write-byte nreq-and-nopt-hi)
+ (write-byte nreq-and-nopt-lo)
+ (write-byte ntotal-hi)
+ (write-byte ntotal-lo)
+ (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index 605e3df..c3469bd 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -43,7 +43,7 @@
(define (br-instruction? x)
(memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null)))
(define (br-nargs-instruction? x)
- (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)))
+ (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt br-if-nargs-lt/non-kw)))
(define (bytes->s24 a b c)
(let ((x (+ (ash a 16) (ash b 8) c)))
@@ -88,6 +88,16 @@
(lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard (br-nargs-instruction? br))
(lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
+ ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
+ ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+ ,ntotal-hi ,ntotal-lo
+ ,rel1 ,rel2 ,rel3)
+ (lp (cons `(bind-optionals/shuffle-or-br
+ ,nreq-hi ,nreq-lo
+ ,nreq-and-nopt-hi ,nreq-and-nopt-lo
+ ,ntotal-hi ,ntotal-lo
+ ,(ensure-label rel1 rel2 rel3))
+ out)))
((mv-call ,n ,rel1 ,rel2 ,rel3)
(lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
((prompt ,n0 ,rel1 ,rel2 ,rel3)
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index ced5f26..5d30be3 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -129,6 +129,8 @@
(list "-> ~A" (assq-ref labels (car args))))
((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
(list "-> ~A" (assq-ref labels (caddr args))))
+ ((bind-optionals/shuffle-or-br)
+ (list "-> ~A" (assq-ref labels (car (last-pair args)))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-boxed-ref local-set local-boxed-set)
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 83a5007..767fda3 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -486,13 +486,18 @@
,(modulo nreq 256)))))
(ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
(bind-optionals-and-shuffle
- `((bind-optionals/shuffle
+ `((,(if (and else-label (not rest))
+ 'bind-optionals/shuffle-or-br
+ 'bind-optionals/shuffle)
,(quotient nreq 256)
,(modulo nreq 256)
,(quotient (+ nreq nopt) 256)
,(modulo (+ nreq nopt) 256)
,(quotient ntotal 256)
- ,(modulo ntotal 256))))
+ ,(modulo ntotal 256)
+ ,@(if (and else-label (not rest))
+ `(,else-label)
+ '()))))
(bind-kw
;; when this code gets called, all optionals are filled
;; in, space has been made for kwargs, and the kwargs
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index a1e62bd..396fdec 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -1,7 +1,7 @@
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,6 +22,9 @@
#:use-module (system base compile)
#:use-module (ice-9 optargs))
+(define exception:invalid-keyword
+ '(keyword-argument-error . "Invalid keyword"))
+
(define exception:unrecognized-keyword
'(keyword-argument-error . "Unrecognized keyword"))
@@ -217,3 +220,70 @@
(pass-if "default arg"
(equal? (transmogrify quote)
10)))
+
+(with-test-prefix/c&e "case-lambda*"
+ (pass-if "unambiguous"
+ ((case-lambda*
+ ((a b) #t)
+ ((a) #f))
+ 1 2))
+
+ (pass-if "unambiguous (reversed)"
+ ((case-lambda*
+ ((a) #f)
+ ((a b) #t))
+ 1 2))
+
+ (pass-if "optionals (order disambiguates)"
+ ((case-lambda*
+ ((a #:optional b) #t)
+ ((a b) #f))
+ 1 2))
+
+ (pass-if "optionals (order disambiguates (2))"
+ ((case-lambda*
+ ((a b) #t)
+ ((a #:optional b) #f))
+ 1 2))
+
+ (pass-if "optionals (one arg)"
+ ((case-lambda*
+ ((a b) #f)
+ ((a #:optional b) #t))
+ 1))
+
+ (pass-if "optionals (one arg (2))"
+ ((case-lambda*
+ ((a #:optional b) #t)
+ ((a b) #f))
+ 1))
+
+ (pass-if "keywords without keyword"
+ ((case-lambda*
+ ((a #:key c) #t)
+ ((a b) #f))
+ 1))
+
+ (pass-if "keywords with keyword"
+ ((case-lambda*
+ ((a #:key c) #t)
+ ((a b) #f))
+ 1 #:c 2))
+
+ (pass-if "keywords (too many positionals)"
+ ((case-lambda*
+ ((a #:key c) #f)
+ ((a b) #t))
+ 1 2))
+
+ (pass-if "keywords (order disambiguates)"
+ ((case-lambda*
+ ((a #:key c) #t)
+ ((a b c) #f))
+ 1 #:c 2))
+
+ (pass-if "keywords (order disambiguates (2))"
+ ((case-lambda*
+ ((a b c) #t)
+ ((a #:key c) #f))
+ 1 #:c 2)))
--
1.7.10.4
[-- Attachment #3: Type: text/plain, Size: 26 bytes --]
--
http://wingolog.org/
^ permalink raw reply related [flat|nested] 13+ messages in thread