dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Nicer docstring syntax for case-lambda.

Browse source 
* module/ice-9/psyntax.scm (case-lambda, case-lambda*): Allow a
  docstring to be placed immediately after the 'case-lambda' or
  'case-lambda*'.

* module/ice-9/psyntax-pp.scm: Regenerate.

* doc/ref/api-procedures.texi (Case-lambda): Update docs.

* test-suite/tests/optargs.test ("case-lambda", "case-lambda*"):
  Add tests.
This commit is contained in:
Mark H Weaver 2013-04-04 15:22:18 -04:00
commit 0426b3f8f8
4 changed files with 110 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

4
doc/ref/api-procedures.texi
View file

@ -575,7 +575,8 @@ with @code{lambda} (@pxref{Lambda}).
@example
@group
<case-lambda>
--> (case-lambda <case-lambda-clause>)
--> (case-lambda <case-lambda-clause>*)
--> (case-lambda <docstring> <case-lambda-clause>*)
<case-lambda-clause>
--> (<formals> <definition-or-command>*)
<formals>
@ -590,6 +591,7 @@ Rest lists can be useful with @code{case-lambda}:
@lisp
(define plus
(case-lambda
"Return the sum of all arguments."
(() 0)
((a) a)
((a b) (+ a b))

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

@ -1742,50 +1742,72 @@
'core
'case-lambda
(lambda (e r w s mod)
(let* ((tmp e)
(tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
(if tmp
(apply (lambda (args e1 e2)
(call-with-values
(lambda ()
(expand-lambda-case
e
r
w
s
mod
lambda-formals
(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)))))
(letrec*
((build-it
(lambda (meta clauses)
(call-with-values
(lambda () (expand-lambda-case e r w s mod lambda-formals clauses))
(lambda (meta* lcase)
(build-case-lambda s (append meta meta*) lcase))))))
(let* ((tmp-1 e)
(tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
(if tmp
(apply (lambda (args e1 e2)
(build-it
'()
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
e2
e1
args)))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
(if (and tmp
(apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
tmp))
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
e2
e1
args)))
tmp)
(syntax-violation 'case-lambda "bad case-lambda" e))))))))
(global-extend
'core
'case-lambda*
(lambda (e r w s mod)
(let* ((tmp e)
(tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
(if tmp
(apply (lambda (args e1 e2)
(call-with-values
(lambda ()
(expand-lambda-case
e
r
w
s
mod
lambda*-formals
(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)))))
(letrec*
((build-it
(lambda (meta clauses)
(call-with-values
(lambda () (expand-lambda-case e r w s mod lambda*-formals clauses))
(lambda (meta* lcase)
(build-case-lambda s (append meta meta*) lcase))))))
(let* ((tmp-1 e)
(tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
(if tmp
(apply (lambda (args e1 e2)
(build-it
'()
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
e2
e1
args)))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
(if (and tmp
(apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
tmp))
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
e2
e1
args)))
tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e))))))))
(global-extend
'core
'let

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

@ -2075,28 +2075,42 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
(define (build-it meta clauses)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda-formals
clauses))
(lambda (meta* lcase)
(build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda-formals
#'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(build-it '() #'((args e1 e2 ...) ...)))
((_ docstring (args e1 e2 ...) ...)
(string? (syntax->datum #'docstring))
(build-it `((documentation
. ,(syntax->datum #'docstring)))
#'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
(define (build-it meta clauses)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda*-formals
clauses))
(lambda (meta* lcase)
(build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
((_ (args e1 e2 ...) ...)
(call-with-values
(lambda ()
(expand-lambda-case e r w s mod
lambda*-formals
#'((args e1 e2 ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(build-it '() #'((args e1 e2 ...) ...)))
((_ docstring (args e1 e2 ...) ...)
(string? (syntax->datum #'docstring))
(build-it `((documentation
. ,(syntax->datum #'docstring)))
#'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let

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

@ -226,7 +226,15 @@
((case-lambda)))
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda) 1)))
((case-lambda) 1))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda
"docstring test"
(() 0)
((x) 1))))))
(with-test-prefix/c&e "case-lambda*"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
@ -235,6 +243,14 @@
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda*) 1))
(pass-if "docstring"
(equal? "docstring test"
(procedure-documentation
(case-lambda*
"docstring test"
(() 0)
((x) 1)))))
(pass-if "unambiguous"
((case-lambda*
((a b) #t)