From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Oct 2006 03:15:29 +0000 (+0000)
Subject: Implement new output operations OUTPUT-PORT/LINE-START? and
X-Git-Tag: 20090517-FFI~878
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cb94a76ff1c4e8dcc00046a52b0d88898a0ac075;p=mit-scheme.git

Implement new output operations OUTPUT-PORT/LINE-START? and
OUTPUT-PORT/BYTES-WRITTEN.
---

diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 78c068215..9eb077587 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.44 2006/10/25 02:50:01 cph Exp $
+$Id: genio.scm,v 1.45 2006/10/25 03:15:09 cph Exp $
 
 Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -118,6 +118,7 @@ USA.
 	   (SET-INPUT-TERMINAL-MODE ,generic-io/set-input-terminal-mode)))
 	(ops:out1
 	 `((BUFFERED-OUTPUT-BYTES ,generic-io/buffered-output-bytes)
+	   (BYTES-WRITTEN ,generic-io/bytes-written)
 	   (CLOSE-OUTPUT ,generic-io/close-output)
 	   (FLUSH-OUTPUT ,generic-io/flush-output)
 	   (OUTPUT-COLUMN ,generic-io/output-column)
@@ -299,6 +300,9 @@ USA.
 
 (define (generic-io/buffered-output-bytes port)
   (output-buffer-start (port-output-buffer port)))
+
+(define (generic-io/bytes-written port)
+  (output-buffer-total (port-output-buffer port)))
 
 ;;;; Non-specific operations
 
@@ -849,6 +853,7 @@ USA.
   (sink #f read-only #t)
   (bytes #f read-only #t)
   start
+  total
   encode
   denormalize
   column)
@@ -857,6 +862,7 @@ USA.
   (%make-output-buffer sink
 		       (make-string byte-buffer-length)
 		       0
+		       0
 		       (name->encoder coder-name)
 		       (name->denormalizer
 			(line-ending ((sink/get-channel sink))
@@ -944,10 +950,9 @@ USA.
   (eq? (output-buffer-denormalize ob) binary-denormalizer))
 
 (define (encode-char ob char)
-  (set-output-buffer-start!
-   ob
-   (fix:+ (output-buffer-start ob)
-	  ((output-buffer-encode ob) ob (char->integer char)))))
+  (let ((n-bytes ((output-buffer-encode ob) ob (char->integer char))))
+    (set-output-buffer-start! ob (fix:+ (output-buffer-start ob) n-bytes))
+    (set-output-buffer-total! ob (fix:+ (output-buffer-total ob) n-bytes))))
 
 (define (set-output-buffer-coding! ob coding)
   (set-output-buffer-encode! ob (name->encoder coding))
@@ -963,7 +968,11 @@ USA.
 (define (write-substring:string ob string start end)
   (if (output-buffer-in-8-bit-mode? ob)
       (let ((bv (output-buffer-bytes ob))
-	    (be (output-buffer-end ob)))
+	    (be (output-buffer-end ob))
+	    (ok
+	     (lambda (n)
+	       (set-output-buffer-total! ob (fix:+ (output-buffer-total ob) n))
+	       n)))
 	(let loop ((i start) (bi (output-buffer-start ob)))
 	  (if (fix:< i end)
 	      (if (fix:< bi be)
@@ -973,12 +982,16 @@ USA.
 		  (begin
 		    (set-output-buffer-start! ob be)
 		    (let ((n (drain-output-buffer ob)))
-		      (cond ((not n) (and (fix:> i start) (fix:- i start)))
-			    ((fix:> n 0) (loop i (output-buffer-start ob)))
-			    (else (fix:- i start))))))
+		      (cond ((not n)
+			     (and (fix:> i start)
+				  (ok (fix:- i start))))
+			    ((fix:> n 0)
+			     (loop i (output-buffer-start ob)))
+			    (else
+			     (ok (fix:- i start)))))))
 	      (begin
 		(set-output-buffer-start! ob bi)
-		(fix:- end start)))))
+		(ok (fix:- end start))))))
       (let loop ((i start))
 	(if (fix:< i end)
 	    (if (write-next-char ob (string-ref string i))
diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index f3c81e01b..07f5a79fc 100644
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: output.scm,v 14.36 2005/03/30 03:50:18 cph Exp $
+$Id: output.scm,v 14.37 2006/10/25 03:15:15 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1992,1993,1999,2001,2002,2003 Massachusetts Institute of Technology
-Copyright 2004,2005 Massachusetts Institute of Technology
+Copyright 2004,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -57,6 +57,9 @@ USA.
 (define (output-port/fresh-line port)
   ((port/operation/fresh-line port) port))
 
+(define (output-port/line-start? port)
+  ((port/operation/line-start? port) port))
+
 (define (output-port/flush-output port)
   ((port/operation/flush-output port) port))
 
@@ -81,6 +84,11 @@ USA.
   (let ((operation (port/operation port 'OUTPUT-COLUMN)))
     (and operation
 	 (operation port))))
+
+(define (output-port/bytes-written port)
+  (let ((operation (port/operation port 'BYTES-WRITTEN)))
+    (and operation
+	 (operation port))))
 
 ;;;; High level
 
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 00e79f4cb..f86725f3a 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.43 2006/10/04 05:51:55 savannah-arthur Exp $
+$Id: port.scm,v 1.44 2006/10/25 03:15:22 cph Exp $
 
 Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
@@ -51,6 +51,7 @@ USA.
   (write-wide-substring #f read-only #t)
   (write-external-substring #f read-only #t)
   (fresh-line #f read-only #t)
+  (line-start? #f read-only #t)
   (flush-output #f read-only #t)
   (discretionary-flush-output #f read-only #t))
 
@@ -161,6 +162,7 @@ USA.
 		       (op 'WRITE-WIDE-SUBSTRING)
 		       (op 'WRITE-EXTERNAL-SUBSTRING)
 		       (op 'FRESH-LINE)
+		       (op 'LINE-START?)
 		       (op 'FLUSH-OUTPUT)
 		       (op 'DISCRETIONARY-FLUSH-OUTPUT)))))
 
@@ -492,6 +494,11 @@ USA.
 		    (not (char=? (port/previous port) #\newline)))
 	       (write-char port #\newline)
 	       0)))
+	((LINE-START)
+	 (lambda (port)
+	   (if (port/previous port)
+	       (char=? (port/previous port) #\newline)
+	       'UNKNOWN)))
 	((FLUSH-OUTPUT) flush-output)
 	((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
 	(else (op name))))))
@@ -567,6 +574,7 @@ USA.
   (define-port-operation write-wide-substring)
   (define-port-operation write-external-substring)
   (define-port-operation fresh-line)
+  (define-port-operation line-start?)
   (define-port-operation flush-output)
   (define-port-operation discretionary-flush-output))
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 95183d3ef..3651f35f6 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.599 2006/10/24 04:08:58 cph Exp $
+$Id: runtime.pkg,v 14.600 2006/10/25 03:15:29 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1940,6 +1940,7 @@ USA.
 	  port-type/discretionary-flush-output
 	  port-type/flush-output
 	  port-type/fresh-line
+	  port-type/line-start?
 	  port-type/operation
 	  port-type/operation-names
 	  port-type/operations
@@ -2016,6 +2017,7 @@ USA.
 	  port/operation/discretionary-flush-output
 	  port/operation/flush-output
 	  port/operation/fresh-line
+	  port/operation/line-start?
 	  port/operation/write-char
 	  port/operation/write-external-substring
 	  port/operation/write-substring
@@ -2076,10 +2078,12 @@ USA.
 	  flush-output
 	  fresh-line
 	  newline
+	  output-port/bytes-written
 	  output-port/column
 	  output-port/discretionary-flush
 	  output-port/flush-output
 	  output-port/fresh-line
+	  output-port/line-start?
 	  output-port/write-char
 	  output-port/write-object
 	  output-port/write-external-string