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)]
[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)]
[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)
(let f ([ls *all-libraries*])
@ -513,6 +516,10 @@
(unless (library? x)
(error 'library-subst/env "~s is not a library" 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! 'imported-label->binding lm:imported-label->binding)
(primitive-set! 'install-library lm:install-library))

73
src/libsyntax.ss
View File

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