Package: guile;
Reported by: Leo Prikler <leo.prikler <at> student.tugraz.at>
Date: Sat, 17 Oct 2020 23:52:02 UTC
Severity: normal
Tags: patch
To reply to this bug, email your comments to 44050 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
bug-guile <at> gnu.org:bug#44050; Package guile.
(Sat, 17 Oct 2020 23:52:02 GMT) Full text and rfc822 format available.Leo Prikler <leo.prikler <at> student.tugraz.at>:bug-guile <at> gnu.org.
(Sat, 17 Oct 2020 23:52:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Leo Prikler <leo.prikler <at> student.tugraz.at> To: bug-guile <at> gnu.org Subject: [PATCH] doc-snarf: Add support for (ice-9 optargs) define*s. Date: Sun, 18 Oct 2020 01:50:49 +0200
* 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.