* split the library expander into a core-library-expander
and two expanders: one for boot and one for runtime
This commit is contained in:
parent
4c4af70ffc
commit
1fdce919d7
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -1841,19 +1841,18 @@
|
||||||
r mr lhs* lex* rhs* kwd*)]
|
r mr lhs* lex* rhs* kwd*)]
|
||||||
[else (return e* r mr lhs* lex* rhs* kwd*)]))))]))))))
|
[else (return e* r mr lhs* lex* rhs* kwd*)]))))]))))))
|
||||||
(define chi-library-internal
|
(define chi-library-internal
|
||||||
(lambda (e* r rib kwd*)
|
(lambda (e* rib kwd*)
|
||||||
(define return
|
(define return
|
||||||
(lambda (init* module-init** r mr lhs* lex* rhs*)
|
(lambda (init* module-init** r mr lhs* lex* rhs*)
|
||||||
(let ([module-init* (apply append (reverse module-init**))])
|
(let ([module-init* (apply append (reverse module-init**))])
|
||||||
(values (append module-init* init*)
|
(values (append module-init* init*)
|
||||||
r mr (reverse lex*) (reverse rhs*)))))
|
r mr (reverse lex*) (reverse rhs*)))))
|
||||||
(let f ([e* e*] [module-init** '()] [r r] [mr r]
|
(let f ([e* e*] [module-init** '()] [r '()] [mr '()]
|
||||||
[lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
|
[lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
|
||||||
(cond
|
(cond
|
||||||
[(null? e*) (return e* module-init** r mr lhs* lex* rhs*)]
|
[(null? e*) (return e* module-init** r mr lhs* lex* rhs*)]
|
||||||
[else
|
[else
|
||||||
(let ([e (car e*)])
|
(let ([e (car e*)])
|
||||||
;(printf "chi ~s\n" e)
|
|
||||||
(let-values ([(type value kwd) (syntax-type e r)])
|
(let-values ([(type value kwd) (syntax-type e r)])
|
||||||
(let ([kwd* (cons-id kwd kwd*)])
|
(let ([kwd* (cons-id kwd kwd*)])
|
||||||
(case type
|
(case type
|
||||||
|
@ -1966,7 +1965,20 @@
|
||||||
(extend-rib! rib (stx name top-mark* '()) label)))
|
(extend-rib! rib (stx name top-mark* '()) label)))
|
||||||
subst)
|
subst)
|
||||||
rib))
|
rib))
|
||||||
(define library-expander
|
(define (make-collector)
|
||||||
|
(let ([ls '()])
|
||||||
|
(case-lambda
|
||||||
|
[() ls]
|
||||||
|
[(x) (set! ls (set-cons x ls))])))
|
||||||
|
(define run-collector
|
||||||
|
(make-parameter
|
||||||
|
(lambda args
|
||||||
|
(error 'run-collector "not initialized"))
|
||||||
|
(lambda (x)
|
||||||
|
(unless (procedure? x)
|
||||||
|
(error 'run-collector "~s is not a procedure" x))
|
||||||
|
x)))
|
||||||
|
(define core-library-expander
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
(let-values ([(name exp* imp* b*) (parse-library e)])
|
(let-values ([(name exp* imp* b*) (parse-library e)])
|
||||||
(let-values ([(subst lib*) (get-import-subst/libs imp*)])
|
(let-values ([(subst lib*) (get-import-subst/libs imp*)])
|
||||||
|
@ -1975,23 +1987,7 @@
|
||||||
[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*)
|
(let-values ([(init* r mr lex* rhs*)
|
||||||
(chi-library-internal b* '() rib kwd*)])
|
(chi-library-internal b* rib kwd*)])
|
||||||
(let ([rhs* (chi-rhs* rhs* r mr)])
|
|
||||||
(let ([body (if (null? init*)
|
|
||||||
(build-void)
|
|
||||||
(build-sequence no-source
|
|
||||||
(chi-expr* init* r mr)))])
|
|
||||||
(build-letrec no-source lex* rhs* body))))))))))
|
|
||||||
(define boot-library-expander
|
|
||||||
(lambda (e)
|
|
||||||
(let-values ([(name exp* imp* b*) (parse-library e)])
|
|
||||||
(let-values ([(subst lib*) (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)))
|
|
||||||
(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 ([rhs* (chi-rhs* rhs* r mr)])
|
||||||
(let ([body (if (and (null? init*) (null? lex*))
|
(let ([body (if (and (null? init*) (null? lex*))
|
||||||
(build-void)
|
(build-void)
|
||||||
|
@ -2000,8 +1996,21 @@
|
||||||
(map build-export lex*)
|
(map build-export lex*)
|
||||||
(chi-expr* init* r mr))))])
|
(chi-expr* init* r mr))))])
|
||||||
(values
|
(values
|
||||||
|
name
|
||||||
(build-letrec no-source lex* rhs* body)
|
(build-letrec no-source lex* rhs* body)
|
||||||
(map (find-export rib r) exp*)))))))))))
|
(map (find-export rib r) exp*)))))))))))
|
||||||
|
(define library-expander
|
||||||
|
(lambda (x)
|
||||||
|
(let ([rtc (make-collector)])
|
||||||
|
(parameterize ([run-collector rtc])
|
||||||
|
(let-values ([(name invoke-code export-subst)
|
||||||
|
(core-library-expander x)])
|
||||||
|
invoke-code)))))
|
||||||
|
(define boot-library-expander
|
||||||
|
(lambda (x)
|
||||||
|
(let-values ([(name 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
|
||||||
|
|
Loading…
Reference in New Issue