From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 21 Feb 1997 05:42:58 +0000 (+0000)
Subject: Guarantee that all input ports have a READ-SUBSTRING operation.
X-Git-Tag: 20090517-FFI~5256
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7191c8ed16cab610a5765ac6332cd7f442317f8a;p=mit-scheme.git

Guarantee that all input ports have a READ-SUBSTRING operation.
Implement procedures READ-STRING! and READ-LINE.
---

diff --git a/v7/src/runtime/chrset.scm b/v7/src/runtime/chrset.scm
index ccd5f23ad..b88ca3cd6 100644
--- a/v7/src/runtime/chrset.scm
+++ b/v7/src/runtime/chrset.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: chrset.scm,v 14.4 1995/11/07 04:39:57 adams Exp $
+$Id: chrset.scm,v 14.5 1997/02/21 05:42:22 cph Exp $
 
-Copyright (c) 1988-1995 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -42,8 +42,6 @@ MIT in each case. |#
        (= (string-length object) 256)
        (not (string-find-next-char-in-set object char-set:not-01))))
 
-(define char-set:not-01)
-
 (define (char-set . chars)
   (chars->char-set chars))
 
@@ -123,6 +121,8 @@ MIT in each case. |#
 (define char-set:alphabetic)
 (define char-set:alphanumeric)
 (define char-set:standard)
