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

* now constructing visit code.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 20:32:36 -04:00
parent 5f07f5f921
commit 57a269436a
2 changed files with 39 additions and 15 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.

54
src/ikarus.syntax.ss
View File

@ -346,6 +346,7 @@
(define binding-type car) (define binding-type car)
(define binding-value cdr) (define binding-value cdr)
(define local-binding-value cadr) (define local-binding-value cadr)
(define local-macro-src cddr)
(define syntax-type (define syntax-type
(lambda (e r) (lambda (e r)
(cond (cond
@ -2160,21 +2161,35 @@
(chi-library-internal b* rib kwd*)]) (chi-library-internal b* rib kwd*)])
(seal-rib! rib) (seal-rib! rib)
(let ([rhs* (chi-rhs* rhs* r mr)]) (let ([rhs* (chi-rhs* rhs* r mr)])
(let ([body (if (and (null? init*) (null? lex*)) (let ([invoke-body (if (and (null? init*) (null? lex*))
(build-void) (build-void)
(build-sequence no-source (build-sequence no-source
(append (append
(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) (let-values ([(export-subst export-env macro*)
(find-exports exp-int* exp-ext* rib r)]) (find-exports exp-int* exp-ext* rib r)])
(values (values
name imp* (rtc) name imp* (rtc)
(build-letrec no-source lex* rhs* body) (build-letrec no-source lex* rhs* invoke-body)
macro*
export-subst export-env)))))))))))) export-subst export-env))))))))))))
(define (visit! macro*)
(for-each (lambda (x)
(let ([loc (car x)] [proc (cadr x)])
(set-symbol-value! loc proc)))
macro*))
(define (build-visit-code macro*)
(if (null? macro*)
(build-void)
(build-sequence no-source
(map (lambda (x)
(let ([loc (car x)] [src (cddr x)])
(build-global-assignment no-source loc src)))
macro*))))
(define (library-expander x) (define (library-expander x)
(let-values ([(name imp* run* invoke-code export-subst export-env) (let-values ([(name imp* run* invoke-code macro* export-subst export-env)
(core-library-expander x)]) (core-library-expander x)])
(let ([id (gensym)] (let ([id (gensym)]
[name name] [name name]
@ -2184,12 +2199,14 @@
[inv* (map library-spec run*)]) [inv* (map library-spec run*)])
(install-library id name ver (install-library id name ver
imp* vis* inv* export-subst export-env imp* vis* inv* export-subst export-env
void ;;; FIXME (lambda () (visit! macro*))
(lambda () (eval-core invoke-code)) (lambda () (eval-core invoke-code))
#t) #t)
(values invoke-code export-subst export-env)))) (values invoke-code
(build-visit-code macro*)
export-subst export-env))))
(define (boot-library-expand x) (define (boot-library-expand x)
(let-values ([(invoke-code export-subst export-env) (let-values ([(invoke-code visit-code export-subst export-env)
(library-expander x)]) (library-expander x)])
(values invoke-code export-subst export-env))) (values invoke-code export-subst export-env)))
(define build-export (define build-export
@ -2197,9 +2214,9 @@
;;; exports use the same gensym ;;; exports use the same gensym
`(#%$set-symbol-value! ',x ,x))) `(#%$set-symbol-value! ',x ,x)))
(define (find-exports int* ext* rib r) (define (find-exports int* ext* rib r)
(let f ([int* int*] [ext* ext*] [subst '()] [env '()]) (let f ([int* int*] [ext* ext*] [subst '()] [env '()] [m* '()])
(cond (cond
[(null? int*) (values subst env)] [(null? int*) (values subst env m*)]
[else [else
(let* ([sym (car int*)] (let* ([sym (car int*)]
[id (stx sym top-mark* (list rib))] [id (stx sym top-mark* (list rib))]
@ -2212,7 +2229,14 @@
[(lexical) [(lexical)
(f (cdr int*) (cdr ext*) (f (cdr int*) (cdr ext*)
(cons (cons (car ext*) label) subst) (cons (cons (car ext*) label) subst)
(cons (cons label (cons 'global (binding-value b))) env))] (cons (cons label (cons 'global (binding-value b))) env)
m*)]
[(local-macro)
(let ([loc (gensym)])
(f (cdr int*) (cdr ext*)
(cons (cons (car ext*) label) subst)
(cons (cons label (cons 'global-macro loc)) env)
(cons (cons loc (binding-value b)) m*)))]
[else (error #f "cannot export ~s of type ~s, value=~s" sym type [else (error #f "cannot export ~s of type ~s, value=~s" sym type
(binding-value b))]))]))) (binding-value b))]))])))
(define generate-temporaries (define generate-temporaries