Added (interaction-environment).

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

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)])

scheme/last-revision

@@ -1 +1 @@
-1458
+1459

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]

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
+          compile-r6rs-top-level boot-library-expand 
-          null-environment scheme-report-environment ellipsis-map)
+          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?)
+      [(top-level-context) =>
-       (let ([label (gen-top-level-label id rib)])
+       (lambda (env)
-         (values label
+         (let ([label (gen-top-level-label id rib)]
-           (cond
+               [locs (interaction-env-locs env)])
-             [(assq label top-level-locations) => cdr]
+           (values label
-             [else 
+             (cond
-              (let ([loc (gen-lexical id)])
+               [(assq label locs) => cdr]
-                (set! top-level-locations 
+               [else 
-                  (cons (cons label loc) top-level-locations))
+                (let ([loc (gen-lexical id)])
-                loc)])))]
+                  (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?) 
+               [(top-level-context) =>
-                ;;; fabricate binding
+                (lambda (env)
-                (let ([rib (get-top-rib)])
+                  ;;; fabricate binding
-                  (let-values ([(lab loc_) (gen-define-label+loc id rib)])
+                  (let ([rib (interaction-env-rib env)])
-                    (extend-rib! rib id lab)
+                    (let-values ([(lab loc_) (gen-define-label+loc id rib)])
-                    lab))]
+                      (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) =>
-           (top-level-context?)
+         (lambda (env)
-           (assq x top-level-locations)) =>
+           (cond
-         (lambda (p)  ;;; fabricate
+             [(assq x (interaction-env-locs env)) =>
-           (cons* 'lexical (cdr p) #f))]
+              (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)
+      (display "#<environment>" p)))
-        (assertion-violation 'record-type-printer "not an environment"))
+
+  (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)
+      (cond
-        (assertion-violation 'expand "not an environment" env))
+        [(env? env)
-      (let ((rib (make-top-rib (env-names env) (env-labels env))))
+         (let ((rib (make-top-rib (env-names env) (env-labels env))))
-        (let ((x (mkstx x top-mark* (list rib) '()))
+           (let ((x (mkstx x top-mark* (list rib) '()))
-              (itc (env-itc env))
+                 (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))
+                                     (imp-collector itc))
-                      (chi-expr x '() '()))))
+                         (chi-expr x '() '()))))
-              (seal-rib! rib)
+                 (seal-rib! rib)
-              (values x (rtc)))))))
+                 (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)
+      (unless (environment? env)
-        (assertion-violation 'eval "not an 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
+  (define interaction-environment
-    (let ([top-rib #f])
+    (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)
+              (let ([env (make-interaction-env rib '() '())])
-              rib)))))
+                (set! the-env env)
+                env))))))
 
-  (define top-level-locations '())
+  (define top-level-context (make-parameter #f))
-  (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))))))))
 
   ;;; register the expander with the library manager
   (current-library-expander library-expander))

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))