#| -*-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.
((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!
#| -*-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.
(declare (usual-integrations))
\f
-(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
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))
\f
;;;; Pathname Parser
(->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
#| -*-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.
(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
(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)))
#| -*-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.
(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)
(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)
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))))
\f
(set! make-simple-error
(condition-constructor condition-type:simple-error
(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)
\f
;;;; Utilities
#| -*-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.
\f
(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)
(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))
\f
(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)))
-\f
(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))
(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))
(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))
\f
(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))
-\f
-(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
#| -*-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
(declare (usual-integrations))
\f
+(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)))
+\f
(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)
output-operations
other-operations)
#f)))
- unspecific)
+ (initialize-name-maps!)
+ (initialize-conditions!))
(define generic-input-type)
(define generic-output-type)
(define generic-i/o-type)
\f
-(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))))
-\f
-(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))
(else (error:wrong-type-datum mode "terminal mode")))
unspecific)))
\f
-(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)))
+\f
+;;;; 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))
+\f
+;;;; 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)
+\f
+(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)
+\f
+;;;; 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)))))
+\f
+(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))))
+\f
+(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)))))))
+\f
+;;;; 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))))))
+\f
+(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)))
+\f
+(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)))))
+\f
+;;;; 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)
+\f
+(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)
+\f
+(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)
+\f
+(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)
+\f
+#|
+(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))))
+|#
+\f
+;;;; 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)))))))
+\f
+(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)))
+\f
+(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))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+;;;; 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
#| -*-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.
;;; package: (runtime input-port)
(declare (usual-integrations))
+\f
+;;;; 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))
+\f
(define (input-port/read-line port)
- (let ((line (input-port/read-string port char-set:newline)))
- ;; Discard delimiter, if any -- this is a no-op at EOF.
- (input-port/discard-char port)
- line))
-
-(define <eof-object> (make-record-type '<EOF-OBJECT> '()))
-(define eof-object? (record-predicate <eof-object>))
-(define eof-object ((record-constructor <eof-object>)))
-(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 <eof-object>
+ (make-eof-object port)
+ eof-object?
+ (port eof-object-port))
\f
-;;;; 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)))
+\f
(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
#| -*-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
(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)))
(define (pty-master-hangup channel)
((ucode-primitive pty-master-hangup 1) (channel-descriptor channel)))
-\f
+
;;;; Directory Primitives
(define-structure (directory-channel (conc-name directory-channel/))
(directory-channel/descriptor channel)
prefix))
\f
-;;;; 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)
-\f
-(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))))
-\f
-(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))
-\f
-(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))
-\f
-;;;; 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)))
-\f
-(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))))
-\f
-(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)))))))
-\f
-(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)))
-\f
-(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))))))
-\f
;;;; Select registry
(define have-select?)
(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)))
#| -*-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.
(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)))))
(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)))))
(input-state 'LINE-START)
(output-buffer (make-string 3) read-only #t)
(pending-return? #f))
-
+\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."))
(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)))))
(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)))
(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)))
(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))
#| -*-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.
(error "Unable to find Windows system root."))
(pathname-new-directory (pathname-as-directory sysroot) '(ABSOLUTE)))))
\f
-(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)
#| -*-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.
(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
(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))
#| -*-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.
(declare (usual-integrations))
\f
-;;;; 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)))
(and operation
(operation port))))
\f
-;;;; 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))))
+\f
+(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
(define beep (wrap-custom-operation-0 'BEEP))
(define clear (wrap-custom-operation-0 'CLEAR))
\f
-(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))))
-\f
;;;; Tabular output
(define (write-strings-in-columns strings port row-major? min-minor
#| -*-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
(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)))
(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
(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)
#| -*-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.
;;; 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)
+\f
(define-structure parser-buffer-pointer
(index #f read-only #t)
(line #f read-only #t))
-\f
+
(define (get-parser-buffer-pointer buffer)
;; Get an object that represents the current position.
(make-parser-buffer-pointer (+ (parser-buffer-base-offset buffer)
(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
;; 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)))
;; 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))))
\f
-(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)))))
\f
-(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)))))
\f
(define-integrable (increment-buffer-index! buffer char)
(set-parser-buffer-index! buffer (fix:+ (parser-buffer-index buffer) 1))
(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)
(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)
(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*)
#| -*-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.
(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)))
\f
(define (pathname=? x y)
(let ((x (->pathname x))
(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)
(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))
#| -*-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.
(declare (usual-integrations))
\f
+;;;; Port type
+
(define-structure (port-type (type-descriptor <port-type>)
(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! <port-type>
(lambda (state type)
(if (not (port-type? object))
(error:wrong-type-argument object "port type" procedure))
object)
-
+\f
(define-integrable (port-type/supports-input? type)
(port-type/read-char type))
(port-type/supports-input? object)
(port-type/supports-output? object)
#t))
-\f
-(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 <port-type> name))
- input-operation-names))
-
-(define input-operation-modifiers
- (map (lambda (name) (record-modifier <port-type> 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 <port-type> name))
- output-operation-names))
-
-(define output-operation-modifiers
- (map (lambda (name) (record-modifier <port-type> 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))))
+\f
+;;;; 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!))))
+\f
+(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))
+\f
+;;;; 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))))))))
+\f
+;;;; 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))))))))
+\f
+;;;; 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))))))
+\f
+;;;; 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))))))
\f
-(define-record-type <port>
- (%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 <port>)
+ (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))
+\f
(set-record-type-unparser-method! <port>
(lambda (state port)
((let ((name
(set-port/state! port state)
(set-port/thread-mutex! port (make-thread-mutex))
port))
-\f
+
(define (close-port port)
(let ((close (port/operation port 'CLOSE)))
(if close
(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))))
\f
(define (input-port? object)
(and (port? object)
(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)
-\f
-;;;; 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)))
-\f
-;;;; 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)))
-\f
-(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 <port-type> '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))))
-\f
-;;;; 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)))
\f
;;;; Special Operations
(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!)))
-\f
-;;;; 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
#| -*-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.
(define (subprocess-remove! process key)
(1d-table/remove! (subprocess-properties process) key))
\f
-(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)))
#| -*-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
(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)
#| -*-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
current-user-name
decode-file-time
decoded-time->file-time
+ default-line-ending
encode-file-time
file-access-time
file-access-time-direct
file-attributes/n-links
file-attributes/type
file-length
+ file-line-ending
file-modes
file-modification-time
file-modification-time-direct
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
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)
(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)
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
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
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
(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)
(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)
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
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
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
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*
*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
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
read-line
read-string
read-string!
- read-substring!)
- (export (runtime primitive-io)
- eof-object))
+ read-substring!))
(define-package (runtime output-port)
(files "output")
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
pathname-default-version
pathname-device
pathname-directory
- pathname-end-of-line-string
pathname-host
pathname-name
pathname-new-device
channel-file-length
channel-file-position
channel-file-set-position
+ channel-has-input?
channel-nonblocking
channel-open?
channel-port
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
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
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)
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
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
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")
guarantee-wide-char
guarantee-wide-string
guarantee-wide-string-index
+ guarantee-wide-substring
make-wide-string
open-wide-input-string
open-wide-output-string
wide-string-ref
wide-string-set!
wide-string?
+ wide-substring
write-utf16-be-char
write-utf16-char
write-utf16-le-char
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")
#| -*-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.
(declare (usual-integrations))
\f
-(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))
(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 ()
(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))))
\f
(define (get-host-by-name host-name)
(with-thread-timer-stopped
#| -*-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.
(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))))
#| -*-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.
(declare (usual-integrations))
\f
-(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))
(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
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)))
-\f
-(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
#| -*-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.
(declare (usual-integrations))
\f
-(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
#| -*-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.
(declare (usual-integrations))
\f
(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
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
#| -*-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.
;; 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
;; 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)))
(condition-signaller condition-type:subprocess-signalled
'(SUBPROCESS REASON)
standard-error-handler))
-\f
+
(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)
(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))
((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))))))
(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))
(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
#| -*-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.
;;; package: (runtime transcript)
(declare (usual-integrations))
-\f
-(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))))))
-\f
-(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
#| -*-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
(declare (usual-integrations))
\f
-(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)
-\f
(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))
(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)))
\f
-(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)
#| -*-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.
(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)
\f
;;;; Unicode characters
(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
(define-integrable (%wide-string-set! string index char)
(vector-set! (wide-string-contents string) index char))
+\f
+(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)
(define (error:not-wide-string-index index caller)
(error:wrong-type-argument index "a Unicode string index" caller))
-\f
-(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))
+\f
(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
(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
#| -*-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.
(set! ti-outside)
unspecific))))
\f
-(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
(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)))
#| -*-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.
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))
(->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
projects / mit-scheme.git / commitdiff