From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 16 Apr 1992 22:30:13 +0000 (+0000)
Subject: Define new procedure CALL-WITH-OUTPUT-MARK, and change most calls to
X-Git-Tag: 20090517-FFI~9481
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5ee67ce3244c773115896e0e7b1657f2e2dd1afb;p=mit-scheme.git

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 22ef5605f..a7fdeeac5 100644
--- 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 1ea71b9b6..fd07a613f 100644
--- 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 cabfdaa78..dd28164fc 100644
--- 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))
 
 (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 618be9876..772b18aeb 100644
--- 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 f857e418a..a9645e555 100644
--- 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 1f4312819..8e27c94a2 100644
--- 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)))))