From: Chris Hanson Date: Mon, 16 Feb 2004 05:39:37 +0000 (+0000) Subject: The I/O subsystem has once again been redesigned. The primary goal of X-Git-Tag: 20090517-FFI~1695 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d125b052fc813686a5d1333a1126589629b5efeb;p=mit-scheme.git The I/O subsystem has once again been redesigned. The primary goal of this large change is to integrate support for Unicode and character coding directly into the I/O subsystem. Secondary goals are to improve I/O performance, to simplify the design, and to provide flexibility for future enhancement. This change set has received cursory testing, and no doubt a number of problems remain. Additionally, there are several unfinished aspects to the change. But this version works well enough to run Edwin. Detailed changes ---------------- The term "line translation" is everywhere replaced with "line ending". A line ending is now specified by a symbol, such as 'crlf or 'lf; previously it was a string. I/O files now support a single line ending for both input and output sides; previously there were two independent line translations. The I/O buffers have been completely redesigned. They now operate in three stages: one stage does byte-stream I/O, the second manages coding (e.g. UTF-8), and the third manages line endings. Only bytes are buffered. As a consequence, READ-CHAR and WRITE-CHAR will now handle any Unicode character, provided the port's coding is set to an appropriate value. The READ-SUBSTRING port operation can now assume that its START argument is strictly less than its END argument. Likewise for the new operations READ-WIDE-SUBSTRING and READ-EXTERNAL-SUBSTRING. The WRITE-SUBSTRING port operation now returns either #F or a non-negative integer. It can also now assume that its START argument is strictly less than its END argument. Both of these properties are true for the new WRITE-WIDE-SUBSTRING and WRITE-EXTERNAL-SUBSTRING. The WRITE-CHAR port operation now returns either #F, 0, or 1, as if it was a call to WRITE-SUBSTRING with a one-char string. The CHAR-READY? port operation and the INPUT-PORT/CHAR-READY? procedure no longer accept a second "interval" argument. Handling of the timeout interval is instead implemented directly in the CHAR-READY? procedure. Strings are always considered to be encoded using ISO-8859-1. The parser-buffer datatype has been widened to handle all Unicode characters. All ports now support the FRESH-LINE operation, which is implemented as a layer on top of the supplied operations. Similarly, the PEEK-CHAR, DISCARD-CHAR, and new UNREAD-CHAR operations are implemented for all ports. End-of-file objects now have an associated port. RUN-SHELL-COMMAND and RUN-SYNCHRONOUS-SUBPROCESS now accept a keyword argument LINE-ENDING, which replaces the old options INPUT-LINE-TRANSLATION and OUTPUT-LINE-TRANSLATION. Transcript support has been moved into the core port abstraction. Consequently, it is no longer necessary to encapsulate a port in order to get transcript support. Encapsulated ports have been eliminated, as this was their only use. The procedures OPEN-TCP-STREAM-SOCKET, OPEN-UNIX-STREAM-SOCKET, SUBPROCESS-I/O-PORT, and TCP-SERVER-CONNECTION-ACCEPT have changed their argument structure. All arguments dealing with buffer size and line translation have been eliminated. In the new implementation, the buffer size is fixed, and handling of line endings is changed by calling PORT/SET-LINE-ENDING. The following variables have been eliminated: CHANNEL-WRITE-CHAR-BLOCK CHANNEL-WRITE-STRING-BLOCK ENCAPSULATED-PORT/PORT ENCAPSULATED-PORT/STATE ENCAPSULATED-PORT? GUARANTEE-ENCAPSULATED-PORT INPUT-PORT/CHANNEL INPUT-PORT/COPY INPUT-PORT/CUSTOM-OPERATION INPUT-PORT/OPERATION INPUT-PORT/OPERATION INPUT-PORT/OPERATION-NAMES INPUT-PORT/STATE MAKE-ENCAPSULATED-PORT MAKE-GENERIC-INPUT-PORT MAKE-GENERIC-OUTPUT-PORT MAKE-I/O-PORT MAKE-INPUT-PORT MAKE-OUTPUT-PORT MATCH-UTF8-CHAR-IN-ALPHABET OUTPUT-PORT/CHANNEL OUTPUT-PORT/COPY OUTPUT-PORT/CUSTOM-OPERATION OUTPUT-PORT/OPERATION OUTPUT-PORT/OPERATION OUTPUT-PORT/OPERATION-NAMES OUTPUT-PORT/STATE PATHNAME-END-OF-LINE-STRING PATHNAME-NEWLINE-TRANSLATION SET-ENCAPSULATED-PORT/STATE! SET-INPUT-PORT/STATE! SET-OUTPUT-PORT/STATE! The following port operations have been eliminated: BUFFERED-INPUT-CHARS BUFFERED-OUTPUT-CHARS CHARS-REMAINING DISCARD-CHAR DISCARD-CHARS FRESH-LINE INPUT-BUFFER-SIZE OUTPUT-BUFFER-SIZE PEEK-CHAR READ-STRING REST->STRING SET-INPUT-BUFFER-SIZE SET-OUTPUT-BUFFER-SIZE To do: * locking * column tracking * convert parser from peek/discard to read/unread * [?] integrate parser-buffer support (port.scm/input.scm) * change buffer I/O ports to handle line endings as needed Change arg structure of: char-ready? port operation input-port/char-ready? make-generic-i/o-port make-input-buffer make-output-buffer open-tcp-stream-socket open-unix-stream-socket subprocess-i/o-port tcp-server-connection-accept Renamed variables: os/default-end-of-line-translation => default-line-ending os/file-end-of-line-translation => file-line-ending New variables: channel-has-input? channel-write-byte-block condition-type:char-decoding-error condition-type:char-encoding-error condition-type:not-8-bit-char console-i/o-port? eof-object-port error:char-decoding error:char-encoding error:not-8-bit-char guarantee-wide-substring input-port/read-external-substring input-port/read-wide-substring input-port/unread-char match-parser-buffer-char-in-alphabet match-parser-buffer-char-in-alphabet-no-advance match-parser-buffer-char-not-in-alphabet match-parser-buffer-char-not-in-alphabet-no-advance match-parser-buffer-char-not-in-set match-parser-buffer-char-not-in-set-no-advance output-port/write-external-substring output-port/write-wide-substring port/coding port/line-ending port/set-coding port/set-line-ending port=? set-channel-port! unread-char wide-string->parser-buffer wide-substring wide-substring->parser-buffer New port operations: coding line-ending read-external-substring read-wide-substring set-coding set-line-ending write-external-substring write-wide-substring --- diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm index e3b748827..c4ce7b2ed 100644 --- a/v7/src/runtime/dosprm.scm +++ b/v7/src/runtime/dosprm.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: dosprm.scm,v 1.46 2003/02/14 18:28:32 cph Exp $ +$Id: dosprm.scm,v 1.47 2004/02/16 05:35:53 cph Exp $ Copyright 1992,1993,1994,1995,1996,1998 Massachusetts Institute of Technology -Copyright 1999,2000,2003 Massachusetts Institute of Technology +Copyright 1999,2000,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -281,12 +281,12 @@ USA. ((ucode-primitive directory-delete 1) (->namestring (directory-pathname-as-file (merge-pathnames name))))) -(define (os/file-end-of-line-translation pathname) +(define (file-line-ending pathname) pathname - "\r\n") + 'CRLF) -(define (os/default-end-of-line-translation) - "\r\n") +(define (default-line-ending) + 'CRLF) (define (initialize-system-primitives!) (let ((reset! diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm index 883070582..7ab039910 100644 --- a/v7/src/runtime/dospth.scm +++ b/v7/src/runtime/dospth.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: dospth.scm,v 1.43 2003/02/14 18:28:32 cph Exp $ +$Id: dospth.scm,v 1.44 2004/02/16 05:36:00 cph Exp $ -Copyright (c) 1992-2001 Massachusetts Institute of Technology +Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology +Copyright 1998,1999,2001,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,8 +29,6 @@ USA. (declare (usual-integrations)) -(define hook/dos/end-of-line-string) - (define sub-directory-delimiters ;; Allow forward slashes as well as backward slashes so that ;; - improperly-written scripts (e.g. compiler/comp.sf) will work @@ -57,11 +56,9 @@ USA. dos/pathname->truename dos/user-homedir-pathname dos/init-file-pathname - dos/pathname-simplify - dos/end-of-line-string)) + dos/pathname-simplify)) (define (initialize-package!) - (set! hook/dos/end-of-line-string default/dos/end-of-line-string) (add-pathname-host-type! 'DOS make-dos-host-type)) ;;;; Pathname Parser @@ -405,10 +402,4 @@ USA. (->namestring pathname) (->namestring pathname*)) pathname*)))))) - pathname))) - -(define (dos/end-of-line-string pathname) - (hook/dos/end-of-line-string pathname)) - -(define (default/dos/end-of-line-string pathname) - (or (os/file-end-of-line-translation pathname) "\n")) \ No newline at end of file + pathname))) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index a9a14ccbd..aa1641837 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: emacs.scm,v 14.32 2003/10/15 17:06:55 cph Exp $ +$Id: emacs.scm,v 14.33 2004/02/16 05:36:06 cph Exp $ Copyright 1986,1987,1991,1993,1994,1999 Massachusetts Institute of Technology -Copyright 2001,2003 Massachusetts Institute of Technology +Copyright 2001,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -239,7 +239,7 @@ USA. (READ-FINISH ,emacs/read-finish) (GC-START ,emacs/gc-start) (GC-FINISH ,emacs/gc-finish)) - the-console-port-type) + (port/type the-console-port)) (port/state the-console-port))) ;; YUCCH! Kludge to copy mutex of console port into emacs port. (set-port/thread-mutex! emacs-console-port @@ -257,11 +257,8 @@ USA. (not (eq? port new-port))))) (replacement-port (lambda (port) - (cond ((old-port? port) new-port) - ((and (transcriptable-port? port) - (old-port? (encapsulated-port/port port))) - (make-transcriptable-port new-port)) - (else #f))))) + (and (old-port? port) + new-port)))) (if (let ((port console-i/o-port)) (or (eq? port the-console-port) (eq? port emacs-console-port))) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 1c00e123d..aa6d96840 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.64 2003/10/10 17:35:42 cph Exp $ +$Id: error.scm,v 14.65 2004/02/16 05:36:11 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1995,2000,2001,2002 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -684,6 +684,7 @@ USA. (define condition-type:illegal-pathname-component) (define condition-type:macro-binding) (define condition-type:no-such-restart) +(define condition-type:not-8-bit-char) (define condition-type:port-error) (define condition-type:serious-condition) (define condition-type:simple-condition) @@ -711,6 +712,7 @@ USA. (define error:derived-thread) (define error:illegal-pathname-component) (define error:macro-binding) +(define error:not-8-bit-char) (define error:unassigned-variable) (define error:unbound-variable) (define error:wrong-number-of-arguments) @@ -1102,6 +1104,13 @@ USA. condition-type:arithmetic-error '() (arithmetic-error-report "Floating-point underflow")))) + + (set! condition-type:not-8-bit-char + (make-condition-type 'NOT-8-BIT-CHAR condition-type:error '(CHAR) + (lambda (condition port) + (write-string "Character too large for 8-bit string: " port) + (write (access-condition condition 'CHAR) port) + (newline port)))) (set! make-simple-error (condition-constructor condition-type:simple-error @@ -1154,7 +1163,10 @@ USA. (condition-signaller condition-type:macro-binding '(ENVIRONMENT LOCATION) standard-error-handler)) - + (set! error:not-8-bit-char + (condition-signaller condition-type:not-8-bit-char + '(CHAR) + standard-error-handler)) unspecific) ;;;; Utilities diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm index 21c931fb0..6a93d9a30 100644 --- a/v7/src/runtime/fileio.scm +++ b/v7/src/runtime/fileio.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: fileio.scm,v 1.21 2003/02/14 18:28:32 cph Exp $ +$Id: fileio.scm,v 1.22 2004/02/16 05:36:25 cph Exp $ -Copyright (c) 1991-2001 Massachusetts Institute of Technology +Copyright 1991,1993,1994,1995,1996,1999 Massachusetts Institute of Technology +Copyright 2001,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -30,8 +31,7 @@ USA. (define (initialize-package!) (let ((input-operations - `((LENGTH ,operation/length) - (REST->STRING ,operation/rest->string))) + `((LENGTH ,operation/length))) (other-operations `((WRITE-SELF ,operation/write-self) (PATHNAME ,operation/pathname) @@ -51,72 +51,67 @@ USA. (define output-file-type) (define i/o-file-type) -(define input-buffer-size 512) -(define output-buffer-size 512) +(define-structure (fstate (type vector) + (initial-offset 4) ;must match "genio.scm" + (constructor #f)) + (pathname #f read-only #t)) + +(define (operation/length port) + (channel-file-length (port/input-channel port))) + +(define (operation/pathname port) + (fstate-pathname (port/state port))) + +(define operation/truename + ;; This works for unix because truename and pathname are the same. + ;; On operating system where they differ, there must be support to + ;; determine the truename. + operation/pathname) + +(define (operation/write-self port output-port) + (write-string " for file: " output-port) + (write (operation/truename port) output-port)) (define (open-input-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) (port - (make-port - input-file-type - (make-file-state - (make-input-buffer channel - input-buffer-size - (pathname-newline-translation pathname)) - #f - pathname)))) + (make-port input-file-type + (make-gstate channel #f 'TEXT pathname)))) (set-channel-port! channel port) + (port/set-line-ending port (file-line-ending pathname)) port)) (define (open-output-file filename #!optional append?) (let* ((pathname (merge-pathnames filename)) (channel (let ((filename (->namestring pathname))) - (if (and (not (default-object? append?)) append?) + (if (if (default-object? append?) #f append?) (file-open-append-channel filename) (file-open-output-channel filename)))) (port - (make-port - output-file-type - (make-file-state - #f - (make-output-buffer channel - output-buffer-size - (pathname-newline-translation pathname)) - pathname)))) + (make-port output-file-type + (make-gstate #f channel 'TEXT pathname)))) (set-channel-port! channel port) + (port/set-line-ending port (file-line-ending pathname)) port)) (define (open-i/o-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-io-channel (->namestring pathname))) - (translation (pathname-newline-translation pathname)) (port - (make-port - i/o-file-type - (make-file-state - (make-input-buffer channel input-buffer-size translation) - (make-output-buffer channel output-buffer-size translation) - pathname)))) + (make-port i/o-file-type + (make-gstate channel channel 'TEXT pathname)))) (set-channel-port! channel port) + (port/set-line-ending port (file-line-ending pathname)) port)) -(define (pathname-newline-translation pathname) - (let ((end-of-line (pathname-end-of-line-string pathname))) - (and (not (string=? "\n" end-of-line)) - end-of-line))) - (define (open-binary-input-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) (port (make-port input-file-type - (make-file-state (make-input-buffer channel - input-buffer-size - #f) - #f - pathname)))) + (make-gstate channel #f 'BINARY pathname)))) (set-channel-port! channel port) port)) @@ -124,16 +119,12 @@ USA. (let* ((pathname (merge-pathnames filename)) (channel (let ((filename (->namestring pathname))) - (if (and (not (default-object? append?)) append?) + (if (if (default-object? append?) #f append?) (file-open-append-channel filename) (file-open-output-channel filename)))) (port (make-port output-file-type - (make-file-state #f - (make-output-buffer channel - output-buffer-size - #f) - pathname)))) + (make-gstate #f channel 'BINARY pathname)))) (set-channel-port! channel port) port)) @@ -142,13 +133,7 @@ USA. (channel (file-open-io-channel (->namestring pathname))) (port (make-port i/o-file-type - (make-file-state (make-input-buffer channel - input-buffer-size - #f) - (make-output-buffer channel - output-buffer-size - #f) - pathname)))) + (make-gstate channel channel 'BINARY pathname)))) (set-channel-port! channel port) port)) @@ -197,53 +182,4 @@ USA. (make-with-output-to-file call-with-output-file)) (define with-output-to-binary-file - (make-with-output-to-file call-with-binary-output-file)) - -(define-structure (file-state (type vector) - (conc-name file-state/)) - ;; First two elements of this vector are required by the generic - ;; I/O port operations. - (input-buffer #f read-only #t) - (output-buffer #f read-only #t) - (pathname #f read-only #t)) - -(define (operation/length port) - (channel-file-length (port/input-channel port))) - -(define (operation/pathname port) - (file-state/pathname (port/state port))) - -(define operation/truename - ;; This works for unix because truename and pathname are the same. - ;; On operating system where they differ, there must be support to - ;; determine the truename. - operation/pathname) - -(define (operation/write-self port output-port) - (write-string " for file: " output-port) - (write (operation/truename port) output-port)) - -(define (operation/rest->string port) - ;; This operation's intended purpose is to snarf an entire file in - ;; a single gulp, exactly what a text editor would need. - (let ((buffer (file-state/input-buffer (port/state port)))) - (let ((remaining (input-buffer/chars-remaining buffer)) - (fill-buffer - (lambda (string) - (let ((length (string-length string))) - (let loop () - (or (input-buffer/read-substring buffer string 0 length) - (loop))))))) - (if remaining - (let ((result (make-string remaining))) - (let ((n (fill-buffer result))) - (if (fix:< n remaining) - (substring result 0 n) - result))) - (let loop ((strings '())) - (let ((string (make-string input-buffer-size))) - (let ((n (fill-buffer string))) - (if (fix:< n input-buffer-size) - (apply string-append - (reverse! (cons (substring string 0 n) strings))) - (loop (cons string strings)))))))))) \ No newline at end of file + (make-with-output-to-file call-with-binary-output-file)) \ No newline at end of file diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index 5623c0a55..bb4c1c20a 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: genio.scm,v 1.21 2004/01/19 04:30:20 cph Exp $ +$Id: genio.scm,v 1.22 2004/02/16 05:36:36 cph Exp $ Copyright 1991,1993,1995,1996,1999,2002 Massachusetts Institute of Technology Copyright 2003,2004 Massachusetts Institute of Technology @@ -29,44 +29,76 @@ USA. (declare (usual-integrations)) +(define (make-generic-i/o-port input-channel output-channel) + (if (not (or input-channel output-channel)) + (error "Missing channel arguments.")) + (let ((port + (make-port (cond ((not input-channel) generic-output-type) + ((not output-channel) generic-input-type) + (else generic-i/o-type)) + (make-gstate input-channel output-channel 'TEXT)))) + (if input-channel (set-channel-port! input-channel port)) + (if output-channel (set-channel-port! output-channel port)) + port)) + +(define-structure (gstate (type vector) (constructor #f)) + ;; Changes to this structure must be copied to "fileio.scm" and + ;; "ttyio.scm". + (input-buffer #f read-only #t) + (output-buffer #f read-only #t) + coding + line-ending) + +(define (make-gstate input-channel output-channel type . extra) + (list->vector + (cons* (and input-channel (make-input-buffer-1 input-channel type)) + (and output-channel (make-output-buffer-1 output-channel type)) + type + type + extra))) + +(define-integrable (port-input-buffer port) + (gstate-input-buffer (port/state port))) + +(define-integrable (port-output-buffer port) + (gstate-output-buffer (port/state port))) + (define (initialize-package!) (let ((input-operations - `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars) - (CHAR-READY? ,operation/char-ready?) - (CHARS-REMAINING ,operation/chars-remaining) - (CLOSE-INPUT ,operation/close-input) - (DISCARD-CHAR ,operation/read-char) - (EOF? ,operation/eof?) - (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) - (INPUT-BUFFER-SIZE ,operation/input-buffer-size) - (INPUT-CHANNEL ,operation/input-channel) - (INPUT-OPEN? ,operation/input-open?) - (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) - (PEEK-CHAR ,operation/peek-char) - (READ-CHAR ,operation/read-char) - (READ-SUBSTRING ,operation/read-substring) - (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) - (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode))) + `((CHAR-READY? ,generic-io/char-ready?) + (CLOSE-INPUT ,generic-io/close-input) + (EOF? ,generic-io/eof?) + (INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode) + (INPUT-CHANNEL ,generic-io/input-channel) + (INPUT-OPEN? ,generic-io/input-open?) + (INPUT-TERMINAL-MODE ,generic-io/input-terminal-mode) + (READ-CHAR ,generic-io/read-char) + (READ-EXTERNAL-SUBSTRING ,generic-io/read-external-substring) + (READ-SUBSTRING ,generic-io/read-substring) + (READ-WIDE-SUBSTRING ,generic-io/read-wide-substring) + (SET-INPUT-BLOCKING-MODE ,generic-io/set-input-blocking-mode) + (SET-INPUT-TERMINAL-MODE ,generic-io/set-input-terminal-mode))) (output-operations - `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) - (CLOSE-OUTPUT ,operation/close-output) - (FLUSH-OUTPUT ,operation/flush-output) - (FRESH-LINE ,operation/fresh-line) - (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) - (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) - (OUTPUT-CHANNEL ,operation/output-channel) - (OUTPUT-COLUMN ,operation/output-column) - (OUTPUT-OPEN? ,operation/output-open?) - (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) - (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) - (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) - (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring))) + `((BUFFERED-OUTPUT-BYTES ,generic-io/buffered-output-bytes) + (CLOSE-OUTPUT ,generic-io/close-output) + (FLUSH-OUTPUT ,generic-io/flush-output) + (OUTPUT-BLOCKING-MODE ,generic-io/output-blocking-mode) + (OUTPUT-CHANNEL ,generic-io/output-channel) + (OUTPUT-OPEN? ,generic-io/output-open?) + (OUTPUT-TERMINAL-MODE ,generic-io/output-terminal-mode) + (SET-OUTPUT-BLOCKING-MODE ,generic-io/set-output-blocking-mode) + (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode) + (WRITE-CHAR ,generic-io/write-char) + (WRITE-EXTERNAL-SUBSTRING ,generic-io/write-external-substring) + (WRITE-SUBSTRING ,generic-io/write-substring) + (WRITE-WIDE-SUBSTRING ,generic-io/write-wide-substring))) (other-operations - `((CLOSE ,operation/close) - (WRITE-SELF ,operation/write-self)))) + `((CLOSE ,generic-io/close) + (CODING ,generic-io/coding) + (LINE-ENDING ,generic-io/line-ending) + (SET-CODING ,generic-io/set-coding) + (SET-LINE-ENDING ,generic-io/set-line-ending) + (WRITE-SELF ,generic-io/write-self)))) (set! generic-input-type (make-port-type (append input-operations other-operations) @@ -80,134 +112,66 @@ USA. output-operations other-operations) #f))) - unspecific) + (initialize-name-maps!) + (initialize-conditions!)) (define generic-input-type) (define generic-output-type) (define generic-i/o-type) -(define (make-generic-input-port input-channel input-buffer-size - #!optional line-translation) - (let ((line-translation - (if (default-object? line-translation) - 'DEFAULT - line-translation))) - (make-generic-port generic-input-type - (make-input-buffer input-channel - input-buffer-size - line-translation) - #f))) - -(define (make-generic-output-port output-channel output-buffer-size - #!optional line-translation) - (let ((line-translation - (if (default-object? line-translation) - 'DEFAULT - line-translation))) - (make-generic-port generic-output-type - #f - (make-output-buffer output-channel - output-buffer-size - line-translation)))) - -(define (make-generic-i/o-port input-channel output-channel - input-buffer-size output-buffer-size - #!optional input-line-translation - output-line-translation) - (let ((input-line-translation - (if (default-object? input-line-translation) - 'DEFAULT - input-line-translation))) - (let ((output-line-translation - (if (default-object? output-line-translation) - input-line-translation - output-line-translation))) - (make-generic-port generic-i/o-type - (make-input-buffer input-channel - input-buffer-size - input-line-translation) - (make-output-buffer output-channel - output-buffer-size - output-line-translation))))) - -(define (make-generic-port type input-buffer output-buffer) - (let ((port (make-port type (vector input-buffer output-buffer)))) - (if input-buffer - (set-channel-port! (input-buffer/channel input-buffer) port)) - (if output-buffer - (set-channel-port! (output-buffer/channel output-buffer) port)) - port)) - -(define-integrable (port/input-buffer port) - (vector-ref (port/state port) 0)) - -(define-integrable (port/output-buffer port) - (vector-ref (port/state port) 1)) - -(define (operation/write-self port output-port) - (cond ((i/o-port? port) - (write-string " for channels: " output-port) - (write (operation/input-channel port) output-port) - (write-string " " output-port) - (write (operation/output-channel port) output-port)) - ((input-port? port) - (write-string " for channel: " output-port) - (write (operation/input-channel port) output-port)) - ((output-port? port) - (write-string " for channel: " output-port) - (write (operation/output-channel port) output-port)) - (else - (write-string " for channel" output-port)))) - -(define (operation/char-ready? port interval) - (input-buffer/char-ready? (port/input-buffer port) interval)) - -(define (operation/chars-remaining port) - (input-buffer/chars-remaining (port/input-buffer port))) - -(define (operation/eof? port) - (input-buffer/eof? (port/input-buffer port))) +;;;; Input operations -(define (operation/peek-char port) - (input-buffer/peek-char (port/input-buffer port))) +(define (generic-io/char-ready? port) + (buffer-has-input? (port-input-buffer port))) -(define (operation/read-char port) - (input-buffer/read-char (port/input-buffer port))) +(define (generic-io/read-char port) + (let ((ib (port-input-buffer port))) + (let loop () + (or (read-next-char ib) + (let ((r (fill-input-buffer ib))) + (case r + ((OK) (loop)) + ((WOULD-BLOCK) #f) + ((EOF) (make-eof-object port)) + (else (error "Unknown result:" r)))))))) -(define (operation/read-substring port string start end) - (input-buffer/read-substring (port/input-buffer port) string start end)) +(define (generic-io/read-substring port string start end) + (read-substring:string (port-input-buffer port) string start end)) -(define (operation/input-buffer-size port) - (input-buffer/size (port/input-buffer port))) +(define (generic-io/read-wide-substring port string start end) + (read-substring:wide-string (port-input-buffer port) string start end)) -(define (operation/buffered-input-chars port) - (input-buffer/buffered-chars (port/input-buffer port))) +(define (generic-io/read-external-substring port string start end) + (read-substring:external-string (port-input-buffer port) string start end)) -(define (operation/set-input-buffer-size port buffer-size) - (input-buffer/set-size (port/input-buffer port) buffer-size)) +(define-integrable (generic-io/eof? port) + (input-buffer-at-eof? (port-input-buffer port))) -(define (operation/input-channel port) - (input-buffer/channel (port/input-buffer port))) +(define (generic-io/input-channel port) + (let ((ib (port-input-buffer port))) + (if (not ib) + (error:bad-range-argument port #f)) + (input-buffer-channel ib))) -(define (operation/input-blocking-mode port) - (if (channel-blocking? (operation/input-channel port)) +(define (generic-io/input-blocking-mode port) + (if (channel-blocking? (generic-io/input-channel port)) 'BLOCKING 'NONBLOCKING)) -(define (operation/set-input-blocking-mode port mode) +(define (generic-io/set-input-blocking-mode port mode) (case mode - ((BLOCKING) (channel-blocking (operation/input-channel port))) - ((NONBLOCKING) (channel-nonblocking (operation/input-channel port))) + ((BLOCKING) (channel-blocking (generic-io/input-channel port))) + ((NONBLOCKING) (channel-nonblocking (generic-io/input-channel port))) (else (error:wrong-type-datum mode "blocking mode")))) -(define (operation/input-terminal-mode port) - (let ((channel (operation/input-channel port))) +(define (generic-io/input-terminal-mode port) + (let ((channel (generic-io/input-channel port))) (cond ((not (channel-type=terminal? channel)) #f) ((terminal-cooked-input? channel) 'COOKED) (else 'RAW)))) -(define (operation/set-input-terminal-mode port mode) - (let ((channel (operation/input-channel port))) +(define (generic-io/set-input-terminal-mode port mode) + (let ((channel (generic-io/input-channel port))) (if (channel-type=terminal? channel) (case mode ((COOKED) (terminal-cooked-input channel)) @@ -216,82 +180,1212 @@ USA. (else (error:wrong-type-datum mode "terminal mode"))) unspecific))) -(define (operation/flush-output port) - (output-buffer/drain-block (port/output-buffer port))) - -(define (operation/write-char port char) - (output-buffer/write-char-block (port/output-buffer port) char)) - -(define (operation/write-substring port string start end) - (output-buffer/write-substring-block (port/output-buffer port) - string start end)) +;;;; Output operations -(define (operation/fresh-line port) - (if (not (fix:= 0 (output-buffer/column (port/output-buffer port)))) - (operation/write-char port #\newline))) +(define (generic-io/write-char port char) + (let ((ob (port-output-buffer port))) + (let loop () + (if (write-next-char ob char) + 1 + (let ((n (drain-output-buffer ob))) + (if (and n (fix:> n 0)) + (loop) + n)))))) -(define (operation/output-column port) - (output-buffer/column (port/output-buffer port))) +(define (generic-io/write-substring port string start end) + (write-substring:string (port-output-buffer port) string start end)) -(define (operation/output-buffer-size port) - (output-buffer/size (port/output-buffer port))) +(define (generic-io/write-wide-substring port string start end) + (write-substring:wide-string (port-output-buffer port) string start end)) -(define (operation/buffered-output-chars port) - (output-buffer/buffered-chars (port/output-buffer port))) +(define (generic-io/write-external-substring port string start end) + (write-substring:external-string (port-output-buffer port) string start end)) -(define (operation/set-output-buffer-size port buffer-size) - (output-buffer/set-size (port/output-buffer port) buffer-size)) +(define (generic-io/flush-output port) + (force-drain-output-buffer (port-output-buffer port))) -(define (operation/output-channel port) - (output-buffer/channel (port/output-buffer port))) +(define (generic-io/output-channel port) + (let ((ob (port-output-buffer port))) + (if (not ob) + (error:bad-range-argument port #f)) + (output-buffer-channel ob))) -(define (operation/output-blocking-mode port) - (if (channel-blocking? (operation/output-channel port)) +(define (generic-io/output-blocking-mode port) + (if (channel-blocking? (generic-io/output-channel port)) 'BLOCKING 'NONBLOCKING)) -(define (operation/set-output-blocking-mode port mode) +(define (generic-io/set-output-blocking-mode port mode) (case mode - ((BLOCKING) (channel-blocking (operation/output-channel port))) - ((NONBLOCKING) (channel-nonblocking (operation/output-channel port))) + ((BLOCKING) (channel-blocking (generic-io/output-channel port))) + ((NONBLOCKING) (channel-nonblocking (generic-io/output-channel port))) (else (error:wrong-type-datum mode "blocking mode")))) -(define (operation/output-terminal-mode port) - (let ((channel (operation/output-channel port))) +(define (generic-io/output-terminal-mode port) + (let ((channel (generic-io/output-channel port))) (cond ((not (channel-type=terminal? channel)) #f) ((terminal-cooked-output? channel) 'COOKED) (else 'RAW)))) -(define (operation/set-output-terminal-mode port mode) - (let ((channel (operation/output-channel port))) +(define (generic-io/set-output-terminal-mode port mode) + (let ((channel (generic-io/output-channel port))) (if (channel-type=terminal? channel) (case mode - ((COOKED) (terminal-cooked-output (operation/output-channel port))) - ((RAW) (terminal-raw-output (operation/output-channel port))) + ((COOKED) (terminal-cooked-output (generic-io/output-channel port))) + ((RAW) (terminal-raw-output (generic-io/output-channel port))) ((#F) unspecific) (else (error:wrong-type-datum mode "terminal mode"))) unspecific))) -(define (operation/close port) - (operation/close-input port) - (operation/close-output port)) - -(define (operation/close-output port) - (let ((output-buffer (port/output-buffer port))) - (if output-buffer - (output-buffer/close output-buffer (port/input-buffer port))))) - -(define (operation/close-input port) - (let ((input-buffer (port/input-buffer port))) - (if input-buffer - (input-buffer/close input-buffer (port/output-buffer port))))) - -(define (operation/output-open? port) - (let ((output-buffer (port/output-buffer port))) - (and output-buffer - (output-buffer/open? output-buffer)))) - -(define (operation/input-open? port) - (let ((input-buffer (port/input-buffer port))) - (and input-buffer - (input-buffer/open? input-buffer)))) \ No newline at end of file +(define (generic-io/buffered-output-bytes port) + (output-buffer-start (port-output-buffer port))) + +;;;; Non-specific operations + +(define (generic-io/close port) + (generic-io/close-input port) + (generic-io/close-output port)) + +(define (generic-io/close-output port) + (let ((ob (port-output-buffer port))) + (if ob + (close-output-buffer ob)))) + +(define (generic-io/close-input port) + (let ((ib (port-input-buffer port))) + (if ib + (close-input-buffer ib)))) + +(define (generic-io/output-open? port) + (let ((ob (port-output-buffer port))) + (and ob + (output-buffer-open? ob)))) + +(define (generic-io/input-open? port) + (let ((ib (port-input-buffer port))) + (and ib + (input-buffer-open? ib)))) + +(define (generic-io/write-self port output-port) + (cond ((i/o-port? port) + (write-string " for channels: " output-port) + (write (generic-io/input-channel port) output-port) + (write-string " " output-port) + (write (generic-io/output-channel port) output-port)) + ((input-port? port) + (write-string " for channel: " output-port) + (write (generic-io/input-channel port) output-port)) + ((output-port? port) + (write-string " for channel: " output-port) + (write (generic-io/output-channel port) output-port)) + (else + (write-string " for channel" output-port)))) + +(define (generic-io/coding port) + (gstate-coding (port/state port))) + +(define (generic-io/set-coding port name) + (let ((state (port/state port))) + (let ((ib (gstate-input-buffer state))) + (if ib + (set-input-buffer-coding! ib name))) + (let ((ob (gstate-output-buffer state))) + (if ob + (set-output-buffer-coding! ob name))) + (set-gstate-coding! state name))) + +(define (generic-io/line-ending port) + (gstate-line-ending (port/state port))) + +(define (generic-io/set-line-ending port name) + (let ((state (port/state port))) + (let ((ib (gstate-input-buffer state)) + (ob (gstate-output-buffer state))) + (let ((name + (line-ending (if ib + (input-buffer-channel ib) + (output-buffer-channel ob)) + name))) + (if ib + (set-input-buffer-line-ending! ib name)) + (if ob + (set-output-buffer-line-ending! ob name)) + (set-gstate-line-ending! state name))))) + +(define (line-ending channel name) + (guarantee-symbol name #f) + (if (eq? name 'TEXT) + (if (eq? 'TCP-STREAM-SOCKET (channel-type channel)) + 'CRLF + (default-line-ending)) + name)) + +;;;; Name maps + +(define-syntax define-name-map + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL) (cdr form)) + (let ((sing (cadr form))) + (let ((plur (symbol-append sing 'S)) + (proc (symbol-append 'DEFINE- sing))) + (let ((rev (symbol-append plur '-REVERSE))) + `(BEGIN + (DEFINE ,plur '()) + (DEFINE ,rev) + (DEFINE (,proc NAME ,sing) + (SET! ,plur (CONS (CONS NAME ,sing) ,plur)) + NAME) + (DEFINE (,(symbol-append proc '/POST-BOOT) NAME ,sing) + (LET ((OLD (HASH-TABLE/GET ,plur NAME #F))) + (IF OLD + (HASH-TABLE/REMOVE! ,rev OLD))) + (HASH-TABLE/PUT! ,plur NAME ,sing)) + (DEFINE (,(symbol-append 'NAME-> sing) NAME) + (LET LOOP ((NAME NAME)) + (LET ((,sing (HASH-TABLE/GET ,plur NAME #F))) + (IF (NOT ,sing) + (ERROR:BAD-RANGE-ARGUMENT NAME #F)) + (if (SYMBOL? ,sing) + (LOOP ,sing) + ,sing)))))))) + (ill-formed-syntax form))))) + +(define-name-map decoder) +(define-name-map encoder) +(define-name-map normalizer) +(define-name-map denormalizer) + +(define (initialize-name-maps!) + (let ((convert-reverse + (lambda (alist) + (let ((table (make-eq-hash-table))) + (for-each (lambda (n.d) + (hash-table/put! table (cdr n.d) (car n.d))) + alist) + table))) + (convert-forward + (lambda (alist) + (let ((table (make-eq-hash-table))) + (for-each (lambda (n.d) + (hash-table/put! table (car n.d) (cdr n.d))) + alist) + table)))) + (let-syntax + ((initialize-name-map + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL) (cdr form)) + (let ((sing (cadr form))) + (let ((plur (symbol-append sing 'S)) + (proc (symbol-append 'DEFINE- sing))) + `(BEGIN + (SET! ,(symbol-append plur '-REVERSE) + (CONVERT-REVERSE ,plur)) + (SET! ,plur (CONVERT-FORWARD ,plur)) + (SET! ,proc ,(symbol-append proc '/POST-BOOT))))) + (ill-formed-syntax form)))))) + (initialize-name-map decoder) + (initialize-name-map encoder) + (initialize-name-map normalizer) + (initialize-name-map denormalizer))) + (set! binary-decoder (name->decoder 'ISO-8859-1)) + (set! binary-encoder (name->encoder 'ISO-8859-1)) + (set! binary-normalizer (name->normalizer 'BINARY)) + (set! binary-denormalizer (name->denormalizer 'BINARY)) + unspecific) + +(define binary-decoder) +(define binary-encoder) +(define binary-normalizer) +(define binary-denormalizer) + +;;;; Input buffer + +(define-integrable page-size #x1000) +(define-integrable max-char-bytes 4) + +(define-integrable byte-buffer-length + (fix:+ page-size + (fix:- (fix:* max-char-bytes 2) 1))) + +(define-structure (input-buffer (constructor %make-input-buffer)) + (channel #f read-only #t) + (bytes #f read-only #t) + start + end + decode + normalize) + +(define (make-input-buffer channel) + (make-input-buffer-1 channel 'TEXT)) + +(define (make-binary-input-buffer channel) + (make-input-buffer-1 channel 'BINARY)) + +(define (make-input-buffer-1 channel type) + (%make-input-buffer channel + (make-string byte-buffer-length) + byte-buffer-length + byte-buffer-length + (name->decoder type) + (name->normalizer (line-ending channel type)))) + +(define-integrable (input-buffer-open? ib) + (channel-open? (input-buffer-channel ib))) + +(define (close-input-buffer ib) + (set-input-buffer-start! ib 0) + (set-input-buffer-end! ib 0) + (channel-close (input-buffer-channel ib))) + +(define-integrable (input-buffer-port ib) + (channel-port (input-buffer-channel ib))) + +(define-integrable (input-buffer-at-eof? ib) + (fix:= (input-buffer-end ib) 0)) + +(define-integrable (input-buffer-byte-count ib) + (fix:- (input-buffer-end ib) (input-buffer-start ib))) + +(define (read-next-char ib) + ((input-buffer-normalize ib) ib)) + +(define (decode-char ib) + (and (fix:< (input-buffer-start ib) (input-buffer-end ib)) + (let ((cp ((input-buffer-decode ib) ib))) + (and cp + (integer->char cp))))) + +(define (fill-input-buffer ib) + (if (input-buffer-at-eof? ib) + 'EOF + (begin + (justify-input-buffer ib) + (let loop () + (let ((n (read-bytes ib))) + (cond ((not n) 'WOULD-BLOCK) + ((fix:> n 0) 'OK) + (else 'EOF))))))) + +(define (buffer-has-input? ib) + (let ((bs (input-buffer-start ib))) + (if (read-next-char ib) + (begin + (set-input-buffer-start! ib bs) + #t) + (and (not (input-buffer-at-eof? ib)) + (channel-has-input? (input-buffer-channel ib)) + (begin + (justify-input-buffer ib) + (read-bytes ib) + (let ((bs (input-buffer-start ib))) + (and (read-next-char ib) + (begin + (set-input-buffer-start! ib bs) + #t)))))))) + +(define (justify-input-buffer ib) + (let ((bs (input-buffer-start ib)) + (be (input-buffer-end ib))) + (if (and (fix:< 0 bs) (fix:< bs be)) + (let ((bv (input-buffer-bytes ib))) + (do ((i bs (fix:+ i 1)) + (j 0 (fix:+ j 1))) + ((not (fix:< i be)) + (set-input-buffer-start! ib 0) + (set-input-buffer-end! ib j) + j) + (string-set! bv j (string-ref bv i))))))) + +(define (read-bytes ib) + (let ((available (input-buffer-byte-count ib))) + (let ((n + (channel-read (input-buffer-channel ib) + (input-buffer-bytes ib) + available + (fix:+ available page-size)))) + (if (and n (fix:> n 0)) + (begin + (set-input-buffer-start! ib 0) + (set-input-buffer-end! ib (fix:+ available n)))) + n))) + +(define (set-input-buffer-coding! ib coding) + (set-input-buffer-decode! ib (name->decoder coding))) + +(define (set-input-buffer-line-ending! ib name) + (set-input-buffer-normalize! ib (name->normalizer name))) + +(define (input-buffer-contents ib) + (substring (input-buffer-bytes ib) + (input-buffer-start ib) + (input-buffer-end ib))) + +(define (set-input-buffer-contents! ib contents) + (guarantee-string contents 'SET-INPUT-BUFFER-CONTENTS!) + (let ((bv (input-buffer-bytes ib))) + (let ((n (fix:min (string-length contents) (string-length bv)))) + (substring-move! contents 0 n bv 0) + (set-input-buffer-start! ib 0) + (set-input-buffer-end! ib n)))) + +(define (read-substring:wide-string ib string start end) + (let ((v (wide-string-contents string))) + (let loop ((i start)) + (cond ((not (fix:< i end)) + (fix:- i start)) + ((read-next-char ib) + => (lambda (char) + (vector-set! v i char) + (loop (fix:+ i 1)))) + ((fix:> i start) + (fix:- i start)) + (else + (let ((r (fill-input-buffer ib))) + (case r + ((OK) (loop i)) + ((WOULD-BLOCK) #f) + ((EOF) 0) + (else (error "Unknown result:" r))))))))) + +(define (read-substring:string ib string start end) + (if (input-buffer-in-8-bit-mode? ib) + (let ((bv (input-buffer-bytes ib)) + (bs (input-buffer-start ib)) + (be (input-buffer-end ib))) + (if (fix:< bs be) + (let ((n (fix:min (fix:- be bs) (fix:- end start)))) + (let ((be (fix:+ bs n))) + (%substring-move! bv bs be string start) + (set-input-buffer-start! ib be) + n)) + (channel-read (input-buffer-channel ib) string start end))) + (read-to-8-bit ib string start end))) + +(define (read-substring:external-string ib string start end) + (if (input-buffer-in-8-bit-mode? ib) + (let ((bv (input-buffer-bytes ib)) + (bs (input-buffer-start ib)) + (be (input-buffer-end ib))) + (if (fix:< bs be) + (let ((n (min (fix:- be bs) (- end start)))) + (let ((be (fix:+ bs n))) + (xsubstring-move! bv bs be string start) + (set-input-buffer-start! ib be) + n)) + (channel-read (input-buffer-channel ib) string start end))) + (let ((bounce (make-string page-size)) + (be (min page-size (- end start)))) + (let ((n (read-to-8-bit ib bounce 0 be))) + (if (and n (fix:> n 0)) + (substring-move! bounce 0 n string start)) + n)))) + +(define (input-buffer-in-8-bit-mode? ib) + (and (eq? (input-buffer-decode ib) binary-decoder) + (eq? (input-buffer-normalize ib) binary-normalizer))) + +(define (read-to-8-bit ib string start end) + (let ((n + (let loop ((i start)) + (if (fix:< i end) + (let ((char (read-next-char ib))) + (if char + (if (fix:< (char->integer char) #x100) + (begin + (string-set! string i char) + (loop (fix:+ i 1))) + (error "Character too large for 8-bit string:" char)) + (fix:- i start))) + (fix:- i start))))) + (if (fix:> n 0) + n + (let ((r (fill-input-buffer ib))) + (case r + ((OK) (read-to-8-bit ib string start end)) + ((WOULD-BLOCK) #f) + ((EOF) 0) + (else (error "Unknown result:" r))))))) + +;;;; Output buffer + +(define-structure (output-buffer (constructor %make-output-buffer)) + (channel #f read-only #t) + (bytes #f read-only #t) + start + encode + denormalize) + +(define (make-output-buffer channel) + (make-output-buffer-1 channel 'TEXT)) + +(define (make-binary-output-buffer channel) + (make-output-buffer-1 channel 'BINARY)) + +(define (make-output-buffer-1 channel type) + (%make-output-buffer channel + (make-string byte-buffer-length) + 0 + (name->encoder type) + (name->denormalizer (line-ending channel type)))) + +(define-integrable (output-buffer-open? ob) + (channel-open? (output-buffer-channel ob))) + +(define (close-output-buffer ob) + (force-drain-output-buffer ob) + (channel-close (output-buffer-channel ob))) + +(define-integrable (output-buffer-port ob) + (channel-port (output-buffer-channel ob))) + +(define-integrable (output-buffer-end ob) + (string-length (output-buffer-bytes ob))) + +(define (flush-output-buffer buffer) + (set-output-buffer-start! buffer 0)) + +(define (force-drain-output-buffer ob) + (with-channel-blocking (output-buffer-channel ob) #t + (lambda () + (let loop () + (drain-output-buffer ob) + (if (fix:> (output-buffer-start ob) 0) + (loop)))))) + +(define (drain-output-buffer ob) + (let ((bs (output-buffer-start ob))) + (if (fix:> bs 0) + (let ((bv (output-buffer-bytes ob))) + (let ((n + (channel-write (output-buffer-channel ob) + bv + 0 + (fix:min bs page-size)))) + (if (and n (fix:> n 0)) + (do ((bi n (fix:+ bi 1)) + (bj 0 (fix:+ bj 1))) + ((not (fix:< bi bs)) + (set-output-buffer-start! ob bj)) + (vector-8b-set! bv bj (vector-8b-ref bv bi)))) + n)) + 0))) + +(define (write-next-char ob char) + (and (fix:< (output-buffer-start ob) page-size) + (begin + ((output-buffer-denormalize ob) ob char) + #t))) + +(define (output-buffer-in-8-bit-mode? ib) + (and (eq? (output-buffer-encode ib) binary-encoder) + (eq? (output-buffer-denormalize ib) 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))))) + +(define (set-output-buffer-coding! ib coding) + (set-output-buffer-encode! ib (name->encoder coding))) + +(define (set-output-buffer-line-ending! ib name) + (set-output-buffer-denormalize! ib (name->denormalizer name))) + +(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))) + (let loop ((i start) (bi (output-buffer-start ob))) + (if (fix:< i end) + (if (fix:< bi be) + (begin + (string-set! bv bi (string-ref string i)) + (loop (fix:+ i 1) (fix:+ bi 1))) + (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)))))) + (begin + (set-output-buffer-start! ob bi) + (fix:- end start))))) + (let loop ((i start)) + (if (fix:< i end) + (if (write-next-char ob (string-ref string i)) + (loop (fix:+ i 1)) + (let ((n (drain-output-buffer ob))) + (cond ((not n) (and (fix:> i start) (fix:- i start))) + ((fix:> n 0) (loop i)) + (else (fix:- i start))))) + (fix:- end start))))) + +(define (write-substring:wide-string ob string start end) + (let ((v (wide-string-contents string))) + (let loop ((i start)) + (if (fix:< i end) + (if (write-next-char ob (vector-ref v i)) + (loop (fix:+ i 1)) + (let ((n (drain-output-buffer ob))) + (cond ((not n) (and (fix:> i start) (fix:- i start))) + ((fix:> n 0) (loop i)) + (else (fix:- i start))))) + (fix:- end start))))) + +(define (write-substring:external-string ob string start end) + (let ((bounce (make-string #x1000))) + (let loop ((i start)) + (if (< i end) + (let ((n (min (- end i) #x1000))) + (substring-move! string i (+ i n) bounce 0) + (let ((m (write-substring:string ob bounce 0 n))) + (cond ((not m) + (and (> i start) + (- i start))) + ((fix:> m 0) + (if (fix:< m n) + (- (+ i m) start) + (loop (+ i n)))) + (else (- i start))))) + (- end start))))) + +;;;; ISO-8859 codecs + +(define-decoder 'ISO-8859-1 + (lambda (ib) + (let ((cp (vector-8b-ref (input-buffer-bytes ib) (input-buffer-start ib)))) + (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) + cp))) + +(define-encoder 'ISO-8859-1 + (lambda (ob cp) + (if (not (fix:< cp #x100)) + (error:char-encoding ob cp)) + (vector-8b-set! (output-buffer-bytes ob) (output-buffer-start ob) cp) + 1)) + +(define-decoder 'BINARY 'ISO-8859-1) +(define-encoder 'BINARY 'ISO-8859-1) +(define-decoder 'TEXT 'ISO-8859-1) +(define-encoder 'TEXT 'ISO-8859-1) + +(define-syntax define-iso-8859-map + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(+ DATUM) (cdr form)) + (let ((name + (intern + (string-append "iso-8859-" (number->string (cadr form)))))) + (let ((decoding-map (symbol-append 'DECODING-MAP: name)) + (encoding-map (symbol-append 'ENCODING-MAP: name))) + `(BEGIN + (DEFINE-DECODER ',name + (LET ((,decoding-map + #(,@(let loop ((i 0)) + (if (fix:= i #xA1) + (cddr form) + (cons i (loop (fix:+ i 1)))))))) + (LAMBDA (IB) + (DECODE-ISO-8859 IB ,decoding-map)))) + (DEFINE-ENCODER ',name + (LET ((,encoding-map + (RECEIVE (LHS RHS) + (REVERSE-ISO-8859-MAP ',(cddr form)) + (CONS LHS RHS)))) + (LAMBDA (OB CP) + (ENCODE-ISO-8859 OB CP ,encoding-map))))))) + (ill-formed-syntax form))))) + +(define (decode-iso-8859 ib table) + (let ((cp + (vector-ref table + (vector-8b-ref (input-buffer-bytes ib) + (input-buffer-start ib))))) + (if cp + (begin + (set-input-buffer-start! ib (fix:+ (input-buffer-start ib) 1)) + cp) + (error:char-decoding ib)))) + +(define (encode-iso-8859 ob cp table) + (vector-8b-set! (input-buffer-bytes ob) + (input-buffer-start ob) + (if (fix:< cp #xA1) + cp + (let ((lhs (car table))) + (let loop ((low 0) (high (vector-length lhs))) + (if (not (fix:< low high)) + (error:char-encoding ob cp)) + (let ((i (fix:quotient (fix:+ low high) 2))) + (cond ((fix:< cp (vector-ref lhs i)) + (loop low i)) + ((fix:> cp (vector-ref lhs i)) + (loop (fix:+ i 1) high)) + (else + (vector-8b-ref (cdr table) i)))))))) + 1) + +(define (reverse-iso-8859-map code-points) + (let ((lhs (make-vector #x5F)) + (rhs (make-string #x5F))) + (do ((alist (sort (let loop ((code-points code-points) (i #xA1)) + (if (pair? code-points) + (if (car code-points) + (cons (cons (car code-points) i) + (loop (cdr code-points) (fix:+ i 1))) + (loop (cdr code-points) (fix:+ i 1))) + '())) + (lambda (a b) + (fix:< (car a) (car b)))) + (cdr alist)) + (i 0 (fix:+ i 1))) + ((not (pair? alist))) + (vector-set! lhs i (caar alist)) + (vector-8b-set! rhs i (cdar alist))) + (values lhs rhs))) + +(define-iso-8859-map 2 + #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7 #x00A8 + #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B #x00B0 + #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7 #x00B8 + #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C #x0154 + #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7 #x010C + #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E #x0110 + #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7 #x0158 + #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF #x0155 + #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7 #x010D + #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F #x0111 + #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7 #x0159 + #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9) + +(define-iso-8859-map 3 + #x0126 #x02D8 #x00A3 #x00A4 #f #x0124 #x00A7 #x00A8 + #x0130 #x015E #x011E #x0134 #x00AD #f #x017B #x00B0 + #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7 #x00B8 + #x0131 #x015F #x011F #x0135 #x00BD #f #x017C #x00C0 + #x00C1 #x00C2 #f #x00C4 #x010A #x0108 #x00C7 #x00C8 + #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #f + #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7 #x011C + #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF #x00E0 + #x00E1 #x00E2 #f #x00E4 #x010B #x0109 #x00E7 #x00E8 + #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #f + #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7 #x011D + #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9) + +(define-iso-8859-map 4 + #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7 #x00A8 + #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF #x00B0 + #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7 #x00B8 + #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B #x0100 + #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E #x010C + #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A #x0110 + #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7 #x00D8 + #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF #x0101 + #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F #x010D + #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B #x0111 + #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8 + #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9) + +(define-iso-8859-map 5 + #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407 #x0408 + #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F #x0410 + #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417 #x0418 + #x0419 #x041A #x041B #x041C #x041D #x041E #x041F #x0420 + #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427 #x0428 + #x0429 #x042A #x042B #x042C #x042D #x042E #x042F #x0430 + #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437 #x0438 + #x0439 #x043A #x043B #x043C #x043D #x043E #x043F #x0440 + #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447 #x0448 + #x0449 #x044A #x044B #x044C #x044D #x044E #x044F #x2116 + #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457 #x0458 + #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F) + +(define-iso-8859-map 6 + #f #f #f #x00A4 #f #f #f #f + #f #f #f #x060C #x00AD #f #f #f + #f #f #f #f #f #f #f #f + #f #f #x061B #f #f #f #x061F #f + #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627 #x0628 + #x0629 #x062A #x062B #x062C #x062D #x062E #x062F #x0630 + #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637 #x0638 + #x0639 #x063A #f #f #f #f #f #x0640 + #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647 #x0648 + #x0649 #x064A #x064B #x064C #x064D #x064E #x064F #x0650 + #x0651 #x0652 #f #f #f #f #f #f + #f #f #f #f #f #f #f ) + +(define-iso-8859-map 7 + #x2018 #x2019 #x00A3 #f #f #x00A6 #x00A7 #x00A8 + #x00A9 #f #x00AB #x00AC #x00AD #f #x2015 #x00B0 + #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7 #x0388 + #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F #x0390 + #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397 #x0398 + #x0399 #x039A #x039B #x039C #x039D #x039E #x039F #x03A0 + #x03A1 #f #x03A3 #x03A4 #x03A5 #x03A6 #x03A7 #x03A8 + #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF #x03B0 + #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7 #x03B8 + #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF #x03C0 + #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7 #x03C8 + #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #f ) + +(define-iso-8859-map 8 + #f #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8 + #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x00AF #x00B0 + #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 #x00B8 + #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #f #f + #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #f #f + #f #f #f #f #f #f #x2017 #x05D0 + #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7 #x05D8 + #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF #x05E0 + #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7 #x05E8 + #x05E9 #x05EA #f #f #x200E #x200F #f ) + +(define-iso-8859-map 9 + #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7 #x00A8 + #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF #x00B0 + #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7 #x00B8 + #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF #x00C0 + #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 #x00C8 + #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #x011E + #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7 #x00D8 + #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF #x00E0 + #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 #x00E8 + #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #x011F + #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8 + #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF) + +(define-iso-8859-map 10 + #x0104 #x0112 #x0122 #x012A #x0128 #x0136 #x00A7 #x013B + #x0110 #x0160 #x0166 #x017D #x00AD #x016A #x014A #x00B0 + #x0105 #x0113 #x0123 #x012B #x0129 #x0137 #x00B7 #x013C + #x0111 #x0161 #x0167 #x017E #x2015 #x016B #x014B #x0100 + #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E #x010C + #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x00CF #x00D0 + #x0145 #x014C #x00D3 #x00D4 #x00D5 #x00D6 #x0168 #x00D8 + #x0172 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF #x0101 + #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F #x010D + #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x00EF #x00F0 + #x0146 #x014D #x00F3 #x00F4 #x00F5 #x00F6 #x0169 #x00F8 + #x0173 #x00FA #x00FB #x00FC #x00FD #x00FE #x0138) + +(define-iso-8859-map 11 + #x0E01 #x0E02 #x0E03 #x0E04 #x0E05 #x0E06 #x0E07 #x0E08 + #x0E09 #x0E0A #x0E0B #x0E0C #x0E0D #x0E0E #x0E0F #x0E10 + #x0E11 #x0E12 #x0E13 #x0E14 #x0E15 #x0E16 #x0E17 #x0E18 + #x0E19 #x0E1A #x0E1B #x0E1C #x0E1D #x0E1E #x0E1F #x0E20 + #x0E21 #x0E22 #x0E23 #x0E24 #x0E25 #x0E26 #x0E27 #x0E28 + #x0E29 #x0E2A #x0E2B #x0E2C #x0E2D #x0E2E #x0E2F #x0E30 + #x0E31 #x0E32 #x0E33 #x0E34 #x0E35 #x0E36 #x0E37 #x0E38 + #x0E39 #x0E3A #f #f #f #f #x0E3F #x0E40 + #x0E41 #x0E42 #x0E43 #x0E44 #x0E45 #x0E46 #x0E47 #x0E48 + #x0E49 #x0E4A #x0E4B #x0E4C #x0E4D #x0E4E #x0E4F #x0E50 + #x0E51 #x0E52 #x0E53 #x0E54 #x0E55 #x0E56 #x0E57 #x0E58 + #x0E59 #x0E5A #x0E5B #f #f #f #f ) + +(define-iso-8859-map 13 + #x201D #x00A2 #x00A3 #x00A4 #x201E #x00A6 #x00A7 #x00D8 + #x00A9 #x0156 #x00AB #x00AC #x00AD #x00AE #x00C6 #x00B0 + #x00B1 #x00B2 #x00B3 #x201C #x00B5 #x00B6 #x00B7 #x00F8 + #x00B9 #x0157 #x00BB #x00BC #x00BD #x00BE #x00E6 #x0104 + #x012E #x0100 #x0106 #x00C4 #x00C5 #x0118 #x0112 #x010C + #x00C9 #x0179 #x0116 #x0122 #x0136 #x012A #x013B #x0160 + #x0143 #x0145 #x00D3 #x014C #x00D5 #x00D6 #x00D7 #x0172 + #x0141 #x015A #x016A #x00DC #x017B #x017D #x00DF #x0105 + #x012F #x0101 #x0107 #x00E4 #x00E5 #x0119 #x0113 #x010D + #x00E9 #x017A #x0117 #x0123 #x0137 #x012B #x013C #x0161 + #x0144 #x0146 #x00F3 #x014D #x00F5 #x00F6 #x00F7 #x0173 + #x0142 #x015B #x016B #x00FC #x017C #x017E #x2019) + +(define-iso-8859-map 14 + #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7 #x1E80 + #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178 #x1E1E + #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56 #x1E81 + #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61 #x00C0 + #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 #x00C8 + #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #x0174 + #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A #x00D8 + #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF #x00E0 + #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 #x00E8 + #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #x0175 + #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B #x00F8 + #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF) + +(define-iso-8859-map 15 + #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7 #x0161 + #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF #x00B0 + #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7 #x017E + #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF #x00C0 + #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7 #x00C8 + #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #x00D0 + #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7 #x00D8 + #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF #x00E0 + #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7 #x00E8 + #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #x00F0 + #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7 #x00F8 + #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF) + +(define-iso-8859-map 16 + #x0104 #x0105 #x0141 #x20AC #x201E #x0160 #x00A7 #x0161 + #x00A9 #x0218 #x00AB #x0179 #x00AD #x017A #x017B #x00B0 + #x00B1 #x010C #x0142 #x017D #x201D #x00B6 #x00B7 #x017E + #x010D #x0219 #x00BB #x0152 #x0153 #x0178 #x017C #x00C0 + #x00C1 #x00C2 #x0102 #x00C4 #x0106 #x00C6 #x00C7 #x00C8 + #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF #x0110 + #x0143 #x00D2 #x00D3 #x00D4 #x0150 #x00D6 #x015A #x0170 + #x00D9 #x00DA #x00DB #x00DC #x0118 #x021A #x00DF #x00E0 + #x00E1 #x00E2 #x0103 #x00E4 #x0107 #x00E6 #x00E7 #x00E8 + #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF #x0111 + #x0144 #x00F2 #x00F3 #x00F4 #x0151 #x00F6 #x015B #x0171 + #x00F9 #x00FA #x00FB #x00FC #x0119 #x021B #x00FF) + +#| +(define (read-iso-8859-directory directory) + (let ((directory (pathname-as-directory directory))) + (let loop ((pathnames (directory-read directory))) + (if (pair? pathnames) + (let ((pathname (car pathnames))) + (let ((name (pathname-name pathname))) + (if (re-string-match "\\`8859-[0-9]+\\'" name) + (cons (list (intern (string-append "ISO-" name)) + (read-iso-8859-file pathname)) + (loop (cdr pathnames))) + (loop (cdr pathnames))))) + '())))) + +(define (read-iso-8859-file pathname) + (call-with-input-file pathname + (lambda (port) + (let ((v (make-vector #x100 #f)) + (re + (rexp-compile + (let ((hex (string->char-set "0123456789abcdefABCDEF"))) + (rexp-sequence (rexp-string-start) + "0x" (rexp-group hex hex) + "\t0x" (rexp-group hex hex hex hex) + "\t")))) + (hex + (lambda (line regs i) + (string->number (re-match-extract line regs i) 16)))) + (let loop () + (let ((line (read-line port))) + (if (not (eof-object? line)) + (let ((regs (re-string-match re line))) + (if regs + (let ((i (hex line regs 1)) + (j (hex line regs 2))) + (let ((c (integer->char j))) + (if (vector-ref v i) + (error "Character defined:" i c) + (vector-set! v i c))))) + (loop))))) + v)))) +|# + +;;;; Unicode codecs + +(define-decoder 'UTF-8 + (lambda (ib) + + (define-integrable (done cp bs) + (set-input-buffer-start! ib bs) + cp) + + (let ((bv (input-buffer-bytes ib)) + (bs (input-buffer-start ib))) + (let ((b0 (get-byte bv bs 0))) + (cond ((fix:< b0 #x80) + (done b0 (fix:+ bs 1))) + ((fix:< b0 #xE0) + (and (fix:<= (fix:+ bs 2) (input-buffer-end ib)) + (let ((b1 (get-byte bv bs 1))) + (if (and (fix:> b0 #xC1) + (trailing-byte? b1)) + (done (fix:or (extract b0 #x1F 6) + (extract b1 #x3F 0)) + (fix:+ bs 2)) + (error:char-decoding ib))))) + ((fix:< b0 #xF0) + (and (fix:<= (fix:+ bs 3) (input-buffer-end ib)) + (let ((b1 (get-byte bv bs 1)) + (b2 (get-byte bv bs 2))) + (if (and (or (fix:> b0 #xE0) (fix:> b1 #x9F)) + (trailing-byte? b1) + (trailing-byte? b2)) + (let ((cp + (fix:or (fix:or (extract b0 #x0F 12) + (extract b1 #x3F 6)) + (extract b2 #x3F 0)))) + (if (illegal-low? cp) + (error:char-decoding ib) + (done cp (fix:+ bs 3)))) + (error:char-decoding ib))))) + ((fix:< b0 #xF8) + (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) + (let ((b1 (get-byte bv bs 1)) + (b2 (get-byte bv bs 2)) + (b3 (get-byte bv bs 3))) + (if (and (or (fix:> b0 #xF0) (fix:> b1 #x8F)) + (trailing-byte? b1) + (trailing-byte? b2) + (trailing-byte? b3)) + (let ((cp + (fix:or (fix:or (extract b0 #x07 18) + (extract b1 #x3F 12)) + (fix:or (extract b2 #x3F 6) + (extract b3 #x3F 0))))) + (if (fix:< cp #x110000) + (done cp (fix:+ bs 4)) + (error:char-decoding ib))) + (error:char-decoding ib))))) + (else + (error:char-decoding ib))))))) + +(define-encoder 'UTF-8 + (lambda (ob cp) + (let ((bv (output-buffer-bytes ob)) + (bs (output-buffer-start ob))) + + (define-integrable (initial-byte n-bits offset) + (fix:or (fix:and (fix:lsh #xFF (fix:+ n-bits 1)) #xFF) + (fix:lsh cp (fix:- 0 offset)))) + + (define-integrable (trailing-byte offset) + (fix:or #x80 (fix:and (fix:lsh cp (fix:- 0 offset)) #x3F))) + + (cond ((fix:< cp #x00000080) + (put-byte bv bs 0 cp) + 1) + ((fix:< cp #x00000800) + (put-byte bv bs 0 (initial-byte 5 6)) + (put-byte bv bs 1 (trailing-byte 0)) + 2) + ((fix:< cp #x00010000) + (put-byte bv bs 0 (initial-byte 4 12)) + (put-byte bv bs 1 (trailing-byte 6)) + (put-byte bv bs 2 (trailing-byte 0)) + 3) + ((fix:< cp #x00110000) + (put-byte bv bs 0 (initial-byte 3 18)) + (put-byte bv bs 1 (trailing-byte 12)) + (put-byte bv bs 2 (trailing-byte 6)) + (put-byte bv bs 3 (trailing-byte 0)) + 4) + (else + (error:char-encoding ob cp)))))) + +(define-integrable (get-byte bv base offset) + (vector-8b-ref bv (fix:+ base offset))) + +(define-integrable (put-byte bv base offset byte) + (vector-8b-set! bv (fix:+ base offset) byte)) + +(define-integrable (extract b m n) + (fix:lsh (fix:and b m) n)) + +(define-integrable (trailing-byte? b) + (fix:= (fix:and #xC0 b) #x80)) + +(define-integrable (illegal-low? n) + (or (fix:= (fix:and #xF800 n) #xD800) + (fix:= (fix:and #xFFFE n) #xFFFE))) + +(define-decoder 'UTF-16-BE + (lambda (ib) + (decode-utf-16 ib be-bytes->digit16))) + +(define-decoder 'UTF-16-LE + (lambda (ib) + (decode-utf-16 ib le-bytes->digit16))) + +(define-integrable (decode-utf-16 ib combine) + + (define-integrable (done cp bs) + (set-input-buffer-start! ib bs) + cp) + + (let ((bv (input-buffer-bytes ib)) + (bs (input-buffer-start ib))) + (and (fix:<= (fix:+ bs 2) (input-buffer-end ib)) + (let ((d0 + (combine (get-byte bv bs 0) + (get-byte bv bs 1)))) + (if (high-surrogate? d0) + (and (fix:<= (fix:+ bs 4) (input-buffer-end ib)) + (let ((d1 + (combine (get-byte bv bs 2) + (get-byte bv bs 3)))) + (if (low-surrogate? d1) + (done (combine-surrogates d0 d1) (fix:+ bs 4)) + (error:char-decoding ib)))) + (if (illegal-low? d0) + (error:char-decoding ib) + (done d0 (fix:+ bs 2)))))))) + +(define-encoder 'UTF-16-BE + (lambda (ob cp) + (encode-utf-16 ob cp high-byte low-byte))) + +(define-encoder 'UTF-16-LE + (lambda (ob cp) + (encode-utf-16 ob cp low-byte high-byte))) + +(define-integrable (encode-utf-16 ob cp first-byte second-byte) + (let ((bv (output-buffer-bytes ob)) + (bs (output-buffer-start ob))) + (cond ((fix:< cp #x10000) + (put-byte bv bs 0 (first-byte cp)) + (put-byte bv bs 1 (second-byte cp)) + 2) + ((fix:< cp #x110000) + (let ((h (fix:or (fix:lsh (fix:- cp #x10000) -10) #xD800)) + (l (fix:or (fix:and (fix:- cp #x10000) #x3FF) #xDC00))) + (put-byte bv bs 0 (first-byte h)) + (put-byte bv bs 1 (second-byte h)) + (put-byte bv bs 2 (first-byte l)) + (put-byte bv bs 3 (second-byte l))) + 4) + (else + (error:char-encoding ob cp))))) + +(define-integrable (be-bytes->digit16 b0 b1) (fix:or (fix:lsh b0 8) b1)) +(define-integrable (le-bytes->digit16 b0 b1) (fix:or b0 (fix:lsh b1 8))) +(define-integrable (high-byte d) (fix:lsh d -8)) +(define-integrable (low-byte d) (fix:and d #xFF)) +(define-integrable (high-surrogate? n) (fix:= (fix:and #xFC00 n) #xD800)) +(define-integrable (low-surrogate? n) (fix:= (fix:and #xFC00 n) #xDC00)) + +(define-integrable (combine-surrogates n0 n1) + (fix:+ (fix:or (extract n0 #x3FF 10) + (extract n1 #x3FF 0)) + #x10000)) + +;;;; Normalizers + +(define-normalizer 'BINARY + (lambda (ib) + (decode-char ib))) + +(define-denormalizer 'BINARY + (lambda (ob char) + (encode-char ob char))) + +(define-normalizer 'LF 'BINARY) +(define-denormalizer 'LF 'BINARY) + +(define-normalizer 'CR + (lambda (ib) + (let ((c0 (decode-char ib))) + (if (eq? c0 #\U+000D) + #\newline + c0)))) + +(define-denormalizer 'CR + (lambda (ob char) + (encode-char ob (if (char=? char #\newline) #\U+000D char)))) + +(define-normalizer 'CRLF + (lambda (ib) + (let* ((bs0 (input-buffer-start ib)) + (c0 (decode-char ib))) + (if (eq? c0 #\U+000D) + (let* ((bs1 (input-buffer-start ib)) + (c1 (decode-char ib))) + (case c1 + ((#\U+000A) + #\newline) + ((#f) + (set-input-buffer-start! ib bs0) + #f) + (else + (set-input-buffer-start! ib bs1) + c0))) + c0)))) + +(define-denormalizer 'CRLF + (lambda (ob char) + (if (char=? char #\newline) + (begin + (encode-char ob #\U+000D) + (encode-char ob #\U+000A)) + (encode-char ob char)))) + +(define-normalizer 'XML-1.0 + (lambda (ib) + (let* ((bs0 (input-buffer-start ib)) + (c0 (decode-char ib))) + (case c0 + ((#\U+000D) + (let* ((bs1 (input-buffer-start ib)) + (c1 (decode-char ib))) + (case c1 + ((#\U+000A) + #\U+000A) + ((#f) + (set-input-buffer-start! ib bs0) + #f) + (else + (set-input-buffer-start! ib bs1) + #\U+000A)))) + (else c0))))) + +(define-normalizer 'XML-1.1 + (lambda (ib) + (let* ((bs0 (input-buffer-start ib)) + (c0 (decode-char ib))) + (case c0 + ((#\U+000D) + (let* ((bs1 (input-buffer-start ib)) + (c1 (decode-char ib))) + (case c1 + ((#\U+000A #\U+0085) + #\U+000A) + ((#f) + (set-input-buffer-start! ib bs0) + #f) + (else + (set-input-buffer-start! ib bs1) + #\U+000A)))) + ((#\U+0085 #\U+2028) #\U+000A) + (else c0))))) + +;;;; Conditions + +(define condition-type:char-decoding-error) +(define condition-type:char-encoding-error) +(define error:char-decoding) +(define error:char-encoding) + +(define (initialize-conditions!) + (set! condition-type:char-decoding-error + (make-condition-type 'CHAR-DECODING-ERROR condition-type:port-error '() + (lambda (condition port) + (write-string "The input port " port) + (write (access-condition condition 'PORT) port) + (write-string " was unable to decode a character." port) + (newline port)))) + (set! error:char-decoding + (condition-signaller condition-type:char-decoding-error + '(PORT) + standard-error-handler)) + (set! condition-type:char-encoding-error + (make-condition-type 'CHAR-ENCODING-ERROR condition-type:port-error + '(CHAR) + (lambda (condition port) + (write-string "The output port " port) + (write (access-condition condition 'PORT) port) + (write-string " was unable to encode the character " port) + (write (access-condition condition 'CHAR) port) + (newline port)))) + (set! error:char-encoding + (condition-signaller condition-type:char-encoding-error + '(PORT CHAR) + standard-error-handler)) + unspecific) \ No newline at end of file diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index a635d251d..4b36248c7 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,9 +1,10 @@ #| -*-Scheme-*- -$Id: input.scm,v 14.25 2003/07/30 17:18:49 cph Exp $ +$Id: input.scm,v 14.26 2004/02/16 05:36:44 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1997,1999,2002,2003 Massachusetts Institute of Technology +Copyright 2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,116 +29,199 @@ USA. ;;; package: (runtime input-port) (declare (usual-integrations)) + +;;;; Low level -;;;; Input Ports - -(define (input-port/char-ready? port interval) - ((input-port/operation/char-ready? port) port interval)) - -(define (input-port/peek-char port) - ((input-port/operation/peek-char port) port)) +(define (input-port/char-ready? port) + ((port/operation/char-ready? port) port)) (define (input-port/read-char port) - ((input-port/operation/read-char port) port)) + ((port/operation/read-char port) port)) -(define (input-port/discard-char port) - ((input-port/operation/discard-char port) port)) - -(define (input-port/read-string port delimiters) - ((input-port/operation/read-string port) port delimiters)) +(define (input-port/unread-char port char) + ((port/operation/unread-char port) port char)) -(define (input-port/discard-chars port delimiters) - ((input-port/operation/discard-chars port) port delimiters)) +(define (input-port/peek-char port) + ((port/operation/peek-char port) port)) -(define (input-port/read-substring! port string start end) - ((input-port/operation/read-substring port) port string start end)) +(define (input-port/discard-char port) + ((port/operation/discard-char port) port)) (define (input-port/read-string! port string) (input-port/read-substring! port string 0 (string-length string))) +(define (input-port/read-substring! port string start end) + (if (fix:< start end) + ((port/operation/read-substring port) port string start end) + 0)) + +(define (input-port/read-wide-string! port string) + (input-port/read-wide-substring! port string 0 (wide-string-length string))) + +(define (input-port/read-wide-substring! port string start end) + (if (fix:< start end) + ((port/operation/read-wide-substring port) port string start end) + 0)) + +(define (input-port/read-external-string! port string) + (input-port/read-external-substring! + port + string + 0 + (external-string-length string))) + +(define (input-port/read-external-substring! port string start end) + (if (< start end) + ((port/operation/read-external-substring port) port string start end) + 0)) + (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 (make-record-type ' '())) -(define eof-object? (record-predicate )) -(define eof-object ((record-constructor ))) -(define (make-eof-object port) port eof-object) + (port/with-input-blocking-mode port 'BLOCKING + (lambda () + (let loop ((a (make-accum 128))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (if (fix:> (cdr a) 0) + (accum->string a) + char)) + ((char=? char #\newline) (accum->string a)) + (else (loop (accum char a))))))))) + +(define (input-port/read-string port delimiters) + (port/with-input-blocking-mode port 'BLOCKING + (lambda () + (let loop ((a (make-accum 128))) + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + (accum->string a)) + ((char-set-member? delimiters char) + (input-port/unread-char port char) + (accum->string a)) + (else + (loop (accum char a))))))))) + +(define (input-port/discard-chars port delimiters) + (port/with-input-blocking-mode port 'BLOCKING + (lambda () + (let loop () + (let ((char (input-port/read-char port))) + (cond ((eof-object? char) + unspecific) + ((char-set-member? delimiters char) + (input-port/unread-char port char)) + (else + (loop)))))))) + +(define-integrable (make-accum n) + (cons (make-string n) 0)) + +(define (accum char a) + (if (fix:= (cdr a) (string-length (car a))) + (let ((s* (make-string (fix:* (cdr a) 2)))) + (substring-move! (car a) 0 (cdr a) s* 0) + (set-car! a s*))) + (string-set! (car a) (cdr a) char) + (set-cdr! a (fix:+ (cdr a) 1)) + a) + +(define-integrable (accum->string a) + (set-string-maximum-length! (car a) (cdr a)) + (car a)) + +(define-record-type + (make-eof-object port) + eof-object? + (port eof-object-port)) -;;;; Input Procedures +;;;; High level + +(define-syntax optional-input-port + (sc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form)) + (let ((port (close-syntax (cadr form) environment)) + (caller (close-syntax (caddr form) environment))) + `(IF (DEFAULT-OBJECT? ,port) + (CURRENT-INPUT-PORT) + (GUARANTEE-INPUT-PORT ,port ,caller))) + (ill-formed-syntax form))))) (define (char-ready? #!optional port interval) - (input-port/char-ready? (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'CHAR-READY?)) - (if (default-object? interval) - 0 - (begin - (if (not (exact-nonnegative-integer? interval)) - (error:wrong-type-argument interval - false - 'CHAR-READY?)) - interval)))) + (let ((port (optional-input-port port 'CHAR-READY?)) + (interval + (if (default-object? interval) + 0 + (begin + (guarantee-exact-nonnegative-integer interval 'CHAR-READY?) + interval)))) + (if (positive? interval) + (let ((timeout (+ (real-time-clock) interval))) + (let loop () + (cond ((input-port/char-ready? port) #t) + ((< (real-time-clock) timeout) (loop)) + (else #f)))) + (input-port/char-ready? port)))) -(define (peek-char #!optional port) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'PEEK-CHAR)))) +(define (read-char #!optional port) + (let ((port (optional-input-port port 'READ-CHAR))) (let loop () - (or (input-port/peek-char port) + (or (input-port/read-char port) (loop))))) -(define (read-char #!optional port) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-CHAR)))) +(define (unread-char char #!optional port) + (guarantee-char char 'UNREAD-CHAR) + (input-port/unread-char (optional-input-port port 'UNREAD-CHAR) char)) + +(define (peek-char #!optional port) + (let ((port (optional-input-port port 'PEEK-CHAR))) (let loop () - (or (input-port/read-char port) + (or (input-port/peek-char port) (loop))))) +(define (discard-char #!optional port) + (input-port/discard-char (optional-input-port port 'DISCARD-CHAR))) + (define (read-char-no-hang #!optional port) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-CHAR-NO-HANG)))) - (if (input-port/char-ready? port 0) + (let ((port (optional-input-port port 'READ-CHAR-NO-HANG))) + (if (input-port/char-ready? port) (input-port/read-char port) (let ((eof? (port/operation port 'EOF?))) (and eof? (eof? port) - eof-object))))) + (make-eof-object port)))))) (define (read-string delimiters #!optional port) - (input-port/read-string (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-STRING)) - delimiters)) + (input-port/read-string (optional-input-port port 'READ-STRING) delimiters)) (define (read #!optional port parser-table) - (parse-object (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ)) + (parse-object (optional-input-port port 'READ) (if (default-object? parser-table) (current-parser-table) - parser-table))) + (begin + (guarantee-parser-table parser-table 'READ) + parser-table)))) (define (read-line #!optional port) - (input-port/read-line (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-LINE)))) + (input-port/read-line (optional-input-port port 'READ-LINE))) (define (read-string! string #!optional port) - (input-port/read-string! (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-STRING!)) - string)) + (let ((port (optional-input-port port 'READ-STRING!))) + (cond ((string? string) + (input-port/read-string! port string)) + ((wide-string? string) + (input-port/read-wide-string! port string)) + ((external-string? string) + (input-port/read-external-string! port string)) + (else + (error:wrong-type-argument string "string" 'READ-STRING!))))) (define (read-substring! string start end #!optional port) - (input-port/read-substring! (if (default-object? port) - (current-input-port) - (guarantee-input-port port 'READ-SUBSTRING!)) - string start end)) \ No newline at end of file + (let ((port (optional-input-port port 'READ-STRING!))) + (cond ((string? string) + (input-port/read-substring! port string start end)) + ((wide-string? string) + (input-port/read-wide-substring! port string start end)) + ((external-string? string) + (input-port/read-external-substring! port string start end)) + (else + (error:wrong-type-argument string "string" 'READ-SUBSTRING!))))) \ No newline at end of file diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 02e15a351..f2af013b9 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: io.scm,v 14.78 2004/01/19 04:37:14 cph Exp $ +$Id: io.scm,v 14.79 2004/02/16 05:36:50 cph Exp $ Copyright 1986,1987,1988,1990,1991,1993 Massachusetts Institute of Technology Copyright 1994,1995,1998,1999,2000,2001 Massachusetts Institute of Technology @@ -231,11 +231,10 @@ USA. (cond ((not n) (loop start n-left)) ((< n n-left) (loop (+ start n) (- n-left n))))))) -(define (channel-write-string-block channel string) - (channel-write-block channel string 0 (string-length string))) - -(define (channel-write-char-block channel char) - (channel-write-block channel (string char) 0 1)) +(define (channel-write-byte-block channel byte) + (let ((bytes (make-string 1))) + (vector-8b-set! bytes 0 byte) + (channel-write-block channel bytes 0 1))) (define (channel-blocking? channel) ((ucode-primitive channel-blocking? 1) (channel-descriptor channel))) @@ -411,7 +410,7 @@ USA. (define (pty-master-hangup channel) ((ucode-primitive pty-master-hangup 1) (channel-descriptor channel))) - + ;;;; Directory Primitives (define-structure (directory-channel (conc-name directory-channel/)) @@ -436,635 +435,6 @@ USA. (directory-channel/descriptor channel) prefix)) -;;;; Buffered Output - -(define-structure (output-buffer - (conc-name output-buffer/) - (constructor %make-output-buffer)) - (channel #f read-only #t) - string - position - line-translation ; string that newline maps to - logical-size - closed? - column) - -(define (output-buffer-sizes translation buffer-size) - (let ((logical-size - (if (and translation (fix:< buffer-size 1)) - 1 - buffer-size))) - (values logical-size - (if (not translation) - logical-size - (fix:+ logical-size - (fix:- (string-length translation) 1)))))) - -(define (make-output-buffer channel buffer-size #!optional line-translation) - (let ((translation - (if (or (default-object? line-translation) - ;; Kludge because of DEFAULT-OBJECT?: - (eq? 'DEFAULT line-translation)) - (if (eq? 'TCP-STREAM-SOCKET (channel-type channel)) - "\r\n" - (os/default-end-of-line-translation)) - (if (and (string? line-translation) - (string=? "\n" line-translation)) - #f - line-translation)))) - (with-values (lambda () (output-buffer-sizes translation buffer-size)) - (lambda (logical-size string-size) - (%make-output-buffer channel - (and (fix:> string-size 0) - (make-string string-size)) - 0 - translation - logical-size - #f - 0))))) - -(define (output-buffer/close buffer associated-buffer) - (output-buffer/drain-block buffer) - (without-interrupts - (lambda () - (set-output-buffer/closed?! buffer #t) - (let ((channel (output-buffer/channel buffer))) - (if (not (and (input-buffer? associated-buffer) - (eq? channel (input-buffer/channel associated-buffer)) - (input-buffer/open? associated-buffer))) - (channel-close channel)))))) - -(define-integrable (output-buffer/open? buffer) - (not (output-buffer/closed? buffer))) - -(define (output-buffer/size buffer) - (output-buffer/logical-size buffer)) - -(define (output-buffer/set-size buffer buffer-size) - (output-buffer/drain-block buffer) - (with-values - (lambda () - (output-buffer-sizes (output-buffer/line-translation buffer) - buffer-size)) - (lambda (logical-size string-size) - (set-output-buffer/logical-size! buffer logical-size) - (set-output-buffer/string! - buffer - (and (fix:> string-size 0) (make-string string-size)))))) - -(define output-buffer/buffered-chars - output-buffer/position) - -(define (output-buffer/write-substring buffer string start end) - (let ((name 'OUTPUT-BUFFER/WRITE-SUBSTRING)) - (if (output-buffer/closed? buffer) - (error:bad-range-argument buffer name)) - (cond ((string? string) - (if (not (index-fixnum? start)) - (error:wrong-type-argument start "string index" name)) - (if (not (index-fixnum? end)) - (error:wrong-type-argument end "string index" name)) - (if (not (fix:<= end (string-length string))) - (error:bad-range-argument end name)) - (cond ((fix:< start end) - (output-buffer/write-substring-1 buffer string start end)) - ((fix:= start end) 0) - (else (error:bad-range-argument start name)))) - ((external-string? string) - (if (not (exact-nonnegative-integer? start)) - (error:wrong-type-argument start "exact nonnegative integer" - name)) - (if (not (exact-nonnegative-integer? end)) - (error:wrong-type-argument end "exact nonnegative integer" - name)) - (if (not (<= end (external-string-length string))) - (error:bad-range-argument end name)) - (cond ((< start end) - (output-buffer/write-xsubstring buffer string start end)) - ((= start end) 0) - (else (error:bad-range-argument start name)))) - (else - (error:wrong-type-argument string "string" name))))) - -(define (output-buffer/write-xsubstring buffer string start end) - (cond ((output-buffer/line-translation buffer) - (let* ((n 65536) - (b (make-string n))) - (let loop ((index start)) - (if (< index end) - (let ((n-to-write (min (- end index) n))) - (xsubstring-move! string index (+ index n-to-write) b 0) - (let ((n-written - (output-buffer/write-substring-1 buffer - b 0 n-to-write))) - (let ((index* (+ n-written index))) - (if (< n-written n-to-write) - (- index* start) - (loop index*))))) - (- index start))))) - ((and (output-buffer/string buffer) - (<= (- end start) - (fix:- (output-buffer/logical-size buffer) - (output-buffer/position buffer)))) - (xsubstring-move! string start end - (output-buffer/string buffer) - (output-buffer/position buffer)) - (set-output-buffer/position! buffer - (fix:+ (output-buffer/position buffer) - (- end start)))) - (else - (output-buffer/drain-block buffer) - (or (channel-write (output-buffer/channel buffer) string start end) - 0)))) - -(define (output-buffer/write-substring-1 buffer string start end) - (define (write-buffered start end n-previous) - (if (fix:< start end) - (let loop ((start start) (n-previous n-previous)) - (let ((n-left (fix:- end start)) - (max-posn (output-buffer/logical-size buffer))) - (let ((room (fix:- max-posn (output-buffer/position buffer)))) - (cond ((fix:>= room n-left) - (add-to-buffer string start end) - (if (fix:= n-left room) - (output-buffer/drain buffer)) - (fix:+ n-previous n-left)) - ((fix:> room 0) - (let ((new-start (fix:+ start room)) - (n-previous (fix:+ n-previous room))) - (add-to-buffer string start new-start) - (if (fix:< (output-buffer/drain buffer) max-posn) - (loop new-start n-previous) - n-previous))) - (else - (if (fix:< (output-buffer/drain buffer) max-posn) - (loop start n-previous) - n-previous)))))) - n-previous)) - - (define (write-newline) - ;; This transfers the end-of-line string atomically. In this way, - ;; as far as the Scheme program is concerned, either the newline - ;; has been completely buffered/written, or it has not at all. - (let ((translation (output-buffer/line-translation buffer))) - (let ((tlen (string-length translation))) - (let loop () - (let ((posn (output-buffer/position buffer))) - (if (fix:<= tlen - (fix:- (string-length (output-buffer/string buffer)) - posn)) - (begin - (add-to-buffer translation 0 tlen) - #t) - (and (fix:< (output-buffer/drain buffer) posn) - (loop)))))))) - - (define (add-to-buffer string start end) - (let ((posn (output-buffer/position buffer))) - (substring-move! string start end (output-buffer/string buffer) posn) - (set-output-buffer/position! buffer (fix:+ posn (fix:- end start))))) - - (let ((n-written - (cond ((not (output-buffer/string buffer)) - (or (channel-write (output-buffer/channel buffer) - string start end) - 0)) - ((not (output-buffer/line-translation buffer)) - (write-buffered start end 0)) - (else - (let loop ((start start) (n-prev 0)) - (let find-newline ((index start)) - (cond ((fix:= index end) - (write-buffered start end n-prev)) - ((not (char=? (string-ref string index) #\newline)) - (find-newline (fix:+ index 1))) - (else - (let ((n-prev* (write-buffered start index n-prev))) - (if (or (fix:< n-prev* - (fix:+ n-prev (fix:- start index))) - (not (write-newline))) - n-prev* - (loop (fix:+ index 1) - (fix:+ n-prev* 1)))))))))))) - (set-output-buffer/column! - buffer - (let* ((end (fix:+ start n-written)) - (nl (substring-find-previous-char string start end #\newline))) - (if nl - (count-columns string (fix:+ nl 1) end 0) - (count-columns string start end (output-buffer/column buffer))))) - n-written)) - -(define (count-columns string start end column) - ;; This simple-minded algorithm works only for a limited subset of - ;; US-ASCII. Doing a better job quickly gets very hairy. - (do ((start start (fix:+ start 1)) - (column column - (fix:+ column - (if (char=? #\tab (string-ref string start)) - (fix:- 8 (fix:remainder column 8)) - 1)))) - ((fix:= start end) column))) - -(define (output-buffer/drain buffer) - (let ((string (output-buffer/string buffer)) - (position (output-buffer/position buffer))) - (if (or (not string) (zero? position) (output-buffer/closed? buffer)) - 0 - (let ((n (channel-write - (output-buffer/channel buffer) - string - 0 - (let ((logical-size (output-buffer/logical-size buffer))) - (if (fix:> position logical-size) - logical-size - position))))) - (cond ((or (not n) (fix:= n 0)) - position) - ((fix:< n position) - (let ((position* (fix:- position n))) - (substring-move! string n position string 0) - (set-output-buffer/position! buffer position*) - position*)) - (else - (set-output-buffer/position! buffer 0) - 0)))))) - -(define (output-buffer/flush buffer) - (set-output-buffer/position! buffer 0)) - -(define (output-buffer/drain-block buffer) - (let loop () - (if (not (fix:= (output-buffer/drain buffer) 0)) - (loop)))) - -(define (output-buffer/write-substring-block buffer string start end) - (do ((start start - (+ start - (output-buffer/write-substring buffer string start end)))) - ((>= start end)))) - -(define (output-buffer/write-char-block buffer char) - (output-buffer/write-substring-block buffer (string char) 0 1)) - -;;;; Buffered Input - -(define-structure (input-buffer - (conc-name input-buffer/) - (constructor %make-input-buffer)) - (channel #f read-only #t) - string - start-index - end-index - line-translation ; string that maps to newline - ;; REAL-END is zero iff the buffer is closed. - real-end) - -(define (input-buffer-size translation buffer-size) - (cond ((not translation) - (if (fix:< buffer-size 1) - 1 - buffer-size)) - ((fix:< buffer-size (string-length translation)) - (string-length translation)) - (else - buffer-size))) - -(define (make-input-buffer channel buffer-size #!optional line-translation) - (let* ((translation - (if (or (default-object? line-translation) - ;; Kludge because of DEFAULT-OBJECT?: - (eq? 'DEFAULT line-translation)) - (if (eq? 'TCP-STREAM-SOCKET (channel-type channel)) - "\r\n" - (os/default-end-of-line-translation)) - (if (and (string? line-translation) - (string=? "\n" line-translation)) - #f - line-translation))) - (string-size (input-buffer-size translation buffer-size))) - (%make-input-buffer channel - (make-string string-size) - string-size - string-size - translation - string-size))) - -(define (input-buffer/close buffer associated-buffer) - (without-interrupts - (lambda () - (set-input-buffer/real-end! buffer 0) - (let ((channel (input-buffer/channel buffer))) - (if (not (and (output-buffer? associated-buffer) - (eq? channel (output-buffer/channel associated-buffer)) - (output-buffer/open? associated-buffer))) - (channel-close channel)))))) - -(define-integrable (input-buffer/closed? buffer) - (fix:= 0 (input-buffer/real-end buffer))) - -(define-integrable (input-buffer/open? buffer) - (not (input-buffer/closed? buffer))) - -(define (input-buffer/size buffer) - (string-length (input-buffer/string buffer))) - -(define (input-buffer/set-size buffer buffer-size) - ;; Returns the actual buffer size, which may be different from the arg. - ;; Discards any buffered characters. - (without-interrupts - (lambda () - (if (input-buffer/closed? buffer) - 0 - (let ((string-size - (input-buffer-size (input-buffer/line-translation buffer) - buffer-size))) - (let ((old-string (input-buffer/string buffer)) - (delta (fix:- (input-buffer/real-end buffer) - (input-buffer/end-index buffer)))) - (set-input-buffer/string! buffer (make-string string-size)) - (let ((logical-end - (if (fix:zero? delta) - string-size - (let ((logical-end (fix:- string-size delta))) - (substring-move! old-string - (input-buffer/end-index buffer) - (input-buffer/real-end buffer) - (input-buffer/string buffer) - logical-end) - logical-end)))) - (set-input-buffer/start-index! buffer logical-end) - (set-input-buffer/end-index! buffer logical-end) - (set-input-buffer/real-end! buffer string-size) - string-size))))))) - -(define (input-buffer/flush buffer) - (without-interrupts - (lambda () - (set-input-buffer/start-index! buffer (input-buffer/end-index buffer))))) - -(define (input-buffer/buffered-chars buffer) - (without-interrupts - (lambda () - (fix:- (input-buffer/end-index buffer) - (input-buffer/start-index buffer))))) - -(define (input-buffer/fill buffer) - ;; Assumption: - ;; (and (input-buffer/open? buffer) - ;; (fix:= (input-buffer/start-index buffer) - ;; (input-buffer/end-index buffer))) - (let ((delta - (fix:- (input-buffer/real-end buffer) - (input-buffer/end-index buffer))) - (string (input-buffer/string buffer))) - (if (not (fix:= delta 0)) - (substring-move! string - (input-buffer/end-index buffer) - (input-buffer/real-end buffer) - string - 0)) - (let ((n-read - (channel-read (input-buffer/channel buffer) - string delta (string-length string)))) - (and n-read - (input-buffer/after-fill! buffer (fix:+ delta n-read)))))) - -(define (input-buffer/after-fill! buffer end-index) - (set-input-buffer/start-index! buffer 0) - (set-input-buffer/end-index! buffer end-index) - (set-input-buffer/real-end! buffer end-index) - (if (and (input-buffer/line-translation buffer) - (not (fix:= end-index 0))) - (input-buffer/translate! buffer) - end-index)) - -(define-integrable (input-buffer/fill* buffer) - (let ((n (input-buffer/fill buffer))) - (and n - (fix:> n 0)))) - -(define (input-buffer/chars-remaining buffer) - (without-interrupts - (lambda () - (and (input-buffer/open? buffer) - (not (input-buffer/line-translation buffer)) - (let ((channel (input-buffer/channel buffer))) - (and (channel-type=file? channel) - (let ((n - (fix:- (channel-file-length channel) - (channel-file-position channel)))) - (and (fix:>= n 0) - (fix:+ (input-buffer/buffered-chars buffer) n))))))))) - -(define (input-buffer/char-ready? buffer interval) - (without-interrupts - (lambda () - (%input-buffer/char-ready? buffer interval)))) - -(define (%input-buffer/char-ready? buffer interval) - (and (input-buffer/open? buffer) - (or (fix:< (input-buffer/start-index buffer) - (input-buffer/end-index buffer)) - (let ((test - (let ((d - (channel-descriptor-for-select - (input-buffer/channel buffer)))) - (lambda () - (let ((mode (test-select-descriptor d #f 'READ))) - (if (pair? mode) - (or (eq? (car mode) 'READ) - (eq? (car mode) 'READ/WRITE)) - (begin - (if (eq? mode 'PROCESS-STATUS-CHANGE) - (handle-subprocess-status-change)) - #f))))))) - (if (positive? interval) - (let ((timeout (+ (real-time-clock) interval))) - (let loop () - (cond ((test) #t) - ((< (real-time-clock) timeout) (loop)) - (else #f)))) - (test)))))) - -(define (input-buffer/eof? buffer) - ;; This returns #t iff it knows that it is at EOF. - ;; If BUFFER is non-blocking with no input available, it returns #f. - (and (not (input-buffer/char-ready? buffer 0)) - (input-buffer/closed? buffer))) - -(define (input-buffer/buffer-contents buffer) - (without-interrupts - (lambda () - (and (fix:< (input-buffer/start-index buffer) - (input-buffer/end-index buffer)) - (substring (input-buffer/string buffer) - (input-buffer/start-index buffer) - (input-buffer/end-index buffer)))))) - -(define (input-buffer/set-buffer-contents buffer contents) - (without-interrupts - (lambda () - (let ((contents-size (string-length contents))) - (if (fix:> contents-size 0) - (let ((string (input-buffer/string buffer))) - (if (fix:> contents-size (string-length string)) - (input-buffer/set-size buffer contents-size)) - (substring-move! contents 0 contents-size string 0) - (input-buffer/after-fill! buffer contents-size))))))) - -(define (input-buffer/translate! buffer) - (with-values - (lambda () - (substring/input-translate! (input-buffer/string buffer) - (input-buffer/line-translation buffer) - 0 - (input-buffer/real-end buffer))) - (lambda (logical-end real-end) - (set-input-buffer/end-index! buffer logical-end) - (set-input-buffer/real-end! buffer real-end) - (and (fix:> logical-end 0) logical-end)))) - -(define (substring/input-translate! string translation start end) - ;; This maps a multi-character (perhaps only 1) sequence into a - ;; single newline character. - (let ((tlen (string-length translation)) - (match (string-ref translation 0))) - - (define (find-loop index) - (cond ((fix:= index end) - (values index index)) - ((char=? match (string-ref string index)) - (case (verify index) - ((#F) (find-loop (fix:+ index 1))) - ((TOO-SHORT) (values index end)) - (else (clobber-loop index (fix:+ index tlen))))) - (else - (find-loop (fix:+ index 1))))) - - (define verify - (if (fix:= tlen 2) - (lambda (index) - (let ((index (fix:+ index 1))) - (if (fix:= index end) - 'TOO-SHORT - (char=? (string-ref translation 1) - (string-ref string index))))) - (lambda (index) - (let loop ((tind 1) (index (fix:+ index 1))) - (cond ((fix:= tind tlen) - #t) - ((fix:= index end) - 'TOO-SHORT) - (else - (and (char=? (string-ref translation tind) - (string-ref string index)) - (loop (fix:+ tind 1) - (fix:+ index 1))))))))) - - (define (clobber-loop target source) - ;; Found one match, continue looking at source - (string-set! string target #\newline) - (let find-next ((target (fix:+ target 1)) (source source)) - (cond ((fix:= source end) - ;; Pointers in sync. - (values target target)) - ((char=? match (string-ref string source)) - (case (verify source) - ((#F) - (string-set! string target (string-ref string source)) - (find-next (fix:+ target 1) (fix:+ source 1))) - ((TOO-SHORT) - ;; Pointers not in sync: buffer ends in what might - ;; be the middle of a translation sequence. - (do ((target* target (fix:+ target* 1)) - (source source (fix:+ source 1))) - ((fix:= source end) - (values target target*)) - (string-set! string target* (string-ref string source)))) - (else - (clobber-loop target (fix:+ source tlen))))) - (else - (string-set! string target (string-ref string source)) - (find-next (fix:+ target 1) (fix:+ source 1)))))) - - (find-loop start))) - -(define (input-buffer/read-char buffer) - (without-interrupts - (lambda () - (let ((start-index (input-buffer/start-index buffer))) - (cond ((fix:< start-index (input-buffer/end-index buffer)) - (set-input-buffer/start-index! buffer (fix:+ start-index 1)) - (string-ref (input-buffer/string buffer) start-index)) - ((input-buffer/closed? buffer) - eof-object) - (else - (let ((n (input-buffer/fill buffer))) - (cond ((not n) #f) - ((fix:= n 0) eof-object) - (else - (set-input-buffer/start-index! buffer 1) - (string-ref (input-buffer/string buffer) 0)))))))))) - -(define (input-buffer/peek-char buffer) - (without-interrupts - (lambda () - (let ((start-index (input-buffer/start-index buffer))) - (cond ((fix:< start-index (input-buffer/end-index buffer)) - (string-ref (input-buffer/string buffer) start-index)) - ((input-buffer/closed? buffer) - eof-object) - (else - (let ((n (input-buffer/fill buffer))) - (cond ((not n) #f) - ((fix:= n 0) eof-object) - (else - (string-ref (input-buffer/string buffer) 0)))))))))) - -(define (input-buffer/read-substring buffer string start end) - (define (transfer-input-buffer index) - (let ((bstart (input-buffer/start-index buffer)) - (bend (input-buffer/end-index buffer))) - (cond ((fix:< bstart bend) - (let ((bstring (input-buffer/string buffer)) - (available (fix:- bend bstart)) - (needed (- end index))) - (if (>= available needed) - (begin - (let ((bend (fix:+ bstart needed))) - (substring-move! bstring bstart bend string index) - (set-input-buffer/start-index! buffer bend)) - end) - (begin - (substring-move! bstring bstart bend string index) - (set-input-buffer/start-index! buffer bend) - (if (input-buffer/char-ready? buffer 0) - (transfer-input-buffer (+ index available)) - (+ index available)))))) - ((input-buffer/closed? buffer) - index) - (else - (read-directly index))))) - - (define (read-directly index) - (if (and (not (input-buffer/line-translation buffer)) - (>= (- end index) (input-buffer/size buffer))) - (let ((n - (channel-read (input-buffer/channel buffer) string index end))) - (if n - (+ index n) - (and (not (= index start)) index))) - (if (input-buffer/fill buffer) - (transfer-input-buffer index) - (and (not (= index start)) index)))) - - (without-interrupts - (lambda () - (let ((index (transfer-input-buffer start))) - (and index - (- index start)))))) - ;;;; Select registry (define have-select?) @@ -1120,6 +490,18 @@ USA. (channel-blocking? channel) mode)) +(define (channel-has-input? channel) + (let ((descriptor (channel-descriptor-for-select channel))) + (let loop () + (let ((mode (test-select-descriptor descriptor #f 'READ))) + (if (pair? mode) + (or (eq? (car mode) 'READ) + (eq? (car mode) 'READ/WRITE)) + (begin + (if (eq? mode 'PROCESS-STATUS-CHANGE) + (handle-subprocess-status-change)) + (loop))))))) + (define-integrable (channel-descriptor-for-select channel) ((ucode-primitive channel-descriptor 1) (channel-descriptor channel))) diff --git a/v7/src/runtime/mime-codec.scm b/v7/src/runtime/mime-codec.scm index 97469e8c6..cc9cec9bf 100644 --- a/v7/src/runtime/mime-codec.scm +++ b/v7/src/runtime/mime-codec.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: mime-codec.scm,v 14.14 2003/02/14 18:28:33 cph Exp $ +$Id: mime-codec.scm,v 14.15 2004/02/16 05:36:56 cph Exp $ -Copyright 2000, 2001 Massachusetts Institute of Technology +Copyright 2000,2001,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -174,9 +174,15 @@ USA. (define decode-quoted-printable-port-type (make-port-type - `((WRITE-SUBSTRING + `((WRITE-CHAR + ,(lambda (port char) + (guarantee-8-bit-char char) + (decode-quoted-printable:update (port/state port) (string char) 0 1) + 1)) + (WRITE-SUBSTRING ,(lambda (port string start end) - (decode-quoted-printable:update (port/state port) string start end))) + (decode-quoted-printable:update (port/state port) string start end) + (fix:- end start))) (CLOSE-OUTPUT ,(lambda (port) (decode-quoted-printable:finalize (port/state port))))) @@ -458,9 +464,15 @@ USA. (define decode-base64-port-type (make-port-type - `((WRITE-SUBSTRING + `((WRITE-CHAR + ,(lambda (port char) + (guarantee-8-bit-char char) + (decode-base64:update (port/state port) (string char) 0 1) + 1)) + (WRITE-SUBSTRING ,(lambda (port string start end) - (decode-base64:update (port/state port) string start end))) + (decode-base64:update (port/state port) string start end) + (fix:- end start))) (CLOSE-OUTPUT ,(lambda (port) (decode-base64:finalize (port/state port))))) @@ -480,7 +492,7 @@ USA. (input-state 'LINE-START) (output-buffer (make-string 3) read-only #t) (pending-return? #f)) - + (define (decode-base64:finalize context) (if (fix:> (base64-decoding-context/input-index context) 0) (error "BASE64 input length is not a multiple of 4.")) @@ -615,9 +627,15 @@ USA. (define decode-binhex40-port-type (make-port-type - `((WRITE-SUBSTRING + `((WRITE-CHAR + ,(lambda (port char) + (guarantee-8-bit-char char) + (decode-binhex40:update (port/state port) (string char) 0 1) + 1)) + (WRITE-SUBSTRING ,(lambda (port string start end) - (decode-binhex40:update (port/state port) string start end))) + (decode-binhex40:update (port/state port) string start end) + (fix:- end start))) (CLOSE-OUTPUT ,(lambda (port) (decode-binhex40:finalize (port/state port))))) @@ -770,6 +788,7 @@ USA. (make-port-type `((WRITE-CHAR ,(lambda (port char) + (guarantee-8-bit-char char) (let ((state (port/state port))) (let ((port (binhex40-rld-state/port state)) (char* (binhex40-rld-state/char state))) @@ -789,7 +808,8 @@ USA. (set-binhex40-rld-state/marker-seen?! state #t)) (else (if char* (write-char char* port)) - (set-binhex40-rld-state/char! state char))))))) + (set-binhex40-rld-state/char! state char))))) + 1)) (CLOSE-OUTPUT ,(lambda (port) (let ((state (port/state port))) @@ -826,12 +846,14 @@ USA. (make-port-type `((WRITE-CHAR ,(lambda (port char) + (guarantee-8-bit-char char) (case (binhex40-decon/state (port/state port)) ((READING-HEADER) (binhex40-decon-reading-header port char)) ((COPYING-DATA) (binhex40-decon-copying-data port char)) ((SKIPPING-TAIL) (binhex40-decon-skipping-tail port)) ((FINISHED) unspecific) - (else (error "Illegal state in BinHex 4.0 deconstructor."))))) + (else (error "Illegal state in BinHex 4.0 deconstructor."))) + 1)) (CLOSE-OUTPUT ,(lambda (port) (if (not (eq? (binhex40-decon/state (port/state port)) 'FINISHED)) diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index b3d9b9c5f..2b52065d3 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.44 2003/09/23 03:37:16 cph Exp $ +$Id: ntprm.scm,v 1.45 2004/02/16 05:37:03 cph Exp $ Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -316,16 +316,16 @@ USA. (error "Unable to find Windows system root.")) (pathname-new-directory (pathname-as-directory sysroot) '(ABSOLUTE))))) -(define (os/file-end-of-line-translation pathname) +(define (file-line-ending pathname) (if (let ((type (dos/fs-drive-type pathname))) (or (string=? "NFS" (car type)) (string=? "NtNfs" (car type)) (string=? "Samba" (car type)))) - #f - "\r\n")) + 'LF + 'CRLF)) -(define (os/default-end-of-line-translation) - "\r\n") +(define (default-line-ending) + 'CRLF) (define (dos/fs-drive-type pathname) ;; (system-name . [nfs-]mount-point) diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm index 9efa5faa1..b76d7faf4 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.51 2003/02/14 18:28:33 cph Exp $ +$Id: os2prm.scm,v 1.52 2004/02/16 05:37:14 cph Exp $ Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology -Copyright 2001,2003 Massachusetts Institute of Technology +Copyright 2001,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -263,7 +263,7 @@ USA. (define (dos/fs-long-filenames? pathname) (not (string-ci=? "fat" (car (dos/fs-drive-type pathname))))) -(define (os/file-end-of-line-translation pathname) +(define (file-line-ending pathname) (let ((type (dos/fs-drive-type pathname))) ;; "ext2" is the Linux ext2 file-system driver. "NFS" is the IBM ;; TCP/IP NFS driver, which we further qualify by examining the @@ -276,11 +276,11 @@ USA. (and colon (fix:< (fix:+ colon 1) (string-length mount)) (char=? #\/ (string-ref mount (fix:+ colon 1))))))) - #f - "\r\n"))) + 'LF + 'CRLF))) -(define (os/default-end-of-line-translation) - "\r\n") +(define (default-line-ending) + 'CRLF) (define (copy-file from to) ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from)) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index fb188f9bf..6744669c1 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: output.scm,v 14.32 2003/02/14 18:28:33 cph Exp $ +$Id: output.scm,v 14.33 2004/02/16 05:37:21 cph Exp $ -Copyright (c) 1986,1987,1988,1989,1990 Massachusetts Institute of Technology -Copyright (c) 1991,1992,1993,1999,2001 Massachusetts Institute of Technology -Copyright (c) 2002,2003 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1999,2001,2002,2003 Massachusetts Institute of Technology +Copyright 2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -30,28 +30,40 @@ USA. (declare (usual-integrations)) -;;;; Output Ports +;;;; Low level (define (output-port/write-char port char) - ((output-port/operation/write-char port) port char)) + ((port/operation/write-char port) port char)) (define (output-port/write-string port string) (output-port/write-substring port string 0 (xstring-length string))) (define (output-port/write-substring port string start end) - ((output-port/operation/write-substring port) port string start end)) + ((port/operation/write-substring port) port string start end)) -(define (output-port/write-object port object) - (unparse-object/top-level object port #t (current-unparser-table))) +(define (output-port/write-wide-string port string) + (output-port/write-wide-substring port string 0 (xstring-length string))) + +(define (output-port/write-wide-substring port string start end) + ((port/operation/write-wide-substring port) port string start end)) + +(define (output-port/write-external-string port string) + (output-port/write-external-substring port string 0 (xstring-length string))) + +(define (output-port/write-external-substring port string start end) + ((port/operation/write-external-substring port) port string start end)) (define (output-port/fresh-line port) - ((output-port/operation/fresh-line port) port)) + ((port/operation/fresh-line port) port)) (define (output-port/flush-output port) - ((output-port/operation/flush-output port) port)) + ((port/operation/flush-output port) port)) (define (output-port/discretionary-flush port) - ((output-port/operation/discretionary-flush port) port)) + ((port/operation/discretionary-flush-output port) port)) + +(define (output-port/write-object port object unparser-table) + (unparse-object/top-level object port #t unparser-table)) (define (output-port/x-size port) (or (let ((operation (port/operation port 'X-SIZE))) @@ -69,54 +81,111 @@ USA. (and operation (operation port)))) -;;;; Output Procedures +;;;; High level + +(define-syntax optional-output-port + (sc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form)) + (let ((port (close-syntax (cadr form) environment)) + (caller (close-syntax (caddr form) environment))) + `(IF (DEFAULT-OBJECT? ,port) + (CURRENT-OUTPUT-PORT) + (GUARANTEE-OUTPUT-PORT ,port ,caller))) + (ill-formed-syntax form))))) + +(define (write-char char #!optional port) + (let ((port (optional-output-port port 'WRITE-CHAR))) + (if (let ((n (output-port/write-char port char))) + (and n + (fix:> n 0))) + (output-port/discretionary-flush port)))) + +(define (write-string string #!optional port) + (let ((port (optional-output-port port 'WRITE-STRING))) + (if (let ((n + (cond ((string? string) + (output-port/write-string port string)) + ((wide-string? string) + (output-port/write-wide-string port string)) + ((external-string? string) + (output-port/write-external-string port string)) + (else + (error:wrong-type-argument string "string" + 'WRITE-STRING))))) + (and n + (> n 0))) + (output-port/discretionary-flush port)))) + +(define (write-substring string start end #!optional port) + (let ((port (optional-output-port port 'WRITE-SUBSTRING))) + (if (let ((n + (cond ((string? string) + (output-port/write-substring port string start end)) + ((wide-string? string) + (output-port/write-wide-substring port string start end)) + ((external-string? string) + (output-port/write-external-substring port + string start end)) + (else + (error:wrong-type-argument string "string" + 'WRITE-SUBSTRING))))) + (and n + (> n 0))) + (output-port/discretionary-flush port)))) (define (newline #!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'NEWLINE)))) - (output-port/write-char port #\newline) - (output-port/discretionary-flush port))) + (let ((port (optional-output-port port 'NEWLINE))) + (if (let ((n (output-port/write-char port #\newline))) + (and n + (fix:> n 0))) + (output-port/discretionary-flush port)))) (define (fresh-line #!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'FRESH-LINE)))) - (output-port/fresh-line port) - (output-port/discretionary-flush port))) + (let ((port (optional-output-port port 'FRESH-LINE))) + (if (let ((n (output-port/fresh-line port))) + (and n + (fix:> n 0))) + (output-port/discretionary-flush port)))) + +(define-syntax optional-unparser-table + (sc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(EXPRESSION EXPRESSION) (cdr form)) + (let ((unparser-table (close-syntax (cadr form) environment)) + (caller (close-syntax (caddr form) environment))) + `(IF (DEFAULT-OBJECT? ,unparser-table) + (CURRENT-UNPARSER-TABLE) + (GUARANTEE-UNPARSER-TABLE ,unparser-table ,caller))) + (ill-formed-syntax form))))) -(define (write-char char #!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'WRITE-CHAR)))) - (output-port/write-char port char) +(define (display object #!optional port unparser-table) + (let ((port (optional-output-port port 'DISPLAY))) + (unparse-object/top-level object port #f + (optional-unparser-table unparser-table + 'DISPLAY)) (output-port/discretionary-flush port))) -(define (write-string string #!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'WRITE-STRING)))) - (output-port/write-string port string) +(define (write object #!optional port unparser-table) + (let ((port (optional-output-port port 'WRITE))) + (output-port/write-object port object + (optional-unparser-table unparser-table 'WRITE)) (output-port/discretionary-flush port))) -(define (write-substring string start end #!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'WRITE-SUBSTRING)))) - (output-port/write-substring port string start end) +(define (write-line object #!optional port unparser-table) + (let ((port (optional-output-port port 'WRITE-LINE))) + (output-port/write-object port object + (optional-unparser-table unparser-table + 'WRITE-LINE)) + (output-port/write-char port #\newline) (output-port/discretionary-flush port))) +(define (flush-output #!optional port) + (output-port/flush-output (optional-output-port port 'FLUSH-OUTPUT))) + (define (wrap-custom-operation-0 operation-name) (lambda (#!optional port) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port operation-name)))) + (let ((port (optional-output-port port operation-name))) (let ((operation (port/operation port operation-name))) (if operation (begin @@ -126,51 +195,6 @@ USA. (define beep (wrap-custom-operation-0 'BEEP)) (define clear (wrap-custom-operation-0 'CLEAR)) -(define (display object #!optional port unparser-table) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'DISPLAY))) - (unparser-table - (if (default-object? unparser-table) - (current-unparser-table) - (guarantee-unparser-table unparser-table 'DISPLAY)))) - (if (string? object) - (output-port/write-string port object) - (unparse-object/top-level object port #f unparser-table)) - (output-port/discretionary-flush port))) - -(define (write object #!optional port unparser-table) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'WRITE))) - (unparser-table - (if (default-object? unparser-table) - (current-unparser-table) - (guarantee-unparser-table unparser-table 'WRITE)))) - (unparse-object/top-level object port #t unparser-table) - (output-port/discretionary-flush port))) - -(define (write-line object #!optional port unparser-table) - (let ((port - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'WRITE-LINE))) - (unparser-table - (if (default-object? unparser-table) - (current-unparser-table) - (guarantee-unparser-table unparser-table 'WRITE-LINE)))) - (unparse-object/top-level object port #t unparser-table) - (output-port/write-char port #\newline) - (output-port/discretionary-flush port))) - -(define (flush-output #!optional port) - (output-port/flush-output - (if (default-object? port) - (current-output-port) - (guarantee-output-port port 'FLUSH-OUTPUT)))) - ;;;; Tabular output (define (write-strings-in-columns strings port row-major? min-minor diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index b01011816..f1aa047e3 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: parse.scm,v 14.49 2004/01/19 05:06:17 cph Exp $ +$Id: parse.scm,v 14.50 2004/02/16 05:37:27 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1997,1998,1999 Massachusetts Institute of Technology @@ -36,13 +36,9 @@ USA. (define ignore-extra-list-closes #t) (define (parse-object port table) - (guarantee-input-port port 'PARSE-OBJECT) - (guarantee-parser-table table 'PARSE-OBJECT) ((top-level-parser port) port table)) (define (parse-objects port table last-object?) - (guarantee-input-port port 'PARSE-OBJECTS) - (guarantee-parser-table table 'PARSE-OBJECTS) (let ((parser (top-level-parser port))) (let loop () (let ((object (parser port table))) @@ -348,7 +344,7 @@ USA. (cond ((eq? ctx 'CLOSE-PAREN-OK) close-parenthesis) ((and (eq? ctx 'TOP-LEVEL) - (eq? (base-port port) (base-port console-input-port)) + (console-i/o-port? port) ignore-extra-list-closes) continue-parsing) (else @@ -580,14 +576,8 @@ USA. (define (position-operation port) (let ((default (lambda (port) port #f))) (if *parser-associate-positions?* - (or (input-port/operation port 'POSITION) - (let ((remaining (input-port/operation port 'CHARS-REMAINING)) - (length (input-port/operation port 'LENGTH))) - (if (and remaining length) - (let ((n-chars (length port))) - (lambda (port) - (- n-chars (remaining port)))) - default))) + (or (port/operation port 'POSITION) + default) default))) (define-integrable (current-position port db) diff --git a/v7/src/runtime/parser-buffer.scm b/v7/src/runtime/parser-buffer.scm index 138474ad7..1ccc17f87 100644 --- a/v7/src/runtime/parser-buffer.scm +++ b/v7/src/runtime/parser-buffer.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: parser-buffer.scm,v 1.10 2003/10/11 04:00:17 cph Exp $ +$Id: parser-buffer.scm,v 1.11 2004/02/16 05:37:34 cph Exp $ -Copyright 2001,2002,2003 Massachusetts Institute of Technology +Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -56,26 +56,48 @@ USA. ;;; buffer is one that reads from an unbuffered source of unbounded ;;; length. -(define (substring->parser-buffer string start end) - (make-parser-buffer string start end 0 start #f #t 0)) +(define (wide-string->parser-buffer string) + (guarantee-wide-string string 'WIDE-STRING->PARSER-BUFFER) + (make-parser-buffer string 0 (%wide-string-length string) 0 0 #f #t 0)) -(define (source->parser-buffer source) - (make-parser-buffer (make-string min-length) 0 0 0 0 source #f 0)) - -(define-integrable min-length 256) +(define (wide-substring->parser-buffer string start end) + (guarantee-wide-substring string start end 'WIDE-SUBSTRING->PARSER-BUFFER) + (make-parser-buffer string start end 0 start #f #t 0)) (define (string->parser-buffer string) - (substring->parser-buffer string 0 (string-length string))) + (guarantee-string string 'STRING->PARSER-BUFFER) + (%substring->parser-buffer string 0 (string-length string))) + +(define (substring->parser-buffer string start end) + (guarantee-substring string start end 'SUBSTRING->PARSER-BUFFER) + (%substring->parser-buffer string start end)) + +(define (%substring->parser-buffer string start end) + (let ((n (fix:- end start))) + (let ((s (make-wide-string n))) + (let ((v (wide-string-contents s))) + (do ((i start (fix:+ i 1)) + (j 0 (fix:+ j 1))) + ((not (fix:< i end))) + (vector-set! v j (string-ref string i)))) + (wide-substring->parser-buffer s 0 n)))) (define (input-port->parser-buffer port) (source->parser-buffer (lambda (string start end) - (read-substring! string start end port)))) + (port/with-input-blocking-mode port 'BLOCKING + (lambda () + (input-port/read-substring! port string start end)))))) +(define (source->parser-buffer source) + (make-parser-buffer (make-wide-string min-length) 0 0 0 0 source #f 0)) + +(define-integrable min-length 256) + (define-structure parser-buffer-pointer (index #f read-only #t) (line #f read-only #t)) - + (define (get-parser-buffer-pointer buffer) ;; Get an object that represents the current position. (make-parser-buffer-pointer (+ (parser-buffer-base-offset buffer) @@ -90,7 +112,7 @@ USA. (set-parser-buffer-line! buffer (parser-buffer-pointer-line p))) (define (get-parser-buffer-tail buffer p) - (call-with-parser-buffer-tail buffer p substring)) + (call-with-parser-buffer-tail buffer p wide-substring)) (define (call-with-parser-buffer-tail buffer p procedure) ;; P must be a buffer pointer previously returned by @@ -128,8 +150,8 @@ USA. ;; characters available, return #F and leave the position unchanged. (and (guarantee-buffer-chars buffer 1) (let ((char - (string-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)))) + (%wide-string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) (increment-buffer-index! buffer char) char))) @@ -138,126 +160,168 @@ USA. ;; current position. If there is a character available, return it, ;; otherwise return #F. The position is unaffected in either case. (and (guarantee-buffer-chars buffer 1) - (string-ref (parser-buffer-string buffer) - (parser-buffer-index buffer)))) + (%wide-string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) (define (parser-buffer-ref buffer index) (if (not (index-fixnum? index)) (error:wrong-type-argument index "index" 'PARSER-BUFFER-REF)) (and (guarantee-buffer-chars buffer (fix:+ index 1)) - (string-ref (parser-buffer-string buffer) - (fix:+ (parser-buffer-index buffer) index)))) + (%wide-string-ref (parser-buffer-string buffer) + (fix:+ (parser-buffer-index buffer) index)))) -(define-syntax char-matcher - (sc-macro-transformer - (lambda (form environment) - (let ((name (cadr form)) - (test - (make-syntactic-closure environment '(REFERENCE CHAR) - (caddr form)))) - `(BEGIN - (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name '-NO-ADVANCE) - BUFFER REFERENCE) - (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) - (LET ((CHAR - (STRING-REF (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER)))) - (DECLARE (INTEGRATE CHAR)) - ,test))) - (DEFINE (,(symbol-append 'MATCH-PARSER-BUFFER- name) - BUFFER REFERENCE) - (AND (GUARANTEE-BUFFER-CHARS BUFFER 1) - (LET ((CHAR - (STRING-REF (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER)))) - (AND ,test - (BEGIN - (INCREMENT-BUFFER-INDEX! BUFFER CHAR) - #T)))))))))) - -(char-matcher char (char=? char reference)) -(char-matcher char-ci (char-ci=? char reference)) -(char-matcher not-char (not (char=? char reference))) -(char-matcher not-char-ci (not (char-ci=? char reference))) -(char-matcher char-in-set (char-set-member? reference char)) - -(define (match-utf8-char-in-alphabet buffer alphabet) - (let ((p (get-parser-buffer-pointer buffer))) - (if (let ((char - (read-utf8-char-from-source - (lambda () - (let ((char (read-parser-buffer-char buffer))) - (and char - (char->integer char))))))) - (and (not (eof-object? char)) - (char-in-alphabet? char alphabet))) - #t - (begin - (set-parser-buffer-pointer! buffer p) - #f)))) +(define (match-parser-buffer-char buffer char) + (match-char buffer char char=?)) + +(define (match-parser-buffer-not-char buffer char) + (match-char-not buffer char char=?)) + +(define (match-parser-buffer-char-no-advance buffer char) + (match-char-no-advance buffer char char=?)) + +(define (match-parser-buffer-not-char-no-advance buffer char) + (match-char-not-no-advance buffer char char=?)) + +(define (match-parser-buffer-char-ci buffer char) + (match-char buffer char char-ci=?)) + +(define (match-parser-buffer-not-char-ci buffer char) + (match-char-not buffer char char-ci=?)) + +(define (match-parser-buffer-char-ci-no-advance buffer char) + (match-char-no-advance buffer char char-ci=?)) + +(define (match-parser-buffer-not-char-ci-no-advance buffer char) + (match-char-not-no-advance buffer char char-ci=?)) + +(define (match-parser-buffer-char-in-set buffer set) + (match-char buffer set char-in-set?)) + +(define (match-parser-buffer-char-not-in-set buffer set) + (match-char-not buffer set char-in-set?)) + +(define (match-parser-buffer-char-in-set-no-advance buffer set) + (match-char-no-advance buffer set char-in-set?)) + +(define (match-parser-buffer-char-not-in-set-no-advance buffer set) + (match-char-not-no-advance buffer set char-in-set?)) + +(define-integrable (char-in-set? char set) + (char-set-member? set char)) + +(define (match-parser-buffer-char-in-alphabet buffer alphabet) + (match-char buffer alphabet char-in-alphabet?)) + +(define (match-parser-buffer-char-not-in-alphabet buffer alphabet) + (match-char-not buffer alphabet char-in-alphabet?)) + +(define (match-parser-buffer-char-in-alphabet-no-advance buffer alphabet) + (match-char-no-advance buffer alphabet char-in-alphabet?)) + +(define (match-parser-buffer-char-not-in-alphabet-no-advance buffer alphabet) + (match-char-not-no-advance buffer alphabet char-in-alphabet?)) + +(define-integrable (match-char buffer reference compare) + (and (guarantee-buffer-chars buffer 1) + (let ((char + (%wide-string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)))) + (and (compare char reference) + (begin + (increment-buffer-index! buffer char) + #t))))) + +(define-integrable (match-char-no-advance buffer reference compare) + (and (guarantee-buffer-chars buffer 1) + (compare (%wide-string-ref (parser-buffer-string buffer) + (parser-buffer-index buffer)) + reference))) + +(define-integrable (match-char-not buffer reference compare) + (match-char buffer reference + (lambda (c1 c2) + (declare (integrate c1 c2)) + (not (compare c1 c2))))) + +(define-integrable (match-char-not-no-advance buffer reference compare) + (match-char-no-advance buffer reference + (lambda (c1 c2) + (declare (integrate c1 c2)) + (not (compare c1 c2))))) -(define-syntax string-matcher - (sc-macro-transformer - (lambda (form environment) - (let ((suffix (cadr form))) - `(DEFINE (,(intern - (string-append "match-parser-buffer-string" suffix)) - BUFFER STRING) - (,(close-syntax - (intern - (string-append "match-parser-buffer-substring" suffix)) - environment) - BUFFER STRING 0 (STRING-LENGTH STRING))))))) - -(string-matcher "") -(string-matcher "-ci") -(string-matcher "-no-advance") -(string-matcher "-ci-no-advance") - -(define-syntax substring-matcher - (sc-macro-transformer - (lambda (form environment) - (let ((suffix (cadr form))) - `(DEFINE (,(intern - (string-append "match-parser-buffer-substring" suffix)) - BUFFER STRING START END) - (LET ((N (FIX:- END START))) - (AND (GUARANTEE-BUFFER-CHARS BUFFER N) - (,(close-syntax - (intern (string-append "substring" suffix "=?")) - environment) - STRING START END - (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER) - (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N)) - (BEGIN - (BUFFER-INDEX+N! BUFFER N) - #T)))))))) - -(substring-matcher "") -(substring-matcher "-ci") - -(define-syntax substring-matcher-no-advance - (sc-macro-transformer - (lambda (form environment) - (let ((suffix (cadr form))) - `(DEFINE (,(intern - (string-append "match-parser-buffer-substring" - suffix - "-no-advance")) - BUFFER STRING START END) - (LET ((N (FIX:- END START))) - (AND (GUARANTEE-BUFFER-CHARS BUFFER N) - (,(close-syntax - (intern (string-append "substring" suffix "=?")) - environment) - STRING START END - (PARSER-BUFFER-STRING BUFFER) - (PARSER-BUFFER-INDEX BUFFER) - (FIX:+ (PARSER-BUFFER-INDEX BUFFER) N))))))))) - -(substring-matcher-no-advance "") -(substring-matcher-no-advance "-ci") +(define (match-parser-buffer-string buffer string) + (match-string buffer string match-substring-loop char=?)) + +(define (match-parser-buffer-string-ci buffer string) + (match-string buffer string match-substring-loop char-ci=?)) + +(define (match-parser-buffer-string-no-advance buffer string) + (match-string buffer string match-substring-loop-na char=?)) + +(define (match-parser-buffer-string-ci-no-advance buffer string) + (match-string buffer string match-substring-loop-na char-ci=?)) + +(define-integrable (match-string buffer string loop compare) + (cond ((wide-string? string) + (let ((v (wide-string-contents string))) + (let ((n (vector-length v))) + (loop buffer v 0 n compare vector-ref)))) + ((string? string) + (let ((n (string-length string))) + (loop buffer string 0 n compare string-ref))) + (else + (error:wrong-type-argument string "string" #f)))) + +(define (match-parser-buffer-substring buffer string start end) + (match-substring buffer string start end match-substring-loop char=?)) + +(define (match-parser-buffer-substring-ci buffer string start end) + (match-substring buffer string start end match-substring-loop char-ci=?)) + +(define (match-parser-buffer-substring-no-advance buffer string start end) + (match-substring buffer string start end match-substring-loop-na char=?)) + +(define (match-parser-buffer-substring-ci-no-advance buffer string start end) + (match-substring buffer string start end match-substring-loop-na char-ci=?)) + +(define-integrable (match-substring buffer string start end loop compare) + (cond ((wide-string? string) + (let ((v (wide-string-contents string))) + (loop buffer v start end compare vector-ref))) + ((string? string) + (loop buffer string start end compare string-ref)) + (else + (error:wrong-type-argument string "string" #f)))) + +(define-integrable (match-substring-loop buffer string start end + compare extract) + (and (guarantee-buffer-chars buffer (fix:- end start)) + (let ((bv (wide-string-contents (parser-buffer-string buffer)))) + (let loop + ((i start) + (bi (parser-buffer-index buffer)) + (bl (parser-buffer-line buffer))) + (if (fix:< i end) + (and (compare (extract string i) (vector-ref bv bi)) + (loop (fix:+ i 1) + (fix:+ bi 1) + (if (char=? (vector-ref bv bi) #\newline) + (fix:+ bl 1) + bl))) + (begin + (set-parser-buffer-index! buffer bi) + (set-parser-buffer-line! buffer bl) + #t)))))) + +(define-integrable (match-substring-loop-na buffer string start end + compare extract) + (and (guarantee-buffer-chars buffer (fix:- end start)) + (let ((bv (wide-string-contents (parser-buffer-string buffer)))) + (let loop ((i start) (bi (parser-buffer-index buffer))) + (if (fix:< i end) + (and (compare (extract string i) (vector-ref bv bi)) + (loop (fix:+ i 1) (fix:+ bi 1))) + #t))))) (define-integrable (increment-buffer-index! buffer char) (set-parser-buffer-index! buffer (fix:+ (parser-buffer-index buffer) 1)) @@ -266,13 +330,13 @@ USA. (define (buffer-index+n! buffer n) (let ((i (parser-buffer-index buffer)) - (s (parser-buffer-string buffer))) + (v (wide-string-contents (parser-buffer-string buffer)))) (let ((j (fix:+ i n))) - (do ((i i (fix:+ i 1))) - ((fix:= i j)) - (if (char=? (string-ref s i) #\newline) - (set-parser-buffer-line! buffer - (fix:+ (parser-buffer-line buffer) 1)))) + (let loop ((i i) (n (parser-buffer-line buffer))) + (if (fix:< i j) + (loop (fix:+ i 1) + (if (char=? (vector-ref v i) #\newline) (fix:+ n 1) n)) + (set-parser-buffer-line! buffer n))) (set-parser-buffer-index! buffer j)))) (define-integrable (guarantee-buffer-chars buffer n) @@ -286,20 +350,24 @@ USA. (and (not (parser-buffer-at-end? buffer)) (begin (let* ((string (parser-buffer-string buffer)) - (max-end (string-length string)) + (v1 (wide-string-contents string)) + (max-end (vector-length v1)) (max-end* (let loop ((max-end* max-end)) (if (fix:<= min-end max-end*) max-end* (loop (fix:* max-end* 2)))))) (if (fix:> max-end* max-end) - (let ((string* (make-string max-end*))) - (string-move! string string* 0) + (let ((string* (make-wide-string max-end*))) + (let ((v2 (wide-string-contents string*))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i end))) + (vector-set! v2 i (vector-ref v1 i)))) (set-parser-buffer-string! buffer string*)))) (let ((n-read (let ((string (parser-buffer-string buffer))) ((parser-buffer-source buffer) - string end (string-length string))))) + string end (%wide-string-length string))))) (if (fix:> n-read 0) (let ((end (fix:+ end n-read))) (set-parser-buffer-end! buffer end) @@ -318,14 +386,15 @@ USA. (if (fix:< 0 index) (let* ((end* (fix:- end index)) (string* - (let ((n (string-length string))) + (let ((n (%wide-string-length string))) (if (and (fix:> n min-length) (fix:<= end* (fix:quotient n 4))) - (make-string (fix:quotient n 2)) + (make-wide-string (fix:quotient n 2)) string)))) (without-interrupts (lambda () - (substring-move! string index end string* 0) + (subvector-move-left! (wide-string-contents string) index end + (wide-string-contents string*) 0) (set-parser-buffer-string! buffer string*) (set-parser-buffer-index! buffer 0) (set-parser-buffer-end! buffer end*) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 993b51ec1..eca895483 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,8 +1,10 @@ #| -*-Scheme-*- -$Id: pathnm.scm,v 14.36 2003/02/14 18:28:33 cph Exp $ +$Id: pathnm.scm,v 14.37 2004/02/16 05:37:40 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology +Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology +Copyright 2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -144,12 +146,6 @@ these rules: (define (pathname-version pathname) (%pathname-version (->pathname pathname))) - -(define (pathname-end-of-line-string pathname) - (let ((pathname (->pathname pathname))) - ((host-type/operation/end-of-line-string - (host/type (%pathname-host pathname))) - pathname))) (define (pathname=? x y) (let ((x (->pathname x)) @@ -458,8 +454,7 @@ these rules: (operation/pathname->truename #f read-only #t) (operation/user-homedir-pathname #f read-only #t) (operation/init-file-pathname #f read-only #t) - (operation/pathname-simplify #f read-only #t) - (operation/end-of-line-string #f read-only #t)) + (operation/pathname-simplify #f read-only #t)) (define-structure (host (type vector) (named ((ucode-primitive string->symbol) @@ -596,7 +591,7 @@ these rules: (lambda arguments (error "Unimplemented host type:" name arguments)))) (make-host-type index name fail fail fail fail fail fail fail fail fail - fail fail fail fail fail)))) + fail fail fail fail)))) (define (reset-package!) (let ((host-type (host-name->type microcode-id/operating-system)) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index 3bbb2a06f..6b68df1d9 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: port.scm,v 1.30 2003/03/08 02:03:47 cph Exp $ +$Id: port.scm,v 1.31 2004/02/16 05:37:53 cph Exp $ Copyright 1991,1992,1993,1994,1997,1999 Massachusetts Institute of Technology -Copyright 2001,2002,2003 Massachusetts Institute of Technology +Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -29,24 +29,33 @@ USA. (declare (usual-integrations)) +;;;; Port type + (define-structure (port-type (type-descriptor ) (conc-name port-type/) - (constructor %make-port-type (custom-operations))) + (constructor %make-port-type)) + standard-operations custom-operations ;; input operations: (char-ready? #f read-only #t) - (peek-char #f read-only #t) (read-char #f read-only #t) + (unread-char #f read-only #t) + (peek-char #f read-only #t) (discard-char #f read-only #t) - (read-string #f read-only #t) - (discard-chars #f read-only #t) (read-substring #f read-only #t) + (read-wide-substring #f read-only #t) + (read-external-substring #f read-only #t) ;; output operations: (write-char #f read-only #t) (write-substring #f read-only #t) + (write-wide-substring #f read-only #t) + (write-external-substring #f read-only #t) (fresh-line #f read-only #t) (flush-output #f read-only #t) - (discretionary-flush-output #f read-only #t)) + (discretionary-flush-output #f read-only #t) + ;; transcript operations: + (get-transcript-port #f read-only #t) + (set-transcript-port #f read-only #t)) (set-record-type-unparser-method! (lambda (state type) @@ -66,7 +75,7 @@ USA. (if (not (port-type? object)) (error:wrong-type-argument object "port type" procedure)) object) - + (define-integrable (port-type/supports-input? type) (port-type/read-char type)) @@ -88,132 +97,489 @@ USA. (port-type/supports-input? object) (port-type/supports-output? object) #t)) - -(define input-operation-names - '(CHAR-READY? - DISCARD-CHAR - DISCARD-CHARS - PEEK-CHAR - READ-CHAR - READ-STRING - READ-SUBSTRING)) - -(define input-operation-accessors - (map (lambda (name) (record-accessor name)) - input-operation-names)) - -(define input-operation-modifiers - (map (lambda (name) (record-modifier name)) - input-operation-names)) - -(define output-operation-names - '(DISCRETIONARY-FLUSH-OUTPUT - FLUSH-OUTPUT - FRESH-LINE - WRITE-CHAR - WRITE-SUBSTRING)) - -(define output-operation-accessors - (map (lambda (name) (record-accessor name)) - output-operation-names)) - -(define output-operation-modifiers - (map (lambda (name) (record-modifier name)) - output-operation-names)) (define (port-type/operation-names type) (guarantee-port-type type 'PORT-TYPE/OPERATION-NAMES) - (append (if (port-type/supports-input? type) input-operation-names '()) - (if (port-type/supports-output? type) output-operation-names '()) + (append (map car (port-type/standard-operations type)) (map car (port-type/custom-operations type)))) (define (port-type/operations type) (guarantee-port-type type 'PORT-TYPE/OPERATIONS) - (append (if (port-type/supports-input? type) - (map (lambda (name accessor) - (list name (accessor type))) - input-operation-names - input-operation-accessors) - '()) - (if (port-type/supports-output? type) - (map (lambda (name accessor) - (list name (accessor type))) - output-operation-names - output-operation-accessors) - '()) - (map (lambda (entry) - (list (car entry) (cdr entry))) - (port-type/custom-operations type)))) + (append! (map (lambda (entry) + (list (car entry) (cdr entry))) + (port-type/standard-operations type)) + (map (lambda (entry) + (list (car entry) (cdr entry))) + (port-type/custom-operations type)))) (define (port-type/operation type name) (guarantee-port-type type 'PORT-TYPE/OPERATION) - ;; Optimized for custom operations, since standard operations will - ;; usually be accessed directly. - (let ((entry (assq name (port-type/custom-operations type)))) - (if entry - (cdr entry) - (let ((accessor - (letrec ((loop - (lambda (names accessors) - (and (pair? names) - (if (eq? name (car names)) - (car accessors) - (loop (cdr names) (cdr accessors))))))) - (or (and (port-type/supports-input? type) - (loop input-operation-names - input-operation-accessors)) - (and (port-type/supports-output? type) - (loop output-operation-names - output-operation-accessors)))))) - (and accessor - (accessor type)))))) + (let ((entry + (or (assq name (port-type/custom-operations type)) + (assq name (port-type/standard-operations type))))) + (and entry + (cdr entry)))) + +;;;; Constructors + +(define (make-port-type operations type) + (if (not (list-of-type? operations + (lambda (elt) + (and (pair? elt) + (symbol? (car elt)) + (pair? (cdr elt)) + (procedure? (cadr elt)) + (null? (cddr elt)))))) + (error:wrong-type-argument operations "operations list" 'MAKE-PORT-TYPE)) + (receive (standard-operations custom-operations) + (parse-operations-list operations type) + (let ((op + (let ((input? (assq 'READ-CHAR standard-operations)) + (output? (assq 'WRITE-CHAR standard-operations)) + (cond-op + (lambda (flag mapper) + (if flag + mapper + (lambda (op) op))))) + ((cond-op output? provide-output-features) + ((cond-op input? provide-input-features) + ((cond-op output? provide-default-output-operations) + ((cond-op input? provide-default-input-operations) + (lambda (name) + (let ((p (assq name standard-operations))) + (and p + (cdr p))))))))))) + (%make-port-type standard-operations + custom-operations + (op 'CHAR-READY?) + (op 'READ-CHAR) + (op 'UNREAD-CHAR) + (op 'PEEK-CHAR) + (op 'DISCARD-CHAR) + (op 'READ-SUBSTRING) + (op 'READ-WIDE-SUBSTRING) + (op 'READ-EXTERNAL-SUBSTRING) + (op 'WRITE-CHAR) + (op 'WRITE-SUBSTRING) + (op 'WRITE-WIDE-SUBSTRING) + (op 'WRITE-EXTERNAL-SUBSTRING) + (op 'FRESH-LINE) + (op 'FLUSH-OUTPUT) + (op 'DISCRETIONARY-FLUSH-OUTPUT) + port/transcript + set-port/transcript!)))) + +(define (parse-operations-list operations type) + (parse-operations-list-1 + (if type + (append operations + (delete-matching-items (port-type/operations type) + (let ((excluded + (append + (if (assq 'READ-CHAR operations) + standard-input-operation-names + '()) + (if (assq 'WRITE-CHAR operations) + standard-output-operation-names + '())))) + (lambda (p) + (or (assq (car p) operations) + (memq (car p) excluded)))))) + operations))) + +(define (parse-operations-list-1 operations) + (let loop ((operations operations) (standard '()) (custom '())) + (if (pair? operations) + (let ((p (cons (caar operations) (cadar operations)))) + (if (or (memq (caar operations) standard-input-operation-names) + (memq (caar operations) standard-output-operation-names)) + (loop (cdr operations) (cons p standard) custom) + (loop (cdr operations) standard (cons p custom)))) + (values (reverse! standard) (reverse! custom))))) + +(define standard-input-operation-names + '(CHAR-READY? + READ-CHAR + READ-SUBSTRING + READ-WIDE-SUBSTRING + READ-EXTERNAL-SUBSTRING)) + +(define standard-output-operation-names + '(WRITE-CHAR + WRITE-SUBSTRING + WRITE-WIDE-SUBSTRING + WRITE-EXTERNAL-SUBSTRING + FLUSH-OUTPUT + DISCRETIONARY-FLUSH-OUTPUT)) + +;;;; Default input operations + +(define (provide-default-input-operations op) + (let ((char-ready? (or (op 'CHAR-READY?) (lambda (port) port #t))) + (read-char (op 'READ-CHAR))) + (let ((read-substring + (or (op 'READ-SUBSTRING) + (lambda (port string start end) + (let ((char (read-char port))) + (cond ((not char) #f) + ((eof-object? char) 0) + (else + (guarantee-8-bit-char char) + (string-set! string start char) + (let loop ((index (fix:+ start 1))) + (if (and (fix:< index end) + (char-ready? port)) + (let ((char (read-char port))) + (cond ((or (not char) + (eof-object? char)) + (fix:- index start)) + (else + (guarantee-8-bit-char char) + (string-set! string index char) + (loop (fix:+ index 1))))) + (fix:- index start))))))))) + (read-wide-substring + (or (op 'READ-WIDE-SUBSTRING) + (lambda (port string start end) + (let ((char (read-char port))) + (cond ((not char) #f) + ((eof-object? char) 0) + (else + (wide-string-set! string start char) + (let loop ((index (fix:+ start 1))) + (if (and (fix:< index end) + (char-ready? port)) + (let ((char (read-char port))) + (if (or (not char) (eof-object? char)) + (fix:- index start) + (begin + (wide-string-set! string + index + char) + (loop (fix:+ index 1))))) + (fix:- index start)))))))))) + (let ((read-external-substring + (or (op 'READ-EXTERNAL-SUBSTRING) + (lambda (port string start end) + (let ((l (min (- end start) #x1000))) + (let ((bounce (make-string l))) + (let ((n (read-substring port bounce 0 l))) + (if (and n (fix:> n 0)) + (xsubstring-move! bounce 0 n string start)) + n))))))) + (lambda (name) + (case name + ((CHAR-READY?) char-ready?) + ((READ-CHAR) read-char) + ((READ-SUBSTRING) read-substring) + ((READ-WIDE-SUBSTRING) read-wide-substring) + ((READ-EXTERNAL-SUBSTRING) read-external-substring) + (else (op name)))))))) + +;;;; Default output operations + +(define (provide-default-output-operations op) + (let ((write-char (op 'WRITE-CHAR)) + (no-flush (lambda (port) port unspecific))) + (let ((write-substring + (or (op 'WRITE-SUBSTRING) + (lambda (port string start end) + (let loop ((i start)) + (if (fix:< i end) + (let ((n (write-char port (string-ref string i)))) + (cond ((not n) + (and (fix:> i start) + (fix:- i start))) + ((fix:> n 0) (loop (fix:+ i 1))) + (else (fix:- i start)))) + (fix:- i start)))))) + (write-wide-substring + (or (op 'WRITE-WIDE-SUBSTRING) + (lambda (port string start end) + (let loop ((i start)) + (if (fix:< i end) + (let ((n + (write-char port + (wide-string-ref string i)))) + (cond ((not n) + (and (fix:> i start) + (fix:- i start))) + ((fix:> n 0) (loop (fix:+ i 1))) + (else (fix:- i start)))) + (fix:- i start)))))) + (flush-output (or (op 'FLUSH-OUTPUT) no-flush)) + (discretionary-flush-output + (or (op 'DISCRETIONARY-FLUSH-OUTPUT) no-flush))) + (let ((write-external-substring + (or (op 'WRITE-EXTERNAL-SUBSTRING) + (lambda (port string start end) + (let ((bounce (make-string #x1000))) + (let loop ((i start)) + (if (< i end) + (let ((m (min (- end i) #x1000))) + (xsubstring-move! string i (+ i m) bounce 0) + (let ((n (write-substring port bounce 0 m))) + (cond ((not n) (and (> i start) (- i start))) + ((fix:> n 0) (loop (+ i n))) + (else (- i start))))) + (- end start)))))))) + (lambda (name) + (case name + ((WRITE-CHAR) write-char) + ((WRITE-SUBSTRING) write-substring) + ((WRITE-WIDE-SUBSTRING) write-wide-substring) + ((WRITE-EXTERNAL-SUBSTRING) write-external-substring) + ((FLUSH-OUTPUT) flush-output) + ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output) + (else (op name)))))))) + +;;;; Input features + +(define (provide-input-features op) + (let ((char-ready? + (let ((defer (op 'CHAR-READY?))) + (lambda (port) + (if (port/unread port) + #t + (defer port))))) + (read-char + (let ((defer (op 'READ-CHAR))) + (lambda (port) + (let ((char (port/unread port))) + (if char + (begin + (set-port/unread! port #f) + char) + (let ((char (defer port))) + (if (and (port/transcript port) (char? char)) + (write-char char (port/transcript port))) + char)))))) + (unread-char + (lambda (port char) + (if (port/unread port) + (error "Can't unread second character:" char port)) + (set-port/unread! port char) + unspecific)) + (peek-char + (let ((defer (op 'READ-CHAR))) + (lambda (port) + (or (port/unread port) + (let ((char (defer port))) + (if (char? char) + (set-port/unread! port char)) + char))))) + (discard-char + (lambda (port) + (if (not (port/unread port)) + (error "No character to discard:" port)) + (set-port/unread! port #f) + unspecific)) + (read-substring + (let ((defer (op 'READ-SUBSTRING))) + (lambda (port string start end) + (if (port/unread port) + (begin + (guarantee-8-bit-char (port/unread port)) + (string-set! string start (port/unread port)) + (set-port/unread! port #f) + 1) + (let ((n (defer port string start end))) + (if (and n (fix:> n 0) (port/transcript port)) + (write-substring string start (fix:+ start n) + (port/transcript port))) + n))))) + (read-wide-substring + (let ((defer (op 'READ-WIDE-SUBSTRING))) + (lambda (port string start end) + (if (port/unread port) + (begin + (wide-string-set! string start (port/unread port)) + (set-port/unread! port #f) + 1) + (let ((n (defer port string start end))) + (if (and n (fix:> n 0) (port/transcript port)) + (write-substring string start (fix:+ start n) + (port/transcript port))) + n))))) + (read-external-substring + (let ((defer (op 'READ-EXTERNAL-SUBSTRING))) + (lambda (port string start end) + (if (port/unread port) + (begin + (guarantee-8-bit-char (port/unread port)) + (xsubstring-move! (make-string 1 (port/unread port)) 0 1 + string start) + (set-port/unread! port #f) + 1) + (let ((n (defer port string start end))) + (if (and n (> n 0) (port/transcript port)) + (write-substring string start (+ start n) + (port/transcript port))) + n)))))) + (lambda (name) + (case name + ((CHAR-READY?) char-ready?) + ((READ-CHAR) read-char) + ((UNREAD-CHAR) unread-char) + ((PEEK-CHAR) peek-char) + ((DISCARD-CHAR) discard-char) + ((READ-SUBSTRING) read-substring) + ((READ-WIDE-SUBSTRING) read-wide-substring) + ((READ-EXTERNAL-SUBSTRING) read-external-substring) + (else (op name)))))) + +;;;; Output features + +(define (provide-output-features op) + (let ((write-char + (let ((defer (op 'WRITE-CHAR))) + (lambda (port char) + (let ((n (defer port char))) + (if (and n (fix:> n 0)) + (begin + (set-port/previous! port char) + (if (port/transcript port) + (write-char char (port/transcript port))))) + n)))) + (write-substring + (let ((defer (op 'WRITE-SUBSTRING))) + (lambda (port string start end) + (let ((n (defer port string start end))) + (if (and n (fix:> n 0)) + (begin + (set-port/previous! + port + (string-ref string (fix:+ start (fix:- n 1)))) + (if (and (port/transcript port)) + (write-substring string start (fix:+ start n) + (port/transcript port))))) + n)))) + (write-wide-substring + (let ((defer (op 'WRITE-WIDE-SUBSTRING))) + (lambda (port string start end) + (let ((n (defer port string start end))) + (if (and n (fix:> n 0)) + (begin + (set-port/previous! + port + (string-ref string (fix:+ start (fix:- n 1)))) + (if (and (port/transcript port)) + (write-substring string start (fix:+ start n) + (port/transcript port))))) + n)))) + (write-external-substring + (let ((defer (op 'WRITE-EXTERNAL-SUBSTRING))) + (lambda (port string start end) + (let ((n (defer port string start end))) + (if (and n (> n 0)) + (let ((i (+ start n)) + (bounce (make-string 1))) + (xsubstring-move! string (- i 1) i bounce 0) + (set-port/previous! port (string-ref bounce 0)) + (if (port/transcript port) + (write-substring string start i + (port/transcript port))))) + n)))) + (flush-output + (let ((defer (op 'FLUSH-OUTPUT))) + (lambda (port) + (defer port) + (if (port/transcript port) + (flush-output (port/transcript port)))))) + (discretionary-flush-output + (let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT))) + (lambda (port) + (defer port) + (if (port/transcript port) + (output-port/discretionary-flush (port/transcript port))))))) + (lambda (name) + (case name + ((WRITE-CHAR) write-char) + ((WRITE-SUBSTRING) write-substring) + ((WRITE-WIDE-SUBSTRING) write-wide-substring) + ((WRITE-EXTERNAL-SUBSTRING) write-external-substring) + ((FRESH-LINE) + (lambda (port) + (if (and (port/previous port) + (not (char=? (port/previous port) #\newline))) + (write-char port #\newline) + 0))) + ((FLUSH-OUTPUT) flush-output) + ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output) + (else (op name)))))) -(define-record-type - (%make-port type state thread-mutex) - port? - (type port/type) - (state %port/state %set-port/state!) - (thread-mutex port/thread-mutex set-port/thread-mutex!)) +;;;; Port object + +(define-structure (port (type-descriptor ) + (conc-name port/) + (constructor %make-port (%type %state))) + (%type #f read-only #t) + %state + (%thread-mutex (make-thread-mutex)) + (unread #f) + (previous #f) + (transcript #f)) + +(define (make-port type state) + (guarantee-port-type type 'MAKE-PORT) + (%make-port type state)) + +(define (port/type port) + (guarantee-port port 'PORT/TYPE) + (port/%type port)) (define (port/state port) - (%port/state (base-port port))) + (guarantee-port port 'PORT/STATE) + (port/%state port)) (define (set-port/state! port state) - (%set-port/state! (base-port port) state)) + (guarantee-port port 'SET-PORT/STATE!) + (set-port/%state! port state)) + +(define (port/thread-mutex port) + (guarantee-port port 'PORT/THREAD-MUTEX) + (port/%thread-mutex port)) + +(define (set-port/thread-mutex! port mutex) + (set-port/%thread-mutex! port mutex)) -(define (base-port port) - (let ((state (%port/state port))) - (if (encapsulated-port-state? state) - (base-port (encapsulated-port-state/port state)) - port))) +(define (port=? p1 p2) + (guarantee-port p1 'PORT=?) + (guarantee-port p2 'PORT=?) + (eq? p1 p2)) (define (port/operation-names port) (port-type/operation-names (port/type port))) +(define (port/operation port name) + (port-type/operation (port/type port) name)) + (let-syntax ((define-port-operation (sc-macro-transformer (lambda (form environment) - (let ((dir (cadr form)) - (name (caddr form))) - `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT) + (let ((name (cadr form))) + `(DEFINE (,(symbol-append 'PORT/OPERATION/ name) PORT) (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment) (PORT/TYPE PORT)))))))) - (define-port-operation input char-ready?) - (define-port-operation input peek-char) - (define-port-operation input read-char) - (define-port-operation input discard-char) - (define-port-operation input read-string) - (define-port-operation input discard-chars) - (define-port-operation input read-substring) - (define-port-operation output write-char) - (define-port-operation output write-substring) - (define-port-operation output fresh-line) - (define-port-operation output flush-output)) - -(define (output-port/operation/discretionary-flush port) - (port-type/discretionary-flush-output (port/type port))) - + (define-port-operation char-ready?) + (define-port-operation read-char) + (define-port-operation unread-char) + (define-port-operation peek-char) + (define-port-operation discard-char) + (define-port-operation read-substring) + (define-port-operation read-wide-substring) + (define-port-operation read-external-substring) + (define-port-operation write-char) + (define-port-operation write-substring) + (define-port-operation write-wide-substring) + (define-port-operation write-external-substring) + (define-port-operation fresh-line) + (define-port-operation flush-output) + (define-port-operation discretionary-flush-output) + (define-port-operation get-transcript-port) + (define-port-operation set-transcript-port)) + (set-record-type-unparser-method! (lambda (state port) ((let ((name @@ -237,7 +603,7 @@ USA. (set-port/state! port state) (set-port/thread-mutex! port (make-thread-mutex)) port)) - + (define (close-port port) (let ((close (port/operation port 'CLOSE))) (if close @@ -265,27 +631,6 @@ USA. (let ((operation (port/operation port 'OUTPUT-CHANNEL))) (and operation (operation port)))) - -(define (port/operation port name) - (port-type/operation (port/type port) name)) - -(define (input-port/operation port name) - (port/operation port - (case name - ((BUFFER-SIZE) 'INPUT-BUFFER-SIZE) - ((SET-BUFFER-SIZE) 'SET-INPUT-BUFFER-SIZE) - ((BUFFERED-CHARS) 'BUFFERED-INPUT-CHARS) - ((CHANNEL) 'INPUT-CHANNEL) - (else name)))) - -(define (output-port/operation port name) - (port/operation port - (case name - ((BUFFER-SIZE) 'OUTPUT-BUFFER-SIZE) - ((SET-BUFFER-SIZE) 'SET-OUTPUT-BUFFER-SIZE) - ((BUFFERED-CHARS) 'BUFFERED-OUTPUT-CHARS) - ((CHANNEL) 'OUTPUT-CHANNEL) - (else name)))) (define (input-port? object) (and (port? object) @@ -301,260 +646,63 @@ USA. (and (port-type/supports-input? type) (port-type/supports-output? type))))) -(define (guarantee-port port procedure) +(define-integrable (guarantee-port port caller) (if (not (port? port)) - (error:wrong-type-argument port "port" procedure)) + (error:not-port port caller)) port) -(define (guarantee-input-port port procedure) +(define (error:not-port port caller) + (error:wrong-type-argument port "port" caller)) + +(define-integrable (guarantee-input-port port caller) (if (not (input-port? port)) - (error:wrong-type-argument port "input port" procedure)) + (error:not-input-port port caller)) port) -(define (guarantee-output-port port procedure) +(define (error:not-input-port port caller) + (error:wrong-type-argument port "input port" caller)) + +(define-integrable (guarantee-output-port port caller) (if (not (output-port? port)) - (error:wrong-type-argument port "output port" procedure)) + (error:not-output-port port caller)) port) -(define (guarantee-i/o-port port procedure) +(define (error:not-output-port port caller) + (error:wrong-type-argument port "output port" caller)) + +(define-integrable (guarantee-i/o-port port caller) (if (not (i/o-port? port)) - (error:wrong-type-argument port "I/O port" procedure)) + (error:not-i/o-port port caller)) port) - -;;;; Encapsulation -(define-structure (encapsulated-port-state - (conc-name encapsulated-port-state/)) - (port #f read-only #t) - state) +(define (error:not-i/o-port port caller) + (error:wrong-type-argument port "I/O port" caller)) -(define (encapsulated-port? object) - (and (port? object) - (encapsulated-port-state? (%port/state object)))) - -(define (guarantee-encapsulated-port object procedure) - (guarantee-port object procedure) - (if (not (encapsulated-port-state? (%port/state object))) - (error:wrong-type-argument object "encapsulated port" procedure))) - -(define (encapsulated-port/port port) - (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/PORT) - (encapsulated-port-state/port (%port/state port))) - -(define (encapsulated-port/state port) - (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/STATE) - (encapsulated-port-state/state (%port/state port))) - -(define (set-encapsulated-port/state! port state) - (guarantee-encapsulated-port port 'SET-ENCAPSULATED-PORT/STATE!) - (set-encapsulated-port-state/state! (%port/state port) state)) - -(define (make-encapsulated-port port state rewrite-operation) - (guarantee-port port 'MAKE-ENCAPSULATED-PORT) - (%make-port (let ((type (port/type port))) - (make-port-type - (append-map - (lambda (entry) - (let ((operation - (rewrite-operation (car entry) (cadr entry)))) - (if operation - (list (list (car entry) operation)) - '()))) - (port-type/operations type)) - #f)) - (make-encapsulated-port-state port state) - (port/thread-mutex port))) - -;;;; Constructors +(define (port/coding port) + (let ((operation (port/operation port 'CODING))) + (if operation + (operation port) + #f))) -(define (make-port type state) - (guarantee-port-type type 'MAKE-PORT) - (%make-port type state (make-thread-mutex))) +(define (port/set-coding port name) + (let ((operation (port/operation port 'SET-CODING))) + (if operation + (operation port name)))) -(define (make-port-type operations type) - (let ((type - (parse-operations-list - (append operations - (if type - (list-transform-negative (port-type/operations type) - (let ((ignored - (append - (if (assq 'READ-CHAR operations) - '(DISCARD-CHAR - DISCARD-CHARS - PEEK-CHAR - READ-CHAR - READ-STRING - READ-SUBSTRING) - '()) - (if (or (assq 'WRITE-CHAR operations) - (assq 'WRITE-SUBSTRING operations)) - '(WRITE-CHAR - WRITE-SUBSTRING) - '())))) - (lambda (entry) - (or (assq (car entry) operations) - (memq (car entry) ignored))))) - '())) - 'MAKE-PORT-TYPE))) - (let ((operations (port-type/operations type))) - (let ((input? (assq 'READ-CHAR operations)) - (output? - (or (assq 'WRITE-CHAR operations) - (assq 'WRITE-SUBSTRING operations)))) - (if (not (or input? output?)) - (error "Port type must implement one of the following operations:" - '(READ-CHAR WRITE-CHAR WRITE-SUBSTRING))) - (install-operations! type input? - input-operation-names - input-operation-modifiers - input-operation-defaults) - (install-operations! type output? - output-operation-names - output-operation-modifiers - output-operation-defaults))) - type)) - -(define (parse-operations-list operations procedure) - (if (not (list? operations)) - (error:wrong-type-argument operations "list" procedure)) - (%make-port-type - (map (lambda (operation) - (if (not (and (pair? operation) - (symbol? (car operation)) - (pair? (cdr operation)) - (procedure? (cadr operation)) - (null? (cddr operation)))) - (error:wrong-type-argument operation "port operation" procedure)) - (cons (car operation) (cadr operation))) - operations))) - -(define (install-operations! type install? names modifiers defaults) - (if install? - (let* ((operations - (map (lambda (name) - (extract-operation! type name)) - names)) - (defaults (defaults names operations))) - (for-each (lambda (modifier operation name) - (modifier - type - (or operation - (let ((entry (assq name defaults))) - (if (not entry) - (error "Must specify operation:" name)) - (cadr entry))))) - modifiers - operations - names)) - (begin - (for-each (lambda (name) - (if (extract-operation! type name) - (error "Illegal operation name:" name))) - names) - (for-each (lambda (modifier) - (modifier type #f)) - modifiers)))) - -(define extract-operation! - (let ((set-port-type/custom-operations! - (record-modifier 'CUSTOM-OPERATIONS))) - (lambda (type name) - (let ((operation (assq name (port-type/custom-operations type)))) - (and operation - (begin - (set-port-type/custom-operations! - type - (delq! operation (port-type/custom-operations type))) - (cdr operation))))))) - -(define (search-paired-lists key keys datums error?) - (if (pair? keys) - (if (eq? key (car keys)) - (car datums) - (search-paired-lists key (cdr keys) (cdr datums) error?)) - (and error? - (error "Unable to find key:" key)))) - -;;;; Default Operations - -(define (input-operation-defaults names operations) - `((CHAR-READY? ,default-operation/char-ready?) - (DISCARD-CHAR ,(search-paired-lists 'READ-CHAR names operations #t)) - (DISCARD-CHARS ,default-operation/discard-chars) - (READ-STRING ,default-operation/read-string) - (READ-SUBSTRING ,default-operation/read-substring))) - -(define (default-operation/char-ready? port interval) - port interval - #t) - -(define (default-operation/read-string port delimiters) - (let ((peek-char - (lambda () (let loop () (or (input-port/peek-char port) (loop)))))) - (let ((char (peek-char))) - (if (eof-object? char) - char - (list->string - (let loop ((char char)) - (if (or (eof-object? char) - (char-set-member? delimiters char)) - '() - (begin - (input-port/discard-char port) - (cons char (loop (peek-char))))))))))) - -(define (default-operation/discard-chars port delimiters) - (let loop () - (let ((char (let loop () (or (input-port/peek-char port) (loop))))) - (if (not (or (eof-object? char) - (char-set-member? delimiters char))) - (begin - (input-port/discard-char port) - (loop)))))) - -(define (default-operation/read-substring port string start end) - (let loop ((index start)) - (if (fix:< index end) - (let ((char (input-port/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)))) - -(define (output-operation-defaults names operations) - (if (not (or (search-paired-lists 'WRITE-CHAR names operations #f) - (search-paired-lists 'WRITE-SUBSTRING names operations #f))) - (error "Must specify at least one of the following:" - '(WRITE-CHAR WRITE-SUBSTRING))) - `((DISCRETIONARY-FLUSH-OUTPUT ,default-operation/flush-output) - (FLUSH-OUTPUT ,default-operation/flush-output) - (FRESH-LINE ,default-operation/fresh-line) - (WRITE-CHAR ,default-operation/write-char) - (WRITE-SUBSTRING ,default-operation/write-substring))) - -(define (default-operation/write-char port char) - (output-port/write-substring port (string char) 0 1)) - -(define (default-operation/write-substring port string start end) - (let loop ((index start)) - (if (< index end) - (begin - (output-port/write-char port (string-ref string index)) - (loop (+ index 1)))))) +(define (port/line-ending port) + (let ((operation (port/operation port 'LINE-ENDING))) + (if operation + (operation port) + #f))) -(define (default-operation/fresh-line port) - (output-port/write-char port #\newline)) +(define (port/set-line-ending port name) + (let ((operation (port/operation port 'SET-LINE-ENDING))) + (if operation + (operation port name)))) -(define (default-operation/flush-output port) - port - unspecific) +(define-integrable (guarantee-8-bit-char char) + (if (fix:>= (char->integer char) #x100) + (error:not-8-bit-char char))) ;;;; Special Operations @@ -706,25 +854,4 @@ USA. (cons current-output-port set-current-output-port!) (cons notification-output-port set-notification-output-port!) (cons trace-output-port set-trace-output-port!) - (cons interaction-i/o-port set-interaction-i/o-port!))) - -;;;; Upwards Compatibility - -(define input-port/channel port/input-channel) -(define input-port/copy port/copy) -(define input-port/custom-operation input-port/operation) -(define input-port/operation-names port/operation-names) -(define input-port/state port/state) -(define output-port/channel port/output-channel) -(define output-port/copy port/copy) -(define output-port/custom-operation output-port/operation) -(define output-port/operation-names port/operation-names) -(define output-port/state port/state) -(define set-input-port/state! set-port/state!) -(define set-output-port/state! set-port/state!) - -(define (make-input-port type state) - (make-port (if (port-type? type) type (make-port-type type #f)) state)) - -(define make-output-port make-input-port) -(define make-i/o-port make-input-port) \ No newline at end of file + (cons interaction-i/o-port set-interaction-i/o-port!))) \ No newline at end of file diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index b1c262d09..8879b85c2 100644 --- a/v7/src/runtime/process.scm +++ b/v7/src/runtime/process.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: process.scm,v 1.31 2003/11/10 21:46:23 cph Exp $ +$Id: process.scm,v 1.32 2004/02/16 05:37:59 cph Exp $ Copyright 1990,1991,1992,1995,1997,1998 Massachusetts Institute of Technology -Copyright 1999,2000,2003 Massachusetts Institute of Technology +Copyright 1999,2000,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -81,38 +81,17 @@ USA. (define (subprocess-remove! process key) (1d-table/remove! (subprocess-properties process) key)) -(define (subprocess-i/o-port process #!optional - input-line-translation output-line-translation) - (let* ((input-line-translation - (if (default-object? input-line-translation) - 'DEFAULT - input-line-translation)) - (output-line-translation - (if (default-object? output-line-translation) - input-line-translation - output-line-translation))) - (without-interrupts - (lambda () - (or (subprocess-%i/o-port process) - (let ((port - (let ((input-channel (subprocess-input-channel process)) - (output-channel (subprocess-output-channel process))) - (if input-channel - (if output-channel - (make-generic-i/o-port input-channel output-channel - 512 512 - input-line-translation - output-line-translation) - (make-generic-input-port input-channel - 512 - input-line-translation)) - (if output-channel - (make-generic-output-port output-channel - 512 - output-line-translation) - #f))))) - (set-subprocess-%i/o-port! process port) - port)))))) +(define (subprocess-i/o-port process) + (without-interrupts + (lambda () + (or (subprocess-%i/o-port process) + (let ((port + (let ((input-channel (subprocess-input-channel process)) + (output-channel (subprocess-output-channel process))) + (and (or input-channel output-channel) + (make-generic-i/o-port input-channel output-channel))))) + (set-subprocess-%i/o-port! process port) + port))))) (define (subprocess-input-port process) (let ((port (subprocess-i/o-port process))) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 7bfa46944..ab325fd53 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.61 2003/03/21 17:51:03 cph Exp $ +$Id: rep.scm,v 14.62 2004/02/16 05:38:05 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1998,1999,2001 Massachusetts Institute of Technology @@ -82,12 +82,7 @@ USA. (error:bad-range-argument port 'MAKE-CMDL)) (%make-cmdl (if parent (+ (cmdl/level parent) 1) 1) parent - (let ((port* (and parent (cmdl/child-port parent)))) - (if port - (if (eq? port port*) - port - (make-transcriptable-port port)) - port*)) + (or port (and parent (cmdl/child-port parent))) driver state (parse-operations-list operations 'MAKE-CMDL) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 40eb329e9..677e68ab2 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.476 2004/01/19 05:06:22 cph Exp $ +$Id: runtime.pkg,v 14.477 2004/02/16 05:38:12 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -587,6 +587,7 @@ USA. current-user-name decode-file-time decoded-time->file-time + default-line-ending encode-file-time file-access-time file-access-time-direct @@ -602,6 +603,7 @@ USA. file-attributes/n-links file-attributes/type file-length + file-line-ending file-modes file-modification-time file-modification-time-direct @@ -611,10 +613,8 @@ USA. file-time->universal-time get-environment-variable init-file-specifier->pathname - os/default-end-of-line-translation os/exec-path os/executable-pathname-types - os/file-end-of-line-translation os/find-program os/form-shell-command os/make-subprocess @@ -834,6 +834,8 @@ USA. xsubstring-move!) (export (runtime primitive-io) external-string-descriptor) + (export (runtime generic-i/o-port) + %substring-move!) (initialization (initialize-package!))) (define-package (runtime 1d-property) @@ -1063,12 +1065,12 @@ USA. (parent (runtime)) (export () console-i/o-port + console-i/o-port? console-input-port console-output-port set-console-i/o-port!) (export (runtime emacs-interface) - the-console-port - the-console-port-type) + the-console-port) (initialization (initialize-package!))) (define-package (runtime continuation) @@ -1419,6 +1421,7 @@ USA. condition-type:illegal-pathname-component condition-type:macro-binding condition-type:no-such-restart + condition-type:not-8-bit-char condition-type:port-error condition-type:serious-condition condition-type:simple-condition @@ -1457,6 +1460,7 @@ USA. error:file-operation error:illegal-pathname-component error:no-such-restart + error:not-8-bit-char error:wrong-number-of-arguments error:wrong-type-argument error:wrong-type-datum @@ -1542,7 +1546,6 @@ USA. open-i/o-file open-input-file open-output-file - pathname-newline-translation with-input-from-binary-file with-input-from-file with-output-to-binary-file @@ -1555,11 +1558,6 @@ USA. (export () transcript-off transcript-on) - (export (runtime rep) - make-transcriptable-port) - (export (runtime emacs-interface) - make-transcriptable-port - transcriptable-port?) (initialization (initialize-package!))) (define-package (runtime format) @@ -1657,16 +1655,21 @@ USA. (files "genio") (parent (runtime)) (export () - make-generic-i/o-port - make-generic-input-port - make-generic-output-port) + make-generic-i/o-port) (export (runtime console-i/o-port) generic-i/o-type - operation/flush-output) + generic-io/char-ready? + generic-io/flush-output + generic-io/read-char + input-buffer-contents + make-gstate + port-input-buffer + set-input-buffer-contents!) (export (runtime file-i/o-port) generic-i/o-type generic-input-type - generic-output-type) + generic-output-type + make-gstate) (initialization (initialize-package!))) (define-package (runtime gensym) @@ -1796,10 +1799,7 @@ USA. close-port current-input-port current-output-port - encapsulated-port/port - encapsulated-port/state - encapsulated-port? - guarantee-encapsulated-port + guarantee-8-bit-char guarantee-i/o-port guarantee-input-port guarantee-output-port @@ -1808,44 +1808,32 @@ USA. i/o-port-type? i/o-port? input-port-type? - input-port/channel - input-port/copy - input-port/custom-operation - input-port/operation - input-port/operation-names - input-port/state input-port? interaction-i/o-port - make-encapsulated-port - make-i/o-port - make-input-port - make-output-port make-port make-port-type notification-output-port output-port-type? - output-port/channel - output-port/copy - output-port/custom-operation - output-port/operation - output-port/operation-names - output-port/state output-port? port-type/operation port-type/operation-names port-type/operations port-type? + port/coding port/copy port/input-blocking-mode port/input-channel port/input-terminal-mode + port/line-ending port/operation port/operation-names port/output-blocking-mode port/output-channel port/output-terminal-mode + port/set-coding port/set-input-blocking-mode port/set-input-terminal-mode + port/set-line-ending port/set-output-blocking-mode port/set-output-terminal-mode port/state @@ -1855,14 +1843,12 @@ USA. port/with-input-terminal-mode port/with-output-blocking-mode port/with-output-terminal-mode + port=? port? set-current-input-port! set-current-output-port! - set-encapsulated-port/state! - set-input-port/state! set-interaction-i/o-port! set-notification-output-port! - set-output-port/state! set-port/state! set-trace-output-port! trace-output-port @@ -1872,19 +1858,25 @@ USA. with-output-to-port with-trace-output-port) (export (runtime input-port) - input-port/operation/char-ready? - input-port/operation/discard-char - input-port/operation/discard-chars - input-port/operation/peek-char - input-port/operation/read-char - input-port/operation/read-string - input-port/operation/read-substring) + port/operation/char-ready? + port/operation/discard-char + port/operation/peek-char + port/operation/read-char + port/operation/read-external-substring + port/operation/read-substring + port/operation/read-wide-substring + port/operation/unread-char) (export (runtime output-port) - output-port/operation/discretionary-flush - output-port/operation/flush-output - output-port/operation/fresh-line - output-port/operation/write-char - output-port/operation/write-substring) + port/operation/discretionary-flush-output + port/operation/flush-output + port/operation/fresh-line + port/operation/write-char + port/operation/write-external-substring + port/operation/write-substring + port/operation/write-wide-substring) + (export (runtime transcript) + port/operation/get-transcript-port + port/operation/set-transcript-port) (export (runtime rep) *current-input-port* *current-output-port* @@ -1893,15 +1885,14 @@ USA. *trace-output-port*) (export (runtime emacs-interface) set-port/thread-mutex! - standard-port-accessors) - (export (runtime parser) - base-port)) + standard-port-accessors)) (define-package (runtime input-port) (files "input") (parent (runtime)) (export () char-ready? + eof-object-port eof-object? input-port/char-ready? input-port/discard-char @@ -1910,8 +1901,13 @@ USA. input-port/read-char input-port/read-line input-port/read-string + input-port/read-external-string! + input-port/read-external-substring! input-port/read-string! input-port/read-substring! + input-port/read-wide-string! + input-port/read-wide-substring! + input-port/unread-char make-eof-object peek-char read @@ -1920,9 +1916,7 @@ USA. read-line read-string read-string! - read-substring!) - (export (runtime primitive-io) - eof-object)) + read-substring!)) (define-package (runtime output-port) (files "output") @@ -1940,8 +1934,12 @@ USA. output-port/fresh-line output-port/write-char output-port/write-object + output-port/write-external-string + output-port/write-external-substring output-port/write-string output-port/write-substring + output-port/write-wide-string + output-port/write-wide-substring output-port/x-size output-port/y-size write @@ -2444,7 +2442,6 @@ USA. pathname-default-version pathname-device pathname-directory - pathname-end-of-line-string pathname-host pathname-name pathname-new-device @@ -2521,6 +2518,7 @@ USA. channel-file-length channel-file-position channel-file-set-position + channel-has-input? channel-nonblocking channel-open? channel-port @@ -2534,8 +2532,6 @@ USA. channel-type=unknown? channel-write channel-write-block - channel-write-char-block - channel-write-string-block channel? close-all-open-channels close-all-open-files @@ -2557,6 +2553,7 @@ USA. pty-master-quit pty-master-send-signal pty-master-stop + set-channel-port! set-terminal-input-baud-rate! set-terminal-output-baud-rate! terminal-cooked-input @@ -2586,60 +2583,6 @@ USA. open-channel) (export (runtime subprocess) channel-descriptor) - (export (runtime generic-i/o-port) - input-buffer/buffered-chars - input-buffer/channel - input-buffer/char-ready? - input-buffer/chars-remaining - input-buffer/close - input-buffer/eof? - input-buffer/open? - input-buffer/peek-char - input-buffer/read-char - input-buffer/read-substring - input-buffer/set-size - input-buffer/size - make-input-buffer - make-output-buffer - output-buffer/buffered-chars - output-buffer/channel - output-buffer/close - output-buffer/column - output-buffer/drain-block - output-buffer/open? - output-buffer/set-size - output-buffer/size - output-buffer/write-char-block - output-buffer/write-substring - output-buffer/write-substring-block - set-channel-port!) - (export (runtime file-i/o-port) - input-buffer/chars-remaining - input-buffer/read-substring - make-input-buffer - make-output-buffer - set-channel-port!) - (export (runtime console-i/o-port) - input-buffer/buffer-contents - input-buffer/buffered-chars - input-buffer/channel - input-buffer/char-ready? - input-buffer/eof? - input-buffer/peek-char - input-buffer/read-char - input-buffer/set-buffer-contents - input-buffer/set-size - input-buffer/size - make-input-buffer - make-output-buffer - output-buffer/buffered-chars - output-buffer/channel - output-buffer/drain-block - output-buffer/set-size - output-buffer/size - output-buffer/write-char-block - output-buffer/write-substring-block - set-channel-port!) (export (runtime microcode-errors) port-error-test) (export (runtime x-graphics) @@ -4505,9 +4448,15 @@ USA. match-parser-buffer-char match-parser-buffer-char-ci match-parser-buffer-char-ci-no-advance + match-parser-buffer-char-in-alphabet + match-parser-buffer-char-in-alphabet-no-advance match-parser-buffer-char-in-set match-parser-buffer-char-in-set-no-advance match-parser-buffer-char-no-advance + match-parser-buffer-char-not-in-alphabet + match-parser-buffer-char-not-in-alphabet-no-advance + match-parser-buffer-char-not-in-set + match-parser-buffer-char-not-in-set-no-advance match-parser-buffer-not-char match-parser-buffer-not-char-ci match-parser-buffer-not-char-ci-no-advance @@ -4520,7 +4469,6 @@ USA. match-parser-buffer-substring-ci match-parser-buffer-substring-ci-no-advance match-parser-buffer-substring-no-advance - match-utf8-char-in-alphabet parser-buffer-line parser-buffer-pointer-index parser-buffer-pointer-line @@ -4533,7 +4481,9 @@ USA. set-parser-buffer-pointer! source->parser-buffer string->parser-buffer - substring->parser-buffer)) + substring->parser-buffer + wide-string->parser-buffer + wide-substring->parser-buffer)) (define-package (runtime unicode) (files "unicode") @@ -4560,6 +4510,7 @@ USA. guarantee-wide-char guarantee-wide-string guarantee-wide-string-index + guarantee-wide-substring make-wide-string open-wide-input-string open-wide-output-string @@ -4610,6 +4561,7 @@ USA. wide-string-ref wide-string-set! wide-string? + wide-substring write-utf16-be-char write-utf16-char write-utf16-le-char @@ -4618,7 +4570,14 @@ USA. write-utf32-le-char write-utf8-char) (export (runtime parser-buffer) - read-utf8-char-from-source)) + %wide-string-length + %wide-string-ref + %wide-substring + wide-string-contents) + (export (runtime generic-i/o-port) + wide-string-contents) + (export (runtime input-port) + wide-string-contents)) (define-package (runtime url) (files "url") diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm index cc192e62a..25f0ce73e 100644 --- a/v7/src/runtime/socket.scm +++ b/v7/src/runtime/socket.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: socket.scm,v 1.24 2003/07/09 22:28:18 cph Exp $ +$Id: socket.scm,v 1.25 2004/02/16 05:38:23 cph Exp $ Copyright 1996,1997,1998,1999,2001,2002 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -29,24 +29,13 @@ USA. (declare (usual-integrations)) -(define (open-tcp-stream-socket host-name service - #!optional buffer-size line-translation) - (socket-port (open-tcp-stream-socket-channel host-name service) - (if (default-object? buffer-size) #f buffer-size) - (if (default-object? line-translation) #f line-translation))) - -(define (open-unix-stream-socket filename - #!optional buffer-size line-translation) - (socket-port (open-unix-stream-socket-channel filename) - (if (default-object? buffer-size) #f buffer-size) - (if (default-object? line-translation) #f line-translation))) - -(define (socket-port channel buffer-size line-translation) - (let ((buffer-size (or buffer-size 4096)) - (line-translation (or line-translation 'DEFAULT))) - (make-generic-i/o-port channel channel - buffer-size buffer-size - line-translation line-translation))) +(define (open-tcp-stream-socket host-name service) + (let ((channel (open-tcp-stream-socket-channel host-name service))) + (make-generic-i/o-port channel channel))) + +(define (open-unix-stream-socket filename) + (let ((channel (open-unix-stream-socket-channel filename))) + (make-generic-i/o-port channel channel))) (define (open-tcp-stream-socket-channel host-name service) (let ((host (vector-ref (get-host-by-name host-name) 0)) @@ -98,8 +87,7 @@ USA. (define (close-tcp-server-socket server-socket) (channel-close server-socket)) -(define (tcp-server-connection-accept server-socket block? peer-address - #!optional line-translation) +(define (tcp-server-connection-accept server-socket block? peer-address) (let ((channel (with-thread-events-blocked (lambda () @@ -128,13 +116,7 @@ USA. (let loop () (do-test loop)) (do-test (lambda () #f)))))))) (and channel - (let ((line-translation - (if (or (default-object? line-translation) - (not line-translation)) - 'DEFAULT - line-translation))) - (make-generic-i/o-port channel channel 4096 4096 - line-translation line-translation))))) + (make-generic-i/o-port channel channel)))) (define (get-host-by-name host-name) (with-thread-timer-stopped diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index 7cd3598bd..59fe0193f 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: string.scm,v 14.54 2003/11/10 21:46:27 cph Exp $ +$Id: string.scm,v 14.55 2004/02/16 05:38:29 cph Exp $ Copyright 1986,1987,1988,1992,1993,1994 Massachusetts Institute of Technology Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -152,6 +152,8 @@ USA. (begin (if (not (char? (car chars))) (error:wrong-type-datum (car chars) "character")) + (if (not (fix:< (char->integer (car chars)) #x100)) + (error:not-8-bit-char (car chars))) (string-set! result index (car chars)) (loop (cdr chars) (fix:+ index 1))) result)))) diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index 401058fb0..9a278aa00 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: strnin.scm,v 14.12 2003/02/27 21:27:58 cph Exp $ +$Id: strnin.scm,v 14.13 2004/02/16 05:38:37 cph Exp $ -Copyright 1988,1990,1993,1999,2003 Massachusetts Institute of Technology +Copyright 1988,1990,1993,1999,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,18 +28,6 @@ USA. (declare (usual-integrations)) -(define (initialize-package!) - (set! input-string-port-type - (make-port-type `((CHAR-READY? ,operation/char-ready?) - (DISCARD-CHAR ,operation/discard-char) - (DISCARD-CHARS ,operation/discard-chars) - (PEEK-CHAR ,operation/peek-char) - (WRITE-SELF ,operation/write-self) - (READ-CHAR ,operation/read-char) - (READ-STRING ,operation/read-string)) - #f)) - unspecific) - (define (with-input-from-string string thunk) (with-input-from-port (open-input-string string) thunk)) @@ -51,7 +39,7 @@ USA. (guarantee-substring-end-index end (string-length string) 'OPEN-INPUT-STRING)))) (make-port input-string-port-type - (make-input-string-state + (make-istate string (if (or (default-object? start) (not start)) 0 @@ -60,72 +48,32 @@ USA. end)))) (define input-string-port-type) +(define (initialize-package!) + (set! input-string-port-type + (make-port-type + `((CHAR-READY? + ,(lambda (port) + (let ((s (port/state port))) + (fix:< (istate-start s) (istate-end s))))) + (READ-CHAR + ,(lambda (port) + (let ((s (port/state port))) + (without-interrupts + (lambda () + (let ((start (istate-start s))) + (if (fix:< start (istate-end s)) + (begin + (set-istate-start! s (fix:+ start 1)) + (string-ref (istate-string s) start)) + (make-eof-object port)))))))) + (WRITE-SELF + ,(lambda (port output-port) + port + (write-string " from string" output-port)))) + #f)) + unspecific) -(define-structure (input-string-state (type vector) - (conc-name input-string-state/)) +(define-structure (istate (type vector)) (string #f read-only #t) start - (end #f read-only #t)) - -(define-integrable (input-port/string port) - (input-string-state/string (port/state port))) - -(define-integrable (input-port/start port) - (input-string-state/start (port/state port))) - -(define-integrable (set-input-port/start! port index) - (set-input-string-state/start! (port/state port) index)) - -(define-integrable (input-port/end port) - (input-string-state/end (port/state port))) - -(define (operation/char-ready? port interval) - interval - (fix:< (input-port/start port) (input-port/end port))) - -(define (operation/peek-char port) - (if (fix:< (input-port/start port) (input-port/end port)) - (string-ref (input-port/string port) (input-port/start port)) - (make-eof-object port))) - -(define (operation/discard-char port) - (set-input-port/start! port (fix:+ (input-port/start port) 1))) - -(define (operation/read-char port) - (let ((start (input-port/start port))) - (if (fix:< start (input-port/end port)) - (begin - (set-input-port/start! port (fix:+ start 1)) - (string-ref (input-port/string port) start)) - (make-eof-object port)))) - -(define (operation/read-string port delimiters) - (let ((start (input-port/start port)) - (end (input-port/end port))) - (if (fix:< start end) - (let ((string (input-port/string port))) - (let ((index - (or (substring-find-next-char-in-set string - start - end - delimiters) - end))) - (set-input-port/start! port index) - (substring string start index))) - (make-eof-object port)))) - -(define (operation/discard-chars port delimiters) - (let ((start (input-port/start port)) - (end (input-port/end port))) - (if (fix:< start end) - (set-input-port/start! - port - (or (substring-find-next-char-in-set (input-port/string port) - start - end - delimiters) - end))))) - -(define (operation/write-self port output-port) - port - (write-string " from string" output-port)) \ No newline at end of file + (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 6eef8ae34..2eef3c220 100644 --- a/v7/src/runtime/strott.scm +++ b/v7/src/runtime/strott.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: strott.scm,v 14.11 2003/02/14 18:28:34 cph Exp $ +$Id: strott.scm,v 14.12 2004/02/16 05:38:42 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright 1988,1993,1999,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,64 +28,59 @@ USA. (declare (usual-integrations)) -(define (initialize-package!) - (set! output-string-port-type - (make-port-type `((WRITE-SELF ,operation/write-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring)) - #f))) - (define (with-output-to-truncated-string max thunk) (call-with-current-continuation - (lambda (return) - (cons #f - (apply string-append - (reverse! - (let ((state - (make-output-string-state return max '() max))) - (with-output-to-port - (make-port output-string-port-type state) - thunk) - (output-string-state/accumulator state)))))))) + (lambda (k) + (let ((state (make-astate k max (make-string (fix:min max 128)) 0))) + (with-output-to-port (make-port output-string-port-type state) + thunk) + (cons #f + (without-interrupts + (lambda () + (string-head (astate-chars state) + (astate-index state))))))))) (define output-string-port-type) +(define (initialize-package!) + (set! output-string-port-type + (make-port-type + `((WRITE-CHAR + ,(lambda (port char) + (guarantee-8-bit-char char) + (let ((state (port/state port))) + (without-interrupts + (lambda () + (let* ((n (astate-index state))) + (if (fix:< n (astate-max-length state)) + (let ((n* (fix:+ n 1))) + (if (fix:= n (string-length (astate-chars state))) + (grow-accumulator! state n*)) + (string-set! (astate-chars state) n char) + (set-astate-index! state n*)) + ((astate-return state) + (cons #t (string-copy (astate-chars state))))))))) + 1)) + (WRITE-SELF + ,(lambda (port output-port) + port + (write-string " to string (truncating)" output-port)))) + #f)) + unspecific) -(define-structure (output-string-state (type vector) - (conc-name output-string-state/)) +(define-structure (astate (type vector)) (return #f read-only #t) (max-length #f read-only #t) - accumulator - counter) - -(define (operation/write-char port char) - (let ((state (port/state port))) - (let ((accumulator (output-string-state/accumulator state)) - (counter (output-string-state/counter state))) - (if (zero? counter) - ((output-string-state/return state) - (cons #t (apply string-append (reverse! accumulator)))) - (begin - (set-output-string-state/accumulator! - state - (cons (string char) accumulator)) - (set-output-string-state/counter! state (-1+ counter))))))) - -(define (operation/write-substring port string start end) - (let ((state (port/state port))) - (let ((accumulator - (cons (substring string start end) - (output-string-state/accumulator state))) - (counter (- (output-string-state/counter state) (- end start)))) - (if (negative? counter) - ((output-string-state/return state) - (cons #t - (substring (apply string-append (reverse! accumulator)) - 0 - (output-string-state/max-length state)))) - (begin - (set-output-string-state/accumulator! state accumulator) - (set-output-string-state/counter! state counter)))))) + chars + index) -(define (operation/write-self port output-port) - port - (write-string " to string (truncating)" output-port)) \ No newline at end of file +(define (grow-accumulator! state min-size) + (let* ((old (astate-chars state)) + (n (string-length old)) + (new + (make-string + (let loop ((n (fix:+ n n))) + (if (fix:>= n min-size) + (fix:min n (astate-max-length state)) + (loop (fix:+ n n))))))) + (substring-move! old 0 n new 0) + (set-astate-chars! state new))) \ No newline at end of file diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index f3b984388..9244b5da0 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: strout.scm,v 14.18 2003/02/14 18:28:34 cph Exp $ +$Id: strout.scm,v 14.19 2004/02/16 05:38:49 cph Exp $ Copyright 1988,1990,1993,1999,2000,2001 Massachusetts Institute of Technology -Copyright 2003 Massachusetts Institute of Technology +Copyright 2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -30,74 +30,74 @@ USA. (declare (usual-integrations)) (define (open-output-string) - (make-port accumulator-output-port-type - (make-accumulator-state (make-string 16) 0))) + (make-port accumulator-output-port-type (make-astate (make-string 128) 0))) (define (get-output-string port) ((port/operation port 'EXTRACT-OUTPUT!) port)) -(define (with-output-to-string thunk) - (call-with-output-string (lambda (port) (with-output-to-port port thunk)))) - (define (call-with-output-string generator) (let ((port (open-output-string))) (generator port) (get-output-string port))) +(define (with-output-to-string thunk) + (call-with-output-string + (lambda (port) + (with-output-to-port port thunk)))) + (define accumulator-output-port-type) (define (initialize-package!) (set! accumulator-output-port-type - (make-port-type `((WRITE-SELF ,operation/write-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring) - (EXTRACT-OUTPUT! ,operation/extract-output!)) - #f)) + (make-port-type + `((EXTRACT-OUTPUT! + ,(lambda (port) + (let ((state (port/state port))) + (without-interrupts + (lambda () + (let ((s (astate-chars state)) + (n (astate-index state))) + (set-astate-chars! state (make-string 128)) + (set-astate-index! state 0) + (set-string-maximum-length! s n) + s)))))) + (WRITE-CHAR + ,(lambda (port char) + (guarantee-8-bit-char char) + (let ((state (port/state port))) + (without-interrupts + (lambda () + (let* ((n (astate-index state)) + (n* (fix:+ n 1))) + (if (fix:> n* (string-length (astate-chars state))) + (grow-accumulator! state n*)) + (string-set! (astate-chars state) n char) + (set-astate-index! state n*))))) + 1)) + (WRITE-SELF + ,(lambda (port output-port) + port + (write-string " to string" output-port))) + (WRITE-SUBSTRING + ,(lambda (port string start end) + (let ((state (port/state port))) + (without-interrupts + (lambda () + (let* ((n (astate-index state)) + (n* (fix:+ n (fix:- end start)))) + (if (fix:> n* (string-length (astate-chars state))) + (grow-accumulator! state n*)) + (substring-move! string start end (astate-chars state) n) + (set-astate-index! state n*))))) + (fix:- end start)))) + #f)) unspecific) -(define (operation/write-self port output-port) - port - (write-string " to string" output-port)) - -(define (operation/write-char port char) - (without-interrupts - (lambda () - (let* ((state (port/state port)) - (n (accumulator-state-counter state)) - (n* (fix:+ n 1))) - (if (fix:= n (string-length (accumulator-state-accumulator state))) - (grow-accumulator! state n*)) - (string-set! (accumulator-state-accumulator state) n char) - (set-accumulator-state-counter! state n*))))) - -(define (operation/write-substring port string start end) - (without-interrupts - (lambda () - (let* ((state (port/state port)) - (n (accumulator-state-counter state)) - (n* (fix:+ n (fix:- end start)))) - (if (fix:> n* (string-length (accumulator-state-accumulator state))) - (grow-accumulator! state n*)) - (substring-move! string start end - (accumulator-state-accumulator state) n) - (set-accumulator-state-counter! state n*))))) - -(define (operation/extract-output! port) - (without-interrupts - (lambda () - (let ((state (port/state port))) - (let ((s (accumulator-state-accumulator state)) - (n (accumulator-state-counter state))) - (set-accumulator-state-accumulator! state (make-string 16)) - (set-accumulator-state-counter! state 0) - (set-string-maximum-length! s n) - s))))) - -(define-structure (accumulator-state (type vector)) - accumulator - counter) +(define-structure (astate (type vector)) + chars + index) (define (grow-accumulator! state min-size) - (let* ((old (accumulator-state-accumulator state)) + (let* ((old (astate-chars state)) (n (string-length old)) (new (make-string @@ -106,4 +106,4 @@ USA. n (loop (fix:+ n n))))))) (substring-move! old 0 n new 0) - (set-accumulator-state-accumulator! state new))) \ No newline at end of file + (set-astate-chars! state new))) \ No newline at end of file diff --git a/v7/src/runtime/syncproc.scm b/v7/src/runtime/syncproc.scm index 2e3379dbe..05ec0377a 100644 --- a/v7/src/runtime/syncproc.scm +++ b/v7/src/runtime/syncproc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: syncproc.scm,v 1.10 2003/02/14 18:28:34 cph Exp $ +$Id: syncproc.scm,v 1.11 2004/02/16 05:38:55 cph Exp $ -Copyright (c) 1999 Massachusetts Institute of Technology +Copyright 1999,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -36,15 +36,11 @@ USA. ;; Where to get input data to send to the subprocess. Either an ;; input port, or #F meaning that nothing is to be sent. (input #f read-only #t) - ;; How to do line translation on data sent to the subprocess. - (input-line-translation 'DEFAULT read-only #t) ;; What size is the input buffer? (input-buffer-size 512 read-only #t) ;; Where to put output data that is received from the subprocess. ;; Either an output port, or #F meaning to discard any output. (output (current-output-port) read-only #t) - ;; How to do line translation on data received from the subprocess. - (output-line-translation 'DEFAULT read-only #t) ;; What size is the output buffer? (output-buffer-size 512 read-only #t) ;; A thunk that is periodically called while the subprocess is @@ -60,7 +56,9 @@ USA. ;; the operating system). (use-pty? #f read-only #t) ;; The name of the shell interpreter. - (shell-file-name (os/shell-file-name) read-only #t)) + (shell-file-name (os/shell-file-name) read-only #t) + ;; How lines are terminated when talking to the subprocess. + (line-ending #f read-only #t)) (define (run-shell-command command . options) (let ((context (apply make-subprocess-context options))) @@ -151,12 +149,13 @@ USA. (condition-signaller condition-type:subprocess-signalled '(SUBPROCESS REASON) standard-error-handler)) - + (define (synchronous-process-wait process context) - ;; Initialize the subprocess line-translation appropriately. - (subprocess-i/o-port process - (subprocess-context/output-line-translation context) - (subprocess-context/input-line-translation context)) + ;; Initialize the subprocess I/O. + (let ((port (subprocess-i/o-port process)) + (line-ending (subprocess-context/line-ending context))) + (if line-ending + (port/set-line-ending port line-ending))) (let ((redisplay-hook (subprocess-context/redisplay-hook context))) (call-with-input-copier process (subprocess-context/input context) @@ -178,10 +177,13 @@ USA. (let ((n (copy-output))) (cond ((not n) (loop)) - ((> n 0) + ((fix:> n 0) (if redisplay-hook (redisplay-hook)) (loop)))))) - (do () ((eqv? (copy-input) 0)))) + (do () + ((let ((n (copy-input))) + (and n + (not (fix:> n 0))))))) (if copy-output (begin (if redisplay-hook (redisplay-hook)) @@ -200,17 +202,19 @@ USA. ((port/operation port 'SET-OUTPUT-BLOCKING-MODE) port 'NONBLOCKING)) (receiver - (let ((buffer (make-string bsize))) + (let ((buffer (make-wide-string bsize))) (lambda () (port/with-input-blocking-mode process-input 'BLOCKING (lambda () (let ((n - (input-port/read-string! process-input buffer))) - (if (> n 0) - (output-port/write-substring port buffer 0 n) - (begin - (output-port/close port) - 0)))))))))) + (input-port/read-wide-string! process-input + buffer))) + (if n + (if (fix:> n 0) + (output-port/write-wide-substring port + buffer 0 n) + (output-port/close port))) + n)))))))) (begin (output-port/close port) (receiver #f)))))) @@ -237,15 +241,15 @@ USA. (let ((input-port/open? (port/operation port 'INPUT-OPEN?)) (input-port/close (port/operation port 'CLOSE-INPUT))) (if process-output - (let ((buffer (make-string bsize))) + (let ((buffer (make-wide-string bsize))) (let ((copy-output (lambda () - (let ((n (input-port/read-string! port buffer))) - (if (and n (> n 0)) + (let ((n (input-port/read-wide-string! port buffer))) + (if (and n (fix:> n 0)) (port/with-output-blocking-mode process-output 'BLOCKING (lambda () - (output-port/write-substring + (output-port/write-wide-substring process-output buffer 0 n)))) n)))) (if nonblock? (port/set-input-blocking-mode port 'NONBLOCKING)) @@ -253,7 +257,7 @@ USA. (if (and nonblock? (input-port/open? port)) (begin (port/set-input-blocking-mode port 'BLOCKING) - (do () ((= (copy-output) 0))) + (do () ((not (fix:> (copy-output) 0)))) (input-port/close port))) status))) (receiver #f))))) \ No newline at end of file diff --git a/v7/src/runtime/tscript.scm b/v7/src/runtime/tscript.scm index 6bbc920bd..7a84bb969 100644 --- a/v7/src/runtime/tscript.scm +++ b/v7/src/runtime/tscript.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: tscript.scm,v 1.6 2003/02/14 18:28:34 cph Exp $ +$Id: tscript.scm,v 1.7 2004/02/16 05:39:03 cph Exp $ -Copyright (c) 1990, 1999 Massachusetts Institute of Technology +Copyright 1990,1999,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -27,90 +27,23 @@ USA. ;;; package: (runtime transcript) (declare (usual-integrations)) - -(define-structure (encap-state - (conc-name encap-state/) - (constructor make-encap-state ())) - (transcript-port #f)) - -(define (transcriptable-port? object) - (and (encapsulated-port? object) - (encap-state? (encapsulated-port/state object)))) - -(define (encap/tport encap) - (encap-state/transcript-port (encapsulated-port/state encap))) - -(define (set-encap/tport! encap tport) - (set-encap-state/transcript-port! (encapsulated-port/state encap) tport)) - -(define (make-transcriptable-port port) - (make-encapsulated-port port (make-encap-state) - (lambda (name operation) - (let ((entry (assq name duplexed-operations))) - (if entry - (and (cadr entry) - ((cadr entry) operation)) - operation))))) (define (transcript-on filename) - (let ((encap (nearest-cmdl/port))) - (if (not (transcriptable-port? encap)) - (error "Transcript not supported for this REPL.")) - (if (encap/tport encap) - (error "transcript already turned on")) - (set-encap/tport! encap (open-output-file filename)))) + (let ((port (nearest-cmdl/port))) + (if (get-transcript-port port) + (error "Transcript already turned on.")) + (set-transcript-port port (open-output-file filename)))) (define (transcript-off) - (let ((encap (nearest-cmdl/port))) - (if (not (transcriptable-port? encap)) - (error "Transcript not supported for this REPL.")) - (let ((tport (encap/tport encap))) - (if tport + (let ((port (nearest-cmdl/port))) + (let ((transcript-port (get-transcript-port port))) + (if transcript-port (begin - (set-encap/tport! encap #f) - (close-port tport)))))) - -(define duplexed-operations) + (set-transcript-port port #f) + (close-port transcript-port)))))) + +(define (get-transcript-port port) + ((port/operation/get-transcript-port port) port)) -(define (initialize-package!) - (set! duplexed-operations - (let ((input-char - (lambda (operation) - (lambda (encap . arguments) - (let ((char (apply operation encap arguments)) - (tport (encap/tport encap))) - (if (and tport (char? char)) - (write-char char tport)) - char)))) - (input-expr - (lambda (operation) - (lambda (encap . arguments) - (let ((expr (apply operation encap arguments)) - (tport (encap/tport encap))) - (if tport - (write expr tport)) - expr)))) - (duplex - (lambda (toperation) - (lambda (operation) - (lambda (encap . arguments) - (apply operation encap arguments) - (let ((tport (encap/tport encap))) - (if tport - (apply toperation tport arguments)))))))) - `((READ-CHAR ,input-char) - (PROMPT-FOR-COMMAND-CHAR ,input-char) - (PROMPT-FOR-EXPRESSION ,input-expr) - (PROMPT-FOR-COMMAND-EXPRESSION ,input-expr) - (READ ,input-expr) - (DISCARD-CHAR #f) - (DISCARD-CHARS #f) - (READ-STRING #f) - (READ-SUBSTRING #f) - (WRITE-CHAR ,(duplex output-port/write-char)) - (WRITE-SUBSTRING ,(duplex output-port/write-substring)) - (FRESH-LINE ,(duplex output-port/fresh-line)) - (FLUSH-OUTPUT ,(duplex output-port/flush-output)) - (DISCRETIONARY-FLUSH-OUTPUT - ,(duplex output-port/discretionary-flush))))) - unspecific) \ No newline at end of file +(define (set-transcript-port port transcript-port) + ((port/operation/set-transcript-port port) port transcript-port)) \ No newline at end of file diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm index d709a8f34..f0f7961e6 100644 --- a/v7/src/runtime/ttyio.scm +++ b/v7/src/runtime/ttyio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ttyio.scm,v 1.16 2004/01/19 04:30:41 cph Exp $ +$Id: ttyio.scm,v 1.17 2004/02/16 05:39:09 cph Exp $ Copyright 1991,1993,1996,1999,2003,2004 Massachusetts Institute of Technology @@ -28,72 +28,57 @@ USA. (declare (usual-integrations)) -(define hook/read-char) -(define hook/peek-char) - (define (initialize-package!) (let ((input-channel (tty-input-channel)) (output-channel (tty-output-channel))) - (set! hook/read-char operation/read-char) - (set! hook/peek-char operation/peek-char) - (set! the-console-port-type - (make-port-type - `((BEEP ,operation/beep) - (CLEAR ,operation/clear) - (DISCRETIONARY-FLUSH-OUTPUT ,operation/flush-output) - (PEEK-CHAR ,(lambda (port) (hook/peek-char port))) - (READ-CHAR ,(lambda (port) (hook/read-char port))) - (READ-FINISH ,operation/read-finish) - (WRITE-SELF ,operation/write-self) - (X-SIZE ,operation/x-size) - (Y-SIZE ,operation/y-size)) - generic-i/o-type)) - (set! the-console-port - (make-port the-console-port-type - (make-console-port-state - (make-input-buffer input-channel input-buffer-size) - (make-output-buffer output-channel output-buffer-size) - (channel-type=file? input-channel)))) - (set-channel-port! input-channel the-console-port) - (set-channel-port! output-channel the-console-port)) + (let ((type + (make-port-type + `((BEEP ,operation/beep) + (CHAR-READY? ,generic-io/char-ready?) + (CLEAR ,operation/clear) + (DISCRETIONARY-FLUSH-OUTPUT ,generic-io/flush-output) + (READ-CHAR ,operation/read-char) + (READ-FINISH ,operation/read-finish) + (WRITE-SELF ,operation/write-self) + (X-SIZE ,operation/x-size) + (Y-SIZE ,operation/y-size)) + generic-i/o-type))) + (let ((port (make-port type (make-cstate input-channel output-channel)))) + (set-channel-port! input-channel port) + (set-channel-port! output-channel port) + (set! the-console-port port) + (set-console-i/o-port! port) + (set-current-input-port! port) + (set-current-output-port! port)))) (add-event-receiver! event:before-exit save-console-input) - (add-event-receiver! event:after-restore reset-console) - (set-console-i/o-port! the-console-port) - (set-current-input-port! the-console-port) - (set-current-output-port! the-console-port)) + (add-event-receiver! event:after-restore reset-console)) + +(define-structure (cstate (type vector) + (initial-offset 4) ;must match "genio.scm" + (constructor #f)) + (echo-input? #f read-only #t)) -(define the-console-port-type) -(define the-console-port) -(define input-buffer-size 512) -(define output-buffer-size 512) - (define (save-console-input) ((ucode-primitive reload-save-string 1) - (input-buffer/buffer-contents (port/input-buffer console-input-port)))) + (input-buffer-contents (port-input-buffer console-input-port)))) (define (reset-console) (let ((input-channel (tty-input-channel)) - (output-channel (tty-output-channel)) - (state (port/state the-console-port))) + (output-channel (tty-output-channel))) + (set-port/state! the-console-port + (make-cstate input-channel output-channel)) + (let ((s ((ucode-primitive reload-retrieve-string 0)))) + (if s + (set-input-buffer-contents! (port-input-buffer the-console-port) + s))) (set-channel-port! input-channel the-console-port) - (set-channel-port! output-channel the-console-port) - (set-console-port-state/input-buffer! - state - (let ((buffer - (make-input-buffer - input-channel - (input-buffer/size (console-port-state/input-buffer state))))) - (let ((contents ((ucode-primitive reload-retrieve-string 0)))) - (if contents - (input-buffer/set-buffer-contents buffer contents))) - buffer)) - (set-console-port-state/output-buffer! - state - (make-output-buffer - output-channel - (output-buffer/size (console-port-state/output-buffer state)))) - (set-console-port-state/echo-input?! state - (channel-type=file? input-channel)))) + (set-channel-port! output-channel the-console-port))) + +(define (make-cstate input-channel output-channel) + (make-gstate input-channel + output-channel + 'TEXT + (channel-type=file? input-channel))) (define (set-console-i/o-port! port) (if (not (i/o-port? port)) @@ -103,57 +88,37 @@ USA. (set! console-output-port port) unspecific) +(define (console-i/o-port? port) + (port=? port console-i/o-port)) + +(define the-console-port) (define console-i/o-port) (define console-input-port) (define console-output-port) - -(define-structure (console-port-state (type vector) - (conc-name console-port-state/)) - ;; First two elements of this vector are required by the generic - ;; I/O port operations. - input-buffer - output-buffer - echo-input?) - -(define-integrable (port/input-buffer port) - (console-port-state/input-buffer (port/state port))) - -(define-integrable (port/output-buffer port) - (console-port-state/output-buffer (port/state port))) -(define (operation/peek-char port) - (let ((char (input-buffer/peek-char (port/input-buffer port)))) - (if (eof-object? char) - (signal-end-of-input port)) - char)) - (define (operation/read-char port) - (let ((char (input-buffer/read-char (port/input-buffer port)))) + (let ((char (generic-io/read-char port))) (if (eof-object? char) - (signal-end-of-input port)) + (begin + (if (not (nearest-cmdl/batch-mode?)) + (begin + (fresh-line port) + (write-string "End of input stream reached" port))) + (%exit))) (if (and char - (not (nearest-cmdl/batch-mode?)) - (console-port-state/echo-input? (port/state port))) + (cstate-echo-input? (port/state port)) + (not (nearest-cmdl/batch-mode?))) (output-port/write-char port char)) char)) -(define (signal-end-of-input port) - (if (not (nearest-cmdl/batch-mode?)) - (begin - (fresh-line port) - (write-string "End of input stream reached" port))) - (%exit)) - (define (operation/read-finish port) - (let ((buffer (port/input-buffer port))) - (let loop () - (if (input-buffer/char-ready? buffer 0) - (let ((char (input-buffer/peek-char buffer))) - (if (and (not (eof-object? char)) - (char-whitespace? char)) - (begin - (operation/read-char port) - (loop))))))) + (let loop () + (if (input-port/char-ready? port) + (let ((char (input-port/read-char port))) + (if (not (eof-object? char)) + (if (char-whitespace? char) + (loop) + (input-port/unread-char port char)))))) (output-port/discretionary-flush port)) (define (operation/clear port) diff --git a/v7/src/runtime/unicode.scm b/v7/src/runtime/unicode.scm index 4d7e0e090..b4e9911f6 100644 --- a/v7/src/runtime/unicode.scm +++ b/v7/src/runtime/unicode.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: unicode.scm,v 1.13 2003/08/03 05:54:34 cph Exp $ +$Id: unicode.scm,v 1.14 2004/02/16 05:39:15 cph Exp $ -Copyright 2001,2003 Massachusetts Institute of Technology +Copyright 2001,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -131,8 +131,8 @@ USA. (write-char (integer->char byte) port)) (define (initialize-package!) - (set! ws-output-port-type (make-port-type ws-output-operations #f)) - (set! ws-input-port-type (make-port-type ws-input-operations #f)) + (initialize-output-port!) + (initialize-input-port!) unspecific) ;;;; Unicode characters @@ -538,13 +538,6 @@ USA. (constructor %make-wide-string)) (contents #f read-only #t)) -(define-integrable (guarantee-wide-string object caller) - (if (not (wide-string? object)) - (error:not-wide-string object caller))) - -(define (error:not-wide-string object caller) - (error:wrong-type-argument object "a Unicode string" caller)) - (define (make-wide-string length #!optional char) (%make-wide-string (make-vector length @@ -581,6 +574,27 @@ USA. (define-integrable (%wide-string-set! string index char) (vector-set! (wide-string-contents string) index char)) + +(define (wide-substring string start end) + (guarantee-wide-substring string start end 'WIDE-SUBSTRING) + (%wide-substring string start end)) + +(define (%wide-substring string start end) + (let ((string* (make-wide-string (fix:- end start)))) + (let ((v1 (wide-string-contents string)) + (v2 (wide-string-contents string*))) + (do ((i start (fix:+ i 1)) + (j 0 (fix:+ j 1))) + ((not (fix:< i end))) + (vector-set! v2 j (vector-ref v1 i)))) + string*)) + +(define-integrable (guarantee-wide-string object caller) + (if (not (wide-string? object)) + (error:not-wide-string object caller))) + +(define (error:not-wide-string object caller) + (error:wrong-type-argument object "a Unicode string" caller)) (define (wide-string-index? index string) (and (index-fixnum? index) @@ -592,48 +606,68 @@ USA. (define (error:not-wide-string-index index caller) (error:wrong-type-argument index "a Unicode string index" caller)) - -(define (open-wide-output-string) - (make-port ws-output-port-type (make-ws-output-state))) +(define-integrable (guarantee-wide-substring string start end caller) + (if (not (and (wide-string? string) + (index-fixnum? start) + (index-fixnum? end) + (fix:<= start end) + (fix:<= end (%wide-string-length string)))) + (guarantee-wide-substring/fail string start end caller))) + +(define (guarantee-wide-substring/fail string start end caller) + (guarantee-wide-string string caller) + (guarantee-substring-end-index end (%wide-string-length string) caller) + (guarantee-substring-start-index start end caller)) + (define (call-with-wide-output-string generator) (let ((port (open-wide-output-string))) (generator port) (get-output-string port))) -(define ws-output-port-type) - -(define (make-ws-output-state) - (let ((v (make-vector 17))) - (vector-set! v 0 0) - v)) +(define (open-wide-output-string) + (make-port ws-output-port-type + (let ((v (make-vector 17))) + (vector-set! v 0 0) + v))) -(define ws-output-operations - `((WRITE-CHAR - ,(lambda (port char) - (guarantee-wide-char char 'WRITE-CHAR) - (without-interrupts - (lambda () - (let* ((v (port/state port)) - (n (vector-ref v 0)) - (n* (fix:+ n 1)) - (v - (if (fix:= (vector-length v) n*) - (vector-grow v (fix:+ n* n)) - v))) - (vector-set! v n* char) - (vector-set! v 0 n*)))))) - (EXTRACT-OUTPUT! - ,(lambda (port) - (%make-wide-string - (without-interrupts - (lambda () - (let ((v (port/state port))) - (subvector v 1 (fix:+ (vector-ref v 0) 1)))))))) - (WRITE-SELF - ,(lambda (port port*) - port - (write-string " to wide string" port*))))) +(define ws-output-port-type) +(define (initialize-output-port!) + (set! ws-output-port-type + (make-port-type + `((WRITE-CHAR + ,(lambda (port char) + (guarantee-wide-char char 'WRITE-CHAR) + (without-interrupts + (lambda () + (let* ((v (port/state port)) + (n (fix:+ (vector-ref v 0) 1))) + (if (fix:< n (vector-length v)) + (begin + (vector-set! v n char) + (vector-set! v 0 n)) + (let ((v + (vector-grow v + (fix:- (fix:* (vector-length v) 2) + 1)))) + (vector-set! v n char) + (vector-set! v 0 n) + (set-port/state! port v) + v))))) + 1)) + (EXTRACT-OUTPUT! + ,(lambda (port) + (%make-wide-string + (without-interrupts + (lambda () + (let ((v (port/state port))) + (subvector v 1 (fix:+ (vector-ref v 0) 1)))))))) + (WRITE-SELF + ,(lambda (port port*) + port + (write-string " to wide string" port*)))) + #f)) + unspecific) (define (string->wide-string string #!optional start end) (let ((input @@ -654,63 +688,46 @@ USA. (let* ((end (if (or (default-object? end) (not end)) (wide-string-length string) - (guarantee-substring-end-index end (wide-string-length string) + (guarantee-substring-end-index end (%wide-string-length string) 'OPEN-WIDE-INPUT-STRING))) (start (if (or (default-object? start) (not start)) 0 (guarantee-substring-start-index start end 'OPEN-WIDE-INPUT-STRING)))) - (make-port ws-input-port-type (make-ws-input-state string start end)))) + (make-port ws-input-port-type (make-istate string start end)))) (define ws-input-port-type) +(define (initialize-input-port!) + (set! ws-input-port-type + (make-port-type + `((CHAR-READY? + ,(lambda (port) + (let ((s (port/state port))) + (fix:< (istate-start s) (istate-end s))))) + (READ-CHAR + ,(lambda (port) + (let ((s (port/state port))) + (without-interrupts + (lambda () + (let ((start (istate-start s))) + (if (fix:< start (istate-end s)) + (begin + (set-istate-start! s (fix:+ start 1)) + (%wide-string-ref (istate-string s) start)) + (make-eof-object port)))))))) + (WRITE-SELF + ,(lambda (port output-port) + port + (write-string " from wide string" output-port)))) + #f)) + unspecific) -(define-structure (ws-input-state (type vector) - (conc-name ws-input-state/)) +(define-structure (istate (type vector)) (string #f read-only #t) start (end #f read-only #t)) -(define-integrable (ws-input-port/string port) - (ws-input-state/string (port/state port))) - -(define-integrable (ws-input-port/start port) - (ws-input-state/start (port/state port))) - -(define-integrable (set-ws-input-port/start! port index) - (set-ws-input-state/start! (port/state port) index)) - -(define-integrable (ws-input-port/end port) - (ws-input-state/end (port/state port))) - -(define ws-input-operations - `((CHAR-READY? - ,(lambda (port interval) - interval - (fix:< (ws-input-port/start port) (ws-input-port/end port)))) - (DISCARD-CHAR - ,(lambda (port) - (set-ws-input-port/start! port (fix:+ (ws-input-port/start port) 1)))) - (PEEK-CHAR - ,(lambda (port) - (let ((start (ws-input-port/start port))) - (if (fix:< start (ws-input-port/end port)) - (%wide-string-ref (ws-input-port/string port) - start) - (make-eof-object port))))) - (READ-CHAR - ,(lambda (port) - (let ((start (ws-input-port/start port))) - (if (fix:< start (ws-input-port/end port)) - (begin - (set-ws-input-port/start! port (fix:+ start 1)) - (%wide-string-ref (ws-input-port/string port) start)) - (make-eof-object port))))) - (WRITE-SELF - ,(lambda (port output-port) - port - (write-string " from wide string" output-port))))) - (define (wide-string->string string #!optional start end) (let ((input (open-wide-input-string string diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index f115d24e7..4adc9fd18 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,10 +1,10 @@ #| -*-Scheme-*- -$Id: unxprm.scm,v 1.65 2003/02/14 18:28:34 cph Exp $ +$Id: unxprm.scm,v 1.66 2004/02/16 05:39:29 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology -Copyright 2001,2003 Massachusetts Institute of Technology +Copyright 2001,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -258,7 +258,7 @@ USA. (set! ti-outside) unspecific)))) -(define (os/file-end-of-line-translation pathname) +(define (file-line-ending pathname) ;; This works because the line translation is harmless when not ;; needed. We can't tell when it is needed, because FAT and HPFS ;; filesystems can be mounted with automatic translation (in the @@ -276,11 +276,11 @@ USA. (string-ci=? "iso9660" type) (string-ci=? "ntfs" type) (string-ci=? "smb" type)) - "\r\n" - #f))) + 'CRLF + 'LF))) -(define (os/default-end-of-line-translation) - #f) +(define (default-line-ending) + 'LF) (define (copy-file from to) (let ((input-filename (->namestring (merge-pathnames from))) diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm index efb0b73c5..cccfa4381 100644 --- a/v7/src/runtime/unxpth.scm +++ b/v7/src/runtime/unxpth.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: unxpth.scm,v 14.28 2003/02/14 18:28:34 cph Exp $ +$Id: unxpth.scm,v 14.29 2004/02/16 05:39:37 cph Exp $ -Copyright (c) 1988-2001 Massachusetts Institute of Technology +Copyright 1987,1988,1989,1991,1994,1995 Massachusetts Institute of Technology +Copyright 1996,1997,2001,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -43,8 +44,7 @@ USA. unix/pathname->truename unix/user-homedir-pathname unix/init-file-pathname - unix/pathname-simplify - unix/end-of-line-string)) + unix/pathname-simplify)) (define (initialize-package!) (add-pathname-host-type! 'UNIX make-unix-host-type)) @@ -342,7 +342,4 @@ USA. (->namestring pathname) (->namestring pathname*)) pathname*))))))) - pathname)) - -(define (unix/end-of-line-string pathname) - (or (os/file-end-of-line-translation pathname) "\n")) \ No newline at end of file + pathname)) \ No newline at end of file