http://www.franz.com/support/documentation/6.2/doc/streams.htm
This code was originally written by Paul Foley for cmucl; Paul's
-version resides (as of 2003-05-12) at
-http://users.actrix.co.nz/mycroft/cl.html
+version is now in cmucl cvs.
The port to sbcl was done by Rudi Schlatte (rudi@constantly.at).
-*- text -*-
-- Test writing beyond the end of a mapped-simple-stream
+- Implement & test read-sequence, write-sequence for (un)signed-8 vectors
+
+- Make reader work with simple-streams
+
+- external format handling: load aliases, load formats, etc.
+
+- Handle writing beyond the end of a mapped-simple-stream properly
+
+- handle device-file-position for mapped streams
- Test write-octets / read-octets handling of encapsulated streams
-- handle ansi-streams in write-octets / read-octets
+- handle ansi-streams in write-octets / read-octets?
- Implement socket-base-simple-stream and chunked transfer encoding.
-- Implement / test string streams.
+- Test string streams.
- Make sure the code examples for stream encapsulation from Franz work
- Test every single output function
-- Handle character position (slot charpos)
-
-- make file-position work for non-file streams, where applicable
+- Test character position (slot charpos)
- make pathname work for simple-streams
+- test :abort argument to close (should revert to original file)
+
;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; This code is in the public domain.
-
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
-;;; (pushnew :sb-simple-stream *features*)
-
;;;
-;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
+;;; **********************************************************************
;;;
+;;; Base class and generic function definitions for simple-streams
;;; See chapter
;;; 12.2 Strategy descriptions necessary for encapsulation
;;; in the Franz documentation for a description of the j-xxx-fn slots.
+;;;; Types for buffer and strategy functions
+
(deftype simple-stream-buffer ()
'(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
(deftype blocking ()
- `(member t nil :bnb))
+ '(member t nil :bnb))
(deftype j-listen-fn ()
'(function (simple-stream) boolean))
'(function ((or character null) simple-stream) (or character null)))
(deftype j-write-chars-fn ()
- '(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
+ '(function (string simple-stream fixnum fixnum) t)) ; return chars-written?
(deftype j-unread-char-fn ()
- '(function (simple-stream t) t)) ;; "relaxed" arg is boolean? what return?
+ '(function (simple-stream t) t)) ; "relaxed" arg is boolean? what return?
-;;;
-;;; STREAM CLASSES
-;;;
-
-;;; KLUDGE (sat 2003-01-15): def-stream-class and the
-;;; with-stream-class / sm accessors implement a form of "sealing" of
-;;; classes -- i.e., implementing very fast slot access at the price
-;;; of not being able to change the class definition at runtime.
-;;; Instead of a method call, a slot access for a simple-stream
-;;; subclass is a funcall or (when the def-stream-class form has a
-;;; location argument for the slot) a sb-pcl::clos-slots-ref. Given a
-;;; sufficiently advanced PCL with (non-standard) sealing
-;;; declarations, this machinery would be superfluous. For the time
-;;; being, replacing 4 method calls with vector accesses for the fast
-;;; path of read-char seems worthwhile to me. Besides, it's the
-;;; documented interface to simple-stream internals, and so it's worth
-;;; keeping.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (declaim (type hash-table *slot-access-functions*))
- (defvar *slot-access-functions* (make-hash-table))
- (defvar *automagic-accessors* nil))
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro def-stream-class (name superclasses slots &rest options)
- (let ((accessors ())
- (real-slots ()))
- (dolist (slot slots)
- ;; Frob the slot arguments, memorizing either the location (an
- ;; integer) or the accessor of the slot. Optionally construct
- ;; an accessor if none is given.
- (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
- ;; We have got a location specifier. Memorize it and
- ;; extract it until pcl itself can work with these.
- (push (cons (first slot)
- (cons (getf (rest slot) :type t)
- (getf (rest slot) 'sb-pcl::location)))
- accessors)
- (let ((slot (copy-list slot)))
- (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
- (push slot real-slots)))
- ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
- (if *automagic-accessors*
- ;; Add an :accessor argument, and memorize it. FIXME:
- ;; will this work with sbcl? reader/writers are
- ;; named differently there (see
- ;; src/pcl/slot-name.lisp)
- (let* ((slot (if (consp slot) slot (list slot)))
- (accessor (or (cdr (gethash (first slot)
- *slot-access-functions*))
- (intern (format nil "~A ~A slot ACCESSOR"
- name (first slot))
- "SB-SLOT-ACCESSOR-NAME"))))
- (push (cons (first slot)
- (cons (getf (rest slot) :type t) accessor))
- accessors)
- (push (append slot `(:accessor ,accessor)) real-slots))
- (push slot real-slots)))
- (t
- ;; No location given, but we have an accessor. Memorize it.
- (push (cons (first slot)
- (cons (getf (rest slot) :type t)
- (getf (rest slot) :accessor)))
- accessors)
- (push slot real-slots))))
- `(prog1
- (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(loop for accessor in accessors
- do (let ((exists (gethash (car accessor)
- *slot-access-functions*)))
- (when (and exists
- (integerp (cdr exists))
- (integerp (cddr accessor))
- (/= (cdr exists) (cddr accessor)))
- (warn "~S slot ~S has moved! ~
- I hope you know what you're doing!"
- name (car accessor))))
- collect `(setf (gethash ',(car accessor) *slot-access-functions*)
- ',(cdr accessor)))))))
-
-
-(defmacro def-stream-class (name superclasses slots &rest options)
- (let ((slots (copy-tree slots)))
- (dolist (slot slots) (remf (cdr slot) 'sb-pcl::location))
- `(defclass ,name ,superclasses ,slots ,@options)))
+;;;; Base simple-stream classes
(def-stream-class simple-stream (standard-object stream)
- ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
+ (;; instance flags (not a normal slot in Allegro CL)
+ (%flags :initform 0 :type fixnum)
+ (plist :initform nil :type list :accessor stream-plist)
;; Strategy slots. See section 12.2 of streams.htm for function
;; signatures and possible side-effects.
;; A function that determines if one character can be successfully
;; read from stream.
- (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn sb-pcl::location 18)
+ (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn)
;; A function that reads one character.
- (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn sb-pcl::location 17)
+ (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn)
;; A function that reads characters into a string.
- (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn sb-pcl::location 16)
+ (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn)
;; A function that writes one character.
- (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn sb-pcl::location 15)
+ (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn)
;; A function that writes characters from a string into the stream.
- (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn sb-pcl::location 14)
+ (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn)
;; A function that unreads the last character read.
- (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn sb-pcl::location 13)
+ (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn)
;; Other slots
- ;; Always a stream, allowing for composing external formats (see
- ;; streams.htm, section 12.5) TODO: document this better
- (melded-stream sb-pcl::location 12)
- ;; Always a stream, allowing for composing external formats (see
- ;; streams.htm, section 12.5) TODO: document this better
- (melding-base sb-pcl::location 11)
- ;; Number of octets the last read-char operation consumed TODO:
- ;; document this better; what is the difference to
- ;; last-char-read-size ?
- (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
- (mode :initform 0 :type fixnum sb-pcl::location 9)
- (control-in :initform nil :type (or null simple-vector)
- sb-pcl::location 8)
- (control-out :initform nil :type (or null simple-vector)
- sb-pcl::location 7)
+ ;; TODO: find out what this one does
+ (oc-state :initform nil)
+ ;; TODO: find out what this one does
+ (co-state :initform nil)
+ (external-format :initform :default)
+
;; A fixnum (denoting a valid file descriptor), a stream, or nil if
;; the stream is not open for input.
- (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
- :type (or null fixnum stream)
+ (input-handle :initform nil :initarg :input-handle
+ :type (or null fixnum stream)
:accessor stream-input-handle)
;; A fixnum (denoting a valid file descriptor), a stream, or nil if
;; the stream is not open for output.
- (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
+ (output-handle :initform nil :initarg :output-handle
:type (or null fixnum stream)
:accessor stream-output-handle)
- (external-format :initform :default sb-pcl::location 4)
- (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
- ;; The character position of the stream.
- (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
- ;; Number of octets the last read-char operation consumed
- (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
- ;; instance flags (not a normal slot in Allegro CL)
- (%flags :initform 0 :type fixnum sb-pcl::location 0)))
+ (control-in :initform nil :type (or null simple-vector))
+ (control-out :initform nil :type (or null simple-vector))
-(def-stream-class probe-simple-stream (simple-stream)
- ())
+ ;; a stream, allowing for composing external formats (see
+ ;; streams.htm, section 12.5) TODO: document this better
+ (melded-stream :type (or null simple-stream))
+ ;; a stream, allowing for composing external formats (see
+ ;; streams.htm, section 12.5) TODO: document this better
+ (melding-base :type (or null simple-stream))
+
+ ;; Number of octets the last read-char operation consumed TODO:
+ ;; document this better; what is the difference to
+ ;; last-char-read-size ?
+ (encapsulated-char-read-size :initform 0 :type fixnum)
+ ;; Number of octets the last read-char operation consumed
+ (last-char-read-size :initform 0 :type fixnum)
+ (charpos :initform 0 :type (or null integer)
+ :accessor stream-line-column)
+ (record-end :initform nil :type (or null fixnum))
-;;; A stream with a single buffer, for example a file stream.
-(def-stream-class single-channel-simple-stream (simple-stream)
;; Input/output buffer.
- ((buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 23)
+ (buffer :initform nil :type (or simple-stream-buffer null))
;; Current position in buffer.
- (buffpos :initform 0 :type fixnum sb-pcl::location 22)
+ (buffpos :initform 0 :type fixnum)
;; Maximum valid position in buffer, or -1 on eof.
- (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
- (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
-
-(def-stream-class direct-simple-stream (single-channel-simple-stream)
- ())
-
-(def-stream-class buffer-input-simple-stream (direct-simple-stream)
- ())
-
-(def-stream-class buffer-output-simple-stream (direct-simple-stream)
- ((out-buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 26)
- ;; Current position in output buffer.
- (outpos :initform 0 :type fixnum sb-pcl::location 25)
- ;; Buffer length (one greater than maximum output buffer index)
- (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
-
-(def-stream-class null-simple-stream (single-channel-simple-stream)
- ())
+ (buffer-ptr :initform 0 :type fixnum)
+ (buf-len :initform 0 :type fixnum)
-(def-stream-class file-simple-stream (single-channel-simple-stream)
- ((pathname :initform nil :initarg :pathname sb-pcl::location 27)
- (filename :initform nil :initarg :filename sb-pcl::location 26)
- (original :initform nil :initarg :original sb-pcl::location 25)
- (delete-original :initform nil :initarg :delete-original
- sb-pcl::location 24)
- ))
+ (pending :initform nil :type list)
+ (handler :initform nil :type (or null sb-impl::handler))))
-(def-stream-class mapped-file-simple-stream (file-simple-stream
- direct-simple-stream)
- ())
+(def-stream-class single-channel-simple-stream (simple-stream)
+ (;; the "dirty" flag -- if this is > 0, write out buffer contents
+ ;; before changing position; see flush-buffer
+ (mode :initform 0 :type fixnum)))
-;;; A stream with two octet buffers, for example a socket or terminal
-;;; stream.
(def-stream-class dual-channel-simple-stream (simple-stream)
(;; Output buffer.
- (out-buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 26)
+ (out-buffer :initform nil :type (or simple-stream-buffer null))
;; Current position in output buffer.
- (outpos :initform 0 :type fixnum sb-pcl::location 25)
+ (outpos :initform 0 :type fixnum)
;; Buffer length (one greater than maximum output buffer index)
- (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
- ;; Input buffer (in this case; the 'buffer' slot serves as
- ;; bidirectional buffer for single-channel-simple-streams).
- (buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 23)
- ;; Current position in buffer.
- (buffpos :initform 0 :type fixnum sb-pcl::location 22)
- ;; Maximum valid position in buffer, or -1 on eof.
- (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
- (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
-
-(def-stream-class terminal-simple-stream (dual-channel-simple-stream)
- ())
-
-(def-stream-class socket-simple-stream (dual-channel-simple-stream)
- ((socket :initform nil :type (or sb-bsd-sockets:socket null)
- :initarg :socket sb-pcl::location 27)))
-
-(def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
- ())
-
-(def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
- ())
+ (max-out-pos :initform 0 :type fixnum)))
;;; A stream with a string as buffer.
(def-stream-class string-simple-stream (simple-stream)
())
-(def-stream-class composing-stream (string-simple-stream)
- ())
-
-(def-stream-class string-input-simple-stream (string-simple-stream)
- (;; The input buffer.
- (buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 23)
- ;; Current position in buffer.
- (buffpos :initform 0 :type fixnum sb-pcl::location 22)
- ;; Maximum valid position in buffer, or -1 on eof.
- (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
- (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
-
-(def-stream-class string-output-simple-stream (string-simple-stream)
- (;; The input buffer.
- (buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 26)
- ;; Current position in input buffer.
- (buffpos :initform 0 :type fixnum sb-pcl::location 25)
- ;; Maximum valid position in input buffer, or -1 on eof.
- (buffer-ptr :initform 0 :type fixnum sb-pcl::location 24)
- (buf-len :initform 0 :type fixnum sb-pcl::location 23)
- ;; The output buffer (slot added so that a class can inherit from
- ;; both string-input-simple-stream and string-output-simple-stream
- ;; without the strategies clashing)
- (out-buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 22)
- ;; Current position in output buffer.
- (outpos :initform 0 :type fixnum sb-pcl::location 21)
- ;; Buffer length (one greater than maximum output buffer index)
- (max-out-pos :initform 0 :type fixnum sb-pcl::location 20)))
-
-(def-stream-class fill-pointer-output-simple-stream
- (string-output-simple-stream)
- ())
-
-(def-stream-class limited-string-output-simple-stream
- (string-output-simple-stream)
- ())
-(def-stream-class xp-simple-stream (string-output-simple-stream)
- ())
-
-(def-stream-class annotation-output-simple-stream (string-output-simple-stream)
- ())
-
-
-(defclass default-latin1-base-ef () ())
-(defclass stream-recording-mixin () ())
-(defclass stream-recording-repaint-mixin () ())
+;;; ======================================================
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf *automagic-accessors* nil))
-
;;;
;;; DEVICE-LEVEL FUNCTIONS
;;;
(defgeneric device-clear-output (stream))
(defgeneric device-finish-record (stream blocking action))
+
+
+(defmethod shared-initialize :after ((instance simple-stream) slot-names
+ &rest initargs &key &allow-other-keys)
+ (declare (ignore slot-names))
+ (unless (slot-boundp instance 'melded-stream)
+ (setf (slot-value instance 'melded-stream) instance)
+ (setf (slot-value instance 'melding-base) instance))
+ (unless (device-open instance initargs)
+ (device-close instance t)))
+
+
+(defmethod print-object ((object simple-stream) stream)
+ (print-unreadable-object (object stream :type nil :identity nil)
+ (cond ((not (any-stream-instance-flags object :simple))
+ (princ "Invalid " stream))
+ ((not (any-stream-instance-flags object :input :output))
+ (princ "Closed " stream)))
+ (format stream "~:(~A~)" (type-of object))))
+
+;;; This takes care of the things all device-close methods have to do,
+;;; regardless of the type of simple-stream
+(defmethod device-close :around ((stream simple-stream) abort)
+ (with-stream-class (simple-stream stream)
+ (when (any-stream-instance-flags stream :input :output)
+ (when (any-stream-instance-flags stream :output)
+ (ignore-errors (if abort
+ (clear-output stream)
+ (force-output stream))))
+ (call-next-method)
+ (setf (sm input-handle stream) nil
+ (sm output-handle stream) nil)
+ (remove-stream-instance-flags stream :input :output)
+ (sb-ext:cancel-finalization stream)
+ ;; This sets all readers and writers to error-raising functions
+ (setf (stream-external-format stream) :void))))
+
+(defmethod device-close ((stream simple-stream) abort)
+ (declare (ignore abort))
+ t)
+
+(defmethod device-buffer-length ((stream simple-stream))
+ 4096)
+
+(defmethod device-file-position ((stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (sm buffpos stream)))
+
+(defmethod (setf device-file-position) (value (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (setf (sm buffpos stream) value)))
+
+(defmethod device-file-length ((stream simple-stream))
+ nil)
+
+(defgeneric (setf stream-external-format) (value stream))
+
+(defmethod (setf stream-external-format) :before (value (stream simple-stream))
+ ;; (unless (eq value (sm external-format stream))
+ ;; flush out the existing external-format
+ )
+
+(defmethod (setf stream-external-format) :after
+ (ef (stream single-channel-simple-stream))
+ (compose-encapsulating-streams stream ef)
+ (install-single-channel-character-strategy (melding-stream stream) ef nil))
+
+(defmethod (setf stream-external-format) :after
+ (ef (stream dual-channel-simple-stream))
+ (compose-encapsulating-streams stream ef)
+ (install-dual-channel-character-strategy (melding-stream stream) ef))
+
+
+(defmethod device-read ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-clear-input ((stream simple-stream) buffer-only)
+ (declare (ignore buffer-only))
+ nil)
+
+(defmethod device-write ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ ;; buffer may be :flush to force/finish-output
+ (when (or (and (null buffer) (not (eql start end)))
+ (eq buffer :flush))
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf buffer (sm buffer stream))
+ (setf end (sm buffpos stream))))
+ (write-octets stream buffer start end blocking))
+
+(defmethod device-write ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ ;; buffer may be :flush to force/finish-output
+ (when (or (and (null buffer) (not (eql start end)))
+ (eq buffer :flush))
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setf buffer (sm out-buffer stream))
+ (setf end (sm outpos stream))))
+ (write-octets stream buffer start end blocking))
+
+(defmethod device-clear-output ((stream simple-stream))
+ nil)
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
+
+(def-stream-class direct-simple-stream (single-channel-simple-stream)
+ ())
+
+(def-stream-class buffer-input-simple-stream (direct-simple-stream)
+ ())
+
+(def-stream-class buffer-output-simple-stream (direct-simple-stream)
+ ((out-buffer :initform nil :type (or simple-stream-buffer null))
+ (outpos :initform 0 :type fixnum)
+ (max-out-pos :initform 0 :type fixnum)))
+
+(defmethod device-file-length ((stream direct-simple-stream))
+ ;; return buffer length
+ )
+
+(defmethod device-open ((stream buffer-input-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream buffer-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Definition of File-Simple-Stream and relations
+
+(def-stream-class file-simple-stream (single-channel-simple-stream)
+ ((pathname :initform nil :initarg :pathname)
+ (filename :initform nil :initarg :filename)
+ (original :initform nil :initarg :original)
+ (delete-original :initform nil :initarg :delete-original)))
+
+(def-stream-class mapped-file-simple-stream (file-simple-stream
+ direct-simple-stream)
+ ())
+
+(def-stream-class probe-simple-stream (simple-stream)
+ ((pathname :initform nil :initarg :pathname)))
+
+(defmethod print-object ((object file-simple-stream) stream)
+ (print-unreadable-object (object stream :type nil :identity nil)
+ (with-stream-class (file-simple-stream object)
+ (cond ((not (any-stream-instance-flags object :simple))
+ (princ "Invalid " stream))
+ ((not (any-stream-instance-flags object :input :output))
+ (princ "Closed " stream)))
+ (format stream "~:(~A~) for ~S"
+ (type-of object) (sm filename object)))))
+
+
+(defun open-file-stream (stream options)
+ (let ((filename (pathname (getf options :filename)))
+ (direction (getf options :direction :input))
+ (if-exists (getf options :if-exists))
+ (if-exists-given (not (eql (getf options :if-exists t) t)))
+ (if-does-not-exist (getf options :if-does-not-exist))
+ (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
+ (with-stream-class (file-simple-stream stream)
+ (ecase direction
+ (:input (add-stream-instance-flags stream :input))
+ (:output (add-stream-instance-flags stream :output))
+ (:io (add-stream-instance-flags stream :input :output)))
+ (cond ((and (sm input-handle stream) (sm output-handle stream)
+ (not (eql (sm input-handle stream)
+ (sm output-handle stream))))
+ (error "Input-Handle and Output-Handle can't be different."))
+ ((or (sm input-handle stream) (sm output-handle stream))
+ (add-stream-instance-flags stream :simple)
+ ;; get namestring, etc., from handle, if possible
+ ;; (i.e., if it's a stream)
+ ;; set up buffers
+ stream)
+ (t
+ (multiple-value-bind (fd namestring original delete-original)
+ (%fd-open filename direction if-exists if-exists-given
+ if-does-not-exist if-does-not-exist-given)
+ (when fd
+ (add-stream-instance-flags stream :simple)
+ (setf (sm pathname stream) filename
+ (sm filename stream) namestring
+ (sm original stream) original
+ (sm delete-original stream) delete-original)
+ (when (any-stream-instance-flags stream :input)
+ (setf (sm input-handle stream) fd))
+ (when (any-stream-instance-flags stream :output)
+ (setf (sm output-handle stream) fd))
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-unix:unix-close fd)
+ (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
+ namestring fd)
+ (when original
+ (revert-file namestring original))))
+ stream)))))))
+
+(defmethod device-open ((stream file-simple-stream) options)
+ (with-stream-class (file-simple-stream stream)
+ (when (open-file-stream stream options)
+ ;; Franz says:
+ ;; "The device-open method must be prepared to recognize resource
+ ;; and change-class situations. If no filename is specified in
+ ;; the options list, and if no input-handle or output-handle is
+ ;; given, then the input-handle and output-handle slots should
+ ;; be examined; if non-nil, that means the stream is still open,
+ ;; and thus the operation being requested of device-open is a
+ ;; change-class. Also, a device-open method need not allocate a
+ ;; buffer every time it is called, but may instead reuse a
+ ;; buffer it finds in a stream, if it does not become a security
+ ;; issue."
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm buffer stream) (allocate-buffer length)
+ (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm buf-len stream) length)))
+ (when (any-stream-instance-flags stream :output)
+ (setf (sm control-out stream) *std-control-out-table*))
+ (setf (stream-external-format stream)
+ (getf options :external-format :default))
+ stream)))
+
+;;; Revert a file, if possible; otherwise just delete it. Used during
+;;; CLOSE when the abort flag is set.
+;;;
+;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
+;;; as well, snarf error reporting from there.
+(defun revert-file (filename original)
+ (declare (type simple-base-string filename)
+ (type (or simple-base-string null) original))
+ ;; We can't do anything unless we know what file were
+ ;; dealing with, and we don't want to do anything
+ ;; strange unless we were writing to the file.
+ (if original
+ (multiple-value-bind (okay err) (sb-unix:unix-rename original filename)
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "Could not restore ~S to its original contents: ~A"
+ filename (sb-int:strerror err))))
+ ;; We can't restore the original, so nuke that puppy.
+ (multiple-value-bind (okay err) (sb-unix:unix-unlink filename)
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "Could not remove ~S: ~A"
+ filename (sb-int:strerror err))))))
+
+;;; DELETE-ORIGINAL -- internal
+;;;
+;;; Delete a backup file. Used during CLOSE.
+;;;
+;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
+;;; as well, snarf error reporting from there.
+(defun delete-original (filename original)
+ (declare (type simple-base-string filename)
+ (type (or simple-base-string null) original))
+ (when original
+ (multiple-value-bind (okay err) (sb-unix:unix-unlink original)
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "Could not delete ~S during close of ~S: ~A"
+ original filename (sb-int:strerror err))))))
+
+(defmethod device-close ((stream file-simple-stream) abort)
+ (with-stream-class (file-simple-stream stream)
+ (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
+ (when (sb-int:fixnump fd)
+ (cond (abort
+ (when (any-stream-instance-flags stream :output)
+ (revert-file (sm filename stream) (sm original stream))))
+ (t
+ (when (sm delete-original stream)
+ (delete-original (sm filename stream) (sm original stream)))))
+ (sb-unix:unix-close fd))
+ (when (sm buffer stream)
+ (free-buffer (sm buffer stream))
+ (setf (sm buffer stream) nil))))
+ t)
+
+(defmethod device-file-position ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
+ (if (sb-int:fixnump fd)
+ (values (sb-unix:unix-lseek fd 0 sb-unix:l_incr))
+ (file-position fd)))))
+
+(defmethod (setf device-file-position) (value (stream file-simple-stream))
+ (declare (type fixnum value))
+ (with-stream-class (file-simple-stream stream)
+ (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
+ (if (sb-int:fixnump fd)
+ (values (sb-unix:unix-lseek fd
+ (if (minusp value) (1+ value) value)
+ (if (minusp value) sb-unix:l_xtnd sb-unix:l_set)))
+ (file-position fd value)))))
+
+(defmethod device-file-length ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (let ((fd (or (sm input-handle stream) (sm output-handle stream))))
+ (if (sb-int:fixnump fd)
+ (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
+ (sb-unix:unix-fstat (sm input-handle stream))
+ (declare (ignore dev ino mode nlink uid gid rdev))
+ (if okay size nil))
+ (file-length fd)))))
+
+(defmethod device-open ((stream mapped-file-simple-stream) options)
+ (with-stream-class (mapped-file-simple-stream stream)
+ (when (open-file-stream stream options)
+ (let* ((input (any-stream-instance-flags stream :input))
+ (output (any-stream-instance-flags stream :output))
+ (prot (logior (if input sb-posix::PROT-READ 0)
+ (if output sb-posix::PROT-WRITE 0)))
+ (fd (or (sm input-handle stream) (sm output-handle stream))))
+ (unless (sb-int:fixnump fd)
+ (error "Can't memory-map an encapsulated stream."))
+ (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
+ (sb-unix:unix-fstat fd)
+ (declare (ignore ino mode nlink uid gid rdev))
+ (unless okay
+ (sb-unix:unix-close fd)
+ (sb-ext:cancel-finalization stream)
+ (error "Error fstating ~S: ~A" stream
+ (sb-int:strerror dev)))
+ (when (> size most-positive-fixnum)
+ ;; Or else BUF-LEN has to be a general integer, or
+ ;; maybe (unsigned-byte 32). In any case, this means
+ ;; BUF-MAX and BUF-PTR have to be the same, which means
+ ;; number-consing every time BUF-PTR moves...
+ ;; Probably don't have the address space available to map
+ ;; bigger files, anyway. Maybe DEVICE-READ can adjust
+ ;; the mapped portion of the file when necessary?
+ (warn "Unable to memory-map entire file.")
+ (setf size most-positive-fixnum))
+ (let ((buffer
+ (handler-case
+ (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
+ (sb-posix:syscall-error nil))))
+ (when (null buffer)
+ (sb-unix:unix-close fd)
+ (sb-ext:cancel-finalization stream)
+ (error "Unable to map file."))
+ (setf (sm buffer stream) buffer
+ (sm buffpos stream) 0
+ (sm buffer-ptr stream) size
+ (sm buf-len stream) size)
+ (when (any-stream-instance-flags stream :output)
+ (setf (sm control-out stream) *std-control-out-table*))
+ (let ((efmt (getf options :external-format :default)))
+ (compose-encapsulating-streams stream efmt)
+ (setf (stream-external-format stream) efmt)
+ ;; overwrite the strategy installed in :after method of
+ ;; (setf stream-external-format)
+ (install-single-channel-character-strategy
+ (melding-stream stream) efmt 'mapped))
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-posix:munmap buffer size)
+ (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))
+ stream)))
+
+
+(defmethod device-close ((stream mapped-file-simple-stream) abort)
+ (with-stream-class (mapped-file-simple-stream stream)
+ (when (sm buffer stream)
+ (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
+ (setf (sm buffer stream) nil))
+ (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
+ t)
+
+;; TODO: implement msync in sb-posix; activate this
+#+paul
+(defmethod device-write ((stream mapped-file-simple-stream) buffer
+ start end blocking)
+ (assert (eq buffer :flush) (buffer)) ; finish/force-output
+ (with-stream-class (mapped-file-simple-stream stream)
+ (unix:unix-msync (sm buffer stream) (sm buf-len stream)
+ (if blocking unix:ms_sync unix:ms_async))))
+
+(defmethod device-open ((stream probe-simple-stream) options)
+ (let ((pathname (getf options :filename)))
+ (with-stream-class (probe-simple-stream stream)
+ (add-stream-instance-flags stream :simple)
+ (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok)
+ (setf (sm pathname stream) pathname)
+ t))))
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Implementations of standard Common Lisp functions for simple-streams
+
+(defun %uninitialized (stream)
+ (error "~S has not been initialized." stream))
+
+(defun %check (stream kind)
+ (declare (type simple-stream stream)
+ (optimize (speed 3) (space 1) (debug 0) (safety 0)))
+ (with-stream-class (simple-stream stream)
+ (cond ((not (any-stream-instance-flags stream :simple))
+ (%uninitialized stream))
+ ((and (eq kind :open)
+ (not (any-stream-instance-flags stream :input :output)))
+ (sb-kernel:closed-flame stream))
+ ((and (or (eq kind :input) (eq kind :io))
+ (not (any-stream-instance-flags stream :input)))
+ (sb-kernel:ill-in stream))
+ ((and (or (eq kind :output) (eq kind :io))
+ (not (any-stream-instance-flags stream :output)))
+ (sb-kernel:ill-out stream)))))
+
+(defmethod input-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :input))
+
+(defmethod output-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :output))
+
+(defmethod open-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :input :output))
+
+;;; From the simple-streams documentation: "A generic function implies
+;;; a specialization capability that does not exist for
+;;; simple-streams; simple-stream specializations should be on
+;;; device-close." So don't do it.
+(defmethod close ((stream simple-stream) &key abort)
+ (device-close stream abort))
+
+(defun %file-position (stream position)
+ (declare (type simple-stream stream)
+ (type (or (integer 0 *) (member nil :start :end)) position))
+ (with-stream-class (simple-stream stream)
+ (%check stream :open)
+ (if position
+ ;; Adjust current position
+ (let ((position (case position (:start 0) (:end -1)
+ (otherwise position))))
+ (etypecase stream
+ (single-channel-simple-stream
+ (when (sc-dirty-p stream)
+ (flush-buffer stream t)))
+ (dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (when (> (sm outpos stream) 0)
+ (device-write stream :flush 0 nil t))))
+ (string-simple-stream
+ nil))
+
+ (setf (sm last-char-read-size stream) 0)
+ (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read
+ (sm buffer-ptr stream) 0)
+ (setf (sm charpos stream) nil)
+ (remove-stream-instance-flags stream :eof)
+ (setf (device-file-position stream) position))
+ ;; Just report current position
+ (let ((posn (device-file-position stream)))
+ (when posn
+ (when (sm handler stream)
+ (dolist (queued (sm pending stream))
+ (incf posn (- (the sb-int:index (third queued))
+ (the sb-int:index (second queued))))))
+ (etypecase stream
+ (single-channel-simple-stream
+ (case (sm mode stream)
+ ((0 3) ; read, read-modify
+ ;; Note that posn can increase here if we wrote
+ ;; past the end of previously-read data
+ (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
+ (1 ; write
+ (incf posn (sm buffpos stream)))))
+ (dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (incf posn (sm outpos stream))
+ (when (>= (sm buffer-ptr stream) 0)
+ (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))))
+ (string-simple-stream
+ nil)))
+ posn))))
+
+(defun %file-length (stream)
+ (declare (type simple-stream stream))
+ (%check stream :open)
+ (device-file-length stream))
+
+
+(defun %file-name (stream)
+ (declare (type simple-stream stream))
+ (%check stream nil)
+ (typecase stream
+ (file-simple-stream
+ (with-stream-class (file-simple-stream stream)
+ (sm pathname stream)))
+ (probe-simple-stream
+ (with-stream-class (probe-simple-stream stream)
+ (sm pathname stream)))
+ (otherwise
+ nil)))
+
+
+(defun %file-rename (stream new-name)
+ (declare (type simple-stream stream))
+ (%check stream nil)
+ (if (typep stream 'file-simple-stream)
+ (with-stream-class (file-simple-stream stream)
+ (setf (sm pathname stream) new-name)
+ (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
+ t)
+ nil))
+
+
+(defun %file-string-length (stream object)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ ;; FIXME: need to account for compositions on the stream...
+ (let ((count 0))
+ (flet ((fn (octet)
+ (declare (ignore octet))
+ (incf count)))
+ (etypecase object
+ (character
+ (let ((x nil))
+ (char-to-octets (sm external-format stream) object x #'fn)))
+ (string
+ (let ((x nil)
+ (ef (sm external-format stream)))
+ (dotimes (i (length object))
+ (declare (type sb-int:index i))
+ (char-to-octets ef (char object i) x #'fn))))))
+ count)))
+
+
+(defun %read-line (stream eof-error-p eof-value recursive-p)
+ (declare (optimize (speed 3) (space 1) (safety 0) (debug 0))
+ (type simple-stream stream)
+ (ignore recursive-p))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (when (any-stream-instance-flags stream :eof)
+ (return-from %read-line
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ ;; for interactive streams, finish output first to force prompt
+ (when (and (any-stream-instance-flags stream :output)
+ (any-stream-instance-flags stream :interactive))
+ (%finish-output stream))
+ (let* ((encap (sm melded-stream stream)) ; encapsulating stream
+ (cbuf (make-string 80)) ; current buffer
+ (bufs (list cbuf)) ; list of buffers
+ (tail bufs) ; last cons of bufs list
+ (index 0) ; current index in current buffer
+ (total 0)) ; total characters
+ (declare (type simple-stream encap)
+ (type simple-base-string cbuf)
+ (type cons bufs tail)
+ (type sb-int:index index total))
+ (loop
+ (multiple-value-bind (chars done)
+ (funcall-stm-handler j-read-chars encap cbuf
+ #\Newline index (length cbuf) t)
+ (declare (type sb-int:index chars))
+ (incf index chars)
+ (incf total chars)
+ (when (and (eq done :eof) (zerop total))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return (values eof-value t))))
+ (when done
+ ;; If there's only one buffer in use, return it directly
+ (when (null (cdr bufs))
+ (return (values (sb-kernel:shrink-vector cbuf total)
+ (eq done :eof))))
+ ;; If total fits in final buffer, use it
+ (when (<= total (length cbuf))
+ (replace cbuf cbuf :start1 (- total index) :end2 index)
+ (let ((idx 0))
+ (declare (type sb-int:index idx))
+ (do ((list bufs (cdr list)))
+ ((eq list tail))
+ (let ((buf (car list)))
+ (declare (type simple-base-string buf))
+ (replace cbuf buf :start1 idx)
+ (incf idx (length buf)))))
+ (return (values (sb-kernel:shrink-vector cbuf total)
+ (eq done :eof))))
+ ;; Allocate new string of appropriate length
+ (let ((string (make-string total))
+ (index 0))
+ (declare (type sb-int:index index))
+ (dolist (buf bufs)
+ (declare (type simple-base-string buf))
+ (replace string buf :start1 index)
+ (incf index (length buf)))
+ (return (values string (eq done :eof)))))
+ (when (>= index (length cbuf))
+ (setf cbuf (make-string (the sb-int:index (* 2 index))))
+ (setf index 0)
+ (setf (cdr tail) (cons cbuf nil))
+ (setf tail (cdr tail))))))))
+
+(defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
+ (declare (type simple-stream stream)
+ (ignore recursive-p))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (when (any-stream-instance-flags stream :eof)
+ (return-from %read-char
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ ;; for interactive streams, finish output first to force prompt
+ (when (and (any-stream-instance-flags stream :output)
+ (any-stream-instance-flags stream :interactive))
+ (%finish-output stream))
+ (funcall-stm-handler j-read-char (sm melded-stream stream)
+ eof-error-p eof-value blocking-p)))
+
+
+(defun %unread-char (stream character)
+ (declare (type simple-stream stream) (ignore character))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (if (zerop (sm last-char-read-size stream))
+ (error "Nothing to unread.")
+ (progn
+ (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
+ (remove-stream-instance-flags stream :eof)
+ (setf (sm last-char-read-size stream) 0)))))
+
+
+(defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
+ (declare (type simple-stream stream)
+ (ignore recursive-p))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (when (any-stream-instance-flags stream :eof)
+ (return-from %peek-char
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (let* ((encap (sm melded-stream stream))
+ (char (funcall-stm-handler j-read-char encap
+ eof-error-p stream t)))
+ (cond ((eq char stream) eof-value)
+ ((characterp peek-type)
+ (do ((char char (funcall-stm-handler j-read-char encap
+ eof-error-p
+ stream t)))
+ ((or (eq char stream) (char= char peek-type))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ ((eq peek-type t)
+ (do ((char char (funcall-stm-handler j-read-char encap
+ eof-error-p
+ stream t)))
+ ((or (eq char stream)
+ (not (sb-impl::whitespacep char)))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ (t
+ (funcall-stm-handler j-unread-char encap t)
+ char)))))
+
+(defun %listen (stream width)
+ (declare (type simple-stream stream))
+ ;; WIDTH is number of octets which must be available; any value
+ ;; other than 1 is treated as 'character.
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (when (any-stream-instance-flags stream :eof)
+ (return-from %listen nil))
+ (if (not (or (eql width 1) (null width)))
+ (funcall-stm-handler j-listen (sm melded-stream stream))
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ (when (>= (sm mode stream) 0) ;; device-connected @@ single-channel
+ (let ((lcrs (sm last-char-read-size stream)))
+ (unwind-protect
+ (progn
+ (setf (sm last-char-read-size stream) (1+ lcrs))
+ (plusp (refill-buffer stream nil)))
+ (setf (sm last-char-read-size stream) lcrs))))))))
+
+(defun %clear-input (stream buffer-only)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (setf (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm last-char-read-size stream) 0
+ #|(sm unread-past-soft-eof stream) nil|#)
+ #| (setf (sm reread-count stream) 0) on dual-channel streams? |#
+ )
+ (device-clear-input stream buffer-only))
+
+
+(defun %read-byte (stream eof-error-p eof-value)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (if (any-stream-instance-flags stream :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ (etypecase stream
+ (single-channel-simple-stream
+ (read-byte-internal stream eof-error-p eof-value t))
+ (dual-channel-simple-stream
+ (read-byte-internal stream eof-error-p eof-value t))
+ (string-simple-stream
+ (with-stream-class (string-simple-stream stream)
+ (let ((encap (sm input-handle stream)))
+ (unless encap
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't read-byte on string streams"
+ :format-arguments '()))
+ (prog1
+ (read-byte encap eof-error-p eof-value)
+ (setf (sm last-char-read-size stream) 0
+ (sm encapsulated-char-read-size stream) 0)))))))))
+
+
+(defun %write-char (stream character)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
+
+
+(defun %fresh-line (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (when (/= (or (sm charpos stream) 1) 0)
+ (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
+ t)))
+
+
+(defun %write-string (stream string start end)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
+ start end)))
+
+
+(defun %line-length (stream)
+ (declare (type simple-stream stream))
+ (%check stream :output)
+ ;; implement me
+ nil)
+
+
+(defun %finish-output (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (when (sm handler stream)
+ (do ()
+ ((null (sm pending stream)))
+ (sb-sys:serve-all-events)))
+ (etypecase stream
+ (single-channel-simple-stream
+ ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
+ ; (setf (device-file-position stream)
+ ; (- (device-file-position stream) (sm buffer-ptr stream))))
+ ;(device-write stream :flush 0 nil t)
+ (flush-buffer stream t)
+ (setf (sm buffpos stream) 0))
+ (dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (device-write stream :flush 0 nil t)
+ (setf (sm outpos stream) 0)))
+ (string-simple-stream
+ (device-write stream :flush 0 nil t))))
+ nil)
+
+
+(defun %force-output (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (etypecase stream
+ (single-channel-simple-stream
+ ;(when (> (sm buffer-ptr stream) 0)
+ ; (setf (device-file-position stream)
+ ; (- (device-file-position stream) (sm buffer-ptr stream))))
+ ;(device-write stream :flush 0 nil nil)
+ (flush-buffer stream nil)
+ (setf (sm buffpos stream) 0))
+ (dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (device-write stream :flush 0 nil nil)
+ (setf (sm outpos stream) 0)))
+ (string-simple-stream
+ (device-write stream :flush 0 nil nil))))
+ nil)
+
+
+(defun %clear-output (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (when (sm handler stream)
+ (sb-sys:remove-fd-handler (sm handler stream))
+ (setf (sm handler stream) nil
+ (sm pending stream) nil))
+ (etypecase stream
+ (single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (case (sm mode stream)
+ (1 (setf (sm buffpos stream) 0))
+ (3 (setf (sm mode stream) 0)))))
+ (dual-channel-simple-stream
+ (setf (sm outpos stream) 0))
+ (string-simple-stream
+ nil))
+ (device-clear-output stream)))
+
+
+(defun %write-byte (stream integer)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (etypecase stream
+ (single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buf-len stream))
+ (setf ptr (flush-buffer stream t)))
+ (setf (sm buffpos stream) (1+ ptr))
+ (setf (sm charpos stream) nil)
+ (setf (bref (sm buffer stream) ptr) integer)
+ (sc-set-dirty stream))))
+ (dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (let ((ptr (sm outpos stream)))
+ (when (>= ptr (sm max-out-pos stream))
+ (setf ptr (flush-out-buffer stream t)))
+ (setf (sm outpos stream) (1+ ptr))
+ (setf (sm charpos stream) nil)
+ (setf (bref (sm out-buffer stream) ptr) integer))))
+ (string-simple-stream
+ (with-stream-class (string-simple-stream stream)
+ (let ((encap (sm output-handle stream)))
+ (unless encap
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't write-byte on string streams."
+ :format-arguments '()))
+ (write-byte integer encap)))))))
+
+
+(defun %read-sequence (stream seq start end partial-fill)
+ (declare (type simple-stream stream)
+ (type sequence seq)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end)
+ (type boolean partial-fill))
+ (with-stream-class (simple-stream stream)
+ (%check stream :input)
+ (when (any-stream-instance-flags stream :eof)
+ (return-from %read-sequence 0))
+ (etypecase seq
+ (string
+ (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
+ start (or end (length seq))
+ (if partial-fill :bnb t)))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; "read-vector" equivalent, but blocking if partial-fill is NIL
+ (error "implement me")
+ )
+ ;; extend to work on other sequences: repeated read-byte
+ )))
+
+
+(defun %write-sequence (stream seq start end)
+ (declare (type simple-stream stream)
+ (type sequence seq)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
+ (with-stream-class (simple-stream stream)
+ (%check stream :output)
+ (etypecase seq
+ (string
+ (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
+ start (or end (length seq))))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; "write-vector" equivalent
+ (setf (sm charpos stream) nil)
+ (etypecase stream
+ (single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (loop with max-ptr = (sm buf-len stream)
+ with real-end = (or end (length seq))
+ for src-pos = start then (+ src-pos count)
+ for src-rest = (- real-end src-pos)
+ while (> src-rest 0) ; FIXME: this is non-ANSI
+ for ptr = (let ((ptr (sm buffpos stream)))
+ (if (>= ptr max-ptr)
+ (flush-buffer stream t)
+ ptr))
+ for buf-rest = (- max-ptr ptr)
+ for count = (min buf-rest src-rest)
+ do (progn (setf (sm mode stream) 1)
+ (setf (sm buffpos stream) (+ ptr count))
+ (buffer-copy seq src-pos (sm buffer stream) ptr count)))))
+ (dual-channel-simple-stream
+ (error "Implement me"))
+ (string-simple-stream
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't write-byte on string streams."
+ :format-arguments '())))
+ )
+ ;; extend to work on other sequences: repeated write-byte
+ )))
+
+
+(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
+ (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
+ (type stream stream))
+ ;; START and END are octet offsets, not vector indices! [Except for strings]
+ ;; Return value is index of next octet to be read into (i.e., start+count)
+ (etypecase stream
+ (simple-stream
+ (with-stream-class (simple-stream stream)
+ (if (stringp vector)
+ (let* ((start (or start 0))
+ (end (or end (length vector)))
+ (encap (sm melded-stream stream))
+ (char (funcall-stm-handler j-read-char encap nil nil t)))
+ (when char
+ (setf (schar vector start) char)
+ (incf start)
+ (+ start (funcall-stm-handler j-read-chars encap vector nil
+ start end nil))))
+ (do* ((j-read-byte (if (any-stream-instance-flags stream :string)
+ (error "Can't READ-BYTE on string streams.")
+ #'read-byte-internal))
+ (encap (sm melded-stream stream))
+ (index (or start 0) (1+ index))
+ (end (or end (* (length vector) (vector-elt-width vector))))
+ (endian-swap (endian-swap-value vector endian-swap))
+ (byte (funcall j-read-byte encap nil nil t)
+ (funcall j-read-byte encap nil nil nil)))
+ ((or (null byte) (>= index end)) index)
+ (setf (bref vector (logxor index endian-swap)) byte)))))
+ ((or ansi-stream fundamental-stream)
+ (unless (typep vector '(or string
+ (simple-array (signed-byte 8) (*))
+ (simple-array (unsigned-byte 8) (*))))
+ (error "Wrong vector type for read-vector on stream not of type simple-stream."))
+ (read-sequence vector stream :start (or start 0) :end end))))
+
+;;; Basic functionality for ansi-streams. These are separate
+;;; functions because they are called in places where we already know
+;;; we operate on an ansi-stream (as opposed to a simple- or
+;;; gray-stream, or the symbols t or nil), so we can evade typecase
+;;; and (in|out)-synonym-of calls.
+
+(declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
+ %ansi-stream-unread-char %ansi-stream-read-line
+ %ansi-stream-read-sequence))
+
+(defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
+ (declare (ignore blocking))
+ #+nil
+ (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
+ (sb-int:prepare-for-fast-read-byte stream
+ (prog1
+ (sb-int:fast-read-byte eof-error-p eof-value t)
+ (sb-int:done-with-fast-read-byte))))
+
+(defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
+ (declare (ignore blocking))
+ #+nil
+ (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
+ (sb-int:prepare-for-fast-read-char stream
+ (prog1
+ (sb-int:fast-read-char eof-error-p eof-value)
+ (sb-int:done-with-fast-read-char))))
+
+(defun %ansi-stream-unread-char (character stream)
+ (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
+ (buffer (sb-kernel:ansi-stream-in-buffer stream)))
+ (declare (fixnum index))
+ (when (minusp index) (error "nothing to unread"))
+ (cond (buffer
+ (setf (aref buffer index) (char-code character))
+ (setf (sb-kernel:ansi-stream-in-index stream) index))
+ (t
+ (funcall (sb-kernel:ansi-stream-misc stream) stream
+ :unread character)))))
+
+(defun %ansi-stream-read-line (stream eof-error-p eof-value)
+ (sb-int:prepare-for-fast-read-char stream
+ (let ((res (make-string 80))
+ (len 80)
+ (index 0))
+ (loop
+ (let ((ch (sb-int:fast-read-char nil nil)))
+ (cond (ch
+ (when (char= ch #\newline)
+ (sb-int:done-with-fast-read-char)
+ (return (values (sb-kernel:shrink-vector res index) nil)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index))
+ ((zerop index)
+ (sb-int:done-with-fast-read-char)
+ (return (values (sb-impl::eof-or-lose stream eof-error-p
+ eof-value)
+ t)))
+ ;; Since FAST-READ-CHAR already hit the eof char, we
+ ;; shouldn't do another READ-CHAR.
+ (t
+ (sb-int:done-with-fast-read-char)
+ (return (values (sb-kernel:shrink-vector res index) t)))))))))
+
+(defun %ansi-stream-read-sequence (seq stream start %end)
+ (declare (type sequence seq)
+ (type sb-kernel:ansi-stream stream)
+ (type sb-int:index start)
+ (type sb-kernel:sequence-end %end)
+ (values sb-int:index))
+ (let ((end (or %end (length seq))))
+ (declare (type sb-int:index end))
+ (etypecase seq
+ (list
+ (let ((read-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'%ansi-stream-read-char
+ #'%ansi-stream-read-byte)))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)) i)
+ (declare (type list rem)
+ (type sb-int:index i))
+ (let ((el (funcall read-function stream nil :eof nil)))
+ (when (eq el :eof)
+ (return i))
+ (setf (first rem) el)))))
+ (vector
+ (sb-kernel:with-array-data ((data seq) (offset-start start)
+ (offset-end end))
+ (typecase data
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*))
+ simple-string)
+ (let* ((numbytes (- end start))
+ (bytes-read (sb-sys:read-n-bytes stream
+ data
+ offset-start
+ numbytes
+ nil)))
+ (if (< bytes-read numbytes)
+ (+ start bytes-read)
+ end)))
+ (t
+ (let ((read-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'%ansi-stream-read-char
+ #'%ansi-stream-read-byte)))
+ (do ((i offset-start (1+ i)))
+ ((>= i offset-end) end)
+ (declare (type sb-int:index i))
+ (let ((el (funcall read-function stream nil :eof nil)))
+ (when (eq el :eof)
+ (return (+ start (- i offset-start))))
+ (setf (aref data i) el)))))))))))
+
+
+(defun %ansi-stream-write-string (string stream start end)
+ (declare (type string string)
+ (type sb-kernel:ansi-stream stream)
+ (type sb-int:index start end))
+
+ ;; Note that even though you might expect, based on the behavior of
+ ;; things like AREF, that the correct upper bound here is
+ ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
+ ;; "bounding index" and "length" indicate that in this case (i.e.
+ ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
+ ;; which are implemented in terms of this function), (LENGTH STRING)
+ ;; is the required upper bound. A foolish consistency is the
+ ;; hobgoblin of lesser languages..
+ (unless (<= 0 start end (length string))
+ (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
+ start
+ end
+ string))
+
+ (if (sb-kernel:array-header-p string)
+ (sb-kernel:with-array-data ((data string) (offset-start start)
+ (offset-end end))
+ (funcall (sb-kernel:ansi-stream-sout stream)
+ stream data offset-start offset-end))
+ (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
+ string)
+
+(defun %ansi-stream-write-sequence (seq stream start %end)
+ (declare (type sequence seq)
+ (type sb-kernel:ansi-stream stream)
+ (type sb-int:index start)
+ (type sb-kernel:sequence-end %end)
+ (values sequence))
+ (let ((end (or %end (length seq))))
+ (declare (type sb-int:index end))
+ (etypecase seq
+ (list
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ ;; TODO: Replace these with ansi-stream specific
+ ;; functions too.
+ #'write-char
+ #'write-byte)))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)) seq)
+ (declare (type list rem)
+ (type sb-int:index i))
+ (funcall write-function (first rem) stream))))
+ (string
+ (%ansi-stream-write-string seq stream start end))
+ (vector
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ ;; TODO: Replace these with ansi-stream specific
+ ;; functions too.
+ #'write-char
+ #'write-byte)))
+ (do ((i start (1+ i)))
+ ((>= i end) seq)
+ (declare (type sb-int:index i))
+ (funcall write-function (aref seq i) stream)))))))
+
+
+;;;
+;;; USER-LEVEL FUNCTIONS
+;;;
+
+(defmethod open-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :input :output))
+
+(defmethod input-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :input))
+
+(defmethod output-stream-p ((stream simple-stream))
+ (any-stream-instance-flags stream :output))
+
+(defmethod stream-element-type ((stream simple-stream))
+ '(unsigned-byte 8))
+
+(defun interactive-stream-p (stream)
+ "Return true if Stream does I/O on a terminal or other interactive device."
+ (etypecase stream
+ (simple-stream
+ (%check stream :open)
+ (any-stream-instance-flags stream :interactive))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
+ (fundamental-stream
+ nil)))
+
+(defun (setf interactive-stream-p) (flag stream)
+ (typecase stream
+ (simple-stream
+ (%check stream :open)
+ (if flag
+ (add-stream-instance-flags stream :interactive)
+ (remove-stream-instance-flags stream :interactive)))
+ (t
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'simple-stream
+ :format-control "Can't set interactive flag on ~S."
+ :format-arguments (list stream)))))
+
+(defun file-string-length (stream object)
+ (declare (type (or string character) object) (type stream stream))
+ "Return the delta in STREAM's FILE-POSITION that would be caused by writing
+ OBJECT to STREAM. Non-trivial only in implementations that support
+ international character sets."
+ (typecase stream
+ (simple-stream (%file-string-length stream object))
+ (t
+ (etypecase object
+ (character 1)
+ (string (length object))))))
+
+(defun stream-external-format (stream)
+ "Returns Stream's external-format."
+ (etypecase stream
+ (simple-stream
+ (with-stream-class (simple-stream)
+ (%check stream :open)
+ (sm external-format stream)))
+ (ansi-stream
+ :default)
+ (fundamental-stream
+ :default)))
+
+(defun open (filename &rest options
+ &key (direction :input)
+ (element-type 'character element-type-given)
+ if-exists if-does-not-exist
+ (external-format :default)
+ class mapped input-handle output-handle
+ &allow-other-keys)
+ "Return a stream which reads from or writes to Filename.
+ Defined keywords:
+ :direction - one of :input, :output, :io, or :probe
+ :element-type - type of object to read or write, default BASE-CHAR
+ :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
+ :overwrite, :append, :supersede or NIL
+ :if-does-not-exist - one of :error, :create or NIL
+ :external-format - :default
+ See the manual for details.
+
+ The following are simple-streams-specific additions:
+ :class - class of stream object to be created
+ :mapped - T to open a memory-mapped file
+ :input-handle - a stream or Unix file descriptor to read from
+ :output-handle - a stream or Unix file descriptor to write to"
+ (declare (ignore element-type external-format input-handle output-handle
+ if-exists if-does-not-exist))
+ (let ((class (or class 'sb-sys::file-stream))
+ (options (copy-list options))
+ (filespec (merge-pathnames filename)))
+ (cond ((eq class 'sb-sys::file-stream)
+ (remf options :class)
+ (remf options :mapped)
+ (remf options :input-handle)
+ (remf options :output-handle)
+ (apply #'open-fd-stream filespec options))
+ ((subtypep class 'simple-stream)
+ (when element-type-given
+ (cerror "Do it anyway."
+ "Can't create simple-streams with an element-type."))
+ (when (and (eq class 'file-simple-stream) mapped)
+ (setq class 'mapped-file-simple-stream)
+ (setf (getf options :class) 'mapped-file-simple-stream))
+ (when (subtypep class 'file-simple-stream)
+ (when (eq direction :probe)
+ (setq class 'probe-simple-stream)))
+ (apply #'make-instance class :filename filespec options))
+ ((subtypep class 'sb-gray:fundamental-stream)
+ (remf options :class)
+ (remf options :mapped)
+ (remf options :input-handle)
+ (remf options :output-handle)
+ (make-instance class :lisp-stream
+ (apply #'open-fd-stream filespec options))))))
+
+
+(declaim (inline read-byte read-char read-char-no-hang unread-char))
+
+(defun read-byte (stream &optional (eof-error-p t) eof-value)
+ "Returns the next byte of the Stream."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%read-byte stream eof-error-p eof-value))
+ (ansi-stream
+ (%ansi-stream-read-byte stream eof-error-p eof-value t))
+ (fundamental-stream
+ (let ((char (sb-gray:stream-read-byte stream)))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+(defun read-char (&optional (stream *standard-input*) (eof-error-p t)
+ eof-value recursive-p)
+ "Inputs a character from Stream and returns it."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%read-char stream eof-error-p eof-value recursive-p t))
+ (ansi-stream
+ (%ansi-stream-read-char stream eof-error-p eof-value t))
+ (fundamental-stream
+ (let ((char (sb-gray:stream-read-char stream)))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+(defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
+ eof-value recursive-p)
+ "Returns the next character from the Stream if one is availible, or nil."
+ (declare (ignore recursive-p))
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check stream :input)
+ (with-stream-class (simple-stream)
+ (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
+ (ansi-stream
+ (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
+ (%ansi-stream-read-char stream eof-error-p eof-value t)
+ nil))
+ (fundamental-stream
+ (let ((char (sb-gray:stream-read-char-no-hang stream)))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+(defun unread-char (character &optional (stream *standard-input*))
+ "Puts the Character back on the front of the input Stream."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%unread-char stream character))
+ (ansi-stream
+ (%ansi-stream-unread-char character stream))
+ (fundamental-stream
+ (sb-gray:stream-unread-char stream character))))
+ nil)
+
+(declaim (notinline read-byte read-char read-char-no-hang unread-char))
+
+(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
+ (eof-error-p t) eof-value recursive-p)
+ "Peeks at the next character in the input Stream. See manual for details."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%peek-char stream peek-type eof-error-p eof-value recursive-p))
+ (ansi-stream
+ (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
+ (cond ((eq char eof-value) char)
+ ((characterp peek-type)
+ (do ((char char (%ansi-stream-read-char stream eof-error-p
+ eof-value t)))
+ ((or (eq char eof-value) (char= char peek-type))
+ (unless (eq char eof-value)
+ (%ansi-stream-unread-char char stream))
+ char)))
+ ((eq peek-type t)
+ (do ((char char (%ansi-stream-read-char stream eof-error-p
+ eof-value t)))
+ ((or (eq char eof-value)
+ (not (sb-int:whitespace-char-p char)))
+ (unless (eq char eof-value)
+ (%ansi-stream-unread-char char stream))
+ char)))
+ (t
+ (%ansi-stream-unread-char char stream)
+ char))))
+ (fundamental-stream
+ (cond ((characterp peek-type)
+ (do ((char (sb-gray:stream-read-char stream)
+ (sb-gray:stream-read-char stream)))
+ ((or (eq char :eof) (char= char peek-type))
+ (cond ((eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+ (t
+ (sb-gray:stream-unread-char stream char)
+ char)))))
+ ((eq peek-type t)
+ (do ((char (sb-gray:stream-read-char stream)
+ (sb-gray:stream-read-char stream)))
+ ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
+ (cond ((eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+ (t
+ (sb-gray:stream-unread-char stream char)
+ char)))))
+ (t
+ (let ((char (sb-gray:stream-peek-char stream)))
+ (if (eq char :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))))
+
+(defun listen (&optional (stream *standard-input*) (width 1))
+ "Returns T if Width octets are available on the given Stream. If Width
+ is given as 'character, check for a character."
+ ;; WIDTH is number of octets which must be available; any value
+ ;; other than 1 is treated as 'character.
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%listen stream width))
+ (ansi-stream
+ (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
+ sb-impl::+ansi-stream-in-buffer-length+)
+ ;; Test for T explicitly since misc methods return :EOF sometimes.
+ (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
+ t)))
+ (fundamental-stream
+ (sb-gray:stream-listen stream)))))
+
+
+(defun read-line (&optional (stream *standard-input*) (eof-error-p t)
+ eof-value recursive-p)
+ "Returns a line of text read from the Stream as a string, discarding the
+ newline character."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%read-line stream eof-error-p eof-value recursive-p))
+ (ansi-stream
+ (%ansi-stream-read-line stream eof-error-p eof-value))
+ (fundamental-stream
+ (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
+ (if (and eof (zerop (length string)))
+ (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
+ (values string eof)))))))
+
+(defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
+ "Destructively modify SEQ by reading elements from STREAM.
+ SEQ is bounded by START and END. SEQ is destructively modified by
+ copying successive elements into it from STREAM. If the end of file
+ for STREAM is reached before copying all elements of the subsequence,
+ then the extra elements near the end of sequence are not updated, and
+ the index of the next element is returned."
+ (let ((stream (sb-impl::in-synonym-of stream))
+ (end (or end (length seq))))
+ (etypecase stream
+ (simple-stream
+ (with-stream-class (simple-stream stream)
+ (%read-sequence stream seq start end partial-fill)))
+ (ansi-stream
+ (%ansi-stream-read-sequence seq stream start end))
+ (fundamental-stream
+ (sb-gray:stream-read-sequence stream seq start end)))))
+
+(defun clear-input (&optional (stream *standard-input*) buffer-only)
+ "Clears any buffered input associated with the Stream."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%clear-input stream buffer-only))
+ (ansi-stream
+ (setf (sb-kernel:ansi-stream-in-index stream)
+ sb-impl::+ansi-stream-in-buffer-length+)
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
+ (fundamental-stream
+ (sb-gray:stream-clear-input stream))))
+ nil)
+
+(defun write-byte (integer stream)
+ "Outputs an octet to the Stream."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%write-byte stream integer))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
+ (fundamental-stream
+ (sb-gray:stream-write-byte stream integer))))
+ integer)
+
+(defun write-char (character &optional (stream *standard-output*))
+ "Outputs the Character to the Stream."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%write-char stream character))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-out stream) stream character))
+ (fundamental-stream
+ (sb-gray:stream-write-char stream character))))
+ character)
+
+(defun write-string (string &optional (stream *standard-output*)
+ &key (start 0) (end nil))
+ "Outputs the String to the given Stream."
+ (let ((stream (sb-impl::out-synonym-of stream))
+ (end (or end (length string))))
+ (etypecase stream
+ (simple-stream
+ (%write-string stream string start end)
+ string)
+ (ansi-stream
+ (%ansi-stream-write-string string stream start end))
+ (fundamental-stream
+ (sb-gray:stream-write-string stream string start end)))))
+
+(defun write-line (string &optional (stream *standard-output*)
+ &key (start 0) end)
+ (declare (type string string))
+ ;; FIXME: Why is there this difference between the treatments of the
+ ;; STREAM argument in WRITE-STRING and WRITE-LINE?
+ (let ((stream (sb-impl::out-synonym-of stream))
+ (end (or end (length string))))
+ (etypecase stream
+ (simple-stream
+ (%check stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-chars string stream start end)
+ (funcall-stm-handler-2 j-write-char #\Newline stream)))
+ (ansi-stream
+ (%ansi-stream-write-string string stream start end)
+ (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
+ (fundamental-stream
+ (sb-gray:stream-write-string stream string start end)
+ (sb-gray:stream-terpri stream))))
+ string)
+
+(defun write-sequence (seq stream &key (start 0) (end nil))
+ "Write the elements of SEQ bounded by START and END to STREAM."
+ (let ((stream (sb-impl::out-synonym-of stream))
+ (end (or end (length seq))))
+ (etypecase stream
+ (simple-stream
+ (%write-sequence stream seq start end))
+ (ansi-stream
+ (%ansi-stream-write-sequence seq stream start end))
+ (fundamental-stream
+ (sb-gray:stream-write-sequence stream seq start end)))))
+
+(defun terpri (&optional (stream *standard-output*))
+ "Outputs a new line to the Stream."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-char #\Newline stream)))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
+ (fundamental-stream
+ (sb-gray:stream-terpri stream))))
+ nil)
+
+(defun fresh-line (&optional (stream *standard-output*))
+ "Outputs a new line to the Stream if it is not positioned at the beginning of
+ a line. Returns T if it output a new line, nil otherwise."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%fresh-line stream))
+ (ansi-stream
+ (when (/= (or (sb-kernel:charpos stream) 1) 0)
+ (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
+ t))
+ (fundamental-stream
+ (sb-gray:stream-fresh-line stream)))))
+
+(defun finish-output (&optional (stream *standard-output*))
+ "Attempts to ensure that all output sent to the Stream has reached its
+ destination, and only then returns."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%finish-output stream))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
+ (fundamental-stream
+ (sb-gray:stream-finish-output stream))))
+ nil)
+
+(defun force-output (&optional (stream *standard-output*))
+ "Attempts to force any buffered output to be sent."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%force-output stream))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
+ (fundamental-stream
+ (sb-gray:stream-force-output stream))))
+ nil)
+
+(defun clear-output (&optional (stream *standard-output*))
+ "Clears the given output Stream."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%clear-output stream))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
+ (fundamental-stream
+ (sb-gray:stream-clear-output stream))))
+ nil)
+
+
+(defun file-position (stream &optional position)
+ "With one argument returns the current position within the file
+ File-Stream is open to. If the second argument is supplied, then
+ this becomes the new file position. The second argument may also
+ be :start or :end for the start and end of the file, respectively."
+ (declare (type (or (integer 0 *) (member nil :start :end)) position))
+ (etypecase stream
+ (simple-stream
+ (%file-position stream position))
+ (ansi-stream
+ (cond
+ (position
+ (setf (sb-kernel:ansi-stream-in-index stream)
+ sb-impl::+ansi-stream-in-buffer-length+)
+ (funcall (sb-kernel:ansi-stream-misc stream)
+ stream :file-position position))
+ (t
+ (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
+ stream :file-position nil)))
+ (when res
+ (- res
+ (- sb-impl::+ansi-stream-in-buffer-length+
+ (sb-kernel:ansi-stream-in-index stream))))))))))
+
+(defun file-length (stream)
+ "This function returns the length of the file that File-Stream is open to."
+ (etypecase stream
+ (simple-stream
+ (%file-length stream))
+ (ansi-stream
+ (progn (sb-impl::stream-must-be-associated-with-file stream)
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
+
+(defun charpos (&optional (stream *standard-output*))
+ "Returns the number of characters on the current line of output of the given
+ Stream, or Nil if that information is not availible."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (with-stream-class (simple-stream stream)
+ (%check stream :open)
+ (sm charpos stream)))
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
+ (fundamental-stream
+ (sb-gray:stream-line-column stream)))))
+
+(defun line-length (&optional (stream *standard-output*))
+ "Returns the number of characters in a line of output of the given
+ Stream, or Nil if that information is not availible."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check stream :output)
+ ;; TODO (sat 2003-04-02): a way to specify a line length would
+ ;; be good, I suppose. Returning nil here means
+ ;; sb-pretty::default-line-length is used.
+ nil)
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
+ (fundamental-stream
+ (sb-gray:stream-line-length stream)))))
+
+(defun wait-for-input-available (stream &optional timeout)
+ "Waits for input to become available on the Stream and returns T. If
+ Timeout expires, Nil is returned."
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (fixnum
+ (sb-sys:wait-until-fd-usable stream :input timeout))
+ (simple-stream
+ (%check stream :input)
+ (with-stream-class (simple-stream stream)
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ (wait-for-input-available (sm input-handle stream) timeout))))
+ (two-way-stream
+ (wait-for-input-available (two-way-stream-input-stream stream) timeout))
+ (synonym-stream
+ (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
+ timeout))
+ (sb-sys::file-stream
+ (or (< (sb-impl::fd-stream-in-index stream)
+ (length (sb-impl::fd-stream-in-buffer stream)))
+ (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
+
+;; Make PATHNAME and NAMESTRING work
+(defun sb-int:file-name (stream &optional new-name)
+ (typecase stream
+ (file-simple-stream
+ (with-stream-class (file-simple-stream stream)
+ (cond (new-name
+ (%file-rename stream new-name))
+ (t
+ (%file-name stream)))))
+ (sb-sys::file-stream
+ (cond (new-name
+ (setf (sb-impl::fd-stream-pathname stream) new-name)
+ (setf (sb-impl::fd-stream-file stream)
+ (sb-int:unix-namestring new-name nil))
+ t)
+ (t
+ (sb-impl::fd-stream-pathname stream))))))
+
+;;; bugfix
+
+;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or
+;;; remove it.
+#+nil
+(defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
+ (declare (type fundamental-stream stream) ;; this is a lie
+ (ignore arg2))
+ (case operation
+ (:listen
+ (ext:stream-listen stream))
+ (:unread
+ (ext:stream-unread-char stream arg1))
+ (:close
+ (close stream))
+ (:clear-input
+ (ext:stream-clear-input stream))
+ (:force-output
+ (ext:stream-force-output stream))
+ (:finish-output
+ (ext:stream-finish-output stream))
+ (:element-type
+ (stream-element-type stream))
+ (:interactive-p
+ (interactive-stream-p stream))
+ (:line-length
+ (ext:stream-line-length stream))
+ (:charpos
+ (ext:stream-line-column stream))
+ (:file-length
+ (file-length stream))
+ (:file-position
+ (file-position stream arg1))))
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
-;;; This code is in the public domain.
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
-;;; HELPER FUNCTIONS
+;;; **********************************************************************
;;;
+;;; Various functions needed by simple-streams
-;; All known stream flags. Note that the position in the constant
-;; list is significant (cf. %flags below).
-(sb-int:defconstant-eqx +flag-bits+
- '(:simple ; instance is valid
- :input :output ; direction
- :dual :string ; type of stream
- :eof ; latched EOF
- :dirty ; output buffer needs write
- :interactive) ; interactive stream
- #'equal)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %flags (flags)
- (loop for flag in flags
- as pos = (position flag +flag-bits+)
- when (eq flag :gray) do
- (error "Gray streams not supported.")
- if pos
- sum (ash 1 pos) into bits
- else
- collect flag into unused
- finally (when unused
- (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
- (length unused) unused))
- (return bits))))
-
-;;; Setup an environment where sm, funcall-stm-handler and
-;;; funcall-stm-handler-2 are valid and efficient for a stream of type
-;;; class-name or for the stream argument (in which case the
-;;; class-name argument is ignored). In nested with-stream-class
-;;; forms, the inner with-stream-class form must specify a stream
-;;; argument if the outer one specifies one, or the wrong object will
-;;; be accessed.
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro with-stream-class ((class-name &optional stream) &body body)
- (if stream
- (let ((stm (gensym "STREAM"))
- (slt (gensym "SV")))
- `(let* ((,stm ,stream)
- (,slt (sb-pcl::std-instance-slots ,stm)))
- (declare (type ,class-name ,stm) (ignorable ,slt))
- (macrolet ((sm (slot-name stream)
- (declare (ignore stream))
- (let ((slot-access (gethash slot-name
- *slot-access-functions*)))
- (cond ((sb-int:fixnump (cdr slot-access))
- ;; Get value in nth slot
- `(the ,(car slot-access)
- (sb-pcl::clos-slots-ref ,',slt
- ,(cdr slot-access))))
- (slot-access
- ;; Call memorized function
- `(the ,(car slot-access) (,(cdr slot-access)
- ,',stm)))
- (t
- ;; Use slot-value
- `(slot-value ,',stm ',slot-name)))))
- (add-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
- ,(%flags flags))))
- (remove-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
- ,(%flags flags))))
- (any-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(not (zerop (logand (sm %flags ,',stm)
- ,(%flags flags))))))
- ,@body)))
- `(macrolet ((sm (slot-name stream)
- (let ((slot-access (gethash slot-name
- *slot-access-functions*)))
- (cond ((sb-int:fixnump (cdr slot-access))
- `(the ,(car slot-access)
- (sb-pcl::clos-slots-ref
- (sb-pcl::std-instance-slots ,stream)
- ,(cdr slot-access))))
- (slot-access
- `(the ,(car slot-access) (,(cdr slot-access)
- ,stream)))
- (t `(slot-value ,stream ',slot-name))))))
- ,@body)))
-
-
-(defmacro with-stream-class ((class-name &optional stream) &body body)
- (if stream
- (let ((stm (gensym "STREAM"))
- (slt (gensym "SV")))
- `(let* ((,stm ,stream)
- (,slt (sb-kernel:%instance-ref ,stm 1)))
- (declare (type ,class-name ,stm)
- (type simple-vector ,slt)
- (ignorable ,slt))
- (macrolet ((sm (slot-name stream)
- (declare (ignore stream))
- #-count-sm
- `(slot-value ,',stm ',slot-name)
- #+count-sm
- `(%sm ',slot-name ,',stm))
- (add-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
- ,(%flags flags))))
- (remove-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
- ,(%flags flags))))
- (any-stream-instance-flags (stream &rest flags)
- (declare (ignore stream))
- `(not (zerop (logand (sm %flags ,',stm)
- ,(%flags flags))))))
- ,@body)))
- `(macrolet ((sm (slot-name stream)
- #-count-sm
- `(slot-value ,stream ',slot-name)
- #+count-sm
- `(%sm ',slot-name ,stream)))
- ,@body)))
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro sm (slot-name stream)
- (let ((slot-access (gethash slot-name *slot-access-functions*)))
- (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
- (cond ((sb-int:fixnump (cdr slot-access))
- `(the ,(car slot-access) (sb-pcl::clos-slots-ref
- (sb-pcl::std-instance-slots ,stream)
- ,(cdr slot-access))))
- (slot-access
- `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
- (t `(slot-value ,stream ',slot-name)))))
-
-
-(defmacro sm (slot-name stream)
- "Access the named slot in Stream."
- (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
- `(slot-value ,stream ',slot-name))
-
-(defmacro funcall-stm-handler (slot-name stream &rest args)
- (let ((s (gensym)))
- `(let ((,s ,stream))
- (funcall (sm ,slot-name ,s) ,s ,@args))))
-
-(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
- (let ((s (gensym)))
- `(let ((,s ,stream))
- (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
-
-(defmacro add-stream-instance-flags (stream &rest flags)
- "Set the given flag bits in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro remove-stream-instance-flags (stream &rest flags)
- "Clear the given flag bits in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro any-stream-instance-flags (stream &rest flags)
- "Determine whether any one of the FLAGS is set in STREAM."
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
-
-(defmacro simple-stream-dispatch (stream single dual string)
- (let ((s (gensym "STREAM")))
- `(let ((,s ,stream))
- (with-stream-class (simple-stream ,s)
- (let ((%flags (sm %flags ,s)))
- (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
- ,single)
- ((zerop (logand %flags ,(%flags '(:string))))
- ,dual)
- (t
- ,string)))))))
-
-(declaim (inline buffer-sap bref (setf bref) buffer-copy))
+(declaim (inline buffer-sap bref (setf bref) buffer-copy
+ allocate-buffer free-buffer))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
(push buffer sb-impl::*available-buffers*))
t)
+
+(defun make-control-table (&rest inits)
+ (let ((table (make-array 32 :initial-element nil)))
+ (do* ((char (pop inits) (pop inits))
+ (func (pop inits) (pop inits)))
+ ((null char))
+ (when (< (char-code char) 32)
+ (setf (aref table (char-code char)) func)))
+ table))
+
+(defun std-newline-out-handler (stream character)
+ (declare (ignore character))
+ (with-stream-class (simple-stream stream)
+ (setf (sm charpos stream) -1)
+ nil))
+
+(defun std-tab-out-handler (stream character)
+ (declare (ignore character))
+ (with-stream-class (simple-stream stream)
+ (let ((col (sm charpos stream)))
+ (when col
+ (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
+ nil))
+
+(defun std-dc-newline-in-handler (stream character)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
+ character))
+
+(defvar *std-control-out-table*
+ (make-control-table #\Newline #'std-newline-out-handler
+ #\Tab #'std-tab-out-handler))
+
+(defvar *default-external-format* :iso8859-1)
+
+(defvar *external-formats* (make-hash-table))
+(defvar *external-format-aliases* (make-hash-table))
+
+(defstruct (external-format
+ (:conc-name ef-)
+ (:print-function %print-external-format)
+ (:constructor make-external-format (name octets-to-char
+ char-to-octets)))
+ (name (sb-int:missing-arg) :type keyword :read-only t)
+ (octets-to-char (sb-int:missing-arg) :type function :read-only t)
+ (char-to-octets (sb-int:missing-arg) :type function :read-only t))
+
+(defun %print-external-format (ef stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (ef stream :type t :identity t)
+ (princ (ef-name ef) stream)))
+
+(defmacro define-external-format (name octets-to-char char-to-octets)
+ `(macrolet ((octets-to-char ((state input unput) &body body)
+ `(lambda (,state ,input ,unput)
+ (declare (type (function () (unsigned-byte 8)) ,input)
+ (type (function (sb-int:index) t) ,unput)
+ (ignorable ,state ,input ,unput)
+ (values character sb-int:index t))
+ ,@body))
+ (char-to-octets ((char state output) &body body)
+ `(lambda (,char ,state ,output)
+ (declare (type character ,char)
+ (type (function ((unsigned-byte 8)) t) ,output)
+ (ignorable state ,output)
+ (values t))
+ ,@body)))
+ (setf (gethash ,name *external-formats*)
+ (make-external-format ,name ,octets-to-char ,char-to-octets))))
+
+;;; TODO: make this work
+(defun load-external-format-aliases ()
+ (let ((*package* (find-package "KEYWORD")))
+ (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
+ (when stm
+ (do ((alias (read stm nil stm) (read stm nil stm))
+ (value (read stm nil stm) (read stm nil stm)))
+ ((or (eq alias stm) (eq value stm))
+ (unless (eq alias stm)
+ (warn "External-format aliases file ends early.")))
+ (if (and (keywordp alias) (keywordp value))
+ (setf (gethash alias *external-format-aliases*) value)
+ (warn "Bad entry in external-format aliases file: ~S => ~S."
+ alias value)))))))
+
+(defun find-external-format (name &optional (error-p t))
+ (when (external-format-p name)
+ (return-from find-external-format name))
+
+ (when (eq name :default)
+ (setq name *default-external-format*))
+
+ ;; TODO: make this work
+ #+nil
+ (unless (ext:search-list-defined-p "ef:")
+ (setf (ext:search-list "ef:") '("library:ef/")))
+
+ (when (zerop (hash-table-count *external-format-aliases*))
+ (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
+ (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
+ (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
+ (load-external-format-aliases))
+
+ (do ((tmp (gethash name *external-format-aliases*)
+ (gethash tmp *external-format-aliases*))
+ (cnt 0 (1+ cnt)))
+ ((or (null tmp) (= cnt 50))
+ (unless (null tmp)
+ (error "External-format aliasing depth exceeded.")))
+ (setq name tmp))
+
+ (or (gethash name *external-formats*)
+ (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
+ (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
+ (gethash name *external-formats*))
+ (if error-p (error "External format ~S not found." name) nil)))
+
+(define-condition void-external-format (error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Attempting I/O through void external-format."))))
+
+(define-external-format :void
+ (octets-to-char (state input unput)
+ (declare (ignore state input unput))
+ (error 'void-external-format))
+ (char-to-octets (char state output)
+ (declare (ignore char state output))
+ (error 'void-external-format)))
+
+(define-external-format :iso8859-1
+ (octets-to-char (state input unput)
+ (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+ (values (code-char (funcall input)) 1 state))
+ (char-to-octets (char state output)
+ (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+ (let ((code (char-code char)))
+ #-(or)
+ (funcall output code)
+ #+(or)
+ (if (< code 256)
+ (funcall output code)
+ (funcall output (char-code #\?))))
+ state))
+
+(defmacro octets-to-char (external-format state count input unput)
+ (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
+ `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
+ (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
+ (setf ,state ,tmp3 ,count ,tmp2)
+ ,tmp1)))
+
+(defmacro char-to-octets (external-format char state output)
+ `(progn
+ (setf ,state (funcall (ef-char-to-octets ,external-format)
+ ,char ,state ,output))
+ nil))
+
+(defun string-to-octets (string &key (start 0) end (external-format :default))
+ (declare (type string string)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
+ (let ((ef (find-external-format external-format))
+ (buffer (make-array (length string) :element-type '(unsigned-byte 8)))
+ (ptr 0)
+ (state nil))
+ (flet ((out (b)
+ (setf (aref buffer ptr) b)
+ (when (= (incf ptr) (length buffer))
+ (setq buffer (adjust-array buffer (* 2 ptr))))))
+ (dotimes (i (- (or end (length string)) start))
+ (declare (type sb-int:index i))
+ (char-to-octets ef (char string (+ start i)) state #'out))
+ (sb-kernel:shrink-vector buffer ptr))))
+
+(defun octets-to-string (octets &key (start 0) end (external-format :default))
+ (declare (type vector octets)
+ (type sb-int:index start)
+ (type (or null sb-int:index) end))
+ (let ((ef (find-external-format external-format))
+ (end (1- (or end (length octets))))
+ (string (make-string (length octets)))
+ (ptr (1- start))
+ (pos -1)
+ (count 0)
+ (state nil))
+ (flet ((input ()
+ (aref octets (incf ptr)))
+ (unput (n)
+ (decf ptr n)))
+ (loop until (>= ptr end)
+ do (setf (schar string (incf pos))
+ (octets-to-char ef state count #'input #'unput))))
+ (sb-kernel:shrink-vector string (1+ pos))))
+
+(defun vector-elt-width (vector)
+ ;; Return octet-width of vector elements
+ (etypecase vector
+ ;; (simple-array fixnum (*)) not supported
+ ;; (simple-array base-char (*)) treated specially; don't call this
+ ((simple-array bit (*)) 1)
+ ((simple-array (unsigned-byte 2) (*)) 1)
+ ((simple-array (unsigned-byte 4) (*)) 1)
+ ((simple-array (signed-byte 8) (*)) 1)
+ ((simple-array (unsigned-byte 8) (*)) 1)
+ ((simple-array (signed-byte 16) (*)) 2)
+ ((simple-array (unsigned-byte 16) (*)) 2)
+ ((simple-array (signed-byte 32) (*)) 4)
+ ((simple-array (unsigned-byte 32) (*)) 4)
+ ((simple-array single-float (*)) 4)
+ ((simple-array double-float (*)) 8)
+ ((simple-array (complex single-float) (*)) 8)
+ ((simple-array (complex double-float) (*)) 16)))
+
+#-(or big-endian little-endian)
+(eval-when (:compile-toplevel)
+ (push sb-c::*backend-byte-order* *features*))
+
+(defun endian-swap-value (vector endian-swap)
+ #+big-endian (declare (ignore vector))
+ (case endian-swap
+ (:network-order #+big-endian 0
+ #+little-endian (1- (vector-elt-width vector)))
+ (:byte-8 0)
+ (:byte-16 1)
+ (:byte-32 3)
+ (:byte-64 7)
+ (:byte-128 15)
+ (otherwise endian-swap)))
+
+#+(or)
+(defun %read-vector (vector stream start end endian-swap blocking)
+ (declare (type (kernel:simple-unboxed-array (*)) vector)
+ (type stream stream))
+ ;; move code from read-vector
+ )
+
+#+(or)
+(defun %write-vector (... blocking)
+ ;; implement me
+ )
+
+(defun read-octets (stream buffer start end blocking)
+ (declare (type simple-stream stream)
+ (type (or null simple-stream-buffer) buffer)
+ (type fixnum start)
+ (type (or null fixnum) end)
+ (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (with-stream-class (simple-stream stream)
+ (let ((fd (sm input-handle stream))
+ (end (or end (sm buf-len stream)))
+ (buffer (or buffer (sm buffer stream))))
+ (declare (fixnum end))
+ (typecase fd
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :input
+ (if blocking nil 0))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t (block nil
+ (let ((count 0))
+ (declare (type fixnum count))
+ (tagbody
+ again
+ ;; Avoid CMUCL gengc write barrier
+ (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+ ((>= i end))
+ (declare (type fixnum i))
+ (setf (bref buffer i) 0))
+ (setf (bref buffer (1- end)) 0)
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-read fd (buffer-sap buffer start)
+ (the fixnum (- end start)))
+ (declare (type (or null fixnum) bytes)
+ (type (integer 0 100) errno))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ((and blocking
+ (or (= errno ;;sb-unix:eagain
+ ;; TODO: move
+ ;; eagain into
+ ;; sb-unix
+ 11)
+ (= errno sb-unix:ewouldblock)))
+ (sb-sys:wait-until-fd-usable fd :input nil)
+ (go again))
+ (t (return (- -10 errno)))))
+ ((zerop count) (return -1))
+ (t (return count)))))))))))
+ (t (%read-vector buffer fd start end :byte-8
+ (if blocking :bnb nil)))))))
+
+(defun write-octets (stream buffer start end blocking)
+ (declare (type simple-stream stream)
+ (type simple-stream-buffer buffer)
+ (type fixnum start)
+ (type (or null fixnum) end))
+ (with-stream-class (simple-stream stream)
+ (when (sm handler stream)
+ (do ()
+ ((null (sm pending stream)))
+ (sb-sys:serve-all-events)))
+
+ (let ((fd (sm output-handle stream))
+ (end (or end (length buffer))))
+ (typecase fd
+ (fixnum
+ (let ((flag (sb-sys:wait-until-fd-usable fd :output
+ (if blocking nil 0))))
+ (cond
+ ((and (not blocking) (= start end)) (if flag -3 0))
+ ((and (not blocking) (not flag)) 0)
+ (t
+ (block nil
+ (let ((count 0))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start
+ (- end start))
+ (when bytes
+ (incf count bytes)
+ (incf start bytes))
+ (cond ((null bytes)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ;; don't block for subsequent chars
+ (t (return (- -10 errno)))))
+ (t (return count)))))))))))
+ (t (error "implement me"))))))
+
+(defun do-some-output (stream)
+ ;; Do some pending output; return T if completed, NIL if more to do
+ (with-stream-class (simple-stream stream)
+ (let ((fd (sm output-handle stream)))
+ (loop
+ (let ((list (pop (sm pending stream))))
+ (unless list
+ (sb-sys:remove-fd-handler (sm handler stream))
+ (setf (sm handler stream) nil)
+ (return t))
+ (let* ((buffer (first list))
+ (start (second list))
+ (end (third list))
+ (len (- end start)))
+ (declare (type simple-stream-buffer buffer)
+ (type sb-int:index start end len))
+ (tagbody again
+ (multiple-value-bind (bytes errno)
+ (sb-unix:unix-write fd (buffer-sap buffer) start len)
+ (cond ((null bytes)
+ (if (= errno sb-unix:eintr)
+ (go again)
+ (progn (push list (sm pending stream))
+ (return nil))))
+ ((< bytes len)
+ (setf (second list) (+ start bytes))
+ (push list (sm pending stream))
+ (return nil))
+ ((= bytes len)
+ (free-buffer buffer)))))))))))
+
+(defun queue-write (stream buffer start end)
+ ;; Queue a write; return T if buffer needs changing, NIL otherwise
+ (declare (type simple-stream stream)
+ (type simple-stream-buffer buffer)
+ (type sb-int:index start end))
+ (with-stream-class (simple-stream stream)
+ (when (sm handler stream)
+ (unless (do-some-output stream)
+ (let ((last (last (sm pending stream))))
+ (setf (cdr last) (list (list buffer start end)))
+ (return-from queue-write t))))
+ (let ((bytes (write-octets stream buffer start end nil)))
+ (unless (or (= bytes (- end start)) ; completed
+ (= bytes -3)) ; empty buffer; shouldn't happen
+ (setf (sm pending stream) (list (list buffer start end)))
+ (setf (sm handler stream)
+ (sb-sys:add-fd-handler (sm output-handle stream) :output
+ (lambda (fd)
+ (declare (ignore fd))
+ (do-some-output stream))))
+ t))))
+
+
+
+
(defun %fd-open (pathname direction if-exists if-exists-given
if-does-not-exist if-does-not-exist-given)
(declare (type pathname pathname)
;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; This code is in the public domain.
+;;; Sbcl port by Rudi Schlatte.
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;;
+;;; **********************************************************************
+;;;
+;;; Macros needed by the simple-streams implementation
-;;; This is just for compatibility with Franz demo code
+(in-package "SB-SIMPLE-STREAMS")
+
+(defmacro def-stream-class (name superclasses slots &rest options)
+ `(defclass ,name ,superclasses ,slots ,@options))
+
+
+;; All known stream flags. Note that the position in the constant
+;; list is significant (cf. %flags below).
+(sb-int:defconstant-eqx +flag-bits+
+ '(:simple ; instance is valid
+ :input :output ; direction
+ :dual :string ; type of stream
+ :eof ; latched EOF
+ :dirty ; output buffer needs write
+ :interactive) ; interactive stream
+ #'equal)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun %flags (flags)
+ (loop for flag in flags
+ as pos = (position flag +flag-bits+)
+ when (eq flag :gray) do
+ (error "Gray streams not supported.")
+ if pos
+ sum (ash 1 pos) into bits
+ else
+ collect flag into unused
+ finally (when unused
+ (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
+ (length unused) unused))
+ (return bits))))
+
+;;; Setup an environment where sm, funcall-stm-handler and
+;;; funcall-stm-handler-2 are valid and efficient for a stream of type
+;;; class-name or for the stream argument (in which case the
+;;; class-name argument is ignored). In nested with-stream-class
+;;; forms, the inner with-stream-class form must specify a stream
+;;; argument if the outer one specifies one, or the wrong object will
+;;; be accessed.
+
+(defmacro with-stream-class ((class-name &optional stream) &body body)
+ (if stream
+ (let ((stm (gensym "STREAM"))
+ (slt (gensym "SV")))
+ `(let* ((,stm ,stream)
+ (,slt (sb-kernel:%instance-ref ,stm 1)))
+ (declare (type ,class-name ,stm)
+ (type simple-vector ,slt)
+ (ignorable ,slt))
+ (macrolet ((sm (slot-name stream)
+ (declare (ignore stream))
+ #-count-sm
+ `(slot-value ,',stm ',slot-name)
+ #+count-sm
+ `(%sm ',slot-name ,',stm))
+ (add-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(setf (sm %flags ,',stm) (logior (the fixnum (sm %flags ,',stm))
+ ,(%flags flags))))
+ (remove-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(setf (sm %flags ,',stm) (logandc2 (the fixnum (sm %flags ,',stm))
+ ,(%flags flags))))
+ (any-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(not (zerop (logand (the fixnum (sm %flags ,',stm))
+ ,(%flags flags))))))
+ ,@body)))
+ `(macrolet ((sm (slot-name stream)
+ #-count-sm
+ `(slot-value ,stream ',slot-name)
+ #+count-sm
+ `(%sm ',slot-name ,stream)))
+ ,@body)))
+
+(defmacro sm (slot-name stream)
+ "Access the named slot in Stream."
+ (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
+ `(slot-value ,stream ',slot-name))
+
+(defmacro funcall-stm-handler (slot-name stream &rest args)
+ "Call the strategy function named by Slot-Name on Stream."
+ (let ((s (gensym)))
+ `(let ((,s ,stream))
+ (funcall (sm ,slot-name ,s) ,s ,@args))))
+
+(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
+ "Call the strategy function named by Slot-Name on Stream."
+ (let ((s (gensym)))
+ `(let ((,s ,stream))
+ (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
+
+(defmacro add-stream-instance-flags (stream &rest flags)
+ "Set the given Flags in Stream."
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (add-stream-instance-flags ,s ,@flags)))))
+
+(defmacro remove-stream-instance-flags (stream &rest flags)
+ "Clear the given Flags in Stream."
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (remove-stream-instance-flags ,s ,@flags)))))
+
+(defmacro any-stream-instance-flags (stream &rest flags)
+ "Determine whether any one of the Flags is set in Stream."
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (any-stream-instance-flags ,s ,@flags)))))
+
+(defmacro simple-stream-dispatch (stream single dual string)
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (let ((%flags (sm %flags ,s)))
+ (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
+ ,single)
+ ((zerop (logand %flags ,(%flags '(:string))))
+ ,dual)
+ (t
+ ,string)))))))
+
+(defmacro simple-stream-dispatch-2 (stream non-string string)
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (let ((%flags (sm %flags ,s)))
+ (cond ((zerop (logand %flags ,(%flags '(:string))))
+ ,non-string)
+ (t
+ ,string)))))))
+
+
+;;;; The following two forms are for Franz source-compatibility,
+;;;; disabled at the moment.
+
+#+nil
(defpackage "EXCL"
- (:use "SB-SIMPLE-STREAM")
- (:import-from "SB-SIMPLE-STREAM"
+ (:use "SB-SIMPLE-STREAMS")
+ (:import-from "SB-SIMPLE-STREAMS"
"BUFFER" "BUFFPOS" "BUFFER-PTR"
"OUT-BUFFER" "MAX-OUT-POS"
"INPUT-HANDLE" "OUTPUT-HANDLE"
"MELDED-STREAM"
"J-READ-CHARS"))
-(use-package "SB-SIMPLE-STREAMS")
-
+#+nil
(provide :iodefs)
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Definition of Null-Simple-Stream
+
+(def-stream-class null-simple-stream (single-channel-simple-stream)
+ ())
+
+(declaim (ftype j-read-char-fn null-read-char))
+(defun null-read-char (stream eof-error-p eof-value blocking)
+ (declare (ignore blocking))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+
+(declaim (ftype j-read-chars-fn null-read-chars))
+(defun null-read-chars (stream string search start end blocking)
+ (declare (ignore stream string search start end blocking))
+ (values 0 :eof))
+
+(declaim (ftype j-unread-char-fn null-unread-char))
+(defun null-unread-char (stream relaxed)
+ (declare (ignore stream relaxed)))
+
+(declaim (ftype j-write-char-fn null-write-char))
+(defun null-write-char (character stream)
+ (declare (ignore stream))
+ character)
+
+(declaim (ftype j-write-chars-fn null-write-chars))
+(defun null-write-chars (string stream start end)
+ (declare (ignore string stream))
+ (- end start))
+
+(declaim (ftype j-listen-fn null-listen))
+(defun null-listen (stream)
+ (declare (ignore stream))
+ nil)
+
+(defmethod device-open ((stream null-simple-stream) options)
+ (with-stream-class (null-simple-stream stream)
+ (add-stream-instance-flags stream :simple :input :output)
+ ;;(install-single-channel-character-strategy
+ ;; stream (getf options :external-format :default) nil)
+ (setf (sm j-read-char stream) #'null-read-char
+ (sm j-read-chars stream) #'null-read-chars
+ (sm j-unread-char stream) #'null-unread-char
+ (sm j-write-char stream) #'null-write-char
+ (sm j-write-chars stream) #'null-write-chars
+ (sm j-listen stream) #'null-listen))
+ stream)
+
+(defmethod device-buffer-length ((stream null-simple-stream))
+ 256)
+
+(defmethod device-read ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer start end blocking))
+ -1)
+
+(defmethod device-write ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer blocking))
+ (- end start))
:depends-on (sb-bsd-sockets sb-posix)
:components ((:file "package")
(:file "fndb")
+ (:file "iodefs" :depends-on ("package"))
;;(:file "pcl")
;;(:file "ext-format" :depends-on ("package"))
- (:file "classes" :depends-on ("package"))
+ (:file "classes" :depends-on ("iodefs"))
(:file "internal" :depends-on ("classes"))
(:file "strategy" :depends-on ("internal"))
- (:file "cl" :depends-on ("internal" "fndb"))
- (:file "simple-streams" :depends-on ("cl" "strategy"))
+ (:file "impl" :depends-on ("internal" "fndb"))
+ (:file "file" :depends-on ("strategy"))
+ (:file "direct" :depends-on ("strategy"))
+ (:file "null" :depends-on ("strategy"))
+ (:file "socket" :depends-on ("strategy"))
+ (:file "string" :depends-on ("strategy"))
+ (:file "terminal" :depends-on ("strategy"))
;;(:file "gray-compat" :depends-on ("package"))
- ;;(:file "iodefs" :depends-on ("package"))
))
(defmethod perform :after ((o load-op)
*load-truename*)
"Directory for temporary test files.")
-(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
+(eval-when (:load-toplevel) (ensure-directories-exist *test-path* :verbose t))
;;; Non-destructive functional analog of REMF
(defun remove-key (key list)
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Socket-simple-stream and socket-base-simple-stream
+
+(def-stream-class socket-simple-stream (dual-channel-simple-stream)
+ (;; keep the socket around; it could be handy e.g. for querying peer
+ ;; host/port
+ (socket :initform nil :type (or sb-bsd-sockets:socket null)
+ :initarg :socket)))
+
+(def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
+ ())
+
+(defmethod device-open ((stream socket-simple-stream) options)
+ (let* ((remote-host (getf options :remote-host))
+ (remote-port (getf options :remote-port))
+ (socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp)))
+ (unless (and remote-host remote-port)
+ (error "~S requires :remote-host and :remote-port arguments"
+ 'socket-simple-stream))
+ (with-stream-class (socket-simple-stream stream)
+ (ecase (getf options :direction :input)
+ (:input (add-stream-instance-flags stream :input))
+ (:output (add-stream-instance-flags stream :output))
+ (:io (add-stream-instance-flags stream :input :output)))
+ (setf (sm socket stream) socket)
+ (sb-bsd-sockets:socket-connect socket remote-host remote-port)
+ (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
+ (when fd
+ (add-stream-instance-flags stream :dual :simple)
+ (when (any-stream-instance-flags stream :input)
+ (setf (sm input-handle stream) fd)
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm buffer stream) (allocate-buffer length)
+ (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm buf-len stream) length))))
+ (when (any-stream-instance-flags stream :output)
+ (setf (sm output-handle stream) fd)
+ (unless (sm out-buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm out-buffer stream) (allocate-buffer length)
+ (sm outpos stream) 0
+ (sm max-out-pos stream) length)))
+ (setf (sm control-out stream) *std-control-out-table*))
+ (sb-ext:cancel-finalization socket)
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-unix:unix-close fd)
+ (format *debug-io*
+ "~&;;; ** closed socket (fd ~D)~%" fd)))
+ ;; this should be done with (setf stream-external-format)
+ (let ((efmt (getf options :external-format :default)))
+ (compose-encapsulating-streams stream efmt)
+ (install-dual-channel-character-strategy (melding-stream stream)
+ efmt))
+ stream)))))
+
+(defmethod device-close ((stream socket-simple-stream) abort)
+ (with-stream-class (socket-simple-stream stream)
+ (sb-unix:unix-close (or (sm input-handle stream)
+ (sm output-handle stream)))
+ (when (sm buffer stream)
+ (free-buffer (sm buffer stream))
+ (setf (sm buffer stream) nil))
+ (when (sm out-buffer stream)
+ (free-buffer (sm out-buffer stream))
+ (setf (sm out-buffer stream) nil))
+ (sb-ext:cancel-finalization stream)
+ t))
+
+(defmethod device-open ((stream socket-base-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-write ((stream socket-base-simple-stream) buffer
+ start end blocking)
+ ;; @@2
+ (call-next-method))
+
;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; This code is in the public domain.
-
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
+;;;
+;;; **********************************************************************
+;;;
+;;; Strategy functions for base simple-stream classes
+;;;; Helper functions
-(defun sc-refill-buffer (stream blocking)
- (with-stream-class (single-channel-simple-stream stream)
- (when (any-stream-instance-flags stream :dirty)
- ;; FIXME: Implement flush-buffer failure protocol instead of
- ;; blocking here
- (sc-flush-buffer stream t))
+(defun refill-buffer (stream blocking)
+ (with-stream-class (simple-stream stream)
(let* ((unread (sm last-char-read-size stream))
- (buffer (sm buffer stream)))
- (unless (zerop unread)
- (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
+ (buffer (sm buffer stream))
+ (bufptr (sm buffer-ptr stream)))
+ (unless (or (zerop unread) (zerop bufptr))
+ (buffer-copy buffer (- bufptr unread) buffer 0 unread))
(let ((bytes (device-read stream nil unread nil blocking)))
(declare (type fixnum bytes))
(setf (sm buffpos stream) unread
unread))
bytes))))
+(defun sc-set-dirty (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm mode stream)
+ (if (<= (sm buffpos stream)
+ (sm buffer-ptr stream))
+ 3 ; read-modify
+ 1 ; write
+ ))))
+
+(defun sc-set-clean (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm mode stream) 0)))
+
+(defun sc-dirty-p (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (> (sm mode stream) 0)))
-(defun sc-flush-buffer (stream blocking)
+(defun flush-buffer (stream blocking)
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr 0)
- (bytes (sm buffpos stream)))
+ (bytes (sm buffpos stream)))
(declare (type fixnum ptr bytes))
- ;; Seek to the left before flushing buffer -- the user could
- ;; have set the file-position, and scribbled something in the
- ;; data that was read from the file.
- (when (> (sm buffer-ptr stream) 0)
+ (when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
+ ;; The data read in from the file could have been changed if
+ ;; the stream is opened in read-write mode -- write back
+ ;; everything in the buffer at the correct position just in
+ ;; case.
(setf (device-file-position stream)
(- (device-file-position stream) (sm buffer-ptr stream))))
(loop
- (when (>= ptr bytes)
- (setf (sm buffpos stream) 0
- (sm buffer-ptr stream) 0)
- (remove-stream-instance-flags stream :dirty)
- (return 0))
- (let ((bytes-written (device-write stream nil ptr bytes blocking)))
- (declare (fixnum bytes-written))
- (when (minusp bytes-written)
- (error "DEVICE-WRITE error."))
- (incf ptr bytes-written))))))
-
-(defun dc-refill-buffer (stream blocking)
- (with-stream-class (dual-channel-simple-stream stream)
- (let* ((unread (sm last-char-read-size stream))
- (buffer (sm buffer stream)))
- (unless (zerop unread)
- (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
- (let ((bytes (device-read stream nil unread nil blocking)))
- (declare (type fixnum bytes))
- (setf (sm buffpos stream) unread
- (sm buffer-ptr stream) (if (plusp bytes)
- (+ bytes unread)
- unread))
- bytes))))
-
-(defun dc-flush-buffer (stream blocking)
+ (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0))
+ (let ((bytes-written (device-write stream nil ptr nil blocking)))
+ (declare (fixnum bytes-written))
+ (when (minusp bytes-written)
+ (error "DEVICE-WRITE error."))
+ (incf ptr bytes-written))))))
+
+(defun flush-out-buffer (stream blocking)
(with-stream-class (dual-channel-simple-stream stream)
(let ((ptr 0)
- (bytes (sm outpos stream)))
+ (bytes (sm outpos stream)))
(declare (type fixnum ptr bytes))
(loop
- (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
- (let ((bytes-written (device-write stream nil ptr bytes blocking)))
- (declare (fixnum bytes-written))
- (when (minusp bytes-written)
- (error "DEVICE-WRITE error."))
- (incf ptr bytes-written))))))
+ (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
+ (let ((bytes-written (device-write stream nil ptr nil blocking)))
+ (declare (fixnum bytes-written))
+ (when (minusp bytes-written)
+ (error "DEVICE-WRITE error."))
+ (incf ptr bytes-written))))))
+
+(defun read-byte-internal (stream eof-error-p eof-value blocking)
+ (with-stream-class (simple-stream stream)
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buffer-ptr stream))
+ (let ((bytes (device-read stream nil 0 nil blocking)))
+ (declare (type fixnum bytes))
+ (if (plusp bytes)
+ (setf (sm buffer-ptr stream) bytes
+ ptr 0)
+ (return-from read-byte-internal
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
+ (setf (sm buffpos stream) (1+ ptr))
+ (setf (sm last-char-read-size stream) 0)
+ (setf (sm charpos stream) nil)
+ (bref (sm buffer stream) ptr))))
-;;;
-;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
-;;;
+;;;; Single-Channel-Simple-Stream strategy functions
-(declaim (ftype j-read-char-fn sc-read-char))
-(defun sc-read-char (stream eof-error-p eof-value blocking)
- (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
- ;; if stream is open for read-write, may need to flush the buffer
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (if (< ptr (sm buffer-ptr stream))
- (progn
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))
- (let ((bytes (sc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (unless (minusp bytes)
- (let ((ptr (sm buffpos stream)))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char))))
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-(declaim (ftype j-read-char-fn sc-read-char--buffer))
-(defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
- (declare (ignore blocking)) ;; everything is already in the buffer
- (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
+(declaim (ftype j-listen-fn sc-listen-ef))
+(defun sc-listen-ef (stream)
+ (with-stream-class (simple-stream stream)
+ (let ((lcrs (sm last-char-read-size stream))
+ (buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (cnt 0)
+ (char nil))
+ (unwind-protect
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (let ((bytes (refill-buffer stream nil)))
+ (cond ((= bytes 0)
+ (return-from sc-listen-ef nil))
+ ((< bytes 0)
+ (return-from sc-listen-ef t))
+ (t
+ (setf buffpos (sm buffpos stream))))))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (setq char (octets-to-char (sm external-format stream)
+ (sm oc-state stream)
+ cnt #'input #'unput))
+ (characterp char))
+ (setf (sm last-char-read-size stream) lcrs)))))
+
+(declaim (ftype j-read-char-fn sc-read-char-ef))
+(defun sc-read-char-ef (stream eof-error-p eof-value blocking)
+ #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
+ (with-stream-class (simple-stream stream)
(let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (when (< ptr (sm buffer-ptr stream))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr)))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char))))
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-
-(declaim (ftype j-read-chars-fn sc-read-chars))
-(defun sc-read-chars (stream string search start end blocking)
+ (buffpos (sm buffpos stream))
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream)))
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (when (sc-dirty-p stream)
+ (flush-buffer stream t))
+ (let ((bytes (refill-buffer stream blocking)))
+ (cond ((= bytes 0)
+ (return-from sc-read-char-ef nil))
+ ((minusp bytes)
+ (return-from sc-read-char-ef
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (t
+ (setf buffpos (sm buffpos stream))))))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) cnt
+ (sm oc-state stream) state)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (if (null char)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+
+(declaim (ftype j-read-char-fn sc-read-char-ef-mapped))
+(defun sc-read-char-ef-mapped (stream eof-error-p eof-value blocking)
+ #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
+ (declare (ignore blocking))
+ (with-stream-class (simple-stream stream)
+ (let* ((buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream)))
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (return-from sc-read-char-ef-mapped
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) cnt
+ (sm oc-state stream) state)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (if (null char)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+
+(declaim (ftype j-read-chars-fn sc-read-chars-ef))
+(defun sc-read-chars-ef (stream string search start end blocking)
;; string is filled from START to END, or until SEARCH is found
;; Return two values: count of chars read and
;; NIL if SEARCH was not found
- ;; T is SEARCH was found
+ ;; T if SEARCH was found
;; :EOF if eof encountered before end
(declare (type simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
- (setf (sm last-char-read-size stream) 0)
- ;; FIXME: Should arrange for the last character to be unreadable
+ (type string string)
+ (type (or null character) search)
+ (type fixnum start end)
+ (type boolean blocking)
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ (with-stream-class (simple-stream stream)
+ (when (sc-dirty-p stream)
+ (flush-buffer stream t))
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (if (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))
- (let ((bytes (sc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (setf ptr (sm buffpos stream)
- max (sm buffer-ptr stream))
- (when (plusp bytes)
- (prog1
- (bref buffer ptr)
- (incf ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-read-chars-fn sc-read-chars--buffer))
-(defun sc-read-chars--buffer (stream string search start end blocking)
+ (buffpos (sm buffpos stream))
+ (buffer-ptr (sm buffer-ptr stream))
+ (lcrs 0)
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (values count nil))
+ (declare (type sb-int:index buffpos buffer-ptr posn count))
+ (flet ((input ()
+ (when (>= buffpos buffer-ptr)
+ (setf (sm last-char-read-size stream) lcrs)
+ (let ((bytes (refill-buffer stream blocking)))
+ (declare (type fixnum bytes))
+ (setf buffpos (sm buffpos stream)
+ buffer-ptr (sm buffer-ptr stream))
+ (unless (plusp bytes)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (if (zerop bytes)
+ (return (values count nil))
+ (return (values count :eof))))))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)
+ (incf lcrs)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setq lcrs cnt)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (cond ((null char)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count :eof)))
+ ((and search (char= char search))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count t)))
+ (t
+ (setf (char string posn) char))))))))
+
+
+(declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped))
+(defun sc-read-chars-ef-mapped (stream string search start end blocking)
+ ;; string is filled from START to END, or until SEARCH is found
+ ;; Return two values: count of chars read and
+ ;; NIL if SEARCH was not found
+ ;; T if SEARCH was found
+ ;; :EOF if eof encountered before end
(declare (type simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (declare (ignore blocking)) ; everything is in the buffer
- (with-stream-class (single-channel-simple-stream stream)
+ (type string string)
+ (type (or null character) search)
+ (type fixnum start end)
+ (type boolean blocking)
+ (ignore blocking)
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ (with-stream-class (simple-stream stream)
+ ;; if stream is single-channel and mode == 3, flush buffer (if dirty)
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((= posn end)
- (setf (sm buffpos stream) ptr)
- (unless (zerop count) (setf (sm last-char-read-size stream) 1))
+ (buffpos (sm buffpos stream))
+ (buffer-ptr (sm buffer-ptr stream))
+ (lcrs 0)
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
(values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (when (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (unless (zerop count) (setf (sm last-char-read-size stream) 1))
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- ;; Unread of last char must unread the search character, too
- ;; If no characters were read, just add the length of the
- ;; search char to that of the previously read char.
- (if (zerop count)
- (incf (sm last-char-read-size stream))
- (setf (sm last-char-read-size stream) 2))
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-unread-char-fn sc-unread-char))
-(defun sc-unread-char (stream relaxed)
+ (declare (type sb-int:index buffpos buffer-ptr posn count))
+ (flet ((input ()
+ (when (>= buffpos buffer-ptr)
+ (return (values count :eof)))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)
+ (incf lcrs)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setq lcrs cnt)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (cond ((null char)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count :eof)))
+ ((and search (char= char search))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count t)))
+ (t
+ (setf (char string posn) char))))))))
+
+
+(declaim (ftype j-unread-char-fn sc-unread-char-ef))
+(defun sc-unread-char-ef (stream relaxed)
(declare (ignore relaxed))
- (with-stream-class (single-channel-simple-stream stream)
+ (with-stream-class (simple-stream stream)
(let ((unread (sm last-char-read-size stream)))
(if (>= (sm buffpos stream) unread)
- (decf (sm buffpos stream) unread)
- (error "Unreading needs work"))
- (setf (sm last-char-read-size stream) 0))))
+ (decf (sm buffpos stream) unread)
+ (error "This shouldn't happen.")))))
-(declaim (ftype j-write-char-fn sc-write-char))
-(defun sc-write-char (character stream)
- (with-stream-class (single-channel-simple-stream stream)
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (char-code character))
- (ctrl (sm control-out stream)))
- (when (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream character))
- (return-from sc-write-char character))
- (when (>= ptr (sm buf-len stream))
- (setf ptr (sc-flush-buffer stream t)))
- (setf (bref buffer ptr) code)
- (setf (sm buffpos stream) (1+ ptr))
- (add-stream-instance-flags stream :dirty)))
+(declaim (ftype j-write-char-fn sc-write-char-ef))
+(defun sc-write-char-ef (character stream)
+ (when character
+ (with-stream-class (single-channel-simple-stream stream)
+ (let ((buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (buf-len (sm buf-len stream))
+ (code (char-code character))
+ (ctrl (sm control-out stream)))
+ (when (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream character))
+ (return-from sc-write-char-ef character))
+ (flet ((output (byte)
+ (when (>= buffpos buf-len)
+ (setf (sm buffpos stream) buffpos)
+ (setq buffpos (flush-buffer stream t)))
+ (setf (bref buffer buffpos) byte)
+ (incf buffpos)))
+ (char-to-octets (sm external-format stream) character
+ (sm co-state stream) #'output))
+ (setf (sm buffpos stream) buffpos)
+ (sc-set-dirty stream)
+ (if (sm charpos stream) (incf (sm charpos stream))))))
character)
-(declaim (ftype j-write-chars-fn sc-write-chars))
-(defun sc-write-chars (string stream start end)
+(declaim (ftype j-write-chars-fn sc-write-chars-ef))
+(defun sc-write-chars-ef (string stream start end)
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buf-len stream))
- (ctrl (sm control-out stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end)
- (setf (sm buffpos stream) ptr)
- (add-stream-instance-flags stream :dirty)
- count)
- (declare (type fixnum ptr max posn count))
+ (buffpos (sm buffpos stream))
+ (buf-len (sm buf-len stream))
+ (ef (sm external-format stream))
+ (ctrl (sm control-out stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end) (setf (sm buffpos stream) buffpos) count)
+ (declare (type fixnum buffpos buf-len posn count))
(let* ((char (char string posn))
- (code (char-code char)))
- ;; FIXME: Can functions in the control-out table side-effect
- ;; the stream? Section 9.0 prohibits this only for control-in
- ;; functions. If they can, update (sm buffpos stream) here,
- ;; like around the call to sc-flush-buffer below
- (unless (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream char))
- (unless (< ptr max)
- ;; need to update buffpos before control leaves this
- ;; function in any way
- (setf (sm buffpos stream) ptr)
- (sc-flush-buffer stream t)
- (setf ptr (sm buffpos stream)))
- (setf (bref buffer ptr) code)
- (incf ptr))))))
-
-(declaim (ftype j-listen-fn sc-listen))
-(defun sc-listen (stream)
- (with-stream-class (single-channel-simple-stream stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (case (device-read stream nil 0 0 nil)
- ((0 -2) nil)
- (-1 #| latch EOF |# nil)
- (-3 t)
- (t (error "DEVICE-READ error."))))))
-
-;;; SC-READ-BYTE doesn't actually live in a strategy slot
-(defun sc-read-byte (stream eof-error-p eof-value blocking)
- (with-stream-class (single-channel-simple-stream stream)
- ;; @@1
- (let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buffer-ptr stream))
- (let ((bytes (device-read stream nil 0 nil blocking)))
- (declare (type fixnum bytes))
- (if (plusp bytes)
- (setf (sm buffer-ptr stream) bytes
- ptr 0)
- (return-from sc-read-byte
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
- (setf (sm buffpos stream) (1+ ptr))
- (setf (sm last-char-read-size stream) 0)
- (bref (sm buffer stream) ptr))))
-
-;;;
-;;; DUAL-CHANNEL STRATEGY FUNCTIONS
-;;;
-
-(declaim (ftype j-read-char-fn dc-read-char))
-(defun dc-read-char (stream eof-error-p eof-value blocking)
- ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (dual-channel-simple-stream stream)
- ;; if interactive flag is set, finish-output first
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (if (< ptr (sm buffer-ptr stream))
- (progn
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))
- (let ((bytes (dc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (unless (minusp bytes)
- (let ((ptr (sm buffpos stream)))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#)
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-
-(declaim (ftype j-read-chars-fn dc-read-chars))
-(defun dc-read-chars (stream string search start end blocking)
- (declare (type dual-channel-simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
- (with-stream-class (dual-channel-simple-stream stream)
- ;; if interactive flag is set, finish-output first
- (setf (sm last-char-read-size stream) 0)
- ;; Should arrange for the last character to be unreadable
- (do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (if (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))
- (let ((bytes (dc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (setf ptr (sm buffpos stream)
- max (sm buffer-ptr stream))
- (when (plusp bytes)
- (prog1
- (bref buffer ptr)
- (incf ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-unread-char-fn dc-unread-char))
-(defun dc-unread-char (stream relaxed)
- (declare (ignore relaxed))
- (with-stream-class (dual-channel-simple-stream stream)
- (let ((unread (sm last-char-read-size stream)))
- (if (>= (sm buffpos stream) unread)
- (decf (sm buffpos stream) unread)
- (error "Unreading needs work"))
- (setf (sm last-char-read-size stream) 0))))
-
-(declaim (ftype j-write-char-fn dc-write-char))
-(defun dc-write-char (character stream)
+ (code (char-code char)))
+ (unless (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream char))
+ (flet ((output (byte)
+ (when (>= buffpos buf-len)
+ (setf (sm buffpos stream) buffpos)
+ (setq buffpos (flush-buffer stream t)))
+ (setf (bref buffer buffpos) byte)
+ (incf buffpos)))
+ (char-to-octets ef char (sm co-state stream) #'output))
+ (setf (sm buffpos stream) buffpos)
+ (if (sm charpos stream) (incf (sm charpos stream)))
+ (sc-set-dirty stream))))))
+
+
+;;;; Dual-Channel-Simple-Stream strategy functions
+
+;; single-channel read-side functions work for dual-channel streams too
+
+(declaim (ftype j-write-char-fn dc-write-char-ef))
+(defun dc-write-char-ef (character stream)
(when character
(with-stream-class (dual-channel-simple-stream stream)
- (let* ((buffer (sm out-buffer stream))
- (ptr (sm outpos stream))
- (code (char-code character))
- (ctrl (sm control-out stream)))
- (when (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream character))
- (return-from dc-write-char character))
- (when (>= ptr (sm max-out-pos stream))
- (setq ptr (dc-flush-buffer stream t)))
- (setf (bref buffer ptr) code)
- (setf (sm outpos stream) (1+ ptr)))))
+ (let ((out-buffer (sm out-buffer stream))
+ (outpos (sm outpos stream))
+ (max-out-pos (sm max-out-pos stream))
+ (code (char-code character))
+ (ctrl (sm control-out stream)))
+ (when (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream character))
+ (return-from dc-write-char-ef character))
+ (flet ((output (byte)
+ (when (>= outpos max-out-pos)
+ (setf (sm outpos stream) outpos)
+ (setq outpos (flush-out-buffer stream t)))
+ (setf (bref out-buffer outpos) byte)
+ (incf outpos)))
+ (char-to-octets (sm external-format stream) character
+ (sm co-state stream) #'output))
+ (setf (sm outpos stream) outpos)
+ (if (sm charpos stream) (incf (sm charpos stream))))))
character)
-(declaim (ftype j-write-chars-fn dc-write-chars))
-(defun dc-write-chars (string stream start end)
+
+(declaim (ftype j-write-chars-fn dc-write-chars-ef))
+(defun dc-write-chars-ef (string stream start end)
(with-stream-class (dual-channel-simple-stream stream)
(do ((buffer (sm out-buffer stream))
- (ptr (sm outpos stream))
- (max (sm max-out-pos stream))
- (ctrl (sm control-out stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end) (setf (sm outpos stream) ptr) count)
- (declare (type fixnum ptr max posn count))
+ (outpos (sm outpos stream))
+ (max-out-pos (sm max-out-pos stream))
+ (ef (sm external-format stream))
+ (ctrl (sm control-out stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end) (setf (sm outpos stream) outpos) count)
+ (declare (type fixnum outpos max-out-pos posn count))
(let* ((char (char string posn))
- (code (char-code char)))
- (unless (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream char))
- (unless (< ptr max)
- (setf (sm outpos stream) ptr)
- (dc-flush-buffer stream t)
- (setf ptr (sm outpos stream)))
- (setf (bref buffer ptr) code)
- (incf ptr))
- ))))
-
-(declaim (ftype j-listen-fn dc-listen))
-(defun dc-listen (stream)
- (with-stream-class (dual-channel-simple-stream stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (case (device-read stream nil 0 0 nil)
- ((0 -2) nil)
- (-1 #| latch EOF |# nil)
- (-3 t)
- (t (error "DEVICE-READ error."))))))
-
-;;; DC-READ-BYTE doesn't actually live in a strategy slot
-(defun dc-read-byte (stream eof-error-p eof-value blocking)
- (with-stream-class (dual-channel-simple-stream stream)
- (let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buffer-ptr stream))
- (let ((bytes (device-read stream nil 0 nil blocking)))
- (declare (type fixnum bytes))
- (if (plusp bytes)
- (setf (sm buffer-ptr stream) bytes
- ptr 0)
- (return-from dc-read-byte
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
- (setf (sm buffpos stream) (1+ ptr))
- (setf (sm last-char-read-size stream) 0)
- (bref (sm buffer stream) ptr))))
-
-;;;
-;;; STRING STRATEGY FUNCTIONS
-;;;
-
-(declaim (ftype j-read-char-fn string-read-char))
-(defun string-read-char (stream eof-error-p eof-value blocking)
+ (code (char-code char)))
+ (unless (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream char))
+ (flet ((output (byte)
+ (when (>= outpos max-out-pos)
+ (setf (sm outpos stream) outpos)
+ (setq outpos (flush-out-buffer stream t)))
+ (setf (bref buffer outpos) byte)
+ (incf outpos)))
+ (char-to-octets ef char (sm co-state stream) #'output))
+ (setf (sm outpos stream) outpos)
+ (if (sm charpos stream) (incf (sm charpos stream))))))))
+
+;;;; String-Simple-Stream strategy functions
+
+(declaim (ftype j-read-char-fn str-read-char))
+(defun str-read-char (stream eof-error-p eof-value blocking)
(declare (type string-input-simple-stream stream) (ignore blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#
+ )
(with-stream-class (string-input-simple-stream stream)
(when (any-stream-instance-flags stream :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value))
(let* ((ptr (sm buffpos stream))
- (char (if (< ptr (sm buffer-ptr stream))
- (schar (sm buffer stream) ptr)
- nil)))
+ (char (if (< ptr (sm buffer-ptr stream))
+ (schar (sm buffer stream) ptr)
+ nil)))
(if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- (progn
- (setf (sm last-char-read-size stream) 1)
- ;; do string-streams do control-in processing?
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#
- char)))))
-
-
-(declaim (ftype j-read-char-fn composing-crlf-read-char))
-(defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
- ;; TODO: what about the eof-error-p parameter?
- (declare (ignore eof-error-p eof-value))
- (with-stream-class (simple-stream stream)
- (let* ((melded-stream (sm melded-stream stream))
- (char (funcall-stm-handler j-read-char melded-stream nil stream
- blocking)))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ (progn
+ (setf (sm last-char-read-size stream) 1)
+ ;; do string-streams do control-in processing?
+ #|(let ((column (sm charpos stream)))
+ (declare (type (or null fixnum) column))
+ (when column
+ (setf (sm charpos stream) (1+ column))))
+ |#
+ char)))))
+
+(declaim (ftype j-listen-fn str-listen-e-crlf))
+(defun str-listen-e-crlf (stream)
+ (with-stream-class (composing-stream stream)
+ ;; if this says there's a character available, it may be #\Return,
+ ;; in which case read-char will only return if there's a following
+ ;; #\Linefeed, so this really has to read the char...
+ ;; but without precluding the later unread-char of a character which
+ ;; has already been read.
+ (funcall-stm-handler j-listen (sm melded-stream stream))))
+
+(declaim (ftype j-read-char-fn str-read-char-e-crlf))
+(defun str-read-char-e-crlf (stream eof-error-p eof-value blocking)
+ (with-stream-class (composing-stream stream)
+ (let* ((encap (sm melded-stream stream))
+ (ctrl (sm control-in stream))
+ (char (funcall-stm-handler j-read-char encap nil stream blocking)))
;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
;; character was available...
(when (eql char #\Return)
- (let ((next (funcall-stm-handler j-read-char melded-stream
- nil stream blocking)))
- ;; if NEXT is STREAM, we hit EOF, so we should just return the
- ;; #\Return (and mark the stream :EOF? At least unread if we
- ;; got a soft EOF, from a terminal, etc.
- ;; if NEXT is NIL, blocking is NIL and there's a CR but no
- ;; LF available on the stream: have to unread the CR and
- ;; return NIL, letting the CR be reread later.
- ;;
- ;; If we did get a linefeed, adjust the last-char-read-size
- ;; so that an unread of the resulting newline will unread both
- ;; the linefeed _and_ the carriage return.
- (if (eql next #\Linefeed)
- (setq char #\Newline)
- (funcall-stm-handler j-unread-char melded-stream nil))))
- ;; do control-in processing on whatever character we've got
- char)))
-
-(declaim (ftype j-unread-char-fn composing-crlf-unread-char))
-(defun composing-crlf-unread-char (stream relaxed)
+ (let ((next (funcall-stm-handler j-read-char encap nil stream blocking)))
+ ;; if NEXT is STREAM, we hit EOF, so we should just return the
+ ;; #\Return (and mark the stream :EOF? At least unread if we
+ ;; got a soft EOF, from a terminal, etc.
+ ;; if NEXT is NIL, blocking is NIL and there's a CR but no
+ ;; LF available on the stream: have to unread the CR and
+ ;; return NIL, letting the CR be reread later.
+ ;;
+ ;; If we did get a linefeed, adjust the last-char-read-size
+ ;; so that an unread of the resulting newline will unread both
+ ;; the linefeed _and_ the carriage return.
+ (if (eql next #\Linefeed)
+ (setq char #\Newline)
+ (funcall-stm-handler j-unread-char encap nil))))
+ (when (characterp char)
+ (let ((code (char-code char)))
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))))
+ (if (eq char stream)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))
+
+(declaim (ftype j-unread-char-fn str-unread-char-e-crlf))
+(defun str-unread-char-e-crlf (stream relaxed)
(declare (ignore relaxed))
- (with-stream-class (simple-stream stream)
+ (with-stream-class (composing-stream stream)
(funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
-;;;
+
;;; Functions to install the strategy functions in the appropriate slots
-;;;
-(defun %find-topmost-stream (stream)
- ;; N.B.: the topmost stream in the chain of encapsulations is actually
- ;; the bottommost in the "melding" chain
+(defun melding-stream (stream)
+ (with-stream-class (simple-stream)
+ (do ((stm stream (sm melded-stream stm)))
+ ((eq (sm melded-stream stm) stream) stm))))
+
+(defun meld (stream encap)
(with-stream-class (simple-stream)
- (loop
- (when (eq (sm melded-stream stream) (sm melding-base stream))
- (return stream))
- (setq stream (sm melded-stream stream)))))
+ (setf (sm melding-base encap) (sm melding-base stream))
+ (setf (sm melded-stream encap) (sm melded-stream stream))
+ (setf (sm melded-stream stream) encap)
+ (rotatef (sm j-listen encap) (sm j-listen stream))
+ (rotatef (sm j-read-char encap) (sm j-read-char stream))
+ (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
+ (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
+ (rotatef (sm j-write-char encap) (sm j-write-char stream))
+ (rotatef (sm j-write-chars encap) (sm j-write-chars stream))))
+
+(defun unmeld (stream)
+ (with-stream-class (simple-stream)
+ (let ((encap (sm melded-stream stream)))
+ (unless (eq encap (sm melding-base stream))
+ (setf (sm melding-base encap) encap)
+ (setf (sm melded-stream stream) (sm melded-stream encap))
+ (setf (sm melded-stream encap) encap)
+ (rotatef (sm j-listen stream) (sm j-listen encap))
+ (rotatef (sm j-read-char encap) (sm j-read-char stream))
+ (rotatef (sm j-read-chars stream) (sm j-read-chars encap))
+ (rotatef (sm j-unread-char stream) (sm j-unread-char encap))
+ (rotatef (sm j-write-char stream) (sm j-write-char encap))
+ (rotatef (sm j-write-chars stream) (sm j-write-chars encap))))))
+
+;;; In cmucl, this is done with define-function-name-syntax (lists as
+;;; function names), we make do with symbol frobbing.
+(defun %sf (kind name format &optional access)
+ (flet ((find-strategy-function (&rest args)
+ (ignore-errors
+ (fdefinition (find-symbol (format nil "~{~A~^-~}"
+ (mapcar #'string args))
+ #.*package*)))))
+ (or (find-strategy-function kind name format access)
+ (find-strategy-function kind name format)
+ (find-strategy-function kind name :ef access)
+ (find-strategy-function kind name :ef))))
+
(defun install-single-channel-character-strategy (stream external-format
- access)
- (find-external-format external-format)
- (let ((stream (%find-topmost-stream stream)))
+ access)
+ (let ((format (find-external-format external-format)))
;; ACCESS is usually NIL
;; May be "undocumented" values: stream::buffer, stream::mapped
;; to install strategies suitable for direct buffer streams
;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
;; (Avoids checking "mode" flags by installing special strategy)
- (with-stream-class (single-channel-simple-stream stream)
- (if (or (eq access 'buffer) (eq access 'mapped))
- (setf (sm j-read-char stream) #'sc-read-char--buffer
- (sm j-read-chars stream) #'sc-read-chars--buffer
- (sm j-unread-char stream) #'sc-unread-char
- (sm j-write-char stream) #'sc-write-char
- (sm j-write-chars stream) #'sc-write-chars
- (sm j-listen stream) #'sc-listen)
- (setf (sm j-read-char stream) #'sc-read-char
- (sm j-read-chars stream) #'sc-read-chars
- (sm j-unread-char stream) #'sc-unread-char
- (sm j-write-char stream) #'sc-write-char
- (sm j-write-chars stream) #'sc-write-chars
- (sm j-listen stream) #'sc-listen))))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-listen stream)
+ (%sf 'sc 'listen (ef-name format) access)
+ (sm j-read-char stream)
+ (%sf 'sc 'read-char (ef-name format) access)
+ (sm j-read-chars stream)
+ (%sf 'sc 'read-chars (ef-name format) access)
+ (sm j-unread-char stream)
+ (%sf 'sc 'unread-char (ef-name format) access)
+ (sm j-write-char stream)
+ (%sf 'sc 'write-char (ef-name format) access)
+ (sm j-write-chars stream)
+ (%sf 'sc 'write-chars (ef-name format) access))))
stream)
(defun install-dual-channel-character-strategy (stream external-format)
- (find-external-format external-format)
- (let ((stream (%find-topmost-stream stream)))
- (with-stream-class (dual-channel-simple-stream stream)
- (setf (sm j-read-char stream) #'dc-read-char
- (sm j-read-chars stream) #'dc-read-chars
- (sm j-unread-char stream) #'dc-unread-char
- (sm j-write-char stream) #'dc-write-char
- (sm j-write-chars stream) #'dc-write-chars
- (sm j-listen stream) #'dc-listen)))
+ (let ((format (find-external-format external-format)))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-listen stream)
+ (%sf 'sc 'listen (ef-name format))
+ (sm j-read-char stream)
+ (%sf 'sc 'read-char (ef-name format))
+ (sm j-read-chars stream)
+ (%sf 'sc 'read-chars (ef-name format))
+ (sm j-unread-char stream)
+ (%sf 'sc 'unread-char (ef-name format))
+ (sm j-write-char stream)
+ (%sf 'dc 'write-char (ef-name format))
+ (sm j-write-chars stream)
+ (%sf 'dc 'write-chars (ef-name format)))))
+ stream)
+
+;; Deprecated -- use install-string-{input,output}-character-strategy instead!
+(defun install-string-character-strategy (stream)
+ (when (any-stream-instance-flags stream :input)
+ (install-string-input-character-strategy stream))
+ (when (any-stream-instance-flags stream :output)
+ (install-string-output-character-strategy stream))
stream)
(defun install-string-input-character-strategy (stream)
#| implement me |#
- (let ((stream (%find-topmost-stream stream)))
- (with-stream-class (simple-stream stream)
- (setf (sm j-read-char stream) #'string-read-char)))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-read-char stream) #'str-read-char))
stream)
(defun install-string-output-character-strategy (stream)
#| implement me |#
stream)
+(defun install-composing-format-character-strategy (stream composing-format)
+ (let ((format composing-format))
+ (with-stream-class (simple-stream stream)
+ (case format
+ (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf
+ (sm j-unread-char stream) #'str-unread-char-e-crlf))))
+ #| implement me |#)
+ stream)
+
(defun compose-encapsulating-streams (stream external-format)
(when (consp external-format)
(with-stream-class (simple-stream)
- (dolist (fmt (butlast external-format))
- (let ((encap (make-instance 'composing-stream :composing-format fmt)))
- (setf (sm melding-base encap) stream)
- (setf (sm melded-stream encap) (sm melded-stream stream))
- (setf (sm melded-stream stream) encap)
- (rotatef (sm j-listen encap) (sm j-listen stream))
- (rotatef (sm j-read-char encap) (sm j-read-char stream))
- (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
- (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
- (rotatef (sm j-write-char encap) (sm j-write-char stream))
- (rotatef (sm j-write-chars encap) (sm j-write-chars stream)))))))
+ (let ((encap (if (eq (sm melded-stream stream) stream)
+ nil
+ (sm melded-stream stream))))
+ (when (null encap)
+ (setq encap (make-instance 'composing-stream))
+ (meld stream encap))
+ (setf (stream-external-format encap) (car (last external-format)))
+ (setf (sm external-format stream) external-format)
+ (install-composing-format-character-strategy stream
+ (butlast external-format))
+ ))))
+
+(defmethod (setf stream-external-format) (ef (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (setf (sm external-format stream) (find-external-format ef)))
+ ef)
;;;
;;; NULL STRATEGY FUNCTIONS
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; String-Simple-Stream and relatives
+
+(def-stream-class string-input-simple-stream (string-simple-stream)
+ ())
+
+(def-stream-class string-output-simple-stream (string-simple-stream)
+ ((out-buffer :initform nil :type (or simple-stream-buffer null))
+ (outpos :initform 0 :type fixnum)
+ (max-out-pos :initform 0 :type fixnum)))
+
+(def-stream-class composing-stream (string-simple-stream)
+ ())
+
+(def-stream-class fill-pointer-output-simple-stream
+ (string-output-simple-stream)
+ ())
+
+(def-stream-class xp-simple-stream (string-output-simple-stream)
+ ())
+
+(def-stream-class annotation-output-simple-stream (string-output-simple-stream)
+ ())
+
+(defmethod device-open :before ((stream string-input-simple-stream) options)
+ ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
+ (with-stream-class (string-input-simple-stream stream)
+ (let ((string (getf options :string)))
+ (when (and string (null (sm buffer stream)))
+ (let ((start (getf options :start))
+ (end (or (getf options :end) (length string))))
+ (setf (sm buffer stream) string
+ (sm buffpos stream) start
+ (sm buffer-ptr stream) end))))
+ (install-string-input-character-strategy stream)
+ (add-stream-instance-flags stream :string :input :simple)))
+
+(defmethod device-open :before ((stream string-output-simple-stream) options)
+ ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
+ (with-stream-class (string-output-simple-stream stream)
+ (unless (sm out-buffer stream)
+ (let ((string (getf options :string)))
+ (if string
+ (setf (sm out-buffer stream) string
+ (sm max-out-pos stream) (length string))
+ (let ((buflen (max (device-buffer-length stream) 16)))
+ (setf (sm out-buffer stream) (make-string buflen)
+ (sm max-out-pos stream) buflen)))))
+ (unless (sm control-out stream)
+ (setf (sm control-out stream) *std-control-out-table*))
+ (install-string-output-character-strategy stream)
+ (add-stream-instance-flags stream :string :output :simple)))
+
+(defmethod device-open ((stream string-simple-stream) options)
+ (declare (ignore options))
+ (with-stream-class (string-simple-stream stream)
+ (if (and (any-stream-instance-flags stream :simple)
+ (any-stream-instance-flags stream :input :output))
+ t
+ nil)))
+
+(defmethod device-file-position ((stream string-simple-stream))
+ (with-stream-class (simple-stream stream)
+ (sm buffpos stream)))
+
+(defmethod (setf device-file-position) (value (stream string-simple-stream))
+ (with-stream-class (simple-stream stream)
+ (cond ((or (> value (sm buffer-ptr stream))
+ (< value (- -1 (sm buffer-ptr stream))))
+ nil)
+ ((>= value 0)
+ (setf (sm buffpos stream) value)
+ t)
+ (t
+ (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1))
+ t))))
+
+(defmethod device-file-length ((stream string-simple-stream))
+ (with-stream-class (simple-stream stream)
+ (sm buffer-ptr stream)))
+
+(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
+ (with-stream-class (fill-pointer-output-simple-stream stream)
+ (fill-pointer (sm out-buffer stream))))
+
+(defmethod (setf device-file-position)
+ (value (stream fill-pointer-output-simple-stream))
+ (with-stream-class (fill-pointer-output-simple-stream stream)
+ (let ((buffer (sm out-buffer stream)))
+ (cond ((or (> value (array-total-size buffer))
+ (< value (- -1 (array-total-size buffer))))
+ nil)
+ ((>= value 0)
+ (setf (fill-pointer buffer) value))
+ (t
+ (setf (fill-pointer buffer)
+ (+ (array-total-size buffer) value 1)))))))
+
+(defmethod device-open ((stream xp-simple-stream) options)
+ #| do something |#
+ stream)
\ No newline at end of file
--- /dev/null
+;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
+
+;;; Sbcl port by Rudi Schlatte.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Terminal-Simple-Stream
+
+(defvar *terminal-control-in-table*
+ (make-control-table #\Newline #'std-dc-newline-in-handler))
+
+(def-stream-class terminal-simple-stream (dual-channel-simple-stream)
+ ())
+
+(defmethod device-open ((stream terminal-simple-stream) options)
+ (with-stream-class (terminal-simple-stream stream)
+ (when (getf options :input-handle)
+ (setf (sm input-handle stream) (getf options :input-handle))
+ (add-stream-instance-flags stream :simple :dual :input)
+ (when (sb-unix:unix-isatty (sm input-handle stream))
+ (add-stream-instance-flags stream :interactive))
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm buffer stream) (allocate-buffer length)
+ (sm buf-len stream) length)))
+ (setf (sm control-in stream) *terminal-control-in-table*))
+ (when (getf options :output-handle)
+ (setf (sm output-handle stream) (getf options :output-handle))
+ (add-stream-instance-flags stream :simple :dual :output)
+ (unless (sm out-buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm out-buffer stream) (make-string length)
+ (sm max-out-pos stream) length)))
+ (setf (sm control-out stream) *std-control-out-table*))
+ (let ((efmt (getf options :external-format :default)))
+ (compose-encapsulating-streams stream efmt)
+ (install-dual-channel-character-strategy
+ (melding-stream stream) efmt)))
+ stream)
+
+(defmethod device-read ((stream terminal-simple-stream) buffer
+ start end blocking)
+ (let ((result (call-next-method)))
+ (if (= result -1) -2 result)))
+
+(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
+ (unless buffer-only
+ (let ((buffer (allocate-buffer sb-impl::bytes-per-buffer)))
+ (unwind-protect
+ (loop until (<= (read-octets stream buffer
+ 0 sb-impl::bytes-per-buffer nil)
+ 0))
+ (free-buffer buffer)))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.3.40"
+"0.8.3.41"
projects / sbcl.git / commitdiff