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

* (export (rename (internal-name external-name) ...)) now works.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 01:32:52 -04:00
parent bf3e5711a9
commit 34fa59f9d4
3 changed files with 31 additions and 13 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.

40
src/libsyntax.ss
View File

@ -1911,6 +1911,23 @@
r mr lhs* lex* rhs* kwd*)] r mr lhs* lex* rhs* kwd*)]
[else [else
(return e* module-init** r mr lhs* lex* rhs*)]))))])))) (return e* module-init** r mr lhs* lex* rhs*)]))))]))))
(define (parse-exports exp*)
(let f ([exp* exp*] [int* '()] [ext* '()])
(cond
[(null? exp*)
(let ([id* (map (lambda (x) (stx x top-mark* '())) ext*)])
(unless (valid-bound-ids? id*)
(error #f "duplicate exports of ~s" (find-dups id*))))
(values int* ext*)]
[else
(syntax-match (car exp*) ()
[(rename (i* e*) ...)
(unless (and (eq? rename 'rename) (andmap symbol? i*) (andmap symbol? e*))
(error #f "invalid export specifier ~s" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*))]
[ie
(unless (symbol? ie) (error #f "invalid export ~s" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*))])])))
(define parse-library (define parse-library
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -1921,9 +1938,9 @@
(if (and (eq? export 'export) (if (and (eq? export 'export)
(eq? import 'import) (eq? import 'import)
(symbol? name) (symbol? name)
(andmap symbol? name*) (andmap symbol? name*))
(andmap symbol? exp*)) (let-values ([(exp-int* exp-ext*) (parse-exports exp*)])
(values (cons name name*) exp* imp* b*) (values (cons name name*) exp-int* exp-ext* imp* b*))
(error who "malformed library ~s" e))] (error who "malformed library ~s" e))]
[_ (error who "malformed library ~s" e)]))) [_ (error who "malformed library ~s" e)])))
(define (set-cons x ls) (define (set-cons x ls)
@ -1983,7 +2000,7 @@
x))) x)))
(define core-library-expander (define core-library-expander
(lambda (e) (lambda (e)
(let-values ([(name exp* imp* b*) (parse-library e)]) (let-values ([(name exp-int* exp-ext* imp* b*) (parse-library e)])
(let-values ([(subst imp*) (get-import-subst/libs imp*)]) (let-values ([(subst imp*) (get-import-subst/libs imp*)])
(let ([rib (make-top-rib subst)]) (let ([rib (make-top-rib subst)])
(let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)] (let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)]
@ -2000,7 +2017,8 @@
(append (append
(map build-export lex*) (map build-export lex*)
(chi-expr* init* r mr))))]) (chi-expr* init* r mr))))])
(let-values ([(export-subst export-env) (find-exports rib r exp*)]) (let-values ([(export-subst export-env)
(find-exports rib r exp-int* exp-ext*)])
(values (values
name imp* (rtc) name imp* (rtc)
(build-letrec no-source lex* rhs* body) (build-letrec no-source lex* rhs* body)
@ -2046,13 +2064,13 @@
;;; exports use the same gensym ;;; exports use the same gensym
(list sym label 'global (binding-value b))] (list sym label 'global (binding-value b))]
[else (error #f "cannot export ~s of type ~s" sym type)]))))) [else (error #f "cannot export ~s of type ~s" sym type)])))))
(define (find-exports rib r sym*) (define (find-exports rib r int* ext*)
;;; FIXME: check unique exports ;;; FIXME: check unique exports
(let f ([sym* sym*] [subst '()] [env '()]) (let f ([int* int*] [ext* ext*] [subst '()] [env '()])
(cond (cond
[(null? sym*) (values subst env)] [(null? int*) (values subst env)]
[else [else
(let* ([sym (car sym*)] (let* ([sym (car int*)]
[id (stx sym top-mark* (list rib))] [id (stx sym top-mark* (list rib))]
[label (id->label id)] [label (id->label id)]
[b (label->binding label r)] [b (label->binding label r)]
@ -2061,8 +2079,8 @@
(stx-error id "cannot export unbound identifier")) (stx-error id "cannot export unbound identifier"))
(case type (case type
[(lexical) [(lexical)
(f (cdr sym*) (f (cdr int*) (cdr ext*)
(cons (cons sym label) subst) (cons (cons (car ext*) label) subst)
(cons (cons label (cons 'global (binding-value b))) env))] (cons (cons label (cons 'global (binding-value b))) env))]
[else (error #f "cannot export ~s of type ~s" sym type)]))]))) [else (error #f "cannot export ~s of type ~s" sym type)]))])))
(primitive-set! 'identifier? id?) (primitive-set! 'identifier? id?)

2
src/makefile.ss
View File

@ -88,7 +88,7 @@
(define-record library (code export-subst export-env)) (define-record library (code export-subst export-env))
(define must-export-primitives '()) (define must-export-primitives '(bar))
(define (expand-file filename) (define (expand-file filename)
(map (lambda (x) (map (lambda (x)