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

* Added an invoke-library primitive to the library manager.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-02 20:05:19 -04:00
parent 362d9f3b38
commit c3767da70e
3 changed files with 45 additions and 5 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.

30
src/library-manager.ss
View File

@ -28,11 +28,17 @@
(or (lm:find-library-by-name name)
(error #f "cannot find library ~s" name)))
(define (find-library-by-spec/die spec)
(let ([id (car spec)])
(or (find-library-by
(lambda (x) (eq? id (library-id x))))
(error #f "cannot find library with spec ~s" spec))))
(define (lm:install-library id name ver
imp* vis* inv* exp-subst exp-env visit-code invoke-code)
(let ([imp-lib* (map find-library-by-name/die imp*)]
[vis-lib* (map find-library-by-name/die vis*)]
[inv-lib* (map find-library-by-name/die inv*)])
(let ([imp-lib* (map find-library-by-spec/die imp*)]
[vis-lib* (map find-library-by-spec/die vis*)]
[inv-lib* (map find-library-by-spec/die inv*)])
(unless (and (symbol? id) (list? name) (list? ver))
(error 'install-library "invalid spec ~s ~s ~s" id name ver))
(when (lm:find-library-by-name name)
@ -489,6 +495,7 @@
[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)]
[library-spec library-spec-label (core-prim . library-spec)]
[invoke-library invoke-library-label (core-prim . invoke-library)]
))
(define (lm:imported-label->binding lab)
(let f ([ls *all-libraries*])
@ -496,6 +503,22 @@
[(null? ls) #f]
[(assq lab (library-env (car ls))) => cdr]
[else (f (cdr ls))])))
(define (lm:invoke-library lib)
(let ([invoke (library-invoke-state lib)])
(when (procedure? invoke)
(set-library-invoke-state! lib
(lambda () (error 'invoke "circularity detected for ~s" lib)))
(for-each lm:invoke-library (library-inv* lib))
(set-library-invoke-state! lib
(lambda () (error 'invoke "first invoke did not return for ~s" lib)))
(invoke)
(set-library-invoke-state! lib #t))))
(define (lm:invoke-library-by-spec spec)
(lm:invoke-library (find-library-by-spec/die spec)))
;;; init
(let ([subst
(map (lambda (x) (cons (car x) (cadr x))) scheme-env)]
[env
@ -521,5 +544,6 @@
(list (library-id x) (library-name x) (library-ver x))))
(primitive-set! 'find-library-by-name lm:find-library-by-name)
(primitive-set! 'imported-label->binding lm:imported-label->binding)
(primitive-set! 'invoke-library lm:invoke-library)
(primitive-set! 'install-library lm:install-library))

20
src/libsyntax.ss
View File

@ -1981,7 +1981,7 @@
(define core-library-expander
(lambda (e)
(let-values ([(name exp* imp* b*) (parse-library e)])
(let-values ([(subst lib*) (get-import-subst/libs imp*)])
(let-values ([(subst imp*) (get-import-subst/libs imp*)])
(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)))
@ -2012,6 +2012,9 @@
(let ([id (gensym)]
[name name]
[ver '()]
[imp* (map library-spec imp*)]
[vis* '()]
[inv* (map library-spec run*)]
[exp-subst
(map (lambda (x) (cons (car x) (cadr x))) exp*)]
[exp-env
@ -2019,7 +2022,20 @@
(let ([label (cadr x)] [type (caddr x)] [val (cadddr x)])
(cons label (cons type val))))
exp*)])
invoke-code))))
(build-application no-source
(build-primref no-source 'install-library)
(list (build-data no-source id)
(build-data no-source name)
(build-data no-source ver)
(build-data no-source imp*)
(build-data no-source vis*)
(build-data no-source inv*)
(build-data no-source exp-subst)
(build-data no-source exp-env)
(build-primref no-source 'void)
(build-sequence no-source
(list invoke-code
(build-primref no-source 'void)))))))))
(define boot-library-expander
(lambda (x)
(let-values ([(name imp* run* invoke-code exp*)