Fix implementation of transcript-disable-evaluation variable so that

it now works.  Implement new option variable
transcript-buffer-read-only, which defaults to true.

diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm
index 841710fbaf74529be3de31712e57c9ddc5966843..58af111e1d464ad0a0e604a4f59c828a749c22f0 100644 (file)
--- a/v7/src/edwin/evlcom.scm
+++ b/v7/src/edwin/evlcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.37 1992/06/01 21:55:55 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.38 1992/08/18 23:31:58 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -82,6 +82,18 @@ and the output, if non-null, is shown in a pop-up buffer."
   false
   boolean?)
 
+(define-variable disable-evaluation-commands
+  "If true, evaluation commands signal an error."
+  false
+  boolean?)
+
+(define-variable evaluate-in-inferior-repl
+  "If true, evaluation commands evaluate expressions in an inferior REPL.
+Also, the inferior REPL's run light appears in all Scheme mode buffers.
+Otherwise, expressions are evaluated directly by the commands."
+  false
+  boolean?)
+\f
 (define-variable transcript-buffer-name
   "Name of evaluation transcript buffer.
 This can also be a buffer object."
@@ -92,6 +104,11 @@ This can also be a buffer object."
 This can be either a mode object or the name of one."
   'scheme)
 
+(define-variable transcript-buffer-read-only
+  "If true, transcript buffer is initialized to read-only when created."
+  true
+  boolean?)
+
 (define-variable transcript-output-wrapper
   "A procedure that is called to setup transcript output.
 It is passed a thunk as its only argument.
@@ -112,18 +129,6 @@ If #F, normal transcript output is done."
   "If true, evaluation commands are disabled in the transcript buffer."
   true
   boolean?)
-
-(define-variable disable-evaluation-commands
-  "If true, evaluation commands signal an error."
-  false
-  boolean?)
-
-(define-variable evaluate-in-inferior-repl
-  "If true, evaluation commands evaluate expressions in an inferior REPL.
-Also, the inferior REPL's run light appears in all Scheme mode buffers.
-Otherwise, expressions are evaluated directly by the commands."
-  false
-  boolean?)
 \f
 ;;;; Commands
 
@@ -180,10 +185,12 @@ The values are printed in the typein window."
             (inferior-repl-eval-expression (current-repl-buffer) expression))
            (else
             (if (ref-variable enable-transcript-buffer buffer)
-                (insert-string
-                 (fluid-let ((*unparse-with-maximum-readability?* true))
-                   (write-to-string expression))
-                 (buffer-end (transcript-buffer))))
+                (call-with-transcript-buffer
+                 (lambda (buffer)
+                   (insert-string
+                    (fluid-let ((*unparse-with-maximum-readability?* true))
+                      (write-to-string expression))
+                    (buffer-end buffer)))))
             (editor-eval buffer
                          expression
                          (evaluation-environment buffer)))))))
@@ -265,7 +272,7 @@ Has no effect if evaluate-in-inferior-repl is false."
   "Select the transcript buffer."
   ()
   (lambda ()
-    (select-buffer (transcript-buffer))))
+    (call-with-transcript-buffer select-buffer)))
 \f
 ;;;; Expression Prompts
 
@@ -327,9 +334,11 @@ may be available.  The following commands are special to this mode:
       (if evaluation-input-recorder
          (evaluation-input-recorder region)))
     (if (ref-variable enable-transcript-buffer buffer)
-       (insert-region (region-start region)
-                      (region-end region)
-                      (buffer-end (transcript-buffer))))
+       (call-with-transcript-buffer
+        (lambda (buffer)
+          (insert-region (region-start region)
+                         (region-end region)
+                         (buffer-end buffer)))))
     (bind-condition-handler (list condition-type:error)
        evaluation-error-handler
       (lambda ()
@@ -501,11 +510,12 @@ FIT           Error messages appear in typein window if they fit;
       (let ((output-wrapper (ref-variable transcript-output-wrapper)))
        (if output-wrapper
            (output-wrapper thunk)
-           (let ((output-port
-                  (let ((buffer (transcript-buffer)))
-                    (mark->output-port (buffer-end buffer) buffer))))
-             (fresh-line output-port)
-             (with-output-to-port output-port thunk))))
+           (call-with-transcript-buffer
+            (lambda (buffer)
+              (let ((output-port
+                     (mark->output-port (buffer-end buffer) buffer)))
+                (fresh-line output-port)
+                (with-output-to-port output-port thunk))))))
       (let ((value))
        (let ((output
               (with-output-to-string
@@ -554,6 +564,24 @@ FIT           Error messages appear in typein window if they fit;
                  (*unparser-list-breadth-limit*
                   (ref-variable transcript-list-breadth-limit)))
        (write-to-string value))))
+\f
+(define (call-with-transcript-buffer procedure)
+  (let ((buffer (transcript-buffer)))
+    (let ((group (buffer-group buffer))
+         (outside)
+         (inside false))
+      (dynamic-wind (lambda ()
+                     (set! outside (group-read-only? group))
+                     (if inside
+                         (set-group-read-only! group)
+                         (set-group-writeable! group)))
+                   (lambda ()
+                     (procedure buffer))
+                   (lambda ()
+                     (set! inside (group-read-only? group))
+                     (if outside
+                         (set-group-read-only! group)
+                         (set-group-writeable! group)))))))
 
 (define (transcript-buffer)
   (let ((name (ref-variable transcript-buffer-name)))
@@ -564,8 +592,16 @@ FIT           Error messages appear in typein window if they fit;
              (set-buffer-major-mode!
               buffer
               (->mode (ref-variable transcript-buffer-mode)))
+             (if (ref-variable transcript-buffer-read-only)
+                 (set-buffer-read-only! buffer))
              (if (ref-variable transcript-disable-evaluation)
-                 (define-variable-local-value! buffer
-                   (ref-variable-object disable-evaluation-commands)
-                   true))
+                 (add-buffer-initialization! buffer
+                   (lambda ()
+                     (local-set-variable! disable-evaluation-commands true)
+                     (if (eq? (buffer-major-mode buffer)
+                              (ref-mode-object scheme))
+                         (begin
+                           (local-set-variable! evaluate-in-inferior-repl
+                                                false)
+                           (local-set-variable! run-light false))))))
              buffer)))))
