Define new procedure CALL-WITH-OUTPUT-MARK, and change most calls to

WITH-OUTPUT-TO-MARK to use the new procedure instead.

diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm
index 22ef5605f21832d021370f66a652e912885152c4..a7fdeeac5c2338f465eca94d2039458d64994abe 100644 (file)
--- a/v7/src/edwin/bufcom.scm
+++ b/v7/src/edwin/bufcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.92 1992/03/13 09:47:34 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.93 1992/04/16 22:30:13 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -224,13 +224,18 @@ Uses the visited file name, the -*- line, and the local variables spec."
     (buffer-not-modified! buffer)
     (pop-up-buffer buffer false)))
 
-(define (with-output-to-temporary-buffer name thunk)
+(define (call-with-output-to-temporary-buffer name procedure)
   (let ((buffer (temporary-buffer name)))
-    (with-output-to-mark (buffer-point buffer) thunk)
+    (call-with-output-mark (buffer-point buffer) procedure)
     (set-buffer-point! buffer (buffer-start buffer))
     (buffer-not-modified! buffer)
     (pop-up-buffer buffer false)))
 
+(define (with-output-to-temporary-buffer name thunk)
+  (call-with-output-to-temporary-buffer name
+    (lambda (port)
+      (with-output-to-port port thunk))))
+
 (define (call-with-temporary-buffer name procedure)
   (let ((buffer))
     (unwind-protect (lambda ()

diff --git a/v7/src/edwin/bufmnu.scm b/v7/src/edwin/bufmnu.scm
index 1ea71b9b665ed37c99d64d7cf2ec11c2a65e31bd..fd07a613fc2948c937784077a8274dc3c3e912ca 100644 (file)
--- a/v7/src/edwin/bufmnu.scm
+++ b/v7/src/edwin/bufmnu.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.118 1992/01/24 23:48:35 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.119 1992/04/16 22:29:46 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -87,9 +87,9 @@ Type q immediately to make the buffer menu go away."
   (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?)))
 
 (define (fill-buffer-menu! buffer files-only?)
-  (with-output-to-mark (buffer-point buffer)
-    (lambda ()
-      (write-string list-buffers-header)
+  (call-with-output-mark (buffer-point buffer)
+    (lambda (port)
+      (write-string list-buffers-header port)
       (let ((current (current-buffer)))
        (for-each (lambda (buffer)
                    (if (not (or (minibuffer? buffer)
@@ -106,8 +106,9 @@ Type q immediately to make the buffer menu go away."
                            (group-length (buffer-group buffer)))
                           (mode-display-name (buffer-major-mode buffer))
                           (let ((truename (buffer-truename buffer)))
-                            (if truename (->namestring truename) ""))))
-                        (newline))))
+                            (if truename (->namestring truename) "")))
+                         port)
+                        (newline port))))
                  (buffer-list)))))
   (set-buffer-point! buffer (line-start (buffer-start buffer) 2))
   (set-buffer-read-only! buffer))

diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm
index cabfdaa787bf878a52a1c085c16e3188583c013c..dd28164fcb19460eec3a19bad157006d4de3330e 100644 (file)
--- a/v7/src/edwin/bufout.scm
+++ b/v7/src/edwin/bufout.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.7 1991/11/26 08:02:36 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.8 1992/04/16 22:28:44 cph Exp $
 ;;;
