Modify handling of EVALUATE-IN-INFERIOR-REPL and RUN-LIGHT so that

they adapt when SCHEME-ENVIRONMENT is set to a procedure.

diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm
index 32277b16813068299589212c0e218dccdb5a3016..542aab8cc4b6bb16cf9065defcdd2340cd3183d3 100644 (file)
--- a/v7/src/edwin/evlcom.scm
+++ b/v7/src/edwin/evlcom.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: evlcom.scm,v 1.75 2007/10/09 04:43:49 cph Exp $
+$Id: evlcom.scm,v 1.76 2008/01/07 14:31:03 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -62,18 +62,44 @@ If 'DEFAULT, use the default (REP loop) environment."
     (if buffer (normal-buffer-evaluation-mode buffer))))
 
 (define (normal-buffer-evaluation-mode buffer)
-  (let ((environment (ref-variable-object scheme-environment))
-       (evaluate-inferior (ref-variable-object evaluate-in-inferior-repl))
+  (let ((env (ref-variable-object scheme-environment))
+       (inf-repl (ref-variable-object evaluate-in-inferior-repl))
        (run-light (ref-variable-object run-light)))
-    (if (and (not (repl-buffer? buffer))
-            (not (variable-local-value? buffer evaluate-inferior))
-            (and (variable-local-value? buffer environment)
-                 (not (eq? 'DEFAULT
-                           (variable-local-value buffer environment)))))
-       (begin
-         (define-variable-local-value! buffer evaluate-inferior #f)
-         (if (not (variable-local-value? buffer run-light))
-             (define-variable-local-value! buffer run-light #f))))))
+    (if (not (repl-buffer? buffer))
+       (let ((value
+              (if (variable-local-value? buffer env)
+                  (variable-local-value buffer env)
+                  'DEFAULT)))
+         (cond ((eq? 'DEFAULT value)
+                (undefine-variable-local-value! buffer inf-repl)
+                (undefine-variable-local-value! buffer run-light))
+               ((procedure? value)
+                (define-variable-local-value! buffer inf-repl
+                  (lambda (buffer) buffer (eq? 'DEFAULT (value 'DEFAULT))))
+                ;; Force run-light to be set:
+                (evaluate-in-inferior-repl? buffer))
+               (else
+                (define-variable-local-value! buffer inf-repl #f)
+                (define-variable-local-value! buffer run-light #f)))))))
+
+(define (evaluate-in-inferior-repl? buffer)
+  (if buffer
+      (let ((buffer (->buffer buffer))
+           (var (ref-variable-object evaluate-in-inferior-repl)))
+       (let ((value (variable-local-value buffer var)))
+         (if (procedure? value)
+             (let ((value (value buffer)))
+               (let ((run-light (ref-variable-object run-light)))
+                 (if value
+                     (undefine-variable-local-value! buffer run-light)
+                     (define-variable-local-value! buffer run-light #f)))
+               (invoke-variable-assignment-daemons! buffer var)
+               value)
+             value)))
+      (let ((value (ref-variable evaluate-in-inferior-repl #f)))
+       (if (procedure? value)
+           (value #f)
+           value))))
 
 (define-variable debug-on-evaluation-error
   "True means enter debugger if an evaluation error is signalled.
@@ -110,7 +136,7 @@ and the output, if non-null, is shown in a pop-up buffer."
 Also, the inferior REPL's run light appears in all Scheme mode buffers.
 Otherwise, expressions are evaluated directly by the commands."
   #t
-  boolean?)
+  (lambda (object) (or (boolean? object) (procedure-of-arity? object 1))))
 
 (define-variable transcript-buffer-name
   "Name of evaluation transcript buffer.
@@ -181,7 +207,7 @@ With an argument, prompts for the evaluation environment."
     (let ((buffer (mark-buffer (region-start region))))
       (cond ((ref-variable disable-evaluation-commands buffer)
             (editor-error "Evaluation commands disabled in this buffer."))
-           ((ref-variable evaluate-in-inferior-repl buffer)
+           ((evaluate-in-inferior-repl? buffer)
             (inferior-repl-eval-region (current-repl-buffer buffer) region))
            (else
             (evaluate-region region (evaluation-environment buffer #f)))))))
@@ -199,7 +225,7 @@ The values are printed in the typein window."
     (let ((buffer (current-buffer)))
       (cond ((ref-variable disable-evaluation-commands buffer)
             (editor-error "Evaluation commands disabled in this buffer."))
-           ((and (ref-variable evaluate-in-inferior-repl buffer)
+           ((and (evaluate-in-inferior-repl? buffer)
                  (current-repl-buffer* buffer))
             => (lambda (buffer)
                  (inferior-repl-eval-expression buffer expression)))
@@ -220,10 +246,9 @@ The values are printed in the typein window."
 Has no effect if evaluate-in-inferior-repl is false."
   ()
   (lambda ()
-    (let ((buffer (current-buffer)))
-      (if (ref-variable evaluate-in-inferior-repl buffer)
-         ((ref-command inferior-cmdl-abort-top-level))
-         (editor-error "Nothing to abort.")))))
+    (if (evaluate-in-inferior-repl? (current-buffer))
+       ((ref-command inferior-cmdl-abort-top-level))
+       (editor-error "Nothing to abort."))))
 \f
 (define-command set-environment
   "Make ENVIRONMENT the current evaluation environment."
@@ -354,7 +379,7 @@ Has no effect if evaluate-in-inferior-repl is false."
     (evaluation-environment-no-repl
      buffer
      (let ((repl-buffer
-           (and (ref-variable evaluate-in-inferior-repl buffer)
+           (and (evaluate-in-inferior-repl? buffer)
                 (current-repl-buffer* buffer))))
        (if (and repl-buffer
                (not (eq? repl-buffer buffer)))

diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm
index 306c45af1f15fa2626007490340f4c85bcc6db07..d38fc8af5532f4598084397f865bd625edb9b52f 100644 (file)
--- a/v7/src/edwin/intmod.scm
+++ b/v7/src/edwin/intmod.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: intmod.scm,v 1.127 2007/08/17 02:34:29 cph Exp $
+$Id: intmod.scm,v 1.128 2008/01/07 14:31:04 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -158,17 +158,13 @@ evaluated in the specified inferior REPL buffer."
   unspecific)
 \f
 (define (current-repl-buffer #!optional buffer)
-  (let ((buffer
-        (current-repl-buffer* (if (default-object? buffer) #f buffer))))
-    (if (not buffer)
+  (let ((repl-buffer (current-repl-buffer* buffer)))
+    (if (not repl-buffer)
        (error "No REPL to evaluate in."))
-    buffer))
+    repl-buffer))
 
 (define (current-repl-buffer* #!optional buffer)
-  (let ((buffer
-        (if (or (default-object? buffer) (not buffer))
-            (current-buffer)
-            buffer)))
+  (let ((buffer (->buffer buffer)))
     (if (repl-buffer? buffer)
        buffer
        (or (local-repl-buffer buffer)
@@ -202,7 +198,7 @@ evaluated in the specified inferior REPL buffer."
         (car buffers))))
 
 (define (repl-buffer-list)
-  (set! repl-buffers (list-transform-positive repl-buffers buffer-alive?))
+  (set! repl-buffers (filter! buffer-alive? repl-buffers))
   repl-buffers)
 
 (define (repl-buffer? buffer)
@@ -336,7 +332,7 @@ evaluated in the specified inferior REPL buffer."
              (buffer-list))))
 
 (define (global-run-light-buffer)
-  (and (variable-default-value (ref-variable-object evaluate-in-inferior-repl))
+  (and (evaluate-in-inferior-repl? #f)
        (global-repl-buffer)))
 
 (define (set-global-run-light! value)
@@ -352,12 +348,13 @@ evaluated in the specified inferior REPL buffer."
 
 (add-variable-assignment-daemon!
  (ref-variable-object evaluate-in-inferior-repl)
- (lambda (buffer variable)
-   buffer variable
+ (lambda (buffer variable) buffer variable (reset-run-light!)))
+
+(define (reset-run-light!)
+  (set-global-run-light!
    (let ((buffer (global-run-light-buffer)))
-     (if buffer
-        (set-global-run-light! (local-run-light buffer))
-        (set-global-run-light! #f)))))
+     (and buffer
+         (local-run-light buffer)))))
 \f
 (define (error-decision repl condition)
   (let ((port (cmdl/port repl)))