+(define char-set:not-01)
+(define char-set:newline)
 
 (define (initialize-package!)
   (set! char-set:upper-case (ascii-range->char-set #x41 #x5B))
@@ -139,7 +139,9 @@ MIT in each case. |#
 	(char-set-union char-set:alphabetic char-set:numeric))
   (set! char-set:standard
 	(char-set-union char-set:graphic (char-set char:newline)))
-  (set! char-set:not-01 (ascii-range->char-set #x02 #x100)))
+  (set! char-set:not-01 (ascii-range->char-set #x02 #x100))
+  (set! char-set:newline (char-set char:newline))
+  unspecific)
 
 (define-integrable (char-upper-case? char)
   (char-set-member? char-set:upper-case char))
diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm
index 086a16313..8010ef1d0 100644
--- a/v7/src/runtime/input.scm
+++ b/v7/src/runtime/input.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: input.scm,v 14.16 1993/10/21 11:49:45 cph Exp $
+$Id: input.scm,v 14.17 1997/02/21 05:42:32 cph Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -57,6 +57,18 @@ MIT in each case. |#
 (define (input-port/discard-chars port delimiters)
   ((input-port/operation/discard-chars port) port delimiters))
 
+(define (input-port/read-substring! port string start end)
+  ((input-port/operation/read-substring port) port string start end))
+
+(define (input-port/read-string! port string)
+  (input-port/read-substring! port string 0 (string-length string)))
+
+(define (input-port/read-line port)
+  (let ((line (input-port/read-string port char-set:newline)))
+    ;; Discard delimiter, if any -- this is a no-op at EOF.
+    (input-port/discard-char port)
+    line))
+
 (define eof-object
   "EOF Object")
 
@@ -124,4 +136,21 @@ MIT in each case. |#
 		    (guarantee-input-port port))
 		(if (default-object? parser-table)
 		    (current-parser-table)
-		    parser-table)))
\ No newline at end of file
+		    parser-table)))
+
+(define (read-line #!optional port)
+  (input-port/read-line (if (default-object? port)
+			    (current-input-port)
+			    (guarantee-input-port port))))
+
+(define (read-string! string #!optional start end port)
+  (input-port/read-substring! string
+			      (if (default-object? start)
+				  0
+				  start)
+			      (if (default-object? end)
+				  (string-length string)
+				  end)
+			      (if (default-object? port)
+				  (current-input-port)
+				  (guarantee-input-port port))))
\ No newline at end of file
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index c1c3dd510..aaa4ca414 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.8 1994/08/15 19:14:15 cph Exp $
+$Id: port.scm,v 1.9 1997/02/21 05:42:40 cph Exp $
 
-Copyright (c) 1991-94 Massachusetts Institute of Technology
+Copyright (c) 1991-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -50,6 +50,7 @@ MIT in each case. |#
       DISCARD-CHAR
       READ-STRING
       DISCARD-CHARS
+      READ-SUBSTRING
       ;; output operations:
       WRITE-CHAR
       WRITE-STRING
@@ -84,6 +85,9 @@ MIT in each case. |#
 (define input-port/operation/discard-chars
   (record-accessor port-rtd 'DISCARD-CHARS))
 
+(define input-port/operation/read-substring
+  (record-accessor port-rtd 'READ-SUBSTRING))
+
 (define output-port/operation/write-char
   (record-accessor port-rtd 'WRITE-CHAR))
 
@@ -98,7 +102,7 @@ MIT in each case. |#
 
 (define output-port/operation/discretionary-flush
   (record-accessor port-rtd 'DISCRETIONARY-FLUSH-OUTPUT))
-
+
 (set-record-type-unparser-method! port-rtd
   (lambda (state port)
     ((let ((name
@@ -116,7 +120,7 @@ MIT in each case. |#
 	      (standard-unparser-method name #f))))
      state
      port)))
-
+
 (define (port/copy port state)
   (let ((port (record-copy port)))
     (set-port/state! port state)
@@ -285,7 +289,7 @@ MIT in each case. |#
 (define install-input-operations!
   (let ((operation-names
 	 '(CHAR-READY? PEEK-CHAR READ-CHAR
-		       DISCARD-CHAR READ-STRING DISCARD-CHARS)))
+		       DISCARD-CHAR READ-STRING DISCARD-CHARS READ-SUBSTRING)))
     (let ((updaters
 	   (map (lambda (name)
 		  (record-updater port-rtd name))
@@ -309,7 +313,8 @@ MIT in each case. |#
 			      false
 			      (caddr operations)
 			      default-operation/read-string
-			      default-operation/discard-chars)
+			      default-operation/discard-chars
+			      default-operation/read-substring)
 			operation-names)
 	      (set-port/operation-names!
 	       port
@@ -322,7 +327,7 @@ MIT in each case. |#
 	      (for-each (lambda (updater)
 			  (updater port false))
 			updaters)))))))
-
+
 (define (default-operation/char-ready? port interval)
   port interval
   true)
@@ -356,6 +361,22 @@ MIT in each case. |#
 	    (begin
 	      (discard-char port)
 	      (loop)))))))
+
+(define (default-operation/read-substring port string start end)
+  (let ((read-char (input-port/operation/read-char port)))
+    (let loop ((index start))
+      (if (fix:< index end)
+	  (let ((char (read-char port)))
+	    (cond ((not char)
+		   (if (fix:= index start)
+		       #f
+		       (fix:- index start)))
+		  ((eof-object? char)
+		   (fix:- index start))
+		  (else
+		   (string-set! string index char)
+		   (loop (fix:+ index 1)))))
+	  (fix:- index start)))))
 
 ;;;; Output Operations
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f99123eb0..9090478e7 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.274 1997/01/05 23:45:13 cph Exp $
+$Id: runtime.pkg,v 14.275 1997/02/21 05:42:58 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -205,6 +205,7 @@ MIT in each case. |#
 	  char-set:alphanumeric
 	  char-set:graphic
 	  char-set:lower-case
+	  char-set:newline
 	  char-set:not-graphic
 	  char-set:not-whitespace
 	  char-set:numeric
@@ -1012,6 +1013,7 @@ MIT in each case. |#
 	  input-port/operation/peek-char
 	  input-port/operation/read-char
 	  input-port/operation/read-string
+	  input-port/operation/read-substring
 	  input-port/state
 	  input-port?
 	  interaction-i/o-port
@@ -1086,13 +1088,18 @@ MIT in each case. |#
 	  input-port/discard-chars
 	  input-port/peek-char
 	  input-port/read-char
+	  input-port/read-line
 	  input-port/read-string
+	  input-port/read-string!
+	  input-port/read-substring!
 	  make-eof-object
 	  peek-char
 	  read
 	  read-char
 	  read-char-no-hang
-	  read-string)
+	  read-line
+	  read-string
+	  read-string!)
   (export (runtime primitive-io)
 	  eof-object))
 
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 93bd7227a..2b98b4796 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.281 1997/01/05 23:45:04 cph Exp $
+$Id: runtime.pkg,v 14.282 1997/02/21 05:42:48 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -205,6 +205,7 @@ MIT in each case. |#
 	  char-set:alphanumeric
 	  char-set:graphic
 	  char-set:lower-case
+	  char-set:newline
 	  char-set:not-graphic
 	  char-set:not-whitespace
 	  char-set:numeric
@@ -1012,6 +1013,7 @@ MIT in each case. |#
 	  input-port/operation/peek-char
 	  input-port/operation/read-char
 	  input-port/operation/read-string
+	  input-port/operation/read-substring
 	  input-port/state
 	  input-port?
 	  interaction-i/o-port
@@ -1086,13 +1088,18 @@ MIT in each case. |#
 	  input-port/discard-chars
 	  input-port/peek-char
 	  input-port/read-char
+	  input-port/read-line
 	  input-port/read-string
+	  input-port/read-string!
+	  input-port/read-substring!
 	  make-eof-object
 	  peek-char
 	  read
 	  read-char
 	  read-char-no-hang
-	  read-string)
+	  read-line
+	  read-string
+	  read-string!)
   (export (runtime primitive-io)
 	  eof-object))