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

* Added an argument "top?" to chi-body* which indicates whether 

we're expanding a top-level program (and thus can generate
  temporaries for expressions) or not.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-09 06:42:37 -04:00
parent e414b2daca
commit 7494c29bba
2 changed files with 10 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.

21
src/ikarus.syntax.ss
View File

@ -1667,7 +1667,7 @@
(let-values ([(e* r mr lex* rhs* mod** kwd*) (let-values ([(e* r mr lex* rhs* mod** kwd*)
(chi-body* (map (lambda (x) (add-subst rib x)) (chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*)) (syntax->list e*))
r mr '() '() '() '() rib)]) r mr '() '() '() '() rib #f)])
(when (null? e*) (when (null? e*)
(stx-error e* "no expression in body")) (stx-error e* "no expression in body"))
(let ([rhs* (chi-rhs* rhs* r mr)] (let ([rhs* (chi-rhs* rhs* r mr)]
@ -1678,7 +1678,7 @@
(define chi-library-internal (define chi-library-internal
(lambda (e* rib) (lambda (e* rib)
(let-values ([(e* r mr lex* rhs* mod** _kwd*) (let-values ([(e* r mr lex* rhs* mod** _kwd*)
(chi-body* e* '() '() '() '() '() '() rib)]) (chi-body* e* '() '() '() '() '() '() rib #t)])
(values (append (apply append (reverse mod**)) e*) (values (append (apply append (reverse mod**)) e*)
r mr (reverse lex*) (reverse rhs*))))) r mr (reverse lex*) (reverse rhs*)))))
(define chi-internal-module (define chi-internal-module
@ -1703,7 +1703,7 @@
[e* (map (lambda (x) (add-subst rib x)) [e* (map (lambda (x) (add-subst rib x))
(syntax->list e*))]) (syntax->list e*))])
(let-values ([(e* r mr lex* rhs* mod** kwd*) (let-values ([(e* r mr lex* rhs* mod** kwd*)
(chi-body* e* r mr lex* rhs* mod** kwd* rib)]) (chi-body* e* r mr lex* rhs* mod** kwd* rib #f)])
(let ([exp-lab* (let ([exp-lab*
(map (lambda (x) (map (lambda (x)
(or (id->label (add-subst rib x)) (or (id->label (add-subst rib x))
@ -1721,7 +1721,7 @@
(cons (cons lab (cons '$module iface)) mr) (cons (cons lab (cons '$module iface)) mr)
mod** kwd*))))))))) mod** kwd*)))))))))
(define chi-body* (define chi-body*
(lambda (e* r mr lex* rhs* mod** kwd* rib) (lambda (e* r mr lex* rhs* mod** kwd* rib top?)
(cond (cond
[(null? e*) (values e* r mr lex* rhs* mod** kwd*)] [(null? e*) (values e* r mr lex* rhs* mod** kwd*)]
[else [else
@ -1739,7 +1739,7 @@
(chi-body* (cdr e*) (chi-body* (cdr e*)
(add-lexical lab lex r) mr (add-lexical lab lex r) mr
(cons lex lex*) (cons rhs rhs*) (cons lex lex*) (cons rhs rhs*)
mod** kwd* rib)))] mod** kwd* rib top?)))]
[(define-syntax) [(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)]) (let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
@ -1750,29 +1750,28 @@
(let ([b (make-eval-transformer expanded-rhs)]) (let ([b (make-eval-transformer expanded-rhs)])
(chi-body* (cdr e*) (chi-body* (cdr e*)
(cons (cons lab b) r) (cons (cons lab b) mr) (cons (cons lab b) r) (cons (cons lab b) mr)
lex* rhs* lex* rhs* mod** kwd* rib top?))))]
mod** kwd* rib))))]
[(module) [(module)
(let-values ([(lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*) (let-values ([(lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*)
(chi-internal-module e r mr lex* rhs* mod** kwd*)]) (chi-internal-module e r mr lex* rhs* mod** kwd*)])
(for-each (for-each
(lambda (id lab) (extend-rib/check! rib id lab)) (lambda (id lab) (extend-rib/check! rib id lab))
m-exp-id* m-exp-lab*) m-exp-id* m-exp-lab*)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib))] (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
(chi-body* (append x* (cdr e*)) (chi-body* (append x* (cdr e*))
r mr lex* rhs* mod** kwd* rib)])] r mr lex* rhs* mod** kwd* rib top?)])]
[(global-macro) (error 'chi-body "global macro")] [(global-macro) (error 'chi-body "global macro")]
[(local-macro) [(local-macro)
(chi-body* (chi-body*
(cons (add-subst rib (chi-local-macro value e)) (cdr e*)) (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
r mr lex* rhs* mod** kwd* rib)] r mr lex* rhs* mod** kwd* rib top?)]
[(macro) [(macro)
(chi-body* (chi-body*
(cons (add-subst rib (chi-macro value e)) (cdr e*)) (cons (add-subst rib (chi-macro value e)) (cdr e*))
r mr lex* rhs* mod** kwd* rib)] r mr lex* rhs* mod** kwd* rib top?)]
[else [else
(values e* r mr lex* rhs* mod** kwd*)]))))]))) (values e* r mr lex* rhs* mod** kwd*)]))))])))
(define (expand-transformer expr r) (define (expand-transformer expr r)