diff options
author | Jean Abou Samra <jean@abou-samra.fr> | 2022-03-29 00:14:45 +0200 |
---|---|---|
committer | Daniel Llorens <lloda@sarc.name> | 2022-08-29 11:45:39 +0200 |
commit | 61d8dab8eafd498306ce618582aab37497df77b4 (patch) | |
tree | 6f1d95fc58b76b773bfd403d275a11349811923a | |
parent | eb5ecf4944cd646341f7e47dda5396cf96a4b8a3 (diff) | |
download | guile-61d8dab8eafd498306ce618582aab37497df77b4.tar.gz |
In curried definitions, move docstrings to outermost lambda
This makes the docstring attached to the curried function being defined
rather than the result of its application until a function that runs the
body is obtained, fixing
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=50068
-rw-r--r-- | module/ice-9/curried-definitions.scm | 68 | ||||
-rw-r--r-- | test-suite/tests/curried-definitions.test | 52 |
2 files changed, 86 insertions, 34 deletions
diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm index 7545338e3..3d76a25cd 100644 --- a/module/ice-9/curried-definitions.scm +++ b/module/ice-9/curried-definitions.scm @@ -20,38 +20,42 @@ define-public define*-public)) -(define-syntax cdefine - (syntax-rules () - ((_ (head . rest) body body* ...) - (cdefine head - (lambda rest body body* ...))) - ((_ name val) - (define name val)))) +(define-syntax make-currying-define + (syntax-rules ::: () + ((_ currying-name lambda-name) + (define-syntax currying-name + (lambda (St-Ax) + (syntax-case St-Ax () + ((_ ((head2 . rest2) . rest) docstring body body* ...) + (string? (syntax->datum #'docstring)) + ;; Keep moving docstring to outermost lambda. + #'(currying-name (head2 . rest2) + docstring + (lambda-name rest body body* ...))) + ((_ (head . rest) body body* ...) + #'(currying-name head + (lambda-name rest body body* ...))) + ((_ name val) + #'(define name val)))))))) -(define-syntax cdefine* - (syntax-rules () - ((_ (head . rest) body body* ...) - (cdefine* head - (lambda* rest body body* ...))) - ((_ name val) - (define* name val)))) +(make-currying-define cdefine lambda) +(make-currying-define cdefine* lambda*) -(define-syntax define-public - (syntax-rules () - ((_ (head . rest) body body* ...) - (define-public head - (lambda rest body body* ...))) - ((_ name val) - (begin - (define name val) - (export name))))) +(define-syntax make-currying-define-public + (syntax-rules ::: () + ((_ public-name define-name) + (define-syntax public-name + (lambda (St-Ax) + (syntax-case St-Ax () + ((_ binding body body* ...) + #`(begin + (define-name binding body body* ...) + (export #,(let find-name ((form #'binding)) + (syntax-case form () + ((head . tail) + (find-name #'head)) + (name + #'name)))))))))))) -(define-syntax define*-public - (syntax-rules () - ((_ (head . rest) body body* ...) - (define*-public head - (lambda* rest body body* ...))) - ((_ name val) - (begin - (define* name val) - (export name))))) +(make-currying-define-public define-public cdefine) +(make-currying-define-public define*-public cdefine*) diff --git a/test-suite/tests/curried-definitions.test b/test-suite/tests/curried-definitions.test index b4a1f6509..c6e8dd3f5 100644 --- a/test-suite/tests/curried-definitions.test +++ b/test-suite/tests/curried-definitions.test @@ -49,7 +49,33 @@ (equal? 444 (primitive-eval '(let () (define foo 444) - foo))))) + foo)))) + + (pass-if "docstring" + (equal? "Doc" + (primitive-eval '(let () + (define (((foo a) b c) d) + "Doc" + 42) + (procedure-documentation foo))))) + + (pass-if "define-public" + (eqv? 6 + (primitive-eval '(let () + (define-public (((f a) b) c) + (+ a b c)) + (((f 1) 2) 3))))) + + ;; FIXME: how to test for define-public actually making + ;; a public binding? + + (pass-if "define-public and docstring" + (equal? "Addition curried." + (primitive-eval '(let () + (define-public (((f a) b) c) + "Addition curried." + (+ a b c)) + (procedure-documentation f)))))) (with-test-prefix "define*" (pass-if "define* works as usual" @@ -81,4 +107,26 @@ (equal? 444 (primitive-eval '(let () (define* foo 444) - foo))))) + foo)))) + (pass-if "docstring" + (equal? "Doc" + (primitive-eval '(let () + (define* (((f a) b c) #:optional d) + "Doc" + 42) + (procedure-documentation f))))) + + (pass-if "define*-public" + (eqv? 6 + (primitive-eval '(let () + (define*-public (((f a) b) #:optional c) + (+ a b c)) + (((f 1) 2) 3))))) + + (pass-if "define*-public and docstring" + (equal? "Addition curried." + (primitive-eval '(let () + (define*-public (((f a) b) #:key (c 3)) + "Addition curried." + (+ a b c)) + (procedure-documentation f)))))) |