From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 1 Jan 2003 02:27:05 +0000 (+0000)
Subject: Change GUARANTEE-*-PORT procedures to accept a second argument
X-Git-Tag: 20090517-FFI~2084
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7d3afd32a86e41c51bf22a405487a9760eabdc72;p=mit-scheme.git

Change GUARANTEE-*-PORT procedures to accept a second argument
specifying the caller, and update all references.
---

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 6f8e78a8c..ff08715a1 100644
--- a/v7/src/runtime/error.scm
+++ b/v7/src/runtime/error.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: error.scm,v 14.58 2002/11/20 19:46:19 cph Exp $
+$Id: error.scm,v 14.59 2003/01/01 02:26:37 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -1245,10 +1245,6 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (if (not (continuation? object))
       (error:wrong-type-argument object "continuation" operator)))
 
-(define-integrable (guarantee-output-port object operator)
-  (if (not (output-port? object))
-      (error:wrong-type-argument object "output port" operator)))
-
 (define-integrable (guarantee-condition-type object operator)
   (if (not (condition-type? object))
       (error:wrong-type-argument object "condition type" operator)))
diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm
index dc590c838..2fff5b0cd 100644
--- a/v7/src/runtime/input.scm
+++ b/v7/src/runtime/input.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: input.scm,v 14.21 2002/11/20 19:46:20 cph Exp $
+$Id: input.scm,v 14.22 2003/01/01 02:25:33 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2002 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -74,7 +74,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (char-ready? #!optional port interval)
   (input-port/char-ready? (if (default-object? port)
 			      (current-input-port)
-			      (guarantee-input-port port))
+			      (guarantee-input-port port 'CHAR-READY?))
 			  (if (default-object? interval)
 			      0
 			      (begin
@@ -88,7 +88,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-input-port)
-	     (guarantee-input-port port))))
+	     (guarantee-input-port port 'PEEK-CHAR))))
     (let loop ()
       (or (input-port/peek-char port)
 	  (loop)))))
@@ -97,7 +97,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-input-port)
-	     (guarantee-input-port port))))
+	     (guarantee-input-port port 'READ-CHAR))))
     (let loop ()
       (or (input-port/read-char port)
 	  (loop)))))
@@ -106,7 +106,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-input-port)
-	     (guarantee-input-port port))))
+	     (guarantee-input-port port 'READ-CHAR-NO-HANG))))
     (if (input-port/char-ready? port 0)
 	(input-port/read-char port)
 	(let ((eof? (port/operation port 'EOF?)))
@@ -117,13 +117,13 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (read-string delimiters #!optional port)
   (input-port/read-string (if (default-object? port)
 			      (current-input-port)
-			      (guarantee-input-port port))
+			      (guarantee-input-port port 'READ-STRING))
 			  delimiters))
 
 (define (read #!optional port parser-table)
   (parse-object (if (default-object? port)
 		    (current-input-port)
-		    (guarantee-input-port port))
+		    (guarantee-input-port port 'READ))
 		(if (default-object? parser-table)
 		    (current-parser-table)
 		    parser-table)))
@@ -131,16 +131,16 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 (define (read-line #!optional port)
   (input-port/read-line (if (default-object? port)
 			    (current-input-port)
-			    (guarantee-input-port port))))
+			    (guarantee-input-port port 'READ-LINE))))
 
 (define (read-string! string #!optional port)
   (input-port/read-string! (if (default-object? port)
 			       (current-input-port)
-			       (guarantee-input-port port))
+			       (guarantee-input-port port 'READ-STRING!))
 			   string))
 
 (define (read-substring! string start end #!optional port)
   (input-port/read-substring! (if (default-object? port)
 				  (current-input-port)
-				  (guarantee-input-port port))
+				  (guarantee-input-port port 'READ-SUBSTRING!))
 			      string start end))
\ No newline at end of file
diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index 24150f558..63ef69b14 100644
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: output.scm,v 14.25 2002/12/09 05:40:26 cph Exp $
+$Id: output.scm,v 14.26 2003/01/01 02:25:54 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -72,7 +72,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port))))
+	     (guarantee-output-port port 'NEWLINE))))
     (output-port/write-char port #\newline)
     (output-port/discretionary-flush port)))
 
@@ -80,7 +80,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port))))
+	     (guarantee-output-port port 'FRESH-LINE))))
     (output-port/fresh-line port)
     (output-port/discretionary-flush port)))
 
@@ -88,7 +88,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port))))
+	     (guarantee-output-port port 'WRITE-CHAR))))
     (output-port/write-char port char)
     (output-port/discretionary-flush port)))
 
@@ -96,7 +96,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port))))
+	     (guarantee-output-port port 'WRITE-STRING))))
     (output-port/write-string port string)
     (output-port/discretionary-flush port)))
 
