* 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

Binary file not shown.

View File

@ -1125,6 +1125,7 @@
(let ((d (syntax-cdr x)))
(and (syntax-pair? d)
(ellipsis? (syntax-car d)))))))
;;; FIXME: these should go away
(define syntax-foo-z
(lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))])
@ -1766,85 +1767,26 @@
[(find-bound=? (car ls) (cdr ls) (cdr ls)) =>
(lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))]
[else (f (cdr ls) dups)])))
(define chi-internal
(lambda (e* r mr)
(define return
(lambda (init* module-init** r mr lhs* lex* rhs*)
(let ([mod-init* (apply append (reverse module-init**))])
(unless (valid-bound-ids? lhs*)
(stx-error (find-dups lhs*) "multiple definitions in internal"))
(let ([rhs* (chi-rhs* rhs* r mr)]
[init* (chi-expr* (append mod-init* init*) r mr)])
(build-letrec no-source
(reverse lex*) (reverse rhs*)
(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*)]))))])))))
(let ([rib (make-empty-rib)])
(let-values ([(e* r mr lhs* lex* rhs* mod** kwd*)
(chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*))
rib r mr '() '() '() '() '())])
(unless (valid-bound-ids? lhs*)
(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)]
[init* (chi-expr* (append (apply append (reverse mod**)) e*) r mr)])
(build-letrec no-source
(reverse lex*) (reverse rhs*)
(build-sequence no-source init*)))))))
(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
(lambda (e)
(syntax-match e ()
@ -1924,6 +1866,76 @@
r mr lhs* lex* rhs* kwd*)]
[else (return e* r mr lhs* lex* rhs* kwd*)]))))]))))))
(define chi-body*
(lambda (e* rib r mr lhs* lex* rhs* mod** kwd*)
(cond
[(null? e*) (values e* r mr lhs* lex* rhs* mod** kwd*)]
[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 "cannot redefine identifier"))
(when (bound-id-member? id lhs*)
(stx-error id "multiple definition"))
(let ([lex (gen-lexical id)]
[lab (gen-label id)])
(extend-rib! rib id lab)
(chi-body* (cdr e*)
rib (add-lexical lab lex r) mr
(cons id lhs*) (cons lex lex*) (cons rhs rhs*)
mod** 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)]
[expanded-rhs (expand-transformer rhs mr)])
(extend-rib! rib id lab)
(let ([b (make-eval-transformer expanded-rhs)])
(chi-body* (cdr e*)
rib (cons (cons lab b) r) (cons (cons lab b) mr)
(cons id lhs*) lex* rhs*
mod** 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*)
(chi-body* (cdr e*)
rib r mr
(append m-exp-id* lhs*)
(append m-lex* lex*)
(append m-rhs* rhs*)
(cons m-init* mod**) kwd*))]
[(begin)
(syntax-match e ()
[(_ x* ...)
(chi-body* (append x* (cdr e*))
rib r mr lhs* lex* rhs* mod** kwd*)])]
[(global-macro) (error 'chi-body "global macro")]
[(local-macro)
(chi-body*
(cons (add-subst rib (chi-local-macro value e)) (cdr e*))
rib r mr lhs* lex* rhs* mod** kwd*)]
[(macro)
(chi-body*
(cons (add-subst rib (chi-macro value e)) (cdr e*))
rib r mr lhs* lex* rhs* mod** kwd*)]
[else
(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
@ -1938,78 +1950,6 @@
(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
[(null? e*) (return e* module-init** r mr lhs* lex* rhs*)]
[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 "cannot redefine identifier"))
(when (bound-id-member? id lhs*)
(stx-error id "multiple definition"))
(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)]
[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*))))]
[(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*))]
[(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*)]
[else
(return e* module-init** r mr lhs* lex* rhs*)]))))]))))
(define (parse-exports exp*)
(let f ([exp* exp*] [int* '()] [ext* '()])
(cond