From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 16 Oct 1993 10:11:21 +0000 (+0000)
Subject: Change PROMPT-FOR-COMMAND-xxx port operations to take an additional
X-Git-Tag: 20090517-FFI~7741
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=09fecccd9fec998bd6625e80492d612671af8507;p=mit-scheme.git

Change PROMPT-FOR-COMMAND-xxx port operations to take an additional
argument, which is a level number; (NEAREST-CMDL/LEVEL) is passed for
this argument.
---

diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm
index 76a76e20c..13744b79e 100644
--- a/v7/src/edwin/intmod.scm
+++ b/v7/src/edwin/intmod.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: intmod.scm,v 1.69 1993/10/16 07:34:12 cph Exp $
+;;;	$Id: intmod.scm,v 1.70 1993/10/16 10:11:21 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -170,20 +170,19 @@ REPL uses current evaluation environment."
   (set! repl-buffers '())
   unspecific)
 
-(define (wait-for-input port mode ready?)
-  (let ((level (nearest-cmdl/level)))
-    (signal-thread-event editor-thread
-      (lambda ()
-	(maybe-switch-modes! port mode)
-	(let ((buffer (port/buffer port)))
-	  (define-variable-local-value! buffer
-	    (ref-variable-object mode-line-process)
-	    (list ": "
-		  'RUN-LIGHT
-		  (if (= level 1)
-		      ""
-		      (string-append " [level: " (number->string level) "]"))))
-	  (set-run-light! buffer #f)))))
+(define (wait-for-input port mode ready? level)
+  (signal-thread-event editor-thread
+    (lambda ()
+      (maybe-switch-modes! port mode)
+      (let ((buffer (port/buffer port)))
+	(define-variable-local-value! buffer
+	  (ref-variable-object mode-line-process)
+	  (list ": "
+		'RUN-LIGHT
+		(if (= level 1)
+		    ""
+		    (string-append " [level: " (number->string level) "]"))))
+	(set-run-light! buffer #f))))
   ;; This doesn't do any output, but prods the editor to notice that
   ;; the modeline has changed and a redisplay is needed.
   (inferior-thread-output! (port/output-registration port))
@@ -307,7 +306,7 @@ REPL uses current evaluation environment."
 		(write-string
 		 ";Type D to debug error, Q to quit back to REP loop: "
 		 port)
-		(let ((char (read-command-char port)))
+		(let ((char (read-command-char port (cmdl/level rep))))
 		  (write-char char port)
 		  (cond ((char-ci=? char #\d)
 			 (fresh-line port)
@@ -792,11 +791,11 @@ If this is an error, the debugger examines the error condition."
 (define (operation/read port parser-table)
   parser-table
   (standard-prompt-spacing port)
-  (read-expression port))
+  (read-expression port (nearest-cmdl/level)))
 
 (define read-expression
   (let ((empty (cons '() '())))
-    (lambda (port)
+    (lambda (port level)
       (let ((queue (port/expression-queue port))
 	    (mode (ref-mode-object inferior-repl))
 	    (ready?
@@ -806,7 +805,7 @@ If this is an error, the debugger examines the error condition."
 	  (let ((element (dequeue! queue empty)))
 	    (if (eq? element empty)
 		(begin
-		  (wait-for-input port mode ready?)
+		  (wait-for-input port mode ready? level)
 		  (loop))
 		(begin
 		  (set-port/current-queue-element! port element)
@@ -899,29 +898,22 @@ 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)
+(define (operation/prompt-for-command-expression port prompt level)
   (parse-command-prompt port prompt)
-  (read-expression port))
+  (read-expression port level))
 
-(define (operation/prompt-for-command-char port prompt)
+(define (operation/prompt-for-command-char port prompt level)
   (parse-command-prompt port prompt)
-  (read-command-char port))
+  (read-command-char port level))
 
-(define (read-command-char port)
+(define (read-command-char port level)
   (set-port/command-char! port false)
-  (wait-for-input port (ref-mode-object inferior-cmdl) port/command-char)
+  (wait-for-input port (ref-mode-object inferior-cmdl) port/command-char level)
   (port/command-char port))
 
 (define (parse-command-prompt port prompt)
   (standard-prompt-spacing port)
-  (let ((prompt
-	 (string-trim-right
-	  (let ((prefix
-		 (string-append (number->string (nearest-cmdl/level)) " ")))
-	    (if (and (string-prefix? prefix prompt)
-		     (not (string=? prefix prompt)))
-		(string-tail prompt (string-length prefix))
-		prompt)))))
+  (let ((prompt (string-trim prompt)))
     (if (not (and suppress-standard-prompts?
 		  (or (string=? prompt user-initial-prompt)
 		      (member prompt standard-prompts))))
diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm
index db8802af5..0b7f7d6ae 100644
--- a/v7/src/runtime/dbgcmd.scm
+++ b/v7/src/runtime/dbgcmd.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.13 1991/11/26 07:05:04 cph Exp $
+$Id: dbgcmd.scm,v 14.14 1993/10/16 10:10:56 cph Exp $
 
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -79,23 +79,22 @@ MIT in each case. |#
 	     (write-condition-report condition port)
 	     (continuation unspecific))
 	 (lambda ()
-	   (let ((command-set (vector-ref (cmdl/state cmdl) 0))
-		 (prompt
-		  (string-append (number->string (cmdl/level cmdl))
-				 " "
-				 (vector-ref (cmdl/state cmdl) 1)))
-		 (state (vector-ref (cmdl/state cmdl) 2)))
-	     (let loop ()
-	       (let ((entry
-		      (assv (char-upcase (prompt-for-command-char prompt port))
-			    (cdr command-set))))
-		 (if entry
-		     ((cadr entry) state port)
-		     (begin
-		       (beep port)
-		       (newline port)
-		       (write-string "Unknown command character" port)
-		       (loop)))))))))))
+	   (let ((state (cmdl/state cmdl)))
+	     (let ((command-set (vector-ref state 0))
+		   (prompt (vector-ref state 1))
+		   (state (vector-ref state 2)))
+	       (let loop ()
+		 (let ((entry
+			(assv (char-upcase
+			       (prompt-for-command-char prompt port))
+			      (cdr command-set))))
+		   (if entry
+		       ((cadr entry) state port)
+		       (begin
+			 (beep port)
+			 (newline port)
+			 (write-string "Unknown command character" port)
+			 (loop))))))))))))
   (cmdl-message/null))
 
 (define ((standard-help-command command-set) state port)
diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm
index d089e9238..b4e8dc186 100644
--- a/v7/src/runtime/emacs.scm
+++ b/v7/src/runtime/emacs.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: emacs.scm,v 14.16 1993/10/16 07:32:43 cph Exp $
+$Id: emacs.scm,v 14.17 1993/10/16 10:11:04 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -39,33 +39,27 @@ MIT in each case. |#
 
 ;;;; Prompting
 
-(define (emacs/prompt-for-command-expression port prompt)
-  (transmit-modeline-string port prompt)
+(define (emacs/prompt-for-command-expression port prompt level)
+  (transmit-modeline-string port prompt level)
   (transmit-signal port #\R)
   (read port))
 
-(define (emacs/prompt-for-command-char port prompt)
-  (transmit-modeline-string port prompt)
+(define (emacs/prompt-for-command-char port prompt level)
+  (transmit-modeline-string port prompt level)
   (transmit-signal-with-argument port #\D "")
   (transmit-signal port #\o)
   (read-char-internal port))
 
-(define (transmit-modeline-string port prompt)
+(define (transmit-modeline-string port prompt level)
   (transmit-signal-with-argument
    port
    #\p
-   (let ((prefix (string-append (number->string (nearest-cmdl/level)) " ")))
-     (string-append prefix
-		    (let ((prompt
-			   (string-trim-right
-			    (if (and (string-prefix? prefix prompt)
-				     (not (string=? prefix prompt)))
-				(string-tail prompt (string-length prefix))
-				prompt))))
-		      (let ((entry (assoc prompt cmdl-prompt-alist)))
-			(if entry
-			    (cadr entry)
-			    (string-append "[Evaluator] " prompt))))))))
+   (let ((prefix (number->string level))
+	 (prompt (string-trim prompt)))
+     (let ((entry (assoc prompt cmdl-prompt-alist)))
+       (if entry
+	   (string-append prefix " " (cadr entry))
+	   (string-append prefix " [Evaluator] " prompt))))))
 
 (define cmdl-prompt-alist
   '(("]=>" "[Evaluator]")
diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index d0aa19990..0772f8f9a 100644
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rep.scm,v 14.36 1993/10/15 10:26:33 cph Exp $
+$Id: rep.scm,v 14.37 1993/10/16 10:10:47 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -42,7 +42,6 @@ MIT in each case. |#
 
 (define (initialize-package!)
   (set! *nearest-cmdl* false)
-  (set! hook/repl-prompt default/repl-prompt)
   (set! hook/repl-eval default/repl-eval)
   (set! hook/repl-write default/repl-write)
   (set! hook/set-default-environment default/set-default-environment)
@@ -406,11 +405,8 @@ MIT in each case. |#
     (port/set-default-syntax-table (cmdl/port repl) (repl/syntax-table repl))
     (do () (false)
       (let ((s-expression
-	     (hook/repl-prompt
-	      (string-append (number->string (cmdl/level repl))
-			     " "
-			     (repl/prompt repl))
-	      (cmdl/port repl))))
+	     (prompt-for-command-expression (repl/prompt repl)
+					    (cmdl/port repl))))
 	(repl-history/record! reader-history s-expression)
 	(let ((value
 	       (hook/repl-eval repl
@@ -420,10 +416,6 @@ MIT in each case. |#
 	  (repl-history/record! printer-history value)
 	  (hook/repl-write repl s-expression value))))))
 
-(define hook/repl-prompt)
-(define (default/repl-prompt prompt port)
-  (prompt-for-command-expression prompt port))
-
 (define hook/repl-eval)
 (define (default/repl-eval repl s-expression environment syntax-table)
   (let ((scode (syntax s-expression syntax-table)))
diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm
index 756ea2d80..59199fcf6 100644
--- a/v7/src/runtime/usrint.scm
+++ b/v7/src/runtime/usrint.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: usrint.scm,v 1.7 1993/10/16 07:32:34 cph Exp $
+$Id: usrint.scm,v 1.8 1993/10/16 10:10:39 cph Exp $
 
 Copyright (c) 1991-93 Massachusetts Institute of Technology
 
@@ -48,19 +48,21 @@ MIT in each case. |#
 
 (define (prompt-for-command-expression prompt #!optional port)
   (let ((prompt (canonicalize-prompt prompt " "))
-	(port (if (default-object? port) (nearest-cmdl/port) port)))
+	(port (if (default-object? port) (nearest-cmdl/port) port))
+	(level (nearest-cmdl/level)))
     (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-EXPRESSION)))
       (if operation
-	  (operation port prompt)
-	  (default/prompt-for-command-expression port prompt)))))
+	  (operation port prompt level)
+	  (default/prompt-for-command-expression port prompt level)))))
 
-(define (default/prompt-for-command-expression port prompt)
+(define (default/prompt-for-command-expression port prompt level)
   (port/with-output-terminal-mode port 'COOKED
     (lambda ()
       (fresh-line port)
       (newline port)
-      (write-string prompt port)
+      (write level port)
       (write-string " " port)
+      (write-string prompt port)
       (flush-output port)))
   (port/with-input-terminal-mode port 'COOKED
     (lambda ()
@@ -74,8 +76,16 @@ MIT in each case. |#
 	  (operation port prompt)
 	  (default/prompt-for-expression port prompt)))))
 
-(define default/prompt-for-expression
-  default/prompt-for-command-expression)
+(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
@@ -90,19 +100,22 @@ MIT in each case. |#
 
 (define (prompt-for-command-char prompt #!optional port)
   (let ((prompt (canonicalize-prompt prompt " "))
-	(port (if (default-object? port) (nearest-cmdl/port) port)))
+	(port (if (default-object? port) (nearest-cmdl/port) port))
+	(level (nearest-cmdl/level)))
     (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-CHAR)))
       (if operation
-	  (operation port prompt)
-	  (default/prompt-for-command-char port prompt)))))
+	  (operation port prompt level)
+	  (default/prompt-for-command-char port prompt level)))))
 
-(define (default/prompt-for-command-char port prompt)
+(define (default/prompt-for-command-char port prompt level)
   (port/with-output-terminal-mode port 'COOKED
     (lambda ()
       (port/with-input-terminal-mode port 'RAW
 	(lambda ()
 	  (fresh-line port)
 	  (newline port)
+	  (write level port)
+	  (write-string " " port)
 	  (write-string prompt port)
 	  (flush-output port)
 	  (let loop ()