changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
* SBCL now builds using CLISP (version of late April 2003 from CVS)
as cross-compilation host.
+ * a contributed module containing a partial implementation of the
+ simple-streams interface has been included. (thanks to Rudi
+ Schlatte)
* minor incompatible change: the :NEGATIVE-ZERO-IS-NOT-ZERO feature
no longer has any effect, as the code controlled by this feature
has been deleted. (As far as we know, no-one has ever built using
--- /dev/null
+SYSTEM=sb-simple-streams
+include ../asdf-module.mk
--- /dev/null
+-*- text -*-
+
+An implementation of simple streams for sbcl.
+
+Simple streams are an extensible streams protocol, with similar goals
+but different architecture than Gray streams. Documentation about
+simple streams is available at
+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
+
+The port to sbcl was done by Rudi Schlatte (rudi@constantly.at). Bug
+reports welcome.
+
+==================================================
+
+Some sketchy notes about the simple-streams architecture, at least
+partly for my own benefit
+
+(For all the details, please see Franz' documentation)
+
+Motivation:
+
+If you want to extend a given Gray stream, is it enough to supply a
+method for stream-write-byte, or do you have to overwrite
+stream-write-sequence as well? How do you extend your Gray socket
+stream to support chunked stream encoding for HTTP/1.1? Chances are
+that for any seriously interesting stream customization, you will
+implement some kind of buffer, collect data in it and
+
+
+
+Simple streams is a layered architecture. The device layer at the
+bottom deals with transferring chunks of bytes between a buffer and a
+device (socket, file, printer, what-have-you). The top layer is the
+familiar CL API (read-line, write-sequence, open, etc). The strategy
+layer in the middle translates between the buffer-of-bytes and CL
+stream world-view, dealing with byte<->character conversion,
+line-ending and stream-external-format conventions, etc.
+
+Implementing a new type of stream is a matter of extending the right
+stream class and implementing device-read, device-write, device-extend
+& friends. single-channel-simple-stream is a class where there is one
+buffer for both input and output (this is appropriate e.g. for a file). The
+dual-channel-simple-stream class deals with devices that require
+separate buffers for input and output (e.g. sockets).
+
+Other character representations (Unicode, other multi-byte encodings)
+are implemented at the strategy level. The Franz documentation is
+unclear about this, but it seems that encodings take an active part
+("the encoding reads as many bytes as are necessary to compose a
+character", or words to that effect). This is not implemented in the
+present code (neither is it in Paul Foley's implementation), and will
+not be until sbcl gains Unicode abilities, but it would be nice to
+have it at least stubbed out in the implementation.
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+
+;;; 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)))
+ (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)))
+ (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."
+ (declare (type stream stream))
+ (etypecase stream
+ (simple-stream
+ (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) (value stream)
+ (etypecase stream
+ (simple-stream
+ (if value
+ (add-stream-instance-flags stream :interactive)
+ (remove-stream-instance-flags stream :interactive)))))
+
+(defun stream-external-format (stream)
+ "Returns Stream's external-format."
+ (declare (type stream stream))
+ (etypecase stream
+ (simple-stream
+ (with-stream-class (simple-stream)
+ (sm external-format stream)))
+ (ansi-stream
+ :default)
+ (fundamental-stream #| not defined on Gray streams? |#
+ :default)))
+
+(defgeneric default-open-class (name &optional element-type)
+ (:documentation
+ "Determine the stream class to be created when an attempt is made
+to open NAME. This is a CMUCL- and SBCL-specific extension to Franz's
+simple-streams proposal.")
+ (:method ((name t) &optional element-type)
+ (declare (ignore element-type))
+ nil)
+ (:method ((name pathname) &optional element-type)
+ (declare (ignore element-type))
+ 'sb-sys::file-stream)
+ (:method ((name string) &optional element-type)
+ (declare (ignore element-type))
+ 'sb-sys::file-stream)
+ (:method ((name stream) &optional element-type)
+ (declare (ignore element-type))
+ (class-name (class-of name))))
+
+(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
+
+ If Class is NIL or not supplied, DEFAULT-OPEN-CLASS is called on
+ Filename to determine its value, thus Filename need not be an actual
+ file name; it could be any arbitrary user-defined object for which a
+ method of DEFAULT-OPEN-CLASS is applicable."
+ (declare (ignore if-exists if-does-not-exist external-format
+ input-handle output-handle))
+ (let ((klass class)
+ (options (copy-list options))
+ (filespec (if (stringp filename) (parse-filespec filename) filename)))
+ (unless klass
+ (setq klass (default-open-class filespec (if element-type-given
+ element-type
+ nil))))
+ (unless klass
+ (error 'type-error :datum filename
+ :expected-type '(or pathname stream base-string)))
+ (cond ((eql klass 'sb-sys::file-stream)
+ (remf options :claass)
+ (remf options :mapped)
+ ;; INPUT-HANDLE and OUTPUT-HANDLE must be fixnums or NIL.
+ ;; If both are given, they must be the same -- or maybe
+ ;; we should make a TWO-WAY-STREAM in that case??
+ ;; If they are given, use SYS:MAKE-FD-STREAM to make the
+ ;; stream. Direction must be appropriate, too.
+ (remf options :input-handle)
+ (remf options :output-handle)
+ (apply #'open-fd-stream filespec options))
+ ((subtypep klass 'simple-stream)
+ (when element-type-given
+ (error "Can't create simple-streams with an element-type."))
+ (when (and (eq klass 'file-simple-stream) mapped)
+ (setq klass 'mapped-file-simple-stream)
+ (setf (getf options :class) 'mapped-file-simple-stream))
+ (when (subtypep klass 'file-simple-stream)
+ (when (eq direction :probe)
+ (setq klass 'probe-simple-stream)))
+ (apply #'make-instance klass (list* :filename filespec options)))
+ ((subtypep klass 'fundamental-stream)
+ (error "Gray streams are not supported by OPEN."))
+ (t
+ (if class
+ (error "Unable to open streams of class ~S." class)
+ (error "DEFAULT-OPEN-CLASS method on ~S instances is broken!"
+ (class-name (class-of filespec))))))))
+
+(defmacro %check-simple-stream (stream &optional direction)
+ ;; Check that STREAM is valid and open in the appropriate direction.
+ `(locally
+ (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (with-stream-class (simple-stream ,stream)
+ (let ((flags (sm %flags ,stream)))
+ (cond ((zerop (logand flags ,(%flags '(:simple))))
+ (error "~S is not properly initialized." stream))
+ ((zerop (logand flags ,(%flags '(:input :output))))
+ (error "~S is closed." stream))
+ ,@(when direction
+ `(((zerop (logand flags ,(%flags (list direction))))
+ (error ,(format nil "~~S is not an ~(~A~) stream."
+ direction)
+ stream)))))))))
+
+(declaim (inline sc-read-byte dc-read-byte))
+(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))))
+
+(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))))
+
+(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
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+ ((any-stream-instance-flags stream :string)
+ (with-stream-class (string-simple-stream stream)
+ (let ((encap (sm input-handle stream)))
+ (unless encap
+ (error "Can't read-byte on string streams"))
+ (prog1
+ (locally (declare (notinline read-byte))
+ (read-byte encap eof-error-p eof-value))
+ (setf (sm last-char-read-size stream) 0
+ (sm encapsulated-char-read-size stream) 0)))))
+ ((any-stream-instance-flags stream :dual)
+ (dc-read-byte stream eof-error-p eof-value t))
+ (t ;; single-channel-simple-stream
+ (sc-read-byte stream eof-error-p eof-value t)))))
+ (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."
+ (declare (ignore recursive-p))
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream)
+ (funcall-stm-handler j-read-char stream eof-error-p eof-value 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-simple-stream 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
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream)
+ (if (zerop (sm last-char-read-size stream))
+ (error "Nothing to unread.")
+ (funcall-stm-handler j-unread-char stream nil))))
+ (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."
+ (declare (ignore recursive-p))
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream)
+ (let ((char (funcall-stm-handler j-read-char stream
+ eof-error-p eof-value t)))
+ (cond ((eq char eof-value) char)
+ ((characterp peek-type)
+ (do ((char char (funcall-stm-handler j-read-char stream
+ eof-error-p
+ eof-value t)))
+ ((or (eq char eof-value) (char= char peek-type))
+ (unless (eq char eof-value)
+ (funcall-stm-handler j-unread-char stream t))
+ char)))
+ ((eq peek-type t)
+ (do ((char char (funcall-stm-handler j-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)
+ (funcall-stm-handler j-unread-char stream t))
+ char)))
+ (t
+ (funcall-stm-handler j-unread-char stream t)
+ char)))))
+ (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
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream stream)
+ (if (not (eql width 1))
+ (funcall-stm-handler j-listen stream)
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ ;; Note: should try DEVICE-EXTEND for more on buffer streams
+ (when (>= (sm mode stream) 0) ;; device-connected
+ (incf (sm last-char-read-size stream))
+ (let ((ok (refill-buffer stream nil)))
+ (decf (sm last-char-read-size stream))
+ (plusp ok)))))))
+ (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)))))
+
+(declaim (inline %simple-stream-read-line))
+(defun %simple-stream-read-line (stream eof-error-p eof-value)
+ (declare (type simple-stream stream)
+ (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (with-stream-class (simple-stream)
+ (let* ((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-base-string cbuf)
+ (type cons bufs tail)
+ (type fixnum index total))
+ (loop
+ (multiple-value-bind (chars done)
+ (funcall-stm-handler j-read-chars stream cbuf
+ #\Newline index (length cbuf) t)
+ (declare (type fixnum chars))
+ (incf index chars)
+ (incf total chars)
+ (when (and (eq done :eof) (zerop index))
+ (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 index)
+ (eq done :eof))))
+ ;; If total fits in final buffer, use it
+ #-ignore
+ (when (<= total (length cbuf))
+ (replace cbuf cbuf :start1 (- total index) :end2 index)
+ (let ((idx 0))
+ (declare (type fixnum idx))
+ (dolist (buf bufs)
+ (declare (type simple-base-string buf))
+ (replace cbuf buf :start1 idx)
+ (incf idx (length buf))))
+ (return (values (sb-kernel:shrink-vector cbuf index)
+ (eq done :eof))))
+ ;; Allocate new string of appropriate length
+ (let ((string (make-string total))
+ (index 0))
+ (declare (type fixnum 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 fixnum (* 2 index))))
+ (setf index 0)
+ (setf (cdr tail) (cons cbuf nil))
+ (setf tail (cdr tail))))))))
+
+(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."
+ (declare (ignore recursive-p))
+ (let ((stream (sb-impl::in-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream :input)
+ (%simple-stream-read-line stream eof-error-p eof-value))
+ (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)
+ (%check-simple-stream stream :input)
+ (etypecase seq
+ (string
+ (funcall-stm-handler j-read-chars stream seq nil start end
+ (if partial-fill :bnb t)))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; TODO: "read-vector" equivalent, but blocking if
+ ;; partial-fill is NIL
+ (error "implement me")
+ ))))
+ (ansi-stream
+ (%ansi-stream-read-sequence seq stream start end))
+ (fundamental-stream
+ (sb-gray:stream-read-sequence seq stream 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
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :input)
+ (setf (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm last-char-read-size stream) 0) ;; ??
+ (device-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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :string)
+ (error "Can't write-byte on string streams"))
+ ((any-stream-instance-flags stream :dual)
+ (let ((ptr (sm outpos stream)))
+ (when (>= ptr (sm max-out-pos stream))
+ (dc-flush-buffer stream t)
+ (setf ptr (1- (sm outpos stream))))
+ (setf (sm outpos stream) (1+ ptr))
+ (setf (bref (sm out-buffer stream) ptr) integer)))
+ (t ;; single-channel-simple-stream
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buffer-ptr stream))
+ (sc-flush-buffer stream t)
+ (setf ptr (1- (sm buffpos stream))))
+ (setf (sm buffpos stream) (1+ ptr))
+ (setf (bref (sm buffer stream) ptr) 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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-char character stream)))
+ (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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-chars string stream 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-simple-stream 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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (etypecase seq
+ (string
+ (funcall-stm-handler-2 j-write-chars seq stream start end))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; TODO: "write-vector" equivalent
+ (error "implement me")
+ ))))
+ (ansi-stream
+ (%ansi-stream-write-sequence seq stream start end))
+ (fundamental-stream
+ (sb-gray:stream-write-sequence seq stream 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-simple-stream 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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (when (/= (or (sm charpos stream) 1) 0)
+ (funcall-stm-handler-2 j-write-char #\Newline stream)
+ t)))
+ (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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :string)
+ #| nothing to do |#)
+ ((any-stream-instance-flags stream :dual)
+ (dc-flush-buffer stream t))
+ (t
+ (sc-flush-buffer stream t)))))
+ (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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :string)
+ #| nothing to do |#)
+ ((any-stream-instance-flags stream :dual)
+ (dc-flush-buffer stream nil))
+ (t
+ (sc-flush-buffer stream nil)))))
+ (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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ #| clear output buffer |#
+ (device-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."
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream)
+ (cond (position
+ ;; set unread to zero
+ ;; if position is within buffer, just move pointer; else
+ ;; flush output, if necessary
+ ;; set buffer pointer to 0, to force a read
+ (setf (device-file-position stream) position))
+ (t
+ (let ((posn (device-file-position stream)))
+ ;; adjust for buffer position
+ )))
+ #| TODO: implement me |#)
+ (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))))))))
+ (fundamental-stream
+ (error "file-position not supported on Gray streams."))))
+
+(defun file-length (stream)
+ "This function returns the length of the file that File-Stream is open to."
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream)
+ (device-file-length stream)
+ #| implement me |#)
+ (ansi-stream
+ (sb-impl::stream-must-be-associated-with-file stream)
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))
+ (fundamental-stream
+ (error "file-length not supported on Gray streams."))))
+
+(defun line-length (&optional (stream *standard-output*))
+ "Returns the number of characters that will fit on a line of output on the
+ given Stream, or Nil if that information is not available."
+ (let ((stream (sb-impl::out-synonym-of stream)))
+ (etypecase stream
+ (simple-stream
+ (%check-simple-stream stream :output)
+ #| implement me |#)
+ (ansi-stream
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
+ (fundamental-stream
+ (sb-gray:stream-line-length stream)))))
+
+(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
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream) (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-simple-stream 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-simple-stream 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))))))
+
+;;;
+;;; SETUP
+;;;
+
+(defmethod shared-initialize :after ((instance simple-stream) slot-names
+ &rest initargs &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 close ((stream simple-stream) &key abort)
+ (device-close stream abort))
+
+
+;;; bugfix
+;;; sat 2003-01-12: What is this for?
+#+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))))
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; BANNER ADS!!
+;;;
+
+(pushnew :sb-simple-stream *features*)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+(or X86) (pushnew :little-endian *features*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #-little-endian (pushnew :big-endian *features*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #-(or big-endian little-endian) (error "Unsupported architecture"))
+
+
+;;;
+;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
+;;;
+
+;;; See chapter
+;;; 12.2 Strategy descriptions necessary for encapsulation
+;;; in the Franz documentation for a description of the j-xxx-fn slots.
+
+(deftype simple-stream-buffer ()
+ '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
+
+(deftype blocking ()
+ `(member t nil :bnb))
+
+(deftype j-listen-fn ()
+ '(function (simple-stream) boolean))
+
+(deftype j-read-char-fn ()
+ '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
+
+(deftype j-read-chars-fn ()
+ '(function (simple-stream string (or character null) fixnum fixnum blocking)
+ (values fixnum &optional (member nil t :eof))))
+
+(deftype j-write-char-fn ()
+ '(function (character simple-stream) character))
+
+(deftype j-write-chars-fn ()
+ '(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?
+
+;;;
+;;; 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))
+
+(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)))))))
+
+(def-stream-class simple-stream (standard-object stream)
+ ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
+
+ ;; 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 :type j-listen-fn sb-pcl::location 18)
+ ;; A function that reads one character.
+ (j-read-char :type j-read-char-fn sb-pcl::location 17)
+ ;; A function that reads characters into a string.
+ (j-read-chars :type j-read-chars-fn sb-pcl::location 16)
+ ;; A function that writes one character.
+ (j-write-char :type j-write-char-fn sb-pcl::location 15)
+ ;; A function that writes characters from a string into the stream.
+ (j-write-chars :type j-write-chars-fn sb-pcl::location 14)
+ ;; A function that unreads the last character read.
+ (j-unread-char :type j-unread-char-fn sb-pcl::location 13)
+
+ ;; 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)
+ ;; 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)
+ :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
+ :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)))
+
+(def-stream-class probe-simple-stream (simple-stream)
+ ())
+
+;;; 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)
+ ;; 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 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)
+ ())
+
+(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)
+ ())
+
+;;; 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)
+ ;; 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)
+ ;; 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)
+ ())
+
+(def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
+ ())
+
+(def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
+ ())
+
+;;; A stream with a string as buffer.
+(def-stream-class string-simple-stream (simple-stream)
+ ;; The input/output 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 composing-stream (string-simple-stream)
+ ())
+
+(def-stream-class string-input-simple-stream (string-simple-stream)
+ ())
+
+(def-stream-class string-output-simple-stream (string-simple-stream)
+ ;; 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 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 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-open (stream options))
+
+(defgeneric device-close (stream abort))
+
+(defgeneric device-buffer-length (stream))
+
+(defgeneric device-file-position (stream))
+
+(defgeneric (setf device-file-position) (value stream))
+
+(defgeneric device-file-length (stream))
+
+(defgeneric device-read (stream buffer start end blocking))
+
+(defgeneric device-clear-input (stream buffer-only))
+
+(defgeneric device-write (stream buffer start end blocking))
+
+(defgeneric device-clear-output (stream))
+
+(defgeneric device-extend (stream need action))
+
+(defgeneric device-finish-record (stream blocking action))
--- /dev/null
+;;; -*- Lisp -*-
+
+;;; 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.
+
+;;; Some constants that are not (yet?) in sbcl itself. Basically,
+;;; constants needed for calling mmap from sbcl.
+
+;;; TODO (Rudi 2003-05-12): The contents of this file, along with
+;;; unix.lisp, should presumably end up somewhere else, either in sbcl
+;;; itself or in sb-posix.
+
+("stdio.h" "sys/types.h" "sys/stat.h" "fcntl.h" "asm/errno.h" "sys/mman.h")
+
+((:integer eacces "EACCES" "Error code for access error")
+ (:integer prot-none "PROT_NONE" "mmap: no protection")
+ (:integer prot-read "PROT_READ" "mmap: read protection")
+ (:integer prot-write "PROT_WRITE" "mmap: write protection")
+ (:integer prot-exec "PROT_EXEC" "mmap: execute protection")
+ (:integer map-shared "MAP_SHARED" "mmap: shared memory")
+ (:integer map-private "MAP_PRIVATE" "mmap: private mapping")
+ (:integer map-fixed "MAP_FIXED" "mmap: map at given location"))
+
+
--- /dev/null
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: COMMON-LISP -*-
+
+;;; 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.
+
+(in-package "COMMON-LISP")
+
+;; .../compiler/knownfun.lisp
+
+;; TODO: I suppose sbcl internals have sufficiently diverged from
+;; cmucl that this does not work after my primitive translation
+;; attempt. This is used in the cmucl version to compute (via
+;; :derive-type arg to defknown) the return type of open. For the
+;; time being, the new defknown form for open does not specify its
+;; return type.
+#+nil
+(defun result-type-open-class (call)
+ (declare (type sb-c::combination call))
+ (do ((args (sb-c::combination-args call) (cdr args)))
+ ((null args))
+ (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args)))))
+ (when (and (typep leaf 'sb-kernel:constant)
+ (eq (sb-c::constant-value leaf) :class)
+ (cdr args))
+ (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args)))))
+ (return (if (typep leaf 'sb-kernel:constant)
+ (find-class (sb-c::constant-value leaf) nil)
+ nil)))))))
+
+(handler-bind ((error #'(lambda (condition) (declare (ignore condition))
+ (continue))))
+ (sb-c:defknown open (t &rest t
+ &key (:direction (member :input :output :io :probe))
+ (:element-type sb-kernel:type-specifier)
+ (:if-exists (member :error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil))
+ (:if-does-not-exist (member :error :create nil))
+ (:external-format (member :default))
+ (:class (or symbol class))
+ (:mapped (member t nil))
+ (:input-handle (or null fixnum stream))
+ (:output-handle (or null fixnum stream))
+ &allow-other-keys)
+ (or stream null)
+ ()
+ ;; :derive-type #'result-type-open-class
+ )
+
+ (sb-c:defknown listen (&optional sb-kernel:streamlike
+ (or null (integer 1 10) (member 'character)))
+ boolean (sb-c::unsafely-flushable sb-c::explicit-check))
+
+ (sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)
+ (:end sb-kernel:sequence-end)
+ (:partial-fill boolean))
+ (sb-int:index) ())
+
+ (sb-c:defknown clear-input (&optional stream boolean) null
+ (sb-c::explicit-check)))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
+
+;;; 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.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; HELPER FUNCTIONS
+;;;
+
+;; 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)))
+ `(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 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 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))))))))
+
+
+(declaim (inline buffer-sap bref (setf bref) buffer-copy))
+
+(defun buffer-sap (thing &optional offset)
+ (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
+ (optimize (speed 3) (space 2) (debug 0) (safety 0)
+ ;; Suppress the note about having to box up the return:
+ (sb-ext:inhibit-warnings 3)))
+ (let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
+ (if offset (sb-sys:sap+ sap offset) sap)))
+
+(defun bref (buffer index)
+ (declare (type simple-stream-buffer buffer)
+ (type (integer 0 #.most-positive-fixnum) index))
+ (sb-sys:sap-ref-8 (buffer-sap buffer) index))
+
+(defun (setf bref) (octet buffer index)
+ (declare (type (unsigned-byte 8) octet)
+ (type simple-stream-buffer buffer)
+ (type (integer 0 #.most-positive-fixnum) index))
+ (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
+
+(defun buffer-copy (src soff dst doff length)
+ (declare (type simple-stream-buffer src dst)
+ (type fixnum soff doff length))
+ (sb-sys:without-gcing ;; is this necessary??
+ (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
+ (buffer-sap dst) (* doff 8)
+ (* length 8))))
+
+(defun allocate-buffer (size)
+ (if (= size sb-impl::bytes-per-buffer)
+ (sb-impl::next-available-buffer)
+ (make-array size :element-type '(unsigned-byte 8))))
+
+(defun free-buffer (buffer)
+ (when (not (vectorp buffer))
+ (push buffer sb-impl::*available-buffers*))
+ t)
+
+(defun %fd-open (pathname direction if-exists if-exists-given
+ if-does-not-exist if-does-not-exist-given)
+ (declare (type pathname pathname)
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist))
+ (multiple-value-bind (input output mask)
+ (ecase direction
+ (:input (values t nil sb-unix:o_rdonly))
+ (:output (values nil t sb-unix:o_wronly))
+ (:io (values t t sb-unix:o_rdwr))
+ (:probe (values t nil sb-unix:o_rdonly)))
+ (declare (type sb-int:index mask))
+ (let ((name (cond ((sb-int:unix-namestring pathname input))
+ ((and input (eq if-does-not-exist :create))
+ (sb-int:unix-namestring pathname nil)))))
+ ;; Process if-exists argument if we are doing any output.
+ (cond (output
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (case if-exists
+ ((:error nil)
+ (setf mask (logior mask sb-unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb-unix:o_creat)))
+ ((:new-version :supersede)
+ (setf mask (logior mask sb-unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb-unix:o_append)))))
+ (t
+ (setf if-exists nil))) ; :ignore-this-arg
+ (unless if-does-not-exist-given
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
+ (if (eq if-does-not-exist :create)
+ (setf mask (logior mask sb-unix:o_creat)))
+
+ (let ((original (if (member if-exists
+ '(:rename :rename-and-delete))
+ (sb-impl::pick-backup-name name)
+ nil))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when original
+ ;; We are doing a :rename or :rename-and-delete.
+ ;; Determine if the file already exists, make sure the original
+ ;; file is not a directory and keep the mode
+ (let ((exists
+ (and name
+ (multiple-value-bind
+ (okay err/dev inode orig-mode)
+ (sb-unix:unix-stat name)
+ (declare (ignore inode)
+ (type (or sb-int:index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Cannot open ~S for output: Is a directory."
+ :format-arguments (list name)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb-unix:enoent)
+ nil)
+ (t
+ (error 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Cannot find ~S: ~A"
+ :format-arguments
+ (list name
+ (sb-int:strerror err/dev)))))))))
+ (unless (and exists
+ (rename-file name original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use SUPERSEDE instead, we have
+ ;; to make sure unix:o_creat corresponds to
+ ;; if-does-not-exist. unix:o_creat was set
+ ;; before because of if-exists being :rename.
+ (unless (eq if-does-not-exist :create)
+ (setf mask (logior (logandc2 mask sb-unix:o_creat)
+ sb-unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Okay, now we can try the actual open.
+ (loop
+ (multiple-value-bind (fd errno)
+ (if name
+ (sb-unix:unix-open name mask mode)
+ (values nil sb-unix:enoent))
+ (cond ((sb-int:fixnump fd)
+ (return (values fd name original delete-original)))
+ ((eql errno sb-unix:enoent)
+ (case if-does-not-exist
+ (:error
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (:create
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control
+ "Error creating ~S, path does not exist."
+ :format-arguments (list pathname))))
+ (return nil))
+ ((eql errno sb-unix:eexist)
+ (unless (eq nil if-exists)
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (return nil))
+ #+nil ; FIXME: reinstate this; error reporting is nice.
+ ((eql errno sb-unix:eacces)
+ (cerror "Try again."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno))))
+ (t
+ (cerror "Return NIL."
+ 'sb-int:simple-file-error
+ :pathname pathname
+ :format-control "Error opening ~S, ~A."
+ :format-arguments
+ (list pathname
+ (sb-int:strerror errno)))
+ (return nil)))))))))
+
+(defun open-fd-stream (pathname &key (direction :input)
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default))
+ (declare (type (or pathname string stream) pathname)
+ (type (member :input :output :io :probe) direction)
+ (type (member :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede nil) if-exists)
+ (type (member :error :create nil) if-does-not-exist)
+ (ignore external-format))
+ (setq pathname (pathname pathname))
+ (multiple-value-bind (fd namestring original delete-original)
+ (%fd-open pathname direction if-exists if-exists-given
+ if-does-not-exist if-does-not-exist-given)
+ (when fd
+ (case direction
+ ((:input :output :io)
+ (sb-sys:make-fd-stream fd
+ :input (member direction '(:input :io))
+ :output (member direction '(:output :io))
+ :element-type element-type
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream))))))
+
+
+;; Make PATHNAME and NAMESTRING work
+(defun cl::file-name (stream &optional new-name)
+ (typecase stream
+ (file-simple-stream
+ (with-stream-class (file-simple-stream stream)
+ (cond (new-name
+ (setf (sm pathname stream) new-name)
+ (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
+ t)
+ (t
+ (sm pathname 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))))))
+
+;; Experimental "filespec" stuff
+
+;; sat: Hooks to parse URIs etc apparently go here
+
+(defstruct (filespec-parser
+ (:constructor make-filespec-parser (name priority function)))
+ name
+ priority
+ function)
+
+(defvar *filespec-parsers* ())
+
+(defun add-filespec (name priority function)
+ (let ((filespec (make-filespec-parser name priority function)))
+ (setf *filespec-parsers*
+ (stable-sort (cons filespec (delete name *filespec-parsers*
+ :key #'filespec-parser-name))
+ #'>
+ :key #'filespec-parser-priority)))
+ t)
+
+(defmacro define-filespec (name lambda-list &body body)
+ (let ((truename (if (consp name) (first name) name))
+ (priority (if (consp name) (second name) 0)))
+ `(add-filespec ',truename ,priority (lambda ,lambda-list
+ (block ,truename
+ ,@body)))))
+
+(defun parse-filespec (string &optional (errorp t))
+ (dolist (i *filespec-parsers* (when errorp
+ (error "~S not recognised." string)))
+ (let ((result (ignore-errors
+ (funcall (filespec-parser-function i) string))))
+ (when result (return result)))))
+
+(define-filespec pathname (string)
+ (pathname string))
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+;;; This is just for compatibility with Franz demo code
+(defpackage "EXCL"
+ (:use "SB-SIMPLE-STREAM")
+ (:import-from "SB-SIMPLE-STREAM"
+ "BUFFER" "BUFFPOS" "BUFFER-PTR"
+ "OUT-BUFFER" "MAX-OUT-POS"
+ "INPUT-HANDLE" "OUTPUT-HANDLE"
+ "MELDED-STREAM"
+ "J-READ-CHARS"))
+
+(use-package "SB-SIMPLE-STREAMS")
+
+(provide :iodefs)
+
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+
+(defpackage sb-simple-streams
+ (:use #:common-lisp)
+ (:import-from #:sb-kernel #:ansi-stream)
+ (:import-from #:sb-gray #:fundamental-stream)
+ (:export ;; Stream classes
+ #:STREAM
+ #:SIMPLE-STREAM
+ #:PROBE-SIMPLE-STREAM
+ #:SINGLE-CHANNEL-SIMPLE-STREAM
+ #:DIRECT-SIMPLE-STREAM
+ #:BUFFER-INPUT-SIMPLE-STREAM
+ #:BUFFER-OUTPUT-SIMPLE-STREAM
+ #:NULL-SIMPLE-STREAM
+ #:FILE-SIMPLE-STREAM
+ #:MAPPED-FILE-SIMPLE-STREAM
+ #:DUAL-CHANNEL-SIMPLE-STREAM
+ #:TERMINAL-SIMPLE-STREAM
+ #:SOCKET-SIMPLE-STREAM
+ #:SOCKET-BASE-SIMPLE-STREAM
+ #:HIPER-SOCKET-SIMPLE-STREAM
+ #:STRING-SIMPLE-STREAM
+ #:COMPOSING-STREAM
+ #:STRING-INPUT-SIMPLE-STREAM
+ #:STRING-OUTPUT-SIMPLE-STREAM
+ #:FILL-POINTER-OUTPUT-SIMPLE-STREAM
+ #:LIMITED-STRING-OUTPUT-SIMPLE-STREAM
+ #:XP-SIMPLE-STREAM
+ #:ANNOTATION-OUTPUT-SIMPLE-STREAM
+ ;; Streams
+ #:*STANDARD-INPUT* #:*STANDARD-OUTPUT* #:*ERROR-OUTPUT*
+ #:*QUERY-IO* #:*DEBUG-IO* #:*TRACE-OUTPUT* #:*TERMINAL-IO*
+ ;; Slot accessors
+ #:STREAM-INPUT-HANDLE #:STREAM-OUTPUT-HANDLE
+ #:STREAM-PLIST
+ ;; Device-level functions
+ #:DEVICE-OPEN #:DEVICE-CLOSE #:DEVICE-BUFFER-LENGTH
+ #:DEVICE-FILE-POSITION #:DEVICE-FILE-LENGTH #:DEVICE-READ
+ #:DEVICE-CLEAR-INPUT #:DEVICE-WRITE #:DEVICE-CLEAR-OUTPUT
+ #:DEVICE-EXTEND #:DEVICE-FINISH-RECORD
+ ;; Implementation functions/macros
+ #:WITH-STREAM-CLASS #:SM #:FUNCALL-STM-HANDLER
+ #:FUNCALL-STM-HANDLER-2 #:ADD-STREAM-INSTANCE-FLAGS
+ #:REMOVE-STREAM-INSTANCE-FLAGS
+ ;; User-level functions (mostly reexported from COMMON-LISP)
+ #:PARSE-FILESPEC #:DEFINE-FILESPEC #:DEFAULT-OPEN-CLASS #:OPEN
+ #:CLOSE #:READ-BYTE #:READ-CHAR #:READ-CHAR-NO-HANG #:UNREAD-CHAR
+ #:PEEK-CHAR #:LISTEN #:READ-LINE #:READ-SEQUENCE #:CLEAR-INPUT
+ #:WRITE-BYTE #:WRITE-CHAR #:WRITE-STRING #:WRITE-SEQUENCE #:TERPRI
+ #:FRESH-LINE #:FINISH-OUTPUT #:FORCE-OUTPUT #:CLEAR-OUTPUT
+ #:FILE-POSITION #:FILE-LENGTH #:LINE-LENGTH #:CHARPOS
+ #:STREAM-ELEMENT-TYPE #:STREAM-EXTERNAL-FORMAT #:STREAMP
+ #:OPEN-STREAM-P #:INPUT-STREAM-P #:OUTPUT-STREAM-P
+ #:INTERACTIVE-STREAM-P #:READ-VECTOR #:WRITE-VECTOR #:READ-OCTETS
+ #:WRITE-OCTETS #:DEF-STREAM-CLASS #:WAIT-FOR-INPUT-AVAILABLE
+ ;; higher level things (reexported from COMMON-LISP)
+ #:WITH-OPEN-FILE #:WITH-OPEN-STREAM #:FORMAT #:PPRINT #:PRIN1
+ #:PRIN1-TO-STRING #:PRINC #:PRINC-TO-STRING #:PRINT #:READ
+ #:READ-DELIMITED-LIST #:READ-FROM-STRING #:WRITE #:WRITE-LINE
+ #:WRITE-TO-STRING #:READ-PRESERVING-WHITESPACE))
+
+#||
+(in-package "SB-EXT")
+(defgeneric stream-file-position (stream &optional position))
+(defgeneric stream-file-length (stream))
+(export '(stream-file-position stream-file-length))
+||#
\ No newline at end of file
--- /dev/null
+;;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :sb-grovel))
+(defpackage #:sb-simple-stream-system (:use #:asdf #:cl #:sb-grovel))
+(in-package #:sb-simple-stream-system)
+
+
+(defsystem sb-simple-streams
+ :depends-on (sb-rt sb-grovel)
+ :components ((:file "package")
+ (:file "fndb")
+ (grovel-constants-file "constants"
+ :package :sb-simple-streams
+ :pathname "constants.lisp"
+ :depends-on ("package"))
+ ;; (:file "stuff_grovelled_from_headers")
+ (:file "unix" :depends-on ("constants"))
+ ;;(:file "pcl")
+ ;;(:file "ext-format" :depends-on ("package"))
+ (:file "classes" :depends-on ("package"))
+ (:file "internal" :depends-on ("classes"))
+ (:file "strategy" :depends-on ("internal"))
+ (:file "cl" :depends-on ("internal" "fndb"))
+ (:file "simple-streams" :depends-on ("cl" "strategy" "unix"))
+ ;;(:file "gray-compat" :depends-on ("package"))
+ ;;(:file "iodefs" :depends-on ("package"))
+ (:file "simple-stream-tests" :depends-on ("simple-streams"))
+ ))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-simple-streams))))
+ (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
+ (error "test-op failed")))
+
+
--- /dev/null
+;;;; -*- lisp -*-
+
+(defpackage sb-simple-streams-test
+ (:use #:common-lisp #:sb-simple-streams #:sb-rt))
+
+
+(in-package #:sb-simple-streams-test)
+
+(defparameter *dumb-string* "This file created by simple-stream-tests.lisp. Nothing to see here, move along.")
+
+(defparameter *test-path* (merge-pathnames
+ (make-pathname :name nil :type nil :version nil)
+ *load-truename*))
+
+(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
+
+(deftest create-file-1
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
+ (stream-object (make-instance 'file-simple-stream
+ :filename file
+ :direction :output
+ :if-exists :overwrite)))
+ (prog1
+ (with-open-stream (s stream-object)
+ (string= (write-string *dumb-string* s) *dumb-string*))
+ (delete-file file)))
+ t)
+
+(deftest create-file-2
+ (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (prog1
+ (with-open-file (s file
+ :class 'file-simple-stream
+ :direction :output :if-exists :overwrite)
+ (string= (write-string *dumb-string* s) *dumb-string*))
+ (delete-file file)))
+ t)
+
+(deftest create-read-file-1
+ (let ((result t)
+ (file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (let ((stream-object (make-instance 'file-simple-stream
+ :filename file
+ :direction :output
+ :if-exists :overwrite)))
+ (with-open-stream (s stream-object)
+ (setf result (and result (string= (write-string *dumb-string* s)
+ *dumb-string*)))
+ (terpri s)))
+ (let ((stream-object (make-instance 'file-simple-stream
+ :filename file
+ :direction :input)))
+ (with-open-stream (s stream-object)
+ (setf result (and result (string= (read-line s) *dumb-string*)))))
+ result)
+ t)
+
+(deftest create-read-mapped-file-1
+ (let ((result t)
+ (file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-open-file (s file
+ :class 'file-simple-stream
+ :direction :output :if-exists :overwrite)
+ (setf result (and result (string= (write-string *dumb-string* s)
+ *dumb-string*))))
+ (with-open-file (s file
+ :class 'mapped-file-simple-stream
+ :direction :input)
+ (setf result (and result (string= (read-line s) *dumb-string*))))
+ (delete-file file)
+ result)
+ t)
+
+
+
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+;;;
+;;; Stream printing
+;;;
+
+(defmethod print-object ((object file-simple-stream) stream)
+ (print-unreadable-object (object stream :type t :identity t)
+ (format stream "for ~S" (slot-value object 'filename))))
+
+(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 *terminal-control-in-table*
+ (make-control-table #\Newline #'std-dc-newline-in-handler))
+
+;;;
+;;; LOW LEVEL STUFF
+;;;
+
+(defun vector-elt-width (vector)
+ ;; Return octet-width of vector elements
+ (etypecase vector
+ ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
+ ;; [and base-char, which is treated specially]
+ ((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)))
+
+(defun endian-swap-value (vector endian-swap)
+ (case endian-swap
+ (:network-order (case (vector-elt-width vector)
+ (1 0)
+ (2 1)
+ (4 3)
+ (8 7)
+ (16 15)))
+ (:byte-8 0)
+ (:byte-16 1)
+ (:byte-32 3)
+ (:byte-64 7)
+ (:byte-128 15)
+ (otherwise endian-swap)))
+
+(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)))
+ (char (funcall-stm-handler j-read-char stream nil nil t)))
+ (when char
+ (setf (schar vector start) char)
+ (incf start)
+ (+ start (funcall-stm-handler j-read-chars stream vector nil
+ start end nil))))
+ (do* ((j-read-byte
+ (cond ((any-stream-instance-flags stream :string)
+ (error "Can't READ-BYTE on string streams."))
+ ((any-stream-instance-flags stream :dual)
+ #'dc-read-byte)
+ (t
+ #'sc-read-byte)))
+ (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 stream nil nil t)
+ (funcall j-read-byte stream 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))))
+
+#|(defun write-vector ...)|#
+
+;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun getpagesize ()
+ (sb-unix::int-syscall ("getpagesize"))))
+
+(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 ;#.(sb-unix:unix-getpagesize)
+ (the fixnum (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 t "~&;; UNIX-READ: errno=~D~%" errno)
+ (cond ((= errno sb-unix:eintr) (go again))
+ ((and blocking
+ (or (= errno ;;sb-unix:eagain
+ ;; FIXME: 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 (error "implement me"))))))
+
+(defun write-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))
+ (with-stream-class (simple-stream stream)
+ (let ((fd (sm output-handle stream))
+ (end (or end (error "WRITE-OCTETS: end=NIL")))
+ (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
+ (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 t "~&;; 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"))))))
+
+
+;;;
+;;; IMPLEMENTATIONS
+;;;
+
+(defmethod device-open ((stream null-simple-stream) options)
+ (add-stream-instance-flags stream :simple :input :output)
+ stream)
+
+(defmethod device-open ((stream buffer-input-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream buffer-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defun open-file-stream (stream options)
+ (let ((filename (getf options :filename))
+ (direction (getf options :direction :input))
+ (if-exists (getf options :if-exists))
+ (if-exists-given (not (getf options :if-exists t)))
+ (if-does-not-exist (getf options :if-does-not-exist))
+ (if-does-not-exist-given (not (getf options :if-does-not-exist 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 (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)))
+ 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)))
+ ;; Buffer should be array of (unsigned-byte 8), in general
+ ;; use strings for now so it's easy to read the content...
+ (setf (sm buffer stream) (make-string 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*))
+ (install-single-channel-character-strategy
+ stream (getf options :external-format :default) nil))))
+
+(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 PROT-READ 0)
+ (if output PROT-WRITE 0)))
+ (fd (or (sm input-handle stream) (sm output-handle 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-EXTEND can adjust
+ ;; the mapped portion of the file?
+ (warn "Unable to memory-map entire file.")
+ (setf size most-positive-fixnum))
+ (let ((buffer
+ (sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
+ (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)
+ (install-single-channel-character-strategy
+ stream (getf options :external-format :default) 'mapped)
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-unix:unix-munmap buffer size)
+ (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
+ stream))
+
+(defmethod device-open ((stream string-input-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream string-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream xp-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream socket-base-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream socket-simple-stream) options)
+ #| do something |#
+ 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 :interactive :dual :input)
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm buffer stream) (make-string 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 :interactive :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*))
+ (install-dual-channel-character-strategy
+ stream (getf options :external-format :default)))
+ #| do something |#
+ 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)
+ (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))))
+
+(defmethod device-close ((stream simple-stream) abort)
+ (declare (ignore abort))
+ t)
+
+(defmethod device-close ((stream file-simple-stream) abort)
+ (with-stream-class (file-simple-stream stream)
+ (cond (abort
+ ;; Remove any fd-handler
+ ;; If it's an output stream and has an original name,
+ ;; revert the file
+ )
+ (t
+ ;; If there's an original name and delete-original is set
+ ;; kill the original
+ ))
+ (if (sm input-handle stream)
+ (sb-unix:unix-close (sm input-handle stream))
+ (sb-unix:unix-close (sm output-handle stream)))
+ (setf (sm buffer stream) nil))
+ t)
+
+(defmethod device-close ((stream mapped-file-simple-stream) abort)
+ (with-stream-class (mapped-file-simple-stream stream)
+ (when (sm buffer stream)
+ (sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
+ (setf (sm buffer stream) nil))
+ (cond (abort
+ ;; remove any FD handler
+ ;; if it has an original name (is this possible for mapped files?)
+ ;; revert the file
+ )
+ (t
+ ;; if there's an original name and delete-original is set (again,
+ ;; is this even possible?), kill the original
+ ))
+ (sb-unix:unix-close (sm input-handle stream)))
+ t)
+
+
+(defmethod device-buffer-length ((stream simple-stream))
+ 4096)
+
+(defmethod device-buffer-length ((stream null-simple-stream))
+ 256)
+
+
+(defmethod device-file-position ((stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ ;; this may be wrong if :DUAL flag is set!
+ (sm buffpos stream)))
+
+(defmethod (setf device-file-position) (value (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ ;; this may be wrong if :DUAL flag is set!
+ (setf (sm buffpos stream) value)))
+
+(defmethod device-file-position ((stream string-simple-stream))
+ ;; get string length (of input or output buffer?)
+ )
+
+(defmethod (setf device-file-position) (value (stream string-simple-stream))
+ ;; set string length (of input or output buffer?)
+ )
+
+(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
+ ;; get fill pointer (of input or output buffer?)
+ )
+
+(defmethod (setf device-file-position)
+ (value (stream fill-pointer-output-simple-stream))
+ ;; set fill pointer (of input or output buffer?)
+ )
+
+(defmethod device-file-position ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (values (sb-unix:unix-lseek (or (sm input-handle stream)
+ (sm output-handle stream))
+ 0
+ sb-unix:l_incr))))
+
+(defmethod (setf device-file-position) (value (stream file-simple-stream))
+ (declare (type fixnum value))
+ (with-stream-class (file-simple-stream stream)
+ (values (sb-unix:unix-lseek (or (sm input-handle stream)
+ (sm output-handle stream))
+ value
+ (if (minusp value)
+ sb-unix:l_xtnd
+ sb-unix:l_set)))))
+
+
+(defmethod device-file-length ((stream simple-stream))
+ nil)
+
+(defmethod device-file-length ((stream direct-simple-stream))
+ ;; return buffer length
+ )
+
+(defmethod device-file-length ((stream string-simple-stream))
+ ;; return string length
+ )
+
+(defmethod device-file-length ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (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))))
+
+
+(defmethod device-read ((stream single-channel-simple-stream) buffer
+ start end blocking)
+;; (when (and (null buffer) (not (eql start end)))
+;; (with-stream-class (single-channel-simple-stream stream)
+;; (setq buffer (sm buffer stream))
+;; (setq end (sm buf-len stream))))
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ (when (null buffer)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setq buffer (sm buffer stream))
+ (setq end (- (sm buf-len stream) start))))
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer start end blocking))
+ -1)
+
+(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 simple-stream) buffer-only)
+ (declare (ignore buffer-only))
+ nil)
+
+(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
+ )
+
+
+(defmethod device-write ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ (when (and (null buffer) (not (eql start end)))
+ (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)
+ (when (and (null buffer) (not (eql start end)))
+ (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-write ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer blocking))
+ (- end start))
+
+(defmethod device-write ((stream socket-base-simple-stream) buffer
+ start end blocking)
+ ;; @@2
+ (call-next-method))
+
+
+(defmethod device-clear-output ((stream simple-stream))
+ nil)
+
+
+(defmethod device-extend ((stream direct-simple-stream) need action)
+ (declare (ignore need action))
+ nil)
+
+(defmethod device-extend ((stream string-input-simple-stream) need action)
+ (declare (ignore need action))
+ nil)
+
+(defmethod device-extend ((stream string-output-simple-stream) need action)
+ ;; @@3
+ )
+
+(defmethod device-extend ((stream fill-pointer-output-simple-stream)
+ need action)
+ ;; @@4
+ )
+
+(defmethod device-extend ((stream mapped-file-simple-stream) need action)
+ (declare (ignore need action))
+ nil)
+
+
+;; device-finish-record apparently has no methods defined
+
+
+;;;
+;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
+;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
+;;;
+
+
+;;;
+;;; CREATION OF STANDARD STREAMS
+;;;
+
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+(in-package "SB-SIMPLE-STREAMS")
+
+
+(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))
+ (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 sc-flush-buffer (stream blocking)
+ (with-stream-class (single-channel-simple-stream stream)
+ (let ((ptr 0)
+ (bytes (sm buffpos stream)))
+ (declare (type fixnum ptr bytes))
+ (loop
+ (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
+ (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 dc-flush-buffer (stream blocking)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (let ((ptr 0)
+ (bytes (sm outpos stream)))
+ (declare (type fixnum ptr bytes))
+ (loop
+ (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
+ (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))))))
+
+;;;
+;;; SINGLE-CHANNEL 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 (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)
+ (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)
+ ;; 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
+ ;; :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)
+ ;; 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 (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)
+ (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)))
+ ;; TODO: what about the blocking parameter?
+ (with-stream-class (single-channel-simple-stream stream)
+ (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))
+ (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 (ignore relaxed))
+ (with-stream-class (single-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 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))
+ (if (< ptr (sm buffer-ptr stream))
+ (progn
+ (setf (bref buffer ptr) code)
+ (setf (sm buffpos stream) (1+ ptr)))
+ (progn
+ (sc-flush-buffer stream t)
+ (setf ptr (sm buffpos stream))))))
+ character)
+
+(declaim (ftype j-write-chars-fn sc-write-chars))
+(defun sc-write-chars (string stream start end)
+ (with-stream-class (single-channel-simple-stream stream)
+ (do ((buffer (sm buffer stream))
+ (ptr (sm buffpos stream))
+ ;; xxx buffer-ptr or buf-len? TODO: look them up in the
+ ;; docs; was: buffer-ptr, but it's initialized to 0 in
+ ;; (device-open file-simple-stream); buf-len seems to work(tm)
+ (max #+nil(sm buffer-ptr stream) ;; or buf-len?
+ (sm buf-len stream))
+ (ctrl (sm control-out stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end) (setf (sm buffpos stream) ptr) count)
+ (declare (type fixnum ptr max 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))
+ (if (< ptr max)
+ (progn
+ (setf (bref buffer ptr) code)
+ (incf ptr))
+ (progn
+ (sc-flush-buffer stream t)
+ (setf ptr (sm buffpos stream)))))))))
+
+(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."))))))
+
+;;;
+;;; 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 (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 (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)
+ (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))
+ (if (< ptr (sm max-out-pos stream))
+ (progn
+ (setf (bref buffer ptr) code)
+ (setf (sm outpos stream) (1+ ptr)))
+ (progn
+ (dc-flush-buffer stream t)
+ (setf ptr (sm outpos stream))))))
+ character)
+
+(declaim (ftype j-write-chars-fn dc-write-chars))
+(defun dc-write-chars (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))
+ (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))
+ (if (< ptr max)
+ (progn
+ (setf (bref buffer ptr) code)
+ (incf ptr))
+ (progn
+ (dc-flush-buffer stream t)
+ (setf ptr (sm outpos stream)))))))))
+
+(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."))))))
+
+;;;
+;;; STRING STRATEGY FUNCTIONS
+;;;
+
+(declaim (ftype j-read-char-fn string-read-char))
+(defun string-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)))
+ (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)))
+ (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?
+ (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)))
+ ;; 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)
+ (declare (ignore relaxed))
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
+
+;;;
+;;;
+;;;
+
+(defun install-single-channel-character-strategy (stream external-format
+ access)
+ (declare (ignore 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)))
+ stream)
+
+(defun install-dual-channel-character-strategy (stream external-format)
+ (declare (ignore external-format))
+ (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))
+ stream)
+
+(defun install-string-character-strategy (stream)
+ (with-stream-class (string-simple-stream stream)
+ (setf (sm j-read-char stream) #'string-read-char))
+ stream)
--- /dev/null
+;;; -*- lisp -*-
+
+;;; 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.
+
+;;; TODO (Rudi 2003-05-12): The contents of this file, along with
+;;; constants.lisp, should presumably end up somewhere else, either in
+;;; sbcl itself or in sb-posix.
+
+(in-package "SB-UNIX")
+
+
+;;; TODO (Rudi 2003-05-12): Check whether this bug exists in sbcl, fix
+;;; it if yes, and take care not to break platforms where the offset
+;;; is not a 32-bit signed integer.
+
+;; Fix bug that claims offset is unsigned, so seeking backwards works!
+(defun unix-lseek (fd offset whence)
+ "Unix-lseek accepts a file descriptor and moves the file pointer ahead
+ a certain offset for that file. Whence can be any of the following:
+
+ l_set Set the file pointer.
+ l_incr Increment the file pointer.
+ l_xtnd Extend the file size.
+ "
+ (declare (type unix-fd fd)
+ (type (signed-byte 32) offset)
+ (type (integer 0 2) whence))
+ (int-syscall ("lseek" int off-t int) fd offset whence))
+
+(export '(prot-read prot-write prot-exec prot-none
+ map-shared map-private map-fixed
+ unix-mmap unix-munmap
+ unix-mlock unix-munlock))
+
+
+(defun unix-mmap (addr length prot flags fd offset)
+ (declare (type (or null system-area-pointer) addr)
+ (type (unsigned-byte 32) length)
+ (type (integer 1 7) prot)
+ (type (unsigned-byte 32) flags)
+ (type (or null unix-fd) fd)
+ (type (signed-byte 32) offset))
+ (let ((result (alien-funcall (extern-alien "mmap"
+ (function system-area-pointer
+ system-area-pointer
+ size-t int int int
+ off-t))
+ (or addr (sb-sys:int-sap 0)) length prot flags
+ (or fd -1) offset)))
+ ;; FIXME (Rudi 2003-05-12) : here, we assume that a sap is 32
+ ;; bits. Revisit during the 64-bit port. #XFFFFFFFF is (void
+ ;; *)-1, which is the charming return value of mmap on failure.
+ (if (= (sb-sys:sap-int result) #XFFFFFFFF)
+ (values nil (get-errno))
+ result)))
+
+(defun unix-munmap (start length)
+ (declare (type system-area-pointer start)
+ (type (unsigned-byte 32) length))
+ (void-syscall ("munmap" system-area-pointer size-t) start length))
+
+(defun unix-mlock (addr length)
+ (declare (type system-area-pointer addr)
+ (type (unsigned-byte 32) length))
+ (void-syscall ("mlock" system-area-pointer size-t) addr length))
+
+(defun unix-munlock (addr length)
+ (declare (type system-area-pointer addr)
+ (type (unsigned-byte 32) length))
+ (void-syscall ("munlock" system-area-pointer size-t) addr length))
+
+
+
;;; 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.8alpha.0.26"
+"0.8alpha.0.27"
projects / sbcl.git / commitdiff