;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: June 2003
;;;;
-;;;; $Id: byte-stream.lisp,v 1.1 2003/07/05 02:32:08 kevin Exp $
+;;;; $Id$
;;;;
;;;; Works for CMUCL, SBCL, and AllergoCL only
;;;;
(in-package #:kmrcl)
+;; Intial CMUCL version by OnShored. Ported to SBCL by Kevin Rosenberg
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (when (sb-ext:without-package-locks
+ (sb-pcl::structure-class-p
+ (find-class (intern "FILE-STREAM" "SB-IMPL"))))
+ (push :old-sb-file-stream cl:*features*)))
+
#+(or cmu sbcl)
(progn
(defstruct (byte-array-output-stream
(:include #+cmu system:lisp-stream
- #+sbcl sb-impl::file-stream
+ #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+ #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
(bout #'byte-array-bout)
(misc #'byte-array-out-misc))
(:print-function %print-byte-array-output-stream)
) ; progn
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (sb-ext:without-package-locks
+ (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL"))
+ (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
+ (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
+ (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
+ sb-vm:n-byte-bits
+ 1))))
+
#+(or cmu sbcl)
(progn
(defstruct (byte-array-input-stream
(:include #+cmu system:lisp-stream
- #+sbcl sb-impl::file-stream
+ ;;#+sbcl sb-impl::file-stream
+ #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+ #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
(in #'byte-array-inch)
(bin #'byte-array-binch)
(n-bin #'byte-array-stream-read-n-bytes)
(current nil)
(end nil))
+
(defun %print-byte-array-input-stream (s stream d)
(declare (ignore s d))
(write-string "#<Byte-Array-Input Stream>" stream))
-
+
(defun byte-array-inch (stream eof-errorp eof-value)
(let ((byte-array (byte-array-input-stream-byte-array stream))
(index (byte-array-input-stream-current stream)))
(cond ((= index (byte-array-input-stream-end stream))
- (eof-or-lose stream eof-errorp eof-value))
+ #+cmu
+ (eof-or-lose stream eof-errorp eof-value)
+ #+sbcl
+ (sb-impl::eof-or-lose stream eof-errorp eof-value)
+ )
(t
(setf (byte-array-input-stream-current stream) (1+ index))
(aref byte-array index)))))
(let ((byte-array (byte-array-input-stream-byte-array stream))
(index (byte-array-input-stream-current stream)))
(cond ((= index (byte-array-input-stream-end stream))
- (eof-or-lose stream eof-errorp eof-value))
+ #+cmu
+ (eof-or-lose stream eof-errorp eof-value)
+ #+sbcl
+ (sb-impl::eof-or-lose stream eof-errorp eof-value)
+ )
(t
(setf (byte-array-input-stream-current stream) (1+ index))
(aref byte-array index)))))
(* copy vm:byte-bits)))
#+sbcl
(sb-sys:without-gcing
- (sb-kernel:system-area-copy (sb-sys:vector-sap byte-array)
- (* index sb-vm:n-byte-bits)
+ (funcall *system-copy-fn* (sb-sys:vector-sap byte-array)
+ (* index +system-copy-multiplier+)
(if (typep buffer 'sb-sys::system-area-pointer)
buffer
(sb-sys:vector-sap buffer))
- (* start sb-vm:n-byte-bits)
- (* copy sb-vm:n-byte-bits))))
+ (* start +system-copy-multiplier+)
+ (* copy +system-copy-multiplier+))))
(if (and (> requested copy) eof-errorp)
(error 'end-of-file :stream stream)
copy)))
) ;; progn
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq cl:*features* (delete :old-sb-file-stream cl:*features*)))
+
+;;; Simple streams implementation by Kevin Rosenberg
+
#+allegro
(progn
(defmethod excl:device-extend ((stream extendable-buffer-output-stream)
need action)
+ (declare (ignore action))
(let* ((len (file-position stream))
(new-len (max (+ len need) (* 2 len)))
(old-buf (slot-value stream 'excl::buffer))
(end (length buffer)))
(excl:make-buffer-input-stream buffer start end :octets))
) ;; progn
+
+