From 88269a157d660447237f477f117f87ab4ad7430a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 29 Nov 2005 06:54:11 +0000
Subject: [PATCH] Add support for codings and line endings to string ports.
---
v7/src/runtime/genio.scm | 16 +++++++++++-----
v7/src/runtime/runtime.pkg | 11 ++++++++++-
v7/src/runtime/strnin.scm | 31 ++++++++++++++++---------------
v7/src/runtime/strott.scm | 13 ++++++++-----
v7/src/runtime/strout.scm | 13 ++++++++-----
5 files changed, 53 insertions(+), 31 deletions(-)
diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index c53889b6d..5e7a9f276 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,9 +1,9 @@
#| -*-Scheme-*-
-$Id: genio.scm,v 1.32 2004/05/27 16:06:31 cph Exp $
+$Id: genio.scm,v 1.33 2005/11/29 06:41:45 cph Exp $
Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -43,7 +43,7 @@ USA.
(define-structure (gstate (type vector) (constructor #f))
;; Changes to this structure must be copied to "fileio.scm" and
- ;; "ttyio.scm".
+ ;; "ttyio.scm", "strnin.scm", "strout.scm", and "strott.scm".
(input-buffer #f read-only #t)
(output-buffer #f read-only #t)
coding
@@ -116,6 +116,9 @@ USA.
(make-port-type (append input-operations
output-operations
other-operations)
+ #f))
+ (set! generic-no-i/o-type
+ (make-port-type other-operations
#f)))
(initialize-name-maps!)
(initialize-conditions!))
@@ -123,6 +126,7 @@ USA.
(define generic-input-type)
(define generic-output-type)
(define generic-i/o-type)
+(define generic-no-i/o-type)
;;;; Input operations
@@ -312,7 +316,8 @@ USA.
(eq-intersection (known-input-codings)
(known-output-codings)))
((input-port? port) (known-input-codings))
- (else (known-output-codings))))
+ ((output-port? port) (known-output-codings))
+ (else '())))
(define (generic-io/line-ending port)
(gstate-line-ending (port/state port)))
@@ -340,7 +345,8 @@ USA.
(eq-intersection (known-input-line-endings)
(known-output-line-endings)))
((input-port? port) (known-input-line-endings))
- (else (known-output-line-endings))))
+ ((output-port? port) (known-output-line-endings))
+ (else '())))
(define (line-ending channel name for-output?)
(guarantee-symbol name #f)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 9b9bf2850..78cd5c33d 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.565 2005/10/24 02:30:08 cph Exp $
+$Id: runtime.pkg,v 14.566 2005/11/29 06:46:06 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -1737,6 +1737,15 @@ USA.
generic-input-type
generic-output-type
make-gstate)
+ (export (runtime string-input)
+ generic-no-i/o-type
+ make-gstate)
+ (export (runtime string-output)
+ generic-no-i/o-type
+ make-gstate)
+ (export (runtime truncated-string-output)
+ generic-no-i/o-type
+ make-gstate)
(initialization (initialize-package!)))
(define-package (runtime gensym)
diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm
index 9a278aa00..3a769a051 100644
--- a/v7/src/runtime/strnin.scm
+++ b/v7/src/runtime/strnin.scm
@@ -1,8 +1,9 @@
#| -*-Scheme-*-
-$Id: strnin.scm,v 14.13 2004/02/16 05:38:37 cph Exp $
+$Id: strnin.scm,v 14.14 2005/11/29 06:50:59 cph Exp $
Copyright 1988,1990,1993,1999,2003,2004 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -33,19 +34,17 @@ USA.
(define (open-input-string string #!optional start end)
(guarantee-string string 'OPEN-INPUT-STRING)
- (let ((end
- (if (or (default-object? end) (not end))
- (string-length string)
- (guarantee-substring-end-index end (string-length string)
- 'OPEN-INPUT-STRING))))
+ (let* ((end
+ (if (or (default-object? end) (not end))
+ (string-length string)
+ (guarantee-substring-end-index end (string-length string)
+ 'OPEN-INPUT-STRING)))
+ (start
+ (if (or (default-object? start) (not start))
+ 0
+ (guarantee-substring-start-index start end 'OPEN-INPUT-STRING))))
(make-port input-string-port-type
- (make-istate
- string
- (if (or (default-object? start) (not start))
- 0
- (guarantee-substring-start-index start end
- 'OPEN-INPUT-STRING))
- end))))
+ (make-gstate #f #f 'TEXT string start end))))
(define input-string-port-type)
(define (initialize-package!)
@@ -70,10 +69,12 @@ USA.
,(lambda (port output-port)
port
(write-string " from string" output-port))))
- #f))
+ generic-no-i/o-type))
unspecific)
-(define-structure (istate (type vector))
+(define-structure (istate (type vector)
+ (initial-offset 4) ;must match "genio.scm"
+ (constructor #f))
(string #f read-only #t)
start
(end #f read-only #t))
\ No newline at end of file
diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm
index 2eef3c220..03ff27067 100644
--- a/v7/src/runtime/strott.scm
+++ b/v7/src/runtime/strott.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: strott.scm,v 14.12 2004/02/16 05:38:42 cph Exp $
+$Id: strott.scm,v 14.13 2005/11/29 06:52:28 cph Exp $
-Copyright 1988,1993,1999,2004 Massachusetts Institute of Technology
+Copyright 1988,1993,1999,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
@@ -31,7 +31,8 @@ USA.
(define (with-output-to-truncated-string max thunk)
(call-with-current-continuation
(lambda (k)
- (let ((state (make-astate k max (make-string (fix:min max 128)) 0)))
+ (let ((state
+ (make-gstate #f #f 'TEXT k max (make-string (fix:min max 128)) 0)))
(with-output-to-port (make-port output-string-port-type state)
thunk)
(cons #f
@@ -64,10 +65,12 @@ USA.
,(lambda (port output-port)
port
(write-string " to string (truncating)" output-port))))
- #f))
+ generic-no-i/o-type))
unspecific)
-(define-structure (astate (type vector))
+(define-structure (astate (type vector)
+ (initial-offset 4) ;must match "genio.scm"
+ (constructor #f))
(return #f read-only #t)
(max-length #f read-only #t)
chars
diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm
index 0ba38a823..d5977d0e3 100644
--- a/v7/src/runtime/strout.scm
+++ b/v7/src/runtime/strout.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: strout.scm,v 14.20 2005/05/30 04:10:38 cph Exp $
+$Id: strout.scm,v 14.21 2005/11/29 06:54:11 cph Exp $
Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology
Copyright 2003,2004,2005 Massachusetts Institute of Technology
@@ -30,7 +30,8 @@ USA.
(declare (usual-integrations))
(define (open-output-string)
- (make-port accumulator-output-port-type (make-astate)))
+ (make-port accumulator-output-port-type
+ (make-gstate #f #f 'TEXT #f #f)))
(define (get-output-string port)
((port/operation port 'EXTRACT-OUTPUT) port))
@@ -48,8 +49,10 @@ USA.
(lambda (port)
(with-output-to-port port thunk))))
-(define-structure (astate (type vector) (constructor make-astate ()))
- (chars #f)
+(define-structure (astate (type vector)
+ (initial-offset 4) ;must match "genio.scm"
+ (constructor #f))
+ chars
index)
(define (maybe-reset-astate state)
@@ -123,5 +126,5 @@ USA.
,(lambda (port output-port)
port
(write-string " to string" output-port))))
- #f))
+ generic-no-i/o-type))
unspecific)
\ No newline at end of file
--
2.25.1