From 581f410fbd803721eb750ed8e7d6ec4cc4bcda79 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Jan 2013 11:38:09 +0100 Subject: 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. --- libguile/vm-i-system.c | 58 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) (limited to 'libguile/vm-i-system.c') diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 40d26afa0..34545ddf4 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 () -- cgit v1.2.3