mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

allow case-lambda expressions with no clauses

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-03-02 19:04:47 +01:00
parent 9ddf06dcee
commit 19113f1ca7
11 changed files with 120 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

25
libguile/memoize.c
View file

@ -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);

30
module/ice-9/psyntax-pp.scm
View file

@ -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)))))

8
module/ice-9/psyntax.scm
View file

@ -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)))))

35
module/language/scheme/decompile-tree-il.scm
View file

@ -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)

22
module/language/tree-il.scm
View file

@ -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))

17
module/language/tree-il/canonicalize.scm
View file

@ -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

8
module/language/tree-il/cse.scm
View file

@ -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)

7
module/language/tree-il/debug.scm
View file

@ -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)))

9
module/language/tree-il/effects.scm
View file

@ -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))

4
module/language/tree-il/peval.scm
View file

@ -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)

13
test-suite/tests/optargs.test
View file

@ -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)