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 6f8e78a8c4a44423b618df1bda8e0a8eea842c4a..ff08715a13a4c84cd6c61a595e5db40c2a9db9fa 100644 (file)
--- 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 dc590c8388e6220b25d56e07904a5f86c43353a7..2fff5b0cd02ce86e8732cbbcf7acb251e2b3e72f 100644 (file)
--- 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 24150f558aada41def1ebb426acb0661d8e95fd0..63ef69b14798dd546f05eeac82d3867cbd47b4d1 100644 (file)
--- 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 b42912691120b0707252d517fa9b022f0f1006eb..8d93ddb688b183a89f9b4bab12b5db96110c80c9 100644 (file)
--- 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)
 \f
 ;;;; 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 d913a92e8a07b91c4796047c43e575a1c2697a76..a8c0bddfe42914d678ce2804a5084a8c9972b6e7 100644 (file)
--- 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 10873acc7c5c772fb485ed547619465b290f62ff..2d4919884523ba4f663f5885e3b6af3de3233418 100644 (file)
--- 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)))