diff --git a/NEWS b/NEWS index 5a501fd1a..a9627a6e8 100644 --- a/NEWS +++ b/NEWS @@ -1711,6 +1711,9 @@ changes in sbcl-0.8alpha.0 relative to sbcl-0.7.14 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 diff --git a/contrib/sb-simple-streams/Makefile b/contrib/sb-simple-streams/Makefile new file mode 100644 index 000000000..815e32d46 --- /dev/null +++ b/contrib/sb-simple-streams/Makefile @@ -0,0 +1,2 @@ +SYSTEM=sb-simple-streams +include ../asdf-module.mk diff --git a/contrib/sb-simple-streams/README b/contrib/sb-simple-streams/README new file mode 100644 index 000000000..47f3a2884 --- /dev/null +++ b/contrib/sb-simple-streams/README @@ -0,0 +1,57 @@ +-*- 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. diff --git a/contrib/sb-simple-streams/cl.lisp b/contrib/sb-simple-streams/cl.lisp new file mode 100644 index 000000000..9d5114a36 --- /dev/null +++ b/contrib/sb-simple-streams/cl.lisp @@ -0,0 +1,1039 @@ +;;; -*- 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 "~@" + 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)))) diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp new file mode 100644 index 000000000..51d2bd187 --- /dev/null +++ b/contrib/sb-simple-streams/classes.lisp @@ -0,0 +1,347 @@ +;;; -*- 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)) diff --git a/contrib/sb-simple-streams/constants.lisp b/contrib/sb-simple-streams/constants.lisp new file mode 100644 index 000000000..c61372960 --- /dev/null +++ b/contrib/sb-simple-streams/constants.lisp @@ -0,0 +1,27 @@ +;;; -*- 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")) + + diff --git a/contrib/sb-simple-streams/fndb.lisp b/contrib/sb-simple-streams/fndb.lisp new file mode 100644 index 000000000..20b3d1c84 --- /dev/null +++ b/contrib/sb-simple-streams/fndb.lisp @@ -0,0 +1,63 @@ +;;; -*- 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))) diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp new file mode 100644 index 000000000..4f79d4b9e --- /dev/null +++ b/contrib/sb-simple-streams/internal.lisp @@ -0,0 +1,425 @@ +;;; -*- 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)) diff --git a/contrib/sb-simple-streams/iodefs.lisp b/contrib/sb-simple-streams/iodefs.lisp new file mode 100644 index 000000000..176fc6641 --- /dev/null +++ b/contrib/sb-simple-streams/iodefs.lisp @@ -0,0 +1,22 @@ +;;; -*- 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) + diff --git a/contrib/sb-simple-streams/package.lisp b/contrib/sb-simple-streams/package.lisp new file mode 100644 index 000000000..eac4c5328 --- /dev/null +++ b/contrib/sb-simple-streams/package.lisp @@ -0,0 +1,75 @@ +;;; -*- 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 diff --git a/contrib/sb-simple-streams/sb-simple-streams.asd b/contrib/sb-simple-streams/sb-simple-streams.asd new file mode 100644 index 000000000..a652c3bfb --- /dev/null +++ b/contrib/sb-simple-streams/sb-simple-streams.asd @@ -0,0 +1,35 @@ +;;; -*- 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"))) + + diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp new file mode 100644 index 000000000..9664814ab --- /dev/null +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -0,0 +1,75 @@ +;;;; -*- 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) + + + diff --git a/contrib/sb-simple-streams/simple-streams.lisp b/contrib/sb-simple-streams/simple-streams.lisp new file mode 100644 index 000000000..1c4e316e1 --- /dev/null +++ b/contrib/sb-simple-streams/simple-streams.lisp @@ -0,0 +1,624 @@ +;;; -*- 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 +;;; + diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp new file mode 100644 index 000000000..f7e2eb3aa --- /dev/null +++ b/contrib/sb-simple-streams/strategy.lisp @@ -0,0 +1,522 @@ +;;; -*- 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) diff --git a/contrib/sb-simple-streams/unix.lisp b/contrib/sb-simple-streams/unix.lisp new file mode 100644 index 000000000..ff15c898f --- /dev/null +++ b/contrib/sb-simple-streams/unix.lisp @@ -0,0 +1,77 @@ +;;; -*- 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)) + + + diff --git a/version.lisp-expr b/version.lisp-expr index ca6142365..f9bbf13d6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"