From: Rudi Schlatte Date: Sun, 7 Sep 2003 14:19:08 +0000 (+0000) Subject: Remove files (cl.lisp superseded by impl.lisp, simple-streams.lisp X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=47aee4c457bc6f655bcc5843da6b67676c4fc097;p=sbcl.git Remove files (cl.lisp superseded by impl.lisp, simple-streams.lisp broken in parts) --- diff --git a/contrib/sb-simple-streams/cl.lisp b/contrib/sb-simple-streams/cl.lisp deleted file mode 100644 index 0df60ea..0000000 --- a/contrib/sb-simple-streams/cl.lisp +++ /dev/null @@ -1,1186 +0,0 @@ -;;; -*- 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") - -;;; Implementations of standard Common Lisp functions for simple-streams - -(defmacro %check-simple-stream (stream &optional direction) - ;; Check that STREAM is valid and open in the appropriate direction. - `(locally - (declare (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (with-stream-class (simple-stream ,stream) - (let ((flags (sm %flags ,stream))) - (cond ((zerop (logand flags ,(%flags '(:simple)))) - (error "~S is not properly initialized." stream)) - ((zerop (logand flags ,(%flags '(:input :output)))) - (error "~S is closed." stream)) - ,@(when direction - `(((zerop (logand flags ,(%flags (list direction)))) - (error ,(format nil "~~S is not an ~(~A~) stream." - direction) - stream))))))))) - - -(defun %simple-stream-file-position (stream position) - (if (typep stream 'file-simple-stream) - (with-stream-class (file-simple-stream stream) - (if (null position) - (let ((posn (device-file-position stream))) - (when posn - ;; Adjust for data read from device but not yet - ;; consumed from buffer, or written after the end of - ;; the buffer - (decf posn (- (sm buffer-ptr stream) (sm buffpos stream)))) - posn) - (progn - (setf (sm last-char-read-size stream) 0) - (let ((position - (cond ((numberp position) position) - ((eq position :start) 0) - ((eq position :end) - (%simple-stream-file-length stream)) - (t (error "Invalid position-spec: ~A" position)))) - (device-position (device-file-position stream))) - (if (and (<= (- device-position (sm buffer-ptr stream)) - position - device-position) - (not (any-stream-instance-flags stream :dirty))) - ;; new position is within buffer; just move pointer - (setf (sm buffpos stream) - (- position (- device-position (sm buffer-ptr stream)))) - (progn - (when (any-stream-instance-flags stream :dirty) - (sc-flush-buffer stream t)) - (setf (device-file-position stream) position - (sm buffer-ptr stream) 0 - (sm buffpos stream) 0))))))) - ;; TODO: implement file-position for other types of stream where - ;; it makes sense - nil)) - - -(defun %simple-stream-file-length (stream) - (declare (type simple-stream stream)) - (%check-simple-stream stream) - (device-file-length stream) - ;; implement me - ) - - -(defun %simple-stream-file-name (stream) - (declare (type simple-stream stream)) - (if (typep stream 'file-simple-stream) - (with-stream-class (file-simple-stream stream) - (sm pathname stream)) - nil)) - - -(defun %simple-stream-file-rename (stream new-name) - (declare (type simple-stream stream)) - (if (typep stream 'file-simple-stream) - (with-stream-class (file-simple-stream stream) - (setf (sm pathname stream) new-name) - (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) - t) - nil)) - - -(defun %simple-stream-file-string-length (stream object) - (declare (type simple-stream stream)) - (etypecase object - (character 1) - (string (length object)))) - - -(defun %simple-stream-read-char (stream eof-error-p eof-value - recursive-p blocking-p) - (declare (type simple-stream stream) - (ignore recursive-p)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :input) - (funcall-stm-handler j-read-char (sm melded-stream stream) - eof-error-p eof-value blocking-p))) - - -(defun %simple-stream-unread-char (stream character) - (declare (type simple-stream stream) (ignore character)) - (%check-simple-stream stream :input) - (with-stream-class (simple-stream) - (if (zerop (sm last-char-read-size stream)) - (error "Nothing to unread.") - (funcall-stm-handler j-unread-char stream nil)))) - -(defun %simple-stream-peek-char (stream peek-type eof-error-p - eof-value recursive-p) - (declare (type simple-stream stream) - (ignore recursive-p)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :input) - (let* ((encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap - eof-error-p stream t))) - (cond ((eq char stream) eof-value) - ((characterp peek-type) - (do ((char char (funcall-stm-handler j-read-char encap - eof-error-p - stream t))) - ((or (eq char stream) (char= char peek-type)) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - ((eq peek-type t) - (do ((char char (funcall-stm-handler j-read-char stream - eof-error-p - stream t))) - ((or (eq char stream) - (not (sb-impl::whitespacep char))) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - (t - (funcall-stm-handler j-unread-char encap t) - char))))) - - -(defun %simple-stream-read-line (stream eof-error-p eof-value recursive-p) - (declare (type simple-stream stream) - (ignore recursive-p) - (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (%check-simple-stream stream :input) - (with-stream-class (simple-stream stream) - (let* ((encap (sm melded-stream stream)) ; encapsulating stream - (cbuf (make-string 80)) ; current buffer - (bufs (list cbuf)) ; list of buffers - (tail bufs) ; last cons of bufs list - (index 0) ; current index in current buffer - (total 0)) ; total characters - (declare (type simple-stream encap) - (type simple-base-string cbuf) - (type cons bufs tail) - (type fixnum index total)) - (loop - (multiple-value-bind (chars done) - (funcall-stm-handler j-read-chars encap cbuf - #\Newline index (length cbuf) t) - (declare (type fixnum chars)) - (incf index chars) - (incf total chars) - (when (and (eq done :eof) (zerop index)) - (if eof-error-p - (error 'end-of-file :stream stream) - (return (values eof-value t)))) - (when done - ;; If there's only one buffer in use, return it directly - (when (null (cdr bufs)) - (return (values (sb-kernel:shrink-vector cbuf index) - (eq done :eof)))) - ;; If total fits in final buffer, use it - #+(or) - (when (<= total (length cbuf)) - (replace cbuf cbuf :start1 (- total index) :end2 index) - (let ((idx 0)) - (declare (type fixnum idx)) - (dolist (buf bufs) - (declare (type simple-base-string buf)) - (replace cbuf buf :start1 idx) - (incf idx (length buf)))) - (return (values (sb-kernel:shrink-vector cbuf index) - (eq done :eof)))) - ;; Allocate new string of appropriate length - (let ((string (make-string total)) - (index 0)) - (declare (type fixnum index)) - (dolist (buf bufs) - (declare (type simple-base-string buf)) - (replace string buf :start1 index) - (incf index (length buf))) - (return (values string (eq done :eof))))) - (when (>= index (length cbuf)) - (setf cbuf (make-string (the fixnum (* 2 index)))) - (setf index 0) - (setf (cdr tail) (cons cbuf nil)) - (setf tail (cdr tail)))))))) - - -(defun %simple-stream-listen (stream width) - (declare (type simple-stream stream)) - ;; WIDTH is number of octets which must be available; any value - ;; other than 1 is treated as 'character. - (%check-simple-stream stream :input) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (with-stream-class (single-channel-simple-stream stream) - (if (not (eql width 1)) - (funcall-stm-handler j-listen stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (when (>= (sm mode stream) 0) ;; device-connected - (incf (sm last-char-read-size stream)) - (let ((ok (sc-refill-buffer stream nil))) - (decf (sm last-char-read-size stream)) - (plusp ok)))))) - ;; dual-channel-simple-stream - (error "Implement %LISTEN") - ;; string-simple-stream - (error "Implement %LISTEN"))) - - -(defun %simple-stream-clear-input (stream buffer-only) - (declare (type simple-stream stream)) - (%check-simple-stream stream :input) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (with-stream-class (single-channel-simple-stream stream) - (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm last-char-read-size stream) 0)) - ;; dual-channel-simple-stream - (with-stream-class (dual-channel-simple-stream stream) - (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm last-char-read-size stream) 0)) - ;; string-simple-stream - nil) - (unless buffer-only (device-clear-input stream buffer-only))) - - -(defun %simple-stream-read-byte (stream eof-error-p eof-value) - (declare (type simple-stream stream)) - (%check-simple-stream stream :input) - (with-stream-class (simple-stream stream) - (if (any-stream-instance-flags stream :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (sc-read-byte stream eof-error-p eof-value t) - ;; dual-channel-simple-stream - (dc-read-byte stream eof-error-p eof-value t) - ;; string-simple-stream - (with-stream-class (string-simple-stream stream) - (let ((encap (sm input-handle stream))) - (unless encap - (error 'simple-type-error - :datum stream - :expected-type 'stream - :format-control "Can't read-byte on string streams" - :format-arguments '())) - (prog1 - (locally (declare (notinline read-byte)) - (read-byte encap eof-error-p eof-value)) - (setf (sm last-char-read-size stream) 0 - (sm encapsulated-char-read-size stream) 0)))))))) - - -(defun %simple-stream-write-char (stream character) - (declare (type simple-stream stream)) - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) - - -(defun %simple-stream-fresh-line (stream) - (declare (type simple-stream stream)) - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - (when (/= (or (sm charpos stream) 1) 0) - (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream)) - t))) - - -(defun %simple-stream-write-string (stream string start end) - (declare (type simple-stream stream)) - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream) - start end))) - - -(defun %simple-stream-line-length (stream) - (declare (type simple-stream stream)) - (%check-simple-stream stream :output) - #| TODO: implement me |# - nil ;; implement me - ) - - -(defun %simple-stream-finish-output (stream) - (declare (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :output) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (sc-flush-buffer stream t) - ;; dual-channel-simple-stream - (dc-flush-buffer stream t) - ;; string-simple-stream - nil))) - - -(defun %simple-stream-force-output (stream) - (declare (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :output) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (sc-flush-buffer stream nil) - ;; dual-channel-simple-stream - (dc-flush-buffer stream nil) - ;; string-simple-stream - nil))) - - -(defun %simple-stream-clear-output (stream) - (declare (type simple-stream stream)) - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - #| TODO: clear output buffer |# - (device-clear-output stream))) - - -(defun %simple-stream-write-byte (stream integer) - (declare (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :output) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (with-stream-class (single-channel-simple-stream stream) - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buf-len stream)) - (setf ptr (sc-flush-buffer stream t))) - (add-stream-instance-flags stream :dirty) - (setf (sm buffpos stream) (1+ ptr)) - (setf (bref (sm buffer stream) ptr) integer))) - ;; dual-channel-simple-stream - (with-stream-class (dual-channel-simple-stream stream) - (let ((ptr (sm outpos stream))) - (when (>= ptr (sm max-out-pos stream)) - (setf ptr (dc-flush-buffer stream t))) - (setf (sm outpos stream) (1+ ptr)) - (setf (bref (sm out-buffer stream) ptr) integer))) - ;; string-simple-stream - (error 'simple-type-error - :datum stream - :expected-type 'stream - :format-control "Can't write-byte on string streams." - :format-arguments '())))) - - -(defun %simple-stream-read-sequence (stream seq start end partial-fill) - (declare (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :input) - (etypecase seq - (string - (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil - start (or end (length seq)) - (if partial-fill :bnb t))) - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - ;; TODO: "read-vector" equivalent, but blocking if partial-fill is NIL - (error "implement me") - )))) - - -(defun %simple-stream-write-sequence (stream seq start end) - (declare (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (%check-simple-stream stream :output) - (etypecase seq - (string - (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream) - start (or end (length seq)))) - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - ;; "write-vector" equivalent - (simple-stream-dispatch stream - ;; single-channel-simple-stream - (with-stream-class (single-channel-simple-stream stream) - (loop with max-ptr = (sm buf-len stream) - with real-end = (or end (length seq)) - for src-pos = start then (+ src-pos count) - for src-rest = (- real-end src-pos) - while (> src-rest 0) ; FIXME: this is non-ANSI - for ptr = (let ((ptr (sm buffpos stream))) - (if (>= ptr max-ptr) - (sc-flush-buffer stream t) - ptr)) - for buf-rest = (- max-ptr ptr) - for count = (min buf-rest src-rest) - do (progn (add-stream-instance-flags stream :dirty) - (setf (sm buffpos stream) (+ ptr count)) - (buffer-copy seq src-pos (sm buffer stream) ptr count)))) - ;; dual-channel-simple-stream - (error "Implement me") - ;; string-simple-stream - (error 'simple-type-error - :datum stream - :expected-type 'stream - :format-control "Can't write-byte on string streams." - :format-arguments '())) - )))) - - -;;; Basic functionality for ansi-streams. These are separate -;;; functions because they are called in places where we already know -;;; we operate on an ansi-stream (as opposed to a simple- or -;;; gray-stream, or the symbols t or nil), so we can evade typecase -;;; and (in|out)-synonym-of calls. - -(declaim (inline %ansi-stream-read-byte %ansi-stream-read-char - %ansi-stream-unread-char %ansi-stream-read-line - %ansi-stream-read-sequence)) - -(defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking) - (declare (ignore blocking)) - #+nil - (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-byte stream - (prog1 - (sb-int:fast-read-byte eof-error-p eof-value t) - (sb-int:done-with-fast-read-byte)))) - -(defun %ansi-stream-read-char (stream eof-error-p eof-value blocking) - (declare (ignore blocking)) - #+nil - (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-char stream - (prog1 - (sb-int:fast-read-char eof-error-p eof-value) - (sb-int:done-with-fast-read-char)))) - -(defun %ansi-stream-unread-char (character stream) - (let ((index (1- (sb-kernel:ansi-stream-in-index stream))) - (buffer (sb-kernel:ansi-stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "nothing to unread")) - (cond (buffer - (setf (aref buffer index) (char-code character)) - (setf (sb-kernel:ansi-stream-in-index stream) index)) - (t - (funcall (sb-kernel:ansi-stream-misc stream) stream - :unread character))))) - -(defun %ansi-stream-read-line (stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (sb-int:fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (sb-int:done-with-fast-read-char) - (return (values (sb-kernel:shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (sb-int:done-with-fast-read-char) - (return (values (sb-impl::eof-or-lose stream eof-error-p - eof-value) - t))) - ;; Since FAST-READ-CHAR already hit the eof char, we - ;; shouldn't do another READ-CHAR. - (t - (sb-int:done-with-fast-read-char) - (return (values (sb-kernel:shrink-vector res index) t))))))))) - -(defun %ansi-stream-read-sequence (seq stream start %end) - (declare (type sequence seq) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start) - (type sb-kernel:sequence-end %end) - (values sb-int:index)) - (let ((end (or %end (length seq)))) - (declare (type sb-int:index end)) - (etypecase seq - (list - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'%ansi-stream-read-char - #'%ansi-stream-read-byte))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end)) i) - (declare (type list rem) - (type sb-int:index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return i)) - (setf (first rem) el))))) - (vector - (sb-kernel:with-array-data ((data seq) (offset-start start) - (offset-end end)) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*)) - simple-string) - (let* ((numbytes (- end start)) - (bytes-read (sb-sys:read-n-bytes stream - data - offset-start - numbytes - nil))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) - (t - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'%ansi-stream-read-char - #'%ansi-stream-read-byte))) - (do ((i offset-start (1+ i))) - ((>= i offset-end) end) - (declare (type sb-int:index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return (+ start (- i offset-start)))) - (setf (aref data i) el))))))))))) - - -(defun %ansi-stream-write-string (string stream start end) - (declare (type string string) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start end)) - - ;; Note that even though you might expect, based on the behavior of - ;; things like AREF, that the correct upper bound here is - ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for - ;; "bounding index" and "length" indicate that in this case (i.e. - ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE - ;; which are implemented in terms of this function), (LENGTH STRING) - ;; is the required upper bound. A foolish consistency is the - ;; hobgoblin of lesser languages.. - (unless (<= 0 start end (length string)) - (error "~@" - start - end - string)) - - (if (sb-kernel:array-header-p string) - (sb-kernel:with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (sb-kernel:ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (sb-kernel:ansi-stream-sout stream) stream string start end)) - string) - -(defun %ansi-stream-write-sequence (seq stream start %end) - (declare (type sequence seq) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start) - (type sb-kernel:sequence-end %end) - (values sequence)) - (let ((end (or %end (length seq)))) - (declare (type sb-int:index end)) - (etypecase seq - (list - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - ;; TODO: Replace these with ansi-stream specific - ;; functions too. - #'write-char - #'write-byte))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end)) seq) - (declare (type list rem) - (type sb-int:index i)) - (funcall write-function (first rem) stream)))) - (string - (%ansi-stream-write-string seq stream start end)) - (vector - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - ;; TODO: Replace these with ansi-stream specific - ;; functions too. - #'write-char - #'write-byte))) - (do ((i start (1+ i))) - ((>= i end) seq) - (declare (type sb-int:index i)) - (funcall write-function (aref seq i) stream))))))) - - -;;; -;;; USER-LEVEL FUNCTIONS -;;; - -(defmethod open-stream-p ((stream simple-stream)) - (any-stream-instance-flags stream :input :output)) - -(defmethod input-stream-p ((stream simple-stream)) - (any-stream-instance-flags stream :input)) - -(defmethod output-stream-p ((stream simple-stream)) - (any-stream-instance-flags stream :output)) - -(defmethod stream-element-type ((stream simple-stream)) - '(unsigned-byte 8)) - -(defun interactive-stream-p (stream) - "Return true if Stream does I/O on a terminal or other interactive device." - (etypecase stream - (simple-stream - (any-stream-instance-flags stream :interactive)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p)) - (fundamental-stream - nil))) - -(defun (setf interactive-stream-p) (flag stream) - (typecase stream - (simple-stream - (if flag - (add-stream-instance-flags stream :interactive) - (remove-stream-instance-flags stream :interactive))) - (t - (error 'simple-type-error - :datum stream - :expected-type 'simple-stream - :format-control "Can't set interactive flag on ~S." - :format-arguments (list stream))))) - -(defun file-string-length (stream object) - (declare (type (or string character) object) (type stream stream)) - "Return the delta in STREAM's FILE-POSITION that would be caused by writing - OBJECT to STREAM. Non-trivial only in implementations that support - international character sets." - (typecase stream - (simple-stream (%simple-stream-file-string-length stream object)) - (t - (etypecase object - (character 1) - (string (length object)))))) - -(defun stream-external-format (stream) - "Returns Stream's external-format." - (etypecase stream - (simple-stream - (with-stream-class (simple-stream) - (sm external-format stream))) - (ansi-stream - :default) - (fundamental-stream - :default))) - -(defun open (filename &rest options - &key (direction :input) - (element-type 'character element-type-given) - if-exists if-does-not-exist - (external-format :default) - class mapped input-handle output-handle - &allow-other-keys) - "Return a stream which reads from or writes to Filename. - Defined keywords: - :direction - one of :input, :output, :io, or :probe - :element-type - type of object to read or write, default BASE-CHAR - :if-exists - one of :error, :new-version, :rename, :rename-and-delete, - :overwrite, :append, :supersede or NIL - :if-does-not-exist - one of :error, :create or NIL - :external-format - :default - See the manual for details. - - The following are simple-streams-specific additions: - :class - class of stream object to be created - :mapped - T to open a memory-mapped file - :input-handle - a stream or Unix file descriptor to read from - :output-handle - a stream or Unix file descriptor to write to" - (declare (ignore external-format input-handle output-handle - if-exists if-does-not-exist)) - (let ((class (or class 'sb-sys::file-stream)) - (options (copy-list options)) - (filespec (merge-pathnames filename))) - (cond ((eq class 'sb-sys::file-stream) - (remf options :class) - (remf options :mapped) - (remf options :input-handle) - (remf options :output-handle) - (apply #'open-fd-stream filespec options)) - ((subtypep class 'simple-stream) - (when element-type-given - (error "Can't create simple-streams with an element-type.")) - (when (and (eq class 'file-simple-stream) mapped) - (setq class 'mapped-file-simple-stream) - (setf (getf options :class) 'mapped-file-simple-stream)) - (when (subtypep class 'file-simple-stream) - (when (eq direction :probe) - (setq class 'probe-simple-stream))) - (apply #'make-instance class :filename filespec options)) - ((subtypep class 'sb-gray:fundamental-stream) - (remf options :class) - (remf options :mapped) - (remf options :input-handle) - (remf options :output-handle) - (make-instance class :lisp-stream - (apply #'open-fd-stream filespec options)))))) - - -(declaim (inline read-byte read-char read-char-no-hang unread-char)) - -(defun read-byte (stream &optional (eof-error-p t) eof-value) - "Returns the next byte of the Stream." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-read-byte stream eof-error-p eof-value)) - (ansi-stream - (%ansi-stream-read-byte stream eof-error-p eof-value t)) - (fundamental-stream - (let ((char (sb-gray:stream-read-byte stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) - -(defun read-char (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Inputs a character from Stream and returns it." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-read-char stream eof-error-p eof-value recursive-p t)) - (ansi-stream - (%ansi-stream-read-char stream eof-error-p eof-value t)) - (fundamental-stream - (let ((char (sb-gray:stream-read-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) - -(defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Returns the next character from the Stream if one is availible, or nil." - (declare (ignore recursive-p)) - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%check-simple-stream stream :input) - (with-stream-class (simple-stream) - (funcall-stm-handler j-read-char stream eof-error-p eof-value nil))) - (ansi-stream - (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen) - (%ansi-stream-read-char stream eof-error-p eof-value t) - nil)) - (fundamental-stream - (let ((char (sb-gray:stream-read-char-no-hang stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) - -(defun unread-char (character &optional (stream *standard-input*)) - "Puts the Character back on the front of the input Stream." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-unread-char stream character)) - (ansi-stream - (%ansi-stream-unread-char character stream)) - (fundamental-stream - (sb-gray:stream-unread-char stream character)))) - nil) - -(declaim (notinline read-byte read-char read-char-no-hang unread-char)) - -(defun peek-char (&optional (peek-type nil) (stream *standard-input*) - (eof-error-p t) eof-value recursive-p) - "Peeks at the next character in the input Stream. See manual for details." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-peek-char stream peek-type eof-error-p eof-value - recursive-p)) - (ansi-stream - (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (%ansi-stream-read-char stream eof-error-p - eof-value t))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (%ansi-stream-unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (%ansi-stream-read-char stream eof-error-p - eof-value t))) - ((or (eq char eof-value) - (not (sb-int:whitespace-char-p char))) - (unless (eq char eof-value) - (%ansi-stream-unread-char char stream)) - char))) - (t - (%ansi-stream-unread-char char stream) - char)))) - (fundamental-stream - (cond ((characterp peek-type) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (char= char peek-type)) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - ((eq peek-type t) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (not (sb-int:whitespace-char-p char))) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - (t - (let ((char (sb-gray:stream-peek-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))))) - -(defun listen (&optional (stream *standard-input*) (width 1)) - "Returns T if Width octets are available on the given Stream. If Width - is given as 'character, check for a character." - ;; WIDTH is number of octets which must be available; any value - ;; other than 1 is treated as 'character. - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-listen stream width)) - (ansi-stream - (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream)) - sb-impl::+ansi-stream-in-buffer-length+) - ;; Test for T explicitly since misc methods return :EOF sometimes. - (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen) - t))) - (fundamental-stream - (sb-gray:stream-listen stream))))) - - -(defun read-line (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) - "Returns a line of text read from the Stream as a string, discarding the - newline character." - (declare (ignore recursive-p)) - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-read-line stream eof-error-p eof-value recursive-p)) - (ansi-stream - (%ansi-stream-read-line stream eof-error-p eof-value)) - (fundamental-stream - (multiple-value-bind (string eof) (sb-gray:stream-read-line stream) - (if (and eof (zerop (length string))) - (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) - (values string eof))))))) - -(defun read-sequence (seq stream &key (start 0) (end nil) partial-fill) - "Destructively modify SEQ by reading elements from STREAM. - SEQ is bounded by START and END. SEQ is destructively modified by - copying successive elements into it from STREAM. If the end of file - for STREAM is reached before copying all elements of the subsequence, - then the extra elements near the end of sequence are not updated, and - the index of the next element is returned." - (let ((stream (sb-impl::in-synonym-of stream)) - (end (or end (length seq)))) - (etypecase stream - (simple-stream - (with-stream-class (simple-stream stream) - (%simple-stream-read-sequence stream seq start end partial-fill))) - (ansi-stream - (%ansi-stream-read-sequence seq stream start end)) - (fundamental-stream - (sb-gray:stream-read-sequence stream seq start end))))) - -(defun clear-input (&optional (stream *standard-input*) buffer-only) - "Clears any buffered input associated with the Stream." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-clear-input stream buffer-only)) - (ansi-stream - (setf (sb-kernel:ansi-stream-in-index stream) - sb-impl::+ansi-stream-in-buffer-length+) - (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input)) - (fundamental-stream - (sb-gray:stream-clear-input stream)))) - nil) - -(defun write-byte (integer stream) - "Outputs an octet to the Stream." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-write-byte stream integer)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-bout stream) stream integer)) - (fundamental-stream - (sb-gray:stream-write-byte stream integer)))) - integer) - -(defun write-char (character &optional (stream *standard-output*)) - "Outputs the Character to the Stream." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-write-char stream character)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-out stream) stream character)) - (fundamental-stream - (sb-gray:stream-write-char stream character)))) - character) - -(defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end nil)) - "Outputs the String to the given Stream." - (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length string)))) - (etypecase stream - (simple-stream - (%simple-stream-write-string stream string start end) - string) - (ansi-stream - (%ansi-stream-write-string string stream start end)) - (fundamental-stream - (sb-gray:stream-write-string stream string start end))))) - -(defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) - (declare (type string string)) - ;; FIXME: Why is there this difference between the treatments of the - ;; STREAM argument in WRITE-STRING and WRITE-LINE? - (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length string)))) - (etypecase stream - (simple-stream - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-chars string stream start end) - (funcall-stm-handler-2 j-write-char #\Newline stream))) - (ansi-stream - (%ansi-stream-write-string string stream start end) - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) - (fundamental-stream - (sb-gray:stream-write-string stream string start end) - (sb-gray:stream-terpri stream)))) - string) - -(defun write-sequence (seq stream &key (start 0) (end nil)) - "Write the elements of SEQ bounded by START and END to STREAM." - (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length seq)))) - (etypecase stream - (simple-stream - (%simple-stream-write-sequence stream seq start end)) - (ansi-stream - (%ansi-stream-write-sequence seq stream start end)) - (fundamental-stream - (sb-gray:stream-write-sequence stream seq start end))))) - -(defun terpri (&optional (stream *standard-output*)) - "Outputs a new line to the Stream." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%check-simple-stream stream :output) - (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-char #\Newline stream))) - (ansi-stream - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) - (fundamental-stream - (sb-gray:stream-terpri stream)))) - nil) - -(defun fresh-line (&optional (stream *standard-output*)) - "Outputs a new line to the Stream if it is not positioned at the beginning of - a line. Returns T if it output a new line, nil otherwise." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-fresh-line stream)) - (ansi-stream - (when (/= (or (sb-kernel:charpos stream) 1) 0) - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline) - t)) - (fundamental-stream - (sb-gray:stream-fresh-line stream))))) - -(defun finish-output (&optional (stream *standard-output*)) - "Attempts to ensure that all output sent to the Stream has reached its - destination, and only then returns." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-finish-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output)) - (fundamental-stream - (sb-gray:stream-finish-output stream)))) - nil) - -(defun force-output (&optional (stream *standard-output*)) - "Attempts to force any buffered output to be sent." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-force-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output)) - (fundamental-stream - (sb-gray:stream-force-output stream)))) - nil) - -(defun clear-output (&optional (stream *standard-output*)) - "Clears the given output Stream." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%simple-stream-clear-output stream)) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output)) - (fundamental-stream - (sb-gray:stream-clear-output stream)))) - nil) - - -(defun file-position (stream &optional position) - "With one argument returns the current position within the file - File-Stream is open to. If the second argument is supplied, then - this becomes the new file position. The second argument may also - be :start or :end for the start and end of the file, respectively." - (declare (type (or (integer 0 *) (member nil :start :end)) position)) - (etypecase stream - (simple-stream - (%simple-stream-file-position stream position)) - (ansi-stream - (cond - (position - (setf (sb-kernel:ansi-stream-in-index stream) - sb-impl::+ansi-stream-in-buffer-length+) - (funcall (sb-kernel:ansi-stream-misc stream) - stream :file-position position)) - (t - (let ((res (funcall (sb-kernel:ansi-stream-misc stream) - stream :file-position nil))) - (when res - (- res - (- sb-impl::+ansi-stream-in-buffer-length+ - (sb-kernel:ansi-stream-in-index stream)))))))))) - -(defun file-length (stream) - "This function returns the length of the file that File-Stream is open to." - (etypecase stream - (simple-stream - (%simple-stream-file-length stream)) - (ansi-stream - (progn (sb-impl::stream-must-be-associated-with-file stream) - (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))) - -(defun charpos (&optional (stream *standard-output*)) - "Returns the number of characters on the current line of output of the given - Stream, or Nil if that information is not availible." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%check-simple-stream stream :output) - (with-stream-class (simple-stream) (sm charpos stream))) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos)) - (fundamental-stream - (sb-gray:stream-line-column stream))))) - -(defun line-length (&optional (stream *standard-output*)) - "Returns the number of characters in a line of output of the given - Stream, or Nil if that information is not availible." - (let ((stream (sb-impl::out-synonym-of stream))) - (etypecase stream - (simple-stream - (%check-simple-stream stream :output) - ;; TODO (sat 2003-04-02): a way to specify a line length would - ;; be good, I suppose. Returning nil here means - ;; sb-pretty::default-line-length is used. - nil) - (ansi-stream - (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length)) - (fundamental-stream - (sb-gray:stream-line-length stream))))) - -(defun wait-for-input-available (stream &optional timeout) - "Waits for input to become available on the Stream and returns T. If - Timeout expires, Nil is returned." - (let ((stream (sb-impl::in-synonym-of stream))) - (etypecase stream - (fixnum - (sb-sys:wait-until-fd-usable stream :input timeout)) - (simple-stream - (%check-simple-stream stream :input) - (with-stream-class (simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (wait-for-input-available (sm input-handle stream) timeout)))) - (two-way-stream - (wait-for-input-available (two-way-stream-input-stream stream) timeout)) - (synonym-stream - (wait-for-input-available (symbol-value (synonym-stream-symbol stream)) - timeout)) - (sb-sys::file-stream - (or (< (sb-impl::fd-stream-in-index stream) - (length (sb-impl::fd-stream-in-buffer stream))) - (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) - -;; Make PATHNAME and NAMESTRING work -(defun sb-int:file-name (stream &optional new-name) - (typecase stream - (file-simple-stream - (with-stream-class (file-simple-stream stream) - (cond (new-name - (%simple-stream-file-rename stream new-name)) - (t - (%simple-stream-file-name stream))))) - (sb-sys::file-stream - (cond (new-name - (setf (sb-impl::fd-stream-pathname stream) new-name) - (setf (sb-impl::fd-stream-file stream) - (sb-int:unix-namestring new-name nil)) - t) - (t - (sb-impl::fd-stream-pathname stream)))))) - -;;; bugfix - -;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or -;;; remove it. -#+nil -(defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type fundamental-stream stream) ;; this is a lie - (ignore arg2)) - (case operation - (:listen - (ext:stream-listen stream)) - (:unread - (ext:stream-unread-char stream arg1)) - (:close - (close stream)) - (:clear-input - (ext:stream-clear-input stream)) - (:force-output - (ext:stream-force-output stream)) - (:finish-output - (ext:stream-finish-output stream)) - (:element-type - (stream-element-type stream)) - (:interactive-p - (interactive-stream-p stream)) - (:line-length - (ext:stream-line-length stream)) - (:charpos - (ext:stream-line-column stream)) - (:file-length - (file-length stream)) - (:file-position - (file-position stream arg1)))) diff --git a/contrib/sb-simple-streams/simple-streams.lisp b/contrib/sb-simple-streams/simple-streams.lisp deleted file mode 100644 index 4caf28a..0000000 --- a/contrib/sb-simple-streams/simple-streams.lisp +++ /dev/null @@ -1,801 +0,0 @@ -;;; -*- 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") - -;;; -;;; SETUP -;;; - -(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))) - -;;; From the simple-streams documentation: "A generic function implies -;;; a specialization capability that does not exist for -;;; simple-streams; simple-stream specializations should be on -;;; device-close." So don't do it. -(defmethod close ((stream simple-stream) &key abort) - (device-close stream abort)) - - -;;; 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) - (if abort - (clear-output stream) - (force-output stream))) - (call-next-method) - (setf (sm input-handle stream) nil - (sm output-handle stream) nil - (sm j-listen stream) #'sb-kernel::closed-flame - (sm j-read-char stream) #'sb-kernel::closed-flame - (sm j-read-chars stream) #'sb-kernel::closed-flame - (sm j-unread-char stream) #'sb-kernel::closed-flame - (sm j-write-char stream) #'sb-kernel::closed-flame ;@@ - (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@ - (remove-stream-instance-flags stream :input :output) - (sb-ext:cancel-finalization stream)))) - -;;; -;;; Stream printing -;;; - -(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)))) - -(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 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)) - -(defun find-external-format (name) - nil) - -;;; -;;; LOW LEVEL STUFF -;;; - -(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))) - -(defun endian-swap-value (vector endian-swap) - (case endian-swap - (:network-order (1- (vector-elt-width vector))) - (: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.")) - ;; FIXME: implement blocking/non-blocking semantics here as well - (read-sequence vector stream :start (or start 0) :end end)))) - -#|(defun write-vector ...)|# - -(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 - ;; 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))))))))))) - ;; Handle encapsulated stream. FIXME: perhaps handle - ;; sbcl-vintage ansi-stream type in read-octets too? - (stream (read-octets fd buffer start end blocking)) - (t (error "Don't know how to handle input handle ~S" fd)))))) - -(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 *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))))))))))) - ;; Handle encapsulated stream. FIXME: perhaps handle - ;; sbcl-vintage ansi-stream type in write-octets too? - (stream (write-octets fd buffer start end blocking)) - (t (error "Don't know how to handle output handle ~A" fd)))))) - - -;;; -;;; IMPLEMENTATIONS -;;; - - -;;; simple-stream, dual-channel-simple-stream, -;;; single-channel-simple-stream - -(defmethod device-buffer-length ((stream simple-stream)) - 4096) - -(defmethod device-file-position ((stream simple-stream)) - (with-stream-class (simple-stream stream) - (cond ((any-stream-instance-flags stream :dual) - (with-stream-class (dual-channel-simple-stream stream) - (sm buffpos stream))) - ((any-stream-instance-flags stream :string) - (with-stream-class (string-simple-stream stream) - (sm buffpos stream))) - (t - (with-stream-class (single-channel-simple-stream stream) - (sm buffpos stream)))))) - - -(defmethod (setf device-file-position) (value (stream simple-stream)) - (with-stream-class (simple-stream stream) - (cond ((any-stream-instance-flags stream :dual) - (with-stream-class (dual-channel-simple-stream stream) - (setf (sm buffpos stream) value))) - ((any-stream-instance-flags stream :string) - (with-stream-class (string-simple-stream stream) - (setf (sm buffpos stream) value))) - (t - (with-stream-class (single-channel-simple-stream stream) - (setf (sm buffpos stream) value)))))) - -(defmethod device-file-length ((stream simple-stream)) - nil) - -(defmethod device-read ((stream single-channel-simple-stream) buffer - start end blocking) - ;; rudi (2003-06-07): this block commented out in Paul Foley's code -;; (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-clear-input ((stream simple-stream) buffer-only) - (declare (ignore buffer-only)) - nil) - -(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)))) - (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)))) - (write-octets stream buffer start end blocking)) - -(defmethod device-clear-output ((stream simple-stream)) - nil) - - -;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream - -(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) - - -;;; Definition of File-Simple-Stream and relations - -(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 (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*)) - (let ((efmt (getf options :external-format :default))) - (compose-encapsulating-streams stream efmt) - (install-single-channel-character-strategy stream efmt nil))))) - -(defmethod device-close ((stream file-simple-stream) abort) - (with-stream-class (file-simple-stream stream) - (cond (abort - ;; TODO: - ;; Remove any fd-handler - ;; If it's an output stream and has an original name, - ;; revert the file - ) - (t - ;; TODO: - ;; 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-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 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-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)))) - (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. - (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) - (install-single-channel-character-strategy - stream (getf options :external-format :default) '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)) - (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) - - -;;; Definition of Null-Simple-Stream - - -(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)) - - -;;; Socket-Simple-Stream and relatives - - -(defmethod device-open ((stream socket-base-simple-stream) options) - #| do something |# - stream) - -(defmethod device-open ((stream socket-simple-stream) options) - (with-stream-class (socket-simple-stream stream) - (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))) - (setf (sm socket stream) socket) - (sb-bsd-sockets:socket-connect socket remote-host remote-port) - (let ((fd (sb-bsd-sockets:socket-file-descriptor socket))) - ;; Connect stream to socket, ... - (setf (sm input-handle stream) fd) - (setf (sm output-handle stream) fd) - ;; ... and socket to stream. - (setf (slot-value socket 'stream) stream) - (sb-ext:cancel-finalization socket) - (sb-ext:finalize stream - (lambda () - (sb-unix:unix-close fd) - (format *terminal-io* - "~&;;; ** closed socket (fd ~D)~%" fd)))) - ;; Now frob the stream slots. FIXME: should we handle a - ;; :direction arg from output, defaulting to :input only? - (add-stream-instance-flags stream :simple :input :output :dual) - (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))) - (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-in stream) *terminal-control-in-table*) - (setf (sm control-out stream) *std-control-out-table*) - (install-dual-channel-character-strategy - stream (getf options :external-format :default))) - stream)) - -(defmethod device-close ((stream socket-simple-stream) abort) - ;; Abort argument is handled by :around method on base class - (declare (ignore abort)) - (with-stream-class (socket-simple-stream stream) - (sb-unix:unix-close (sm input-handle stream)) - (setf (sm buffer stream) nil) - (setf (sm out-buffer stream) nil)) - (sb-ext:cancel-finalization stream) - t) - - -;;; String-Simple-Stream and relatives - - -(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-length ((stream string-simple-stream)) - ;; return string length - ) - -(defmethod device-open :before ((stream string-input-simple-stream) options) - (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) - (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-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-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?) - ) - - -;;; Terminal-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 :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))) - ;; TODO (rudi 2003-06-08): when neither input-handle nor - ;; output-handle are given, close the stream again. - #| do something |# - 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) - ) - -(defmethod device-close ((stream simple-stream) abort) - (declare (ignore abort)) - t) - - - - - - - - - - - -(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) - ) - - - -(defmethod device-write ((stream socket-base-simple-stream) buffer - start end blocking) - ;; @@2 - (call-next-method)) - - - - - - - - -;; device-finish-record apparently has no methods defined - - -;;; -;;; IMPLEMENTATIONS FOR FOREIGN STREAMS -;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM) -;;; - - -;;; -;;; CREATION OF STANDARD STREAMS -;;; -