From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 4 Nov 2004 03:00:47 +0000 (+0000)
Subject: Change MAKE-EOF-OBJECT to return the same object if called twice with
X-Git-Tag: 20090517-FFI~1483
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8d4b3f21e38c96674b939ed641004375305429d;p=mit-scheme.git

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 6a4a304ff..0787e2536 100644
--- 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)
 
 ;;;; High level
 
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index f87301df1..8aacd3d0f 100644
--- 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)))))
 
 (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))
 
 (set-record-type-unparser-method! <port>
   (lambda (state port)
@@ -636,6 +615,51 @@ USA.
     (and operation
 	 (operation port))))
 
+(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))
+
 (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 1c5c9cb66..f0ca2893a 100644
--- 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 7a84bb969..5e2e6c2bd 100644
--- 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