-;;;    Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -48,8 +48,15 @@
 (declare (usual-integrations))
 \f
 (define (with-output-to-mark mark thunk)
-  (with-output-to-port (mark->output-port mark)
-    thunk))
+  (call-with-output-mark mark
+    (lambda (port)
+      (with-output-to-port port thunk))))
+
+(define (call-with-output-mark mark procedure)
+  (let ((port (mark->output-port mark)))
+    (let ((value (procedure port)))
+      (operation/close port)
+      value)))
 
 (define (mark->output-port mark #!optional buffer)
   (output-port/copy mark-output-port-template

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 618be9876a2dcaa248a8f908317e6b48cf530761..772b18aebb905d4a16bca5db0f801fe359d44b6d 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.87 1992/04/09 18:12:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.88 1992/04/16 22:29:00 cph Exp $
 
 Copyright (c) 1989-92 Massachusetts Institute of Technology
 
@@ -567,6 +567,7 @@ MIT in each case. |#
   (files "bufout")
   (parent (edwin))
   (export (edwin)
+         call-with-output-mark
          mark->output-port
          with-output-to-mark))
 

diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm
index f857e418a6570da27acc81f5db30fd7f288b8f60..a9645e555826c8b5dfae3c69a153f63cbd54df71 100644 (file)
--- a/v7/src/edwin/info.scm
+++ b/v7/src/edwin/info.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.109 1991/11/06 19:56:45 arthur Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.110 1992/04/16 22:29:16 cph Exp $
 ;;;
-;;;    Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -253,9 +253,11 @@ s  Search through this Info file for specified regexp,
   ()
   (lambda ()
     (let ((buffer (temporary-buffer "*Help*")))
-      (with-output-to-mark (buffer-point buffer)
-       (lambda ()
-         (write-description (mode-description (current-major-mode)))))
+      (call-with-output-mark (buffer-point buffer)
+       (lambda (port)
+         (write-string
+          (substitute-command-keys (mode-description (current-major-mode)))
+          port)))
       (set-buffer-point! buffer (buffer-start buffer))
       (buffer-not-modified! buffer)
       (with-selected-buffer buffer
@@ -792,16 +794,16 @@ The name may be an abbreviation of the reference name."
                                        (string-length tag-table-end-string))))
              ;; Then write new table.
              (let ((entries (collect-tag-entries (buffer-start buffer))))
-               (with-output-to-mark (buffer-end buffer)
-                 (lambda ()
-                   (write-string tag-table-start-string)
+               (call-with-output-mark (buffer-end buffer)
+                 (lambda (port)
+                   (write-string tag-table-start-string port)
                    (for-each (lambda (entry)
-                               (write-string (cdr entry))
-                               (write-char #\Rubout)
-                               (write (mark-index (car entry)))
-                               (newline))
+                               (write-string (cdr entry) port)
+                               (write-char #\Rubout port)
+                               (write (mark-index (car entry)) port)
+                               (newline port))
                              entries)
-                   (write-string tag-table-end-string))))))
+                   (write-string tag-table-end-string port))))))
          ;; Finally, reset the tag table marks.
          (find-tag-table buffer))))))
 

diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm
index 1f431281941d718665084a014f0813d1604b2be4..8e27c94a2d04d3791f65639e164f1e1e299c6139 100644 (file)
--- a/v7/src/edwin/kmacro.scm
+++ b/v7/src/edwin/kmacro.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.37 1992/02/17 22:09:31 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.38 1992/04/16 22:30:00 cph Exp $
 ;;;
 ;;;    Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -199,25 +199,22 @@ With argument, also record the keys it is bound to."
                                  false
                                  false))
            (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*")))
-       (with-output-to-mark (buffer-point buffer)
-         (lambda ()
-           (write-string "(IN-PACKAGE EDWIN-PACKAGE")
-           (newline) (write-string "  (KEYBOARD-MACRO-DEFINE ") (write name)
-           (newline) (write-string "    '")
-           (write (string-table-get named-keyboard-macros name))
-           (write-string ")")
-           (if argument
-               (for-each (lambda (key)
-                           (newline)
-                           (write-string "  (DEFINE-KEY \"Fundamental\" '")
-                           (write key)
-                           (write-string " ")
-                           (write name)
-                           (write-string ")"))
-                         (comtab-key-bindings
-                          (mode-comtabs (ref-mode-object fundamental))
-                          (name->command name))))
-           (newline) (write-string ")")))
+       (call-with-output-mark (buffer-point buffer)
+         (lambda (port)
+           (pretty-print
+            `(IN-PACKAGE EDWIN-PACKAGE
+               (KEYBOARD-MACRO-DEFINE
+                ',name
+                ',(string-table-get named-keyboard-macros name))
+               ,@(if argument
+                     (map (lambda (key)
+                            `(DEFINE-KEY 'FUNDAMENTAL ',key ',name))
+                          (comtab-key-bindings
+                           (mode-comtabs (ref-mode-object fundamental))
+                           (name->command name)))
+                     '()))
+            port
+            true)))
        (set-buffer-pathname! buffer pathname)
        (write-buffer buffer)
        (kill-buffer buffer)))))