summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/eval.c10
-rw-r--r--libguile/vm-i-system.c58
2 files changed, 66 insertions, 2 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index c5b458009..0526f078d 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 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 ()