* 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
