From: Chris Hanson Date: Fri, 1 Apr 2005 05:09:26 +0000 (+0000) Subject: Continued changes to pass environment to READ and WRITE where X-Git-Tag: 20090517-FFI~1335 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=da428c008b353b10ae96cf3aa12a5d6071716f61;p=mit-scheme.git 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. --- 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