diff --git a/libguile/memoize.c b/libguile/memoize.c index 584096fbd..dfbeea781 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 2adb83ec6..7b565dbe8 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 336c8da96..228d8e32a 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 9191b2f96..f94661da4 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))) (( 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))) (( req opt rest kw inits gensyms body alternate) (let ((names (map output-name gensyms))) @@ -694,7 +696,8 @@ (recurse test) (recurse consequent) (recurse alternate)) (( exps) (primitive 'begin) (for-each recurse exps)) - (( body) (recurse body)) + (( body) + (if body (recurse body))) (( 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 1ac1809fb..aa00b381e 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))) (( meta body) - `(lambda ,meta ,(unparse-tree-il body))) + (if body + `(lambda ,meta ,(unparse-tree-il body)) + `(lambda ,meta (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 (( exps) (up tree (loop exps (down tree result)))) (( body) - (up tree (loop body (down tree result)))) + (let ((result (down tree result))) + (up tree + (if body + (loop body result) + result)))) (( 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 (( exps) (fold-values foldts exps seed ...)) (( body) - (foldts body seed ...)) + (if body + (foldts body seed ...) + (values seed ...))) (( 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))) (( body) - (set! (lambda-body x) (lp body))) + (if body + (set! (lambda-body x) (lp body)))) (( 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))) (( body) - (set! (lambda-body x) (lp body))) + (if body + (set! (lambda-body x) (lp body)))) (( 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 c3229cab1..2fa8c2ec9 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) (($ src () () body) body) + (($ 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))) (($ 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 d8c7e3fc9..b025bcb08 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*)))) (($ 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))) (($ 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 78f132416..97737c29b 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))))) (($ 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 4610f7f8f..1fe4aebb0 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)))) (($ ) (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. (($ src ($ _ (? bailout-primitive? name)) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index da3f4a82c..bf96179e0 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))))))) (($ src req opt rest kw inits gensyms body alt) (define (lift-applied-lambda body gensyms) (and (not opt) rest (not kw) (match body (($ _ ($ _ '@apply) - (($ _ _ lcase) + (($ _ _ (and lcase ($ ))) ($ _ _ sym) ...)) (and (equal? sym gensyms) diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 396fdeca8..0be1a541e 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)