From 721918c8a36e811091a9b51f88827422c0a8e7ab Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 5 Dec 1987 16:40:57 +0000
Subject: [PATCH] Change Emacs interface to have special mode for `debug' and
 `where'.

---
 v7/src/runtime/debug.scm | 130 ++++++++++++++++++++-------------------
 v7/src/runtime/emacs.scm |  59 ++++++++++++++++--
 v7/src/runtime/rep.scm   |   7 ++-
 v7/src/runtime/where.scm |  23 ++++---
 4 files changed, 138 insertions(+), 81 deletions(-)

diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm
index 5ad70542b..aa204b77c 100644
--- a/v7/src/runtime/debug.scm
+++ b/v7/src/runtime/debug.scm
@@ -1,6 +1,6 @@
 ;;; -*-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
 ;;;
@@ -70,6 +70,9 @@
 (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))
 
@@ -100,7 +103,7 @@
 		   (lambda ()
 		     (print-current-expression)
 		     ((standard-rep-message "Debugger")))
-		   (standard-rep-prompt "Debug-->")))
+		   "Debug-->"))
 
 (define (undefined-environment? environment)
   (or (continuation-undefined-environment? environment)
@@ -158,30 +161,37 @@
     (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")
@@ -334,9 +344,11 @@
 
 (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!")
@@ -355,8 +367,8 @@
 	  (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!")
@@ -383,22 +395,20 @@
 ;;;; 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")
@@ -413,7 +423,7 @@
   "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")
@@ -426,27 +436,23 @@
 ;;;; 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)
@@ -460,9 +466,9 @@
 (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")
diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm
index 52aaf628c..30f07cdfa 100644
--- a/v7/src/runtime/emacs.scm
+++ b/v7/src/runtime/emacs.scm
@@ -1,6 +1,6 @@
 ;;; -*-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
 ;;;
@@ -82,7 +82,7 @@
   (with-output-to-string
     (lambda ()
       (write object))))
-
+
 (define paranoid-error-hook?
   false)
 
@@ -95,7 +95,7 @@
 "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!")))))
-
+
 (define (emacs-rep-prompt level string)
   (transmit-signal-with-argument
    #\p
@@ -136,6 +136,34 @@
 (define primitive-read-char-immediate
   (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
 
+(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))
+
 (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)
@@ -146,6 +174,13 @@
 (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)
@@ -157,7 +192,14 @@
   (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)
@@ -169,7 +211,14 @@
   (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))
diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index 8ceaa5e7a..e1131e7b4 100644
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.42 1987/04/13 18:44:00 cph Rel $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.43 1987/12/05 16:39:25 cph Rel $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -221,6 +221,9 @@
 (define environment-warning-hook
   identity-procedure)
 
+(define rep-read-hook
+  read)
+
 (define rep-value-hook
   write-line)
 
@@ -267,7 +270,7 @@
   (*rep-current-prompt*)
   (let ((object
 	 (let ((scode
-		(let ((s-expression (read)))
+		(let ((s-expression (rep-read-hook)))
 		  (record-in-history! (rep-state-reader-history state)
 				      s-expression)
 		  (syntax s-expression *rep-current-syntax-table*))))
diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm
index 6a260a672..e83f75b61 100644
--- a/v7/src/runtime/where.scm
+++ b/v7/src/runtime/where.scm
@@ -1,6 +1,6 @@
 ;;; -*-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
 ;;;
@@ -84,7 +84,7 @@
 		(current-frame-depth 0))
       (letter-commands env-commands
 		       (standard-rep-message "Environment Inspector")
-		       (standard-rep-prompt "Where-->")))))
+		       "Where-->"))))
 
 ;;;; Display Commands
 
@@ -185,7 +185,8 @@
 (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)
@@ -199,10 +200,9 @@
 	 (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")
@@ -216,16 +216,15 @@
 ;;;; 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")
-- 
2.25.1