Package: guile;
Reported by: Göran Weinholt <goran <at> weinholt.se>
Date: Mon, 17 Oct 2011 16:19:02 UTC
Severity: normal
Done: Andy Wingo <wingo <at> pobox.com>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 9776 in the body.
You can then email your comments to 9776 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
bug-guile <at> gnu.org:bug#9776; Package guile.
(Mon, 17 Oct 2011 16:19:02 GMT) Full text and rfc822 format available.Göran Weinholt <goran <at> weinholt.se>:bug-guile <at> gnu.org.
(Mon, 17 Oct 2011 16:19:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Göran Weinholt <goran <at> weinholt.se> To: bug-guile <at> gnu.org Subject: case-lambda should accept zero clauses Date: Mon, 17 Oct 2011 12:15:40 +0200
Hello guilers, the case-lambda form is specified in r6rs-lib as accepting any number of clauses, including zero. So this should not give an error: scheme@(guile-user)> (case-lambda) While compiling expression: ERROR: Syntax error: standard input:1:0: case-lambda: bad case-lambda in form (case-lambda) Instead it should return a procedure that never gets the right number of arguments. Regards, -- Göran Weinholt <goran <at> weinholt.se>
bug-guile <at> gnu.org:bug#9776; Package guile.
(Thu, 05 Jan 2012 22:11:02 GMT) Full text and rfc822 format available.Message #8 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Göran Weinholt <goran <at> weinholt.se> Cc: 9776 <at> debbugs.gnu.org Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Thu, 05 Jan 2012 23:06:54 +0100
Hi Göran, Sorry for the delay. Göran Weinholt <goran <at> weinholt.se> skribis: > the case-lambda form is specified in r6rs-lib as accepting any number of > clauses, including zero. So this should not give an error: My interpretation of the ‘case-lambda’ implementation on p. 15 of r6rs-lib.pdf is that ‘case-lambda-help’ raises an assertion violation when ‘case-lambda’ is called with zero clauses. The text itself doesn’t explicitly mention that zero clauses are supported. What makes you think otherwise? Thanks, Ludo’.
bug-guile <at> gnu.org:bug#9776; Package guile.
(Sun, 08 Jan 2012 04:52:02 GMT) Full text and rfc822 format available.Message #11 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: Ian Price <ianprice90 <at> googlemail.com> To: ludo <at> gnu.org (Ludovic Courtès) Cc: 9776 <at> debbugs.gnu.org, Göran Weinholt <goran <at> weinholt.se> Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Sun, 08 Jan 2012 04:45:45 +0000
ludo <at> gnu.org (Ludovic Courtès) writes:
> Hi Göran,
>
> Sorry for the delay.
>
> Göran Weinholt <goran <at> weinholt.se> skribis:
>
>> the case-lambda form is specified in r6rs-lib as accepting any number of
>> clauses, including zero. So this should not give an error:
>
> My interpretation of the ‘case-lambda’ implementation on p. 15 of
> r6rs-lib.pdf is that ‘case-lambda-help’ raises an assertion violation
> when ‘case-lambda’ is called with zero clauses.
The case-lambda-help macro is expanded from within
(lambda args
(let ((n (length args)))
(case-lambda-help args n
(fmls b1 b2 ...) ...)))
So, the full expansion is
(lambda args
(let ((n (length args)))
(assertion-violation #f "unexpected number of arguments")))
and thus a procedure that always returns an assertion violation.
>
> The text itself doesn’t explicitly mention that zero clauses are
> supported.
I would disagree with this. Even without looking at the implementation, you
see the specification of case-lambda as
(case-lambda <case-lambda clause> ...)
The traditional meaning of ..., as seen in syntax-rules, and elsewhere
in the r6rs, is 0 or more. Therefore a (case-lambda) form seems allowed
to me.
Oh, and an existence proof for good measure :)
scheme@(guile−user)> (import (rnrs))
scheme@(guile−user)> (define-syntax case-lambda
(syntax-rules ()
((_ (fmls b1 b2 ...))
(lambda fmls b1 b2 ...))
((_ (fmls b1 b2 ...) ...)
(lambda args
(let ((n (length args)))
(case-lambda-help args n
(fmls b1 b2 ...) ...))))))
scheme@(guile−user)> (define-syntax case-lambda-help
(syntax-rules ()
((_ args n)
(assertion-violation #f
"unexpected number of arguments"))
((_ args n ((x ...) b1 b2 ...) more ...)
(if (= n (length ’(x ...)))
(apply (lambda (x ...) b1 b2 ...) args)
(case-lambda-help args n more ...)))
((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...)
(if (>= n (length ’(x1 x2 ...)))
(apply (lambda (x1 x2 ... . r) b1 b2 ...)
args)
(case-lambda-help args n more ...)))
((_ args n (r b1 b2 ...) more ...)
(apply (lambda r b1 b2 ...) args))))
scheme@(guile−user)> (case-lambda)
$22 = #<procedure 905a980 at <current input>:734:0 args>
scheme@(guile−user)> ($22)
ERROR: ERROR: R6RS exception:
1. &assertion
2. &message: "unexpected number of arguments"
3. &irritants: ()
Entering a new prompt. Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile−user) [1]> ,q
scheme@(guile−user)>
--
Ian Price
"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"
bug-guile <at> gnu.org:bug#9776; Package guile.
(Tue, 31 Jan 2012 22:56:02 GMT) Full text and rfc822 format available.Message #14 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Ian Price <ianprice90 <at> googlemail.com> Cc: 9776 <at> debbugs.gnu.org, Göran Weinholt <goran <at> weinholt.se> Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Tue, 31 Jan 2012 23:55:23 +0100
[Message part 1 (text/plain, inline)]
Hi Ian, Sorry for the late reply. Ian Price <ianprice90 <at> googlemail.com> skribis: > ludo <at> gnu.org (Ludovic Courtès) writes: > >> Hi Göran, >> >> Sorry for the delay. >> >> Göran Weinholt <goran <at> weinholt.se> skribis: >> >>> the case-lambda form is specified in r6rs-lib as accepting any number of >>> clauses, including zero. So this should not give an error: >> >> My interpretation of the ‘case-lambda’ implementation on p. 15 of >> r6rs-lib.pdf is that ‘case-lambda-help’ raises an assertion violation >> when ‘case-lambda’ is called with zero clauses. > The case-lambda-help macro is expanded from within > (lambda args > (let ((n (length args))) > (case-lambda-help args n > (fmls b1 b2 ...) ...))) > > So, the full expansion is > (lambda args > (let ((n (length args))) > (assertion-violation #f "unexpected number of arguments"))) > > and thus a procedure that always returns an assertion violation. Indeed, thanks for the correction (I was thinking of ‘assertion-violation’ as a compile-time assertion.) So, here’s a tentative patch for review:
[Message part 2 (text/x-patch, inline)]
Modified module/ice-9/psyntax.scm
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 728ab12..c3aa6d8 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1778,7 +1778,19 @@
r* w* mod)))))
(syntax-case clauses ()
- (() (values '() #f))
+ (() ; zero clauses
+ (values
+ '()
+ (build-lambda-case s '() '() 'rest #f '()
+ (list (build-lexical-var s 'rest))
+ (build-application s
+ (make-toplevel-ref s 'throw)
+ (list
+ (build-data
+ s 'wrong-number-of-args)
+ (build-data
+ s "Wrong number of arguments")))
+ #f)))
(((args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values (lambda () (get-formals #'args))
(lambda (req opt rest kw)
@@ -2092,12 +2104,12 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ ((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ #'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
@@ -2105,12 +2117,12 @@
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ ((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda*-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ #'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
Modified test-suite/tests/compiler.test
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ee688c0..bb2be06 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 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
@@ -163,4 +163,11 @@
(display (list x y))
(list x y))))
(display (t 'x)))))
- "(x y)(x y)")))
+ "(x y)(x y)"))
+
+ (pass-if-exception "zero clauses"
+ exception:wrong-num-args
+ ;; See <http://bugs.gnu.org/9776>.
+ (compile '(let ((p (case-lambda)))
+ (and (procedure? p) (p)))
+ #:to 'value)))
[Message part 3 (text/plain, inline)]
The problem is that the new test itself fails with: ERROR: compiler.test: case-lambda: zero clauses - arguments: ((wrong-number-of-args "eval" "Wrong number of arguments" () #f)) and then a number of tests in tree-il.test fail because they were assuming the previous behavior for zero-clause ‘case-lambda’. In addition, this patch uses the Guilish ‘wrong-number-of-args’ exception, not the R6RS one. This is consistent, but it means that the R6RS layer would have to convert exceptions again. Thoughts? Thanks, Ludo’.
bug-guile <at> gnu.org:bug#9776; Package guile.
(Wed, 01 Feb 2012 05:10:02 GMT) Full text and rfc822 format available.Message #17 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: Mark H Weaver <mhw <at> netris.org> To: ludo <at> gnu.org (Ludovic Courtès) Cc: 9776 <at> debbugs.gnu.org, Göran Weinholt <goran <at> weinholt.se>, Ian Price <ianprice90 <at> googlemail.com> Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Wed, 01 Feb 2012 00:07:43 -0500
[Message part 1 (text/plain, inline)]
Hi Ludovic,
Thanks for tackling this. Of course this is Andy's area, but psyntax is
still fresh in my mind, so I'll attempt a review as well as my own
tentative approach.
ludo <at> gnu.org (Ludovic Courtès) writes:
> So, here’s a tentative patch for review:
>
>
> Modified module/ice-9/psyntax.scm
> diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
> index 728ab12..c3aa6d8 100644
> --- a/module/ice-9/psyntax.scm
> +++ b/module/ice-9/psyntax.scm
> @@ -1778,7 +1778,19 @@
> r* w* mod)))))
>
> (syntax-case clauses ()
> - (() (values '() #f))
> + (() ; zero clauses
> + (values
> + '()
> + (build-lambda-case s '() '() 'rest #f '()
> + (list (build-lexical-var s 'rest))
> + (build-application s
> + (make-toplevel-ref s 'throw)
This 'make-toplevel-ref' should instead be 'build-primref', so that it
refers to the 'throw' in the 'guile' module. As it is now, this won't
work in modules that have bound 'throw' to something else.
> + (list
> + (build-data
> + s 'wrong-number-of-args)
> + (build-data
> + s "Wrong number of arguments")))
> + #f)))
Unfortunately, the above case is not only triggered for an empty
case-lambda; it is the base case at the end of iteration over the
clauses, so this code will be added to _every_ case-lambda.
Apart from the extra bloat, this will make error reporting much worse.
Right now, if you call a procedure created by 'case-lambda' with an
incorrect number of arguments, the VM will generate a nice error message
that includes the procedure itself, including the procedure's name.
By adding this "catch-all" clause to the end of every 'case-lambda', you
have taken over the job of error reporting for _all_ case-lambdas, but
you produce a much less useful error message than the VM does.
This also destroys the arity information for all case-lambdas.
* * * * *
I think the _right_ way to do this is to change all code that deals with
case-lambdas (in the compiler and evaluator) to gracefully handle the
zero-clause case.
In the meantime, here's my attempt at a temporary fix for this problem.
It contains a terrible hack, but the upside is that it produces helpful
error messages in almost every case, and the tests do the right thing.
Here's how it reports errors:
> scheme@(guile-user)> (define foo (case-lambda))
> scheme@(guile-user)> (foo)
> ;;; <stdin>:2:0: warning: possibly wrong number of arguments to `foo'
> ERROR: In procedure foo:
> ERROR: Wrong number of arguments to #<procedure foo (created by case-lambda with no clauses a b c d e f g h i j k l m n o p q r s t u v w x y z)>
The terrible hack is that (case-lambda) expands into a normal 'lambda'
that takes 32 arguments. The first six argument names form a message
that informs the user that the procedure was created by an empty case
lambda. The next 26 arguments make it very unlikely that you will call
it with the correct number of arguments, because an inferior error
message is generated in that case:
> scheme@(guile-user)> (apply foo (iota 32))
> ERROR: In procedure scm-error:
> ERROR: Wrong number of arguments to a procedure created by case-lambda with no clauses
Okay, here's my hackish attempt. Comments welcome. *ducks* :)
Mark
[MARKS_HACKISH_ZERO_CLAUSE_CASE_LAMBDA_FIX.patch (text/x-patch, inline)]
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 728ab12..3c0623c 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2092,6 +2092,15 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
(syntax-case e ()
+ ((_) (expand
+ ;; a terrible hack to produce helpful error messages in most cases
+ #`(lambda (created by case-lambda with no clauses
+ a b c d e f g h i j k l m n o p q r s t u v w x y z)
+ (scm-error
+ '#,'wrong-number-of-args #f
+ "Wrong number of arguments to a procedure created by case-lambda with no clauses"
+ '() #f))
+ r w mod))
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
@@ -2105,6 +2114,7 @@
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
(syntax-case e ()
+ ((_) (expand #'(case-lambda) r w mod))
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ee688c0..bb2be06 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 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
@@ -163,4 +163,11 @@
(display (list x y))
(list x y))))
(display (t 'x)))))
- "(x y)(x y)")))
+ "(x y)(x y)"))
+
+ (pass-if-exception "zero clauses"
+ exception:wrong-num-args
+ ;; See <http://bugs.gnu.org/9776>.
+ (compile '(let ((p (case-lambda)))
+ (and (procedure? p) (p)))
+ #:to 'value)))
bug-guile <at> gnu.org:bug#9776; Package guile.
(Thu, 02 Feb 2012 22:18:02 GMT) Full text and rfc822 format available.Message #20 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Mark H Weaver <mhw <at> netris.org> Cc: 9776 <at> debbugs.gnu.org, Göran Weinholt <goran <at> weinholt.se>, Ian Price <ianprice90 <at> googlemail.com> Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Thu, 02 Feb 2012 23:16:45 +0100
[Message part 1 (text/plain, inline)]
Hi Mark, Mark H Weaver <mhw <at> netris.org> skribis: > Thanks for tackling this. Of course this is Andy's area, but psyntax is > still fresh in my mind, so I'll attempt a review as well as my own > tentative approach. Psyntax is not yet a place where I feel comfortable, so I appreciate. :-) > ludo <at> gnu.org (Ludovic Courtès) writes: >> So, here’s a tentative patch for review: >> >> >> Modified module/ice-9/psyntax.scm >> diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm >> index 728ab12..c3aa6d8 100644 >> --- a/module/ice-9/psyntax.scm >> +++ b/module/ice-9/psyntax.scm >> @@ -1778,7 +1778,19 @@ >> r* w* mod))))) >> >> (syntax-case clauses () >> - (() (values '() #f)) >> + (() ; zero clauses >> + (values >> + '() >> + (build-lambda-case s '() '() 'rest #f '() >> + (list (build-lexical-var s 'rest)) >> + (build-application s >> + (make-toplevel-ref s 'throw) > > This 'make-toplevel-ref' should instead be 'build-primref', so that it > refers to the 'throw' in the 'guile' module. As it is now, this won't > work in modules that have bound 'throw' to something else. Oh, OK. >> + (list >> + (build-data >> + s 'wrong-number-of-args) >> + (build-data >> + s "Wrong number of arguments"))) >> + #f))) > > Unfortunately, the above case is not only triggered for an empty > case-lambda; it is the base case at the end of iteration over the > clauses, so this code will be added to _every_ case-lambda. Oops, indeed. > Apart from the extra bloat, this will make error reporting much worse. > Right now, if you call a procedure created by 'case-lambda' with an > incorrect number of arguments, the VM will generate a nice error message > that includes the procedure itself, including the procedure's name. > > By adding this "catch-all" clause to the end of every 'case-lambda', you > have taken over the job of error reporting for _all_ case-lambdas, but > you produce a much less useful error message than the VM does. > > This also destroys the arity information for all case-lambdas. OK, I see. [...] > Here's how it reports errors: > >> scheme@(guile-user)> (define foo (case-lambda)) >> scheme@(guile-user)> (foo) >> ;;; <stdin>:2:0: warning: possibly wrong number of arguments to `foo' >> ERROR: In procedure foo: >> ERROR: Wrong number of arguments to #<procedure foo (created by case-lambda with no clauses a b c d e f g h i j k l m n o p q r s t u v w x y z)> [...] > + ;; a terrible hack to produce helpful error messages in most cases > + #`(lambda (created by case-lambda with no clauses > + a b c d e f g h i j k l m n o p q r s t u v w x y z) > + (scm-error > + '#,'wrong-number-of-args #f > + "Wrong number of arguments to a procedure created by case-lambda with no clauses" > + '() #f)) But this is terrrrrible! What about something along these lines instead (untested):
[Message part 2 (text/x-patch, inline)]
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 728ab12..da7f16a 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1704,7 +1704,7 @@
orig-args))))
(req orig-args '())))
- (define expand-lambda-case
+ (define expand-lambda-case*
(lambda (e r w s mod get-formals clauses)
(define (parse-req req opt rest kw body)
(let ((vars (map gen-var req))
@@ -1795,6 +1795,25 @@
(build-lambda-case s req opt rest kw inits vars
body else*))))))))))))
+ (define expand-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (syntax-case clauses ()
+ (()
+ (values
+ '()
+ (build-lambda-case s '() '() 'rest #f '()
+ (list (build-lexical-var s 'rest))
+ (build-application s
+ (build-primref s 'throw)
+ (list
+ (build-data
+ s 'wrong-number-of-args)
+ (build-data
+ s "Wrong number of arguments")))
+ #f)))
+ (((args e1 e2 ...) (args* e1* e2* ...) ...)
+ (expand-lambda-case* e r w s mod get-formal clauses)))))
+
;; data
;; strips syntax-objects down to top-wrap
[Message part 3 (text/plain, inline)]
The idea would be to explicitly check for the zero-clause case before any recursive call is made. Thanks, Ludo’.
bug-guile <at> gnu.org:bug#9776; Package guile.
(Sat, 02 Mar 2013 18:14:02 GMT) Full text and rfc822 format available.Message #23 received at 9776 <at> debbugs.gnu.org (full text, mbox):
From: Andy Wingo <wingo <at> pobox.com> To: ludo <at> gnu.org (Ludovic Courtès) Cc: Mark H Weaver <mhw <at> netris.org>, Göran Weinholt <goran <at> weinholt.se>, Ian Price <ianprice90 <at> googlemail.com>, 9776 <at> debbugs.gnu.org Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Sat, 02 Mar 2013 19:13:21 +0100
[Message part 1 (text/plain, inline)]
Hi! Picking up an old thread. What do people think about the attached patch? It preserves arity checking for case-lambdas defined in the same compilation unit. Case-lambdas are converted to nullary procedures in the last minute, before compiling or memoizing. Calling one of these procedures with arguments will still produce an arity-check warning; calling one without arguments will not. In both cases a wrong-number-of-args exception is thrown at runtime (either by the normal argument count check or via the explicit throw in the body). I think allowing lambda-body to be #f is the right way to go because it precludes inlining of ((case-lambda)). I'll push soon if there are no comments. Andy
[0001-allow-case-lambda-expressions-with-no-clauses.patch (text/x-diff, inline)]
From 8dbcaecca7492788452881b3f06328329ed8bcf1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo <at> pobox.com>
Date: Sat, 2 Mar 2013 19:04:47 +0100
Subject: [PATCH] allow case-lambda expressions with no clauses
* module/ice-9/psyntax-pp.scm:
* module/ice-9/psyntax.scm (case-lambda, case-lambda*): Allow 0
clauses.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
(choose-output-names):
* module/language/tree-il.scm (unparse-tree-il):
(tree-il-fold, post-order!, pre-order!):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/peval.scm (peval): Allow for lambda-body to be
#f.
* libguile/memoize.c (memoize):
* module/language/tree-il/canonicalize.scm (canonicalize!): Give a body
to empty case-lambda before evaluating it or compiling it,
respectively.
* test-suite/tests/optargs.test ("case-lambda", "case-lambda*"): Add
tests.
---
libguile/memoize.c | 25 +++++++++++++++---
module/ice-9/psyntax-pp.scm | 30 +++++++++-------------
module/ice-9/psyntax.scm | 8 +++---
module/language/scheme/decompile-tree-il.scm | 35 ++++++++++++++------------
module/language/tree-il.scm | 22 +++++++++++-----
module/language/tree-il/canonicalize.scm | 17 ++++++++++++-
module/language/tree-il/cse.scm | 8 +++---
module/language/tree-il/debug.scm | 7 +++---
module/language/tree-il/effects.scm | 9 +++++--
module/language/tree-il/peval.scm | 4 +--
test-suite/tests/optargs.test | 13 ++++++++++
11 files changed, 120 insertions(+), 58 deletions(-)
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 584096f..dfbeea7 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -269,14 +269,33 @@ memoize (SCM exp, SCM env)
return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case. */
+ /* The body will be a lambda-case or #f. */
{
- SCM meta, docstring, proc;
+ SCM meta, docstring, body, proc;
meta = REF (exp, LAMBDA, META);
docstring = scm_assoc_ref (meta, scm_sym_documentation);
- proc = memoize (REF (exp, LAMBDA, BODY), env);
+ body = REF (exp, LAMBDA, BODY);
+ if (scm_is_false (body))
+ /* Give a body to case-lambda with no clauses. */
+ proc = MAKMEMO_LAMBDA
+ (MAKMEMO_CALL
+ (MAKMEMO_MOD_REF (list_of_guile,
+ scm_from_latin1_symbol ("throw"),
+ SCM_BOOL_F),
+ 5,
+ scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
+ MAKMEMO_QUOTE (SCM_BOOL_F),
+ MAKMEMO_QUOTE (scm_from_latin1_string
+ ("Wrong number of arguments")),
+ MAKMEMO_QUOTE (SCM_EOL),
+ MAKMEMO_QUOTE (SCM_BOOL_F))),
+ FIXED_ARITY (0),
+ SCM_BOOL_F /* docstring */);
+ else
+ proc = memoize (body, env);
+
if (scm_is_string (docstring))
{
SCM args = SCM_MEMOIZED_ARGS (proc);
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 2adb83e..7b565db 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1743,11 +1743,9 @@
'case-lambda
(lambda (e r w s mod)
(let* ((tmp e)
- (tmp ($sc-dispatch
- tmp
- '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
(if tmp
- (apply (lambda (args e1 e2 args* e1* e2*)
+ (apply (lambda (args e1 e2)
(call-with-values
(lambda ()
(expand-lambda-case
@@ -1757,11 +1755,10 @@
s
mod
lambda-formals
- (cons (cons args (cons e1 e2))
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
- e2*
- e1*
- args*))))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
(lambda (meta lcase) (build-case-lambda s meta lcase))))
tmp)
(syntax-violation 'case-lambda "bad case-lambda" e)))))
@@ -1770,11 +1767,9 @@
'case-lambda*
(lambda (e r w s mod)
(let* ((tmp e)
- (tmp ($sc-dispatch
- tmp
- '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
(if tmp
- (apply (lambda (args e1 e2 args* e1* e2*)
+ (apply (lambda (args e1 e2)
(call-with-values
(lambda ()
(expand-lambda-case
@@ -1784,11 +1779,10 @@
s
mod
lambda*-formals
- (cons (cons args (cons e1 e2))
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
- e2*
- e1*
- args*))))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
(lambda (meta lcase) (build-case-lambda s meta lcase))))
tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e)))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 336c8da..228d8e3 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2076,12 +2076,12 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ ((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ #'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
@@ -2089,12 +2089,12 @@
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
(syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ ((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda*-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ #'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index 9191b2f..f94661d 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 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
@@ -256,20 +256,22 @@
(build-define name (recurse exp)))
((<lambda> meta body)
- (let ((body (recurse body))
- (doc (assq-ref meta 'documentation)))
- (if (not doc)
- body
- (match body
- (('lambda formals body ...)
- `(lambda ,formals ,doc ,@body))
- (('lambda* formals body ...)
- `(lambda* ,formals ,doc ,@body))
- (('case-lambda (formals body ...) clauses ...)
- `(case-lambda (,formals ,doc ,@body) ,@clauses))
- (('case-lambda* (formals body ...) clauses ...)
- `(case-lambda* (,formals ,doc ,@body) ,@clauses))
- (e e)))))
+ (if body
+ (let ((body (recurse body))
+ (doc (assq-ref meta 'documentation)))
+ (if (not doc)
+ body
+ (match body
+ (('lambda formals body ...)
+ `(lambda ,formals ,doc ,@body))
+ (('lambda* formals body ...)
+ `(lambda* ,formals ,doc ,@body))
+ (('case-lambda (formals body ...) clauses ...)
+ `(case-lambda (,formals ,doc ,@body) ,@clauses))
+ (('case-lambda* (formals body ...) clauses ...)
+ `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+ (e e))))
+ '(case-lambda)))
((<lambda-case> req opt rest kw inits gensyms body alternate)
(let ((names (map output-name gensyms)))
@@ -694,7 +696,8 @@
(recurse test) (recurse consequent) (recurse alternate))
((<sequence> exps) (primitive 'begin) (for-each recurse exps))
- ((<lambda> body) (recurse body))
+ ((<lambda> body)
+ (if body (recurse body)))
((<lambda-case> req opt rest kw inits gensyms body alternate)
(primitive 'lambda)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1ac1809..aa00b38 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -287,7 +287,9 @@
`(define ,name ,(unparse-tree-il exp)))
((<lambda> meta body)
- `(lambda ,meta ,(unparse-tree-il body)))
+ (if body
+ `(lambda ,meta ,(unparse-tree-il body))
+ `(lambda ,meta (lambda-case))))
((<lambda-case> req opt rest kw inits gensyms body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
@@ -370,7 +372,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<sequence> exps)
(up tree (loop exps (down tree result))))
((<lambda> body)
- (up tree (loop body (down tree result))))
+ (let ((result (down tree result)))
+ (up tree
+ (if body
+ (loop body result)
+ result))))
((<lambda-case> inits body alternate)
(up tree (if alternate
(loop alternate
@@ -442,7 +448,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<sequence> exps)
(fold-values foldts exps seed ...))
((<lambda> body)
- (foldts body seed ...))
+ (if body
+ (foldts body seed ...)
+ (values seed ...)))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
@@ -511,7 +519,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> body)
- (set! (lambda-body x) (lp body)))
+ (if body
+ (set! (lambda-body x) (lp body))))
((<lambda-case> inits body alternate)
(set! inits (map lp inits))
@@ -595,7 +604,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> body)
- (set! (lambda-body x) (lp body)))
+ (if body
+ (set! (lambda-body x) (lp body))))
((<lambda-case> inits body alternate)
(set! inits (map lp inits))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index c3229ca..2fa8c2e 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -1,6 +1,6 @@
;;; Tree-il canonicalizer
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -54,6 +54,21 @@
body)
(($ <dynlet> src () () body)
body)
+ (($ <lambda> src meta #f)
+ ;; Give a body to case-lambda with no clauses.
+ (make-lambda
+ src meta
+ (make-lambda-case
+ #f '() #f #f #f '() '()
+ (make-application
+ #f
+ (make-primitive-ref #f 'throw)
+ (list (make-const #f 'wrong-number-of-args)
+ (make-const #f #f)
+ (make-const #f "Wrong number of arguments")
+ (make-const #f '())
+ (make-const #f #f)))
+ #f)))
(($ <prompt> src tag body handler)
(define (escape-only? handler)
(match handler
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index d8c7e3f..b025bcb 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -1,6 +1,6 @@
;;; Common Subexpression Elimination (CSE) on Tree-IL
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -535,8 +535,10 @@
(return (make-application src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
- (let*-values (((body _) (visit body (control-flow-boundary db)
- env 'values)))
+ (let*-values (((body _) (if body
+ (visit body (control-flow-boundary db)
+ env 'values)
+ (values #f #f))))
(return (make-lambda src meta body)
vlist-null)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 78f1324..97737c2 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -1,6 +1,6 @@
;;; Tree-IL verifier
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -115,10 +115,11 @@
(cond
((and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
- ((not (lambda-case? body))
+ ((and body (not (lambda-case? body)))
(error "lambda body should be lambda-case" exp))
(else
- (visit body env))))
+ (if body
+ (visit body env)))))
(($ <let> src names gensyms vals body)
(cond
((not (and (list? names) (and-map symbol? names)))
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 4610f7f..1fe4aeb 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on Tree-IL
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -315,7 +315,12 @@ of an expression."
(cause &type-check))))
(($ <lambda-case>)
(logior (compute-effects body)
- (cause &type-check))))))
+ (cause &type-check)))
+ (#f
+ ;; Calling a case-lambda with no clauses
+ ;; definitely causes bailout.
+ (logior (cause &definite-bailout)
+ (cause &possible-bailout))))))
;; Bailout primitives.
(($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index da3f4a8..bf96179 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1440,14 +1440,14 @@ top-level bindings from ENV and return the resulting expression."
((operator) exp)
(else (record-source-expression!
exp
- (make-lambda src meta (for-values body))))))
+ (make-lambda src meta (and body (for-values body)))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
(($ <application> _
($ <primitive-ref> _ '@apply)
- (($ <lambda> _ _ lcase)
+ (($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
(and (equal? sym gensyms)
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 396fdec..0be1a54 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -221,7 +221,20 @@
(equal? (transmogrify quote)
10)))
+(with-test-prefix/c&e "case-lambda"
+ (pass-if-exception "no clauses, no args" exception:wrong-num-args
+ ((case-lambda)))
+
+ (pass-if-exception "no clauses, args" exception:wrong-num-args
+ ((case-lambda) 1)))
+
(with-test-prefix/c&e "case-lambda*"
+ (pass-if-exception "no clauses, no args" exception:wrong-num-args
+ ((case-lambda*)))
+
+ (pass-if-exception "no clauses, args" exception:wrong-num-args
+ ((case-lambda*) 1))
+
(pass-if "unambiguous"
((case-lambda*
((a b) #t)
--
1.7.10.4
[Message part 3 (text/plain, inline)]
-- http://wingolog.org/
Andy Wingo <wingo <at> pobox.com>:Göran Weinholt <goran <at> weinholt.se>:Message #28 received at 9776-done <at> debbugs.gnu.org (full text, mbox):
From: Andy Wingo <wingo <at> pobox.com> To: ludo <at> gnu.org (Ludovic Courtès) Cc: Ian Price <ianprice90 <at> googlemail.com>, 9776-done <at> debbugs.gnu.org, Göran Weinholt <goran <at> weinholt.se> Subject: Re: bug#9776: case-lambda should accept zero clauses Date: Sat, 09 Mar 2013 11:17:44 +0100
On Sat 02 Mar 2013 19:13, Andy Wingo <wingo <at> pobox.com> writes: > Picking up an old thread. What do people think about the attached > patch? It preserves arity checking for case-lambdas defined in the same > compilation unit. Case-lambdas are converted to nullary procedures in > the last minute, before compiling or memoizing. Calling one of these > procedures with arguments will still produce an arity-check warning; > calling one without arguments will not. In both cases a > wrong-number-of-args exception is thrown at runtime (either by the > normal argument count check or via the explicit throw in the body). > > I think allowing lambda-body to be #f is the right way to go because it > precludes inlining of ((case-lambda)). > > I'll push soon if there are no comments. Pushed. Later we can figure out a way to warn for all applications of (case-lambda), regardless of arity. Andy -- http://wingolog.org/
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Sat, 06 Apr 2013 11:24:05 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.