From: Mark H Weaver Date: Thu, 4 Apr 2013 19:22:18 +0000 (-0400) Subject: Nicer docstring syntax for case-lambda. X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/0426b3f8f8036364aca13c24ef769283937faa3d 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. --- diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 8ff240a14..e11479dc2 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 *) --> ( *) @@ -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 7b565dbe8..8619d78c6 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 228d8e32a..b359fc1db 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 0be1a541e..16a45336a 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)