adding modules introspection lib

currently just analyze-module to return all top-level forms
of a module analyzed in the internal AST form.
This commit is contained in:
Alex Shinn 2010-07-20 08:53:43 +09:00
parent 54005c4d66
commit 49cd07dad1
2 changed files with 69 additions and 0 deletions

5
lib/chibi/modules.module Normal file
View file

@ -0,0 +1,5 @@
(define-module (chibi modules)
(export analyze-module)
(import-immutable (scheme) (config) (chibi ast))
(include "modules.scm"))

64
lib/chibi/modules.scm Normal file
View file

@ -0,0 +1,64 @@
(define (file->sexp-list file)
(call-with-input-file file
(lambda (in)
(let lp ((res '()))
(let ((x (read in)))
(if (eof-object? x)
(reverse res)
(lp (cons x res))))))))
;; load the module and return it with a list of all top-level forms in
;; the module analyzed
(define (analyze-module name . o)
(let ((recursive? (and (pair? o) (car o)))
(modules `(((scheme) . ,(find-module '(scheme))))))
(let go ((name name))
(let ((env (make-environment))
(dir (module-name-prefix name)))
(define (load-modules files extension)
(for-each
(lambda (f)
(let ((f (string-append dir f extension)))
(cond ((find-module-file f) => (lambda (x) (load x env)))
(else (error "couldn't find include" f)))))
files))
(define (include-source file)
(cond ((find-module-file (string-append dir file))
=> (lambda (x) (cons 'body (file->sexp-list x))))
(else (error "couldn't find include" file))))
(cond
((assoc name modules) => cdr)
(else
(let ((mod (find-module name)))
(let lp ((ls (module-meta-data mod)) (res '()))
(cond
((not (pair? ls)) (reverse res))
(else
(case (and (pair? (car ls)) (caar ls))
((import import-immutable)
(for-each
(lambda (m)
(let* ((mod2-name+imports (resolve-import m))
(mod2 (load-module (car mod2-name+imports))))
(%env-copy! env (module-env mod2) (cdr mod2-name+imports)
(eq? (caar ls) 'import-immutable))))
(cdar ls))
(lp (cdr ls) res))
((include)
(lp (append (map include-source (cdar ls)) (cdr ls)) res))
((include-shared)
(cond-expand
(dynamic-loading
(load-modules (cdar ls) *shared-object-extension*))
(else #f)))
((body)
(let lp2 ((ls2 (cdar ls)) (res res))
(cond
((pair? ls2)
(eval (car ls2) env)
(lp2 (cdr ls2) (cons (analyze (car ls2)) res)))
(else
(lp (cdr ls) res)))))
(else
(lp (cdr ls) res)))))))))))))