* bug#9776: case-lambda should accept zero clauses
@ 2011-10-17 10:15 Göran Weinholt
2012-01-05 22:06 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Göran Weinholt @ 2011-10-17 10:15 UTC (permalink / raw)
To: 9776
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@weinholt.se>
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2011-10-17 10:15 bug#9776: case-lambda should accept zero clauses Göran Weinholt
@ 2012-01-05 22:06 ` Ludovic Courtès
2012-01-08 4:45 ` Ian Price
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2012-01-05 22:06 UTC (permalink / raw)
To: Göran Weinholt; +Cc: 9776
Hi Göran,
Sorry for the delay.
Göran Weinholt <goran@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’.
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2012-01-05 22:06 ` Ludovic Courtès
@ 2012-01-08 4:45 ` Ian Price
2012-01-31 22:55 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Ian Price @ 2012-01-08 4:45 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 9776, Göran Weinholt
ludo@gnu.org (Ludovic Courtès) writes:
> Hi Göran,
>
> Sorry for the delay.
>
> Göran Weinholt <goran@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"
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2012-01-08 4:45 ` Ian Price
@ 2012-01-31 22:55 ` Ludovic Courtès
2012-02-01 5:07 ` Mark H Weaver
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2012-01-31 22:55 UTC (permalink / raw)
To: Ian Price; +Cc: 9776, Göran Weinholt
[-- Attachment #1: Type: text/plain, Size: 1133 bytes --]
Hi Ian,
Sorry for the late reply.
Ian Price <ianprice90@googlemail.com> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>
>> Hi Göran,
>>
>> Sorry for the delay.
>>
>> Göran Weinholt <goran@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:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 3957 bytes --]
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)))
[-- Attachment #3: Type: text/plain, Size: 553 bytes --]
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’.
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2012-01-31 22:55 ` Ludovic Courtès
@ 2012-02-01 5:07 ` Mark H Weaver
2012-02-02 22:16 ` Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Mark H Weaver @ 2012-02-01 5:07 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 9776, Göran Weinholt, Ian Price
[-- Attachment #1: Type: text/plain, Size: 3800 bytes --]
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@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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Mark's hackish zero-clause case-lambda fix --]
[-- Type: text/x-patch, Size: 2418 bytes --]
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)))
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2012-02-01 5:07 ` Mark H Weaver
@ 2012-02-02 22:16 ` Ludovic Courtès
2013-03-02 18:13 ` Andy Wingo
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2012-02-02 22:16 UTC (permalink / raw)
To: Mark H Weaver; +Cc: 9776, Göran Weinholt, Ian Price
[-- Attachment #1: Type: text/plain, Size: 3670 bytes --]
Hi Mark,
Mark H Weaver <mhw@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@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):
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 1620 bytes --]
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
[-- Attachment #3: Type: text/plain, Size: 123 bytes --]
The idea would be to explicitly check for the zero-clause case before
any recursive call is made.
Thanks,
Ludo’.
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2012-02-02 22:16 ` Ludovic Courtès
@ 2013-03-02 18:13 ` Andy Wingo
2013-03-09 10:17 ` Andy Wingo
0 siblings, 1 reply; 8+ messages in thread
From: Andy Wingo @ 2013-03-02 18:13 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Göran Weinholt, Ian Price, 9776
[-- Attachment #1: Type: text/plain, Size: 708 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-allow-case-lambda-expressions-with-no-clauses.patch --]
[-- Type: text/x-diff, Size: 19633 bytes --]
From 8dbcaecca7492788452881b3f06328329ed8bcf1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@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
[-- Attachment #3: Type: text/plain, Size: 26 bytes --]
--
http://wingolog.org/
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#9776: case-lambda should accept zero clauses
2013-03-02 18:13 ` Andy Wingo
@ 2013-03-09 10:17 ` Andy Wingo
0 siblings, 0 replies; 8+ messages in thread
From: Andy Wingo @ 2013-03-09 10:17 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: Göran Weinholt, 9776-done, Ian Price
On Sat 02 Mar 2013 19:13, Andy Wingo <wingo@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/
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2013-03-09 10:17 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-10-17 10:15 bug#9776: case-lambda should accept zero clauses Göran Weinholt
2012-01-05 22:06 ` Ludovic Courtès
2012-01-08 4:45 ` Ian Price
2012-01-31 22:55 ` Ludovic Courtès
2012-02-01 5:07 ` Mark H Weaver
2012-02-02 22:16 ` Ludovic Courtès
2013-03-02 18:13 ` Andy Wingo
2013-03-09 10:17 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).