From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.user Subject: Re: case-lambda* question Date: Mon, 14 Jan 2013 11:39:26 +0100 Message-ID: <876230t5ep.fsf@pobox.com> References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1358160048 21186 80.91.229.3 (14 Jan 2013 10:40:48 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 14 Jan 2013 10:40:48 +0000 (UTC) Cc: guile-user@gnu.org To: Daniel Llorens Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Mon Jan 14 11:41:04 2013 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1TuhTS-0001bb-WC for guile-user@m.gmane.org; Mon, 14 Jan 2013 11:41:04 +0100 Original-Received: from localhost ([::1]:60045 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TuhTC-0007pN-Q1 for guile-user@m.gmane.org; Mon, 14 Jan 2013 05:40:46 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:47943) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TuhSW-0007hB-13 for guile-user@gnu.org; Mon, 14 Jan 2013 05:40:40 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1TuhRz-0001GJ-I7 for guile-user@gnu.org; Mon, 14 Jan 2013 05:40:03 -0500 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:50204 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TuhRy-0001G9-Ob for guile-user@gnu.org; Mon, 14 Jan 2013 05:39:31 -0500 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id 11229957B; Mon, 14 Jan 2013 05:39:30 -0500 (EST) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; s=sasl; bh=fk8HwccjQ0T1DPeFGnvbVj/e0KY=; b=PS+2Mu d1dQSLZQamXbuV0IbZN6h+JrzvQkKjOcoKl+/JMU85ZR17o5/ixl5Pj08RUG3L6Q rzlNhN4S0s39TFNgZXmJQNHu8cI+pTF6r0ikMtEl2MYHbprjKSKcRIkK25+wijRK abxAJ10KPHOUlhtvRKLRm8M8Aui+2Rhx94mPE= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:references:date:in-reply-to:message-id:mime-version :content-type; q=dns; s=sasl; b=Jmn7/2E4N9boHQB4pCB333XYFIMgy0Gj T/6hjfcEzVcJIko8sZVhQ8fiCuw6ka+/YsCRh2IZrHmt+S7PmyHM7FoKFSDFPvK3 wjf5fLwJ+FyS33h3z/Cj3teNAhSm1TfvCyOiJochktz7t7AwYgWtueKhv3HLixXz 7bcdgx8hPH0= Original-Received: from a-pb-sasl-quonix.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id F39FF957A; Mon, 14 Jan 2013 05:39:29 -0500 (EST) Original-Received: from badger (unknown [88.160.190.192]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTPSA id 021C89579; Mon, 14 Jan 2013 05:39:28 -0500 (EST) In-Reply-To: (Daniel Llorens's message of "Mon, 12 Nov 2012 14:54:45 +0100") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) X-Pobox-Relay-ID: AC96A710-5E36-11E2-A453-0A4F0E5B5709-02397024!a-pb-sasl-quonix.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 X-Received-From: 208.72.237.25 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Original-Sender: guile-user-bounces+guile-user=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.user:9857 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hi Daniel, On Mon 12 Nov 2012 14:54, Daniel Llorens writes: > (define f > (case-lambda* > ((a b c #:key x) 3) > ((a #:key x) 1))) > > scheme@(guile-user)> (g 0 #:x 1) > $1 =3D 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. >>=20 >> Keyword arguments are possible with case-lambda*, but they do not >> contribute to the =E2=80=9Cmatching=E2=80=9D behavior. That is to say, c= ase-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 =E2=80=9Csuccess=E2=80=9D of a match. In fact a bad keyword argument= list may >> cause an error to be raised. > > I see that it gives 3 because =E2=80=98a b c=E2=80=99 matches =E2=80=980 = #:x 1=E2=80=99, so it's > counting #:x as an =E2=80=98argument=E2=80=99 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 --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-case-lambda-clauses-fail-to-match-if-too-many-positi.patch >From 581f410fbd803721eb750ed8e7d6ec4cc4bcda79 Mon Sep 17 00:00:00 2001 From: Andy Wingo 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 --- 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 --=-=-= Content-Type: text/plain -- http://wingolog.org/ --=-=-=--