conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* added an "imported-loc->library" procedure to the library manager

This commit is contained in:
Abdulaziz Ghuloum 2007-05-03 01:07:10 -04:00
parent d0c92ae99e
commit 86a75e8d54
3 changed files with 18 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

16
src/library-manager.ss
View File

@ -490,6 +490,7 @@
[library-subst/env library-subst/env-label (core-prim . library-subst/env)] [library-subst/env library-subst/env-label (core-prim . library-subst/env)]
[find-library-by-name find-library-by-name-label (core-prim . find-library-by-name)] [find-library-by-name find-library-by-name-label (core-prim . find-library-by-name)]
[imported-label->binding imported-label->binding-label (core-prim . imported-label->binding)] [imported-label->binding imported-label->binding-label (core-prim . imported-label->binding)]
[imported-loc->library imported-loc->library-label (core-prim . imported-loc->library)]
[library-spec library-spec-label (core-prim . library-spec)] [library-spec library-spec-label (core-prim . library-spec)]
[invoke-library invoke-library-label (core-prim . invoke-library)] [invoke-library invoke-library-label (core-prim . invoke-library)]
)) ))
@ -500,6 +501,20 @@
[(assq lab (library-env (car ls))) => cdr] [(assq lab (library-env (car ls))) => cdr]
[else (f (cdr ls))]))) [else (f (cdr ls))])))
(define (lm:imported-loc->library loc)
(define (loc-in-env? ls)
(and (pair? ls)
(let ([a (car ls)])
(let ([binding (cdr a)])
(or (and (eq? (car binding) 'global)
(eq? (cdr binding) loc))
(loc-in-env? (cdr ls)))))))
(let f ([ls *all-libraries*])
(cond
[(null? ls) #f]
[(loc-in-env? (library-env (car ls))) (car ls)]
[else (f (cdr ls))])))
(define (lm:invoke-library lib) (define (lm:invoke-library lib)
(let ([invoke (library-invoke-state lib)]) (let ([invoke (library-invoke-state lib)])
(when (procedure? invoke) (when (procedure? invoke)
@ -540,6 +555,7 @@
(list (library-id x) (library-name x) (library-ver x)))) (list (library-id x) (library-name x) (library-ver x))))
(primitive-set! 'find-library-by-name lm:find-library-by-name) (primitive-set! 'find-library-by-name lm:find-library-by-name)
(primitive-set! 'imported-label->binding lm:imported-label->binding) (primitive-set! 'imported-label->binding lm:imported-label->binding)
(primitive-set! 'imported-loc->library lm:imported-loc->library)
(primitive-set! 'invoke-library lm:invoke-library) (primitive-set! 'invoke-library lm:invoke-library)
(primitive-set! 'install-library lm:install-library)) (primitive-set! 'install-library lm:install-library))

5
src/libsyntax.ss
View File

@ -308,7 +308,7 @@
(unless label (unless label
(stx-error e "unbound identifier")) (stx-error e "unbound identifier"))
(case type (case type
[(lexical core-prim macro) [(lexical core-prim macro global)
(values type (binding-value b) id)] (values type (binding-value b) id)]
[else (values 'other #f #f)])))] [else (values 'other #f #f)])))]
[(syntax-pair? e) [(syntax-pair? e)
@ -2022,8 +2022,7 @@
imp* vis* inv* exp-subst exp-env imp* vis* inv* exp-subst exp-env
void ;;; FIXME void ;;; FIXME
(lambda () (eval-core invoke-code))) (lambda () (eval-core invoke-code)))
(invoke-library (find-library-by-name name)) (invoke-library (find-library-by-name name))))))
(build-void)))))
(define boot-library-expander (define boot-library-expander
(lambda (x) (lambda (x)
(let-values ([(name imp* run* invoke-code exp*) (let-values ([(name imp* run* invoke-code exp*)