From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Jean Abou Samra Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] In curried definitions, move docstrings to outermost lambda Date: Tue, 29 Mar 2022 01:25:21 +0200 Message-ID: Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8; format=flowed Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="27041"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:91.0) Gecko/20100101 Thunderbird/91.7.0 Cc: guile-devel@gnu.org To: 50068@debbugs.gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Tue Mar 29 01:26:28 2022 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1nYykm-0006t3-2T for guile-devel@m.gmane-mx.org; Tue, 29 Mar 2022 01:26:28 +0200 Original-Received: from localhost ([::1]:40356 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1nYykk-0008Pw-KA for guile-devel@m.gmane-mx.org; Mon, 28 Mar 2022 19:26:26 -0400 Original-Received: from eggs.gnu.org ([209.51.188.92]:44550) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nYyjx-0008PY-Ks for guile-devel@gnu.org; Mon, 28 Mar 2022 19:25:38 -0400 Original-Received: from mout.kundenserver.de ([217.72.192.73]:56885) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1nYyjs-0005WP-DU for guile-devel@gnu.org; Mon, 28 Mar 2022 19:25:37 -0400 Original-Received: from [10.188.216.67] ([46.193.67.184]) by mrelayeu.kundenserver.de (mreue107 [212.227.15.184]) with ESMTPSA (Nemesis) id 1MEVqu-1nnsyG0gu2-00FxpD; Tue, 29 Mar 2022 01:25:22 +0200 Content-Language: en-US X-Provags-ID: V03:K1:O+fYQ5i/PuO92di3boOzLYIRvPvvvGgMCGar3qRf8AJr1/I+GPD jyDJiV3NIn3dlNggoIHWgt+sW3JCAE49IA317X7/KN2k7zuuRGAm2VsNUhqcNAIyiGAbkHl fsVZvnnqyxJ2QjN509gay9E2yRp1Re25av3SQP7hAL5Rj5BFqe5OJou91y48G9qYgEHIZ5l Plq6AEAH6alMLyL0BSSDQ== X-UI-Out-Filterresults: notjunk:1;V03:K0:RzZgqL2d7us=:O9yBgGS8e1cuGh0hdpjCnD JJ/1SPiwg7QHtkLQvoofLwOwK9kvjuRIYgG9H6xt1oZUVk5Uu2Sfnn0vawUzLGW4nhjV/5Nnk i4ZARWDSPwerlORaCquKibHMtbbQpfNFfZgGEstugZZ4F5WrRBVuKqmRe8DpDPAtB0rNk4oYs dOvBI8cvhWO1RJLVHFSicKbtc7/FYzZv9CgcS7Ll+a+RA3jTyzKbsNCP5tqonZceSI5zXKTke t31Y4z6KilQoj4NOiSGBDdicDHMZQX9YcrMlKh66gCA+CmCJbt+loPbBisbAkFC3xAPcCHhw4 fGODKjdSFQ8K7oGUs8t8B1MV4cwJXaKUUkopmVXV6wFtMYCAFJUF9Ra6vdsLwQ5HqsQu85qy2 OPc73o/3KQRV4MVixi6u/SvFbMwv8JBZ2nCF2jDnsjejQ/I14nrx7Up0oZbeqALGXzAXUA6eZ BPdpqEV8Et2WtSK0YAhybGTTfl9FKzKtRCW7usbYsdu7E0ezXOgF8jU/53DmNhrjHfh6Mj0uu ve1dVhqvXfP9WTJjd6xfjwQpWb5tv/bWINcX6r+ez0gqChhePTg1iEjgg/23BoJ9um+c1oD1U O2FqFFu8BVPfLB3PQNXS6ROa3s0TjVeK9OPASEV+szfss9LGrkv4nN+/71VDF6d5yrbcduZ4J VZbPPAC2mf90N3gpBpBOB9+OijUTccui3lmFeAu2L4ACjqKv90+cAKUahCI53NaG35DE= Received-SPF: none client-ip=217.72.192.73; envelope-from=jean@abou-samra.fr; helo=mout.kundenserver.de X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, RCVD_IN_DNSWL_NONE=-0.0001, RCVD_IN_MSPIKE_H4=0.001, RCVD_IN_MSPIKE_WL=0.001, SPF_HELO_NONE=0.001, SPF_NONE=0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:21181 Archived-At: Hi, Please consider the following patch, fixing bug #50068. Best regards, Jean From 79552d2974e9cbcfcf01960aab68cb6824c88972 Mon Sep 17 00:00:00 2001 From: Jean Abou Samra Date: Tue, 29 Mar 2022 00:14:45 +0200 Subject: [PATCH] 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 ---  module/ice-9/curried-definitions.scm      | 72 ++++++++++++-----------  test-suite/tests/curried-definitions.test | 56 ++++++++++++++++--  2 files changed, 90 insertions(+), 38 deletions(-) diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm index 7545338e3..7e758be5e 100644 --- a/module/ice-9/curried-definitions.scm +++ b/module/ice-9/curried-definitions.scm @@ -4,12 +4,12 @@  ;;;; modify it under the terms of the GNU Lesser General Public  ;;;; License as published by the Free Software Foundation; either  ;;;; version 3 of the License, or (at your option) any later version. -;;;; +;;;;  ;;;; This library is distributed in the hope that it will be useful,  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU  ;;;; Lesser General Public License for more details. -;;;; +;;;;  ;;;; You should have received a copy of the GNU Lesser General Public  ;;;; License along with this library; if not, write to the Free Software  ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA @@ -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..cd535b162 100644 --- a/test-suite/tests/curried-definitions.test +++ b/test-suite/tests/curried-definitions.test @@ -5,12 +5,12 @@  ;;;; modify it under the terms of the GNU Lesser General Public  ;;;; License as published by the Free Software Foundation; either  ;;;; version 3 of the License, or (at your option) any later version. -;;;; +;;;;  ;;;; This library is distributed in the hope that it will be useful,  ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU  ;;;; Lesser General Public License for more details. -;;;; +;;;;  ;;;; You should have received a copy of the GNU Lesser General Public  ;;;; License along with this library; if not, write to the Free Software  ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA @@ -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)))))) -- 2.32.0