From da428c008b353b10ae96cf3aa12a5d6071716f61 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 1 Apr 2005 05:09:26 +0000
Subject: [PATCH] Continued changes to pass environment to READ and WRITE where
possible. Change interfaces of
REPL-READ
REPL-EVAL
REPL-WRITE
PROMPT-FOR-EXPRESSION
PROMPT-FOR-COMMAND-EXPRESSION
WRITE-RESULT
and their associated hooks/methods so that environment is passed
consistently, with more-or-less regular argument structures.
Implement new procedure REPL-EVAL/WRITE that combines REPL-EVAL and
REPL-WRITE, since that's a common combination.
---
v7/src/6001/6001.pkg | 7 ++--
v7/src/6001/nodefs.scm | 9 +++--
v7/src/edwin/artdebug.scm | 17 +++++----
v7/src/edwin/debug.scm | 31 +++++++--------
v7/src/edwin/edwin.pkg | 8 ++--
v7/src/edwin/evlcom.scm | 79 ++++++++++++++++++++++++---------------
v7/src/edwin/intmod.scm | 20 ++++++----
v7/src/edwin/prompt.scm | 24 ++++++------
8 files changed, 108 insertions(+), 87 deletions(-)
diff --git a/v7/src/6001/6001.pkg b/v7/src/6001/6001.pkg
index f5b00c166..b3027f2ee 100644
--- a/v7/src/6001/6001.pkg
+++ b/v7/src/6001/6001.pkg
@@ -1,8 +1,9 @@
#| -*-Scheme-*-
-$Id: 6001.pkg,v 1.16 2003/02/14 18:28:00 cph Exp $
+$Id: 6001.pkg,v 1.17 2005/04/01 05:09:21 cph Exp $
-Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1994,1995,2001 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -34,8 +35,6 @@ USA.
(define-package (student scode-rewriting)
(files "nodefs")
(parent (student))
- (import (runtime rep)
- hook/repl-eval)
(initialization (initialize-package!)))
(define-package (student number)
diff --git a/v7/src/6001/nodefs.scm b/v7/src/6001/nodefs.scm
index afc09aeb1..f0b518b48 100644
--- a/v7/src/6001/nodefs.scm
+++ b/v7/src/6001/nodefs.scm
@@ -1,8 +1,9 @@
#| -*-Scheme-*-
-$Id: nodefs.scm,v 1.15 2003/02/14 18:28:00 cph Exp $
+$Id: nodefs.scm,v 1.16 2005/04/01 05:09:26 cph Exp $
Copyright 1991,1992,1993,1995,2001,2003 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -32,9 +33,8 @@ USA.
(set! hook/repl-eval student/repl-eval)
unspecific)
-(define (student/repl-eval repl s-expression environment)
+(define (student/repl-eval s-expression environment repl)
(repl-scode-eval
- repl
(rewrite-scode (syntax s-expression environment)
(and repl
(let ((port (cmdl/port repl)))
@@ -44,7 +44,8 @@ USA.
'CURRENT-EXPRESSION-CONTEXT)))
(and operation
(operation port s-expression))))))
- environment))
+ environment
+ repl))
(define (rewrite-scode expression context)
(let ((expression
diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm
index 4f902fa01..e36da9dd5 100644
--- a/v7/src/edwin/artdebug.scm
+++ b/v7/src/edwin/artdebug.scm
@@ -1,9 +1,9 @@
#| -*-Scheme-*-
-$Id: artdebug.scm,v 1.34 2004/02/16 05:42:42 cph Exp $
+$Id: artdebug.scm,v 1.35 2005/04/01 05:06:51 cph Exp $
Copyright 1989,1990,1991,1992,1993,1998 Massachusetts Institute of Technology
-Copyright 1999,2001,2003,2004 Massachusetts Institute of Technology
+Copyright 1999,2001,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -515,11 +515,11 @@ The evaluation occurs in the dynamic state of the current frame."
(let ((environment (dstate-evaluation-environment dstate))
(continuation
(stack-frame->continuation (dstate/subproblem dstate)))
- (repl-eval hook/repl-eval))
+ (old-hook hook/repl-eval))
(fluid-let
((in-debugger-evaluation? #t)
(hook/repl-eval
- (lambda (expression environment)
+ (lambda (expression environment repl)
(let ((unique (cons 'unique 'id)))
(let ((result
(call-with-current-continuation
@@ -532,8 +532,9 @@ The evaluation occurs in the dynamic state of the current frame."
(continuation* (cons unique condition)))
(lambda ()
(continuation*
- (repl-eval expression
- environment))))))))))
+ (old-hook expression
+ environment
+ repl))))))))))
(if (and (pair? result)
(eq? unique (car result)))
(error (cdr result))
@@ -1332,8 +1333,8 @@ Prefix argument means do not kill the debugger buffer."
(newline port)
(newline port))
-(define (operation/prompt-for-expression port prompt)
- port
+(define (operation/prompt-for-expression port environment prompt)
+ port environment
(prompt-for-expression prompt))
(define (operation/prompt-for-confirmation port prompt)
diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm
index 73b8cca30..0b849c444 100644
--- a/v7/src/edwin/debug.scm
+++ b/v7/src/edwin/debug.scm
@@ -1,10 +1,10 @@
#| -*-Scheme-*-
-$Id: debug.scm,v 1.68 2004/12/06 21:26:13 cph Exp $
+$Id: debug.scm,v 1.69 2005/04/01 05:06:57 cph Exp $
Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology
Copyright 1998,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -443,23 +443,18 @@ USA.
(fluid-let ((prompt-for-confirmation
(lambda (prompt #!optional port)
port
- (call-with-interface-port
- (buffer-end buffer)
- (lambda (port)
- port
- (prompt-for-yes-or-no? prompt)))))
+ (call-with-interface-port (buffer-end buffer)
+ (lambda (port)
+ port
+ (prompt-for-yes-or-no? prompt)))))
(prompt-for-evaluated-expression
(lambda (prompt #!optional environment port)
port
- (call-with-interface-port
- (buffer-end buffer)
- (lambda (port)
- port
- (hook/repl-eval #f
- (prompt-for-expression prompt)
- (if (default-object? environment)
- (nearest-repl/environment)
- environment))))))
+ (call-with-interface-port (buffer-end buffer)
+ (lambda (port)
+ port
+ (repl-eval (prompt-for-expression prompt)
+ environment)))))
(hook/invoke-restart
(lambda (continuation arguments)
(invoke-continuation continuation
@@ -494,7 +489,9 @@ USA.
(PROMPT-FOR-CONFIRMATION
,(lambda (port prompt) port (prompt-for-confirmation? prompt)))
(PROMPT-FOR-EXPRESSION
- ,(lambda (port prompt) port (prompt-for-expression prompt))))
+ ,(lambda (port environment prompt)
+ port environment
+ (prompt-for-expression prompt))))
#f))
(define (invoke-continuation continuation arguments avoid-deletion?)
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 253d3b450..b7517f7ab 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,10 +1,10 @@
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.288 2004/03/30 04:27:52 cph Exp $
+$Id: edwin.pkg,v 1.289 2005/04/01 05:07:03 cph Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
-Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -102,8 +102,6 @@ USA.
)
(parent ())
- (import (runtime rep)
- hook/repl-eval)
(import (runtime character)
bucky-bits->prefix)
(import (runtime char-syntax)
@@ -533,6 +531,8 @@ USA.
(files "bufinp")
(parent (edwin))
(export (edwin)
+ call-with-input-mark
+ call-with-input-region
make-buffer-input-port
with-input-from-mark
with-input-from-region)
diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm
index 321ff2106..daeee4d47 100644
--- a/v7/src/edwin/evlcom.scm
+++ b/v7/src/edwin/evlcom.scm
@@ -1,10 +1,10 @@
#| -*-Scheme-*-
-$Id: evlcom.scm,v 1.69 2004/11/19 17:35:08 cph Exp $
+$Id: evlcom.scm,v 1.70 2005/04/01 05:07:07 cph Exp $
Copyright 1986,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -249,8 +249,14 @@ Has no effect if evaluate-in-inferior-repl is false."
;;;; Expression Prompts
-(define (prompt-for-expression-value prompt #!optional default . options)
- (let ((buffer (current-buffer)))
+(define (prompt-for-expression-value prompt #!optional default environment
+ . options)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment)
+ (begin
+ (guarantee-environment environment 'PROMPT-FOR-EXPRESSION-VALUE)
+ environment))))
(eval-with-history (apply prompt-for-expression
prompt
(if (or (symbol? default)
@@ -258,30 +264,37 @@ Has no effect if evaluate-in-inferior-repl is false."
(vector? default))
`',default
default)
+ environment
options)
- (evaluation-environment buffer))))
-
-(define (prompt-for-expression prompt #!optional default . options)
- (read-from-string
- (apply prompt-for-string
- prompt
- (if (default-object? default)
- #f
- (write-to-string default))
- 'MODE
- (let ((environment (ref-variable scheme-environment)))
+ environment)))
+
+(define (prompt-for-expression prompt #!optional default environment . options)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment)
+ (begin
+ (guarantee-environment environment 'PROMPT-FOR-EXPRESSION)
+ environment))))
+ (read-from-string
+ (apply prompt-for-string
+ prompt
+ (if (default-object? default)
+ #f
+ (write-to-string default))
+ 'MODE
(lambda (buffer)
(set-buffer-major-mode! buffer
(ref-mode-object prompt-for-expression))
;; This sets up the correct environment in the typein buffer
;; so that completion of variables works right.
- (local-set-variable! scheme-environment environment buffer)))
- options)))
+ (local-set-variable! scheme-environment environment buffer))
+ options)
+ environment)))
-(define (read-from-string string)
+(define (read-from-string string environment)
(bind-condition-handler (list condition-type:error) evaluation-error-handler
(lambda ()
- (with-input-from-string string read))))
+ (read (open-input-string string) environment))))
(define-major-mode prompt-for-expression scheme #f
(mode-description (ref-mode-object minibuffer-local))
@@ -299,7 +312,7 @@ Has no effect if evaluate-in-inferior-repl is false."
;;;; Evaluation
(define (evaluate-region region environment)
- (let ((buffer (mark-buffer (region-start region))))
+ (let ((buffer (->buffer region)))
(let ((evaluation-input-recorder
(ref-variable evaluation-input-recorder buffer)))
(if evaluation-input-recorder
@@ -314,24 +327,28 @@ Has no effect if evaluate-in-inferior-repl is false."
evaluation-error-handler
(lambda ()
(let loop
- ((expressions (read-expressions-from-region region))
+ ((expressions (read-expressions-from-region region environment))
(result unspecific))
(if (null? expressions)
result
(loop (cdr expressions)
(editor-eval buffer (car expressions) environment))))))))
-(define (read-expressions-from-region region)
- (with-input-from-region region
- (lambda ()
- (let loop ()
- (let ((expression (read)))
- (if (eof-object? expression)
- '()
- (cons expression (loop))))))))
+(define (read-expressions-from-region region #!optional environment)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment region)
+ environment)))
+ (call-with-input-region region
+ (lambda (port)
+ (let loop ()
+ (let ((expression (read port environment)))
+ (if (eof-object? expression)
+ '()
+ (cons expression (loop)))))))))
(define (evaluation-environment buffer #!optional global-ok?)
- (let ((buffer (or buffer (current-buffer)))
+ (let ((buffer (->buffer buffer))
(non-default
(lambda (object)
(if (environment? object)
@@ -416,7 +433,7 @@ Set by Scheme evaluation code to update the mode line."
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
- (hook/repl-eval #f expression environment))))
+ (repl-eval expression environment))))
(define (evaluation-error-handler condition)
(maybe-debug-scheme-error 'EVALUATION condition)
diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm
index 688c825dc..a0b788d35 100644
--- a/v7/src/edwin/intmod.scm
+++ b/v7/src/edwin/intmod.scm
@@ -1,9 +1,9 @@
#| -*-Scheme-*-
-$Id: intmod.scm,v 1.120 2004/02/16 05:43:38 cph Exp $
+$Id: intmod.scm,v 1.121 2005/04/01 05:07:13 cph Exp $
Copyright 1986,1989,1991,1992,1993,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -874,7 +874,7 @@ If this is an error, the debugger examines the error condition."
(and (not (null? windows))
(apply min (map window-x-size windows)))))))
-(define (operation/write-result port expression value hash-number)
+(define (operation/write-result port expression value hash-number environment)
(let ((buffer (port/buffer port))
(other-buffer?
(memq (operation/current-expression-context port expression)
@@ -885,7 +885,7 @@ If this is an error, the debugger examines the error condition."
(and (ref-variable enable-transcript-buffer buffer)
(transcript-buffer)))
(begin
- (default/write-result port expression value hash-number)
+ (default/write-result port expression value hash-number environment)
(if (and other-buffer? (not (mark-visible? (port/mark port))))
(transcript-write value #f))))))
@@ -1013,8 +1013,11 @@ If this is an error, the debugger examines the error condition."
;;; Prompting
-(define (operation/prompt-for-expression port prompt)
- (unsolicited-prompt port prompt-for-expression prompt))
+(define (operation/prompt-for-expression port environment prompt)
+ (unsolicited-prompt port
+ (lambda (prompt)
+ (prompt-for-expression prompt #!default environment))
+ prompt))
(define (operation/prompt-for-confirmation port prompt)
(unsolicited-prompt port prompt-for-confirmation? prompt))
@@ -1057,7 +1060,7 @@ If this is an error, the debugger examines the error condition."
(cond ((eq? value wait-value) (suspend-current-thread) (loop))
((eq? value abort-value) (abort->nearest))
(else value)))))))
-
+
(define (when-buffer-selected buffer thunk)
(if (current-buffer? buffer)
(thunk)
@@ -1068,7 +1071,8 @@ If this is an error, the debugger examines the error condition."
(remove-select-buffer-hook buffer hook))))))
(add-select-buffer-hook buffer hook))))
-(define (operation/prompt-for-command-expression port prompt level)
+(define (operation/prompt-for-command-expression port environment prompt level)
+ environment
(parse-command-prompt port prompt)
(read-expression port level))
diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm
index f2e8ca08f..9ccd801e6 100644
--- a/v7/src/edwin/prompt.scm
+++ b/v7/src/edwin/prompt.scm
@@ -1,8 +1,10 @@
#| -*-Scheme-*-
-$Id: prompt.scm,v 1.201 2003/02/14 18:28:13 cph Exp $
+$Id: prompt.scm,v 1.202 2005/04/01 05:07:18 cph Exp $
-Copyright 1986, 1989-2001 Massachusetts Institute of Technology
+Copyright 1987.1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
+Copyright 2000,2001,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -101,13 +103,12 @@ USA.
(define (typein-edit-other-window)
(let loop ((windows typein-saved-windows))
- (cond ((null? windows)
- (window0))
- ((and (not (typein-window? (car windows)))
- (window-visible? (car windows)))
- (car windows))
- (else
- (loop (cdr windows))))))
+ (if (pair? windows)
+ (if (and (not (typein-window? (car windows)))
+ (window-visible? (car windows)))
+ (car windows)
+ (loop (cdr windows)))
+ (window0))))
(define-variable enable-recursive-minibuffers
"True means allow minibuffers to invoke commands that use recursive minibuffers."
@@ -841,7 +842,7 @@ a repetition of this command will exit."
(lambda ()
(delete-string start end)
(set-current-point! point)))))
-
+
;;;; Character Prompts
(define (prompt-for-char prompt)
@@ -986,7 +987,8 @@ it is added to the front of the command history."
(prompt-for-string "Redo" #f
'DEFAULT-TYPE 'INSERTED-DEFAULT
'HISTORY 'REPEAT-COMPLEX-COMMAND
- 'HISTORY-INDEX (- argument 1))))))
+ 'HISTORY-INDEX (- argument 1))
+ (->environment '(EDWIN))))))
;;;; Pass-phrase Prompts
--
2.25.1