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

* removed chi-internal-body

This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 23:25:28 -04:00
parent 887552b49f
commit bee9773072
2 changed files with 88 additions and 148 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.

176
src/ikarus.syntax.ss
View File

@ -1125,6 +1125,7 @@
(let ((d (syntax-cdr x))) (let ((d (syntax-cdr x)))
(and (syntax-pair? d) (and (syntax-pair? d)
(ellipsis? (syntax-car d))))))) (ellipsis? (syntax-car d)))))))
;;; FIXME: these should go away
(define syntax-foo-z (define syntax-foo-z
(lambda (x) (lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))]) (let f ([x (syntax-cdr (syntax-cdr x))])
@ -1766,85 +1767,26 @@
[(find-bound=? (car ls) (cdr ls) (cdr ls)) => [(find-bound=? (car ls) (cdr ls) (cdr ls)) =>
(lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))] (lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))]
[else (f (cdr ls) dups)]))) [else (f (cdr ls) dups)])))
(define chi-internal (define chi-internal
(lambda (e* r mr) (lambda (e* r mr)
(define return (let ([rib (make-empty-rib)])
(lambda (init* module-init** r mr lhs* lex* rhs*) (let-values ([(e* r mr lhs* lex* rhs* mod** kwd*)
(let ([mod-init* (apply append (reverse module-init**))]) (chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*))
rib r mr '() '() '() '() '())])
(unless (valid-bound-ids? lhs*) (unless (valid-bound-ids? lhs*)
(stx-error (find-dups lhs*) "multiple definitions in internal")) (stx-error (find-dups lhs*) "multiple definitions in internal"))
(when (null? e*)
(stx-error e* "no expression in body"))
(let ([rhs* (chi-rhs* rhs* r mr)] (let ([rhs* (chi-rhs* rhs* r mr)]
[init* (chi-expr* (append mod-init* init*) r mr)]) [init* (chi-expr* (append (apply append (reverse mod**)) e*) r mr)])
(build-letrec no-source (build-letrec no-source
(reverse lex*) (reverse rhs*) (reverse lex*) (reverse rhs*)
(build-sequence no-source init*)))))) (build-sequence no-source init*)))))))
(let* ([rib (make-empty-rib)]
[e* (map (lambda (x) (add-subst rib x))
(syntax->list e*))])
(let f ([e* e*] [module-init** '()] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
(cond
[(null? e*) (error 'chi-internal "empty body")]
[else
(let ([e (car e*)])
(let-values ([(type value kwd) (syntax-type e r)])
(let ([kwd* (cons-id kwd kwd*)])
(case type
[(define)
(let-values ([(id rhs) (parse-define e)])
(when (bound-id-member? id kwd*)
(stx-error id "undefined identifier"))
(let ([lex (gen-lexical id)]
[lab (gen-label id)])
(extend-rib! rib id lab)
(f (cdr e*)
module-init**
(add-lexical lab lex r)
mr
(cons id lhs*)
(cons lex lex*)
(cons rhs rhs*)
kwd*)))]
[(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*)
(stx-error id "undefined identifier"))
(let ([lab (gen-label id)])
(let ([expanded-rhs (expand-transformer rhs mr)])
(extend-rib! rib id lab)
(let ([b (make-eval-transformer expanded-rhs)])
(f (cdr e*)
module-init**
(cons (cons lab b) r)
(cons (cons lab b) mr)
(cons id lhs*) lex* rhs* kwd*)))))]
[(begin)
(syntax-match e ()
[(_ x* ...)
(f (append x* (cdr e*)) module-init**
r mr lhs* lex* rhs* kwd*)])]
[(local-macro)
(f (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)]
[(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)]
[(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
(chi-internal-module e r mr kwd*)])
(for-each
(lambda (id lab) (extend-rib! rib id lab))
m-exp-id* m-exp-lab*)
(f (cdr e*)
(cons m-init* module-init**)
r mr
(append m-exp-id* lhs*)
(append m-lex* lex*)
(append m-rhs* rhs*)
kwd*))]
[else
(return e* module-init** r mr lhs* lex* rhs*)]))))])))))
(define chi-internal-module (define chi-internal-module
(lambda (e r mr kwd*) (lambda (e r mr kwd*) ;;; (return init* r mr lhs* lex* rhs* kwd*)
(define parse-module (define parse-module
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -1924,31 +1866,10 @@
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 (expand-transformer expr r) (define chi-body*
(let ([rtc (make-collector)]) (lambda (e* rib r mr lhs* lex* rhs* mod** kwd*)
(let ([expanded-rhs
(parameterize ([inv-collector rtc]
[vis-collector (lambda (x) (void))])
(chi-expr expr r r))])
(for-each
(let ([mark-visit (vis-collector)])
(lambda (x)
(invoke-library x)
(mark-visit x)))
(rtc))
expanded-rhs)))
(define chi-library-internal
(lambda (e* rib kwd*)
(define return
(lambda (init* module-init** r mr lhs* lex* rhs*)
(let ([module-init* (apply append (reverse module-init**))])
(values (append module-init* init*)
r mr (reverse lex*) (reverse rhs*)))))
(let f ([e* e*] [module-init** '()] [r '()] [mr '()]
[lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
(cond (cond
[(null? e*) (return e* module-init** r mr lhs* lex* rhs*)] [(null? e*) (values e* r mr lhs* lex* rhs* mod** kwd*)]
[else [else
(let ([e (car e*)]) (let ([e (car e*)])
(let-values ([(type value kwd) (syntax-type e r)]) (let-values ([(type value kwd) (syntax-type e r)])
@ -1963,12 +1884,10 @@
(let ([lex (gen-lexical id)] (let ([lex (gen-lexical id)]
[lab (gen-label id)]) [lab (gen-label id)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
(f (cdr e*) (chi-body* (cdr e*)
module-init** rib (add-lexical lab lex r) mr
(add-lexical lab lex r)
mr
(cons id lhs*) (cons lex lex*) (cons rhs rhs*) (cons id lhs*) (cons lex lex*) (cons rhs rhs*)
kwd*)))] mod** kwd*)))]
[(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*)
@ -1977,39 +1896,60 @@
[expanded-rhs (expand-transformer rhs mr)]) [expanded-rhs (expand-transformer rhs mr)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
(let ([b (make-eval-transformer expanded-rhs)]) (let ([b (make-eval-transformer expanded-rhs)])
(f (cdr e*) (chi-body* (cdr e*)
module-init** rib (cons (cons lab b) r) (cons (cons lab b) mr)
(cons (cons lab b) r) (cons id lhs*) lex* rhs*
(cons (cons lab b) mr) mod** kwd*))))]
(cons id lhs*) lex* rhs* kwd*))))]
[(module) [(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*) (let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
(chi-internal-module e r mr kwd*)]) (chi-internal-module e r mr kwd*)])
(for-each (for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab))
m-exp-id* m-exp-lab*) m-exp-id* m-exp-lab*)
(f (cdr e*) (chi-body* (cdr e*)
(cons m-init* module-init**) rib r mr
r mr
(append m-exp-id* lhs*) (append m-exp-id* lhs*)
(append m-lex* lex*) (append m-lex* lex*)
(append m-rhs* rhs*) (append m-rhs* rhs*)
kwd*))] (cons m-init* mod**) kwd*))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
(f (append x* (cdr e*)) module-init** r mr lhs* lex* rhs* (chi-body* (append x* (cdr e*))
kwd*)])] rib r mr lhs* lex* rhs* mod** kwd*)])]
[(global-macro) (error 'chi-body "global macro")]
[(local-macro) [(local-macro)
(f (cons (add-subst rib (chi-local-macro value e)) (cdr e*)) (chi-body*
module-init** (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
r mr lhs* lex* rhs* kwd*)] rib r mr lhs* lex* rhs* mod** kwd*)]
[(macro) [(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*)) (chi-body*
module-init** (cons (add-subst rib (chi-macro value e)) (cdr e*))
r mr lhs* lex* rhs* kwd*)] rib r mr lhs* lex* rhs* mod** kwd*)]
[else [else
(return e* module-init** r mr lhs* lex* rhs*)]))))])))) (values e* r mr lhs* lex* rhs* mod** kwd*)]))))])))
(define chi-library-internal
(lambda (e* rib kwd*)
(let-values ([(e* r mr lhs* lex* rhs* mod** kwd*)
(chi-body* e* rib '() '() '() '() '() '() kwd*)])
(values (append (apply append (reverse mod**)) e*)
r mr (reverse lex*) (reverse rhs*)))))
(define (expand-transformer expr r)
(let ([rtc (make-collector)])
(let ([expanded-rhs
(parameterize ([inv-collector rtc]
[vis-collector (lambda (x) (void))])
(chi-expr expr r r))])
(for-each
(let ([mark-visit (vis-collector)])
(lambda (x)
(invoke-library x)
(mark-visit x)))
(rtc))
expanded-rhs)))
(define (parse-exports exp*) (define (parse-exports exp*)
(let f ([exp* exp*] [int* '()] [ext* '()]) (let f ([exp* exp*] [int* '()] [ext* '()])
(cond (cond