#| -*-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.
(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")
#| -*-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.
(if invalid-expression?
""
" ($ to retry)"))
- port)))
+ port
+ environment)))
(if (and (not invalid-expression?)
(eq? expression '$))
(debug/scode-eval (dstate/expression dstate)
#| -*-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.
\f
;;;; 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)
'(("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
"(set-window-start (selected-window) xscheme-temp-1 nil)"))
(thunk)))
-(define emacs-presentation-top-justify?
- #f)
+(define emacs-presentation-top-justify? #f)
;;;; Interrupt Support
(define (emacs/^G-interrupt)
(transmit-signal the-console-port #\g))
-
+\f
;;;; 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 ""))
(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
(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)))
#| -*-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
(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)
(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)
(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)))))))
\f
;;;; Loader for packed binaries
#| -*-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
(if (default-object? condition) #f condition)
(if (default-object? operations) '() operations)
(if (default-object? prompt) 'INHERIT prompt))))
-\f
+
(define (repl-driver repl)
(let ((condition (repl/condition repl)))
(if (and condition (condition/error? condition))
(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))
+\f
+(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))))
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
(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)))
\f
(define (repl/start repl #!optional message)
(cmdl/start repl
(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))
#| -*-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
re
read-eval-print
repl-eval
+ repl-eval/write
repl-history/read
repl-history/record!
repl-history/size
#| -*-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.
\f
;;;; 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)))
\f
(define (prompt-for-command-char prompt #!optional port)
(let ((prompt (canonicalize-command-prompt prompt))
(flush-output port)))
(loop))))))
\f
+(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)))))
+\f
;;;; Debugger Support
(define (port/debugger-failure port message)
\f
;;;; 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
(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)
#| -*-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.
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.")))
(define command-set)
\f
(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
(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
projects / mit-scheme.git / commitdiff