[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Nicer docstring syntax for case-lambda
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Nicer docstring syntax for case-lambda |
|
Date: |
Thu, 04 Apr 2013 15:28:24 -0400 |
Hello all,
Currently, the only way to add docstrings to 'case-lambda' or
'case-lambda*' forms is to put them like this:
(case-lambda
((x)
"this is the docstring"
x)
((x y)
"this one is not easily accessible"
(+ x y)))
After applying the attached patch, the above syntax is still supported,
but you can also do this:
(case-lambda
"this is the docstring"
((x) x)
((x y) (+ x y)))
What do you think?
Mark
>From 0426b3f8f8036364aca13c24ef769283937faa3d Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Thu, 4 Apr 2013 15:22:18 -0400
Subject: [PATCH] Nicer docstring syntax for case-lambda.
* 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.
---
doc/ref/api-procedures.texi | 4 +-
module/ice-9/psyntax-pp.scm | 102 +++++++++++++++++++++++++----------------
module/ice-9/psyntax.scm | 42 +++++++++++------
test-suite/tests/optargs.test | 18 +++++++-
4 files changed, 110 insertions(+), 56 deletions(-)
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8ff240a..e11479d 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -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))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7b565db..8619d78 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 228d8e3..b359fc1 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 0be1a54..16a4533 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -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)
--
1.7.10.4
- [PATCH] Nicer docstring syntax for case-lambda,
Mark H Weaver <=