From: Chris Hanson Date: Fri, 1 Apr 2005 04:47:16 +0000 (+0000) Subject: Continued changes to pass environment to READ and WRITE where X-Git-Tag: 20090517-FFI~1336 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=623219318376eada5dbdd123584414d5559438c7;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/runtime/dbgutl.scm b/v7/src/runtime/dbgutl.scm index 6971d997c..064ded03e 100644 --- a/v7/src/runtime/dbgutl.scm +++ b/v7/src/runtime/dbgutl.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: dbgutl.scm,v 14.24 2003/07/31 02:32:02 cph Exp $ +$Id: dbgutl.scm,v 14.25 2005/04/01 04:46:30 cph Exp $ Copyright 1988,1989,1990,1991,1992,2001 Massachusetts Institute of Technology -Copyright 2002,2003 Massachusetts Institute of Technology +Copyright 2002,2003,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -69,7 +69,8 @@ USA. (define (debug/read-eval-print-1 environment port) (let ((value - (debug/eval (prompt-for-expression "Evaluate expression" port) + (debug/eval (prompt-for-expression "Evaluate expression" + port environment) environment))) (if (undefined-value? value) (debugger-message port "No value") diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index f11820332..188083bec 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: debug.scm,v 14.45 2003/02/14 18:28:32 cph Exp $ +$Id: debug.scm,v 14.46 2005/04/01 04:46:36 cph Exp $ -Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1999,2001,2002,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -752,7 +753,8 @@ USA. (if invalid-expression? "" " ($ to retry)")) - port))) + port + environment))) (if (and (not invalid-expression?) (eq? expression '$)) (debug/scode-eval (dstate/expression dstate) diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index d2bd70f5f..319b67d0e 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: emacs.scm,v 14.39 2004/10/01 04:39:32 cph Exp $ +$Id: emacs.scm,v 14.40 2005/04/01 04:46:43 cph Exp $ Copyright 1986,1987,1991,1993,1994,1999 Massachusetts Institute of Technology -Copyright 2001,2003,2004 Massachusetts Institute of Technology +Copyright 2001,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -31,10 +31,10 @@ USA. ;;;; Prompting -(define (emacs/prompt-for-command-expression port prompt level) +(define (emacs/prompt-for-command-expression port environment prompt level) (transmit-modeline-string port prompt level) (transmit-signal port #\R) - (read port)) + (read port environment)) (define (emacs/prompt-for-command-char port prompt level) (transmit-modeline-string port prompt level) @@ -60,9 +60,9 @@ USA. '(("debug> " "[Debug]") ("where> " "[Where]"))) -(define (emacs/prompt-for-expression port prompt) +(define (emacs/prompt-for-expression port environment prompt) (transmit-signal-with-argument port #\i prompt) - (read port)) + (read port environment)) (define (emacs/prompt-for-confirmation port prompt) (transmit-signal-with-argument @@ -107,8 +107,7 @@ USA. "(set-window-start (selected-window) xscheme-temp-1 nil)")) (thunk))) -(define emacs-presentation-top-justify? - #f) +(define emacs-presentation-top-justify? #f) ;;;; Interrupt Support @@ -121,10 +120,10 @@ USA. (define (emacs/^G-interrupt) (transmit-signal the-console-port #\g)) - + ;;;; Miscellaneous Hooks -(define (emacs/write-result port expression object hash-number) +(define (emacs/write-result port expression object hash-number environment) expression (cond ((undefined-value? object) (transmit-signal-with-argument port #\v "")) @@ -139,7 +138,11 @@ USA. (number->string hash-number) ": %s\" xscheme-prompt))")) (else - (transmit-signal-with-argument port #\v (write-to-string object))))) + (transmit-signal-with-argument + port #\v + (call-with-output-string + (lambda (port) + (write object port environment))))))) (define (emacs/error-decision repl condition) condition @@ -151,8 +154,7 @@ USA. (if paranoid-error-decision? (cmdl-interrupt/abort-previous)))))) -(define paranoid-error-decision? - #f) +(define paranoid-error-decision? #f) (define (emacs/set-default-directory port pathname) (transmit-signal-with-argument port #\w (->namestring pathname))) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index eb5e659c1..9e928577e 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.70 2005/03/30 03:50:09 cph Exp $ +$Id: load.scm,v 14.71 2005/04/01 04:46:49 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology @@ -223,9 +223,7 @@ USA. (if load-noisily? (write-stream (value-stream) (lambda (exp&value) - (hook/repl-write (nearest-repl) - (car exp&value) - (cdr exp&value)))) + (repl-write (cdr exp&value) (car exp&value)))) (loading-message load/suppress-loading-message? pathname (lambda () (write-stream (value-stream) @@ -357,14 +355,9 @@ USA. (define (eval-stream stream environment) (stream-map stream - (let ((repl (nearest-repl))) - (let* ((environment - (if (default-object? environment) - (repl/environment repl) - environment))) - (lambda (s-expression) - (cons s-expression - (hook/repl-eval #f s-expression environment))))))) + (lambda (s-expression) + (cons s-expression + (repl-eval s-expression environment))))) (define (write-stream stream write) (if (stream-pair? stream) @@ -554,14 +547,16 @@ USA. (lambda (arg) (run-in-nearest-repl (lambda (repl) - repl - (load arg))))) + (load arg (repl/environment repl)))))) (argument-command-line-parser "eval" #t (lambda (arg) (run-in-nearest-repl (lambda (repl) - (let ((sexp (with-input-from-string arg read))) - (repl-write repl sexp (repl-eval repl sexp)))))))) + (let ((environment (repl/environment repl))) + (repl-eval/write (read (open-input-string arg) + environment) + environment + repl))))))) ;;;; Loader for packed binaries diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 31ca8158b..e8e6d18eb 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.63 2005/03/29 05:04:00 cph Exp $ +$Id: rep.scm,v 14.64 2005/04/01 04:46:57 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1998,1999,2001 Massachusetts Institute of Technology @@ -422,7 +422,7 @@ USA. (if (default-object? condition) #f condition) (if (default-object? operations) '() operations) (if (default-object? prompt) 'INHERIT prompt)))) - + (define (repl-driver repl) (let ((condition (repl/condition repl))) (if (and condition (condition/error? condition)) @@ -431,39 +431,49 @@ USA. (operation repl condition))) (hook/error-decision (hook/error-decision repl condition))))) - (port/set-default-environment (cmdl/port repl) (repl/environment repl)) - (let ((queue (repl/input-queue repl))) - (do () (#f) - (if (queue-empty? queue) - (let ((s-expression (repl-read repl))) - (repl-write repl s-expression (repl-eval repl s-expression))) - ((dequeue! queue) repl))))) + (let ((environment (repl/environment repl))) + (port/set-default-environment (cmdl/port repl) environment) + (let ((queue (repl/input-queue repl))) + (do () (#f) + (if (queue-empty? queue) + (%repl-eval/write (hook/repl-read environment repl) + environment + repl) + ((dequeue! queue) repl)))))) (define (run-in-nearest-repl procedure) (guarantee-procedure-of-arity procedure 1 'run-in-nearest-repl) (enqueue! (repl/input-queue (nearest-repl)) procedure)) - -(define (repl-read repl) - (guarantee-repl repl 'repl-read) - (hook/repl-read repl)) + +(define (repl-read #!optional environment repl) + (receive (environment repl) (optional-er environment repl 'REPL-READ) + (hook/repl-read environment repl))) (define hook/repl-read) -(define (default/repl-read repl) +(define (default/repl-read environment repl) (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl)) - (cmdl/port repl))) + (cmdl/port repl) + environment)) + +(define (repl-eval s-expression #!optional environment repl) + (receive (environment repl) (optional-er environment repl 'REPL-EVAL) + (%repl-eval s-expression environment repl))) -(define (repl-eval repl s-expression) - (guarantee-repl repl 'repl-eval) +(define (%repl-eval s-expression environment repl) (repl-history/record! (repl/reader-history repl) s-expression) - (let ((value (hook/repl-eval repl s-expression (repl/environment repl)))) + (let ((value (hook/repl-eval s-expression environment repl))) (repl-history/record! (repl/printer-history repl) value) value)) (define hook/repl-eval) -(define (default/repl-eval repl s-expression environment) - (repl-scode-eval repl (syntax s-expression environment) environment)) +(define (default/repl-eval s-expression environment repl) + (%repl-scode-eval (syntax s-expression environment) environment repl)) + +(define (repl-scode-eval scode #!optional environment repl) + (receive (environment repl) (optional-er environment repl 'REPL-SCODE-EVAL) + (%repl-scode-eval scode environment repl))) -(define (repl-scode-eval repl scode environment) +(define (%repl-scode-eval scode environment repl) (with-repl-eval-boundary repl (lambda () (extended-scode-eval scode environment)))) @@ -474,12 +484,12 @@ USA. with-repl-eval-boundary repl)) -(define (repl-write repl s-expression value) - (guarantee-repl repl 'repl-write) - (hook/repl-write repl s-expression value)) +(define (repl-write value s-expression #!optional environment repl) + (receive (environment repl) (optional-er environment repl 'REPL-WRITE) + (hook/repl-write value s-expression environment repl))) (define hook/repl-write) -(define (default/repl-write repl s-expression object) +(define (default/repl-write object s-expression environment repl) (port/write-result (cmdl/port repl) s-expression object @@ -487,7 +497,32 @@ USA. (object-pointer? object) (not (interned-symbol? object)) (not (number? object)) - (object-hash object)))) + (object-hash object)) + environment)) + +(define (repl-eval/write s-expression #!optional environment repl) + (receive (environment repl) (optional-er environment repl 'REPL-EVAL/WRITE) + (%repl-eval/write s-expression environment repl))) + +(define (%repl-eval/write s-expression environment repl) + (hook/repl-write (%repl-eval s-expression environment repl) + s-expression + environment + repl)) + +(define (optional-er environment repl caller) + (let ((repl + (if (default-object? repl) + (nearest-repl) + (begin + (guarantee-repl repl caller) + repl)))) + (values (if (default-object? environment) + (repl/environment repl) + (begin + (guarantee-environment environment caller) + environment)) + repl))) (define (repl/start repl #!optional message) (cmdl/start repl @@ -766,10 +801,8 @@ USA. (package/environment package)))))) (define (re #!optional index) - (let ((repl (nearest-repl))) - (repl-eval repl - (repl-history/read (repl/reader-history repl) - (if (default-object? index) 1 index))))) + (repl-eval (repl-history/read (repl/reader-history (nearest-repl)) + (if (default-object? index) 1 index)))) (define (in #!optional index) (repl-history/read (repl/reader-history (nearest-repl)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 25a911612..f2ca5ca7a 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.536 2005/03/30 03:51:02 cph Exp $ +$Id: runtime.pkg,v 14.537 2005/04/01 04:47:06 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -2883,6 +2883,7 @@ USA. re read-eval-print repl-eval + repl-eval/write repl-history/read repl-history/record! repl-history/size diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm index 5a592d7c1..47e0eb28a 100644 --- a/v7/src/runtime/usrint.scm +++ b/v7/src/runtime/usrint.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: usrint.scm,v 1.20 2003/03/21 17:51:23 cph Exp $ +$Id: usrint.scm,v 1.21 2005/04/01 04:47:12 cph Exp $ Copyright 1991,1992,1993,1994,1995,2001 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -31,81 +31,63 @@ USA. ;;;; Prompting -(define (canonicalize-prompt prompt suffix) - (if (let ((length (string-length prompt))) - (and (not (fix:= length 0)) - (char=? (string-ref prompt (fix:- length 1)) #\space))) - prompt - (string-append prompt suffix))) - -(define (canonicalize-command-prompt prompt) - (cond ((string? prompt) - prompt) - ((and (pair? prompt) - (eq? 'STANDARD (car prompt)) - (string? (cdr prompt))) - (cons (car prompt) (canonicalize-prompt (cdr prompt) " "))) - (else - (error:wrong-type-datum prompt "a string or standard prompt")))) - -(define (write-command-prompt port prompt level) - (if (not (nearest-cmdl/batch-mode?)) - (port/with-output-terminal-mode port 'COOKED - (lambda () - (fresh-line port) - (newline port) - (if (and (pair? prompt) - (eq? 'STANDARD (car prompt))) - (begin - (write level port) - (write-string " " port) - (write-string (cdr prompt) port)) - (write-string prompt port)) - (flush-output port))))) - -(define (prompt-for-command-expression prompt #!optional port) +(define (prompt-for-command-expression prompt #!optional port environment) (let ((prompt (canonicalize-command-prompt prompt)) - (port (if (default-object? port) (interaction-i/o-port) port)) + (port (optional-port port 'PROMPT-FOR-COMMAND-EXPRESSION)) + (environment + (optional-environment environment 'PROMPT-FOR-COMMAND-EXPRESSION)) (level (nearest-cmdl/level))) (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-EXPRESSION))) (if operation - (operation port prompt level) - (default/prompt-for-command-expression port prompt level))))) + (operation port environment prompt level) + (begin + (write-command-prompt port prompt level) + (port/with-input-terminal-mode port 'COOKED + (lambda () + (read port environment)))))))) -(define (default/prompt-for-command-expression port prompt level) - (write-command-prompt port prompt level) - (port/with-input-terminal-mode port 'COOKED - (lambda () - (read port)))) +(define (prompt-for-expression prompt #!optional port environment) + (%prompt-for-expression + (optional-port port 'PROMPT-FOR-EXPRESSION) + (optional-environment environment 'PROMPT-FOR-EXPRESSION) + prompt)) -(define (prompt-for-expression prompt #!optional port) - (let ((prompt (canonicalize-prompt prompt ": ")) - (port (if (default-object? port) (interaction-i/o-port) port))) +(define (prompt-for-evaluated-expression prompt #!optional environment port) + (let ((environment + (optional-environment environment 'PROMPT-FOR-EVALUATED-EXPRESSION)) + (port (optional-port port 'PROMPT-FOR-EVALUATED-EXPRESSION))) + (repl-eval (%prompt-for-expression port environment prompt) + environment))) + +(define (%prompt-for-expression port environment prompt) + (let ((prompt (canonicalize-prompt prompt ": "))) (let ((operation (port/operation port 'PROMPT-FOR-EXPRESSION))) (if operation - (operation port prompt) - (default/prompt-for-expression port prompt))))) - -(define (default/prompt-for-expression port prompt) - (port/with-output-terminal-mode port 'COOKED - (lambda () - (fresh-line port) - (newline port) - (write-string prompt port) - (flush-output port))) - (port/with-input-terminal-mode port 'COOKED - (lambda () - (read port)))) - -(define (prompt-for-evaluated-expression prompt #!optional environment port) - (hook/repl-eval #f - (prompt-for-expression prompt - (if (default-object? port) - (interaction-i/o-port) - port)) - (if (default-object? environment) - (nearest-repl/environment) - environment))) + (operation port environment prompt) + (begin + (port/with-output-terminal-mode port 'COOKED + (lambda () + (fresh-line port) + (newline port) + (write-string prompt port) + (flush-output port))) + (port/with-input-terminal-mode port 'COOKED + (lambda () + (read port environment)))))))) + +(define (optional-port port caller) + (if (default-object? port) + (interaction-i/o-port) + (begin + (guarantee-i/o-port port caller) + port))) + +(define (optional-environment environment caller) + (if (default-object? environment) + (nearest-repl/environment) + (begin + (guarantee-environment environment caller) + environment))) (define (prompt-for-command-char prompt #!optional port) (let ((prompt (canonicalize-command-prompt prompt)) @@ -177,6 +159,38 @@ USA. (flush-output port))) (loop)))))) +(define (canonicalize-prompt prompt suffix) + (if (let ((length (string-length prompt))) + (and (not (fix:= length 0)) + (char=? (string-ref prompt (fix:- length 1)) #\space))) + prompt + (string-append prompt suffix))) + +(define (canonicalize-command-prompt prompt) + (cond ((string? prompt) + prompt) + ((and (pair? prompt) + (eq? 'STANDARD (car prompt)) + (string? (cdr prompt))) + (cons (car prompt) (canonicalize-prompt (cdr prompt) " "))) + (else + (error:wrong-type-datum prompt "a string or standard prompt")))) + +(define (write-command-prompt port prompt level) + (if (not (nearest-cmdl/batch-mode?)) + (port/with-output-terminal-mode port 'COOKED + (lambda () + (fresh-line port) + (newline port) + (if (and (pair? prompt) + (eq? 'STANDARD (car prompt))) + (begin + (write level port) + (write-string " " port) + (write-string (cdr prompt) port)) + (write-string prompt port)) + (flush-output port))))) + ;;;; Debugger Support (define (port/debugger-failure port message) @@ -211,13 +225,20 @@ USA. ;;;; Miscellaneous Hooks -(define (port/write-result port expression value hash-number) - (let ((operation (port/operation port 'WRITE-RESULT))) +(define (port/write-result port expression value hash-number + #!optional environment) + (let ((operation (port/operation port 'WRITE-RESULT)) + (environment + (if (default-object? environment) + (nearest-repl/environment) + (begin + (guarantee-environment environment 'PORT/WRITE-RESULT) + environment)))) (if operation - (operation port expression value hash-number) - (default/write-result port expression value hash-number)))) + (operation port expression value hash-number environment) + (default/write-result port expression value hash-number environment)))) -(define (default/write-result port expression object hash-number) +(define (default/write-result port expression object hash-number environment) expression (if (not (nearest-cmdl/batch-mode?)) (port/with-output-terminal-mode port 'COOKED @@ -232,9 +253,9 @@ USA. (if hash-number (begin (write-string " " port) - (write hash-number port))) + (write hash-number port environment))) (write-string ": " port) - (write object port))))))) + (write object port environment))))))) (define write-result:undefined-value-is-special? true) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index b4e0eb4b7..10432f21e 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: where.scm,v 14.13 2003/02/14 18:28:34 cph Exp $ +$Id: where.scm,v 14.14 2005/04/01 04:47:16 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -41,7 +42,7 @@ USA. command-set (cmdl-message/active (lambda (port) - (show-current-frame wstate true port) + (show-current-frame wstate #t port) (debugger-message port "You are now in the environment inspector. Type q to quit, ? for commands."))) @@ -83,7 +84,7 @@ USA. (define command-set) (define (show wstate port) - (show-current-frame wstate false port)) + (show-current-frame wstate #f port)) (define (show-current-frame wstate brief? port) (debugger-presentation port @@ -99,31 +100,35 @@ USA. (define (parent wstate port) (let ((frame-list (wstate/frame-list wstate))) - (if (eq? true (environment-has-parent? (car frame-list))) + (if (eq? #t (environment-has-parent? (car frame-list))) (begin (set-wstate/frame-list! wstate (cons (environment-parent (car frame-list)) frame-list)) - (show-current-frame wstate true port)) + (show-current-frame wstate #t port)) (debugger-failure port "The current frame has no parent")))) (define (son wstate port) (let ((frames (wstate/frame-list wstate))) - (if (null? (cdr frames)) - (debugger-failure - port - "This is the original frame; its children cannot be found") + (if (pair? (cdr frames)) (begin (set-wstate/frame-list! wstate (cdr frames)) - (show-current-frame wstate true port))))) + (show-current-frame wstate #t port)) + (debugger-failure + port + "This is the original frame; its children cannot be found")))) (define (command/print-environment-procedure wstate port) (show-environment-procedure (car (wstate/frame-list wstate)) port)) (define (recursive-where wstate port) - (let ((inp (prompt-for-expression "Object to evaluate and examine" port))) - (debugger-message port "New where!") - (debug/where (debug/eval inp (car (wstate/frame-list wstate)))))) + (let ((environment (car (wstate/frame-list wstate)))) + (let ((inp + (prompt-for-expression "Object to evaluate and examine" + port + environment))) + (debugger-message port "New where!") + (debug/where (debug/eval inp environment))))) (define (enter wstate port) port