Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
12673 lines (11125 sloc) 435 KB
;;;============================================================================
;;; File: "_io.scm"
;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
;;;============================================================================
(##include "header.scm")
;;;============================================================================
;;; Implementation of exceptions.
(implement-library-type-datum-parsing-exception)
(define-prim (##raise-datum-parsing-exception kind readenv . parameters)
(macro-raise
(macro-make-datum-parsing-exception
kind
readenv
parameters)))
(implement-library-type-unterminated-process-exception)
(define-prim (##raise-unterminated-process-exception proc . args)
(##extract-procedure-and-arguments
proc
args
#f
#f
#f
(lambda (procedure arguments dummy1 dummy2 dummy3)
(macro-raise
(macro-make-unterminated-process-exception procedure arguments)))))
(implement-library-type-nonempty-input-port-character-buffer-exception)
(define-prim (##raise-nonempty-input-port-character-buffer-exception proc . args)
(##extract-procedure-and-arguments
proc
args
#f
#f
#f
(lambda (procedure arguments dummy1 dummy2 dummy3)
(macro-raise
(macro-make-nonempty-input-port-character-buffer-exception procedure arguments)))))
(implement-library-type-no-such-file-or-directory-exception)
(define-prim (##raise-no-such-file-or-directory-exception proc . args)
(##extract-procedure-and-arguments
proc
args
#f
#f
#f
(lambda (procedure arguments dummy1 dummy2 dummy3)
(macro-raise
(macro-make-no-such-file-or-directory-exception
procedure
arguments)))))
;;;----------------------------------------------------------------------------
;;; Define type checking procedures.
(define-fail-check-type settings
'settings)
(define-fail-check-type exact-integer-or-string-or-settings
'exact-integer-or-string-or-settings)
(define-fail-check-type string-or-ip-address
'string-or-ip-address)
;;;----------------------------------------------------------------------------
;;; Implementation of write environments.
(define-prim (##make-writeenv
style
port
readtable
marktable
force?
width
shift
close-parens
level
limit)
(macro-make-writeenv
style
port
readtable
marktable
force?
width
shift
close-parens
level
limit))
;;;----------------------------------------------------------------------------
;;; Implementation of read environments.
(define-prim (##make-readenv
port
readtable
wrapper
unwrapper
allow-script?)
(macro-make-readenv
port
readtable
wrapper
unwrapper
allow-script?
'()
#f
0))
(define-prim (##readenv-current-filepos re)
(##readenv-relative-filepos re 0))
(define-prim (##readenv-relative-filepos re offset)
(let* ((port
(macro-readenv-port re))
(line
(macro-character-port-rlines port))
(char-count
(##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rlo port))
offset))
(col
(##fixnum.- char-count
(macro-character-port-rcurline port))))
(##make-filepos line col char-count)))
;;;----------------------------------------------------------------------------
;;; Implementation of port settings.
(define-prim (##make-psettings
direction
allowed-settings
settings
fail
succeed)
(let ((psettings
(macro-make-psettings
direction
(macro-make-psettings-options
(macro-default-readtable)
(macro-default-char-encoding)
(macro-default-char-encoding-errors)
(macro-default-eol-encoding)
(macro-default-buffering)
(macro-default-permanent-close))
(macro-make-psettings-options
(macro-default-readtable)
(macro-default-char-encoding-errors)
(macro-default-char-encoding)
(macro-default-eol-encoding)
(macro-default-buffering)
(macro-default-permanent-close))
(macro-default-path)
(macro-default-init)
(macro-default-arguments)
(macro-default-environment)
(macro-default-directory)
(macro-default-append)
(macro-default-create)
(macro-default-truncate)
(macro-default-permissions)
(macro-default-output-width)
(macro-default-stdin-redir)
(macro-default-stdout-redir)
(macro-default-stderr-redir)
(macro-default-pseudo-term)
(macro-default-show-console)
(macro-default-server-address)
(macro-default-port-number)
(macro-default-socket-type)
(macro-default-coalesce)
(macro-default-keep-alive)
(macro-default-backlog)
(macro-default-reuse-address)
(macro-default-broadcast)
(macro-default-ignore-hidden))))
(##parse-psettings!
allowed-settings
settings
psettings
fail
succeed)))
(define-prim (##parse-psettings!
allowed-settings
settings
psettings
fail
succeed)
(define (error name)
(fail))
(define (error-improper-list)
(fail))
(define (direction value)
(cond ((##eq? value 'input)
(macro-direction-in))
((##eq? value 'output)
(macro-direction-out))
((##eq? value 'input-output)
(macro-direction-inout))
(else
#f)))
(define (readtable value)
(cond ((macro-readtable? value)
value)
(else
#f)))
(define (char-encoding value)
(cond ((##eq? value 'ASCII)
(macro-char-encoding-ASCII))
((##eq? value 'ISO-8859-1)
(macro-char-encoding-ISO-8859-1))
((##eq? value 'UTF-8)
(macro-char-encoding-UTF-8))
((##eq? value 'UTF-16)
(macro-char-encoding-UTF-16))
((##eq? value 'UTF-16LE)
(macro-char-encoding-UTF-16LE))
((##eq? value 'UTF-16BE)
(macro-char-encoding-UTF-16BE))
((##eq? value 'UTF)
(macro-char-encoding-UTF))
((##eq? value 'UTF-fallback-ASCII)
(macro-char-encoding-UTF-fallback-ASCII))
((##eq? value 'UTF-fallback-ISO-8859-1)
(macro-char-encoding-UTF-fallback-ISO-8859-1))
((##eq? value 'UTF-fallback-UTF-8)
(macro-char-encoding-UTF-fallback-UTF-8))
((##eq? value 'UTF-fallback-UTF-16)
(macro-char-encoding-UTF-fallback-UTF-16))
((##eq? value 'UTF-fallback-UTF-16LE)
(macro-char-encoding-UTF-fallback-UTF-16LE))
((##eq? value 'UTF-fallback-UTF-16BE)
(macro-char-encoding-UTF-fallback-UTF-16BE))
((##eq? value 'UCS-2)
(macro-char-encoding-UCS-2))
((##eq? value 'UCS-2LE)
(macro-char-encoding-UCS-2LE))
((##eq? value 'UCS-2BE)
(macro-char-encoding-UCS-2BE))
((##eq? value 'UCS-4)
(macro-char-encoding-UCS-4))
((##eq? value 'UCS-4LE)
(macro-char-encoding-UCS-4LE))
((##eq? value 'UCS-4BE)
(macro-char-encoding-UCS-4BE))
;; ((##eq? value 'wchar)
;; (macro-char-encoding-wchar))
;; ((##eq? value 'native)
;; (macro-char-encoding-native))
(else
#f)))
(define (char-encoding-errors value)
(cond ((##eq? value #t)
(macro-char-encoding-errors-on))
((##eq? value #f)
(macro-char-encoding-errors-off))
(else
#f)))
(define (eol-encoding value)
(cond ((##eq? value 'lf)
(macro-eol-encoding-lf))
((##eq? value 'cr)
(macro-eol-encoding-cr))
((##eq? value 'cr-lf)
(macro-eol-encoding-crlf))
(else
#f)))
(define (buffering value)
(cond ((##eq? value #t)
(macro-full-buffering))
((##eq? value 'line)
(macro-line-buffering))
((##eq? value #f)
(macro-no-buffering))
(else
#f)))
(define (permanent-close value)
(cond ((##eq? value #t)
(macro-permanent-close))
((##eq? value #f)
(macro-no-permanent-close))
(else
#f)))
(define (path value)
value)
(define (init value)
value)
(define (arguments value)
(##copy-string-list value))
(define (environment value)
(cond ((##not value)
value)
(else
(##copy-string-list value))))
(define (directory value)
value)
(define (append-flag value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-in))
#f)
(value
(macro-append))
(else
(macro-no-append))))
(define (create-flag value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-in))
#f)
((##eq? value #f)
(macro-no-create))
((##eq? value 'maybe)
(macro-maybe-create))
((##eq? value #t)
(macro-create))
(else
#f)))
(define (truncate-flag value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-in))
#f)
(value
(macro-truncate))
(else
(macro-no-truncate))))
(define (permissions value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-in))
#f)
((and (##fixnum? value)
(##not (##fixnum.< value 0))
(##fixnum.< value #o1000))
value)
(else
#f)))
(define (output-width value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-in))
#f)
((and (##fixnum? value)
(##fixnum.< 0 value))
value)
(else
#f)))
(define (stdin-redir value)
(cond ((##eq? value #t)
(macro-stdin-from-port))
((##eq? value #f)
(macro-stdin-unchanged))
(else
#f)))
(define (stdout-redir value)
(cond ((##eq? value #t)
(macro-stdout-to-port))
((##eq? value #f)
(macro-stdout-unchanged))
(else
#f)))
(define (stderr-redir value)
(cond ((##eq? value #t)
(macro-stderr-to-port))
((##eq? value #f)
(macro-stderr-unchanged))
(else
#f)))
(define (pseudo-term value)
(cond ((##eq? value #t)
(macro-pseudo-term))
((##eq? value #f)
(macro-no-pseudo-term))
(else
#f)))
(define (show-console value)
(cond ((##eq? value #t)
(macro-show-console))
((##eq? value #f)
(macro-no-show-console))
(else
#f)))
(define (port-number value)
(cond ((and (##fixnum? value)
(##fixnum.<= 0 value)
(##fixnum.<= value 65535))
value)
(else
#f)))
(define (socket-type value)
(cond ((or (##eq? value 'TCP) (##eq? value 'tcp))
(macro-socket-type-TCP))
((or (##eq? value 'UDP) (##eq? value 'udp))
(macro-socket-type-UDP))
((or (##eq? value 'RAW) (##eq? value 'raw))
(macro-socket-type-RAW))
(else
#f)))
(define (coalesce value)
(cond ((##eq? value #t)
(macro-coalesce))
((##eq? value #f)
(macro-no-coalesce))
(else
#f)))
(define (keep-alive value)
(cond ((##eq? value #t)
(macro-keep-alive))
((##eq? value #f)
(macro-no-keep-alive))
(else
#f)))
(define (backlog value)
(if (and (##fixnum? value)
(##not (##fixnum.< value 0)))
value
#f))
(define (reuse-address value)
(cond ((##eq? value #t)
(macro-reuse-address))
((##eq? value #f)
(macro-no-reuse-address))
(else
#f)))
(define (broadcast value)
(cond ((##eq? value #t)
(macro-broadcast))
((##eq? value #f)
(macro-no-broadcast))
(else
#f)))
(define (ignore-hidden value)
(cond ((##eq? (macro-psettings-direction psettings)
(macro-direction-out))
#f)
((##eq? value #t)
(macro-ignore-hidden))
((##eq? value #f)
(macro-ignore-nothing))
((##eq? value 'dot-and-dot-dot)
(macro-ignore-dot-and-dot-dot))
(else
#f)))
(let loop ((lst settings))
(macro-force-vars (lst)
(cond ((##pair? lst)
(let ((name (##car lst))
(rest1 (##cdr lst)))
(macro-force-vars (name rest1)
(if (and (##memq name allowed-settings)
(##pair? rest1))
(let ((value (##car rest1))
(rest2 (##cdr rest1)))
(macro-force-vars (value)
(cond ((##eq? name 'direction:)
(let ((x (direction value)))
(if x
(begin
(macro-psettings-direction-set!
psettings
x)
(loop rest2))
(error name))))
((and (##eq? name 'input-readtable:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-out))))
(let ((x (readtable value)))
(if x
(begin
(macro-psettings-options-readtable-set!
(macro-psettings-roptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'output-readtable:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-in))))
(let ((x (readtable value)))
(if x
(begin
(macro-psettings-options-readtable-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'readtable:)
(let ((x (readtable value)))
(if x
(begin
(macro-psettings-options-readtable-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-readtable-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'input-char-encoding:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-out))))
(let ((x (char-encoding value)))
(if x
(begin
(macro-psettings-options-char-encoding-set!
(macro-psettings-roptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'output-char-encoding:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-in))))
(let ((x (char-encoding value)))
(if x
(begin
(macro-psettings-options-char-encoding-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'char-encoding:)
(let ((x (char-encoding value)))
(if x
(begin
(macro-psettings-options-char-encoding-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-char-encoding-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'input-char-encoding-errors:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-out))))
(let ((x (char-encoding-errors value)))
(if x
(begin
(macro-psettings-options-char-encoding-errors-set!
(macro-psettings-roptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'output-char-encoding-errors:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-in))))
(let ((x (char-encoding-errors value)))
(if x
(begin
(macro-psettings-options-char-encoding-errors-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'char-encoding-errors:)
(let ((x (char-encoding-errors value)))
(if x
(begin
(macro-psettings-options-char-encoding-errors-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-char-encoding-errors-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'input-eol-encoding:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-out))))
(let ((x (eol-encoding value)))
(if x
(begin
(macro-psettings-options-eol-encoding-set!
(macro-psettings-roptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'output-eol-encoding:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-in))))
(let ((x (eol-encoding value)))
(if x
(begin
(macro-psettings-options-eol-encoding-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'eol-encoding:)
(let ((x (eol-encoding value)))
(if x
(begin
(macro-psettings-options-eol-encoding-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-eol-encoding-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'input-buffering:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-out))))
(let ((x (buffering value)))
(if x
(begin
(macro-psettings-options-buffering-set!
(macro-psettings-roptions psettings)
x)
(loop rest2))
(error name))))
((and (##eq? name 'output-buffering:)
(##not
(##eq?
(macro-psettings-direction psettings)
(macro-direction-in))))
(let ((x (buffering value)))
(if x
(begin
(macro-psettings-options-buffering-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'buffering:)
(let ((x (buffering value)))
(if x
(begin
(macro-psettings-options-buffering-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-buffering-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'permanent-close:)
(let ((x (permanent-close value)))
(if x
(begin
(macro-psettings-options-permanent-close-set!
(macro-psettings-roptions psettings)
x)
(macro-psettings-options-permanent-close-set!
(macro-psettings-woptions psettings)
x)
(loop rest2))
(error name))))
((##eq? name 'path:)
(let ((x (path value)))
(if x
(begin
(macro-psettings-path-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'init:)
(let ((x (init value)))
(if x
(begin
(macro-psettings-init-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'arguments:)
(let ((x (arguments value)))
(if (##fixnum? x)
(error name)
(begin
(macro-psettings-arguments-set!
psettings
x)
(loop rest2)))))
((##eq? name 'environment:)
(let ((x (environment value)))
(if (##fixnum? x)
(error name)
(begin
(macro-psettings-environment-set!
psettings
x)
(loop rest2)))))
((##eq? name 'directory:)
(let ((x (directory value)))
(if (##fixnum? x)
(error name)
(begin
(macro-psettings-directory-set!
psettings
x)
(loop rest2)))))
((##eq? name 'append:)
(let ((x (append-flag value)))
(if x
(begin
(macro-psettings-append-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'create:)
(let ((x (create-flag value)))
(if x
(begin
(macro-psettings-create-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'truncate:)
(let ((x (truncate-flag value)))
(if x
(begin
(macro-psettings-truncate-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'permissions:)
(let ((x (permissions value)))
(if x
(begin
(macro-psettings-permissions-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'output-width:)
(let ((x (output-width value)))
(if x
(begin
(macro-psettings-output-width-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'stdin-redirection:)
(let ((x (stdin-redir value)))
(if x
(begin
(macro-psettings-stdin-redir-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'stdout-redirection:)
(let ((x (stdout-redir value)))
(if x
(begin
(macro-psettings-stdout-redir-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'stderr-redirection:)
(let ((x (stderr-redir value)))
(if x
(begin
(macro-psettings-stderr-redir-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'pseudo-terminal:)
(let ((x (pseudo-term value)))
(if x
(begin
(macro-psettings-pseudo-term-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'show-console:)
(let ((x (show-console value)))
(if x
(begin
(macro-psettings-show-console-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'server-address:)
(cond ((##string? value)
(let ((address-and-port-number
(##string->address-and-port-number
value
(macro-default-server-address)
#f)))
(if address-and-port-number
(let ((address
(##car
address-and-port-number))
(port-number
(##cdr
address-and-port-number)))
(macro-psettings-server-address-set!
psettings
address)
(if port-number
(macro-psettings-port-number-set!
psettings
port-number))
(loop rest2))
(error name))))
((##ip-address? value)
(macro-psettings-server-address-set!
psettings
value)
(loop rest2))
(else
(error name))))
((##eq? name 'port-number:)
(let ((x (port-number value)))
(if x
(begin
(macro-psettings-port-number-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'socket-type:)
(let ((x (socket-type value)))
(if x
(begin
(macro-psettings-socket-type-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'coalesce:)
(let ((x (coalesce value)))
(if x
(begin
(macro-psettings-coalesce-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'keep-alive:)
(let ((x (keep-alive value)))
(if x
(begin
(macro-psettings-keep-alive-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'backlog:)
(let ((x (backlog value)))
(if x
(begin
(macro-psettings-backlog-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'reuse-address:)
(let ((x (reuse-address value)))
(if x
(begin
(macro-psettings-reuse-address-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'broadcast:)
(let ((x (broadcast value)))
(if x
(begin
(macro-psettings-broadcast-set!
psettings
x)
(loop rest2))
(error name))))
((##eq? name 'ignore-hidden:)
(let ((x (ignore-hidden value)))
(if x
(begin
(macro-psettings-ignore-hidden-set!
psettings
x)
(loop rest2))
(error name))))
(else
(error name)))))
(error name)))))
((##null? lst)
(succeed psettings))
(else
(error-improper-list))))))
(##define-macro (macro-stream-options-output-shift) 32768)
(define-prim (##psettings->roptions psettings default-options)
(##psettings-options->options
(macro-psettings-roptions psettings)
(##fixnum.modulo default-options (macro-stream-options-output-shift))))
(define-prim (##psettings->woptions psettings default-options)
(##psettings-options->options
(macro-psettings-woptions psettings)
(##fixnum.quotient default-options (macro-stream-options-output-shift))))
(define-prim (##psettings->input-readtable psettings)
(or (macro-psettings-options-readtable
(macro-psettings-roptions psettings))
(##current-readtable)))
(define-prim (##psettings->output-readtable psettings)
(or (macro-psettings-options-readtable
(macro-psettings-woptions psettings))
(##current-readtable)))
(define-prim (##psettings-options->options options default-options)
(let ((permanent-close
(macro-psettings-options-permanent-close options))
(buffering
(macro-psettings-options-buffering options))
(eol-encoding
(macro-psettings-options-eol-encoding options))
(char-encoding
(macro-psettings-options-char-encoding options))
(char-encoding-errors
(macro-psettings-options-char-encoding-errors options)))
(##fixnum.+
(##fixnum.+
(##fixnum.* (macro-char-encoding-shift)
(if (##fixnum.= char-encoding (macro-default-char-encoding))
(##fixnum.modulo
(##fixnum.quotient default-options
(macro-char-encoding-shift))
(macro-char-encoding-range))
char-encoding))
(##fixnum.* (macro-char-encoding-errors-shift)
(if (##fixnum.= char-encoding-errors (macro-default-char-encoding-errors))
(##fixnum.modulo
(##fixnum.quotient default-options
(macro-char-encoding-errors-shift))
(macro-char-encoding-errors-range))
char-encoding-errors))
(##fixnum.+
(##fixnum.+
(##fixnum.* (macro-eol-encoding-shift)
(if (##fixnum.= eol-encoding (macro-default-eol-encoding))
(##fixnum.modulo
(##fixnum.quotient default-options
(macro-eol-encoding-shift))
(macro-eol-encoding-range))
eol-encoding))
(##fixnum.+
(##fixnum.* (macro-open-state-shift)
(##fixnum.modulo
(##fixnum.quotient default-options
(macro-open-state-shift))
(macro-open-state-range)))
(##fixnum.+
(##fixnum.* (macro-permanent-close-shift)
permanent-close)
(##fixnum.* (macro-buffering-shift)
(if (##fixnum.= buffering (macro-default-buffering))
(##fixnum.modulo
(##fixnum.quotient default-options
(macro-buffering-shift))
(macro-buffering-range))
buffering))))))))))
(define-prim (##psettings->device-flags psettings)
(let ((direction
(macro-psettings-direction psettings))
(append
(macro-psettings-append psettings))
(create
(macro-psettings-create psettings))
(truncate
(macro-psettings-truncate psettings)))
(##fixnum.+
(##fixnum.* (macro-direction-shift)
direction)
(##fixnum.+
(##fixnum.* (macro-append-shift)
(if (##not (##fixnum.= append (macro-default-append)))
append
(macro-no-append)))
(##fixnum.+
(##fixnum.* (macro-create-shift)
(cond ((##not (##fixnum.= create (macro-default-create)))
create)
((##fixnum.= direction (macro-direction-out))
(macro-maybe-create))
(else
(macro-no-create))))
(##fixnum.* (macro-truncate-shift)
(cond ((##not (##fixnum.= truncate (macro-default-truncate)))
truncate)
((##fixnum.= direction (macro-direction-out))
(if (##fixnum.= append (macro-append))
(macro-no-truncate)
(macro-truncate)))
(else
(macro-no-truncate)))))))))
(define-prim (##psettings->permissions psettings default-permissions)
(let ((permissions (macro-psettings-permissions psettings)))
(if (##not (##fixnum.= permissions (macro-default-permissions)))
permissions
default-permissions)))
(define-prim (##psettings->output-width psettings)
(let ((output-width (macro-psettings-output-width psettings)))
(if (##not (##fixnum.= output-width (macro-default-output-width)))
output-width
80)))
;;;----------------------------------------------------------------------------
;;; Implementation of port type checking.
(define-prim (##port? obj)
(macro-port? obj))
(define-prim (port? obj)
(macro-force-vars (obj)
(macro-port? obj)))
(define-prim (##input-port? obj)
(macro-input-port? obj))
(define-prim (input-port? obj)
(macro-force-vars (obj)
(macro-input-port? obj)))
(define-prim (##output-port? obj)
(macro-output-port? obj))
(define-prim (output-port? obj)
(macro-force-vars (obj)
(macro-output-port? obj)))
(implement-check-type-port)
(define-fail-check-type input-port 'input-port)
(define-fail-check-type output-port 'output-port)
(define-fail-check-type character-input-port 'character-input-port)
(define-fail-check-type character-output-port 'character-output-port)
(define-fail-check-type byte-port 'byte-port)
(define-fail-check-type byte-input-port 'byte-input-port)
(define-fail-check-type byte-output-port 'byte-output-port)
(define-fail-check-type device-input-port 'device-input-port)
(define-fail-check-type device-output-port 'device-output-port)
;;;----------------------------------------------------------------------------
;;; I/O condition variables.
(define-prim (##make-io-condvar name for-writing?)
(let ((cv (##make-condvar name)))
(macro-btq-owner-set! cv (if for-writing? 2 0))
cv))
(define-prim (##io-condvar? cv)
(##fixnum? (macro-btq-owner cv)))
(define-prim (##io-condvar-for-writing? cv)
(##not (##fixnum.= 0 (##fixnum.bitwise-and 2 (macro-btq-owner cv)))))
(define-prim (##io-condvar-port cv)
(macro-condvar-specific cv))
(define-prim (##io-condvar-port-set! cv port)
(macro-condvar-specific-set! cv port))
;;;----------------------------------------------------------------------------
;;; Implementation of dummy ports.
(define-prim (##make-dummy-port)
(let* ((mutex
#f)
(rkind
(macro-object-kind))
(wkind
(macro-object-kind))
(roptions
0)
(rtimeout
#t)
(rtimeout-thunk
#f)
(woptions
0)
(wtimeout
#t)
(wtimeout-thunk
#f))
(define (name port)
'dummy)
(define (read-datum port re)
#!eof)
(define (write-datum port obj we)
(##void))
(define (newline port)
(##void))
(define (force-output port level prim arg1 arg2 arg3 arg4)
(##void))
(define (close port prim arg1)
(##void))
(define (set-rtimeout port timeout thunk)
(##void))
(define (set-wtimeout port timeout thunk)
(##void))
(macro-make-port
mutex
rkind
wkind
name
read-datum
write-datum
newline
force-output
close
roptions
rtimeout
rtimeout-thunk
set-rtimeout
woptions
wtimeout
wtimeout-thunk
set-wtimeout)))
(define (open-dummy)
(##make-dummy-port))
;;;----------------------------------------------------------------------------
;;; Implementation of device ports.
(define-prim (##make-device-port device-name rdevice wdevice psettings)
(define char-buf-len 512) ;; character buffer length
(define byte-buf-len 1024) ;; byte buffer length
(let* ((mutex
(macro-make-port-mutex))
(rkind
(if rdevice
(##os-device-kind rdevice)
(macro-none-kind)))
(wkind
(if wdevice
(##os-device-kind wdevice)
(macro-none-kind)))
(roptions
(if (##fixnum.= rkind (macro-none-kind))
0
(##psettings->roptions
psettings
(##os-device-stream-default-options rdevice))))
(rtimeout
#t)
(rtimeout-thunk
#f)
(woptions
(if (##fixnum.= wkind (macro-none-kind))
0
(##psettings->woptions
psettings
(##os-device-stream-default-options wdevice))))
(wtimeout
#t)
(wtimeout-thunk
#f)
(char-rbuf
(and (##not (##fixnum.= rkind (macro-none-kind)))
(##make-string (if (macro-unbuffered? roptions)
1
char-buf-len))))
(char-rlo
0)
(char-rhi
0)
(char-rchars
0)
(char-rlines
0)
(char-rcurline
0)
(char-rbuf-fill
##char-rbuf-fill)
(char-peek-eof?
#f)
(char-wbuf
(and (##not (##fixnum.= wkind (macro-none-kind)))
(##make-string (if (macro-unbuffered? woptions)
1
char-buf-len))))
(char-wlo
0)
(char-whi
0)
(char-wchars
0)
(char-wlines
0)
(char-wcurline
0)
(char-wbuf-drain
##char-wbuf-drain)
(input-readtable
(##psettings->input-readtable psettings))
(output-readtable
(##psettings->output-readtable psettings))
(byte-rbuf
(and (##not (##fixnum.= rkind (macro-none-kind)))
(##make-u8vector byte-buf-len)))
(byte-rlo
0)
(byte-rhi
0)
(byte-rbuf-fill
##byte-rbuf-fill)
(byte-wbuf
(and (##not (##fixnum.= wkind (macro-none-kind)))
(##make-u8vector byte-buf-len)))
(byte-wlo
0)
(byte-whi
0)
(byte-wbuf-drain
##byte-wbuf-drain)
(rdevice-condvar
(and (##not (##fixnum.= rkind (macro-none-kind)))
(##make-rdevice-condvar rdevice)))
(wdevice-condvar
(and (##not (##fixnum.= wkind (macro-none-kind)))
(##make-wdevice-condvar wdevice))))
(define (name port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-device-port-name port))
(define (read-datum port re)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##read-datum-or-eof re))
(define (write-datum port obj we)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##wr we obj))
(define (newline port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##write-char #\newline port))
(define (force-output port level prim arg1 arg2 arg3 arg4)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let ((code (force-output-aux port level #t)))
(macro-port-mutex-unlock! port)
(if (##fixnum.< code 0)
(##raise-os-exception #f code prim arg1 arg2 arg3 arg4)
(##void))))
(define (force-output-aux port level block?)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let ((code1 (drain-output port)))
(if (##fixnum? code1)
code1
(let* ((wdevice-condvar (macro-device-port-wdevice-condvar port))
(wdevice (macro-condvar-name wdevice-condvar))
(code2 (##os-device-force-output wdevice level)))
(cond ((##fixnum.= code2 ##err-code-EINTR)
;; the force was interrupted, so try again
(force-output-aux port level block?))
((and block?
(##fixnum.= code2 ##err-code-EAGAIN))
;; the force would block, so wait and then try again
(macro-port-mutex-unlock! port)
(let ((continue?
(or (##wait-for-io!
(macro-device-port-wdevice-condvar port)
(macro-port-wtimeout port))
((macro-port-wtimeout-thunk port)))))
(macro-port-mutex-lock! port) ;; regain access to port
(if continue?
(force-output-aux port level block?)
code2)))
(else
code2))))))
(define (drain-output port)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let ((code ((macro-character-port-wbuf-drain port) port)))
(if (##fixnum? code)
code
((macro-byte-port-wbuf-drain port) port))))
(define (close port prim arg1)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let ((result (close-aux1 port prim)))
(macro-port-mutex-unlock! port)
(if (##fixnum? result)
(##raise-os-exception #f result prim arg1)
result)))
(define (close-aux1 port prim)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(if (or (##fixnum.= (macro-port-wkind port) (macro-none-kind))
(##eq? prim close-input-port))
(close-aux2 port prim)
(let ((code (force-output-aux port 0 #f)))
(if (and (##fixnum.< code 0)
(##not (##fixnum.= code ##err-code-EAGAIN)))
code
;; The close operation may have failed to force the output.
;; However the close operation is not allowed to block, so
;; we just continue and close the device. The user can make
;; sure that the output is forced by calling force-output
;; (which can block) before calling close-port.
(close-aux2 port prim)))))
(define (close-aux2 port prim)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(##close-device
port
(macro-device-port-rdevice-condvar port)
(macro-device-port-wdevice-condvar port)
prim))
(define (set-rtimeout port timeout thunk)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(macro-port-rtimeout-set! port timeout)
(macro-port-rtimeout-thunk-set! port thunk)
(##condvar-signal-no-reschedule!
(macro-device-port-rdevice-condvar port)
#t)
(macro-port-mutex-unlock! port)
(##void))
(define (set-wtimeout port timeout thunk)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(macro-port-wtimeout-set! port timeout)
(macro-port-wtimeout-thunk-set! port thunk)
(##condvar-signal-no-reschedule!
(macro-device-port-wdevice-condvar port)
#t)
(macro-port-mutex-unlock! port)
(##void))
(define (output-width port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let* ((wdevice-condvar (macro-device-port-wdevice-condvar port))
(wdevice (macro-condvar-name wdevice-condvar))
(result (##os-device-stream-width wdevice)))
(macro-port-mutex-unlock! port)
(if (##fixnum.< result 0)
(##raise-os-exception #f result output-port-width port)
result)))
(let ((port
(macro-make-device-port
mutex
rkind
wkind
name
read-datum
write-datum
newline
force-output
close
roptions
rtimeout
rtimeout-thunk
set-rtimeout
woptions
wtimeout
wtimeout-thunk
set-wtimeout
char-rbuf
char-rlo
char-rhi
char-rchars
char-rlines
char-rcurline
char-rbuf-fill
char-peek-eof?
char-wbuf
char-wlo
char-whi
char-wchars
char-wlines
char-wcurline
char-wbuf-drain
input-readtable
output-readtable
output-width
byte-rbuf
byte-rlo
byte-rhi
byte-rbuf-fill
byte-wbuf
byte-wlo
byte-whi
byte-wbuf-drain
rdevice-condvar
wdevice-condvar
device-name)))
(if rdevice-condvar
(##io-condvar-port-set! rdevice-condvar port))
(if wdevice-condvar
(##io-condvar-port-set! wdevice-condvar port))
port)))
(define-prim (##make-rdevice-condvar rdevice)
(##make-io-condvar rdevice #f))
(define-prim (##make-wdevice-condvar wdevice)
(##make-io-condvar wdevice #t))
(define-prim (##make-device-port-from-single-device
device-name
device
psettings)
(let ((direction (macro-psettings-direction psettings)))
(cond ((##fixnum.= direction (macro-direction-in))
(##make-device-port device-name
device
#f
psettings))
((##fixnum.= direction (macro-direction-out))
(##make-device-port device-name
#f
device
psettings))
(else
(##make-device-port device-name
device
device
psettings)))))
(define-prim (##close-device port rdevice-condvar wdevice-condvar prim)
(##declare (not interrupts-enabled))
(let ((rdevice
(if (##fixnum.= (macro-port-rkind port) (macro-none-kind))
#f
(macro-condvar-name rdevice-condvar)))
(wdevice
(if (##fixnum.= (macro-port-wkind port) (macro-none-kind))
#f
(macro-condvar-name wdevice-condvar))))
(if (and (##eq? rdevice wdevice)
(##eq? prim close-port))
(let ((code1
(##os-device-close rdevice (macro-direction-inout))))
(if (##fixnum.< code1 0)
code1
(##void)))
(let ((code2
(if (and rdevice
(##not (##eq? prim close-output-port)))
(##os-device-close rdevice (macro-direction-in))
0)))
(if (##fixnum.< code2 0)
code2
(let ((code3
(if (and wdevice
(##not (##eq? prim close-input-port)))
(##os-device-close wdevice (macro-direction-out))
0)))
(if (##fixnum.< code3 0)
code3
(##void))))))))
(define-prim (##input-port-byte-position
port
#!optional
(position (macro-absent-obj))
(whence (macro-absent-obj)))
(let loop ()
(let ((result
(if (##eq? position (macro-absent-obj))
(##os-device-stream-seek
(macro-condvar-name (macro-device-port-rdevice-condvar port))
0
1)
(begin
(##flush-input-buffering port)
(##os-device-stream-seek
(macro-condvar-name (macro-device-port-rdevice-condvar port))
position
(if (##eq? whence (macro-absent-obj)) 0 whence))))))
(if (and (##fixnum? result)
(##fixnum.< result 0))
(if (or (##fixnum.= result ##err-code-EINTR)
(##fixnum.= result ##err-code-EAGAIN))
(loop)
(##raise-os-exception
#f
result
input-port-byte-position
port
position
whence))
result))))
(define-prim (input-port-byte-position
port
#!optional
(position (macro-absent-obj))
(whence (macro-absent-obj)))
(macro-force-vars (port position whence)
(macro-check-device-input-port
port
1
(input-port-byte-position port position whence)
(cond ((##eq? position (macro-absent-obj))
(##input-port-byte-position port))
((##not (macro-exact-int? position))
(##fail-check-exact-integer 2 input-port-byte-position port position whence))
((##eq? whence (macro-absent-obj))
(##input-port-byte-position port position))
(else
(macro-check-index-range-incl
whence
3
0
2
(input-port-byte-position port position whence)
(##input-port-byte-position port position whence)))))))
(define-prim (##output-port-byte-position
port
#!optional
(position (macro-absent-obj))
(whence (macro-absent-obj)))
(let loop ()
(let ((result
(if (##eq? position (macro-absent-obj))
(##os-device-stream-seek
(macro-condvar-name (macro-device-port-wdevice-condvar port))
0
1)
(begin
(##force-output port)
(##os-device-stream-seek
(macro-condvar-name (macro-device-port-wdevice-condvar port))
position
(if (##eq? whence (macro-absent-obj)) 0 whence))))))
(if (and (##fixnum? result)
(##fixnum.< result 0))
(if (or (##fixnum.= result ##err-code-EINTR)
(##fixnum.= result ##err-code-EAGAIN))
(loop)
(##raise-os-exception
#f
result
output-port-byte-position
port
position
whence))
result))))
(define-prim (output-port-byte-position
port
#!optional
(position (macro-absent-obj))
(whence (macro-absent-obj)))
(macro-force-vars (port position whence)
(macro-check-device-output-port
port
1
(output-port-byte-position port position whence)
(cond ((##eq? position (macro-absent-obj))
(##output-port-byte-position port))
((##not (macro-exact-int? position))
(##fail-check-exact-integer 2 output-port-byte-position port position whence))
((##eq? whence (macro-absent-obj))
(##output-port-byte-position port position))
(else
(macro-check-index-range-incl
whence
3
0
2
(output-port-byte-position port position whence)
(##output-port-byte-position port position whence)))))))
(define-prim (##device-port-wait-for-input! port)
;; TODO: generalize this to all other types of ports.
;; The thread will wait until there is data available to read on the
;; port's device or the port's timeout is reached. The value #f is
;; returned when the timeout is reached. The value #t is returned
;; when there is data available to read on the port's device or the
;; thread was interrupted (for example with thread-interrupt!).
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##wait-for-io!
(macro-device-port-rdevice-condvar port)
(macro-port-rtimeout port)))
;;;----------------------------------------------------------------------------
(define-prim (##char-rbuf-fill port want block?)
;; port is the character input-port
;; want is the number of characters that the caller wants (#f = max)
;; block? is a boolean indicating whether it is OK for the thread to block
;; This procedure returns one of the following values:
;; - #t if characters were added to the char buffer,
;; - #f if no character could be added to the char buffer (because
;; end-of-file was reached),
;; - fixnum indicating an error code (in particular, only if block?
;; is false or there was a read timeout and the timeout thunk
;; returned #f, ##err-code-EAGAIN is returned to indicate that no
;; character was currently available).
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let loop ()
;; keep track of number of characters read
(macro-character-port-rchars-set!
port
(##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rhi port)))
(macro-character-port-rlo-set! port 0)
(macro-character-port-rhi-set! port 0)
;; convert bytes from the byte buffer into characters in the char buffer
(let* ((want
(if (macro-unbuffered? (macro-port-roptions port))
want
#f))
(code1
(##os-port-decode-chars! port want #f)))
(cond ((##not (##fixnum.= code1 0))
;; an error occurred, return the error code to caller
code1)
((##fixnum.< (macro-character-port-rlo port)
(macro-character-port-rhi port))
;; characters were added to char buffer
#t)
(else
;; no characters were added to char buffer, so try to get
;; some more bytes
(let ((code2 ((macro-byte-port-rbuf-fill port)
port
want ;; assumes chars are at least 1 byte long
block?)))
(cond ((##fixnum? code2)
;; an error occurred, return the error code to caller
code2)
(code2
;; bytes were added to byte buffer, so try again
;; to extract characters from the byte buffer
(loop))
(else
;; no bytes were added to byte buffer
;; (end-of-file was reached)
;; The following call to ##os-port-decode-chars! will
;; check that the byte buffer is empty. If the
;; buffer is not empty an error code is returned
;; to indicate that the remaining bytes can't
;; form a character, otherwise #f is returned.
(let ((code3 (##os-port-decode-chars! port want #t)))
(if (##fixnum.= code3 0)
#f
code3))))))))))
(define-prim (##byte-rbuf-fill port want block?)
;; port is the byte input-port
;; want is the number of bytes that the caller wants (#f = max)
;; block? is a boolean indicating whether it is OK for the thread to block
;; This procedure returns one of the following values:
;; - #t if bytes were added to the byte buffer,
;; - #f if no byte could be added to the byte buffer (because
;; end-of-file was reached),
;; - fixnum indicating an error code (in particular, only if block?
;; is false or there was a read timeout and the timeout thunk
;; returned #f, ##err-code-EAGAIN is returned to indicate that no
;; byte was currently available).
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let loop ()
;; shift bytes between rlo and rhi to beginning of buffer
(let ((byte-rlo (macro-byte-port-rlo port))
(byte-rhi (macro-byte-port-rhi port)))
(if (##fixnum.< byte-rlo byte-rhi)
(let ((byte-rbuf (macro-byte-port-rbuf port)))
(##subu8vector-move! byte-rbuf byte-rlo byte-rhi byte-rbuf 0)))
(macro-byte-port-rlo-set! port 0)
(macro-byte-port-rhi-set! port (##fixnum.- byte-rhi byte-rlo)))
;; read into byte buffer at rhi
(let* ((byte-rbuf
(macro-byte-port-rbuf port))
(byte-rhi
(macro-byte-port-rhi port))
(n
(##os-device-stream-read
(macro-condvar-name (macro-device-port-rdevice-condvar port))
byte-rbuf
byte-rhi
(let ((rbuf-len (##u8vector-length byte-rbuf)))
(if (and want (macro-unbuffered? (macro-port-roptions port)))
(##fixnum.min (##fixnum.+ byte-rhi want) rbuf-len)
rbuf-len)))))
(if (##fixnum.< n 0)
;; the read caused an error
(cond ((##fixnum.= n ##err-code-EINTR)
;; the read was interrupted, so try again
(loop))
((and block?
(##fixnum.= n ##err-code-EAGAIN))
;; the read would block and it is OK to block so wait
;; and then try again
(macro-port-mutex-unlock! port)
(let ((continue?
(or (##wait-for-io!
(macro-device-port-rdevice-condvar port)
(macro-port-rtimeout port))
((macro-port-rtimeout-thunk port)))))
(macro-port-mutex-lock! port) ;; regain access to port
(if continue?
(loop)
n)))
(else
;; return the error code to the caller
n))
;; the read completed successfully
(if (##fixnum.= n 0) ;; was end-of-file reached?
#f
(begin
(macro-byte-port-rhi-set! port
(##fixnum.+ (macro-byte-port-rhi port) n))
#t))))))
(define-prim (##char-wbuf-drain-no-reset port)
;; This procedure returns #f when the char buffer was successfully
;; drained or it returns an error code (fixnum). In particular,
;; only if there was a write timeout and the timeout thunk returned
;; #f, ##err-code-EAGAIN is returned to indicate that some chars
;; could not be written at this time.
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let loop ()
;; convert characters from char buffer into bytes in the byte buffer
(let ((code1 (##os-port-encode-chars! port)))
(cond ((##not (##fixnum.= code1 0))
;; an error occurred, return the error code to caller
code1)
((##fixnum.< (macro-character-port-wlo port)
(macro-character-port-whi port))
;; the byte buffer is full, so drain it and continue
;; draining char buffer
(let ((code2 ((macro-byte-port-wbuf-drain port) port)))
(if (##fixnum? code2)
;; an error occurred, return the error code to caller
code2
;; the byte buffer was successfully drained, continue
;; draining char buffer
(loop))))
(else
;; the char buffer has been emptied
#f)))))
(define-prim (##char-wbuf-drain port)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(or (##char-wbuf-drain-no-reset port)
(begin
(macro-character-port-wchars-set!
port
(##fixnum.+ (macro-character-port-wchars port)
(macro-character-port-whi port)))
(macro-character-port-wlo-set! port 0)
(macro-character-port-whi-set! port 0)
#f)))
(define-prim (##byte-wbuf-drain-no-reset port)
;; This procedure returns #f when the byte buffer was successfully
;; drained or it returns an error code (fixnum). In particular,
;; only if there was a write timeout and the timeout thunk returned
;; #f, ##err-code-EAGAIN is returned to indicate that no byte could
;; be written at this time.
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let loop ()
(let ((byte-wlo (macro-byte-port-wlo port))
(byte-whi (macro-byte-port-whi port)))
(if (##fixnum.< byte-wlo byte-whi)
;; the byte buffer is not empty, write content of byte buffer
;; from wlo to whi
(let ((n
(##os-device-stream-write
(macro-condvar-name (macro-device-port-wdevice-condvar port))
(macro-byte-port-wbuf port)
byte-wlo
byte-whi)))
(if (##fixnum.< n 0)
;; the write caused an error
(cond ((##fixnum.= n ##err-code-EINTR)
;; the write was interrupted, so try again
(loop))
((##fixnum.= n ##err-code-EAGAIN)
;; the write would block, so wait and then try again
(macro-port-mutex-unlock! port)
(let ((continue?
(or (##wait-for-io!
(macro-device-port-wdevice-condvar port)
(macro-port-wtimeout port))
((macro-port-wtimeout-thunk port)))))
(macro-port-mutex-lock! port) ;; regain access to port
(if continue?
(loop)
n)))
(else
;; return the error code to the caller
n))
;; some bytes (possibly zero) were written, advance
;; wlo and try to write more
(begin
(macro-byte-port-wlo-set! port
(##fixnum.+ (macro-byte-port-wlo port) n))
(loop))))
;; the byte buffer is empty
#f))))
(define-prim (##byte-wbuf-drain port)
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(or (##byte-wbuf-drain-no-reset port)
(begin
;; the byte buffer is empty, reset wlo and whi
(macro-byte-port-wlo-set! port 0)
(macro-byte-port-whi-set! port 0)
#f)))
;;;----------------------------------------------------------------------------
;;; Implementation of vector, string and u8vector ports.
(##define-macro (define-prim-vector-port-procedures
name
empty-vect
vect-zap!
drain-output
allowed-settings)
(define (sym . lst)
(string->symbol
(apply string-append
(map (lambda (s) (if (symbol? s) (symbol->string s) s))
lst))))
(let ((vector/character/byte
(cond ((eq? name 'u8vector) 'byte)
((eq? name 'string) 'character)
(else 'vector))))
(define vect-input-port
(sym name '-input-port))
(define vect-output-port
(sym name '-output-port))
(define vect-or-settings
(sym name '-or-settings))
(define macro-check-vect-output-port
(sym 'macro-check- name '-output-port))
(define ##fail-check-vect-or-settings
(sym '##fail-check- name '-or-settings))
(define ##fail-check-vect (sym '##fail-check- name))
(define ##make-vect (sym '##make- name))
(define ##vect? (sym "##" name '?))
(define ##vect-ref (sym "##" name '-ref))
(define ##vect-set! (sym "##" name '-set!))
(define ##vect-length (sym "##" name '-length))
(define ##vect-shrink! (sym "##" name '-shrink!))
(define ##subvect (sym '##sub name))
(define ##subvect-move! (sym '##sub name '-move!))
(define ##subvect->fifo (sym '##sub name '->fifo))
(define ##fifo->vect (sym '##fifo-> name))
(define ##open-vect-generic (sym '##open- name '-generic))
(define ##open-vect-pipe-generic (sym '##open- name '-pipe-generic))
(define ##open-input-vect (sym '##open-input- name))
(define ##open-output-vect (sym '##open-output- name))
(define ##open-vect (sym '##open- name))
(define ##open-vect-pipe (sym '##open- name '-pipe))
(define ##make-vect-port (sym '##make- name '-port))
(define ##make-vect-pipe-port (sym '##make- name '-pipe-port))
(define ##get-output-vect (sym '##get-output- name))
(define open-vect (sym 'open- name))
(define open-vect-pipe (sym 'open- name '-pipe))
(define open-input-vect (sym 'open-input- name))
(define open-output-vect (sym 'open-output- name))
(define get-output-vect (sym 'get-output- name))
(define call-with-input-vect (sym 'call-with-input- name))
(define call-with-output-vect (sym 'call-with-output- name))
(define with-input-from-vect (sym 'with-input-from- name))
(define with-output-to-vect (sym 'with-output-to- name))
(define define-vect-port-methods
(sym 'define- name '-port-methods))
(define macro-vect-port-rbuf
(sym 'macro- vector/character/byte '-port-rbuf))
(define macro-vect-port-rbuf-set!
(sym 'macro- vector/character/byte '-port-rbuf-set!))
(define macro-vect-port-rlo
(sym 'macro- vector/character/byte '-port-rlo))
(define macro-vect-port-rlo-set!
(sym 'macro- vector/character/byte '-port-rlo-set!))
(define macro-vect-port-rhi
(sym 'macro- vector/character/byte '-port-rhi))
(define macro-vect-port-rhi-set!
(sym 'macro- vector/character/byte '-port-rhi-set!))
(define macro-vect-port-rbuf-fill
(sym 'macro- vector/character/byte '-port-rbuf-fill))
(define macro-vect-port-rbuf-fill-set!
(sym 'macro- vector/character/byte '-port-rbuf-fill-set!))
(define macro-vect-port-wbuf
(sym 'macro- vector/character/byte '-port-wbuf))
(define macro-vect-port-wbuf-set!
(sym 'macro- vector/character/byte '-port-wbuf-set!))
(define macro-vect-port-wlo
(sym 'macro- vector/character/byte '-port-wlo))
(define macro-vect-port-wlo-set!
(sym 'macro- vector/character/byte '-port-wlo-set!))
(define macro-vect-port-whi
(sym 'macro- vector/character/byte '-port-whi))
(define macro-vect-port-whi-set!
(sym 'macro- vector/character/byte '-port-whi-set!))
(define macro-vect-port-wbuf-drain
(sym 'macro- vector/character/byte '-port-wbuf-drain))
(define macro-vect-port-wbuf-drain-set!
(sym 'macro- vector/character/byte '-port-wbuf-drain-set!))
(define macro-vect-port-peer
(sym 'macro- name '-port-peer))
(define macro-vect-port-peer-set!
(sym 'macro- name '-port-peer-set!))
(define macro-vect-port-fifo
(sym 'macro- name '-port-fifo))
(define macro-vect-port-fifo-set!
(sym 'macro- name '-port-fifo-set!))
(define macro-vect-port-rcondvar
(sym 'macro- name '-port-rcondvar))
(define macro-vect-port-rcondvar-set!
(sym 'macro- name '-port-rcondvar-set!))
(define macro-vect-port-wcondvar
(sym 'macro- name '-port-wcondvar))
(define macro-vect-port-wcondvar-set!
(sym 'macro- name '-port-wcondvar-set!))
(define macro-vect-port-buffering-limit
(sym 'macro- name '-port-buffering-limit))
(define macro-vect-port-buffering-limit-set!
(sym 'macro- name '-port-buffering-limit-set!))
(define vect-rbuf-fill
(sym name '-rbuf-fill))
(define vect-wbuf-drain
(sym name '-wbuf-drain))
`(begin
(define-fail-check-type ,vect-input-port ',vect-input-port)
(define-fail-check-type ,vect-output-port ',vect-output-port)
(define-fail-check-type ,vect-or-settings ',vect-or-settings)
(##define-macro (,define-vect-port-methods)
`(begin
(define (,',vect-rbuf-fill port want block?)
;; port is the vector input-port
;; want is the number of elements that the caller wants (#f = max)
;; block? is a boolean indicating whether it is OK for the
;; thread to block
;; This procedure returns one of the following values:
;; - #t if something was added to the read buffer,
;; - #f if nothing could be added to the read buffer
;; (because end-of-file was reached),
;; - fixnum indicating an error code (in particular,
;; only if block? is false or there was a read timeout
;; and the timeout thunk returned #f, ##err-code-EAGAIN
;; is returned to indicate that nothing is currently
;; available to be read).
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
(let loop ()
#;
(if (##u8vector? (,',macro-vect-port-rbuf port))
(pp (##list (,',macro-vect-port-rlo port)
(,',macro-vect-port-rhi port)
(,',macro-vect-port-wlo port)
(,',macro-vect-port-whi port)
(,',macro-vect-port-rbuf port)
(,',macro-vect-port-wbuf port)
)
##stdout-port))
(let* ((peer (,',macro-vect-port-peer port))
(vect-rbuf (,',macro-vect-port-rbuf port))
(vect-wbuf (,',macro-vect-port-wbuf peer)))
(if (##not (##eq? vect-rbuf vect-wbuf))
(let ((vect-rhi (,',macro-vect-port-rhi port))
(len (,',##vect-length vect-rbuf)))
(cond ((##fixnum.< vect-rhi len)
(,',macro-vect-port-rhi-set! port len)
#t)
(else
(let ((new-vect-rbuf
(macro-fifo-advance!
(,',macro-vect-port-fifo port))))
(,',macro-vect-port-wlo-set!
port
(##fixnum.- (,',macro-vect-port-wlo port) len))
(,',macro-vect-port-rbuf-set!
port
new-vect-rbuf)
,',(if (eq? name 'string)
`(begin
;; keep track of number of characters read
(macro-character-port-rchars-set!
port
(##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rhi port))))
#f)
(,',macro-vect-port-rlo-set! port 0)
(,',macro-vect-port-rhi-set! port 0)
(##condvar-signal-no-reschedule!
(,',macro-vect-port-wcondvar peer)
#t)
(loop)))))
(let* ((vect-rhi (,',macro-vect-port-rhi port))
(vect-whi (,',macro-vect-port-whi peer)))
(cond ((##fixnum.< vect-rhi vect-whi)
(,',macro-vect-port-rhi-set! port vect-whi)
#t)
((macro-closed? (macro-port-woptions peer))
(if (##not (macro-perm-close?
(macro-port-woptions peer)))
(macro-port-woptions-set!
peer
(macro-unclose! (macro-port-woptions peer))))
#f)
(block?
(let ((continue?
(or (##mutex-signal-and-condvar-wait!
(macro-port-mutex port)
(,',macro-vect-port-rcondvar port)
(macro-port-rtimeout port))
((macro-port-rtimeout-thunk port)))))
(macro-port-mutex-lock! port)
(if continue?
(loop)
##err-code-EAGAIN)))
(else
##err-code-EAGAIN)))))))
(define (,',vect-wbuf-drain port)
;; This procedure returns #f when the write buffer was
;; successfully drained or it returns an error code
;; (fixnum). In particular, only if there was a write
;; timeout and the timeout thunk returned #f,
;; ##err-code-EAGAIN is returned to indicate that nothing
;; could be written at this time.
;; It is assumed that the thread has exclusive access to the port.
(##declare (not interrupts-enabled))
;;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
(let loop ()
(let* ((peer
(,',macro-vect-port-peer port))
(buffering-limit
(,',macro-vect-port-buffering-limit port)))
(if (and buffering-limit
(let ((unread
(##fixnum.- (,',macro-vect-port-wlo peer)
(,',macro-vect-port-rlo peer))))
(##fixnum.< buffering-limit unread)))
(let ((continue?
(or (##mutex-signal-and-condvar-wait!
(macro-port-mutex port)
(,',macro-vect-port-wcondvar port)
(macro-port-wtimeout port))
((macro-port-wtimeout-thunk port)))))
(macro-port-mutex-lock! port)
(if continue?
(loop)
##err-code-EAGAIN))
(let* ((new-vect-wbuf
(,',##make-vect chunk-size))
(vect-wbuf
(,',macro-vect-port-wbuf port))
(vect-whi
(,',macro-vect-port-whi port)))
(,',macro-vect-port-wlo-set!
peer
(##fixnum.+ (,',macro-vect-port-wlo peer) vect-whi))
,',(if (eq? name 'vector)
#f
`(macro-character-port-wchars-set!
port
(##fixnum.+
(macro-character-port-wchars port)
vect-whi)))
(,',##vect-shrink! vect-wbuf vect-whi)
(,',macro-vect-port-whi-set! port 0)
(,',macro-vect-port-wbuf-set! port new-vect-wbuf)
(macro-fifo-insert-at-tail!
(,',macro-vect-port-fifo peer)
new-vect-wbuf)
(##condvar-signal-no-reschedule!
(,',macro-vect-port-rcondvar peer)
#t)
#f)))))
(define (name port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
'(,',name))
(define (force-output port level prim arg1 arg2 arg3 arg4)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let ((peer (,',macro-vect-port-peer port)))
(##condvar-signal-no-reschedule!
(,',macro-vect-port-rcondvar peer)
#t)
,',(if drain-output
`(let ((code (,drain-output port)))
(macro-port-mutex-unlock! port)
(if (##fixnum? code)
(if (##fixnum.= code ##err-code-EAGAIN)
#f;;;;;;;;;;;this doesn't appear to be right!
(##raise-os-exception #f code prim arg1 arg2 arg3 arg4))
(##void)))
`(begin
(macro-port-mutex-unlock! port)
(##void)))))
(define (close port prim arg1)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
((macro-port-force-output port)
port
0
prim
arg1
(macro-absent-obj)
(macro-absent-obj)
(macro-absent-obj))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let ((peer (,',macro-vect-port-peer port)))
(if (##not (##eq? prim close-output-port))
(begin
(macro-port-roptions-set!
port
(macro-close! (macro-port-roptions port)))
(##condvar-signal-no-reschedule!
(,',macro-vect-port-wcondvar peer)
#t)))
(if (##not (##eq? prim close-input-port))
(begin
(macro-port-woptions-set!
port
(macro-close! (macro-port-woptions port)))
(##condvar-signal-no-reschedule!
(,',macro-vect-port-rcondvar peer)
#t)))
(macro-port-mutex-unlock! port)
(##void)))
(define (set-rtimeout port timeout thunk)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(macro-port-rtimeout-set! port timeout)
(macro-port-rtimeout-thunk-set! port thunk)
(##condvar-signal-no-reschedule!
(,',macro-vect-port-rcondvar port)
#t)
(macro-port-mutex-unlock! port)
(##void))
(define (set-wtimeout port timeout thunk)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(macro-port-wtimeout-set! port timeout)
(macro-port-wtimeout-thunk-set! port thunk)
(##condvar-signal-no-reschedule!
(,',macro-vect-port-wcondvar port)
#t)
(macro-port-mutex-unlock! port)
(##void))))
(define-prim (,##subvect->fifo vect start end chunk-size)
(let ((fifo (macro-make-fifo)))
(let loop ((lo start))
(let ((hi (##fixnum.+ lo chunk-size)))
(if (##fixnum.< hi end)
(begin
(macro-fifo-insert-at-tail! fifo (,##subvect vect lo hi))
(loop hi))
(begin
(macro-fifo-insert-at-tail! fifo (,##subvect vect lo end))
fifo))))))
(define-prim (,##fifo->vect fifo start end)
(let* ((len (##fixnum.max (##fixnum.- end start) 0))
(vect (,##make-vect len)))
(let loop ((elems (macro-fifo-next fifo))
(hi end)
(lo start)
(i 0))
(if (##fixnum.< lo hi)
(let* ((chunk
(macro-fifo-elem elems))
(chunk-len
(,##vect-length chunk))
(n
(##fixnum.min (##fixnum.- chunk-len lo)
(##fixnum.- hi lo))))
(,##subvect-move! chunk lo (##fixnum.+ lo n) vect i)
(loop (macro-fifo-next elems)
(##fixnum.- hi chunk-len)
(##fixnum.- (##fixnum.+ lo n) chunk-len)
(##fixnum.+ i n)))
vect))))
(define-prim (,##open-vect-generic
direction
cont
prim
#!optional
(init-or-settings (macro-absent-obj))
(arg2 (macro-absent-obj)))
(define (fail)
(,##fail-check-vect-or-settings 1 prim init-or-settings arg2))
(##make-psettings
direction
',allowed-settings
(cond ((##eq? init-or-settings (macro-absent-obj))
'())
((,##vect? init-or-settings)
(##list 'init: init-or-settings))
(else
init-or-settings))
fail
(lambda (psettings)
(let ((init
(or (macro-psettings-init psettings)
',empty-vect)))
(if (##not (,##vect? init))
(fail)
(cont
(,##make-vect-port
init
0
(,##vect-length init)
psettings)))))))
(define-prim (,##open-vect
#!optional
(init-or-settings (macro-absent-obj)))
(,##open-vect-generic
(macro-direction-inout)
(lambda (port) port)
,open-vect
init-or-settings))
(define-prim (,open-vect
#!optional
(init-or-settings (macro-absent-obj)))
(macro-force-vars (init-or-settings)
(,##open-vect init-or-settings)))
(define-prim (,##make-vect-pipe-port
psettings1
#!optional
(psettings2 (macro-absent-obj)))
(let* ((init1
(or (macro-psettings-init psettings1)
',empty-vect))
(port1
(,##make-vect-port
init1
0
(,##vect-length init1)
psettings1))
(port2
(if (##eq? psettings2 (macro-absent-obj))
(,##make-vect-port
',empty-vect
0
0
(let ((roptions (macro-psettings-roptions psettings1))
(woptions (macro-psettings-woptions psettings1)))
(macro-psettings-roptions-set! psettings1 woptions)
(macro-psettings-woptions-set! psettings1 roptions)
(cond ((##fixnum.= (macro-psettings-direction psettings1)
(macro-direction-in))
(macro-psettings-direction-set!
psettings1
(macro-direction-out)))
((##fixnum.= (macro-psettings-direction psettings1)
(macro-direction-out))
(macro-psettings-direction-set!
psettings1
(macro-direction-in))))
psettings1))
(let ((init2
(or (macro-psettings-init psettings2)
',empty-vect)))
(,##make-vect-port
init2
0
(,##vect-length init2)
psettings2)))))
(let ((wbuf1 (,macro-vect-port-wbuf port1))
(wbuf2 (,macro-vect-port-wbuf port2))
(whi1 (,macro-vect-port-whi port1))
(whi2 (,macro-vect-port-whi port2)))
(,macro-vect-port-wbuf-set! port1 wbuf2)
(,macro-vect-port-wbuf-set! port2 wbuf1)
(,macro-vect-port-whi-set! port1 whi2)
(,macro-vect-port-whi-set! port2 whi1)
(,macro-vect-port-peer-set! port1 port2)
(,macro-vect-port-peer-set! port2 port1))
(##values port1 port2)))
(define-prim (,##open-vect-pipe-generic
direction
cont
prim
#!optional
(init-or-settings1 (macro-absent-obj))
(init-or-settings2 (macro-absent-obj)))
(define (fail1)
(,##fail-check-vect-or-settings 1 prim init-or-settings1 init-or-settings2))
(define (fail2)
(,##fail-check-vect-or-settings 2 prim init-or-settings1 init-or-settings2))
(##make-psettings
direction
',allowed-settings
(cond ((##eq? init-or-settings1 (macro-absent-obj))
'())
((,##vect? init-or-settings1)
(##list 'init: init-or-settings1))
(else
init-or-settings1))
fail1
(lambda (psettings1)
(let ((init1
(or (macro-psettings-init psettings1)
',empty-vect)))
(if (##not (,##vect? init1))
(fail1)
(if (##eq? init-or-settings2 (macro-absent-obj))
(cont (,##make-vect-pipe-port psettings1))
(##make-psettings
direction
',allowed-settings
(cond ((,##vect? init-or-settings2)
(##list 'init: init-or-settings2))
(else
init-or-settings2))
fail2
(lambda (psettings2)
(let ((init2
(or (macro-psettings-init psettings2)
',empty-vect)))
(if (##not (,##vect? init2))
(fail2)
(cont (,##make-vect-pipe-port psettings1 psettings2))))))))))))
(define-prim (,##open-vect-pipe
#!optional
(init-or-settings1 (macro-absent-obj))
(init-or-settings2 (macro-absent-obj)))
(,##open-vect-pipe-generic
(macro-direction-inout)
(lambda (ports) ports)
,open-vect-pipe
init-or-settings1
init-or-settings2))
(define-prim (,open-vect-pipe
#!optional
(init-or-settings1 (macro-absent-obj))
(init-or-settings2 (macro-absent-obj)))
(macro-force-vars (init-or-settings1 init-or-settings2)
(,##open-vect-pipe init-or-settings1 init-or-settings2)))
(define-prim (,##open-input-vect
#!optional
(init-or-settings (macro-absent-obj)))
(,##open-vect-generic
(macro-direction-in)
(lambda (port) port)
,open-input-vect
init-or-settings))
(define-prim (,open-input-vect
#!optional
(init-or-settings (macro-absent-obj)))
(macro-force-vars (init-or-settings)
(,##open-input-vect init-or-settings)))
(define-prim (,##open-output-vect
#!optional
(init-or-settings (macro-absent-obj)))
(,##open-vect-generic
(macro-direction-out)
(lambda (port) port)
,open-output-vect
init-or-settings))
(define-prim (,open-output-vect
#!optional
(init-or-settings (macro-absent-obj)))
(macro-force-vars (init-or-settings)
(,##open-output-vect init-or-settings)))
(define-prim (,##get-output-vect port)
(##declare (not interrupts-enabled))
(let ((peer
(,macro-vect-port-peer port)))
((macro-port-force-output peer)
peer
0
,get-output-vect
port
(macro-absent-obj)
(macro-absent-obj)
(macro-absent-obj))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let* ((vect-fifo
(,macro-vect-port-fifo peer))
(result
(,##fifo->vect
vect-fifo
(,macro-vect-port-rlo peer)
(##fixnum.+ (,macro-vect-port-wlo peer)
(,macro-vect-port-whi port))))
(new-vect-buf
(macro-fifo-advance-to-tail! vect-fifo)))
;; zap the entries of the buffer to avoid leaks
,(if vect-zap!
`(let loop ((i
(if (##eq?
(,macro-vect-port-rbuf peer)
new-vect-buf)
(,macro-vect-port-rlo peer)
0)))
(if (##fixnum.< i (,macro-vect-port-whi port))
(begin
(,vect-zap! new-vect-buf i)
(loop (##fixnum.+ i 1)))))
#f)
(,macro-vect-port-rbuf-set! peer new-vect-buf)
(,macro-vect-port-rlo-set! peer 0)
(,macro-vect-port-rhi-set! peer 0)
(,macro-vect-port-wbuf-set! port new-vect-buf)
(,macro-vect-port-wlo-set! peer 0) ;;;;;;;;;;;; peer or port ?
(,macro-vect-port-whi-set! port 0)
(macro-port-mutex-unlock! port)
result)))
(define-prim (,get-output-vect port)
(macro-force-vars (port)
(,macro-check-vect-output-port
port
1
(,get-output-vect port)
(,##get-output-vect port))))
(define-prim (,call-with-input-vect init-or-settings proc)
(macro-force-vars (init-or-settings proc)
(macro-check-procedure
proc
2
(,call-with-input-vect init-or-settings proc)
(,##open-vect-generic
(macro-direction-in)
(lambda (port)
(let ((results ;; may get bound to a multiple-values object
(proc port)))
(##close-input-port port)
results))
,call-with-input-vect
init-or-settings
proc))))
(define-prim (,call-with-output-vect init-or-settings proc)
(macro-force-vars (init-or-settings proc)
(macro-check-procedure
proc
2
(,call-with-output-vect init-or-settings proc)
(,##open-vect-generic
(macro-direction-out)
(lambda (port)
(let ((results ;; may get bound to a multiple-values object
(proc port)))
(##force-output port)
(##close-output-port port)
(,##get-output-vect port)))
,call-with-output-vect
init-or-settings
proc))))
(define-prim (,with-input-from-vect init-or-settings thunk)
(macro-force-vars (init-or-settings thunk)
(macro-check-procedure
thunk
2
(,with-input-from-vect init-or-settings thunk)
(,##open-vect-generic
(macro-direction-in)
(lambda (port)
(let ((results ;; may get bound to a multiple-values object
(macro-dynamic-bind input-port port thunk)))
(##close-input-port port)
results))
,with-input-from-vect
init-or-settings
thunk))))
(define-prim (,with-output-to-vect init-or-settings thunk)
(macro-force-vars (init-or-settings thunk)
(macro-check-procedure
thunk
2
(,with-output-to-vect init-or-settings thunk)
(,##open-vect-generic
(macro-direction-out)
(lambda (port)
(let ((results ;; may get bound to a multiple-values object
(macro-dynamic-bind output-port port thunk)))
(##force-output port)
(##close-output-port port)
(,##get-output-vect port)))
,with-output-to-vect
init-or-settings
thunk)))))))
(define-prim (##vect-port-options options kind buffering)
(##psettings-options->options
options
(##fixnum.+
(##fixnum.* (macro-open-state-shift)
(if (##fixnum.= kind (macro-none-kind))
(macro-open-state-closed)
(macro-open-state-open)))
(##fixnum.* (macro-buffering-shift)
buffering))))
;;;----------------------------------------------------------------------------
;;; Implementation of vector ports.
(define-prim-vector-port-procedures
vector
#()
(lambda (vect i) (##vector-set! vect i #f))
#f
(init:
permanent-close:
direction:
input-buffering:
output-buffering:
buffering:))
(define-prim (##make-vector-port src start end psettings)
(define chunk-size 16)
(let* ((direction
(macro-psettings-direction psettings))
(len
(##fixnum.max (##fixnum.- end start) 0))
(vector-fifo
(##subvector->fifo src start end chunk-size))
(mutex
(macro-make-port-mutex))
(rkind
(if (##fixnum.= direction (macro-direction-out))
(macro-none-kind)
(macro-vector-kind)))
(wkind
(if (##fixnum.= direction (macro-direction-in))
(macro-none-kind)
(macro-vector-kind)))
(roptions
(##vect-port-options
(macro-psettings-roptions psettings)
rkind
(macro-full-buffering)))
(rtimeout
#t)
(rtimeout-thunk
#f)
(woptions
(##vect-port-options
(macro-psettings-woptions psettings)
wkind
(macro-full-buffering)))
(wtimeout
#t)
(wtimeout-thunk
#f)
(vector-rbuf
(macro-fifo-elem (macro-fifo-next vector-fifo)))
(vector-rlo
0)
(vector-rhi
(##vector-length vector-rbuf))
(vector-wbuf
(macro-fifo-elem (macro-fifo-tail vector-fifo)))
(vector-whi
(##vector-length vector-wbuf))
(vector-wlo
(##fixnum.- len vector-whi))
(vector-rcondvar
(##make-io-condvar #f #f))
(vector-wcondvar
(##make-io-condvar #f #t))
(vector-buffering-limit
#f))
(define (read-datum port re)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let loop ()
(let ((vector-rlo (macro-vector-port-rlo port))
(vector-rhi (macro-vector-port-rhi port)))
(if (##fixnum.< vector-rlo vector-rhi)
;; the next object is in the object read buffer
(let* ((vector-rbuf
(macro-vector-port-rbuf port))
(obj
(##vector-ref vector-rbuf vector-rlo)))
;; frequent simple case, just advance rlo and zap vector
;; to avoid retaining objects uselessly
(##vector-set! vector-rbuf vector-rlo #f)
(macro-vector-port-rlo-set! port (##fixnum.+ vector-rlo 1))
(macro-port-mutex-unlock! port)
obj)
;; try to get more objects into the object read
;; buffer, and try again if successful otherwise
;; signal an error or return end-of-file object
(let ((code ((macro-vector-port-rbuf-fill port)
port
1
#t)))
(cond ((##fixnum? code)
;; the conversion or read caused an error
(macro-port-mutex-unlock! port)
(if (##fixnum.= code ##err-code-EAGAIN)
#!eof ;; the read timeout thunk returned #f
(##raise-os-exception #f code read port)))
(code
;; some objects were added to object buffer
(loop))
(else
;; no objects were added to object buffer
(macro-port-mutex-unlock! port)
#!eof)))))))
(define (write-datum port obj we)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let loop ()
(let ((vector-wbuf (macro-vector-port-wbuf port))
(vector-whi+1 (##fixnum.+ (macro-vector-port-whi port) 1)))
(if (##not (##fixnum.< (##vector-length vector-wbuf) vector-whi+1))
;; there is enough space in the object write buffer, so add
;; object and increment whi
(let ()
(##vector-set! vector-wbuf (##fixnum.- vector-whi+1 1) obj)
;; advance whi
(macro-vector-port-whi-set! port vector-whi+1)
;; force output if port is set for unbuffered output
(if (macro-unbuffered? (macro-port-woptions port))
(begin
(macro-port-mutex-unlock! port)
((macro-port-force-output port)
port
0
write
obj
port
(macro-absent-obj)
(macro-absent-obj)))
(begin
(macro-port-mutex-unlock! port)
(##void))))
;; make some space in the object buffer and try again
(let ((code ((macro-vector-port-wbuf-drain port) port)))
(if (##fixnum? code)
(begin
(macro-port-mutex-unlock! port)
(if (##fixnum.= code ##err-code-EAGAIN)
#f
(##raise-os-exception #f code write obj port)))
(loop)))))))
(define (newline port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##void))
(define-vector-port-methods)
(let ((port
(macro-make-vector-port
mutex
rkind
wkind
name
read-datum
write-datum
newline
force-output
close
roptions
rtimeout
rtimeout-thunk
set-rtimeout
woptions
wtimeout
wtimeout-thunk
set-wtimeout
vector-rbuf
vector-rlo
vector-rhi
vector-rbuf-fill
vector-wbuf
vector-wlo
vector-whi
vector-wbuf-drain
#f
vector-fifo
vector-rcondvar
vector-wcondvar
vector-buffering-limit)))
(macro-vector-port-peer-set! port port)
(##io-condvar-port-set! vector-rcondvar port)
(##io-condvar-port-set! vector-wcondvar port)
port)))
;;;----------------------------------------------------------------------------
;;; Implementation of string ports.
(define-prim-vector-port-procedures
string
""
#f
#f
(output-width:
init:
permanent-close:
direction:
input-buffering:
output-buffering:
buffering:
input-readtable:
output-readtable:
readtable:))
(define-prim (##make-string-port src start end psettings)
(define chunk-size 32)
(let* ((direction
(macro-psettings-direction psettings))
(len
(##fixnum.max (##fixnum.- end start) 0))
(string-fifo
(##substring->fifo src start end chunk-size))
(mutex
(macro-make-port-mutex))
(rkind
(if (##fixnum.= direction (macro-direction-out))
(macro-none-kind)
(macro-string-kind)))
(wkind
(if (##fixnum.= direction (macro-direction-in))
(macro-none-kind)
(macro-string-kind)))
(roptions
(##vect-port-options
(macro-psettings-roptions psettings)
rkind
(macro-full-buffering)))
(rtimeout
#t)
(rtimeout-thunk
#f)
(woptions
(##vect-port-options
(macro-psettings-woptions psettings)
wkind
(macro-full-buffering)))
(wtimeout
#t)
(wtimeout-thunk
#f)
(string-rbuf
(macro-fifo-elem (macro-fifo-next string-fifo)))
(string-rlo
0)
(string-rhi
(##string-length string-rbuf))
(char-rchars
0)
(char-rlines
0)
(char-rcurline
0)
(char-peek-eof?
#f)
(string-wbuf
(macro-fifo-elem (macro-fifo-tail string-fifo)))
(string-whi
(##string-length string-wbuf))
(string-wlo
(##fixnum.- len string-whi))
(char-wchars
0)
(char-wlines
0)
(char-wcurline
0)
(input-readtable
(##psettings->input-readtable psettings))
(output-readtable
(##psettings->output-readtable psettings))
(string-rcondvar
(##make-io-condvar #f #f))
(string-wcondvar
(##make-io-condvar #f #t))
(string-width
(##psettings->output-width psettings))
(string-buffering-limit
#f))
(define (read-datum port re)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##read-datum-or-eof re))
(define (write-datum port obj we)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##wr we obj))
(define (newline port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##write-char #\newline port))
(define (output-width port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-string-port-width port))
(define-string-port-methods)
(let ((port
(macro-make-string-port
mutex
rkind
wkind
name
read-datum
write-datum
newline
force-output
close
roptions
rtimeout
rtimeout-thunk
set-rtimeout
woptions
wtimeout
wtimeout-thunk
set-wtimeout
string-rbuf
string-rlo
string-rhi
char-rchars
char-rlines
char-rcurline
string-rbuf-fill
char-peek-eof?
string-wbuf
string-wlo
string-whi
char-wchars
char-wlines
char-wcurline
string-wbuf-drain
input-readtable
output-readtable
output-width
#f
string-fifo
string-rcondvar
string-wcondvar
string-width
string-buffering-limit)))
(macro-string-port-peer-set! port port)
(##io-condvar-port-set! string-rcondvar port)
(##io-condvar-port-set! string-wcondvar port)
port)))
;;;----------------------------------------------------------------------------
;;; Implementation of u8vector ports.
(define-prim-vector-port-procedures
u8vector
#u8()
#f
(lambda (port) ((macro-character-port-wbuf-drain port) port))
(input-char-encoding:
output-char-encoding:
char-encoding:
input-char-encoding-errors:
output-char-encoding-errors:
char-encoding-errors:
input-eol-encoding:
output-eol-encoding:
eol-encoding:
output-width:
init:
permanent-close:
direction:
input-buffering:
output-buffering:
buffering:
input-readtable:
output-readtable:
readtable:))
(define-prim (##make-u8vector-port src start end psettings)
(define char-buf-len 32) ;; character buffer length
(define chunk-size 64)
;;; (define char-buf-len 3) ;; character buffer length
;;; (define chunk-size 6)
(let* ((direction
(macro-psettings-direction psettings))
(len
(##fixnum.max (##fixnum.- end start) 0))
(u8vector-fifo
(##subu8vector->fifo src start end chunk-size))
(mutex
(macro-make-port-mutex))
(rkind
(if (##fixnum.= direction (macro-direction-out))
(macro-none-kind)
(macro-u8vector-kind)))
(wkind
(if (##fixnum.= direction (macro-direction-in))
(macro-none-kind)
(macro-u8vector-kind)))
(roptions
(##vect-port-options
(macro-psettings-roptions psettings)
rkind
(macro-full-buffering)))
(rtimeout
#t)
(rtimeout-thunk
#f)
(woptions
(##vect-port-options
(macro-psettings-woptions psettings)
wkind
(macro-full-buffering)))
(wtimeout
#t)
(wtimeout-thunk
#f)
(char-rbuf
(and (##not (##fixnum.= rkind (macro-none-kind)))
(##make-string (if (macro-unbuffered? roptions)
1
char-buf-len))))
(char-rlo
0)
(char-rhi
0)
(char-rchars
0)
(char-rlines
0)
(char-rcurline
0)
(char-rbuf-fill
##char-rbuf-fill)
(char-peek-eof?
#f)
(char-wbuf
(and (##not (##fixnum.= wkind (macro-none-kind)))
(##make-string (if (macro-unbuffered? woptions)
1
char-buf-len))))
(char-wlo
0)
(char-whi
0)
(char-wchars
0)
(char-wlines
0)
(char-wcurline
0)
(char-wbuf-drain
##char-wbuf-drain)
(input-readtable
(##psettings->input-readtable psettings))
(output-readtable
(##psettings->output-readtable psettings))
#|
;;;;;;;;;;;;;;;;;;;;;;;;
(byte-rbuf
(and (##not (##fixnum.= rkind (macro-none-kind)))
(##make-u8vector byte-buf-len)))
(byte-rlo
0)
(byte-rhi
0)
(byte-rbuf-fill
##byte-rbuf-fill)
(byte-wbuf
(and (##not (##fixnum.= wkind (macro-none-kind)))
(##make-u8vector byte-buf-len)))
(byte-wlo
0)
(byte-whi
0)
(byte-wbuf-drain
##byte-wbuf-drain)
;;;;;;;;;;;;;;;;;;;;;;;;
|#
(u8vector-rbuf
(macro-fifo-elem (macro-fifo-next u8vector-fifo)))
(u8vector-rlo
0)
(u8vector-rhi
(##u8vector-length u8vector-rbuf))
(u8vector-wbuf
(macro-fifo-elem (macro-fifo-tail u8vector-fifo)))
(u8vector-whi
(##u8vector-length u8vector-wbuf))
(u8vector-wlo
(##fixnum.- len u8vector-whi))
(u8vector-rcondvar
(##make-io-condvar #f #f))
(u8vector-wcondvar
(##make-io-condvar #f #t))
(u8vector-width
(##psettings->output-width psettings))
(u8vector-buffering-limit
#f))
(define (read-datum port re)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##read-datum-or-eof re))
(define (write-datum port obj we)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##wr we obj))
(define (newline port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(##write-char #\newline port))
(define (output-width port)
;; It is assumed that the thread **does not** have exclusive
;; access to the port.
(##declare (not interrupts-enabled))
(macro-u8vector-port-width port))
(define-u8vector-port-methods)
(let ((fill u8vector-rbuf-fill)
(drain u8vector-wbuf-drain))
#;
(define (u8vector-rbuf-fill port want block?)
(pp (list 'u8vector-rbuf-fill port want block?))
(##repl)
(fill port want block?))
#;
(define (u8vector-wbuf-drain port)
(pp (list 'u8vector-wbuf-drain port))
(##repl)
(drain port))
(let ((port
(macro-make-u8vector-port
mutex
rkind
wkind
name
read-datum
write-datum
newline
force-output
close
roptions
rtimeout
rtimeout-thunk
set-rtimeout
woptions
wtimeout
wtimeout-thunk
set-wtimeout
char-rbuf
char-rlo
char-rhi
char-rchars
char-rlines
char-rcurline
char-rbuf-fill
char-peek-eof?
char-wbuf
char-wlo
char-whi
char-wchars
char-wlines
char-wcurline
char-wbuf-drain
input-readtable
output-readtable
output-width
u8vector-rbuf
u8vector-rlo
u8vector-rhi
u8vector-rbuf-fill
u8vector-wbuf
u8vector-wlo
u8vector-whi
u8vector-wbuf-drain
#f
u8vector-fifo
u8vector-rcondvar
u8vector-wcondvar
u8vector-width
u8vector-buffering-limit)))
(macro-u8vector-port-peer-set! port port)
(##io-condvar-port-set! u8vector-rcondvar port)
(##io-condvar-port-set! u8vector-wcondvar port)
port)))
)
;;;----------------------------------------------------------------------------
;;; Implementation of generic object port procedures.
(define-prim (##port-of-kind? obj kind)
(##declare (not interrupts-enabled))
(and (macro-port? obj)
(##fixnum.= (##fixnum.bitwise-and (##port-kind obj) kind) kind)))
(define-prim (##port-kind port)
(##declare (not interrupts-enabled))
(let ((rkind (macro-port-rkind port)))
(if (##fixnum.= rkind (macro-none-kind))
(macro-port-wkind port)
rkind)))
(define-prim (##port-device port)
(##declare (not interrupts-enabled))
(if (##fixnum.= (macro-port-rkind port) (macro-none-kind))
(let ((wdevice-condvar (macro-device-port-wdevice-condvar port)))
(macro-condvar-name wdevice-condvar))
(let ((rdevice-condvar (macro-device-port-rdevice-condvar port)))
(macro-condvar-name rdevice-condvar))))
(define-prim (##port-name port)
(##declare (not interrupts-enabled))
((macro-port-name port) port))
(define-prim (##read port)
(##declare (not interrupts-enabled))
(if (macro-character-input-port? port)
(let* ((noop
(lambda (re x) x)) ;; do not wrap datum
(re
(##make-readenv
port
(macro-character-port-input-readtable port)
noop
noop
#f)))
((macro-port-read-datum port) port re))
((macro-port-read-datum port) port #f)))
(define-prim (read
#!optional
(port (macro-absent-obj)))
(macro-force-vars (port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-input-port)
port)))
(macro-check-input-port p 1 (read p)
(##read p)))))
(define-prim (##write-generic-to-character-port style port rt force? limit obj)
(##declare (not interrupts-enabled))
(let* ((mt
(and (macro-readtable-sharing-allowed? rt)
(##make-marktable)))
(width
(##output-port-width port)))
(if mt
(let ((we1 (##make-writeenv 'mark port rt mt force? width 0 0 0 limit)))
((macro-port-write-datum port) port obj we1)))
(let ((we2 (##make-writeenv style port rt mt force? width 0 0 0 limit)))
((macro-port-write-datum port) port obj we2)
(##fixnum.- limit (macro-writeenv-limit we2)))))
(define-prim (##write obj port #!optional (max-length ##max-fixnum))
(if (macro-character-output-port? port)
(begin
(##write-generic-to-character-port
'write
port
(macro-character-port-output-readtable port)
(macro-if-forces #t #f)
max-length
obj)
(##void))
((macro-port-write-datum port) port obj #f)))
(define-prim (write
obj
#!optional
(port (macro-absent-obj)))
(macro-force-vars (obj port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 2 (write obj p)
(##write obj p)))))
(define-prim (##display obj port #!optional (max-length ##max-fixnum))
(if (macro-character-output-port? port)
(begin
(##write-generic-to-character-port
'display
port
(macro-character-port-output-readtable port)
(macro-if-forces #t #f)
max-length
obj)
(##void))
((macro-port-write-datum port) port obj #f)))
(define-prim (display
obj
#!optional
(port (macro-absent-obj)))
(macro-force-vars (obj port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 2 (display obj p)
(##display obj p)))))
(define-prim (##pretty-print obj port #!optional (max-length ##max-fixnum))
(if (macro-character-output-port? port)
(begin
(##write-generic-to-character-port
'pretty-print
port
(macro-character-port-output-readtable port)
(macro-if-forces #t #f)
max-length
obj)
(##newline port))
((macro-port-write-datum port) port obj #f)))
(define-prim (pretty-print
obj
#!optional
(port (macro-absent-obj)))
(macro-force-vars (obj port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 2 (pretty-print obj p)
(##pretty-print obj p)))))
(define-prim (##print-fringe obj port #!optional (max-length ##max-fixnum))
(if (macro-character-output-port? port)
(begin
(##write-generic-to-character-port
'print
port
(macro-character-port-output-readtable port)
(macro-if-forces #t #f)
max-length
obj)
(##void))
((macro-port-write-datum port) port obj #f)))
(define-prim (print
#!key (port (macro-absent-obj))
#!rest body)
(macro-force-vars (port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 2 (print port: p . body)
(##print-fringe body p)))))
(define-prim (println
#!key (port (macro-absent-obj))
#!rest body)
(macro-force-vars (port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 2 (println port: p . body)
(begin
(##print-fringe body p)
(##newline p))))))
(define-prim (##newline port)
(##declare (not interrupts-enabled))
((macro-port-newline port) port))
(define-prim (newline
#!optional
(port (macro-absent-obj)))
(macro-force-vars (port)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port p 1 (newline p)
(##newline p)))))
(define-prim (##flush-input-buffering port)
(##declare (not interrupts-enabled))
(macro-character-port-peek-eof?-set! port #f)
(macro-character-port-rlo-set! port (macro-character-port-rhi port))
(if (macro-byte-input-port? port)
(macro-byte-port-rlo-set! port (macro-byte-port-rhi port)))
(##void))
(define-prim (##force-output
port
#!optional
(level (macro-absent-obj)))
(##declare (not interrupts-enabled))
((macro-port-force-output port)
port
(if (##eq? level (macro-absent-obj)) 0 level)
force-output
port
level
(macro-absent-obj)
(macro-absent-obj)))
(define-prim (force-output
#!optional
(port (macro-absent-obj))
(level (macro-absent-obj)))
(macro-force-vars (port level)
(let ((p
(if (##eq? port (macro-absent-obj))
(macro-current-output-port)
port)))
(macro-check-output-port
p
1
(force-output p level)
(if (##eq? level (macro-absent-obj))
(##force-output p)
(macro-check-index-range-incl
level
2
0
2
(force-output p level)
(##force-output p level)))))))
(define-prim (##close-input-port port)
(##declare (not interrupts-enabled))
((macro-port-close port) port close-input-port port))
(define-prim (close-input-port port)
(macro-force-vars (port)
(macro-check-input-port port 1 (close-input-port port)
(##close-input-port port))))
(define-prim (##close-output-port port)
(##declare (not interrupts-enabled))
((macro-port-close port) port close-output-port port))
(define-prim (close-output-port port)
(macro-force-vars (port)
(macro-check-output-port port 1 (close-output-port port)
(##close-output-port port))))
(define-prim (##close-port port)
(##declare (not interrupts-enabled))
((macro-port-close port) port close-port port))
(define-prim (close-port port)
(macro-force-vars (port)
(macro-check-port port 1 (close-port port)
(##close-port port))))
(define-prim (input-port-readtable port)
(macro-force-vars (port)
(macro-check-character-input-port port 1 (input-port-readtable port)
(macro-character-port-input-readtable port))))
(define-prim (input-port-readtable-set! port rt)
(macro-force-vars (port rt)
(macro-check-character-input-port port 1 (input-port-readtable-set! port rt)
(macro-check-readtable rt 2 (input-port-readtable-set! port rt)
(begin
(macro-character-port-input-readtable-set! port rt)
(##void))))))
(define-prim (output-port-readtable port)
(macro-force-vars (port)
(macro-check-character-output-port port 1 (output-port-readtable port)
(macro-character-port-output-readtable port))))
(define-prim (output-port-readtable-set! port rt)
(macro-force-vars (port rt)
(macro-check-character-output-port port 1 (output-port-readtable-set! port rt)
(macro-check-readtable rt 2 (output-port-readtable-set! port rt)
(begin
(macro-character-port-output-readtable-set! port rt)
(##void))))))
(define-prim (##input-port-timeout-set! port absrel-timeout thunk)
(##declare (not interrupts-enabled))
(let ((timeout (##absrel-timeout->timeout absrel-timeout)))
((macro-port-set-rtimeout port) port timeout thunk)))
(define-prim (input-port-timeout-set!
port
absrel-timeout
#!optional
(t (macro-absent-obj)))
(macro-force-vars (port absrel-timeout t)
(let ((thunk
(if (##eq? t (macro-absent-obj))
(lambda () #f)
t)))
(macro-check-input-port
port
1
(input-port-timeout-set! port absrel-timeout t)
(macro-check-absrel-time-or-false
absrel-timeout
2
(input-port-timeout-set! port absrel-timeout t)
(macro-check-procedure
thunk
3
(input-port-timeout-set! port absrel-timeout t)
(##input-port-timeout-set! port absrel-timeout thunk)))))))
(define-prim (##output-port-timeout-set! port absrel-timeout thunk)
(##declare (not interrupts-enabled))
(let ((timeout (##absrel-timeout->timeout absrel-timeout)))
((macro-port-set-wtimeout port) port timeout thunk)))
(define-prim (output-port-timeout-set!
port
absrel-timeout
#!optional
(t (macro-absent-obj)))
(macro-force-vars (port absrel-timeout t)
(let ((thunk
(if (##eq? t (macro-absent-obj))
(lambda () #f)
t)))
(macro-check-output-port
port
1
(output-port-timeout-set! port absrel-timeout t)
(macro-check-absrel-time-or-false
absrel-timeout
2
(output-port-timeout-set! port absrel-timeout t)
(macro-check-procedure
thunk
3
(output-port-timeout-set! port absrel-timeout t)
(##output-port-timeout-set! port absrel-timeout thunk)))))))
(define-prim (##input-port-char-position port)
(##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rlo port)))
(define-prim (input-port-char-position port)
(macro-force-vars (port)
(macro-check-character-input-port
port
1
(input-port-char-position port)
(##input-port-char-position port))))
(define-prim (##output-port-char-position port)
(##fixnum.+ (macro-character-port-wchars port)
(macro-character-port-whi port)))
(define-prim (output-port-char-position port)
(macro-force-vars (port)
(macro-check-character-output-port
port
1
(output-port-char-position port)
(##output-port-char-position port))))
(define-prim (##input-port-line-set! port line)
(##declare (not interrupts-enabled))
(macro-character-port-rlines-set! port (##fixnum.- line 1)))
(define-prim (##input-port-line port)
(##declare (not interrupts-enabled))
(##fixnum.+ (macro-character-port-rlines port) 1))
(define-prim (input-port-line port)
(macro-force-vars (port)
(macro-check-character-input-port port 1 (input-port-line port)
(##input-port-line port))))
(define-prim (##input-port-column-set! port col)
(##declare (not interrupts-enabled))
(macro-character-port-rcurline-set!
port
(##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rlo port))
col)
1)))
(define-prim (##input-port-column port)
(##declare (not interrupts-enabled))
(##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
(macro-character-port-rlo port))
(macro-character-port-rcurline port))
1))
(define-prim (input-port-column port)
(macro-force-vars (port)
(macro-check-character-input-port port 1 (input-port-column port)
(##input-port-column port))))
(define-prim (##output-port-line-set! port line)
(##declare (not interrupts-enabled))
(macro-character-port-wlines-set! port (##fixnum.- line 1)))
(define-prim (##output-port-line port)
(##declare (not interrupts-enabled))
(##fixnum.+ (macro-character-port-wlines port) 1))
(define-prim (output-port-line port)
(macro-force-vars (port)
(macro-check-character-output-port port 1 (output-port-line port)
(##output-port-line port))))
(define-prim (##output-port-column-set! port col)
(##declare (not interrupts-enabled))
(macro-character-port-wcurline-set!
port
(##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-wchars port)
(macro-character-port-whi port))
col)
1)))
(define-prim (##output-port-column port)
(##declare (not interrupts-enabled))
(##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-wchars port)
(macro-character-port-whi port))
(macro-character-port-wcurline port))
1))
(define-prim (output-port-column port)
(macro-force-vars (port)
(macro-check-character-output-port port 1 (output-port-column port)
(##output-port-column port))))
(define-prim (##output-port-width port)
(##declare (not interrupts-enabled))
((macro-character-port-output-width port) port))
(define-prim (output-port-width port)
(macro-force-vars (port)
(macro-check-character-output-port port 1 (output-port-width port)
(##output-port-width port))))
(define-prim (##object->truncated-string obj max-length)
(let* ((port
(##open-output-string))
(we
(##make-writeenv
'write
port
(macro-character-port-output-readtable port)
#f
(macro-if-forces #t #f)
0
0
0
0
max-length)))
(##wr we obj)
(##get-output-string port)))
(define-prim (##object->string obj #!optional (max-length ##max-fixnum))
(if (##fixnum.< 0 max-length)
(let ((str
(##object->truncated-string
obj
(if (##fixnum.< max-length ##max-fixnum)
(##fixnum.+ max-length 1)
##max-fixnum))))
(##string->limited-string str max-length))
(##string)))
(define-prim (object->string obj #!optional (m (macro-absent-obj)))
(macro-force-vars (obj m)
(if (##eq? m (macro-absent-obj))
(##object->string obj)
(let ()
(define (type-error)
(##fail-check-exact-integer 2 object->string obj m))
(define (range-error)
(##raise-range-exception 2 object->string obj m))
(if (macro-exact-int? m)
(if (or (##not (##fixnum? m)) (##fixnum.negative? m))
(range-error)
(##object->string obj m))
(type-error))))))
(define-prim (##string->limited-string str max-length)
(if (##fixnum.< max-length (##string-length str))
(##force-limited-string! (##substring str 0 max-length) max-length)
str))
(define-prim (##force-limited-string! str max-length)
(if (##fixnum.< 0 max-length)
(begin
(##string-set! str (##fixnum.- max-length 1) #\.)
(if (##fixnum.< 1 max-length)
(begin
(##string-set! str (##fixnum.- max-length 2) #\.)
(if (##fixnum.< 2 max-length)
(##string-set! str (##fixnum.- max-length 3) #\.))))))
(##string-shrink! str max-length)
str)
;;;----------------------------------------------------------------------------
;;; Implementation of generic char port procedures.
(define-prim (##input-port-characters-buffered port)
(##declare (not interrupts-enabled))
(macro-port-mutex-lock! port) ;; get exclusive access to port
(let* ((char-rlo
(macro-character-port-rlo port))
(char-rhi
(macro-character-port-rhi port))
(characters-buffered
(if (macro-character-port-peek-eof? port)
1
(##fixnum.- char-rhi char-rlo))))
(macro-port-mutex-unlock! port)
characters-buffered))