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

* library manager exports library-name/id/version prims

This commit is contained in:
Abdulaziz Ghuloum 2007-05-02 19:19:37 -04:00
parent eb0d58f2aa
commit 63d35807c1
3 changed files with 43 additions and 37 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.

7
src/library-manager.ss
View File

@ -488,6 +488,9 @@
[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)]
[xlibrary-id xlibrary-id-label (core-prim . xlibrary-id)]
[xlibrary-name xlibrary-name-label (core-prim . xlibrary-name)]
[xlibrary-version xlibrary-version-label (core-prim . xlibrary-version)]
)) ))
(define (lm:imported-label->binding lab) (define (lm:imported-label->binding lab)
(let f ([ls *all-libraries*]) (let f ([ls *all-libraries*])
@ -513,6 +516,10 @@
(unless (library? x) (unless (library? x)
(error 'library-subst/env "~s is not a library" x)) (error 'library-subst/env "~s is not a library" x))
(values (library-subst x) (library-env x)))) (values (library-subst x) (library-env x))))
(primitive-set! 'xlibrary-id library-id)
(primitive-set! 'xlibrary-name library-name)
(primitive-set! 'xlibrary-version library-ver)
(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! 'install-library lm:install-library)) (primitive-set! 'install-library lm:install-library))

73
src/libsyntax.ss
View File

@ -1985,47 +1985,46 @@
(let ([rib (make-top-rib subst)]) (let ([rib (make-top-rib subst)])
(let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)] (let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)]
[kwd* (map (lambda (sym mark*) (stx sym mark* (list rib))) [kwd* (map (lambda (sym mark*) (stx sym mark* (list rib)))
(rib-sym* rib) (rib-mark** rib))]) (rib-sym* rib) (rib-mark** rib))]
(let-values ([(init* r mr lex* rhs*) [rtc (make-collector)])
(chi-library-internal b* rib kwd*)]) (parameterize ([run-collector rtc])
(let ([rhs* (chi-rhs* rhs* r mr)]) (let-values ([(init* r mr lex* rhs*)
(let ([body (if (and (null? init*) (null? lex*)) (chi-library-internal b* rib kwd*)])
(build-void) (let ([rhs* (chi-rhs* rhs* r mr)])
(build-sequence no-source (let ([body (if (and (null? init*) (null? lex*))
(append (build-void)
(map build-export lex*) (build-sequence no-source
(chi-expr* init* r mr))))]) (append
(values (map build-export lex*)
name imp* (chi-expr* init* r mr))))])
(build-letrec no-source lex* rhs* body) (values
(map (find-export rib r) exp*))))))))))) name imp* (rtc)
(build-letrec no-source lex* rhs* body)
(map (find-export rib r) exp*))))))))))))
(define run-library-expander (define run-library-expander
(lambda (x) (lambda (x)
(let ([rtc (make-collector)]) (let-values ([(name imp* run* invoke-code exp*)
(parameterize ([run-collector rtc]) (core-library-expander x)])
(let-values ([(name imp* invoke-code exp*) ;;; we need: name/ver/id,
(core-library-expander x)]) ;;; imports, visit, invoke name/ver/id
;;; we need: name/ver/id, ;;; export-subst, export-env
;;; imports, visit, invoke name/ver/id ;;; visit-code, invoke-code
;;; export-subst, export-env (let ([id (gensym)]
;;; visit-code, invoke-code [name name]
(let ([id (gensym)] [ver '()]
[ver '()] [exp-subst
[exp-subst (map (lambda (x) (cons (car x) (cadr x))) exp*)]
(map (lambda (x) (cons (car x) (cadr x))) exp*)] [exp-env
[exp-env (map (lambda (x)
(map (lambda (x) (let ([label (cadr x)] [type (caddr x)] [val (cadddr x)])
(let ([label (cadr x)] [type (caddr x)] [val (cadddr x)]) (cons label (cons type val))))
(cons label (cons type val)))) exp*)])
exp*)]) invoke-code))))
invoke-code))))))
(define boot-library-expander (define boot-library-expander
(lambda (x) (lambda (x)
(let ([rtc (make-collector)]) (let-values ([(name imp* run* invoke-code exp*)
(parameterize ([run-collector rtc]) (core-library-expander x)])
(let-values ([(name imp* invoke-code exp*) (values invoke-code exp*))))
(core-library-expander x)])
(values invoke-code exp*))))))
(define build-export (define build-export
(lambda (x) (lambda (x)
;;; exports use the same gensym ;;; exports use the same gensym