From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Leo Prikler Newsgroups: gmane.lisp.guile.bugs Subject: bug#44050: [PATCH] doc-snarf: Add support for (ice-9 optargs) define*s. Date: Sun, 18 Oct 2020 01:50:49 +0200 Message-ID: <20201017235049.19525-1-leo.prikler@student.tugraz.at> Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="20435"; mail-complaints-to="usenet@ciao.gmane.io" To: 44050@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Sun Oct 18 01:52:08 2020 Return-path: Envelope-to: guile-bugs@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 1kTvzb-0005C5-W1 for guile-bugs@m.gmane-mx.org; Sun, 18 Oct 2020 01:52:08 +0200 Original-Received: from localhost ([::1]:35816 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1kTvza-0004NO-Ke for guile-bugs@m.gmane-mx.org; Sat, 17 Oct 2020 19:52:06 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:57042) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kTvzW-0004Mz-Ls for bug-guile@gnu.org; Sat, 17 Oct 2020 19:52:02 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:52436) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1kTvzW-0000HO-D2 for bug-guile@gnu.org; Sat, 17 Oct 2020 19:52:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1kTvzW-0004Nt-Ao for bug-guile@gnu.org; Sat, 17 Oct 2020 19:52:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Leo Prikler Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sat, 17 Oct 2020 23:52:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 44050 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-guile@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.160297868416804 (code B ref -1); Sat, 17 Oct 2020 23:52:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 17 Oct 2020 23:51:24 +0000 Original-Received: from localhost ([127.0.0.1]:35749 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kTvyt-0004My-RU for submit@debbugs.gnu.org; Sat, 17 Oct 2020 19:51:24 -0400 Original-Received: from lists.gnu.org ([209.51.188.17]:52816) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1kTvyr-0004Mq-Sr for submit@debbugs.gnu.org; Sat, 17 Oct 2020 19:51:22 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:56938) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kTvyq-0004J5-L2 for bug-guile@gnu.org; Sat, 17 Oct 2020 19:51:21 -0400 Original-Received: from mailrelay.tugraz.at ([129.27.2.202]:43040) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1kTvym-0000Dz-W0 for bug-guile@gnu.org; Sat, 17 Oct 2020 19:51:19 -0400 Original-Received: from localhost.localdomain (217-149-162-161.nat.highway.telekom.at [217.149.162.161]) by mailrelay.tugraz.at (Postfix) with ESMTPSA id 4CDKXp5ZXnz1LLyW for ; Sun, 18 Oct 2020 01:51:06 +0200 (CEST) DKIM-Filter: OpenDKIM Filter v2.11.0 mailrelay.tugraz.at 4CDKXp5ZXnz1LLyW DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tugraz.at; s=mailrelay; t=1602978666; bh=alfpoPbD4Mfr0mpCDnIWCB2h1NQzu5mb87eGZsMrQRc=; h=From:To:Subject:Date:From; b=e31FFPwhAIWEkhPxBiFSHPj6TG27irLdUhxNxixE1H2Xvoylv4PTOQgZp9aN4U68P Kvq836WCN8fVXdFTAgm3NlYJ+7VI0YV4cTPzCeMd148xs6modTE+4tZ7FZS6maxuCh w6imAdoQyumf8qXKgte7PG7pJ1lPfBF2iSQoQMgw= X-Mailer: git-send-email 2.28.0 X-TUG-Backscatter-control: bt4lQm5Tva3SBgCuw0EnZw X-Scanned-By: MIMEDefang 2.74 on 129.27.10.117 Received-SPF: pass client-ip=129.27.2.202; envelope-from=leo.prikler@student.tugraz.at; helo=mailrelay.tugraz.at X-detected-operating-system: by eggs.gnu.org: First seen = 2020/10/17 19:51:08 X-ACL-Warn: Detected OS = Linux 3.11 and newer [fuzzy] X-Spam_score_int: -42 X-Spam_score: -4.3 X-Spam_bar: ---- X-Spam_report: (-4.3 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_MED=-2.3, RCVD_IN_MSPIKE_H3=0.001, RCVD_IN_MSPIKE_WL=0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.io gmane.lisp.guile.bugs:9900 Archived-At: * module/scripts/doc-snarf.scm (supported-languages)[scheme]: Limit signature start to define and define*. (peek-sexp): New variable. (find-std-int-doc): Implement in terms of peek-sexp. (parse-entry, make-prototype, get-symbol): Use full function definition instead of def-line. (snarf): Adjust accordingly. (join-symbols): Removed variable. (parse-defun): New variable. --- module/scripts/doc-snarf.scm | 141 +++++++++++++++++++++-------------- 1 file changed, 86 insertions(+), 55 deletions(-) diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm index fa3dfb312..3dd714d9e 100644 --- a/module/scripts/doc-snarf.scm +++ b/module/scripts/doc-snarf.scm @@ -152,7 +152,7 @@ This procedure foos, or bars, depending on the argument @var{braz}. "^;;\\." "^;; (.*)" "^;;-(.*)" - "^\\(define" + "^\\(define(\\*)?( |$)" #t ))) @@ -178,6 +178,14 @@ This procedure foos, or bars, depending on the argument @var{braz}. (write-output (snarf input lang) output (if texinfo? format-texinfo format-plain))) +;; Read an s-expression from @var{port}, then rewind it, so that it can be +;; read again. +(define (peek-sexp port) + (let* ((pos (ftell port)) + (sexp (read port))) + (seek port pos SEEK_SET) + sexp)) + ;; fixme: this comment is required to trigger standard internal ;; docstring snarfing... ideally, it wouldn't be necessary. ;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?) @@ -185,7 +193,8 @@ This procedure foos, or bars, depending on the argument @var{braz}. "Unread @var{line} from @var{input-port}, then read in the entire form and return the standard internal docstring if found. Return #f if not." (unread-string line input-port) ; ugh - (let ((form (read input-port))) + (seek input-port -1 SEEK_CUR) ; ugh^2 + (let ((form (peek-sexp input-port))) (cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...) (< 3 (length form)) (eq? 'define (car form)) @@ -270,9 +279,12 @@ return the standard internal docstring if found. Return #f if not." doc-strings (cons (match:substring m1 1) options) entries (+ lno 1))) (m2 - (let ((options (augmented-options line i-p options))) ; ttn-mod - (lp (read-line i-p) 'neutral '() '() - (cons (parse-entry doc-strings options line input-file lno) + (let* ((options (augmented-options line i-p options)) ; ttn-mod + (def (peek-sexp i-p))) + ;; due to the rewind in augmented-options and peek-sexp, + ;; we will actually see this line again, so read twice + (lp (begin (read-line i-p) (read-line i-p)) 'neutral '() '() + (cons (parse-entry doc-strings options def input-file lno) entries) (+ lno 1)))) (m3 @@ -295,9 +307,10 @@ return the standard internal docstring if found. Return #f if not." doc-strings (cons (match:substring m1 1) options) entries (+ lno 1))) (m2 - (let ((options (augmented-options line i-p options))) ; ttn-mod - (lp (read-line i-p) 'neutral '() '() - (cons (parse-entry doc-strings options line input-file lno) + (let* ((options (augmented-options line i-p options)) ; ttn-mod + (def (peek-sexp i-p))) + (lp (begin (read-line i-p) (read-line i-p)) 'neutral '() '() + (cons (parse-entry doc-strings options def input-file lno) entries) (+ lno 1)))) (m3 @@ -326,13 +339,13 @@ return the standard internal docstring if found. Return #f if not." ;; Create a docstring entry from the docstring line list ;; @var{doc-strings}, the option line list @var{options} and the -;; define line @var{def-line} -(define (parse-entry docstrings options def-line filename line-no) +;; definition @var{def} +(define (parse-entry docstrings options def filename line-no) ; (write-line docstrings) (cond - (def-line - (make-entry (get-symbol def-line) - (make-prototype def-line) (reverse docstrings) + (def + (make-entry (get-symbol def) + (make-prototype def) (reverse docstrings) (reverse options) filename (+ (- line-no (length docstrings) (length options)) 1))) ((> (length docstrings) 0) @@ -347,48 +360,66 @@ return the standard internal docstring if found. Return #f if not." ;; Create a string which is a procedure prototype. The necessary ;; information for constructing the prototype is taken from the line -;; @var{def-line}, which is a line starting with @code{(define...}. -(define (make-prototype def-line) - (call-with-input-string - def-line - (lambda (s-p) - (let* ((paren (read-char s-p)) - (keyword (read s-p)) - (tmp (read s-p))) - (cond - ((pair? tmp) - (join-symbols tmp)) - ((symbol? tmp) - (symbol->string tmp)) - (else - "")))))) - -(define (get-symbol def-line) - (call-with-input-string - def-line - (lambda (s-p) - (let* ((paren (read-char s-p)) - (keyword (read s-p)) - (tmp (read s-p))) - (cond - ((pair? tmp) - (car tmp)) - ((symbol? tmp) - tmp) - (else - 'foo)))))) - -;; Append the symbols in the string list @var{s}, separated with a -;; space character. -(define (join-symbols s) - (cond ((null? s) - "") - ((symbol? s) - (string-append ". " (symbol->string s))) - ((null? (cdr s)) - (symbol->string (car s))) - (else - (string-append (symbol->string (car s)) " " (join-symbols (cdr s)))))) +;; @var{def}, which is the full function definition starting with +;; @code{(define...}. +(define (make-prototype def) + (let ((tmp (false-if-exception (cadr def)))) + (cond + ((pair? tmp) (parse-defun tmp)) + ((symbol? tmp) (symbol->string tmp)) + (else "")))) + +(define (get-symbol def) + (let ((tmp (false-if-exception (cadr def)))) + (cond + ((pair? tmp) (car tmp)) + ((symbol? tmp) tmp) + (else 'foo)))) + +;; Parse function definition @var{defun}. +;; This parser accepts the formats +;; @itemize +;; @item (name . args) +;; @item (name arg1 arg2 ...) +;; @item (name arg1 arg2 ... [#:optional optarg...] [#:key kwarg...] . rest) +;; @item (name arg1 arg2 ... [#:optional optarg...] [#:key kwarg...] [#:rest rest]) +;; @end itemize +(define (parse-defun defun) + (define (append-arg prototype arg val optional? key?) + (string-append prototype + " " + (cond + (optional? "[") + (key? "[#:") + (else "")) + (symbol->string arg) + (if val (string-append "=" (object->string val write)) "") + (if (or optional? key?) "]" ""))) + (let lp ((prototype (symbol->string (car defun))) + (args (cdr defun)) + (optional? #f) + (key? #f)) + (cond + ((null? args) prototype) + ((symbol? args) + (string-append prototype " . " (symbol->string args))) + (else + (let ((arg (car args)) + (rest (cdr args))) + (cond + ((eq? arg #:optional) (lp prototype rest #t #f)) + ((eq? arg #:key) (lp prototype rest #f #t)) + ((eq? arg #:rest) + (lp (string-append prototype " .") rest #f #f)) + ((symbol? arg) + (lp (append-arg prototype arg #f optional? key?) + rest optional? key?)) + ((pair? arg) + (lp (append-arg prototype (car arg) (cadr arg) optional? key?) + rest optional? key?)) + (else + (error "failed to parse ~s: cannot match ~s" + defun arg)))))))) ;; Write @var{entries} to @var{output-file} using @var{writer}. ;; @var{writer} is a proc that takes one entry. -- 2.28.0