Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 06:39:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing doc inference via procedure analysis.

Browse source 
Show a basic header even when inference fails.
This commit is contained in:
Alex Shinn 2014-07-28 23:44:49 +09:00
parent 7469dd82da
commit 89e5c7f87d
3 changed files with 69 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

84
lib/chibi/doc.scm
View file

@ -385,6 +385,19 @@ div#footer {padding-bottom: 50px}
(or (contains? (car tree) x)
(contains? (cdr tree) x)))))
(define (form-defined-name form)
(match form
(('define (name . x) . y) name)
(((or 'define 'define-syntax) name . x)
name)
(((or 'define-c 'define-c-const)
t (name . x) . y)
name)
(((or 'define-c 'define-c-const)
t name . x)
name)
(else #f)))
;; Try to determine the names of optional parameters checking common
;; patterns.
(define (get-optionals ls body)
@ -445,36 +458,38 @@ div#footer {padding-bottom: 50px}
(else
(list opts)))))))))))))
(define (get-procedure-signature proc)
(cond ((and (procedure? proc) (procedure-signature proc)) => list)
(define (get-procedure-signature mod id proc)
(cond ((and (procedure? proc) (procedure-signature id mod))
=> (lambda (sig)
(list (cons (or id (procedure-name proc)) (cdr sig)))))
(else '())))
(define (get-value-signature proc name value)
(define (get-value-signature mod id proc name value)
(match value
(('(or let let* letrec letrec*) vars body0 ... body)
(get-value-signature proc name body))
(get-value-signature mod id proc name body))
(('lambda args . body) (list (cons name (get-optionals args body))))
((('lambda args body0 ... body) vals ...)
(get-value-signature proc name body))
(('begin body0 ... body) (get-value-signature proc name body))
(else (get-procedure-signature proc))))
(get-value-signature mod id proc name body))
(('begin body0 ... body) (get-value-signature mod id proc name body))
(else (get-procedure-signature mod id proc))))
;; TODO: analyze and match on AST instead of making assumptions about
;; bindings
(define (get-signature proc source form)
(define (get-signature mod id proc source form)
(match form
(('define (name args ...) . body)
(list (cons name args)))
(('define (name . args) . body)
(list (cons name (get-optionals args body))))
(('define name value)
(get-value-signature proc name value))
(get-value-signature mod id proc name value))
(('define-syntax name ('syntax-rules () (clause . body) ...))
;; TODO: smarter summary merging forms
(map (lambda (x) (cons name (cdr x)))
(filter external-clause? clause)))
(else
(get-procedure-signature proc))))
(get-procedure-signature mod id proc))))
(define (get-ffi-signatures form)
(match form
@ -608,7 +623,7 @@ div#footer {padding-bottom: 50px}
;; Extract inline scribble documentation (with the ;;> prefix) from a
;; source file, associating any signatures from the provided defs when
;; available and not overridden in the docs.
(define (extract-file-docs file all-defs strict? . o)
(define (extract-file-docs mod file all-defs strict? . o)
;; extract (<file> . <line>) macro source or
;; (<offset> <file . <line>>) procedure source
(define (source-line source)
@ -718,6 +733,7 @@ div#footer {padding-bottom: 50px}
(let* ((cur (collect))
(ids (append (get-ids cur) ids))
(form (cons op (read-to-paren in)))
(id (form-defined-name form))
(line (port-line in))
;; find all procedures defined by form
(procs (filter (lambda (x) (<= last-line (third x) line))
@ -732,9 +748,10 @@ div#footer {padding-bottom: 50px}
all-defs))
(get-ffi-signatures form)))
((= 1 (length procs))
(get-signature (caar procs) (cdar procs) form))
(get-signature mod id (caar procs) (cdar procs) form))
(else
(get-signature #f #f form)))))
(get-signature
mod id (and id (module-ref mod id)) #f form)))))
(cond
((and strict?
(or (not (pair? sigs)) (not (assq (caar sigs) defs))))
@ -748,21 +765,12 @@ div#footer {padding-bottom: 50px}
(append (insert-signature cur (caar procs) sigs) res)
ids depth line))
((and (null? procs)
(let ((id (match form
(('define (name . x) . y) name)
(((or 'define 'define-syntax) name . x)
name)
(((or 'define-c 'define-c-const)
t (name . x) . y)
name)
(((or 'define-c 'define-c-const)
t name . x)
name)
(else #f))))
(and (not (memq id ids))
(assq id all-defs))))
(lp '() '() (append (insert-signature cur #f sigs) res)
ids depth line))
(and (not (memq id ids)) (assq id all-defs)))
(let ((sigs (if (and (null? sigs) id)
(list id)
sigs)))
(lp '() '() (append (insert-signature cur #f sigs) res)
ids depth line)))
(else
(lp '() '() (append cur res) ids depth line))))))))))))))
@ -792,15 +800,19 @@ div#footer {padding-bottom: 50px}
(append
(cond
((find-module-file (module-name->file mod-name))
=> (lambda (f) (reverse (extract-file-docs f defs strict? 'module))))
=> (lambda (f)
(reverse (extract-file-docs mod f defs strict? 'module))))
(else '()))
(reverse (append-map (lambda (x)
(extract-file-docs x defs strict? 'module))
(module-include-library-declarations mod)))
(reverse (append-map (lambda (x) (extract-file-docs x defs strict?))
(module-includes mod)))
(reverse (append-map (lambda (x) (extract-file-docs x defs strict? 'ffi))
(module-shared-includes mod))))))))
(reverse
(append-map (lambda (x)
(extract-file-docs mod x defs strict? 'module))
(module-include-library-declarations mod)))
(reverse
(append-map (lambda (x) (extract-file-docs mod x defs strict?))
(module-includes mod)))
(reverse
(append-map (lambda (x) (extract-file-docs mod x defs strict? 'ffi))
(module-shared-includes mod))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

15
lib/chibi/modules.scm
View file

@ -143,14 +143,19 @@
(lp2 (cdr e-ls))))))))))
(define (procedure-analysis x . o)
(let ((mod (or (and (pair? o) (car o)) (containing-module x))))
(let ((name (if (procedure? x) (procedure-name x) x))
(mod (or (and (pair? o) (car o)) (containing-module x))))
(and mod
(let lp ((ls (module-ast (analyze-module (module-name mod)))))
(and (pair? ls)
(if (and (set? (car ls))
(eq? (procedure-name x) (ref-name (set-var (car ls)))))
(set-value (car ls))
(lp (cdr ls))))))))
(cond
((and (set? (car ls))
(eq? name (ref-name (set-var (car ls)))))
(set-value (car ls)))
((seq? (car ls))
(lp (append (seq-ls (car ls)) (cdr ls))))
(else
(lp (cdr ls)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; finding all available modules

16
lib/chibi/type-inference.scm
View file

@ -304,7 +304,15 @@
;;> a list whose first element is the return type and whose
;;> remaining arguments are the parameter types.
(define (procedure-signature x)
(define (procedure-signature x . o)
(define (ast-sig x)
(cond
((lambda? x) (cdr (lambda-type x)))
((seq? x) (ast-sig (last (seq-ls x))))
((and (pair? x) (lambda? (car x))) (ast-sig (lambda-body x)))
;; ((and (pair? x) (ref? (car x)) (lambda? (cdr (ref-cell (car x)))))
;; (ast-sig (lambda-body (cdr (ref-cell (car x))))))
(else #f)))
(cond
((opcode? x)
(cdr (opcode-type x)))
@ -312,14 +320,12 @@
(procedure-signature (macro-procedure x)))
(else
(let lp ((count 0))
(let ((lam (procedure-analysis x)))
(let ((lam (apply procedure-analysis x o)))
(cond
((and lam (not (typed? lam)) (zero? count)
(containing-module x))
=> (lambda (mod)
(and (type-analyze-module (car mod))
(lp (+ count 1)))))
((lambda? lam)
(cdr (lambda-type lam)))
(else
#f)))))))
(ast-sig lam))))))))