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

* removed lhs* and kwd* from expander, now reinstating properly.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 00:45:22 -04:00
parent fc418d1fb6
commit 2d8a4521cf
2 changed files with 35 additions and 42 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.

77
src/ikarus.syntax.ss
View File

@ -1771,12 +1771,12 @@
(define chi-internal (define chi-internal
(lambda (e* r mr) (lambda (e* r mr)
(let ([rib (make-empty-rib)]) (let ([rib (make-empty-rib)])
(let-values ([(e* r mr lhs* lex* rhs* mod** kwd*) (let-values ([(e* r mr lex* rhs* mod**)
(chi-body* (map (lambda (x) (add-subst rib x)) (chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*)) (syntax->list e*))
rib r mr '() '() '() '() '())]) 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*) (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)]
@ -1787,13 +1787,13 @@
(define chi-library-internal (define chi-library-internal
(lambda (e* rib kwd*) (lambda (e* rib kwd*)
(let-values ([(e* r mr lhs* lex* rhs* mod** kwd*) (let-values ([(e* r mr lex* rhs* mod**)
(chi-body* e* rib '() '() '() '() '() '() kwd*)]) (chi-body* e* rib '() '() '() '() '())])
(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
(lambda (e r mr kwd*) ;;; (return init* r mr lhs* lex* rhs* kwd*) (lambda (e r mr lex* rhs* mod**) ;;; (return init* r mr lhs* lex* rhs* kwd*)
(define parse-module (define parse-module
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -1807,91 +1807,84 @@
(let* ([rib (make-empty-rib)] (let* ([rib (make-empty-rib)]
[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 lhs* lex* rhs* mod** kwd*) (let-values ([(e* r mr lex* rhs* mod**)
(chi-body* e* rib r mr '() '() '() '() kwd*)]) (chi-body* e* rib r mr lex* rhs* mod**)])
(unless (valid-bound-ids? lhs*) ;;; (unless (valid-bound-ids? lhs*)
(stx-error (find-dups lhs*) "multiple definitions in module")) ;;; (stx-error (find-dups lhs*) "multiple definitions in module"))
(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))
(stx-error x "cannot find export"))) (stx-error x "cannot find export")))
exp-id*)] exp-id*)]
[init* [mod** (cons e* mod**)])
(append (apply append (reverse mod**)) e*)])
(if (not name) ;;; explicit export (if (not name) ;;; explicit export
(values lhs* lex* rhs* init* exp-id* exp-lab* r mr kwd*) (values lex* rhs* exp-id* exp-lab* r mr mod**)
(let ([lab (gen-label 'module)] (let ([lab (gen-label 'module)]
[iface (cons exp-id* exp-lab*)]) [iface (cons exp-id* exp-lab*)])
(values lhs* lex* rhs* init* (values lex* rhs*
(list name) ;;; FIXME: module cannot (list name) ;;; FIXME: module cannot
(list lab) ;;; export itself yet (list lab) ;;; export itself yet
(cons (cons lab (cons '$module iface)) r) (cons (cons lab (cons '$module iface)) r)
(cons (cons lab (cons '$module iface)) mr) (cons (cons lab (cons '$module iface)) mr)
kwd*))))))))) mod**)))))))))
(define chi-body* (define chi-body*
(lambda (e* rib r mr lhs* lex* rhs* mod** kwd*) (lambda (e* rib r mr lex* rhs* mod**)
(cond (cond
[(null? e*) (values e* r mr lhs* lex* rhs* mod** kwd*)] [(null? e*) (values e* r mr lex* rhs* mod**)]
[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)])
(let ([kwd* (cons-id kwd kwd*)]) (let () ;;; ([kwd* (cons-id kwd kwd*)])
(case type (case type
[(define) [(define)
(let-values ([(id rhs) (parse-define e)]) (let-values ([(id rhs) (parse-define e)])
(when (bound-id-member? id kwd*) ;;; (when (bound-id-member? id kwd*)
(stx-error id "cannot redefine identifier")) ;;; (stx-error id "cannot redefine identifier"))
(when (bound-id-member? id lhs*) ;;; (when (bound-id-member? id lhs*)
(stx-error id "multiple definition")) ;;; (stx-error id "multiple definition in body*"))
(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)
(chi-body* (cdr e*) (chi-body* (cdr e*)
rib (add-lexical lab lex r) mr rib (add-lexical lab lex r) mr
(cons id lhs*) (cons lex lex*) (cons rhs rhs*) (cons lex lex*) (cons rhs rhs*)
mod** kwd*)))] mod**)))]
[(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*)
(stx-error id "undefined identifier")) ;;; (stx-error id "undefined identifier"))
(let ([lab (gen-label id)] (let ([lab (gen-label id)]
[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)])
(chi-body* (cdr e*) (chi-body* (cdr e*)
rib (cons (cons lab b) r) (cons (cons lab b) mr) rib (cons (cons lab b) r) (cons (cons lab b) mr)
(cons id lhs*) lex* rhs* lex* rhs*
mod** kwd*))))] mod**))))]
[(module) [(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*) (let-values ([(lex* rhs* m-exp-id* m-exp-lab* r mr mod**)
(chi-internal-module e r mr kwd*)]) (chi-internal-module e r mr lex* rhs* mod**)])
(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*)
(chi-body* (cdr e*) (chi-body* (cdr e*) rib r mr lex* rhs* mod**))]
rib r mr
(append m-exp-id* lhs*)
(append m-lex* lex*)
(append m-rhs* rhs*)
(cons m-init* mod**) kwd*))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
(chi-body* (append x* (cdr e*)) (chi-body* (append x* (cdr e*))
rib r mr lhs* lex* rhs* mod** kwd*)])] rib r mr lex* rhs* mod**)])]
[(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*))
rib r mr lhs* lex* rhs* mod** kwd*)] rib r mr lex* rhs* mod**)]
[(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*))
rib r mr lhs* lex* rhs* mod** kwd*)] rib r mr lex* rhs* mod**)]
[else [else
(values e* r mr lhs* lex* rhs* mod** kwd*)]))))]))) (values e* r mr lex* rhs* mod**)]))))])))
(define (expand-transformer expr r) (define (expand-transformer expr r)
(let ([rtc (make-collector)]) (let ([rtc (make-collector)])