Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Supporting macro source info in docs, more robust line range checking.

Browse source
This commit is contained in:
Alex Shinn 2013-06-02 19:45:25 +09:00
parent ea5a424ede
commit 65ed450d7a
1 changed files with 36 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
lib/chibi/doc.scm
View file

@ -352,10 +352,10 @@ div#footer {padding-bottom: 50px}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (skip-whitespace in) (define (skip-horizontal-whitespace in)
(cond ((char-whitespace? (peek-char in)) (cond ((memv (peek-char in) '(#\space #\tab))
(read-char in) (read-char in)
(skip-whitespace in)))) (skip-horizontal-whitespace in))))
(define (external-clause? x) (define (external-clause? x)
(not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x)))))) (not (and (pair? (cdr x)) (pair? (cadr x)) (string? (car (cadr x))))))
@ -467,19 +467,30 @@ div#footer {padding-bottom: 50px}
;; source file, associating any signatures from the provided defs when ;; source file, associating any signatures from the provided defs when
;; available and not overridden in the docs. ;; available and not overridden in the docs.
(define (extract-file-docs file all-defs strict? . o) (define (extract-file-docs file all-defs strict? . o)
;; extract (<file> . <line>) macro source or
;; (<offset> <file . <line>>) procedure source
(define (source-line source)
(and (pair? source)
(if (string? (car source))
(and (equal? file (car source))
(number? (cdr source))
(cdr source))
(and (number? (car source))
(pair? (cdr source))
(equal? file (cadr source))
(cddr source)))))
(call-with-input-file file (call-with-input-file file
(lambda (in) (lambda (in)
(let* ((lang (or (and (pair? o) (car o)) 'scheme)) (let* ((lang (or (and (pair? o) (car o)) 'scheme))
;; filter to only defs found in this file ;; filter to only defs found in this file
(defs (map (lambda (x) `(,(car x) ,(cadr x) ,(cddr (third x)))) (defs (filter-map
;; (name value line) (lambda (x)
(filter (let ((line (source-line (third x))))
(lambda (x) (and line
(and (pair? (third x)) ;; (name value line)
(pair? (cdr (third x))) `(,(car x) ,(cadr x) ,line))))
(equal? file (cadr (third x))))) all-defs)))
all-defs)))) (let lp ((lines '()) (cur '()) (res '()) (last-line 0))
(let lp ((lines '()) (cur '()) (res '()))
(define (collect) (define (collect)
(if (pair? lines) (if (pair? lines)
(append (append
@ -489,12 +500,13 @@ div#footer {padding-bottom: 50px}
scribble-parse)) scribble-parse))
cur) cur)
cur)) cur))
(skip-whitespace in) (skip-horizontal-whitespace in)
(cond (cond
((eof-object? (peek-char in)) ((eof-object? (peek-char in))
(append (collect) res)) (append (collect) res))
((eqv? #\newline (peek-char in)) ((eqv? #\newline (peek-char in))
(lp lines cur res)) (read-char in)
(lp lines cur res last-line))
((eqv? #\; (peek-char in)) ((eqv? #\; (peek-char in))
(read-char in) (read-char in)
(cond (cond
@ -502,7 +514,7 @@ div#footer {padding-bottom: 50px}
(begin (read-char in) (eqv? #\> (peek-char in)))) (begin (read-char in) (eqv? #\> (peek-char in))))
(read-char in) (read-char in)
(if (eqv? #\space (peek-char in)) (read-char in)) (if (eqv? #\space (peek-char in)) (read-char in))
(lp (cons (read-line in) lines) cur res)) (lp (cons (read-line in) lines) cur res last-line))
(else (else
(let lp () (let lp ()
(cond ((eqv? #\; (peek-char in)) (cond ((eqv? #\; (peek-char in))
@ -512,15 +524,14 @@ div#footer {padding-bottom: 50px}
(cur (collect))) (cur (collect)))
;; ";;/" attaches the docs to the preceding form ;; ";;/" attaches the docs to the preceding form
(if (equal? line "/") (if (equal? line "/")
(lp '() '() (append cur res)) (lp '() '() (append cur res) last-line)
(lp '() cur res)))))) (lp '() cur res last-line))))))
(else ;; found a top-level expression (else ;; found a top-level expression
(let* ((cur (collect)) (let* ((cur (collect))
(line1 (port-line in))
(form (read in)) (form (read in))
(line2 (port-line in)) (line (port-line in))
;; find all procedures defined by form ;; find all procedures defined by form
(procs (filter (lambda (x) (<= line1 (third x) line2)) (procs (filter (lambda (x) (<= last-line (third x) line))
(filter third defs))) (filter third defs)))
;; the the signature for the form ;; the the signature for the form
(sigs (sigs
@ -539,14 +550,15 @@ div#footer {padding-bottom: 50px}
((and strict? ((and strict?
(or (not (pair? sigs)) (not (assq (caar sigs) defs)))) (or (not (pair? sigs)) (not (assq (caar sigs) defs))))
;; drop unrelated docs in strict mode ;; drop unrelated docs in strict mode
(lp '() '() res)) (lp '() '() res line))
((and (eq? lang 'ffi) (pair? sigs)) ((and (eq? lang 'ffi) (pair? sigs))
(lp '() '() (append (insert-signature cur #f sigs) res))) (lp '() '() (append (insert-signature cur #f sigs) res) line))
((and (eq? lang 'scheme) (= 1 (length procs))) ((and (eq? lang 'scheme) (= 1 (length procs)))
(lp '() '() (append (insert-signature cur (caar procs) sigs) (lp '() '() (append (insert-signature cur (caar procs) sigs)
res))) res)
line))
(else (else
(lp '() '() (append cur res)))))))))))) (lp '() '() (append cur res) line)))))))))))
;; utility to get the source position of an object ;; utility to get the source position of an object
(define (object-source x) (define (object-source x)