\ No newline at end of file

diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm
index 4cce08c98962b7249dc0d8cd393962ed4aabd38f..cce8bebe7d6c66e34149f35a5402cfaa174e4ed2 100644 (file)
--- a/v7/src/edwin/intmod.scm
+++ b/v7/src/edwin/intmod.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.48 1992/06/05 21:38:54 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.49 1992/08/18 23:32:10 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -53,10 +53,13 @@ This flag has effect only when ENABLE-TRANSCRIPT-BUFFER is also true."
   true
   boolean?)
 
-(define (transcript-output-mark buffer)
-  (and (ref-variable repl-enable-transcript-buffer buffer)
-       (ref-variable enable-transcript-buffer buffer)
-       (buffer-end (transcript-buffer))))
+(define (call-with-transcript-output-mark buffer procedure)
+  (if (and (ref-variable repl-enable-transcript-buffer buffer)
+          (ref-variable enable-transcript-buffer buffer))
+      (call-with-transcript-buffer
+       (lambda (buffer)
+        (procedure (buffer-end buffer))))
+      (procedure false)))
 
 (define-variable repl-error-decision
   "If true, errors in REPL evaluation force the user to choose an option.
@@ -440,11 +443,12 @@ If this is an error, the debugger examines the error condition."
       (end-input-wait port))))
 \f
 (define (inferior-repl-eval-region buffer region)
-  (let ((mark (transcript-output-mark buffer)))
-    (if mark
-       (insert-region (region-start region)
-                      (region-end region)
-                      mark)))
+  (call-with-transcript-output-mark buffer
+    (lambda (mark)
+      (if mark
+         (insert-region (region-start region)
+                        (region-end region)
+                        mark))))
   (let ((port (buffer-interface-port buffer)))
     (let ((end
           (let ((end (buffer-end buffer))
@@ -464,11 +468,13 @@ If this is an error, the debugger examines the error condition."
          (end-input-wait port)))))
 
 (define (inferior-repl-eval-expression buffer expression)
-  (let ((mark (transcript-output-mark buffer)))
-    (if mark
-       (insert-string (fluid-let ((*unparse-with-maximum-readability?* true))
-                        (write-to-string expression))
-                      mark)))
+  (call-with-transcript-output-mark buffer
+    (lambda (mark)
+      (if mark
+         (insert-string
+          (fluid-let ((*unparse-with-maximum-readability?* true))
+            (write-to-string expression))
+          mark))))
   (let ((port (buffer-interface-port buffer)))
     (let ((end (buffer-end buffer)))
       (set-buffer-point! buffer end)
@@ -629,24 +635,26 @@ If this is an error, the debugger examines the error condition."
 
 (define (process-output-queue port)
   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))
-       (mark (port/mark port))
-       (transcript-mark (transcript-output-mark (port/buffer port))))
-    (let loop ()
-      (let ((operation (dequeue!/unsafe (port/output-queue port) false)))
-       (if operation
-           (begin
-             (operation mark false)
-             (if transcript-mark (operation transcript-mark true))
-             (loop)))))
-    (let ((strings (port/output-strings port)))
-      (if (not (null? strings))
-         (begin
-           (set-port/output-strings! port '())
-           (do ((strings (reverse! strings) (cdr strings)))
-               ((null? strings))
-             (region-insert-string! mark (car strings))
-             (if transcript-mark
-                 (region-insert-string! transcript-mark (car strings)))))))
+       (mark (port/mark port)))
+    (call-with-transcript-output-mark (port/buffer port)
+      (lambda (transcript-mark)
+       (let loop ()
+         (let ((operation (dequeue!/unsafe (port/output-queue port) false)))
+           (if operation
+               (begin
+                 (operation mark false)
+                 (if transcript-mark (operation transcript-mark true))
+                 (loop)))))
+       (let ((strings (port/output-strings port)))
+         (if (not (null? strings))
+             (begin
+               (set-port/output-strings! port '())
+               (do ((strings (reverse! strings) (cdr strings)))
+                   ((null? strings))
+                 (region-insert-string! mark (car strings))
+                 (if transcript-mark
+                     (region-insert-string! transcript-mark
+                                            (car strings)))))))))
     (set-interrupt-enables! interrupt-mask))
   true)
 \f