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 78c0682159e6cc6bdec71ec61017352effdff799..9eb077587aeab12c1dcfb4dc7b35fb2160f3e02a 100644 (file)
--- 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)))
 \f
 ;;;; 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 f3c81e01b973ae6597a136eae294488b6bc973b1..07f5a79fc770502ea31b56f6654edeaab62121cf 100644 (file)
--- 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))))
 \f
 ;;;; High level
 

diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 00e79f4cb575dc1ca5c3ce2a39fd0f7d33e926b3..f86725f3af88b2a6c4d3c90d69944be8272649f2 100644 (file)
--- 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)))))
 \f
@@ -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 95183d3ef595e6233a141028a7314046f31dc6c1..3651f35f66461eb0a1084596c98bf11d077dd3c8 100644 (file)
--- 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