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

Added (interaction-environment).

This commit is contained in:
Abdulaziz Ghuloum 2008-05-01 06:02:36 -04:00
parent e7386cd7d7
commit d49aed209a
7 changed files with 84 additions and 85 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.

3
scheme/ikarus.cafe.ss
View File

@ -41,7 +41,6 @@ description:
(export new-cafe)
(import
(only (rnrs) with-exception-handler)
(only (psyntax expander) eval-top-level)
(except (ikarus) new-cafe))
(define eval-depth 0)
@ -105,7 +104,7 @@ description:
(define default-cafe-eval
(lambda (x)
(eval-top-level x)))
(eval x (interaction-environment))))
(define new-cafe
(case-lambda

5
scheme/ikarus.load.ss
View File

@ -21,7 +21,7 @@
(only (ikarus.compiler) compile-core-expr)
(only (psyntax library-manager)
serialize-all current-precompiled-library-loader)
(only (psyntax expander) eval-top-level compile-r6rs-top-level)
(only (psyntax expander) compile-r6rs-top-level)
(only (ikarus reader) read-initial))
@ -65,7 +65,8 @@
(define load-handler
(lambda (x)
(eval-top-level x)))
(eval x (interaction-environment))))
(define read-and-eval
(lambda (p eval-proc)
(let ([x (read p)])

2
scheme/last-revision
View File

@ -1 +1 @@
1458
1459

2
scheme/makefile.ss
View File

@ -1067,6 +1067,7 @@
[null-environment i r5 se]
[quotient i r5 se]
[scheme-report-environment i r5 se]
[interaction-environment i r5 se]
[close-port i r ip]
[eol-style i r ip]
[error-handling-mode i r ip]
@ -1292,7 +1293,6 @@
[getenv i]
[nanosleep i]
[char-ready? ]
[interaction-environment ]
[load i]
[void i $boot]
[gensym i symbols $boot]

144
scheme/psyntax.expander.ss
View File

@ -24,8 +24,10 @@
bound-identifier=? datum->syntax syntax-error
syntax-violation
syntax->datum make-variable-transformer
compile-r6rs-top-level boot-library-expand eval-top-level
null-environment scheme-report-environment ellipsis-map)
compile-r6rs-top-level boot-library-expand
null-environment scheme-report-environment
interaction-environment
ellipsis-map)
(import
(except (rnrs)
environment environment? identifier?
@ -118,22 +120,24 @@
(define (gen-define-label+loc id rib)
(cond
[(top-level-context?)
(let ([label (gen-top-level-label id rib)])
(values label
(cond
[(assq label top-level-locations) => cdr]
[else
(let ([loc (gen-lexical id)])
(set! top-level-locations
(cons (cons label loc) top-level-locations))
loc)])))]
[(top-level-context) =>
(lambda (env)
(let ([label (gen-top-level-label id rib)]
[locs (interaction-env-locs env)])
(values label
(cond
[(assq label locs) => cdr]
[else
(let ([loc (gen-lexical id)])
(set-interaction-env-locs! env
(cons (cons label loc) locs))
loc)]))))]
[else (values (gensym) (gen-lexical id))]))
(define (gen-define-label id rib)
(cond
[(top-level-context?)
[(top-level-context)
(gen-top-level-label id rib)]
[else (gensym)]))
@ -176,7 +180,7 @@
(lambda (p)
(unless (eq? label (car p))
(cond
[(top-level-context?)
[(top-level-context)
;;; override label
(set-car! p label)]
[else
@ -583,12 +587,13 @@
(cond
((null? subst*)
(cond
[(top-level-context?)
;;; fabricate binding
(let ([rib (get-top-rib)])
(let-values ([(lab loc_) (gen-define-label+loc id rib)])
(extend-rib! rib id lab)
lab))]
[(top-level-context) =>
(lambda (env)
;;; fabricate binding
(let ([rib (interaction-env-rib env)])
(let-values ([(lab loc_) (gen-define-label+loc id rib)])
(extend-rib! rib id lab)
lab)))]
[else #f]))
((eq? (car subst*) 'shift)
;;; a shift is inserted when a mark is added.
@ -641,11 +646,13 @@
(cons '$rtd (symbol-value loc)))]
[else b])))
((assq x r) => cdr)
[(and
(top-level-context?)
(assq x top-level-locations)) =>
(lambda (p) ;;; fabricate
(cons* 'lexical (cdr p) #f))]
[(top-level-context) =>
(lambda (env)
(cond
[(assq x (interaction-env-locs env)) =>
(lambda (p) ;;; fabricate
(cons* 'lexical (cdr p) #f))]
[else '(displaced-lexical . #f)]))]
(else '(displaced-lexical . #f)))))
(define make-binding cons)
@ -3437,7 +3444,7 @@
(lambda (exp* imp* b* top?)
(define itc (make-collector))
(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)
(parse-import-spec* imp*)))
@ -3526,12 +3533,14 @@
;;; libraries.
(define-record env (names labels itc)
(lambda (x p)
(unless (env? x)
(assertion-violation 'record-type-printer "not an environment"))
(display "#<environment>" p)))
(define-record interaction-env (rib r locs)
(lambda (x p)
(display "#<environment>" p)))
(define environment?
(lambda (x) (env? x)))
(lambda (x) (or (env? x) (interaction-env? x))))
;;; This is R6RS's environment. It parses the import specs
;;; and constructs an env record that can be used later by
@ -3561,32 +3570,48 @@
;;; libraries that must be invoked before evaluating the core expr.
(define expand
(lambda (x env)
(unless (env? env)
(assertion-violation 'expand "not an environment" env))
(let ((rib (make-top-rib (env-names env) (env-labels env))))
(let ((x (mkstx x top-mark* (list rib) '()))
(itc (env-itc env))
(rtc (make-collector))
(vtc (make-collector)))
(let ((x
(parameterize ((inv-collector rtc)
(vis-collector vtc)
(imp-collector itc))
(chi-expr x '() '()))))
(seal-rib! rib)
(values x (rtc)))))))
(cond
[(env? env)
(let ((rib (make-top-rib (env-names env) (env-labels env))))
(let ((x (mkstx x top-mark* (list rib) '()))
(itc (env-itc env))
(rtc (make-collector))
(vtc (make-collector)))
(let ((x
(parameterize ((inv-collector rtc)
(vis-collector vtc)
(imp-collector itc))
(chi-expr x '() '()))))
(seal-rib! rib)
(values x (rtc)))))]
[(interaction-env? env)
(let ([rib (interaction-env-rib env)]
[r (interaction-env-r env)]
[rtc (make-collector)])
(let ([x (make-stx x top-mark* (list rib) '())])
(let-values ([(e r^)
(parameterize ([top-level-context env]
[inv-collector rtc]
[vis-collector (make-collector)]
[imp-collector (make-collector)])
(chi-interaction-expr x rib r))])
(set-interaction-env-r! env r^)
(values e (rtc)))))]
[else
(assertion-violation 'expand "not an environment" env)])))
;;; This is R6RS's eval. It takes an expression and an environment,
;;; expands the expression, invokes its invoke-required libraries and
;;; evaluates its expanded core form.
(define eval
(lambda (x env)
(unless (env? env)
(assertion-violation 'eval "not an environment" env))
(unless (environment? env)
(error 'eval "not an environment" env))
(let-values (((x invoke-req*) (expand x env)))
(for-each invoke-library invoke-req*)
(eval-core (expanded->core x)))))
;;; Given a (library . _) s-expression, library-expander expands
;;; it to core-form, registers it with the library manager, and
;;; returns its invoke-code, visit-code, subst and env.
@ -3838,10 +3863,10 @@
(for-each invoke-library lib*)
(eval-core (expanded->core invoke-code))))))
(define get-top-rib
(let ([top-rib #f])
(define interaction-environment
(let ([the-env #f])
(lambda ()
(or top-rib
(or the-env
(let ([lib (find-library-by-name '(ikarus))]
[rib (make-empty-rib)])
(let ([subst (library-subst lib)])
@ -3849,26 +3874,11 @@
(set-rib-mark**! rib
(map (lambda (x) top-mark*) subst))
(set-rib-label*! rib (map cdr subst)))
(set! top-rib rib)
rib)))))
(let ([env (make-interaction-env rib '() '())])
(set! the-env env)
env))))))
(define top-level-locations '())
(define top-level-context? (make-parameter #f))
(define eval-top-level
(let ([r '()])
(lambda (x)
(let ([rib (get-top-rib)] [rtc (make-collector)])
(let ([x (make-stx x top-mark* (list rib) '())])
(let-values ([(e r^)
(parameterize ([top-level-context? #t]
[inv-collector rtc]
[vis-collector (make-collector)]
[imp-collector (make-collector)])
(chi-interaction-expr x rib r))])
(set! r r^)
(for-each invoke-library (rtc))
(eval-core (expanded->core e))))))))
(define top-level-context (make-parameter #f))
;;; register the expander with the library manager
(current-library-expander library-expander))

13
scheme/psyntax.library-manager.ss
View File

@ -22,7 +22,7 @@
(export imported-label->binding library-subst installed-libraries
visit-library library-name library-version library-exists?
find-library-by-name install-library library-spec invoke-library
extend-library-subst! extend-library-env! current-library-expander
current-library-expander
current-library-collection library-path library-extensions
serialize-all current-precompiled-library-loader)
(import (rnrs) (psyntax compat) (rnrs r5rs)
@ -315,17 +315,6 @@
visit-code invoke-code visible? source-file-name)))
(install-library-record lib)))]))
(define extend-library-subst!
(lambda (lib sym label)
(set-library-subst! lib
(cons (cons sym label) (library-subst lib)))))
(define extend-library-env!
(lambda (lib label binding)
(set-library-env! lib
(cons (cons label binding) (library-env lib)))
(hashtable-set! label->binding-table label binding)))
(define (imported-label->binding lab)
(hashtable-ref label->binding-table lab #f))