mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
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)
This commit is contained in:
Rudi Schlatte
parent
303253a69e
commit
cc9a73604f
|
|
@ -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).
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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,290 +40,104 @@
|
|||
'(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)
|
||||
(control-in :initform nil :type (or null simple-vector))
|
||||
(control-out :initform nil :type (or null simple-vector))
|
||||
|
||||
;; 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 sb-pcl::location 1)
|
||||
;; instance flags (not a normal slot in Allegro CL)
|
||||
(%flags :initform 0 :type fixnum sb-pcl::location 0)))
|
||||
(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))
|
||||
|
||||
(def-stream-class probe-simple-stream (simple-stream)
|
||||
())
|
||||
|
||||
;;; A stream with a single buffer, for example a file stream.
|
||||
(def-stream-class single-channel-simple-stream (simple-stream)
|
||||
;; Input/output buffer.
|
||||
((buffer :initform nil :type (or simple-stream-buffer null)
|
||||
sb-pcl::location 23)
|
||||
(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)))
|
||||
(buffer-ptr :initform 0 :type fixnum)
|
||||
(buf-len :initform 0 :type fixnum)
|
||||
|
||||
(def-stream-class direct-simple-stream (single-channel-simple-stream)
|
||||
())
|
||||
(pending :initform nil :type list)
|
||||
(handler :initform nil :type (or null sb-impl::handler))))
|
||||
|
||||
(def-stream-class buffer-input-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)))
|
||||
|
||||
(def-stream-class buffer-output-simple-stream (direct-simple-stream)
|
||||
((out-buffer :initform nil :type (or simple-stream-buffer null)
|
||||
sb-pcl::location 26)
|
||||
;; Current position in output buffer.
|
||||
(outpos :initform 0 :type fixnum sb-pcl::location 25)
|
||||
;; Buffer length (one greater than maximum output buffer index)
|
||||
(max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
|
||||
|
||||
(def-stream-class null-simple-stream (single-channel-simple-stream)
|
||||
())
|
||||
|
||||
(def-stream-class file-simple-stream (single-channel-simple-stream)
|
||||
((pathname :initform nil :initarg :pathname 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)
|
||||
))
|
||||
|
||||
(def-stream-class mapped-file-simple-stream (file-simple-stream
|
||||
direct-simple-stream)
|
||||
())
|
||||
|
||||
;;; A stream with two octet buffers, for example a socket or terminal
|
||||
;;; stream.
|
||||
(def-stream-class dual-channel-simple-stream (simple-stream)
|
||||
(;; Output buffer.
|
||||
(out-buffer :initform nil :type (or simple-stream-buffer null)
|
||||
sb-pcl::location 26)
|
||||
(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)
|
||||
|
|
|
|||
40
contrib/sb-simple-streams/direct.lisp
Normal file
40
contrib/sb-simple-streams/direct.lisp
Normal file
|
|
@ -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)
|
||||
|
||||
|
||||
274
contrib/sb-simple-streams/file.lisp
Normal file
274
contrib/sb-simple-streams/file.lisp
Normal file
|
|
@ -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))))
|
||||
1340
contrib/sb-simple-streams/impl.lisp
Normal file
1340
contrib/sb-simple-streams/impl.lisp
Normal file
File diff suppressed because it is too large
Load diff
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
73
contrib/sb-simple-streams/null.lisp
Normal file
73
contrib/sb-simple-streams/null.lisp
Normal file
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
94
contrib/sb-simple-streams/socket.lisp
Normal file
94
contrib/sb-simple-streams/socket.lisp
Normal file
|
|
@ -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))
|
||||
|
||||
File diff suppressed because it is too large
Load diff
118
contrib/sb-simple-streams/string.lisp
Normal file
118
contrib/sb-simple-streams/string.lisp
Normal file
|
|
@ -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)
|
||||
61
contrib/sb-simple-streams/terminal.lisp
Normal file
61
contrib/sb-simple-streams/terminal.lisp
Normal file
|
|
@ -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)))))
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue