From 50f69a14d6200a6445749eb08b0bd944fa7f52eb Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 7 Jan 2008 14:31:04 +0000
Subject: [PATCH] Modify handling of EVALUATE-IN-INFERIOR-REPL and RUN-LIGHT so
that they adapt when SCHEME-ENVIRONMENT is set to a procedure.
---
v7/src/edwin/evlcom.scm | 65 ++++++++++++++++++++++++++++-------------
v7/src/edwin/intmod.scm | 29 +++++++++---------
2 files changed, 58 insertions(+), 36 deletions(-)
diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm
index 32277b168..542aab8cc 100644
--- 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."))))
(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 306c45af1..d38fc8af5 100644
--- 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)
(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)))))
(define (error-decision repl condition)
(let ((port (cmdl/port repl)))
--
2.25.1