← Back to branch summary

~ubuntu-branches/ubuntu/hardy/cl-kmrcl/hardy

« back to all changes in this revision

Viewing changes to byte-stream.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Kevin M. Rosenberg
  • Date: 2007-09-18 23:54:44 UTC
  • mfrom: (1.1.8 upstream)
  • Revision ID: james.westby@ubuntu.com-20070918235444-5wdl38udmwy6bdd1
Tags: 1.97-1
New upstream

Show diffs side-by-side

added added

removed removed

Lines of Context:
byte-stream.lisp
7
7
;;;; Programmer:    Kevin M. Rosenberg
8
8
;;;; Date Started:  June 2003
9
9
;;;;
10
 
;;;; $Id: byte-stream.lisp 10390 2005-04-06 17:40:37Z kevin $
 
10
;;;; $Id$
11
11
;;;;
12
12
;;;; Works for CMUCL, SBCL, and AllergoCL only
13
13
;;;;
26
26
#+sbcl
27
27
(eval-when (:compile-toplevel :load-toplevel :execute)
28
28
  (when (sb-ext:without-package-locks
29
 
            (sb-pcl::structure-class-p
30
 
             (find-class (intern "FILE-STREAM" "SB-IMPL"))))
 
29
            (sb-pcl::structure-class-p
 
30
             (find-class (intern "FILE-STREAM" "SB-IMPL"))))
31
31
    (push :old-sb-file-stream cl:*features*)))
32
32
 
