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

more cleanup in expander.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-13 06:41:44 -05:00
parent 112e00a6e6
commit 75f2d78678
4 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

2
scheme/ikarus.vectors.ss
View File

@ -139,7 +139,7 @@
(module (vector-map) (module (vector-map)
(define who 'vector-map) (define who 'vector-map)
(define (ls->vec ls n) (define (ls->vec ls n)
(let f ([v ($make-vector n)] (let f ([v (make-vector n)]
[n n] [n n]
[ls ls]) [ls ls])
(cond (cond

2
scheme/last-revision
View File

@ -1 +1 @@
1238 1239

26
scheme/psyntax.expander.ss
View File

@ -2649,14 +2649,14 @@
(begin (begin
(unless (for-all id? export*) (unless (for-all id? export*)
(stx-error e "module exports must be identifiers")) (stx-error e "module exports must be identifiers"))
(values #f export* b*))) (values #f (list->vector export*) b*)))
((_ name (export* ...) b* ...) ((_ name (export* ...) b* ...)
(begin (begin
(unless (id? name) (unless (id? name)
(stx-error e "module name must be an identifier")) (stx-error e "module name must be an identifier"))
(unless (for-all id? export*) (unless (for-all id? export*)
(stx-error e "module exports must be identifiers")) (stx-error e "module exports must be identifiers"))
(values name export* b*)))))) (values name (list->vector export*) b*))))))
(define chi-internal-module (define chi-internal-module
(lambda (e r mr lex* rhs* mod** kwd*) (lambda (e r mr lex* rhs* mod** kwd*)
@ -2666,20 +2666,21 @@
(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 #f))) (chi-body* e* r mr lex* rhs* mod** kwd* rib #f)))
(let ((exp-lab* (let ((exp-lab*
(map (lambda (x) (vector-map
(or (id->label (lambda (x)
(mkstx (id->sym x) (stx-mark* x) (or (id->label
(list rib))) (mkstx (id->sym x) (stx-mark* x)
(stx-error x "cannot find module export"))) (list rib)))
exp-id*)) (stx-error x "cannot find module export")))
exp-id*))
(mod** (cons e* mod**))) (mod** (cons e* mod**)))
(if (not name) ;;; explicit export (if (not name) ;;; explicit export
(values lex* rhs* exp-id* exp-lab* r mr mod** kwd*) (values lex* rhs* exp-id* exp-lab* r mr mod** kwd*)
(let ((lab (gen-label 'module)) (let ((lab (gen-label 'module))
(iface (cons exp-id* exp-lab*))) (iface (cons exp-id* exp-lab*)))
(values lex* rhs* (values lex* rhs*
(list name) ;;; FIXME: module cannot (vector name) ;;; FIXME: module cannot
(list lab) ;;; export itself yet (vector 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)
mod** kwd*))))))))) mod** kwd*)))))))))
@ -2753,7 +2754,7 @@
((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 (vector-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*) r mr lex* rhs* mod** kwd* rib top?))) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)))
@ -2775,8 +2776,7 @@
(($module) (($module)
(let ((iface value)) (let ((iface value))
(let ((id* (car iface)) (lab* (cdr iface))) (let ((id* (car iface)) (lab* (cdr iface)))
(values (list->vector id*) (values id* lab*))))
(list->vector lab*)))))
(else (stx-error e "invalid import"))))))) (else (stx-error e "invalid import")))))))
(define (library-import e) (define (library-import e)
(syntax-match e () (syntax-match e ()