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

Improving automated "optionals" signature extraction in (chibi doc).

Browse source
This commit is contained in:
Alex Shinn 2015-04-30 08:54:11 +09:00
parent ea9ba3b5cb
commit 315d87174c
4 changed files with 37 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
lib/chibi/doc-test.sld Normal file
View file

@ -0,0 +1,13 @@
(define-library (chibi doc-test)
(export run-tests)
(import (scheme base) (chibi doc) (chibi test))
(begin
(define (run-tests)
(test-begin "doc")
(test '(spec (args config))
(get-optionals-signature
'(spec . o)
'(let ((args (or (and (pair? o) (car o)) (command-line)))
(config (and (pair? o) (pair? (cdr o)) (cadr o))))
(foo))))
(test-end))))

30
lib/chibi/doc.scm
View file

@ -476,7 +476,7 @@ div#footer {padding-bottom: 50px}
;; Try to determine the names of optional parameters checking common ;; Try to determine the names of optional parameters checking common
;; patterns. ;; patterns.
(define (get-optionals ls body) (define (get-optionals-signature ls body)
(let lp ((ls ls) (pre '())) (let lp ((ls ls) (pre '()))
(cond (cond
((pair? ls) (lp (cdr ls) (cons (car ls) pre))) ((pair? ls) (lp (cdr ls) (cons (car ls) pre)))
@ -492,30 +492,37 @@ div#footer {padding-bottom: 50px}
(if (contains? val o) (if (contains? val o)
(extract #f vars i) (extract #f vars i)
(extract rest vars i))) (extract rest vars i)))
((((or 'let 'let* 'letrec 'letrec*) (y ...) . body)) (((or 'let 'let* 'letrec 'letrec*) (y ...) . body)
(let ((ordered? (memq (car x) '(let* letrec*)))) (let ((ordered? (memq (car x) '(let* letrec*))))
(let lp ((ls y) (vars vars) (j i)) (let lp ((ls y) (vars vars) (j i))
(cond (cond
((pair? ls) ((pair? ls)
(match (car ls) (match (car ls)
;; handle rebinding o
(((? o?) ('if ('pair? (? o?)) ('cdr (? o?)) default)) (((? o?) ('if ('pair? (? o?)) ('cdr (? o?)) default))
(lp (cdr ls) vars (+ j 1))) (lp (cdr ls) vars (+ j 1)))
(((? o?) expr) (((? o?) expr)
(extract #f vars i)) (extract #f vars i))
;; binding vars to o
((v ('if ('pair? (? o?)) ('car (? o?)) default)) ((v ('if ('pair? (? o?)) ('car (? o?)) default))
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
((v ('and ('pair? (? o?)) ('car (? o?)))) ((v ('and ('pair? (? o?)) ('car (? o?))))
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
((v ('or ('and ('pair? (? o?)) ('car (? o?))) default))
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))) ((v ('if ('and ('pair? (? o?)) ('pair? ('cdr (? o?))))
('cadr (? o?)) ('cadr (? o?))
default)) default))
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j)) (lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
((v ('and ('pair? (? o?)) ('pair? ('cdr (? o?)))
('cadr (? o?))))
(lp (cdr ls) (cons (cons v (if ordered? j i)) vars) j))
(else (else
(lp (cdr ls) vars j)))) (lp (cdr ls) vars j))))
(else (else
(extract body vars j)))))) (extract body vars j))))))
((((or 'let-optionals 'let-optionals*) ls ((var default) ...) (((or 'let-optionals 'let-optionals*) ls ((var default) ...)
. body)) . body)
(let lp ((ls var) (vars vars) (i i)) (let lp ((ls var) (vars vars) (i i))
(cond (cond
((pair? ls) ((pair? ls)
@ -524,15 +531,17 @@ div#footer {padding-bottom: 50px}
(extract body vars i))))) (extract body vars i)))))
(else (else
(let ((opts (map car (sort vars < cdr))) (let ((opts (map car (sort vars < cdr)))
(dotted? (contains? x o))) (rest-var? (contains? x o)))
(append (reverse pre) (append (reverse pre)
(cond (cond
((and (pair? opts) dotted?) ((and (pair? opts) rest-var?)
(list (append opts o))) (list (append opts o)))
(dotted? (rest-var?
o) o)
((pair? opts)
(list opts))
(else (else
(list opts))))))))))))) '()))))))))))))
(define (get-procedure-signature mod id proc) (define (get-procedure-signature mod id proc)
(cond ((and mod (procedure? proc) (procedure-signature id mod)) (cond ((and mod (procedure? proc) (procedure-signature id mod))
@ -544,7 +553,8 @@ div#footer {padding-bottom: 50px}
(match value (match value
(('(or let let* letrec letrec*) vars body0 ... body) (('(or let let* letrec letrec*) vars body0 ... body)
(get-value-signature mod id proc name body)) (get-value-signature mod id proc name body))
(('lambda args . body) (list (cons name (get-optionals args body)))) (('lambda args . body)
(list (cons name (get-optionals-signature args body))))
((('lambda args body0 ... body) vals ...) ((('lambda args body0 ... body) vals ...)
(get-value-signature mod id proc name body)) (get-value-signature mod id proc name body))
(('begin body0 ... body) (get-value-signature mod id proc name body)) (('begin body0 ... body) (get-value-signature mod id proc name body))
@ -557,7 +567,7 @@ div#footer {padding-bottom: 50px}
(('define (name args ...) . body) (('define (name args ...) . body)
(list (cons name args))) (list (cons name args)))
(('define (name . args) . body) (('define (name . args) . body)
(list (cons name (get-optionals args body)))) (list (cons name (get-optionals-signature args body))))
(('define name value) (('define name value)
(get-value-signature mod id proc name value)) (get-value-signature mod id proc name value))
(('define-syntax name ('syntax-rules () (clause . body) ...)) (('define-syntax name ('syntax-rules () (clause . body) ...))

3
lib/chibi/doc.sld
View file

@ -10,5 +10,6 @@
print-module-docs print-module-binding-docs print-module-docs print-module-binding-docs
generate-docs expand-docs fixup-docs generate-docs expand-docs fixup-docs
extract-module-docs extract-module-file-docs extract-file-docs extract-module-docs extract-module-file-docs extract-file-docs
make-default-doc-env make-module-doc-env) make-default-doc-env make-module-doc-env
get-optionals-signature)
(include "doc.scm")) (include "doc.scm"))

2
tests/lib-tests.scm
View file

@ -15,6 +15,7 @@
(rename (chibi crypto md5-test) (run-tests run-md5-tests)) (rename (chibi crypto md5-test) (run-tests run-md5-tests))
(rename (chibi crypto rsa-test) (run-tests run-rsa-tests)) (rename (chibi crypto rsa-test) (run-tests run-rsa-tests))
(rename (chibi crypto sha2-test) (run-tests run-sha2-tests)) (rename (chibi crypto sha2-test) (run-tests run-sha2-tests))
(rename (chibi doc-test) (run-tests run-doc-tests))
;;(rename (chibi filesystem-test) (run-tests run-filesystem-tests)) ;;(rename (chibi filesystem-test) (run-tests run-filesystem-tests))
(rename (chibi generic-test) (run-tests run-generic-tests)) (rename (chibi generic-test) (run-tests run-generic-tests))
(rename (chibi io-test) (run-tests run-io-tests)) (rename (chibi io-test) (run-tests run-io-tests))
@ -51,6 +52,7 @@
(run-srfi-95-tests) (run-srfi-95-tests)
(run-srfi-99-tests) (run-srfi-99-tests)
(run-base64-tests) (run-base64-tests)
(run-doc-tests)
(run-generic-tests) (run-generic-tests)
(run-io-tests) (run-io-tests)
(run-iset-tests) (run-iset-tests)