common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.8alpha.0.27:

Browse source 
Add skeletal simple-streams contrib from Rudi Schlatte, based on Paul
	Foley's implementation for CMUCL.
This commit is contained in:
Christophe Rhodes 2003-05-13 12:21:15 +00:00
parent 541c9393cf
commit ac85367426
16 changed files with 3394 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
NEWS
View file

@ -1711,6 +1711,9 @@ changes in sbcl-0.8alpha.0 relative to sbcl-0.7.14
changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
* SBCL now builds using CLISP (version of late April 2003 from CVS)
as cross-compilation host.
* a contributed module containing a partial implementation of the
simple-streams interface has been included. (thanks to Rudi
Schlatte)
* minor incompatible change: the :NEGATIVE-ZERO-IS-NOT-ZERO feature
no longer has any effect, as the code controlled by this feature
has been deleted. (As far as we know, no-one has ever built using

2
contrib/sb-simple-streams/Makefile Normal file
View file

@ -0,0 +1,2 @@
SYSTEM=sb-simple-streams
include ../asdf-module.mk

57
contrib/sb-simple-streams/README Normal file
View file

@ -0,0 +1,57 @@
-*- text -*-
An implementation of simple streams for sbcl.
Simple streams are an extensible streams protocol, with similar goals
but different architecture than Gray streams. Documentation about
simple streams is available at
http://www.franz.com/support/documentation/6.2/doc/streams.htm
This code was originally written by Paul Foley for cmucl; Paul's
version resides (as of 2003-05-12) at
http://users.actrix.co.nz/mycroft/cl.html
The port to sbcl was done by Rudi Schlatte (rudi@constantly.at). Bug
reports welcome.
==================================================
Some sketchy notes about the simple-streams architecture, at least
partly for my own benefit
(For all the details, please see Franz' documentation)
Motivation:
If you want to extend a given Gray stream, is it enough to supply a
method for stream-write-byte, or do you have to overwrite
stream-write-sequence as well? How do you extend your Gray socket
stream to support chunked stream encoding for HTTP/1.1? Chances are
that for any seriously interesting stream customization, you will
implement some kind of buffer, collect data in it and
Simple streams is a layered architecture. The device layer at the
bottom deals with transferring chunks of bytes between a buffer and a
device (socket, file, printer, what-have-you). The top layer is the
familiar CL API (read-line, write-sequence, open, etc). The strategy
layer in the middle translates between the buffer-of-bytes and CL
stream world-view, dealing with byte<->character conversion,
line-ending and stream-external-format conventions, etc.
Implementing a new type of stream is a matter of extending the right
stream class and implementing device-read, device-write, device-extend
& friends. single-channel-simple-stream is a class where there is one
buffer for both input and output (this is appropriate e.g. for a file). The
dual-channel-simple-stream class deals with devices that require
separate buffers for input and output (e.g. sockets).
Other character representations (Unicode, other multi-byte encodings)
are implemented at the strategy level. The Franz documentation is
unclear about this, but it seems that encodings take an active part
("the encoding reads as many bytes as are necessary to compose a
character", or words to that effect). This is not implemented in the
present code (neither is it in Paul Foley's implementation), and will
not be until sbcl gains Unicode abilities, but it would be nice to
have it at least stubbed out in the implementation.

1039
contrib/sb-simple-streams/cl.lisp Normal file
View file

File diff suppressed because it is too large Load diff

347
contrib/sb-simple-streams/classes.lisp Normal file
View file

@ -0,0 +1,347 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
;;; BANNER ADS!!
;;;
(pushnew :sb-simple-stream *features*)
(eval-when (:compile-toplevel :load-toplevel :execute)
#+(or X86) (pushnew :little-endian *features*))
(eval-when (:compile-toplevel :load-toplevel :execute)
#-little-endian (pushnew :big-endian *features*))
(eval-when (:compile-toplevel :load-toplevel :execute)
#-(or big-endian little-endian) (error "Unsupported architecture"))
;;;
;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
;;;
;;; See chapter
;;; 12.2 Strategy descriptions necessary for encapsulation
;;; in the Franz documentation for a description of the j-xxx-fn slots.
(deftype simple-stream-buffer ()
'(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
(deftype blocking ()
`(member t nil :bnb))
(deftype j-listen-fn ()
'(function (simple-stream) boolean))
(deftype j-read-char-fn ()
'(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
(deftype j-read-chars-fn ()
'(function (simple-stream string (or character null) fixnum fixnum blocking)
(values fixnum &optional (member nil t :eof))))
(deftype j-write-char-fn ()
'(function (character simple-stream) character))
(deftype j-write-chars-fn ()
'(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
(deftype j-unread-char-fn ()
'(function (simple-stream t) t)) ;; "relaxed" arg is boolean? what return?
;;;
;;; STREAM CLASSES
;;;
;;; KLUDGE (sat 2003-01-15): def-stream-class and the
;;; with-stream-class / sm accessors implement a form of "sealing" of
;;; classes -- i.e., implementing very fast slot access at the price
;;; of not being able to change the class definition at runtime.
;;; Instead of a method call, a slot access for a simple-stream
;;; subclass is a funcall or (when the def-stream-class form has a
;;; location argument for the slot) a sb-pcl::clos-slots-ref. Given a
;;; sufficiently advanced PCL with (non-standard) sealing
;;; declarations, this machinery would be superfluous. For the time
;;; being, replacing 4 method calls with vector accesses for the fast
;;; path of read-char seems worthwhile to me. Besides, it's the
;;; documented interface to simple-stream internals, and so it's worth
;;; keeping.
(eval-when (:compile-toplevel :load-toplevel :execute)
(declaim (type hash-table *slot-access-functions*))
(defvar *slot-access-functions* (make-hash-table))
(defvar *automagic-accessors* nil))
(defmacro def-stream-class (name superclasses slots &rest options)
(let ((accessors ())
(real-slots ()))
(dolist (slot slots)
;; Frob the slot arguments, memorizing either the location (an
;; integer) or the accessor of the slot. Optionally construct
;; an accessor if none is given.
(cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
;; We have got a location specifier. Memorize it and
;; extract it until pcl itself can work with these.
(push (cons (first slot)
(cons (getf (rest slot) :type t)
(getf (rest slot) 'sb-pcl::location)))
accessors)
(let ((slot (copy-list slot)))
(remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
(push slot real-slots)))
((or (not (consp slot)) (not (getf (rest slot) :accessor)))
(if *automagic-accessors*
;; Add an :accessor argument, and memorize it. FIXME:
;; will this work with sbcl? reader/writers are
;; named differently there (see
;; src/pcl/slot-name.lisp)
(let* ((slot (if (consp slot) slot (list slot)))
(accessor (or (cdr (gethash (first slot)
*slot-access-functions*))
(intern (format nil "~A ~A slot ACCESSOR"
name (first slot))
"SB-SLOT-ACCESSOR-NAME"))))
(push (cons (first slot)
(cons (getf (rest slot) :type t) accessor))
accessors)
(push (append slot `(:accessor ,accessor)) real-slots))
(push slot real-slots)))
(t
;; No location given, but we have an accessor. Memorize it.
(push (cons (first slot)
(cons (getf (rest slot) :type t)
(getf (rest slot) :accessor)))
accessors)
(push slot real-slots))))
`(prog1
(defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
(eval-when (:compile-toplevel :load-toplevel :execute)
,@(loop for accessor in accessors
do (let ((exists (gethash (car accessor)
*slot-access-functions*)))
(when (and exists
(integerp (cdr exists))
(integerp (cddr accessor))
(/= (cdr exists) (cddr accessor)))
(warn "~S slot ~S has moved! ~
I hope you know what you're doing!"
name (car accessor))))
collect `(setf (gethash ',(car accessor) *slot-access-functions*)
',(cdr accessor)))))))
(def-stream-class simple-stream (standard-object stream)
((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
;; Strategy slots. See section 12.2 of streams.htm for function
;; signatures and possible side-effects.
;; A function that determines if one character can be successfully
;; read from stream.
(j-listen :type j-listen-fn sb-pcl::location 18)
;; A function that reads one character.
(j-read-char :type j-read-char-fn sb-pcl::location 17)
;; A function that reads characters into a string.
(j-read-chars :type j-read-chars-fn sb-pcl::location 16)
;; A function that writes one character.
(j-write-char :type j-write-char-fn sb-pcl::location 15)
;; A function that writes characters from a string into the stream.
(j-write-chars :type j-write-chars-fn sb-pcl::location 14)
;; A function that unreads the last character read.
(j-unread-char :type j-unread-char-fn sb-pcl::location 13)
;; Other slots
;; Always a stream, allowing for composing external formats (see
;; streams.htm, section 12.5) TODO: document this better
(melded-stream sb-pcl::location 12)
;; Always a stream, allowing for composing external formats (see
;; streams.htm, section 12.5) TODO: document this better
(melding-base sb-pcl::location 11)
;; Number of octets the last read-char operation consumed TODO:
;; document this better; what is the difference to
;; last-char-read-size ?
(encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
(mode :initform 0 :type fixnum sb-pcl::location 9)
(control-in :initform nil :type (or null simple-vector)
sb-pcl::location 8)
(control-out :initform nil :type (or null simple-vector)
sb-pcl::location 7)
;; A fixnum (denoting a valid file descriptor), a stream, or nil if
;; the stream is not open for input.
(input-handle :initform nil :initarg :input-handle sb-pcl::location 6
:type (or null fixnum stream)
:accessor stream-input-handle)
;; A fixnum (denoting a valid file descriptor), a stream, or nil if
;; the stream is not open for output.
(output-handle :initform nil :initarg :output-handle sb-pcl::location 5
:type (or null fixnum stream)
:accessor stream-output-handle)
(external-format :initform :default sb-pcl::location 4)
(record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
;; The character position of the stream.
(charpos :initform 0 :type (or null integer) sb-pcl::location 2)
;; Number of octets the last read-char operation consumed
(last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
;; instance flags (not a normal slot in Allegro CL)
(%flags :initform 0 :type fixnum sb-pcl::location 0)))
(def-stream-class probe-simple-stream (simple-stream)
())
;;; A stream with a single buffer, for example a file stream.
(def-stream-class single-channel-simple-stream (simple-stream)
;; Input/output buffer.
((buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 23)
;; Current position in buffer.
(buffpos :initform 0 :type fixnum sb-pcl::location 22)
;; Maximum valid position in buffer, or -1 on eof.
(buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
(buf-len :initform 0 :type fixnum sb-pcl::location 20)))
(def-stream-class direct-simple-stream (single-channel-simple-stream)
())
(def-stream-class buffer-input-simple-stream (direct-simple-stream)
())
(def-stream-class buffer-output-simple-stream (direct-simple-stream)
((out-buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 26)
;; Current position in output buffer.
(outpos :initform 0 :type fixnum sb-pcl::location 25)
;; Buffer length (one greater than maximum output buffer index)
(max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
(def-stream-class null-simple-stream (single-channel-simple-stream)
())
(def-stream-class file-simple-stream (single-channel-simple-stream)
((pathname :initform nil :initarg :pathname)
(filename :initform nil :initarg :filename)
(original :initform nil :initarg :original)
(delete-original :initform nil :initarg :delete-original)
))
(def-stream-class mapped-file-simple-stream (file-simple-stream
direct-simple-stream)
())
;;; A stream with two octet buffers, for example a socket or terminal
;;; stream.
(def-stream-class dual-channel-simple-stream (simple-stream)
;; Output buffer.
((out-buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 26)
;; Current position in output buffer.
(outpos :initform 0 :type fixnum sb-pcl::location 25)
;; Buffer length (one greater than maximum output buffer index)
(max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
;; Input buffer (in this case; the 'buffer' slot serves as
;; bidirectional buffer for single-channel-simple-streams).
(buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 23)
;; Current position in buffer.
(buffpos :initform 0 :type fixnum sb-pcl::location 22)
;; Maximum valid position in buffer, or -1 on eof.
(buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
(buf-len :initform 0 :type fixnum sb-pcl::location 20)))
(def-stream-class terminal-simple-stream (dual-channel-simple-stream)
())
(def-stream-class socket-simple-stream (dual-channel-simple-stream)
())
(def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
())
(def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
())
;;; A stream with a string as buffer.
(def-stream-class string-simple-stream (simple-stream)
;; The input/output buffer.
((buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 23)
;; Current position in buffer.
(buffpos :initform 0 :type fixnum sb-pcl::location 22)
;; Maximum valid position in buffer, or -1 on eof.
(buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
(buf-len :initform 0 :type fixnum sb-pcl::location 20)))
(def-stream-class composing-stream (string-simple-stream)
())
(def-stream-class string-input-simple-stream (string-simple-stream)
())
(def-stream-class string-output-simple-stream (string-simple-stream)
;; The output buffer (slot added so that a class can inherit from
;; both string-input-simple-stream and string-output-simple-stream
;; without the strategies clashing)
((out-buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 26)
;; Current position in output buffer.
(outpos :initform 0 :type fixnum sb-pcl::location 25)
;; Buffer length (one greater than maximum output buffer index)
(max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
(def-stream-class fill-pointer-output-simple-stream
(string-output-simple-stream)
())
(def-stream-class limited-string-output-simple-stream
(string-output-simple-stream)
())
(def-stream-class xp-simple-stream (string-output-simple-stream)
())
(def-stream-class annotation-output-simple-stream (string-output-simple-stream)
())
(defclass default-latin1-base-ef () ())
(defclass stream-recording-mixin () ())
(defclass stream-recording-repaint-mixin () ())
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *automagic-accessors* nil))
;;;
;;; DEVICE-LEVEL FUNCTIONS
;;;
(defgeneric device-open (stream options))
(defgeneric device-close (stream abort))
(defgeneric device-buffer-length (stream))
(defgeneric device-file-position (stream))
(defgeneric (setf device-file-position) (value stream))
(defgeneric device-file-length (stream))
(defgeneric device-read (stream buffer start end blocking))
(defgeneric device-clear-input (stream buffer-only))
(defgeneric device-write (stream buffer start end blocking))
(defgeneric device-clear-output (stream))
(defgeneric device-extend (stream need action))
(defgeneric device-finish-record (stream blocking action))

27
contrib/sb-simple-streams/constants.lisp Normal file
View file

@ -0,0 +1,27 @@
;;; -*- Lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
;;; Some constants that are not (yet?) in sbcl itself. Basically,
;;; constants needed for calling mmap from sbcl.
;;; TODO (Rudi 2003-05-12): The contents of this file, along with
;;; unix.lisp, should presumably end up somewhere else, either in sbcl
;;; itself or in sb-posix.
("stdio.h" "sys/types.h" "sys/stat.h" "fcntl.h" "asm/errno.h" "sys/mman.h")
((:integer eacces "EACCES" "Error code for access error")
(:integer prot-none "PROT_NONE" "mmap: no protection")
(:integer prot-read "PROT_READ" "mmap: read protection")
(:integer prot-write "PROT_WRITE" "mmap: write protection")
(:integer prot-exec "PROT_EXEC" "mmap: execute protection")
(:integer map-shared "MAP_SHARED" "mmap: shared memory")
(:integer map-private "MAP_PRIVATE" "mmap: private mapping")
(:integer map-fixed "MAP_FIXED" "mmap: map at given location"))

63
contrib/sb-simple-streams/fndb.lisp Normal file
View file

@ -0,0 +1,63 @@
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: COMMON-LISP -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(in-package "COMMON-LISP")
;; .../compiler/knownfun.lisp
;; TODO: I suppose sbcl internals have sufficiently diverged from
;; cmucl that this does not work after my primitive translation
;; attempt. This is used in the cmucl version to compute (via
;; :derive-type arg to defknown) the return type of open. For the
;; time being, the new defknown form for open does not specify its
;; return type.
#+nil
(defun result-type-open-class (call)
(declare (type sb-c::combination call))
(do ((args (sb-c::combination-args call) (cdr args)))
((null args))
(let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args)))))
(when (and (typep leaf 'sb-kernel:constant)
(eq (sb-c::constant-value leaf) :class)
(cdr args))
(let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args)))))
(return (if (typep leaf 'sb-kernel:constant)
(find-class (sb-c::constant-value leaf) nil)
nil)))))))
(handler-bind ((error #'(lambda (condition) (declare (ignore condition))
(continue))))
(sb-c:defknown open (t &rest t
&key (:direction (member :input :output :io :probe))
(:element-type sb-kernel:type-specifier)
(:if-exists (member :error :new-version :rename
:rename-and-delete :overwrite
:append :supersede nil))
(:if-does-not-exist (member :error :create nil))
(:external-format (member :default))
(:class (or symbol class))
(:mapped (member t nil))
(:input-handle (or null fixnum stream))
(:output-handle (or null fixnum stream))
&allow-other-keys)
(or stream null)
()
;; :derive-type #'result-type-open-class
)
(sb-c:defknown listen (&optional sb-kernel:streamlike
(or null (integer 1 10) (member 'character)))
boolean (sb-c::unsafely-flushable sb-c::explicit-check))
(sb-c:defknown read-sequence (sequence stream &key (:start sb-int:index)
(:end sb-kernel:sequence-end)
(:partial-fill boolean))
(sb-int:index) ())
(sb-c:defknown clear-input (&optional stream boolean) null
(sb-c::explicit-check)))

425
contrib/sb-simple-streams/internal.lisp Normal file
View file

@ -0,0 +1,425 @@
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
;;; HELPER FUNCTIONS
;;;
;; All known stream flags. Note that the position in the constant
;; list is significant (cf. %flags below).
(sb-int:defconstant-eqx +flag-bits+
'(:simple ; instance is valid
:input :output ; direction
:dual :string ; type of stream
:eof ; latched EOF
:dirty ; output buffer needs write
:interactive) ; interactive stream
#'equal)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %flags (flags)
(loop for flag in flags
as pos = (position flag +flag-bits+)
when (eq flag :gray) do
(error "Gray streams not supported.")
if pos
sum (ash 1 pos) into bits
else
collect flag into unused
finally (when unused
(warn "Invalid stream instance flag~P: ~{~S~^, ~}"
(length unused) unused))
(return bits))))
;;; Setup an environment where sm, funcall-stm-handler and
;;; funcall-stm-handler-2 are valid and efficient for a stream of type
;;; class-name or for the stream argument (in which case the
;;; class-name argument is ignored). In nested with-stream-class
;;; forms, the inner with-stream-class form must specify a stream
;;; argument if the outer one specifies one, or the wrong object will
;;; be accessed.
(defmacro with-stream-class ((class-name &optional stream) &body body)
(if stream
(let ((stm (gensym "STREAM"))
(slt (gensym)))
`(let* ((,stm ,stream)
(,slt (sb-pcl::std-instance-slots ,stm)))
(declare (type ,class-name ,stm) (ignorable ,slt))
(macrolet ((sm (slot-name stream)
(declare (ignore stream))
(let ((slot-access (gethash slot-name
*slot-access-functions*)))
(cond ((sb-int:fixnump (cdr slot-access))
;; Get value in nth slot
`(the ,(car slot-access)
(sb-pcl::clos-slots-ref ,',slt
,(cdr slot-access))))
(slot-access
;; Call memorized function
`(the ,(car slot-access) (,(cdr slot-access)
,',stm)))
(t
;; Use slot-value
`(slot-value ,',stm ',slot-name)))))
(add-stream-instance-flags (stream &rest flags)
(declare (ignore stream))
`(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
,(%flags flags))))
(remove-stream-instance-flags (stream &rest flags)
(declare (ignore stream))
`(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
,(%flags flags))))
(any-stream-instance-flags (stream &rest flags)
(declare (ignore stream))
`(not (zerop (logand (sm %flags ,',stm)
,(%flags flags))))))
,@body)))
`(macrolet ((sm (slot-name stream)
(let ((slot-access (gethash slot-name
*slot-access-functions*)))
(cond ((sb-int:fixnump (cdr slot-access))
`(the ,(car slot-access)
(sb-pcl::clos-slots-ref
(sb-pcl::std-instance-slots ,stream)
,(cdr slot-access))))
(slot-access
`(the ,(car slot-access) (,(cdr slot-access)
,stream)))
(t `(slot-value ,stream ',slot-name))))))
,@body)))
(defmacro sm (slot-name stream)
(let ((slot-access (gethash slot-name *slot-access-functions*)))
(warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
(cond ((sb-int:fixnump (cdr slot-access))
`(the ,(car slot-access) (sb-pcl::clos-slots-ref
(sb-pcl::std-instance-slots ,stream)
,(cdr slot-access))))
(slot-access
`(the ,(car slot-access) (,(cdr slot-access) ,stream)))
(t `(slot-value ,stream ',slot-name)))))
(defmacro funcall-stm-handler (slot-name stream &rest args)
(let ((s (gensym)))
`(let ((,s ,stream))
(funcall (sm ,slot-name ,s) ,s ,@args))))
(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
(let ((s (gensym)))
`(let ((,s ,stream))
(funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
(defmacro add-stream-instance-flags (stream &rest flags)
"Set the given flag bits in STREAM."
(let ((s (gensym "STREAM")))
`(let ((,s ,stream))
(with-stream-class (simple-stream ,s)
(setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
(defmacro remove-stream-instance-flags (stream &rest flags)
"Clear the given flag bits in STREAM."
(let ((s (gensym "STREAM")))
`(let ((,s ,stream))
(with-stream-class (simple-stream ,s)
(setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
(defmacro any-stream-instance-flags (stream &rest flags)
"Determine whether any one of the FLAGS is set in STREAM."
(let ((s (gensym "STREAM")))
`(let ((,s ,stream))
(with-stream-class (simple-stream ,s)
(not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
(declaim (inline buffer-sap bref (setf bref) buffer-copy))
(defun buffer-sap (thing &optional offset)
(declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
(optimize (speed 3) (space 2) (debug 0) (safety 0)
;; Suppress the note about having to box up the return:
(sb-ext:inhibit-warnings 3)))
(let ((sap (if (vectorp thing) (sb-sys:vector-sap thing) thing)))
(if offset (sb-sys:sap+ sap offset) sap)))
(defun bref (buffer index)
(declare (type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(sb-sys:sap-ref-8 (buffer-sap buffer) index))
(defun (setf bref) (octet buffer index)
(declare (type (unsigned-byte 8) octet)
(type simple-stream-buffer buffer)
(type (integer 0 #.most-positive-fixnum) index))
(setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
(defun buffer-copy (src soff dst doff length)
(declare (type simple-stream-buffer src dst)
(type fixnum soff doff length))
(sb-sys:without-gcing ;; is this necessary??
(sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
(buffer-sap dst) (* doff 8)
(* length 8))))
(defun allocate-buffer (size)
(if (= size sb-impl::bytes-per-buffer)
(sb-impl::next-available-buffer)
(make-array size :element-type '(unsigned-byte 8))))
(defun free-buffer (buffer)
(when (not (vectorp buffer))
(push buffer sb-impl::*available-buffers*))
t)
(defun %fd-open (pathname direction if-exists if-exists-given
if-does-not-exist if-does-not-exist-given)
(declare (type pathname pathname)
(type (member :input :output :io :probe) direction)
(type (member :error :new-version :rename :rename-and-delete
:overwrite :append :supersede nil) if-exists)
(type (member :error :create nil) if-does-not-exist))
(multiple-value-bind (input output mask)
(ecase direction
(:input (values t nil sb-unix:o_rdonly))
(:output (values nil t sb-unix:o_wronly))
(:io (values t t sb-unix:o_rdwr))
(:probe (values t nil sb-unix:o_rdonly)))
(declare (type sb-int:index mask))
(let ((name (cond ((sb-int:unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
(sb-int:unix-namestring pathname nil)))))
;; Process if-exists argument if we are doing any output.
(cond (output
(unless if-exists-given
(setf if-exists
(if (eq (pathname-version pathname) :newest)
:new-version
:error)))
(case if-exists
((:error nil)
(setf mask (logior mask sb-unix:o_excl)))
((:rename :rename-and-delete)
(setf mask (logior mask sb-unix:o_creat)))
((:new-version :supersede)
(setf mask (logior mask sb-unix:o_trunc)))
(:append
(setf mask (logior mask sb-unix:o_append)))))
(t
(setf if-exists nil))) ; :ignore-this-arg
(unless if-does-not-exist-given
(setf if-does-not-exist
(cond ((eq direction :input) :error)
((and output
(member if-exists '(:overwrite :append)))
:error)
((eq direction :probe)
nil)
(t
:create))))
(if (eq if-does-not-exist :create)
(setf mask (logior mask sb-unix:o_creat)))
(let ((original (if (member if-exists
'(:rename :rename-and-delete))
(sb-impl::pick-backup-name name)
nil))
(delete-original (eq if-exists :rename-and-delete))
(mode #o666))
(when original
;; We are doing a :rename or :rename-and-delete.
;; Determine if the file already exists, make sure the original
;; file is not a directory and keep the mode
(let ((exists
(and name
(multiple-value-bind
(okay err/dev inode orig-mode)
(sb-unix:unix-stat name)
(declare (ignore inode)
(type (or sb-int:index null) orig-mode))
(cond
(okay
(when (and output (= (logand orig-mode #o170000)
#o40000))
(error 'sb-int:simple-file-error
:pathname pathname
:format-control
"Cannot open ~S for output: Is a directory."
:format-arguments (list name)))
(setf mode (logand orig-mode #o777))
t)
((eql err/dev sb-unix:enoent)
nil)
(t
(error 'sb-int:simple-file-error
:pathname pathname
:format-control "Cannot find ~S: ~A"
:format-arguments
(list name
(sb-int:strerror err/dev)))))))))
(unless (and exists
(rename-file name original))
(setf original nil)
(setf delete-original nil)
;; In order to use SUPERSEDE instead, we have
;; to make sure unix:o_creat corresponds to
;; if-does-not-exist. unix:o_creat was set
;; before because of if-exists being :rename.
(unless (eq if-does-not-exist :create)
(setf mask (logior (logandc2 mask sb-unix:o_creat)
sb-unix:o_trunc)))
(setf if-exists :supersede))))
;; Okay, now we can try the actual open.
(loop
(multiple-value-bind (fd errno)
(if name
(sb-unix:unix-open name mask mode)
(values nil sb-unix:enoent))
(cond ((sb-int:fixnump fd)
(return (values fd name original delete-original)))
((eql errno sb-unix:enoent)
(case if-does-not-exist
(:error
(cerror "Return NIL."
'sb-int:simple-file-error
:pathname pathname
:format-control "Error opening ~S, ~A."
:format-arguments
(list pathname
(sb-int:strerror errno))))
(:create
(cerror "Return NIL."
'sb-int:simple-file-error
:pathname pathname
:format-control
"Error creating ~S, path does not exist."
:format-arguments (list pathname))))
(return nil))
((eql errno sb-unix:eexist)
(unless (eq nil if-exists)
(cerror "Return NIL."
'sb-int:simple-file-error
:pathname pathname
:format-control "Error opening ~S, ~A."
:format-arguments
(list pathname
(sb-int:strerror errno))))
(return nil))
#+nil ; FIXME: reinstate this; error reporting is nice.
((eql errno sb-unix:eacces)
(cerror "Try again."
'sb-int:simple-file-error
:pathname pathname
:format-control "Error opening ~S, ~A."
:format-arguments
(list pathname
(sb-int:strerror errno))))
(t
(cerror "Return NIL."
'sb-int:simple-file-error
:pathname pathname
:format-control "Error opening ~S, ~A."
:format-arguments
(list pathname
(sb-int:strerror errno)))
(return nil)))))))))
(defun open-fd-stream (pathname &key (direction :input)
(element-type 'base-char)
(if-exists nil if-exists-given)
(if-does-not-exist nil if-does-not-exist-given)
(external-format :default))
(declare (type (or pathname string stream) pathname)
(type (member :input :output :io :probe) direction)
(type (member :error :new-version :rename :rename-and-delete
:overwrite :append :supersede nil) if-exists)
(type (member :error :create nil) if-does-not-exist)
(ignore external-format))
(setq pathname (pathname pathname))
(multiple-value-bind (fd namestring original delete-original)
(%fd-open pathname direction if-exists if-exists-given
if-does-not-exist if-does-not-exist-given)
(when fd
(case direction
((:input :output :io)
(sb-sys:make-fd-stream fd
:input (member direction '(:input :io))
:output (member direction '(:output :io))
:element-type element-type
:file namestring
:original original
:delete-original delete-original
:pathname pathname
:input-buffer-p t
:auto-close t))
(:probe
(let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
:pathname pathname
:element-type element-type)))
(close stream)
stream))))))
;; Make PATHNAME and NAMESTRING work
(defun cl::file-name (stream &optional new-name)
(typecase stream
(file-simple-stream
(with-stream-class (file-simple-stream stream)
(cond (new-name
(setf (sm pathname stream) new-name)
(setf (sm filename stream) (sb-int:unix-namestring new-name nil))
t)
(t
(sm pathname stream)))))
(sb-sys::file-stream
(cond (new-name
(setf (sb-impl::fd-stream-pathname stream) new-name)
(setf (sb-impl::fd-stream-file stream)
(sb-int:unix-namestring new-name nil))
t)
(t
(sb-impl::fd-stream-pathname stream))))))
;; Experimental "filespec" stuff
;; sat: Hooks to parse URIs etc apparently go here
(defstruct (filespec-parser
(:constructor make-filespec-parser (name priority function)))
name
priority
function)
(defvar *filespec-parsers* ())
(defun add-filespec (name priority function)
(let ((filespec (make-filespec-parser name priority function)))
(setf *filespec-parsers*
(stable-sort (cons filespec (delete name *filespec-parsers*
:key #'filespec-parser-name))
#'>
:key #'filespec-parser-priority)))
t)
(defmacro define-filespec (name lambda-list &body body)
(let ((truename (if (consp name) (first name) name))
(priority (if (consp name) (second name) 0)))
`(add-filespec ',truename ,priority (lambda ,lambda-list
(block ,truename
,@body)))))
(defun parse-filespec (string &optional (errorp t))
(dolist (i *filespec-parsers* (when errorp
(error "~S not recognised." string)))
(let ((result (ignore-errors
(funcall (filespec-parser-function i) string))))
(when result (return result)))))
(define-filespec pathname (string)
(pathname string))

22
contrib/sb-simple-streams/iodefs.lisp Normal file
View file

@ -0,0 +1,22 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
;;; This is just for compatibility with Franz demo code
(defpackage "EXCL"
(:use "SB-SIMPLE-STREAM")
(:import-from "SB-SIMPLE-STREAM"
"BUFFER" "BUFFPOS" "BUFFER-PTR"
"OUT-BUFFER" "MAX-OUT-POS"
"INPUT-HANDLE" "OUTPUT-HANDLE"
"MELDED-STREAM"
"J-READ-CHARS"))
(use-package "SB-SIMPLE-STREAMS")
(provide :iodefs)

75
contrib/sb-simple-streams/package.lisp Normal file
View file

@ -0,0 +1,75 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(defpackage sb-simple-streams
(:use #:common-lisp)
(:import-from #:sb-kernel #:ansi-stream)
(:import-from #:sb-gray #:fundamental-stream)
(:export ;; Stream classes
#:STREAM
#:SIMPLE-STREAM
#:PROBE-SIMPLE-STREAM
#:SINGLE-CHANNEL-SIMPLE-STREAM
#:DIRECT-SIMPLE-STREAM
#:BUFFER-INPUT-SIMPLE-STREAM
#:BUFFER-OUTPUT-SIMPLE-STREAM
#:NULL-SIMPLE-STREAM
#:FILE-SIMPLE-STREAM
#:MAPPED-FILE-SIMPLE-STREAM
#:DUAL-CHANNEL-SIMPLE-STREAM
#:TERMINAL-SIMPLE-STREAM
#:SOCKET-SIMPLE-STREAM
#:SOCKET-BASE-SIMPLE-STREAM
#:HIPER-SOCKET-SIMPLE-STREAM
#:STRING-SIMPLE-STREAM
#:COMPOSING-STREAM
#:STRING-INPUT-SIMPLE-STREAM
#:STRING-OUTPUT-SIMPLE-STREAM
#:FILL-POINTER-OUTPUT-SIMPLE-STREAM
#:LIMITED-STRING-OUTPUT-SIMPLE-STREAM
#:XP-SIMPLE-STREAM
#:ANNOTATION-OUTPUT-SIMPLE-STREAM
;; Streams
#:*STANDARD-INPUT* #:*STANDARD-OUTPUT* #:*ERROR-OUTPUT*
#:*QUERY-IO* #:*DEBUG-IO* #:*TRACE-OUTPUT* #:*TERMINAL-IO*
;; Slot accessors
#:STREAM-INPUT-HANDLE #:STREAM-OUTPUT-HANDLE
#:STREAM-PLIST
;; Device-level functions
#:DEVICE-OPEN #:DEVICE-CLOSE #:DEVICE-BUFFER-LENGTH
#:DEVICE-FILE-POSITION #:DEVICE-FILE-LENGTH #:DEVICE-READ
#:DEVICE-CLEAR-INPUT #:DEVICE-WRITE #:DEVICE-CLEAR-OUTPUT
#:DEVICE-EXTEND #:DEVICE-FINISH-RECORD
;; Implementation functions/macros
#:WITH-STREAM-CLASS #:SM #:FUNCALL-STM-HANDLER
#:FUNCALL-STM-HANDLER-2 #:ADD-STREAM-INSTANCE-FLAGS
#:REMOVE-STREAM-INSTANCE-FLAGS
;; User-level functions (mostly reexported from COMMON-LISP)
#:PARSE-FILESPEC #:DEFINE-FILESPEC #:DEFAULT-OPEN-CLASS #:OPEN
#:CLOSE #:READ-BYTE #:READ-CHAR #:READ-CHAR-NO-HANG #:UNREAD-CHAR
#:PEEK-CHAR #:LISTEN #:READ-LINE #:READ-SEQUENCE #:CLEAR-INPUT
#:WRITE-BYTE #:WRITE-CHAR #:WRITE-STRING #:WRITE-SEQUENCE #:TERPRI
#:FRESH-LINE #:FINISH-OUTPUT #:FORCE-OUTPUT #:CLEAR-OUTPUT
#:FILE-POSITION #:FILE-LENGTH #:LINE-LENGTH #:CHARPOS
#:STREAM-ELEMENT-TYPE #:STREAM-EXTERNAL-FORMAT #:STREAMP
#:OPEN-STREAM-P #:INPUT-STREAM-P #:OUTPUT-STREAM-P
#:INTERACTIVE-STREAM-P #:READ-VECTOR #:WRITE-VECTOR #:READ-OCTETS
#:WRITE-OCTETS #:DEF-STREAM-CLASS #:WAIT-FOR-INPUT-AVAILABLE
;; higher level things (reexported from COMMON-LISP)
#:WITH-OPEN-FILE #:WITH-OPEN-STREAM #:FORMAT #:PPRINT #:PRIN1
#:PRIN1-TO-STRING #:PRINC #:PRINC-TO-STRING #:PRINT #:READ
#:READ-DELIMITED-LIST #:READ-FROM-STRING #:WRITE #:WRITE-LINE
#:WRITE-TO-STRING #:READ-PRESERVING-WHITESPACE))
#||
(in-package "SB-EXT")
(defgeneric stream-file-position (stream &optional position))
(defgeneric stream-file-length (stream))
(export '(stream-file-position stream-file-length))
||#

35
contrib/sb-simple-streams/sb-simple-streams.asd Normal file
View file

@ -0,0 +1,35 @@
;;; -*- lisp -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :sb-grovel))
(defpackage #:sb-simple-stream-system (:use #:asdf #:cl #:sb-grovel))
(in-package #:sb-simple-stream-system)
(defsystem sb-simple-streams
:depends-on (sb-rt sb-grovel)
:components ((:file "package")
(:file "fndb")
(grovel-constants-file "constants"
:package :sb-simple-streams
:pathname "constants.lisp"
:depends-on ("package"))
;; (:file "stuff_grovelled_from_headers")
(:file "unix" :depends-on ("constants"))
;;(:file "pcl")
;;(:file "ext-format" :depends-on ("package"))
(:file "classes" :depends-on ("package"))
(:file "internal" :depends-on ("classes"))
(:file "strategy" :depends-on ("internal"))
(:file "cl" :depends-on ("internal" "fndb"))
(:file "simple-streams" :depends-on ("cl" "strategy" "unix"))
;;(:file "gray-compat" :depends-on ("package"))
;;(:file "iodefs" :depends-on ("package"))
(:file "simple-stream-tests" :depends-on ("simple-streams"))
))
(defmethod perform ((o test-op) (c (eql (find-system :sb-simple-streams))))
(or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
(error "test-op failed")))

75
contrib/sb-simple-streams/simple-stream-tests.lisp Normal file
View file

@ -0,0 +1,75 @@
;;;; -*- lisp -*-
(defpackage sb-simple-streams-test
(:use #:common-lisp #:sb-simple-streams #:sb-rt))
(in-package #:sb-simple-streams-test)
(defparameter *dumb-string* "This file created by simple-stream-tests.lisp. Nothing to see here, move along.")
(defparameter *test-path* (merge-pathnames
(make-pathname :name nil :type nil :version nil)
*load-truename*))
(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
(deftest create-file-1
(let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
(stream-object (make-instance 'file-simple-stream
:filename file
:direction :output
:if-exists :overwrite)))
(prog1
(with-open-stream (s stream-object)
(string= (write-string *dumb-string* s) *dumb-string*))
(delete-file file)))
t)
(deftest create-file-2
(let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
(prog1
(with-open-file (s file
:class 'file-simple-stream
:direction :output :if-exists :overwrite)
(string= (write-string *dumb-string* s) *dumb-string*))
(delete-file file)))
t)
(deftest create-read-file-1
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
(let ((stream-object (make-instance 'file-simple-stream
:filename file
:direction :output
:if-exists :overwrite)))
(with-open-stream (s stream-object)
(setf result (and result (string= (write-string *dumb-string* s)
*dumb-string*)))
(terpri s)))
(let ((stream-object (make-instance 'file-simple-stream
:filename file
:direction :input)))
(with-open-stream (s stream-object)
(setf result (and result (string= (read-line s) *dumb-string*)))))
result)
t)
(deftest create-read-mapped-file-1
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
(with-open-file (s file
:class 'file-simple-stream
:direction :output :if-exists :overwrite)
(setf result (and result (string= (write-string *dumb-string* s)
*dumb-string*))))
(with-open-file (s file
:class 'mapped-file-simple-stream
:direction :input)
(setf result (and result (string= (read-line s) *dumb-string*))))
(delete-file file)
result)
t)

624
contrib/sb-simple-streams/simple-streams.lisp Normal file
View file

@ -0,0 +1,624 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(in-package "SB-SIMPLE-STREAMS")
;;;
;;; Stream printing
;;;
(defmethod print-object ((object file-simple-stream) stream)
(print-unreadable-object (object stream :type t :identity t)
(format stream "for ~S" (slot-value object 'filename))))
(defun make-control-table (&rest inits)
(let ((table (make-array 32 :initial-element nil)))
(do* ((char (pop inits) (pop inits))
(func (pop inits) (pop inits)))
((null char))
(when (< (char-code char) 32)
(setf (aref table (char-code char)) func)))
table))
(defun std-newline-out-handler (stream character)
(declare (ignore character))
(with-stream-class (simple-stream stream)
(setf (sm charpos stream) -1)
nil))
(defun std-tab-out-handler (stream character)
(declare (ignore character))
(with-stream-class (simple-stream stream)
(let ((col (sm charpos stream)))
(when col
(setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
nil))
(defun std-dc-newline-in-handler (stream character)
(with-stream-class (dual-channel-simple-stream stream)
(setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
character))
(defvar *std-control-out-table*
(make-control-table #\Newline #'std-newline-out-handler
#\Tab #'std-tab-out-handler))
(defvar *terminal-control-in-table*
(make-control-table #\Newline #'std-dc-newline-in-handler))
;;;
;;; LOW LEVEL STUFF
;;;
(defun vector-elt-width (vector)
;; Return octet-width of vector elements
(etypecase vector
;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
;; [and base-char, which is treated specially]
((simple-array (signed-byte 8) (*)) 1)
((simple-array (unsigned-byte 8) (*)) 1)
((simple-array (signed-byte 16) (*)) 2)
((simple-array (unsigned-byte 16) (*)) 2)
((simple-array (signed-byte 32) (*)) 4)
((simple-array (unsigned-byte 32) (*)) 4)
((simple-array single-float (*)) 4)
((simple-array double-float (*)) 8)
((simple-array (complex single-float) (*)) 8)
((simple-array (complex double-float) (*)) 16)))
(defun endian-swap-value (vector endian-swap)
(case endian-swap
(:network-order (case (vector-elt-width vector)
(1 0)
(2 1)
(4 3)
(8 7)
(16 15)))
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
(:byte-64 7)
(:byte-128 15)
(otherwise endian-swap)))
(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
(declare (type (sb-kernel:simple-unboxed-array (*)) vector)
(type stream stream))
;; START and END are octet offsets, not vector indices! [Except for strings]
;; Return value is index of next octet to be read into (i.e., start+count)
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
(if (stringp vector)
(let* ((start (or start 0))
(end (or end (length vector)))
(char (funcall-stm-handler j-read-char stream nil nil t)))
(when char
(setf (schar vector start) char)
(incf start)
(+ start (funcall-stm-handler j-read-chars stream vector nil
start end nil))))
(do* ((j-read-byte
(cond ((any-stream-instance-flags stream :string)
(error "Can't READ-BYTE on string streams."))
((any-stream-instance-flags stream :dual)
#'dc-read-byte)
(t
#'sc-read-byte)))
(index (or start 0) (1+ index))
(end (or end (* (length vector) (vector-elt-width vector))))
(endian-swap (endian-swap-value vector endian-swap))
(byte (funcall j-read-byte stream nil nil t)
(funcall j-read-byte stream nil nil nil)))
((or (null byte) (>= index end)) index)
(setf (bref vector (logxor index endian-swap)) byte)))))
((or ansi-stream fundamental-stream)
(unless (typep vector '(or string
(simple-array (signed-byte 8) (*))
(simple-array (unsigned-byte 8) (*))))
(error "Wrong vector type for read-vector on stream not of type simple-stream."))
(read-sequence vector stream :start (or start 0) :end end))))
#|(defun write-vector ...)|#
;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun getpagesize ()
(sb-unix::int-syscall ("getpagesize"))))
(defun read-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
(type (or null simple-stream-buffer) buffer)
(type fixnum start)
(type (or null fixnum) end)
(optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (simple-stream stream)
(let ((fd (sm input-handle stream))
(end (or end (sm buf-len stream)))
(buffer (or buffer (sm buffer stream))))
(declare (fixnum end))
(typecase fd
(fixnum
(let ((flag (sb-sys:wait-until-fd-usable fd :input
(if blocking nil 0))))
(cond
((and (not blocking) (= start end)) (if flag -3 0))
((and (not blocking) (not flag)) 0)
(t (block nil
(let ((count 0))
(declare (type fixnum count))
(tagbody
again
;; Avoid CMUCL gengc write barrier
(do ((i start (+ i ;#.(sb-unix:unix-getpagesize)
(the fixnum (getpagesize)))))
((>= i end))
(declare (type fixnum i))
(setf (bref buffer i) 0))
(setf (bref buffer (1- end)) 0)
(multiple-value-bind (bytes errno)
(sb-unix:unix-read fd (buffer-sap buffer start)
(the fixnum (- end start)))
(declare (type (or null fixnum) bytes)
(type (integer 0 100) errno))
(when bytes
(incf count bytes)
(incf start bytes))
(cond ((null bytes)
(format t "~&;; UNIX-READ: errno=~D~%" errno)
(cond ((= errno sb-unix:eintr) (go again))
((and blocking
(or (= errno ;;sb-unix:eagain
;; FIXME: move
;; eagain into
;; sb-unix
11)
(= errno sb-unix:ewouldblock)))
(sb-sys:wait-until-fd-usable fd :input nil)
(go again))
(t (return (- -10 errno)))))
((zerop count) (return -1))
(t (return count)))))))))))
(t (error "implement me"))))))
(defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
(type (or null simple-stream-buffer) buffer)
(type fixnum start)
(type (or null fixnum) end))
(with-stream-class (simple-stream stream)
(let ((fd (sm output-handle stream))
(end (or end (error "WRITE-OCTETS: end=NIL")))
(buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
(typecase fd
(fixnum
(let ((flag (sb-sys:wait-until-fd-usable fd :output
(if blocking nil 0))))
(cond
((and (not blocking) (= start end)) (if flag -3 0))
((and (not blocking) (not flag)) 0)
(t
(block nil
(let ((count 0))
(tagbody again
(multiple-value-bind (bytes errno)
(sb-unix:unix-write fd (buffer-sap buffer) start
(- end start))
(when bytes
(incf count bytes)
(incf start bytes))
(cond ((null bytes)
(format t "~&;; UNIX-WRITE: errno=~D~%" errno)
(cond ((= errno sb-unix:eintr) (go again))
;; don't block for subsequent chars
(t (return (- -10 errno)))))
(t (return count)))))))))))
(t (error "implement me"))))))
;;;
;;; IMPLEMENTATIONS
;;;
(defmethod device-open ((stream null-simple-stream) options)
(add-stream-instance-flags stream :simple :input :output)
stream)
(defmethod device-open ((stream buffer-input-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream buffer-output-simple-stream) options)
#| do something |#
stream)
(defun open-file-stream (stream options)
(let ((filename (getf options :filename))
(direction (getf options :direction :input))
(if-exists (getf options :if-exists))
(if-exists-given (not (getf options :if-exists t)))
(if-does-not-exist (getf options :if-does-not-exist))
(if-does-not-exist-given (not (getf options :if-does-not-exist t))))
(with-stream-class (file-simple-stream stream)
(ecase direction
(:input (add-stream-instance-flags stream :input))
(:output (add-stream-instance-flags stream :output))
(:io (add-stream-instance-flags stream :input :output)))
(cond ((and (sm input-handle stream) (sm output-handle stream)
(not (eql (sm input-handle stream)
(sm output-handle stream))))
(error "Input-Handle and Output-Handle can't be different."))
((or (sm input-handle stream) (sm output-handle stream))
(add-stream-instance-flags stream :simple)
;; get namestring, etc. from handle, if possible (it's a stream)
;; set up buffers
stream)
(t
(multiple-value-bind (fd namestring original delete-original)
(%fd-open filename direction if-exists if-exists-given
if-does-not-exist if-does-not-exist-given)
(when fd
(add-stream-instance-flags stream :simple)
(setf (sm pathname stream) filename
(sm filename stream) namestring
(sm original stream) original
(sm delete-original stream) delete-original)
(when (any-stream-instance-flags stream :input)
(setf (sm input-handle stream) fd))
(when (any-stream-instance-flags stream :output)
(setf (sm output-handle stream) fd))
(sb-ext:finalize stream
(lambda ()
(sb-unix:unix-close fd)
(format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
namestring fd)))
stream)))))))
(defmethod device-open ((stream file-simple-stream) options)
(with-stream-class (file-simple-stream stream)
(when (open-file-stream stream options)
;; Franz says:
;; "The device-open method must be prepared to recognize resource
;; and change-class situations. If no filename is specified in
;; the options list, and if no input-handle or output-handle is
;; given, then the input-handle and output-handle slots should
;; be examined; if non-nil, that means the stream is still open,
;; and thus the operation being requested of device-open is a
;; change-class. Also, a device-open method need not allocate a
;; buffer every time it is called, but may instead reuse a
;; buffer it finds in a stream, if it does not become a security
;; issue."
(unless (sm buffer stream)
(let ((length (device-buffer-length stream)))
;; Buffer should be array of (unsigned-byte 8), in general
;; use strings for now so it's easy to read the content...
(setf (sm buffer stream) (make-string length)
(sm buffpos stream) 0
(sm buffer-ptr stream) 0
(sm buf-len stream) length)))
(when (any-stream-instance-flags stream :output)
(setf (sm control-out stream) *std-control-out-table*))
(install-single-channel-character-strategy
stream (getf options :external-format :default) nil))))
(defmethod device-open ((stream mapped-file-simple-stream) options)
(with-stream-class (mapped-file-simple-stream stream)
(when (open-file-stream stream options)
(let* ((input (any-stream-instance-flags stream :input))
(output (any-stream-instance-flags stream :output))
(prot (logior (if input PROT-READ 0)
(if output PROT-WRITE 0)))
(fd (or (sm input-handle stream) (sm output-handle stream))))
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
(sb-unix:unix-fstat fd)
(declare (ignore ino mode nlink uid gid rdev))
(unless okay
(sb-unix:unix-close fd)
(sb-ext:cancel-finalization stream)
(error "Error fstating ~S: ~A" stream
(sb-int:strerror dev)))
(when (> size most-positive-fixnum)
;; Or else BUF-LEN has to be a general integer, or
;; maybe (unsigned-byte 32). In any case, this means
;; BUF-MAX and BUF-PTR have to be the same, which means
;; number-consing every time BUF-PTR moves...
;; Probably don't have the address space available to map
;; bigger files, anyway. Maybe DEVICE-EXTEND can adjust
;; the mapped portion of the file?
(warn "Unable to memory-map entire file.")
(setf size most-positive-fixnum))
(let ((buffer
(sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
(when (null buffer)
(sb-unix:unix-close fd)
(sb-ext:cancel-finalization stream)
(error "Unable to map file."))
(setf (sm buffer stream) buffer
(sm buffpos stream) 0
(sm buffer-ptr stream) size
(sm buf-len stream) size)
(install-single-channel-character-strategy
stream (getf options :external-format :default) 'mapped)
(sb-ext:finalize stream
(lambda ()
(sb-unix:unix-munmap buffer size)
(format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
stream))
(defmethod device-open ((stream string-input-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream string-output-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream xp-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream socket-base-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream socket-simple-stream) options)
#| do something |#
stream)
(defmethod device-open ((stream terminal-simple-stream) options)
(with-stream-class (terminal-simple-stream stream)
(when (getf options :input-handle)
(setf (sm input-handle stream) (getf options :input-handle))
(add-stream-instance-flags stream :simple :interactive :dual :input)
(unless (sm buffer stream)
(let ((length (device-buffer-length stream)))
(setf (sm buffer stream) (make-string length)
(sm buf-len stream) length)))
(setf (sm control-in stream) *terminal-control-in-table*))
(when (getf options :output-handle)
(setf (sm output-handle stream) (getf options :output-handle))
(add-stream-instance-flags stream :simple :interactive :dual :output)
(unless (sm out-buffer stream)
(let ((length (device-buffer-length stream)))
(setf (sm out-buffer stream) (make-string length)
(sm max-out-pos stream) length)))
(setf (sm control-out stream) *std-control-out-table*))
(install-dual-channel-character-strategy
stream (getf options :external-format :default)))
#| do something |#
stream)
(defmethod device-close :around ((stream simple-stream) abort)
(with-stream-class (simple-stream stream)
(when (any-stream-instance-flags stream :input :output)
(when (any-stream-instance-flags stream :output)
(if abort
(clear-output stream)
(force-output stream)))
(call-next-method)
(setf (sm input-handle stream) nil
(sm output-handle stream) nil)
(remove-stream-instance-flags stream :input :output)
(sb-ext:cancel-finalization stream))))
(defmethod device-close ((stream simple-stream) abort)
(declare (ignore abort))
t)
(defmethod device-close ((stream file-simple-stream) abort)
(with-stream-class (file-simple-stream stream)
(cond (abort
;; Remove any fd-handler
;; If it's an output stream and has an original name,
;; revert the file
)
(t
;; If there's an original name and delete-original is set
;; kill the original
))
(if (sm input-handle stream)
(sb-unix:unix-close (sm input-handle stream))
(sb-unix:unix-close (sm output-handle stream)))
(setf (sm buffer stream) nil))
t)
(defmethod device-close ((stream mapped-file-simple-stream) abort)
(with-stream-class (mapped-file-simple-stream stream)
(when (sm buffer stream)
(sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
(setf (sm buffer stream) nil))
(cond (abort
;; remove any FD handler
;; if it has an original name (is this possible for mapped files?)
;; revert the file
)
(t
;; if there's an original name and delete-original is set (again,
;; is this even possible?), kill the original
))
(sb-unix:unix-close (sm input-handle stream)))
t)
(defmethod device-buffer-length ((stream simple-stream))
4096)
(defmethod device-buffer-length ((stream null-simple-stream))
256)
(defmethod device-file-position ((stream simple-stream))
(with-stream-class (simple-stream stream)
;; this may be wrong if :DUAL flag is set!
(sm buffpos stream)))
(defmethod (setf device-file-position) (value (stream simple-stream))
(with-stream-class (simple-stream stream)
;; this may be wrong if :DUAL flag is set!
(setf (sm buffpos stream) value)))
(defmethod device-file-position ((stream string-simple-stream))
;; get string length (of input or output buffer?)
)
(defmethod (setf device-file-position) (value (stream string-simple-stream))
;; set string length (of input or output buffer?)
)
(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
;; get fill pointer (of input or output buffer?)
)
(defmethod (setf device-file-position)
(value (stream fill-pointer-output-simple-stream))
;; set fill pointer (of input or output buffer?)
)
(defmethod device-file-position ((stream file-simple-stream))
(with-stream-class (file-simple-stream stream)
(values (sb-unix:unix-lseek (or (sm input-handle stream)
(sm output-handle stream))
0
sb-unix:l_incr))))
(defmethod (setf device-file-position) (value (stream file-simple-stream))
(declare (type fixnum value))
(with-stream-class (file-simple-stream stream)
(values (sb-unix:unix-lseek (or (sm input-handle stream)
(sm output-handle stream))
value
(if (minusp value)
sb-unix:l_xtnd
sb-unix:l_set)))))
(defmethod device-file-length ((stream simple-stream))
nil)
(defmethod device-file-length ((stream direct-simple-stream))
;; return buffer length
)
(defmethod device-file-length ((stream string-simple-stream))
;; return string length
)
(defmethod device-file-length ((stream file-simple-stream))
(with-stream-class (file-simple-stream stream)
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
(sb-unix:unix-fstat (sm input-handle stream))
(declare (ignore dev ino mode nlink uid gid rdev))
(if okay size nil))))
(defmethod device-read ((stream single-channel-simple-stream) buffer
start end blocking)
;; (when (and (null buffer) (not (eql start end)))
;; (with-stream-class (single-channel-simple-stream stream)
;; (setq buffer (sm buffer stream))
;; (setq end (sm buf-len stream))))
(read-octets stream buffer start end blocking))
(defmethod device-read ((stream dual-channel-simple-stream) buffer
start end blocking)
(when (null buffer)
(with-stream-class (dual-channel-simple-stream stream)
(setq buffer (sm buffer stream))
(setq end (- (sm buf-len stream) start))))
(read-octets stream buffer start end blocking))
(defmethod device-read ((stream null-simple-stream) buffer
start end blocking)
(declare (ignore buffer start end blocking))
-1)
(defmethod device-read ((stream terminal-simple-stream) buffer
start end blocking)
(let ((result (call-next-method)))
(if (= result -1) -2 result)))
(defmethod device-clear-input ((stream simple-stream) buffer-only)
(declare (ignore buffer-only))
nil)
(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
)
(defmethod device-write ((stream single-channel-simple-stream) buffer
start end blocking)
(when (and (null buffer) (not (eql start end)))
(with-stream-class (single-channel-simple-stream stream)
(setf buffer (sm buffer stream))
(setf end (sm buffpos stream))))
(write-octets stream buffer start end blocking))
(defmethod device-write ((stream dual-channel-simple-stream) buffer
start end blocking)
(when (and (null buffer) (not (eql start end)))
(with-stream-class (dual-channel-simple-stream stream)
(setf buffer (sm out-buffer stream))
(setf end (sm outpos stream))))
(write-octets stream buffer start end blocking))
(defmethod device-write ((stream null-simple-stream) buffer
start end blocking)
(declare (ignore buffer blocking))
(- end start))
(defmethod device-write ((stream socket-base-simple-stream) buffer
start end blocking)
;; @@2
(call-next-method))
(defmethod device-clear-output ((stream simple-stream))
nil)
(defmethod device-extend ((stream direct-simple-stream) need action)
(declare (ignore need action))
nil)
(defmethod device-extend ((stream string-input-simple-stream) need action)
(declare (ignore need action))
nil)
(defmethod device-extend ((stream string-output-simple-stream) need action)
;; @@3
)
(defmethod device-extend ((stream fill-pointer-output-simple-stream)
need action)
;; @@4
)
(defmethod device-extend ((stream mapped-file-simple-stream) need action)
(declare (ignore need action))
nil)
;; device-finish-record apparently has no methods defined
;;;
;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
;;;
;;;
;;; CREATION OF STANDARD STREAMS
;;;

522
contrib/sb-simple-streams/strategy.lisp Normal file
View file

@ -0,0 +1,522 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
(in-package "SB-SIMPLE-STREAMS")
(defun refill-buffer (stream blocking)
(with-stream-class (simple-stream stream)
(let* ((unread (sm last-char-read-size stream))
(buffer (sm buffer stream)))
(unless (zerop unread)
(buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
(let ((bytes (device-read stream nil unread nil blocking)))
(declare (type fixnum bytes))
(setf (sm buffpos stream) unread
(sm buffer-ptr stream) (if (plusp bytes)
(+ bytes unread)
unread))
bytes))))
(defun sc-flush-buffer (stream blocking)
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr 0)
(bytes (sm buffpos stream)))
(declare (type fixnum ptr bytes))
(loop
(when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
(let ((bytes-written (device-write stream nil ptr nil blocking)))
(declare (fixnum bytes-written))
(when (minusp bytes-written)
(error "DEVICE-WRITE error."))
(incf ptr bytes-written))))))
(defun dc-flush-buffer (stream blocking)
(with-stream-class (dual-channel-simple-stream stream)
(let ((ptr 0)
(bytes (sm outpos stream)))
(declare (type fixnum ptr bytes))
(loop
(when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
(let ((bytes-written (device-write stream nil ptr nil blocking)))
(declare (fixnum bytes-written))
(when (minusp bytes-written)
(error "DEVICE-WRITE error."))
(incf ptr bytes-written))))))
;;;
;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
;;;
(declaim (ftype j-read-char-fn sc-read-char))
(defun sc-read-char (stream eof-error-p eof-value blocking)
(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (single-channel-simple-stream stream)
;; if stream is open for read-write, may need to flush the buffer
(let* ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(code (if (< ptr (sm buffer-ptr stream))
(progn
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))
(let ((bytes (refill-buffer stream blocking)))
(declare (type fixnum bytes))
(unless (minusp bytes)
(let ((ptr (sm buffpos stream)))
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))))))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when code
(setf (sm last-char-read-size stream) 1)
(when (and (< code 32) ctrl (svref ctrl code))
;; Does this have to be a function, or can it be a symbol?
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char))))
(if (null char)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))
(declaim (ftype j-read-char-fn sc-read-char--buffer))
(defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
(declare (ignore blocking)) ;; everything is already in the buffer
(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (single-channel-simple-stream stream)
(let* ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(code (when (< ptr (sm buffer-ptr stream))
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr)))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when code
(setf (sm last-char-read-size stream) 1)
(when (and (< code 32) ctrl (svref ctrl code))
;; Does this have to be a function, or can it be a symbol?
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char))))
(if (null char)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))
(declaim (ftype j-read-chars-fn sc-read-chars))
(defun sc-read-chars (stream string search start end blocking)
;; string is filled from START to END, or until SEARCH is found
;; Return two values: count of chars read and
;; NIL if SEARCH was not found
;; T is SEARCH was found
;; :EOF if eof encountered before end
(declare (type simple-stream stream)
(type string string)
(type (or null character) search)
(type fixnum start end)
(type boolean blocking)
(optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (single-channel-simple-stream stream)
(setf (sm last-char-read-size stream) 0)
;; Should arrange for the last character to be unreadable
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(max (sm buffer-ptr stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
(declare (type fixnum ptr max posn count))
(let* ((code (if (< ptr max)
(prog1
(bref buffer ptr)
(incf ptr))
(let ((bytes (refill-buffer stream blocking)))
(declare (type fixnum bytes))
(setf ptr (sm buffpos stream)
max (sm buffer-ptr stream))
(when (plusp bytes)
(prog1
(bref buffer ptr)
(incf ptr))))))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when (and code (< code 32) ctrl (svref ctrl code))
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char)))
(cond ((null char)
(setf (sm buffpos stream) ptr)
(return (values count :eof)))
((and search (char= char search))
(setf (sm buffpos stream) ptr)
(return (values count t)))
(t
(setf (char string posn) char)))))))
(declaim (ftype j-read-chars-fn sc-read-chars--buffer))
(defun sc-read-chars--buffer (stream string search start end blocking)
(declare (type simple-stream stream)
(type string string)
(type (or null character) search)
(type fixnum start end)
(type boolean blocking)
(optimize (speed 3) (space 2) (safety 0) (debug 0)))
;; TODO: what about the blocking parameter?
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(max (sm buffer-ptr stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((= posn end)
(setf (sm buffpos stream) ptr)
(unless (zerop count) (setf (sm last-char-read-size stream) 1))
(values count nil))
(declare (type fixnum ptr max posn count))
(let* ((code (when (< ptr max)
(prog1
(bref buffer ptr)
(incf ptr))))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when (and code (< code 32) ctrl (svref ctrl code))
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char)))
(cond ((null char)
(setf (sm buffpos stream) ptr)
(unless (zerop count) (setf (sm last-char-read-size stream) 1))
(return (values count :eof)))
((and search (char= char search))
(setf (sm buffpos stream) ptr)
;; Unread of last char must unread the search character, too
;; If no characters were read, just add the length of the
;; search char to that of the previously read char.
(if (zerop count)
(incf (sm last-char-read-size stream))
(setf (sm last-char-read-size stream) 2))
(return (values count t)))
(t
(setf (char string posn) char)))))))
(declaim (ftype j-unread-char-fn sc-unread-char))
(defun sc-unread-char (stream relaxed)
(declare (ignore relaxed))
(with-stream-class (single-channel-simple-stream stream)
(let ((unread (sm last-char-read-size stream)))
(if (>= (sm buffpos stream) unread)
(decf (sm buffpos stream) unread)
(error "Unreading needs work"))
(setf (sm last-char-read-size stream) 0))))
(declaim (ftype j-write-char-fn sc-write-char))
(defun sc-write-char (character stream)
(with-stream-class (single-channel-simple-stream stream)
(let* ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(code (char-code character))
(ctrl (sm control-out stream)))
(when (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream character))
(return-from sc-write-char character))
(if (< ptr (sm buffer-ptr stream))
(progn
(setf (bref buffer ptr) code)
(setf (sm buffpos stream) (1+ ptr)))
(progn
(sc-flush-buffer stream t)
(setf ptr (sm buffpos stream))))))
character)
(declaim (ftype j-write-chars-fn sc-write-chars))
(defun sc-write-chars (string stream start end)
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
;; xxx buffer-ptr or buf-len? TODO: look them up in the
;; docs; was: buffer-ptr, but it's initialized to 0 in
;; (device-open file-simple-stream); buf-len seems to work(tm)
(max #+nil(sm buffer-ptr stream) ;; or buf-len?
(sm buf-len stream))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end) (setf (sm buffpos stream) ptr) count)
(declare (type fixnum ptr max posn count))
(let* ((char (char string posn))
(code (char-code char)))
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream char))
(if (< ptr max)
(progn
(setf (bref buffer ptr) code)
(incf ptr))
(progn
(sc-flush-buffer stream t)
(setf ptr (sm buffpos stream)))))))))
(declaim (ftype j-listen-fn sc-listen))
(defun sc-listen (stream)
(with-stream-class (single-channel-simple-stream stream)
(or (< (sm buffpos stream) (sm buffer-ptr stream))
(case (device-read stream nil 0 0 nil)
((0 -2) nil)
(-1 #| latch EOF |# nil)
(-3 t)
(t (error "DEVICE-READ error."))))))
;;;
;;; DUAL-CHANNEL STRATEGY FUNCTIONS
;;;
(declaim (ftype j-read-char-fn dc-read-char))
(defun dc-read-char (stream eof-error-p eof-value blocking)
;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (dual-channel-simple-stream stream)
;; if interactive flag is set, finish-output first
(let* ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(code (if (< ptr (sm buffer-ptr stream))
(progn
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))
(let ((bytes (refill-buffer stream blocking)))
(declare (type fixnum bytes))
(unless (minusp bytes)
(let ((ptr (sm buffpos stream)))
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))))))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when code
(setf (sm last-char-read-size stream) 1)
(when (and (< code 32) ctrl (svref ctrl code))
;; Does this have to be a function, or can it be a symbol?
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char)))
#|(let ((column (sm charpos stream)))
(declare (type (or null fixnum) column))
(when column
(setf (sm charpos stream) (1+ column))))|#)
(if (null char)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
char))))
(declaim (ftype j-read-chars-fn dc-read-chars))
(defun dc-read-chars (stream string search start end blocking)
(declare (type dual-channel-simple-stream stream)
(type string string)
(type (or null character) search)
(type fixnum start end)
(type boolean blocking)
#|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
(with-stream-class (dual-channel-simple-stream stream)
;; if interactive flag is set, finish-output first
(setf (sm last-char-read-size stream) 0)
;; Should arrange for the last character to be unreadable
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(max (sm buffer-ptr stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
(declare (type fixnum ptr max posn count))
(let* ((code (if (< ptr max)
(prog1
(bref buffer ptr)
(incf ptr))
(let ((bytes (refill-buffer stream blocking)))
(declare (type fixnum bytes))
(setf ptr (sm buffpos stream)
max (sm buffer-ptr stream))
(when (plusp bytes)
(prog1
(bref buffer ptr)
(incf ptr))))))
(char (if code (code-char code) nil))
(ctrl (sm control-in stream)))
(when (and code (< code 32) ctrl (svref ctrl code))
(setq char (funcall (the (or symbol function) (svref ctrl code))
stream char)))
#|(let ((column (sm charpos stream)))
(declare (type (or null fixnum) column))
(when column
(setf (sm charpos stream) (1+ column))))|#
(cond ((null char)
(setf (sm buffpos stream) ptr)
(return (values count :eof)))
((and search (char= char search))
(setf (sm buffpos stream) ptr)
(return (values count t)))
(t
(setf (char string posn) char)))))))
(declaim (ftype j-unread-char-fn dc-unread-char))
(defun dc-unread-char (stream relaxed)
(declare (ignore relaxed))
(with-stream-class (dual-channel-simple-stream stream)
(let ((unread (sm last-char-read-size stream)))
(if (>= (sm buffpos stream) unread)
(decf (sm buffpos stream) unread)
(error "Unreading needs work"))
(setf (sm last-char-read-size stream) 0))))
(declaim (ftype j-write-char-fn dc-write-char))
(defun dc-write-char (character stream)
(with-stream-class (dual-channel-simple-stream stream)
(let* ((buffer (sm out-buffer stream))
(ptr (sm outpos stream))
(code (char-code character))
(ctrl (sm control-out stream)))
(when (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream character))
(return-from dc-write-char character))
(if (< ptr (sm max-out-pos stream))
(progn
(setf (bref buffer ptr) code)
(setf (sm outpos stream) (1+ ptr)))
(progn
(dc-flush-buffer stream t)
(setf ptr (sm outpos stream))))))
character)
(declaim (ftype j-write-chars-fn dc-write-chars))
(defun dc-write-chars (string stream start end)
(with-stream-class (dual-channel-simple-stream stream)
(do ((buffer (sm out-buffer stream))
(ptr (sm outpos stream))
(max (sm max-out-pos stream))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
((>= posn end) (setf (sm outpos stream) ptr) count)
(declare (type fixnum ptr max posn count))
(let* ((char (char string posn))
(code (char-code char)))
(unless (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream char))
(if (< ptr max)
(progn
(setf (bref buffer ptr) code)
(incf ptr))
(progn
(dc-flush-buffer stream t)
(setf ptr (sm outpos stream)))))))))
(declaim (ftype j-listen-fn dc-listen))
(defun dc-listen (stream)
(with-stream-class (dual-channel-simple-stream stream)
(or (< (sm buffpos stream) (sm buffer-ptr stream))
(case (device-read stream nil 0 0 nil)
((0 -2) nil)
(-1 #| latch EOF |# nil)
(-3 t)
(t (error "DEVICE-READ error."))))))
;;;
;;; STRING STRATEGY FUNCTIONS
;;;
(declaim (ftype j-read-char-fn string-read-char))
(defun string-read-char (stream eof-error-p eof-value blocking)
(declare (type string-input-simple-stream stream) (ignore blocking)
(optimize (speed 3) (space 2) (safety 0) (debug 0)))
(with-stream-class (string-input-simple-stream stream)
(when (any-stream-instance-flags stream :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value))
(let* ((ptr (sm buffpos stream))
(char (if (< ptr (sm buffer-ptr stream))
(schar (sm buffer stream) ptr)
nil)))
(if (null char)
(sb-impl::eof-or-lose stream eof-error-p eof-value)
(progn
(setf (sm last-char-read-size stream) 1)
;; do string-streams do control-in processing?
#|(let ((column (sm charpos stream)))
(declare (type (or null fixnum) column))
(when column
(setf (sm charpos stream) (1+ column))))|#
char)))))
(declaim (ftype j-read-char-fn composing-crlf-read-char))
(defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
;; TODO: what about the eof-error-p parameter?
(with-stream-class (simple-stream stream)
(let* ((melded-stream (sm melded-stream stream))
(char (funcall-stm-handler j-read-char melded-stream nil stream
blocking)))
;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
;; character was available...
(when (eql char #\Return)
(let ((next (funcall-stm-handler j-read-char melded-stream
nil stream blocking)))
;; if NEXT is STREAM, we hit EOF, so we should just return the
;; #\Return (and mark the stream :EOF? At least unread if we
;; got a soft EOF, from a terminal, etc.
;; if NEXT is NIL, blocking is NIL and there's a CR but no
;; LF available on the stream: have to unread the CR and
;; return NIL, letting the CR be reread later.
;;
;; If we did get a linefeed, adjust the last-char-read-size
;; so that an unread of the resulting newline will unread both
;; the linefeed _and_ the carriage return.
(if (eql next #\Linefeed)
(setq char #\Newline)
(funcall-stm-handler j-unread-char melded-stream nil))))
;; do control-in processing on whatever character we've got
char)))
(declaim (ftype j-unread-char-fn composing-crlf-unread-char))
(defun composing-crlf-unread-char (stream relaxed)
(declare (ignore relaxed))
(with-stream-class (simple-stream stream)
(funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
;;;
;;;
;;;
(defun install-single-channel-character-strategy (stream external-format
access)
(declare (ignore external-format))
;; ACCESS is usually NIL
;; May be "undocumented" values: stream::buffer, stream::mapped
;; to install strategies suitable for direct buffer streams
;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
;; (Avoids checking "mode" flags by installing special strategy)
(with-stream-class (single-channel-simple-stream stream)
(if (or (eq access 'buffer) (eq access 'mapped))
(setf (sm j-read-char stream) #'sc-read-char--buffer
(sm j-read-chars stream) #'sc-read-chars--buffer
(sm j-unread-char stream) #'sc-unread-char
(sm j-write-char stream) #'sc-write-char
(sm j-write-chars stream) #'sc-write-chars
(sm j-listen stream) #'sc-listen)
(setf (sm j-read-char stream) #'sc-read-char
(sm j-read-chars stream) #'sc-read-chars
(sm j-unread-char stream) #'sc-unread-char
(sm j-write-char stream) #'sc-write-char
(sm j-write-chars stream) #'sc-write-chars
(sm j-listen stream) #'sc-listen)))
stream)
(defun install-dual-channel-character-strategy (stream external-format)
(declare (ignore external-format))
(with-stream-class (dual-channel-simple-stream stream)
(setf (sm j-read-char stream) #'dc-read-char
(sm j-read-chars stream) #'dc-read-chars
(sm j-unread-char stream) #'dc-unread-char
(sm j-write-char stream) #'dc-write-char
(sm j-write-chars stream) #'dc-write-chars
(sm j-listen stream) #'dc-listen))
stream)
(defun install-string-character-strategy (stream)
(with-stream-class (string-simple-stream stream)
(setf (sm j-read-char stream) #'string-read-char))
stream)

77
contrib/sb-simple-streams/unix.lisp Normal file
View file

@ -0,0 +1,77 @@
;;; -*- lisp -*-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
;;; who placed the code in the public domain. Sbcl port by Rudi
;;; Schlatte.
;;; TODO (Rudi 2003-05-12): The contents of this file, along with
;;; constants.lisp, should presumably end up somewhere else, either in
;;; sbcl itself or in sb-posix.
(in-package "SB-UNIX")
;;; TODO (Rudi 2003-05-12): Check whether this bug exists in sbcl, fix
;;; it if yes, and take care not to break platforms where the offset
;;; is not a 32-bit signed integer.
;; Fix bug that claims offset is unsigned, so seeking backwards works!
(defun unix-lseek (fd offset whence)
"Unix-lseek accepts a file descriptor and moves the file pointer ahead
a certain offset for that file. Whence can be any of the following:
l_set Set the file pointer.
l_incr Increment the file pointer.
l_xtnd Extend the file size.
"
(declare (type unix-fd fd)
(type (signed-byte 32) offset)
(type (integer 0 2) whence))
(int-syscall ("lseek" int off-t int) fd offset whence))
(export '(prot-read prot-write prot-exec prot-none
map-shared map-private map-fixed
unix-mmap unix-munmap
unix-mlock unix-munlock))
(defun unix-mmap (addr length prot flags fd offset)
(declare (type (or null system-area-pointer) addr)
(type (unsigned-byte 32) length)
(type (integer 1 7) prot)
(type (unsigned-byte 32) flags)
(type (or null unix-fd) fd)
(type (signed-byte 32) offset))
(let ((result (alien-funcall (extern-alien "mmap"
(function system-area-pointer
system-area-pointer
size-t int int int
off-t))
(or addr (sb-sys:int-sap 0)) length prot flags
(or fd -1) offset)))
;; FIXME (Rudi 2003-05-12) : here, we assume that a sap is 32
;; bits. Revisit during the 64-bit port. #XFFFFFFFF is (void
;; *)-1, which is the charming return value of mmap on failure.
(if (= (sb-sys:sap-int result) #XFFFFFFFF)
(values nil (get-errno))
result)))
(defun unix-munmap (start length)
(declare (type system-area-pointer start)
(type (unsigned-byte 32) length))
(void-syscall ("munmap" system-area-pointer size-t) start length))
(defun unix-mlock (addr length)
(declare (type system-area-pointer addr)
(type (unsigned-byte 32) length))
(void-syscall ("mlock" system-area-pointer size-t) addr length))
(defun unix-munlock (addr length)
(declare (type system-area-pointer addr)
(type (unsigned-byte 32) length))
(void-syscall ("munlock" system-area-pointer size-t) addr length))

2
version.lisp-expr
View file

@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.8alpha.0.26"
"0.8alpha.0.27"