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

Adding introspection to available unloaded modules.

Browse source
This commit is contained in:
Alex Shinn 2013-10-03 12:14:31 +09:00
parent daf5478824
commit fc2ca6181f
1 changed files with 51 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
lib/chibi/modules.scm
View file

@ -1,5 +1,5 @@
;; modules.scm -- module introspection utilities
;; Copyright (c) 2011 Alex Shinn. All rights reserved.
;; Copyright (c) 2011-2013 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Module introspection library.
@ -143,3 +143,53 @@
(eq? (procedure-name x) (ref-name (set-var (car ls)))))
(set-value (car ls))
(lp (cdr ls))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; finding all available modules
(define (module-file? file)
(let ((len (string-length file)))
(and (> len 4) (equal? ".sld" (substring file (- len 4))))))
(define (read-static-modules file)
(protect (exn (else '()))
(call-with-input-file file
(lambda (in)
(let lp ((res '()))
(let ((expr (read in)))
(cond
((eof-object? expr)
res)
((and (pair? expr) (eq? 'define-library (car expr)))
(let ((name (cadr expr))
(exports (cond ((assq 'export (cddr expr)) => cdr)
(else '()))))
(lp (cons (cons name (make-module exports #f #f)) res))))
(else
(lp res)))))))))
(define (available-modules-in-directory dir)
(directory-fold-tree
dir #f #f
(lambda (file res)
(if (module-file? file)
(append (read-static-modules file) res)
res))
'()))
(define (available-modules)
(reverse
(apply append
*modules*
(map available-modules-in-directory
(current-module-path)))))
(define (modules-exporting-identifier name)
(let lp ((ls (available-modules))
(res '()))
(cond
((null? ls) (reverse res))
((and (memq name (module-exports (cdar ls)))
(not (assoc (caar ls) res)))
(lp (cdr ls) (cons (car ls) res)))
(else (lp (cdr ls) res)))))