Subject: bug#9776: case-lambda should accept zero clauses

From: Andy Wingo <[email-masked]>
Date: Sat, 02 Mar 2013 19:13:21 +0100

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 <[email-masked]>
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/