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

* Added (import M) for M \in modules.

This commit is contained in:
Abdulaziz Ghuloum 2007-06-02 05:59:55 +03:00
parent d2657bde24
commit b7b3709f69
2 changed files with 27 additions and 9 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.

36
src/ikarus.syntax.ss
View File

@ -415,7 +415,8 @@
(stx-error e "unbound identifier")) (stx-error e "unbound identifier"))
(case type (case type
[(lexical core-prim macro global local-macro [(lexical core-prim macro global local-macro
global-macro displaced-lexical syntax import) global-macro displaced-lexical syntax import
$module)
(values type (binding-value b) id)] (values type (binding-value b) id)]
[else (values 'other #f #f)])))] [else (values 'other #f #f)])))]
[(syntax-pair? e) [(syntax-pair? e)
@ -1657,7 +1658,7 @@
[(displaced-lexical) [(displaced-lexical)
(stx-error e "identifier out of context")] (stx-error e "identifier out of context")]
[(syntax) (stx-error e "reference to pattern variable outside a syntax form")] [(syntax) (stx-error e "reference to pattern variable outside a syntax form")]
[(define define-syntax module) [(define define-syntax module import)
(stx-error e "invalid expression")] (stx-error e "invalid expression")]
[else (error 'chi-expr "invalid type ~s for ~s" type [else (error 'chi-expr "invalid type ~s for ~s" type
(strip e '())) (stx-error e)])))) (strip e '())) (stx-error e)]))))
@ -1858,13 +1859,6 @@
(append (map cons xlab* xb*) r) (append (map cons xlab* xb*) r)
(append (map cons xlab* xb*) mr) (append (map cons xlab* xb*) mr)
lex* rhs* mod** kwd* rib top?))])] lex* rhs* mod** kwd* rib top?))])]
[(module)
(let-values ([(lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*)
(chi-internal-module e r mr lex* rhs* mod** kwd*)])
(for-each
(lambda (id lab) (extend-rib/check! rib id lab))
m-exp-id* m-exp-lab*)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
@ -1882,6 +1876,30 @@
(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 top?)] r mr lex* rhs* mod** kwd* rib top?)]
[(module)
(let-values ([(lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*)
(chi-internal-module e r mr lex* rhs* mod** kwd*)])
(for-each
(lambda (id lab) (extend-rib/check! rib id lab))
m-exp-id* m-exp-lab*)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?))]
[(import)
(let ()
(define (module-import e r)
(syntax-match e ()
[(_ id) (id? id)
(let-values ([(type value kwd) (syntax-type id r)])
(case type
[($module)
(let ([iface value])
(let ([id* (car iface)] [lab* (cdr iface)])
(values id* lab*)))]
[else (stx-error e "invalid import")]))]))
(let-values ([(id* lab*) (module-import e r)])
(for-each
(lambda (id lab) (extend-rib/check! rib id lab))
id* lab*)))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)]
[else [else
(if top? (if top?
(chi-body* (cdr e*) r mr (chi-body* (cdr e*) r mr