byte-stream.lisp

   1 ;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: kmrcl -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          byte-stream.lisp
   6 ;;;; Purpose:       Byte array input/output streams
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  June 2003
   9 ;;;;
  10 ;;;; $Id: byte-stream.lisp,v 1.1 2003/07/05 02:32:08 kevin Exp $
  11 ;;;;
  12 ;;;; Works for CMUCL, SBCL, and AllergoCL only
  13 ;;;;
  14 ;;;; This file, part of KMRCL, is Copyright (c) 2003 by Kevin M. Rosenberg
  15 ;;;; and by onShore Development, Inc.
  16 ;;;;
  17 ;;;; KMRCL users are granted the rights to distribute and use this software
  18 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  19 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  20 ;;;; *************************************************************************
  21
  22 (in-package #:kmrcl)
  23
  24 #+(or cmu sbcl)
  25 (progn
  26 (defstruct (byte-array-output-stream
  27              (:include #+cmu system:lisp-stream
  28                        #+sbcl sb-impl::file-stream
  29                        (bout #'byte-array-bout)
  30                        (misc #'byte-array-out-misc))
  31              (:print-function %print-byte-array-output-stream)
  32              (:constructor make-byte-array-output-stream ()))
  33   ;; The buffer we throw stuff in.
  34   (buffer (make-array 128 :element-type '(unsigned-byte 8)))
  35   ;; Index of the next location to use.
  36   (index 0 :type fixnum))
  37
  38 (defun %print-byte-array-output-stream (s stream d)
  39   (declare (ignore s d))
  40   (write-string "#<Byte-Array-Output Stream>" stream))
  41
  42 (setf (documentation 'make-binary-output-stream 'function)
  43   "Returns an Output stream which will accumulate all output given it for
  44    the benefit of the function Get-Output-Stream-Data.")
  45
  46 (defun byte-array-bout (stream byte)
  47   (let ((current (byte-array-output-stream-index stream))
  48         (workspace (byte-array-output-stream-buffer stream)))
  49     (if (= current (length workspace))
  50         (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
  51           (replace new-workspace workspace)
  52           (setf (aref new-workspace current) byte)
  53           (setf (byte-array-output-stream-buffer stream) new-workspace))
  54         (setf (aref workspace current) byte))
  55     (setf (byte-array-output-stream-index stream) (1+ current))))
  56
  57 (defun byte-array-out-misc (stream operation &optional arg1 arg2)
  58   (declare (ignore arg2))
  59   (case operation
  60     (:file-position
  61      (if (null arg1)
  62          (byte-array-output-stream-index stream)))
  63     (:element-type '(unsigned-byte 8))))
  64
  65 (defun get-output-stream-data (stream)
  66   "Returns an array of all data sent to a stream made by
  67 Make-Byte-Array-Output-Stream since the last call to this function and
  68 clears buffer."
  69   (declare (type byte-array-output-stream stream))
  70     (prog1
  71         (dump-output-stream-data stream)
  72       (setf (byte-array-output-stream-index stream) 0)))
  73
  74 (defun dump-output-stream-data (stream)
  75   "Returns an array of all data sent to a stream made by
  76 Make-Byte-Array-Output-Stream since the last call to this function."
  77   (declare (type byte-array-output-stream stream))
  78   (let* ((length (byte-array-output-stream-index stream))
  79          (result (make-array length :element-type '(unsigned-byte 8))))
  80     (replace result (byte-array-output-stream-buffer stream))
  81     result))
  82
  83 ) ; progn
  84
  85
  86 #+(or cmu sbcl)
  87 (progn
  88   (defstruct (byte-array-input-stream
  89              (:include #+cmu system:lisp-stream
  90                        #+sbcl sb-impl::file-stream
  91                        (in #'byte-array-inch)
  92                        (bin #'byte-array-binch)
  93                        (n-bin #'byte-array-stream-read-n-bytes)
  94                        (misc #'byte-array-in-misc))
  95              (:print-function %print-byte-array-input-stream)
  96                                         ;(:constructor nil)
  97              (:constructor internal-make-byte-array-input-stream
  98                            (byte-array current end)))
  99   (byte-array nil :type vector)
 100   (current nil)
 101   (end nil))
 102
 103 (defun %print-byte-array-input-stream (s stream d)
 104   (declare (ignore s d))
 105   (write-string "#<Byte-Array-Input Stream>" stream))
 106
 107 (defun byte-array-inch (stream eof-errorp eof-value)
 108   (let ((byte-array (byte-array-input-stream-byte-array stream))
 109         (index (byte-array-input-stream-current stream)))
 110     (cond ((= index (byte-array-input-stream-end stream))
 111            (eof-or-lose stream eof-errorp eof-value))
 112           (t
 113            (setf (byte-array-input-stream-current stream) (1+ index))
 114            (aref byte-array index)))))
 115
 116 (defun byte-array-binch (stream eof-errorp eof-value)
 117   (let ((byte-array (byte-array-input-stream-byte-array stream))
 118         (index (byte-array-input-stream-current stream)))
 119     (cond ((= index (byte-array-input-stream-end stream))
 120            (eof-or-lose stream eof-errorp eof-value))
 121           (t
 122            (setf (byte-array-input-stream-current stream) (1+ index))
 123            (aref byte-array index)))))
 124
 125 (defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp)
 126   (declare (type byte-array-input-stream stream))
 127   (let* ((byte-array (byte-array-input-stream-byte-array stream))
 128          (index (byte-array-input-stream-current stream))
 129          (available (- (byte-array-input-stream-end stream) index))
 130          (copy (min available requested)))
 131     (when (plusp copy)
 132       (setf (byte-array-input-stream-current stream)
 133         (+ index copy))
 134       #+cmu
 135       (system:without-gcing
 136        (system::system-area-copy (system:vector-sap byte-array)
 137                          (* index vm:byte-bits)
 138                          (if (typep buffer 'system::system-area-pointer)
 139                              buffer
 140                              (system:vector-sap buffer))
 141                          (* start vm:byte-bits)
 142                          (* copy vm:byte-bits)))
 143       #+sbcl
 144       (sb-sys:without-gcing
 145        (sb-kernel:system-area-copy (sb-sys:vector-sap byte-array)
 146                          (* index sb-vm:n-byte-bits)
 147                          (if (typep buffer 'sb-sys::system-area-pointer)
 148                              buffer
 149                              (sb-sys:vector-sap buffer))
 150                          (* start sb-vm:n-byte-bits)
 151                          (* copy sb-vm:n-byte-bits))))
 152     (if (and (> requested copy) eof-errorp)
 153         (error 'end-of-file :stream stream)
 154         copy)))
 155
 156 (defun byte-array-in-misc (stream operation &optional arg1 arg2)
 157   (declare (ignore arg2))
 158   (case operation
 159     (:file-position
 160      (if arg1
 161          (setf (byte-array-input-stream-current stream) arg1)
 162          (byte-array-input-stream-current stream)))
 163     (:file-length (length (byte-array-input-stream-byte-array stream)))
 164     (:unread (decf (byte-array-input-stream-current stream)))
 165     (:listen (or (/= (the fixnum (byte-array-input-stream-current stream))
 166                      (the fixnum (byte-array-input-stream-end stream)))
 167                  :eof))
 168     (:element-type 'base-char)))
 169
 170 (defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer)))
 171   "Returns an input stream which will supply the bytes of BUFFER between
 172   Start and End in order."
 173   (internal-make-byte-array-input-stream buffer start end))
 174
 175 ) ;; progn
 176
 177 #+allegro
 178 (progn
 179
 180   (defclass extendable-buffer-output-stream (excl:buffer-output-simple-stream)
 181     ()
 182     )
 183
 184   (defun make-byte-array-output-stream ()
 185     "Returns an Output stream which will accumulate all output given it for
 186    the benefit of the function Get-Output-Stream-Data."
 187     (make-instance 'extendable-buffer-output-stream
 188       :buffer (make-array 128 :element-type '(unsigned-byte 8))
 189       :external-form :octets))
 190
 191   (defun get-output-stream-data (stream)
 192     "Returns an array of all data sent to a stream made by
 193 Make-Byte-Array-Output-Stream since the last call to this function
 194 and clears buffer."
 195     (prog1
 196         (dump-output-stream-data stream)
 197       (file-position stream 0)))
 198
 199   (defun dump-output-stream-data (stream)
 200     "Returns an array of all data sent to a stream made by
 201 Make-Byte-Array-Output-Stream since the last call to this function."
 202     (force-output stream)
 203     (let* ((length (file-position stream))
 204            (result (make-array length :element-type '(unsigned-byte 8))))
 205       (replace result (slot-value stream 'excl::buffer))
 206       result))
 207
 208   (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
 209                                  need action)
 210     (let* ((len (file-position stream))
 211            (new-len (max (+ len need) (* 2 len)))
 212            (old-buf (slot-value stream 'excl::buffer))
 213            (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
 214       (declare (fixnum len)
 215                (optimize (speed 3) (safety 0)))
 216       (dotimes (i len)
 217         (setf (aref new-buf i) (aref old-buf i)))
 218       (setf (slot-value stream 'excl::buffer) new-buf)
 219       (setf (slot-value stream 'excl::buffer-ptr) new-len)
 220       )
 221     t)
 222
 223 )
 224
 225 #+allegro
 226 (progn
 227   (defun make-byte-array-input-stream (buffer &optional (start 0)
 228                                                         (end (length buffer)))
 229     (excl:make-buffer-input-stream buffer start end :octets))
 230   ) ;; progn