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

- Added (environment-symbols <env>) which returns a list of symbols 

exported by the environment.  Try 
  > (environment-symbols (environment '(rnrs)))

- Added an internal export mechanism so that identifiers can be
  exported from within a library.  The syntax is the same:
    (export export-spec* ...) 
  when appears in a library's top level, adds the export specs to
  the set of exported identifiers.  So, one can do:
    (library (A) 
      (export)
      (import (ikarus))
      (export a)
      (define a 17))
  When appearing in non-library definition context, the export form
  is ignored.
This commit is contained in:
Abdulaziz Ghuloum 2008-09-10 06:35:18 -07:00
parent a9193018a6
commit fcef21c693
3 changed files with 66 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1590 1592

3
scheme/makefile.ss
View File

@ -116,6 +116,7 @@
[library (library)] [library (library)]
[begin (begin)] [begin (begin)]
[import (import)] [import (import)]
[export (export)]
[set! (set!)] [set! (set!)]
[let-syntax (let-syntax)] [let-syntax (let-syntax)]
[letrec-syntax (letrec-syntax)] [letrec-syntax (letrec-syntax)]
@ -279,6 +280,7 @@
(define identifier->library-map (define identifier->library-map
'( '(
[import i] [import i]
[export i]
[foreign-call i] [foreign-call i]
[type-descriptor i] [type-descriptor i]
[parameterize i parameters] [parameterize i parameters]
@ -378,6 +380,7 @@
[expand i] [expand i]
[expand/optimize i] [expand/optimize i]
[environment? i] [environment? i]
[environment-symbols i]
[time-it i] [time-it i]
[verbose-timer i] [verbose-timer i]
[current-time i] [current-time i]

112
scheme/psyntax.expander.ss
View File

@ -19,7 +19,7 @@
;;; DEALINGS IN THE SOFTWARE. ;;; DEALINGS IN THE SOFTWARE.
(library (psyntax expander) (library (psyntax expander)
(export identifier? syntax-dispatch environment environment? (export identifier? syntax-dispatch
eval expand generate-temporaries free-identifier=? eval expand generate-temporaries free-identifier=?
bound-identifier=? datum->syntax syntax-error bound-identifier=? datum->syntax syntax-error
syntax-violation syntax-violation
@ -30,7 +30,8 @@
compile-r6rs-top-level boot-library-expand compile-r6rs-top-level boot-library-expand
null-environment scheme-report-environment null-environment scheme-report-environment
interaction-environment interaction-environment
ellipsis-map assertion-error) ellipsis-map assertion-error
environment environment? environment-symbols)
(import (import
(except (rnrs) (except (rnrs)
environment environment? identifier? environment environment? identifier?
@ -688,8 +689,8 @@
(case type (case type
((lexical core-prim macro macro! global local-macro ((lexical core-prim macro macro! global local-macro
local-macro! global-macro global-macro! local-macro! global-macro global-macro!
displaced-lexical syntax import $module $core-rtd displaced-lexical syntax import export $module
library mutable) $core-rtd library mutable)
(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)
@ -704,7 +705,7 @@
((define define-syntax core-macro begin macro ((define define-syntax core-macro begin macro
macro! local-macro local-macro! global-macro macro! local-macro local-macro! global-macro
global-macro! module library set! let-syntax global-macro! module library set! let-syntax
letrec-syntax import $core-rtd) letrec-syntax import export $core-rtd)
(values type (binding-value b) id)) (values type (binding-value b) id))
(else (else
(values 'call #f #f)))) (values 'call #f #f))))
@ -2760,6 +2761,7 @@
((module) "a module definition") ((module) "a module definition")
((library) "a library definition") ((library) "a library definition")
((import) "an import declaration") ((import) "an import declaration")
((export) "an export declaration")
(else "a non-expression")) (else "a non-expression"))
" was found where an expression was expected"))) " was found where an expression was expected")))
((mutable) ((mutable)
@ -2913,10 +2915,10 @@
(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 lex* rhs* mod** kwd*) (let-values (((e* r mr lex* rhs* mod** kwd* _exp*)
(chi-body* (map (lambda (x) (add-subst rib x)) (chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*)) (syntax->list e*))
r mr '() '() '() '() rib #f))) r mr '() '() '() '() '() rib #f)))
(when (null? e*) (when (null? e*)
(stx-error e* "no expression in body")) (stx-error e* "no expression in body"))
(let* ((init* (let* ((init*
@ -2967,8 +2969,8 @@
(let-values (((name exp-id* e*) (parse-module e))) (let-values (((name exp-id* e*) (parse-module e)))
(let* ((rib (make-empty-rib)) (let* ((rib (make-empty-rib))
(e* (map (lambda (x) (add-subst rib x)) (syntax->list e*)))) (e* (map (lambda (x) (add-subst rib x)) (syntax->list e*))))
(let-values (((e* r mr lex* rhs* mod** kwd*) (let-values (((e* r mr lex* rhs* mod** kwd* _exp*)
(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*
(vector-map (vector-map
(lambda (x) (lambda (x)
@ -2998,9 +3000,9 @@
mod** kwd*))))))))) mod** kwd*)))))))))
(define chi-body* (define chi-body*
(lambda (e* r mr lex* rhs* mod** kwd* rib top?) (lambda (e* r mr lex* rhs* mod** kwd* exp* rib top?)
(cond (cond
((null? e*) (values e* r mr lex* rhs* mod** kwd*)) ((null? e*) (values e* r mr lex* rhs* mod** kwd* exp*))
(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)))
@ -3015,7 +3017,7 @@
(chi-body* (cdr e*) (chi-body* (cdr e*)
(add-lexical lab lex r) mr (add-lexical lab lex r) mr
(cons lex lex*) (cons rhs rhs*) (cons lex lex*) (cons rhs rhs*)
mod** kwd* rib top?)))) mod** kwd* exp* rib top?))))
((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*)
@ -3026,7 +3028,7 @@
(let ((b (make-eval-transformer expanded-rhs))) (let ((b (make-eval-transformer expanded-rhs)))
(chi-body* (cdr e*) (chi-body* (cdr e*)
(cons (cons lab b) r) (cons (cons lab b) mr) (cons (cons lab b) r) (cons (cons lab b) mr)
lex* rhs* mod** kwd* rib top?))))) lex* rhs* mod** kwd* exp* rib top?)))))
((let-syntax letrec-syntax) ((let-syntax letrec-syntax)
(syntax-match e () (syntax-match e ()
((_ ((xlhs* xrhs*) ...) xbody* ...) ((_ ((xlhs* xrhs*) ...) xbody* ...)
@ -3046,37 +3048,43 @@
(append (map (lambda (x) (add-subst xrib x)) xbody*) (cdr e*)) (append (map (lambda (x) (add-subst xrib x)) xbody*) (cdr e*))
(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* exp* rib top?)))))
((begin) ((begin)
(syntax-match e () (syntax-match e ()
((_ x* ...) ((_ x* ...)
(chi-body* (append x* (cdr e*)) (chi-body* (append x* (cdr e*))
r mr lex* rhs* mod** kwd* rib top?)))) r mr lex* rhs* mod** kwd* exp* rib top?))))
((global-macro global-macro!) ((global-macro global-macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-global-macro value e)) (cons (add-subst rib (chi-global-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* rib top?)) r mr lex* rhs* mod** kwd* exp* rib top?))
((local-macro local-macro!) ((local-macro local-macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-local-macro value e)) (cons (add-subst rib (chi-local-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* rib top?)) r mr lex* rhs* mod** kwd* exp* rib top?))
((macro macro!) ((macro macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-macro value e)) (cons (add-subst rib (chi-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* rib top?)) r mr lex* rhs* mod** kwd* exp* rib top?))
((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*)))
(vector-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* exp* rib top?)))
((library) ((library)
(library-expander (stx->datum e)) (library-expander (stx->datum e))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))
((export)
(syntax-match e ()
((_ exp-decl* ...)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd*
(append exp-decl* exp*) rib top?))))
((import) ((import)
(let () (let ()
(define (module-import? e) (define (module-import? e)
@ -3115,14 +3123,14 @@
(vector-for-each (vector-for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab))
id* lab*))) id* lab*)))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))
(else (else
(if top? (if top?
(chi-body* (cdr e*) r mr (chi-body* (cdr e*) r mr
(cons (gen-lexical 'dummy) lex*) (cons (gen-lexical 'dummy) lex*)
(cons (cons 'top-expr e) rhs*) (cons (cons 'top-expr e) rhs*)
mod** kwd* rib top?) mod** kwd* exp* rib top?)
(values e* r mr lex* rhs* mod** kwd*))))))))))) (values e* r mr lex* rhs* mod** kwd* exp*)))))))))))
(define (expand-transformer expr r) (define (expand-transformer expr r)
(let ((rtc (make-collector))) (let ((rtc (make-collector)))
@ -3139,27 +3147,25 @@
expanded-rhs))) expanded-rhs)))
(define (parse-exports exp*) (define (parse-exports exp*)
(define (idsyn? x) (symbol? (syntax->datum x)))
(let f ((exp* exp*) (int* '()) (ext* '())) (let f ((exp* exp*) (int* '()) (ext* '()))
(cond (cond
((null? exp*) ((null? exp*)
(let ((id* (map (lambda (x) (make-stx x top-mark* '() '())) ext*))) (unless (valid-bound-ids? ext*)
(unless (valid-bound-ids? id*) (syntax-violation 'export "invalid exports"
(syntax-violation 'export "invalid exports" (find-dups ext*)))
(find-dups id*))))
(values (map syntax->datum int*) (map syntax->datum ext*))) (values (map syntax->datum int*) (map syntax->datum ext*)))
(else (else
(syntax-match (car exp*) () (syntax-match (car exp*) ()
((rename (i* e*) ...) ((rename (i* e*) ...)
(begin (begin
(unless (and (eq? (syntax->datum rename) 'rename) (unless (and (eq? (syntax->datum rename) 'rename)
(for-all idsyn? i*) (for-all id? i*)
(for-all idsyn? e*)) (for-all id? e*))
(syntax-violation 'export "invalid export specifier" (car exp*))) (syntax-violation 'export "invalid export specifier" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*)))) (f (cdr exp*) (append i* int*) (append e* ext*))))
(ie (ie
(begin (begin
(unless (idsyn? ie) (unless (id? ie)
(syntax-violation 'export "invalid export" ie)) (syntax-violation 'export "invalid export" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*))))))))) (f (cdr exp*) (cons ie int*) (cons ie ext*)))))))))
@ -3456,16 +3462,16 @@
(define chi-library-internal (define chi-library-internal
(lambda (e* rib top?) (lambda (e* rib top?)
(let-values (((e* r mr lex* rhs* mod** _kwd*) (let-values (((e* r mr lex* rhs* mod** _kwd* exp*)
(chi-body* e* '() '() '() '() '() '() rib top?))) (chi-body* e* '() '() '() '() '() '() '() rib top?)))
(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*) exp*))))
(define chi-interaction-expr (define chi-interaction-expr
(lambda (e rib r) (lambda (e rib r)
(let-values (((e* r mr lex* rhs* mod** _kwd*) (let-values (((e* r mr lex* rhs* mod** _kwd* _exp*)
(chi-body* (list e) r r '() '() '() '() rib #t))) (chi-body* (list e) r r '() '() '() '() '() rib #t)))
(let ([e* (expand-interaction-rhs*/init* (let ([e* (expand-interaction-rhs*/init*
(reverse lex*) (reverse rhs*) (reverse lex*) (reverse rhs*)
(append (apply append (reverse mod**)) e*) (append (apply append (reverse mod**)) e*)
@ -3477,23 +3483,24 @@
(values e r)))))) (values e r))))))
(define library-body-expander (define library-body-expander
(lambda (exp* imp* b* top?) (lambda (main-exp* imp* b* top?)
(define itc (make-collector)) (define itc (make-collector))
(parameterize ((imp-collector itc) (parameterize ((imp-collector itc)
(top-level-context #f)) (top-level-context #f))
(let-values (((exp-int* exp-ext*) (parse-exports exp*))) (let-values (((subst-names subst-labels)
(let-values (((subst-names subst-labels) (parse-import-spec* imp*)))
(parse-import-spec* imp*))) (let ((rib (make-top-rib subst-names subst-labels)))
(let ((rib (make-top-rib subst-names subst-labels))) (define (wrap x) (make-stx x top-mark* (list rib) '()))
(let ((b* (map (lambda (x) (let ((b* (map wrap b*))
(make-stx x top-mark* (list rib) '())) (main-exp* (map wrap main-exp*))
b*)) (rtc (make-collector))
(rtc (make-collector)) (vtc (make-collector)))
(vtc (make-collector))) (parameterize ((inv-collector rtc)
(parameterize ((inv-collector rtc) (vis-collector vtc))
(vis-collector vtc)) (let-values (((init* r mr lex* rhs* internal-exp*)
(let-values (((init* r mr lex* rhs*) (chi-library-internal b* rib top?)))
(chi-library-internal b* rib top?))) (let-values (((exp-int* exp-ext*)
(parse-exports (append main-exp* internal-exp*))))
(seal-rib! rib) (seal-rib! rib)
(let* ((init* (chi-expr* init* r mr)) (let* ((init* (chi-expr* init* r mr))
(rhs* (chi-rhs* rhs* r mr))) (rhs* (chi-rhs* rhs* r mr)))
@ -3580,6 +3587,11 @@
(define environment? (define environment?
(lambda (x) (or (env? x) (interaction-env? x)))) (lambda (x) (or (env? x) (interaction-env? x))))
(define (environment-symbols x)
(if (env? x)
(vector->list (env-names x))
(assertion-violation 'environment-symbols "not an environment" x)))
;;; This is R6RS's environment. It parses the import specs ;;; This is R6RS's environment. It parses the import specs
;;; and constructs an env record that can be used later by ;;; and constructs an env record that can be used later by
;;; eval and/or expand. ;;; eval and/or expand.