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

* building export env seems to be ok.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 22:18:46 -04:00
parent 151913a749
commit 2c4ddb0f67
2 changed files with 41 additions and 11 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.

52
src/ikarus.syntax.ss
View File

@ -389,8 +389,7 @@
[(procedure? x) (list* 'local-macro x src)] [(procedure? x) (list* 'local-macro x src)]
[(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x))) [(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
(list* 'local-macro! (cdr x) src)] (list* 'local-macro! (cdr x) src)]
[(and (pair? x) (eq? (car x) '$rtd)) [(and (pair? x) (eq? (car x) '$rtd)) x]
(list* 'local-rtd (cdr x) src)]
[else (error 'expand "invalid transformer ~s" x)]))) [else (error 'expand "invalid transformer ~s" x)])))
(define make-eval-transformer (define make-eval-transformer
(lambda (x) (lambda (x)
@ -679,8 +678,8 @@
[type (binding-type b)]) [type (binding-type b)])
(unless lab (stx-error e "unbound identifier")) (unless lab (stx-error e "unbound identifier"))
(case type (case type
[(local-rtd) [($rtd)
(build-data no-source (local-binding-value b))] (build-data no-source (binding-value b))]
[else (stx-error e "invalid type")]))]))) [else (stx-error e "invalid type")]))])))
(define when-transformer ;;; go away (define when-transformer ;;; go away
(lambda (e r mr) (lambda (e r mr)
@ -2207,13 +2206,14 @@
(map build-export lex*) (map build-export lex*)
(chi-expr* init* r mr))))]) (chi-expr* init* r mr))))])
(unseal-rib! rib) (unseal-rib! rib)
(let-values ([(export-subst export-env macro*) (let ([export-subst (make-export-subst exp-int* exp-ext* rib)])
(find-exports exp-int* exp-ext* rib r)]) (let-values ([(export-env macro*)
(values (make-export-env/macros r)])
name imp* (rtc) (vtc) (values
(build-letrec no-source lex* rhs* invoke-body) name imp* (rtc) (vtc)
macro* (build-letrec no-source lex* rhs* invoke-body)
export-subst export-env)))))))))))) macro*
export-subst export-env)))))))))))))
(define (visit! macro*) (define (visit! macro*)
(for-each (lambda (x) (for-each (lambda (x)
(let ([loc (car x)] [proc (cadr x)]) (let ([loc (car x)] [proc (cadr x)])
@ -2253,6 +2253,36 @@
(lambda (x) (lambda (x)
;;; exports use the same gensym ;;; exports use the same gensym
`(#%$set-symbol-value! ',x ,x))) `(#%$set-symbol-value! ',x ,x)))
(define (make-export-subst int* ext* rib)
(map
(lambda (int ext)
(let* ([id (stx int top-mark* (list rib))]
[label (id->label id)])
(unless label
(stx-error id "cannot export unbound identifier"))
(cons ext label)))
int* ext*))
(define (make-export-env/macros r)
(let f ([r r] [env '()] [macro* '()])
(cond
[(null? r) (values env macro*)]
[else
(let ([x (car r)])
(let ([label (car x)] [b (cdr x)])
(case (binding-type b)
[(lexical)
(f (cdr r)
(cons (list* label 'global (binding-value b)) env)
macro*)]
[(local-macro)
(let ([loc (gensym)])
(f (cdr r)
(cons (list* label 'global-macro loc) env)
(cons (cons loc (binding-value b)) macro*)))]
[($rtd) (f (cdr r) (cons x env) macro*)]
[else
(error #f "don't know how to export ~s ~s"
(binding-type b) (binding-value b))])))])))
(define (find-exports int* ext* rib r) (define (find-exports int* ext* rib r)
(let f ([int* int*] [ext* ext*] [subst '()] [env '()] [m* '()]) (let f ([int* int*] [ext* ext*] [subst '()] [env '()] [m* '()])
(cond (cond