;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.43 1987/04/18 00:15:53 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.44 1987/12/05 16:40:13 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define print-return-values?
false)
+(define environment-arguments-truncation
+ 68)
+
(define (define-debug-command letter function help-text)
(define-letter-command command-set letter function help-text))
(lambda ()
(print-current-expression)
((standard-rep-message "Debugger")))
- (standard-rep-prompt "Debug-->")))
+ "Debug-->"))
(define (undefined-environment? environment)
(or (continuation-undefined-environment? environment)
(print-expression (reduction-expression current-reduction)))
(define (print-application-information env)
- (define (do-it return?)
- (if return? (format "~%within ") (format "within "))
- (print-user-friendly-name env)
- (if return?
- (format "~%applied to ~@68o" (environment-arguments env))
- (format " applied to ~@68o" (environment-arguments env))))
-
- (let ((output (with-output-to-string (lambda () (do-it false)))))
- (if (< (string-length output)
- (access printer-width implementation-dependencies))
- (format "~%~s" output)
- (do-it true))))
-
+ (let ((do-it
+ (lambda (return?)
+ (if return? (newline))
+ (write-string "within ")
+ (print-user-friendly-name env)
+ (if return? (newline))
+ (write-string " applied to ")
+ (write-string
+ (cdr (write-to-string (environment-arguments env)
+ environment-arguments-truncation))))))
+ (let ((output (with-output-to-string (lambda () (do-it false)))))
+ (if (< (string-length output)
+ (access printer-width implementation-dependencies))
+ (begin (newline) (write-string output))
+ (do-it true)))))
+
+ (newline)
(if (null-continuation? current-continuation)
- (format "~%Null continuation")
+ (write-string "Null continuation")
(begin
- (format "~%Subproblem Level: ~o" (length previous-continuations))
- (if current-reduction
- (print-current-reduction)
- (begin
- (format "~%Possibly Incomplete Expression:")
- (print-expression (continuation-expression current-continuation))))
- (if-valid-environment current-environment
- print-application-information))))
+ (write-string "Subproblem Level: ")
+ (write (length previous-continuations))
+ (if current-reduction
+ (print-current-reduction)
+ (begin
+ (newline)
+ (write-string "Possibly Incomplete Expression:")
+ (print-expression
+ (continuation-expression current-continuation))))
+ (if-valid-environment current-environment
+ print-application-information))))
(define-debug-command #\S print-current-expression
"Print the current subproblem/reduction")
(define (goto-command)
(define (get-reduction-number)
- (format "~%Reduction Number (0 through ~o inclusive): "
- (-1+ current-number-of-reductions))
- (let ((red (read)))
+ (let ((red
+ (prompt-for-expression
+ (format false
+ "Reduction Number (0 through ~o inclusive): "
+ (-1+ current-number-of-reductions)))))
(cond ((not (number? red))
(beep)
(format "~%Reduction number must be numeric!")
(else (format "~%There are no reductions for this subproblem."))))
(define (get-subproblem-number)
- (format "~%Subproblem number: ")
- (let ((len (length previous-continuations)) (sub (read)))
+ (let ((len (length previous-continuations))
+ (sub (prompt-for-expression "Subproblem number: ")))
(cond ((not (number? sub))
(beep)
(format "~%Subproblem level must be numeric!")
;;;; Evaluation and frame display commands
(define (enter-read-eval-print-loop)
- (with-rep-alternative
- current-environment
- (lambda (env)
- (read-eval-print env
- "You are now in the desired environment"
- "Eval-in-env-->"))))
+ (with-rep-alternative current-environment
+ (lambda (env)
+ (debug/read-eval-print env
+ "You are now in the desired environment"
+ "Eval-in-env-->"))))
(define-debug-command #\E enter-read-eval-print-loop
"Enter a read-eval-print loop in the current environment")
(define (eval-in-current-environment)
(with-rep-alternative current-environment
- (lambda (env)
- (environment-warning-hook env)
- (format "~%Eval--> ")
- (eval (read) env))))
+ (lambda (env)
+ (environment-warning-hook env)
+ (debug/eval (prompt-for-expression "Eval--> ") env))))
(define-debug-command #\V eval-in-current-environment
"Evaluate expression in current environment")
"Show Bindings of identifiers in the current environment")
(define (enter-where-command)
- (with-rep-alternative current-environment where))
+ (with-rep-alternative current-environment debug/where))
(define-debug-command #\W enter-where-command
"Enter WHERE on the current environment")
;;;; Advanced hacking commands
(define (return-command) ;command Z
- (define (confirm)
- (format "~%Confirm: [Y or N] ")
- (let ((ans (read)))
- (cond ((eq? ans 'Y) true)
- ((eq? ans 'N) false)
- (else (confirm)))))
-
- (define (return-read)
- (let ((exp (read)))
- (if (eq? exp '$)
- (unsyntax (current-expression))
- exp)))
-
(define (do-it environment next)
(environment-warning-hook environment)
- (format "~%Expression to EVALUATE and CONTINUE with ($ to retry): ")
- (if print-return-values?
- (let ((eval-exp (eval (return-read) environment)))
- (format "~%That evaluates to:~%~o" eval-exp)
- (if (confirm) (next eval-exp)))
- (next (eval (return-read) environment))))
+ (let ((value
+ (debug/eval
+ (let ((expression
+ (prompt-for-expression
+ "Expression to EVALUATE and CONTINUE with ($ to retry): "
+ )))
+ (if (eq? expression '$)
+ (unsyntax (current-expression))
+ expression))
+ environment)))
+ (if print-return-values?
+ (begin
+ (format "~%That evaluates to:~%~o" value)
+ (if (prompt-for-confirmation "Confirm: ") (next value)))
+ (next value))))
(let ((next (continuation-next-continuation current-continuation)))
(if (null-continuation? next)
(define user-debug-environment (make-environment))
(define (internal-command)
- (read-eval-print user-debug-environment
- "You are now in the debugger environment"
- "Debugger-->"))
+ (debug/read-eval-print user-debug-environment
+ "You are now in the debugger environment"
+ "Debugger-->"))
(define-debug-command #\X internal-command
"Create a read eval print loop in the debugger environment")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.49 1987/11/22 22:17:39 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.50 1987/12/05 16:38:53 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(with-output-to-string
(lambda ()
(write object))))
-
+\f
(define paranoid-error-hook?
false)
"Error! Type ctl-E to enter error loop, anything else to return to top level.")
(if (not (char-ci=? (emacs-read-char-immediate) #\C-E))
(abort-to-previous-driver "Quit!")))))
-\f
+
(define (emacs-rep-prompt level string)
(transmit-signal-with-argument
#\p
(define primitive-read-char-immediate
(make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
\f
+(define (emacs/prompt-for-command-char prompt)
+ (emacs-rep-prompt (rep-level) prompt)
+ (transmit-signal-with-argument
+ #\D
+ (cond ((string=? "Debug-->" prompt) "Scheme-debug")
+ ((string=? "Where-->" prompt) "Scheme-where")
+ (else "Scheme")))
+ (transmit-signal-without-gc #\o)
+ (emacs/read-char-internal))
+
+(define (emacs/prompt-for-confirmation prompt)
+ (transmit-signal-with-argument #\n prompt)
+ (emacs/read-char-internal))
+
+(define (emacs/read-char-internal)
+ (emacs-read-start)
+ (let ((char (primitive-read-char-immediate)))
+ (emacs-read-finish)
+ char))
+
+(define (emacs/prompt-for-expression prompt)
+ (transmit-signal-with-argument #\i prompt)
+ (read))
+
+(define (emacs/rep-read-hook)
+ (transmit-signal-without-gc #\R)
+ (read))
+\f
(define normal-start-gc (access gc-start-hook gc-statistics-package))
(define normal-finish-gc (access gc-finish-hook gc-statistics-package))
(define normal-rep-message rep-message-hook)
(define normal-read-char-immediate
(access tty-read-char-immediate console-input-port))
(define normal-error-hook (access *error-decision-hook* error-system))
+(define normal/rep-read-hook rep-read-hook)
+(define normal/prompt-for-command-char
+ (access prompt-for-command-char debugger-package))
+(define normal/prompt-for-confirmation
+ (access prompt-for-confirmation debugger-package))
+(define normal/prompt-for-expression
+ (access prompt-for-expression debugger-package))
(define (install-emacs-hooks!)
(set! (access gc-start-hook gc-statistics-package) emacs-start-gc)
(set! (access read-finish-hook console-input-port) emacs-read-finish)
(set! (access tty-read-char-immediate console-input-port)
emacs-read-char-immediate)
- (set! (access *error-decision-hook* error-system) emacs-error-hook))
+ (set! (access *error-decision-hook* error-system) emacs-error-hook)
+ (set! rep-read-hook emacs/rep-read-hook)
+ (set! (access prompt-for-command-char debugger-package)
+ emacs/prompt-for-command-char)
+ (set! (access prompt-for-confirmation debugger-package)
+ emacs/prompt-for-confirmation)
+ (set! (access prompt-for-expression debugger-package)
+ emacs/prompt-for-expression))
(define (install-normal-hooks!)
(set! (access gc-start-hook gc-statistics-package) normal-start-gc)
(set! (access read-finish-hook console-input-port) normal-read-finish)
(set! (access tty-read-char-immediate console-input-port)
normal-read-char-immediate)
- (set! (access *error-decision-hook* error-system) normal-error-hook))
+ (set! (access *error-decision-hook* error-system) normal-error-hook)
+ (set! rep-read-hook normal/rep-read-hook)
+ (set! (access prompt-for-command-char debugger-package)
+ normal/prompt-for-command-char)
+ (set! (access prompt-for-confirmation debugger-package)
+ normal/prompt-for-confirmation)
+ (set! (access prompt-for-expression debugger-package)
+ normal/prompt-for-expression))
(define under-emacs?
(make-primitive-procedure 'UNDER-EMACS? 0))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.42 1987/03/17 18:55:18 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.43 1987/12/05 16:40:57 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(current-frame-depth 0))
(letter-commands env-commands
(standard-rep-message "Environment Inspector")
- (standard-rep-prompt "Where-->")))))
+ "Where-->"))))
\f
;;;; Display Commands
(define (son)
(cond ((eq? current-frame env)
(newline)
- (write-string "This is the original frame. Its children cannot be found."))
+ (write-string
+ "This is the original frame. Its children cannot be found."))
(else
(let son-1 ((prev env)
(prev-depth 0)
(show))))
(define (recursive-where)
- (write-string "; Object to eval and examine-> ")
- (let ((inp (read)))
+ (let ((inp (prompt-for-expression "Object to eval and examine-> ")))
(write-string "New where!")
- (where (eval inp current-frame))))
+ (debug/where (debug/eval inp current-frame))))
(define-where-command #\P parent
"Find the parent frame of the current one")
;;;; Relative Evaluation Commands
(define (show-object)
- (write-string "; Object to eval and print-> ")
- (let ((inp (read)))
+ (let ((inp (prompt-for-expression "Object to eval and print-> ")))
(newline)
- (write (eval inp current-frame))
+ (write (debug/eval inp current-frame))
(newline)))
(define (enter)
- (read-eval-print current-frame
- "You are now in the desired environment"
- "Eval-in-env-->"))
+ (debug/read-eval-print current-frame
+ "You are now in the desired environment"
+ "Eval-in-env-->"))
(define-where-command #\V show-object
"Eval an expression in the current frame and print the result")
projects / mit-scheme.git / commitdiff