Change MAKE-EOF-OBJECT to return the same object if called twice with

the same argument.

diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm
index 6a4a304ff88be351519c5b1b7c97beb99a249ae3..0787e2536a410f3450fac646558ab16d98994e13 100644 (file)
--- a/v7/src/runtime/input.scm
+++ b/v7/src/runtime/input.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: input.scm,v 14.27 2004/02/26 19:05:06 cph Exp $
+$Id: input.scm,v 14.28 2004/11/04 03:00:15 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1997,1999,2002,2003 Massachusetts Institute of Technology
@@ -134,9 +134,24 @@ USA.
   (cdr a))
 
 (define-record-type <eof-object>
-    (make-eof-object port)
+    (%make-eof-object port)
     eof-object?
   (port eof-object-port))
+
+(define (make-eof-object port)
+  (if port
+      (begin
+       (guarantee-input-port port 'MAKE-EOF-OBJECT)
+       (or (port/eof-object port)
+           (let ((eof (%make-eof-object port)))
+             (set-port/eof-object! port eof)
+             eof)))
+      (or saved-eof-object
+         (let ((eof (%make-eof-object port)))
+           (set! saved-eof-object eof)
+           eof))))
+
+(define saved-eof-object #f)
 \f
 ;;;; High level
 

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index f87301df17a4e7b7aeb21f7036892fd2f59a5481..8aacd3d0ffcdfbcd6bc0afe13de9d93234027ebc 100644 (file)
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.34 2004/09/14 20:00:05 cph Exp $
+$Id: port.scm,v 1.35 2004/11/04 03:00:25 cph Exp $
 
 Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
@@ -52,10 +52,7 @@ USA.
   (write-external-substring #f read-only #t)
   (fresh-line #f read-only #t)
   (flush-output #f read-only #t)
-  (discretionary-flush-output #f read-only #t)
-  ;; transcript operations:
-  (get-transcript-port #f read-only #t)
-  (set-transcript-port #f read-only #t))
+  (discretionary-flush-output #f read-only #t))
 
 (set-record-type-unparser-method! <port-type>
   (lambda (state type)
@@ -165,9 +162,7 @@ USA.
                       (op 'WRITE-EXTERNAL-SUBSTRING)
                       (op 'FRESH-LINE)
                       (op 'FLUSH-OUTPUT)
-                      (op 'DISCRETIONARY-FLUSH-OUTPUT)
-                      port/transcript
-                      set-port/transcript!))))
+                      (op 'DISCRETIONARY-FLUSH-OUTPUT)))))
 \f
 (define (parse-operations-list operations type)
   (parse-operations-list-1
@@ -351,8 +346,7 @@ USA.
                     (set-port/unread! port #f)
                     char)
                   (let ((char (defer port)))
-                    (if (and (port/transcript port) (char? char))
-                        (write-char char (port/transcript port)))
+                    (transcribe-char char port)
                     char))))))
        (unread-char
         (lambda (port char)
@@ -384,9 +378,7 @@ USA.
                   (set-port/unread! port #f)
                   1)
                 (let ((n (defer port string start end)))
-                  (if (and n (fix:> n 0) (port/transcript port))
-                      (write-substring string start (fix:+ start n)
-                                       (port/transcript port)))
+                  (transcribe-substring string start (fix:+ start n) port)
                   n)))))
        (read-wide-substring
         (let ((defer (op 'READ-WIDE-SUBSTRING)))
@@ -397,9 +389,9 @@ USA.
                   (set-port/unread! port #f)
                   1)
                 (let ((n (defer port string start end)))
-                  (if (and n (fix:> n 0) (port/transcript port))
-                      (write-substring string start (fix:+ start n)
-                                       (port/transcript port)))
+                  (if (and n (fix:> n 0))
+                      (transcribe-substring string start (fix:+ start n)
+                                            port))
                   n)))))
        (read-external-substring
         (let ((defer (op 'READ-EXTERNAL-SUBSTRING)))
@@ -412,9 +404,7 @@ USA.
                   (set-port/unread! port #f)
                   1)
                 (let ((n (defer port string start end)))
-                  (if (and n (> n 0) (port/transcript port))
-                      (write-substring string start (+ start n)
-                                       (port/transcript port)))
+                  (transcribe-substring string start (+ start n) port)
                   n))))))
     (lambda (name)
       (case name
@@ -438,8 +428,7 @@ USA.
               (if (and n (fix:> n 0))
                   (begin
                     (set-port/previous! port char)
-                    (if (port/transcript port)
-                        (write-char char (port/transcript port)))))
+                    (transcribe-char char port)))
               n))))
        (write-substring
         (let ((defer (op 'WRITE-SUBSTRING)))
@@ -450,9 +439,7 @@ USA.
                     (set-port/previous!
                      port
                      (string-ref string (fix:+ start (fix:- n 1))))
-                    (if (and (port/transcript port))
-                        (write-substring string start (fix:+ start n)
-                                         (port/transcript port)))))
+                    (transcribe-substring string start (fix:+ start n) port)))
               n))))
        (write-wide-substring
         (let ((defer (op 'WRITE-WIDE-SUBSTRING)))
@@ -463,9 +450,7 @@ USA.
                     (set-port/previous!
                      port
                      (string-ref string (fix:+ start (fix:- n 1))))
-                    (if (and (port/transcript port))
-                        (write-substring string start (fix:+ start n)
-                                         (port/transcript port)))))
+                    (transcribe-substring string start (fix:+ start n) port)))
               n))))
        (write-external-substring
         (let ((defer (op 'WRITE-EXTERNAL-SUBSTRING)))
@@ -476,22 +461,18 @@ USA.
                         (bounce (make-string 1)))
                     (xsubstring-move! string (- i 1) i bounce 0)
                     (set-port/previous! port (string-ref bounce 0))
-                    (if (port/transcript port)
-                        (write-substring string start i
-                                         (port/transcript port)))))
+                    (transcribe-substring string start i port)))
               n))))
        (flush-output
         (let ((defer (op 'FLUSH-OUTPUT)))
           (lambda (port)
             (defer port)
-            (if (port/transcript port)
-                (flush-output (port/transcript port))))))
+            (flush-transcript port))))
        (discretionary-flush-output
         (let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT)))
           (lambda (port)
             (defer port)
-            (if (port/transcript port)
-                (output-port/discretionary-flush (port/transcript port)))))))
+            (discretionary-flush-transcript port)))))
     (lambda (name)
       (case name
        ((WRITE-CHAR) write-char)
@@ -518,7 +499,7 @@ USA.
   (%thread-mutex (make-thread-mutex))
   (unread #f)
   (previous #f)
-  (transcript #f))
+  (properties '()))
 
 (define (make-port type state)
   (guarantee-port-type type 'MAKE-PORT)
@@ -580,9 +561,7 @@ USA.
   (define-port-operation write-external-substring)
   (define-port-operation fresh-line)
   (define-port-operation flush-output)
-  (define-port-operation discretionary-flush-output)
-  (define-port-operation get-transcript-port)
-  (define-port-operation set-transcript-port))
+  (define-port-operation discretionary-flush-output))
 \f
 (set-record-type-unparser-method! <port>
   (lambda (state port)
@@ -636,6 +615,51 @@ USA.
     (and operation
         (operation port))))
 \f
+(define (port/get-property port name default)
+  (let ((p (assq name (port/properties port))))
+    (if p
+       (cdr p)
+       default)))
+
+(define (port/set-property! port name value)
+  (let ((alist (port/properties port)))
+    (let ((p (assq name alist)))
+      (if p
+         (set-cdr! p value)
+         (set-port/properties! port (cons (cons name value) alist))))))
+
+(define (port/transcript port)
+  (port/get-property port 'TRANSCRIPT #f))
+
+(define (set-port/transcript! port tport)
+  (port/set-property! port 'TRANSCRIPT tport))
+
+(define (transcribe-char char port)
+  (let ((tport (port/transcript port)))
+    (if tport
+       (write-char char tport))))
+
+(define (transcribe-substring string start end port)
+  (let ((tport (port/transcript port)))
+    (if tport
+       (write-substring string start end tport))))
+
+(define (flush-transcript port)
+  (let ((tport (port/transcript port)))
+    (if tport
+       (flush-output tport))))
+
+(define (discretionary-flush-transcript port)
+  (let ((tport (port/transcript port)))
+    (if tport
+       (output-port/discretionary-flush tport))))
+
+(define (port/eof-object port)
+  (port/get-property port 'EOF-OBJECT #f))
+
+(define (set-port/eof-object! port eof)
+  (port/set-property! port 'EOF-OBJECT eof))
+\f
 (define (input-port? object)
   (and (port? object)
        (port-type/supports-input? (port/type object))))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 1c5c9cb660185e4be1c2eb9e61b9afa9f24ed2f1..f0ca2893aa7f50b4b17759729c5db8503253d140 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.506 2004/10/30 03:59:06 cph Exp $
+$Id: runtime.pkg,v 14.507 2004/11/04 03:00:38 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1848,7 +1848,6 @@ USA.
          port-type/discretionary-flush-output
          port-type/flush-output
          port-type/fresh-line
-         port-type/get-transcript-port
          port-type/operation
          port-type/operation-names
          port-type/operations
@@ -1857,7 +1856,6 @@ USA.
          port-type/read-external-substring
          port-type/read-substring
          port-type/read-wide-substring
-         port-type/set-transcript-port
          port-type/unread-char
          port-type/write-char
          port-type/write-external-substring
@@ -1908,6 +1906,7 @@ USA.
          with-output-to-port
          with-trace-output-port)
   (export (runtime input-port)
+         port/eof-object
          port/operation/char-ready?
          port/operation/discard-char
          port/operation/peek-char
@@ -1915,7 +1914,8 @@ USA.
          port/operation/read-external-substring
          port/operation/read-substring
          port/operation/read-wide-substring
-         port/operation/unread-char)
+         port/operation/unread-char
+         set-port/eof-object!)
   (export (runtime output-port)
          port/operation/discretionary-flush-output
          port/operation/flush-output
@@ -1925,8 +1925,8 @@ USA.
          port/operation/write-substring
          port/operation/write-wide-substring)
   (export (runtime transcript)
-         port/operation/get-transcript-port
-         port/operation/set-transcript-port)
+         port/transcript
+         set-port/transcript!)
   (export (runtime rep)
          *current-input-port*
          *current-output-port*

diff --git a/v7/src/runtime/tscript.scm b/v7/src/runtime/tscript.scm
index 7a84bb969d954185b552508cddcb7b7e0d921ca1..5e2e6c2bd26d4c07b82fab3ea506d2b09f786ee8 100644 (file)
--- a/v7/src/runtime/tscript.scm
+++ b/v7/src/runtime/tscript.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: tscript.scm,v 1.7 2004/02/16 05:39:03 cph Exp $
+$Id: tscript.scm,v 1.8 2004/11/04 03:00:47 cph Exp $
 
 Copyright 1990,1999,2004 Massachusetts Institute of Technology
 
@@ -30,20 +30,14 @@ USA.
 
 (define (transcript-on filename)
   (let ((port (nearest-cmdl/port)))
-    (if (get-transcript-port port)
+    (if (port/transcript port)
        (error "Transcript already turned on."))
-    (set-transcript-port port (open-output-file filename))))
+    (set-port/transcript! port (open-output-file filename))))
 
 (define (transcript-off)
   (let ((port (nearest-cmdl/port)))
-    (let ((transcript-port (get-transcript-port port)))
+    (let ((transcript-port (port/transcript port)))
       (if transcript-port
          (begin
-           (set-transcript-port port #f)
-           (close-port transcript-port))))))
-
-(define (get-transcript-port port)
-  ((port/operation/get-transcript-port port) port))
-
-(define (set-transcript-port port transcript-port)
-  ((port/operation/set-transcript-port port) port transcript-port))
\ No newline at end of file
+           (set-port/transcript! port #f)
+           (close-port transcript-port))))))
\ No newline at end of file