From ebdc10d6061ecd23a789f45a3857f99d4bcc0259 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 2 Feb 2008 02:02:53 +0000 Subject: [PATCH] Eliminate direct use of make-gstate in string I/O ports, by extending MAKE-GENERIC-I/O-PORT to take extra arguments. --- v7/src/runtime/genio.scm | 6 +++--- v7/src/runtime/runtime.pkg | 8 +------- v7/src/runtime/strnin.scm | 33 ++++++++++++++++++--------------- v7/src/runtime/strott.scm | 19 +++++++++---------- v7/src/runtime/strout.scm | 22 ++++++++++++---------- 5 files changed, 43 insertions(+), 45 deletions(-) diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index 72e4fb67c..2cdbd4f4a 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: genio.scm,v 1.58 2008/02/02 01:48:51 cph Exp $ +$Id: genio.scm,v 1.59 2008/02/02 02:02:48 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -30,7 +30,7 @@ USA. (declare (usual-integrations)) -(define (make-generic-i/o-port source sink #!optional type) +(define (make-generic-i/o-port source sink #!optional type . extra-state) (if (not (or source sink)) (error "Missing arguments.")) (let ((port @@ -38,7 +38,7 @@ USA. (generic-i/o-port-type (source-type source) (sink-type sink)) type) - (make-gstate source sink 'TEXT 'TEXT)))) + (apply make-gstate source sink 'TEXT 'TEXT extra-state)))) (let ((ib (port-input-buffer port))) (if ib ((source/set-port (input-buffer-source ib)) port))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 891d25260..476289b5f 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.632 2008/02/02 01:48:52 cph Exp $ +$Id: runtime.pkg,v 14.633 2008/02/02 02:02:49 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -1769,12 +1769,6 @@ USA. output-buffer-using-binary-denormalizer? port-input-buffer port-output-buffer) - (export (runtime string-input) - make-gstate) - (export (runtime string-output) - make-gstate) - (export (runtime truncated-string-output) - make-gstate) (initialization (initialize-package!))) (define-package (runtime gensym) diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index 71ae4f405..053708a8f 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strnin.scm,v 14.22 2008/02/02 01:48:54 cph Exp $ +$Id: strnin.scm,v 14.23 2008/02/02 02:02:51 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -35,20 +35,23 @@ 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))) - (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-gstate (make-string-source string start end) - #f - 'ISO-8859-1 - 'NEWLINE)))) + (let ((port + (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-generic-i/o-port (make-string-source string start end) + #f + input-string-port-type)))) + (port/set-coding port 'ISO-8859-1) + (port/set-line-ending port 'NEWLINE) + port)) (define (call-with-input-string string procedure) (let ((port (open-input-string string))) diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm index 8e8df4e56..05e7920e1 100644 --- a/v7/src/runtime/strott.scm +++ b/v7/src/runtime/strott.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strott.scm,v 14.19 2008/02/02 01:48:55 cph Exp $ +$Id: strott.scm,v 14.20 2008/02/02 02:02:52 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -34,15 +34,14 @@ USA. (call-with-current-continuation (lambda (k) (let ((port - (make-port output-string-port-type - (receive (sink extract extract!) - (make-accumulator-sink limit k) - (make-gstate #f - sink - 'ISO-8859-1 - 'NEWLINE - extract - extract!))))) + (receive (sink extract extract!) (make-accumulator-sink limit k) + (make-generic-i/o-port #f + sink + output-string-port-type + extract + extract!)))) + (port/set-coding port 'ISO-8859-1) + (port/set-line-ending port 'NEWLINE) (generator port) (cons #f (get-output-string port)))))) diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index 89ae4a894..cf860d644 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strout.scm,v 14.30 2008/02/02 01:48:56 cph Exp $ +$Id: strout.scm,v 14.31 2008/02/02 02:02:53 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -31,15 +31,17 @@ USA. (declare (usual-integrations)) (define (open-output-string) - (make-port accumulator-output-port-type - (receive (sink extract extract! position) (make-accumulator-sink) - (make-gstate #f - sink - 'ISO-8859-1 - 'NEWLINE - extract - extract! - position)))) + (let ((port + (receive (sink extract extract! position) (make-accumulator-sink) + (make-generic-i/o-port #f + sink + accumulator-output-port-type + extract + extract! + position)))) + (port/set-coding port 'ISO-8859-1) + (port/set-line-ending port 'NEWLINE) + port)) (define (get-output-string port) ((port/operation port 'EXTRACT-OUTPUT) port)) -- 2.25.1