@@ -104,7 +104,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port))))
+	     (guarantee-output-port port 'WRITE-SUBSTRING))))
     (output-port/write-substring port string start end)
     (output-port/discretionary-flush port)))
 
@@ -113,7 +113,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
     (let ((port
 	   (if (default-object? port)
 	       (current-output-port)
-	       (guarantee-output-port port))))
+	       (guarantee-output-port port operation-name))))
       (let ((operation (port/operation port operation-name)))
 	(if operation
 	    (begin
@@ -127,7 +127,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port)))
+	     (guarantee-output-port port 'DISPLAY)))
 	(unparser-table
 	 (if (default-object? unparser-table)
 	     (current-unparser-table)
@@ -141,7 +141,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port)))
+	     (guarantee-output-port port 'WRITE)))
 	(unparser-table
 	 (if (default-object? unparser-table)
 	     (current-unparser-table)
@@ -153,7 +153,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((port
 	 (if (default-object? port)
 	     (current-output-port)
-	     (guarantee-output-port port)))
+	     (guarantee-output-port port 'WRITE-LINE)))
 	(unparser-table
 	 (if (default-object? unparser-table)
 	     (current-unparser-table)
@@ -166,4 +166,4 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (output-port/flush-output
    (if (default-object? port)
        (current-output-port)
-       (guarantee-output-port port))))
\ No newline at end of file
+       (guarantee-output-port port 'FLUSH-OUTPUT))))
\ No newline at end of file
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index b42912691..8d93ddb68 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.24 2002/11/20 19:46:22 cph Exp $
+$Id: port.scm,v 1.25 2003/01/01 02:26:11 cph Exp $
 
 Copyright (c) 1991-2002 Massachusetts Institute of Technology
 
@@ -302,24 +302,24 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	 (and (port-type/supports-input? type)
 	      (port-type/supports-output? type)))))
 
-(define (guarantee-port port)
+(define (guarantee-port port procedure)
   (if (not (port? port))
-      (error:wrong-type-argument port "port" #f))
+      (error:wrong-type-argument port "port" procedure))
   port)
 
-(define (guarantee-input-port port)
+(define (guarantee-input-port port procedure)
   (if (not (input-port? port))
-      (error:wrong-type-argument port "input port" #f))
+      (error:wrong-type-argument port "input port" procedure))
   port)
 
-(define (guarantee-output-port port)
+(define (guarantee-output-port port procedure)
   (if (not (output-port? port))
-      (error:wrong-type-argument port "output port" #f))
+      (error:wrong-type-argument port "output port" procedure))
   port)
 
-(define (guarantee-i/o-port port)
+(define (guarantee-i/o-port port procedure)
   (if (not (i/o-port? port))
-      (error:wrong-type-argument port "I/O port" #f))
+      (error:wrong-type-argument port "I/O port" procedure))
   port)
 
 ;;;; Encapsulation
@@ -334,7 +334,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
        (encapsulated-port-state? (%port/state object))))
 
 (define (guarantee-encapsulated-port object procedure)
-  (guarantee-port object)
+  (guarantee-port object procedure)
   (if (not (encapsulated-port-state? (%port/state object)))
       (error:wrong-type-argument object "encapsulated port" procedure)))
 
@@ -351,7 +351,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (set-encapsulated-port-state/state! (%port/state port) state))
 
 (define (make-encapsulated-port port state rewrite-operation)
-  (guarantee-port port)
+  (guarantee-port port 'MAKE-ENCAPSULATED-PORT)
   (%make-port (let ((type (port/type port)))
 		(make-port-type
 		 (append-map
@@ -641,55 +641,65 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (or *current-input-port* (nearest-cmdl/port)))
 
 (define (set-current-input-port! port)
-  (set! *current-input-port* (guarantee-input-port port))
+  (set! *current-input-port*
+	(guarantee-input-port port 'SET-CURRENT-INPUT-PORT!))
   unspecific)
 
 (define (with-input-from-port port thunk)
-  (fluid-let ((*current-input-port* (guarantee-input-port port)))
+  (fluid-let ((*current-input-port*
+	       (guarantee-input-port port 'WITH-INPUT-FROM-PORT)))
     (thunk)))
 
 (define (current-output-port)
   (or *current-output-port* (nearest-cmdl/port)))
 
 (define (set-current-output-port! port)
-  (set! *current-output-port* (guarantee-output-port port))
+  (set! *current-output-port*
+	(guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!))
   unspecific)
 
 (define (with-output-to-port port thunk)
-  (fluid-let ((*current-output-port* (guarantee-output-port port)))
+  (fluid-let ((*current-output-port*
+	       (guarantee-output-port port 'WITH-OUTPUT-TO-PORT)))
     (thunk)))
 
 (define (notification-output-port)
   (or *notification-output-port* (nearest-cmdl/port)))
 
 (define (set-notification-output-port! port)
-  (set! *notification-output-port* (guarantee-output-port port))
+  (set! *notification-output-port*
+	(guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!))
   unspecific)
 
 (define (with-notification-output-port port thunk)
-  (fluid-let ((*notification-output-port* (guarantee-output-port port)))
+  (fluid-let ((*notification-output-port*
+	       (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT)))
     (thunk)))
 
 (define (trace-output-port)
   (or *trace-output-port* (nearest-cmdl/port)))
 
 (define (set-trace-output-port! port)
-  (set! *trace-output-port* (guarantee-output-port port))
+  (set! *trace-output-port*
+	(guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!))
   unspecific)
 
 (define (with-trace-output-port port thunk)
-  (fluid-let ((*trace-output-port* (guarantee-output-port port)))
+  (fluid-let ((*trace-output-port*
+	       (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT)))
     (thunk)))
 
 (define (interaction-i/o-port)
   (or *interaction-i/o-port* (nearest-cmdl/port)))
 
 (define (set-interaction-i/o-port! port)
-  (set! *interaction-i/o-port* (guarantee-i/o-port port))
+  (set! *interaction-i/o-port*
+	(guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!))
   unspecific)
 
 (define (with-interaction-i/o-port port thunk)
-  (fluid-let ((*interaction-i/o-port* (guarantee-i/o-port port)))
+  (fluid-let ((*interaction-i/o-port*
+	       (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT)))
     (thunk)))
 
 (define standard-port-accessors
diff --git a/v7/src/runtime/stream.scm b/v7/src/runtime/stream.scm
index d913a92e8..a8c0bddfe 100644
--- a/v7/src/runtime/stream.scm
+++ b/v7/src/runtime/stream.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: stream.scm,v 14.13 2002/11/20 19:46:23 cph Exp $
+$Id: stream.scm,v 14.14 2003/01/01 02:26:49 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2002 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -233,7 +233,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 	    #\{
 	    (if (default-object? port)
 		(current-output-port)
-		(guarantee-output-port port))))))
+		(guarantee-output-port port 'STREAM-WRITE))))))
 
 (define (list->stream list)
   (if (pair? list)
diff --git a/v7/src/sicp/compat.scm b/v7/src/sicp/compat.scm
index 10873acc7..2d4919884 100644
--- a/v7/src/sicp/compat.scm
+++ b/v7/src/sicp/compat.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: compat.scm,v 1.9 2002/11/20 19:46:25 cph Exp $
+$Id: compat.scm,v 1.10 2003/01/01 02:27:05 cph Exp $
 
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2002 Massachusetts Institute of Technology
 
 This file is part of MIT Scheme.
 
@@ -126,8 +126,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((char
 	 (read-char
 	  (if (default-object? port)
-	      (current-output-port)
-	      (guarantee-output-port port)))))
+	      (current-input-port)
+	      (guarantee-input-port port 'TYI)))))
     (if (char? char)
 	(char->ascii char)
 	char)))
@@ -136,8 +136,8 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (let ((char
 	 (peek-char
 	  (if (default-object? port)
-	      (current-output-port)
-	      (guarantee-output-port port)))))
+	      (current-input-port)
+	      (guarantee-input-port port 'TYIPEEK)))))
     (if (char? char)
 	(char->ascii char)
 	char)))
@@ -146,7 +146,7 @@ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
   (write-char (ascii->char ascii)
 	      (if (default-object? port)
 		  (current-output-port)
-		  (guarantee-output-port port))))
+		  (guarantee-output-port port 'TYO))))
 
 (define (print-depth #!optional newval)
   (let ((newval (if (default-object? newval) false newval)))