33
33
#+(or cmu sbcl)
34
34
(progn
35
35
(defstruct (byte-array-output-stream
36
36
             (:include #+cmu system:lisp-stream
37
 
                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
38
 
                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
 
37
                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
 
38
                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
39
39
                       (bout #'byte-array-bout)
40
40
                       (misc #'byte-array-out-misc))
41
41
             (:print-function %print-byte-array-output-stream)
55
55
 
56
56
(defun byte-array-bout (stream byte)
57
57
  (let ((current (byte-array-output-stream-index stream))
58
 
        (workspace (byte-array-output-stream-buffer stream)))
 
58
        (workspace (byte-array-output-stream-buffer stream)))
59
59
    (if (= current (length workspace))
60
 
        (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
61
 
          (replace new-workspace workspace)
62
 
          (setf (aref new-workspace current) byte)
63
 
          (setf (byte-array-output-stream-buffer stream) new-workspace))
64
 
        (setf (aref workspace current) byte))
 
60
        (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
 
61
          (replace new-workspace workspace)
 
62
          (setf (aref new-workspace current) byte)
 
63
          (setf (byte-array-output-stream-buffer stream) new-workspace))
 
64
        (setf (aref workspace current) byte))
65
65
    (setf (byte-array-output-stream-index stream) (1+ current))))
66
66
 
67
67
(defun byte-array-out-misc (stream operation &optional arg1 arg2)
69
69
  (case operation
70
70
    (:file-position
71
71
     (if (null arg1)
72
 
         (byte-array-output-stream-index stream)))
 
72
         (byte-array-output-stream-index stream)))
73
73
    (:element-type '(unsigned-byte 8))))
74
74
 
75
75
(defun get-output-stream-data (stream)
77
77
Make-Byte-Array-Output-Stream since the last call to this function and
78
78
clears buffer."
79
79
  (declare (type byte-array-output-stream stream))
80
 
    (prog1 
81
 
        (dump-output-stream-data stream)
 
80
    (prog1
 
81
        (dump-output-stream-data stream)
82
82
      (setf (byte-array-output-stream-index stream) 0)))
83
83
 
84
84
(defun dump-output-stream-data (stream)
86
86
Make-Byte-Array-Output-Stream since the last call to this function."
87
87
  (declare (type byte-array-output-stream stream))
88
88
  (let* ((length (byte-array-output-stream-index stream))
89
 
         (result (make-array length :element-type '(unsigned-byte 8))))
 
89
         (result (make-array length :element-type '(unsigned-byte 8))))
90
90
    (replace result (byte-array-output-stream-buffer stream))
91
91
    result))
92
92
 
97
97
(eval-when (:compile-toplevel :load-toplevel :execute)
98
98
  (sb-ext:without-package-locks
99
99
      (defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL"))
100
 
                                   (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
101
 
                                   (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
 
100
                                   (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
 
101
                                   (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
102
102
    (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
103
 
                                              sb-vm:n-byte-bits
104
 
                                         1))))
105
 
  
 
103
                                              sb-vm:n-byte-bits
 
104
                                         1))))
 
105
 
106
106
#+(or cmu sbcl)
107
107
(progn
108
108
  (defstruct (byte-array-input-stream
109
 
             (:include #+cmu system:lisp-stream
110
 
                       ;;#+sbcl sb-impl::file-stream
111
 
                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
112
 
                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
113
 
                       (in #'byte-array-inch)
114
 
                       (bin #'byte-array-binch)
115
 
                       (n-bin #'byte-array-stream-read-n-bytes)
116
 
                       (misc #'byte-array-in-misc))
117
 
             (:print-function %print-byte-array-input-stream)
118
 
                                        ;(:constructor nil)
119
 
             (:constructor internal-make-byte-array-input-stream
120
 
                           (byte-array current end)))
 
109
             (:include #+cmu system:lisp-stream
 
110
                       ;;#+sbcl sb-impl::file-stream
 
111
                       #+(and sbcl old-sb-file-stream) sb-impl::file-stream
 
112
                       #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
 
113
                       (in #'byte-array-inch)
 
114
                       (bin #'byte-array-binch)
 
115
                       (n-bin #'byte-array-stream-read-n-bytes)
 
116
                       (misc #'byte-array-in-misc))
 
117
             (:print-function %print-byte-array-input-stream)
 
118
                                        ;(:constructor nil)
 
119
             (:constructor internal-make-byte-array-input-stream
 
120
                           (byte-array current end)))
121
121
  (byte-array nil :type vector)
122
122
  (current nil)
123
123
  (end nil))
124
124
 
125
 
  
 
125
 
126
126
(defun %print-byte-array-input-stream (s stream d)
127
127
  (declare (ignore s d))
128
128
  (write-string "#<Byte-Array-Input Stream>" stream))
129
129
 
130
130
(defun byte-array-inch (stream eof-errorp eof-value)
131
131
  (let ((byte-array (byte-array-input-stream-byte-array stream))
132
 
        (index (byte-array-input-stream-current stream)))
 
132
        (index (byte-array-input-stream-current stream)))
133
133
    (cond ((= index (byte-array-input-stream-end stream))
134
 
           #+cmu
135
 
           (eof-or-lose stream eof-errorp eof-value)
136
 
           #+sbcl
137
 
           (sb-impl::eof-or-lose stream eof-errorp eof-value)
138
 
           )
139
 
          (t
140
 
           (setf (byte-array-input-stream-current stream) (1+ index))
141
 
           (aref byte-array index)))))
 
134
           #+cmu
 
135
           (eof-or-lose stream eof-errorp eof-value)
 
136
           #+sbcl
 
137
           (sb-impl::eof-or-lose stream eof-errorp eof-value)
 
138
           )
 
139
          (t
 
140
           (setf (byte-array-input-stream-current stream) (1+ index))
 
141
           (aref byte-array index)))))
142
142
 
143
143
(defun byte-array-binch (stream eof-errorp eof-value)
144
144
  (let ((byte-array (byte-array-input-stream-byte-array stream))
145
 
        (index (byte-array-input-stream-current stream)))
 
145
        (index (byte-array-input-stream-current stream)))
146
146
    (cond ((= index (byte-array-input-stream-end stream))
147
 
           #+cmu
148
 
           (eof-or-lose stream eof-errorp eof-value)
149
 
           #+sbcl
150
 
           (sb-impl::eof-or-lose stream eof-errorp eof-value)
151
 
           )
152
 
          (t
153
 
           (setf (byte-array-input-stream-current stream) (1+ index))
154
 
           (aref byte-array index)))))
 
147
           #+cmu
 
148
           (eof-or-lose stream eof-errorp eof-value)
 
149
           #+sbcl
 
150
           (sb-impl::eof-or-lose stream eof-errorp eof-value)
 
151
           )
 
152
          (t
 
153
           (setf (byte-array-input-stream-current stream) (1+ index))
 
154
           (aref byte-array index)))))
155
155
 
156
156
(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp)
157
157
  (declare (type byte-array-input-stream stream))
158
158
  (let* ((byte-array (byte-array-input-stream-byte-array stream))
159
 
         (index (byte-array-input-stream-current stream))
160
 
         (available (- (byte-array-input-stream-end stream) index))
161
 
         (copy (min available requested)))
 
159
         (index (byte-array-input-stream-current stream))
 
160
         (available (- (byte-array-input-stream-end stream) index))
 
161
         (copy (min available requested)))
162
162
    (when (plusp copy)
163
163
      (setf (byte-array-input-stream-current stream)
164
 
        (+ index copy))
 
164
        (+ index copy))
165
165
      #+cmu
166
166
      (system:without-gcing
167
167
       (system::system-area-copy (system:vector-sap byte-array)
168
 
                         (* index vm:byte-bits)
169
 
                         (if (typep buffer 'system::system-area-pointer)
170
 
                             buffer
171
 
                             (system:vector-sap buffer))
172
 
                         (* start vm:byte-bits)
173
 
                         (* copy vm:byte-bits)))
 
168
                         (* index vm:byte-bits)
 
169
                         (if (typep buffer 'system::system-area-pointer)
 
170
                             buffer
 
171
                             (system:vector-sap buffer))
 
172
                         (* start vm:byte-bits)
 
173
                         (* copy vm:byte-bits)))
174
174
      #+sbcl
175
175
      (sb-sys:without-gcing
176
176
       (funcall *system-copy-fn* (sb-sys:vector-sap byte-array)
177
 
                         (* index +system-copy-multiplier+)
178
 
                         (if (typep buffer 'sb-sys::system-area-pointer)
179
 
                             buffer
180
 
                             (sb-sys:vector-sap buffer))
181
 
                         (* start +system-copy-multiplier+)
182
 
                         (* copy +system-copy-multiplier+))))
 
177
                         (* index +system-copy-multiplier+)
 
178
                         (if (typep buffer 'sb-sys::system-area-pointer)
 
179
                             buffer
 
180
                             (sb-sys:vector-sap buffer))
 
181
                         (* start +system-copy-multiplier+)
 
182
                         (* copy +system-copy-multiplier+))))
183
183
    (if (and (> requested copy) eof-errorp)
184
 
        (error 'end-of-file :stream stream)
185
 
        copy)))
 
184
        (error 'end-of-file :stream stream)
 
185
        copy)))
186
186
 
187
187
(defun byte-array-in-misc (stream operation &optional arg1 arg2)
188
188
  (declare (ignore arg2))
189
189
  (case operation
190
190
    (:file-position
191
191
     (if arg1
192
 
         (setf (byte-array-input-stream-current stream) arg1)
193
 
         (byte-array-input-stream-current stream)))
 
192
         (setf (byte-array-input-stream-current stream) arg1)
 
193
         (byte-array-input-stream-current stream)))
194
194
    (:file-length (length (byte-array-input-stream-byte-array stream)))
195
195
    (:unread (decf (byte-array-input-stream-current stream)))
196
196
    (:listen (or (/= (the fixnum (byte-array-input-stream-current stream))
197
 
                     (the fixnum (byte-array-input-stream-end stream)))
198
 
                 :eof))
 
197
                     (the fixnum (byte-array-input-stream-end stream)))
 
198
                 :eof))
199
199
    (:element-type 'base-char)))
200
 
  
 
200
 
201
201
(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer)))
202
202
  "Returns an input stream which will supply the bytes of BUFFER between
203
203
  Start and End in order."
228
228
    "Returns an array of all data sent to a stream made by
229
229
Make-Byte-Array-Output-Stream since the last call to this function
230
230
and clears buffer."
231
 
    (prog1 
232
 
        (dump-output-stream-data stream)
 
231
    (prog1
 
232
        (dump-output-stream-data stream)
233
233
      (file-position stream 0)))
234
 
  
 
234
 
235
235
  (defun dump-output-stream-data (stream)
236
236
    "Returns an array of all data sent to a stream made by
237
237
Make-Byte-Array-Output-Stream since the last call to this function."
238
238
    (force-output stream)
239
239
    (let* ((length (file-position stream))
240
 
           (result (make-array length :element-type '(unsigned-byte 8))))
 
240
           (result (make-array length :element-type '(unsigned-byte 8))))
241
241
      (replace result (slot-value stream 'excl::buffer))
242
242
      result))
243
 
  
244
 
  (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
245
 
                                 need action)
246
 
    (declare (ignore action))
247
 
    (let* ((len (file-position stream))
248
 
           (new-len (max (+ len need) (* 2 len)))
249
 
           (old-buf (slot-value stream 'excl::buffer))
250
 
           (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
251
 
      (declare (fixnum len)
252
 
               (optimize (speed 3) (safety 0)))
253
 
      (dotimes (i len)
254
 
        (setf (aref new-buf i) (aref old-buf i)))
255
 
      (setf (slot-value stream 'excl::buffer) new-buf)
256
 
      (setf (slot-value stream 'excl::buffer-ptr) new-len)
257
 
      )
258
 
    t)
259
 
  
 
243
 
 
244
  (excl::without-package-locks
 
245
   (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
 
246
                                  need action)
 
247
     (declare (ignore action))
 
248
     (let* ((len (file-position stream))
 
249
            (new-len (max (+ len need) (* 2 len)))
 
250
            (old-buf (slot-value stream 'excl::buffer))
 
251
            (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
 
252
       (declare (fixnum len)
 
253
                (optimize (speed 3) (safety 0)))
 
254
       (dotimes (i len)
 
255
         (setf (aref new-buf i) (aref old-buf i)))
 
256
       (setf (slot-value stream 'excl::buffer) new-buf)
 
257
       (setf (slot-value stream 'excl::buffer-ptr) new-len)
 
258
       )
 
259
     t))
 
260
 
260
261
)
261
262
 
262
263
#+allegro
263
264
(progn
264
265
  (defun make-byte-array-input-stream (buffer &optional (start 0)
265
 
                                                        (end (length buffer)))
 
266
                                                        (end (length buffer)))
266
267
    (excl:make-buffer-input-stream buffer start end :octets))
267
268
  ) ;; progn
268
269