diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index 7c2dadc..6f73f50 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.cafe.ss b/scheme/ikarus.cafe.ss index 46de0b4..0f72f4a 100644 --- a/scheme/ikarus.cafe.ss +++ b/scheme/ikarus.cafe.ss @@ -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 diff --git a/scheme/ikarus.load.ss b/scheme/ikarus.load.ss index ee67887..bfef0f5 100644 --- a/scheme/ikarus.load.ss +++ b/scheme/ikarus.load.ss @@ -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)]) diff --git a/scheme/last-revision b/scheme/last-revision index 2794bbe..07c2bc8 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1458 +1459 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index b16fa80..eeda3cd 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 01b5d19..6b0294f 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -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 "#" p))) + + (define-record interaction-env (rib r locs) + (lambda (x p) (display "#" 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)) diff --git a/scheme/psyntax.library-manager.ss b/scheme/psyntax.library-manager.ss index 8a45704..78a59f1 100644 --- a/scheme/psyntax.library-manager.ss +++ b/scheme/psyntax.library-manager.ss @@ -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))