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
>From 8dbcaecca7492788452881b3f06328329ed8bcf1 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wi...@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
--
http://wingolog.org/
