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