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

(ikarus)'s "import" keyword now handles libraries, allowing 

libraries to be imported into any definition context including
the top-level, body of a script, body of a library, or body of a
function.
This commit is contained in:
Abdulaziz Ghuloum 2007-11-12 04:40:48 -05:00
parent eaeb6a4876
commit 880a6f8efd
1 changed files with 99 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
scheme/psyntax.expander.ss
View File

@ -570,7 +570,8 @@
(syntax-case x () (syntax-case x ()
((_ stx) ((_ stx)
(syntax (error 'expander "invalid syntax" (stx->datum stx)))) (syntax (error 'expander "invalid syntax" (stx->datum stx))))
((_ stx msg) (syntax (error 'expander msg (strip stx '()))))))) ((_ stx msg arg* ...)
(syntax (error 'expander msg (strip stx '()) arg* ...))))))
;;; when the rhs of a syntax definition is evaluated, it should be ;;; when the rhs of a syntax definition is evaluated, it should be
;;; either a procedure, an identifier-syntax transformer or an ;;; either a procedure, an identifier-syntax transformer or an
@ -2599,10 +2600,15 @@
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?)))
((library) ((library)
((current-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* rib top?))
((import) ((import)
(let () (let ()
(define (module-import? e)
(syntax-match e ()
[(_ id) (id? id) #t]
[(_ imp* ...) #f]
[_ (stx-error e "malformed import form")]))
(define (module-import e r) (define (module-import e r)
(syntax-match e () (syntax-match e ()
((_ id) (id? id) ((_ id) (id? id)
@ -2613,7 +2619,21 @@
(let ((id* (car iface)) (lab* (cdr iface))) (let ((id* (car iface)) (lab* (cdr iface)))
(values id* lab*)))) (values id* lab*))))
(else (stx-error e "invalid import"))))))) (else (stx-error e "invalid import")))))))
(let-values (((id* lab*) (module-import e r))) (define (library-import e)
(syntax-match e ()
[(ctxt imp* ...)
(let ((subst (parse-import-spec*
(syntax->datum imp*))))
(values
(map (lambda (x)
(let ([name (car x)])
(datum->stx ctxt name)))
subst)
(map cdr subst)))]))
(let-values (((id* lab*)
(if (module-import? e)
(module-import e r)
(library-import e))))
(for-each (for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab))
id* lab*))) id* lab*)))
@ -2693,8 +2713,31 @@
((macro macro!) ((macro macro!)
(chi-top* (cons (chi-macro value e) (cdr e*)) init*)) (chi-top* (cons (chi-macro value e) (cdr e*)) init*))
((library) ((library)
((current-library-expander) (stx->datum e)) (library-expander (stx->datum e))
(chi-top* (cdr e*) init*)) (chi-top* (cdr e*) init*))
((import)
(begin
(syntax-match e ()
[(ctxt imp* ...)
(let ((subst (parse-import-spec* (syntax->datum imp*))))
(cond
((interaction-library) =>
(lambda (lib)
(for-each
(lambda (x)
(let ([sym (car x)] [label (cdr x)])
(cond
((assq sym (library-subst lib)) =>
(lambda (p)
(unless (eq? (cdr p) label)
(stx-error e
"identifier conflict"
sym))))
(else
(extend-library-subst! lib sym label)))))
subst)))
(else (error 'import "BUG: cannot happen"))))])
(chi-top* (cdr e*) init*)))
(else (else
(chi-top* (cdr e*) (chi-top* (cdr e*)
(cons (cons #f (chi-expr e '() '())) (cons (cons #f (chi-expr e '() '()))
@ -2772,7 +2815,6 @@
;;; returns: ((z . z$label) (y . x$label) (q . q$label)) ;;; returns: ((z . z$label) (y . x$label) (q . q$label))
;;; and (#<library (foo)> #<library (bar)>) ;;; and (#<library (foo)> #<library (bar)>)
(define (parse-import-spec* imp*) (define (parse-import-spec* imp*)
(define imp-collector (make-collector))
(define (merge-substs s subst) (define (merge-substs s subst)
(define (insert-to-subst a subst) (define (insert-to-subst a subst)
(let ((name (car a)) (label (cdr a))) (let ((name (car a)) (label (cdr a)))
@ -2930,7 +2972,7 @@
"library does not satisfy version specification" "library does not satisfy version specification"
lib lib
spec*)) spec*))
(imp-collector lib) ((imp-collector) lib)
(library-subst lib)))) (library-subst lib))))
((x x* ...) ((x x* ...)
(not (memq x '(rename except only prefix library))) (not (memq x '(rename except only prefix library)))
@ -2938,7 +2980,7 @@
(spec (error 'import "invalid import spec" spec)))) (spec (error 'import "invalid import spec" spec))))
(let f ((imp* imp*) (subst '())) (let f ((imp* imp*) (subst '()))
(cond (cond
((null? imp*) (values subst (imp-collector))) ((null? imp*) subst)
(else (else
(f (cdr imp*) (merge-substs (get-import (car imp*)) subst)))))) (f (cdr imp*) (merge-substs (get-import (car imp*)) subst))))))
@ -2983,6 +3025,15 @@
(error 'vis-collector "not a procedure" x)) (error 'vis-collector "not a procedure" x))
x))) x)))
(define imp-collector
(make-parameter
(lambda args
(error 'imp-collector "not initialized"))
(lambda (x)
(unless (procedure? x)
(error 'imp-collector "not a procedure" x))
x)))
(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*)
@ -2992,34 +3043,36 @@
(define library-body-expander (define library-body-expander
(lambda (exp* imp* b* top?) (lambda (exp* imp* b* top?)
(let-values (((exp-int* exp-ext*) (parse-exports exp*)) (define itc (make-collector))
((subst imp*) (parse-import-spec* imp*))) (parameterize ((imp-collector itc))
(let ((rib (make-top-rib subst))) (let-values (((exp-int* exp-ext*) (parse-exports exp*)))
(let ((b* (map (lambda (x) (mkstx x top-mark* (list rib))) b*)) (let ((subst (parse-import-spec* imp*)))
(rtc (make-collector)) (let ((rib (make-top-rib subst)))
(vtc (make-collector))) (let ((b* (map (lambda (x) (mkstx x top-mark* (list rib))) b*))
(parameterize ((inv-collector rtc) (rtc (make-collector))
(vis-collector vtc)) (vtc (make-collector)))
(let-values (((init* r mr lex* rhs*) (parameterize ((inv-collector rtc)
(chi-library-internal b* rib top?))) (vis-collector vtc))
(seal-rib! rib) (let-values (((init* r mr lex* rhs*)
(let ((rhs* (chi-rhs* rhs* r mr)) (chi-library-internal b* rib top?)))
(init* (chi-expr* init* r mr))) (seal-rib! rib)
(unseal-rib! rib) (let ((rhs* (chi-rhs* rhs* r mr))
(let ((export-subst (make-export-subst exp-int* exp-ext* rib))) (init* (chi-expr* init* r mr)))
(let-values (((export-env global* macro*) (unseal-rib! rib)
(make-export-env/macros r))) (let ((export-subst (make-export-subst exp-int* exp-ext* rib)))
(let ((invoke-body (let-values (((export-env global* macro*)
(build-letrec* no-source lex* rhs* (make-export-env/macros r)))
(build-exports global* init*))) (let ((invoke-body
(invoke-definitions (build-letrec* no-source lex* rhs*
(map build-global-define (map cdr global*)))) (build-exports global* init*)))
(values (invoke-definitions
imp* (rtc) (vtc) (map build-global-define (map cdr global*))))
(build-sequence no-source (values
(append invoke-definitions (itc) (rtc) (vtc)
(list invoke-body))) (build-sequence no-source
macro* export-subst export-env)))))))))))) (append invoke-definitions
(list invoke-body)))
macro* export-subst export-env))))))))))))))
(define core-library-expander (define core-library-expander
(lambda (e) (lambda (e)
@ -3053,7 +3106,7 @@
;;; An env record encapsulates a substitution and a set of ;;; An env record encapsulates a substitution and a set of
;;; libraries. ;;; libraries.
(define-record env (subst imp*) (define-record env (subst itc)
(lambda (x p) (lambda (x p)
(unless (env? x) (unless (env? x)
(error 'record-type-printer "not an environment")) (error 'record-type-printer "not an environment"))
@ -3067,8 +3120,10 @@
;;; eval and/or expand. ;;; eval and/or expand.
(define environment (define environment
(lambda imp* (lambda imp*
(let-values (((subst imp*) (parse-import-spec* imp*))) (let ([itc (make-collector)])
(make-env subst imp*)))) (parameterize ([imp-collector itc])
(let ((subst (parse-import-spec* imp*)))
(make-env subst itc))))))
;;; R6RS's null-environment and scheme-report-environment are ;;; R6RS's null-environment and scheme-report-environment are
;;; constructed simply using the corresponding libraries. ;;; constructed simply using the corresponding libraries.
@ -3092,11 +3147,13 @@
(let ((subst (env-subst env))) (let ((subst (env-subst env)))
(let ((rib (make-top-rib subst))) (let ((rib (make-top-rib subst)))
(let ((x (mkstx x top-mark* (list rib))) (let ((x (mkstx x top-mark* (list rib)))
(itc (env-itc env))
(rtc (make-collector)) (rtc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
(let ((x (let ((x
(parameterize ((inv-collector rtc) (parameterize ((inv-collector rtc)
(vis-collector vtc)) (vis-collector vtc)
(imp-collector itc))
(chi-expr x '() '())))) (chi-expr x '() '()))))
(seal-rib! rib) (seal-rib! rib)
(values x (rtc)))))))) (values x (rtc))))))))
@ -3133,7 +3190,7 @@
(core-library-expander x))) (core-library-expander x)))
(let ((id (gensym)) (let ((id (gensym))
(name name) (name name)
(ver ver) ;;; FIXME (ver ver)
(imp* (map library-spec imp*)) (imp* (map library-spec imp*))
(vis* (map library-spec vis*)) (vis* (map library-spec vis*))
(inv* (map library-spec inv*))) (inv* (map library-spec inv*)))
@ -3309,10 +3366,12 @@
(loc (set-symbol-value! loc (eval-core (expanded->core expr)))) (loc (set-symbol-value! loc (eval-core (expanded->core expr))))
(else (eval-core (expanded->core expr)))))) (else (eval-core (expanded->core expr))))))
(let ((rtc (make-collector)) (let ((rtc (make-collector))
(itc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
(let ((init* (let ((init*
(parameterize ((inv-collector rtc) (parameterize ((inv-collector rtc)
(vis-collector vtc) (vis-collector vtc)
(imp-collector itc)
(interaction-library (interaction-library
(find-library-by-name '(ikarus interaction)))) (find-library-by-name '(ikarus interaction))))
(chi-top* (list (mkstx x top-mark* '())) '())))) (chi-top* (list (mkstx x top-mark* '())) '()))))