Changeset 5398


Ignore:
Timestamp:
Oct 22, 2006, 7:01:15 AM (18 years ago)
Author:
Gary Byers
Message:

Don't disable interrupts when calling ioblock functions.

New string-stream implementation. Better ...

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/level-1/l1-streams.lisp

    r5392 r5398  
    408408  (sharing nil)
    409409  (line-termination nil)
    410   (reserved1 nil)
     410  (unread-char-function 'ioblock-no-char-input)
    411411  (reserved2 nil)
    412412  (reserved3 nil))
    … …  
    26162616  (setf (ioblock-sharing ioblock) sharing)
    26172617  (when character-p
     2618    (setf (ioblock-unread-char-function ioblock) '%ioblock-untyi)
    26182619    (if encoding
    26192620      (let* ((unit-size (character-encoding-code-unit-size encoding)))
    … …  
    36483649(defmethod stream-read-char ((s basic-character-input-stream))
    36493650  (let* ((ioblock (basic-stream-ioblock s)))
    3650     (declare (optimize (speed 3)))
    3651     (without-interrupts
    3652      (values
    3653       (funcall (ioblock-read-char-function ioblock) ioblock)))))
     3651    (funcall (ioblock-read-char-function ioblock) ioblock)))
    36543652
    36553653
    … …  
    36573655  (let* ((ioblock (basic-stream-ioblock stream)))
    36583656    (with-ioblock-input-locked (ioblock)
    3659       (locally (declare (optimize (speed 3)))
    3660         (without-interrupts
    3661          (values
    3662           (%ioblock-tyi-no-hang ioblock)))))))
     3657      (values
     3658          (%ioblock-tyi-no-hang ioblock)))))
    36633659       
    36643660(defmethod stream-peek-char ((stream basic-character-input-stream))
    36653661  (let* ((ioblock (basic-stream-ioblock stream)))
    36663662    (with-ioblock-input-locked (ioblock)
    3667       (locally (declare (optimize (speed 3)))
    3668         (without-interrupts
    3669          (values
    3670           (%ioblock-peek-char ioblock)))))))
     3663      (values
     3664       (funcall (ioblock-peek-char-function ioblock) ioblock)))))
    36713665
    36723666(defmethod stream-clear-input ((stream basic-character-input-stream))
    36733667  (let* ((ioblock (basic-stream-ioblock stream)))
    36743668    (with-ioblock-input-locked (ioblock)
    3675       (locally (declare (optimize (speed 3)))
    3676         (without-interrupts
    3677          (values
    3678           (%ioblock-clear-input ioblock)))))))
     3669      (values
     3670        (%ioblock-clear-input ioblock)))))
    36793671
    36803672(defmethod stream-unread-char ((s basic-character-input-stream) char)
    36813673  (let* ((ioblock (basic-stream-ioblock s)))
    36823674    (with-ioblock-input-locked (ioblock)
    3683       (locally (declare (optimize (speed 3)))
    3684         (without-interrupts
    3685          (values
    3686           (%ioblock-untyi ioblock char)))))))
     3675      (values
     3676       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))
    36873677
    36883678(defmethod stream-read-ivector ((s basic-character-input-stream)
    … …  
    36903680  (let* ((ioblock (basic-stream-ioblock s)))
    36913681    (with-ioblock-input-locked (ioblock)
    3692       (locally (declare (optimize (speed 3)))
    3693         (without-interrupts
    3694          (values
    3695           (%ioblock-character-in-ivect ioblock iv start nb)))))))
     3682      (values
     3683       (%ioblock-character-in-ivect ioblock iv start nb)))))
    36963684
    36973685(defmethod stream-read-vector ((stream basic-character-input-stream)
    … …  
    37023690    (let* ((ioblock (basic-stream-ioblock stream)))
    37033691      (with-ioblock-input-locked (ioblock)
    3704         (locally (declare (optimize (speed 3)))
    3705           (without-interrupts
    3706            (values
    3707             (funcall (ioblock-character-read-vector-function ioblock)
    3708                      ioblock vector start end))))))))
     3692        (values
     3693         (funcall (ioblock-character-read-vector-function ioblock)
     3694                  ioblock vector start end))))))
    37093695
    37103696(defmethod stream-read-line ((stream basic-character-input-stream))
    37113697  (let* ((ioblock (basic-stream-ioblock stream)))
    37123698    (with-ioblock-input-locked (ioblock)
    3713       (locally (declare (optimize (speed 3)))
    3714         (without-interrupts
    3715          (values
    3716           (funcall (ioblock-read-line-function ioblock) ioblock)))))))
     3699      (values
     3700       (funcall (ioblock-read-line-function ioblock) ioblock)))))
    37173701
    37183702                             
    … …  
    40994083
    41004084;;; String streams.
    4101 (defclass string-stream (fundamental-character-stream)
    4102     ((string :initarg :string :initform nil :reader %string-stream-string)))
    4103 
    4104 (defmethod string-stream-string ((s string-stream))
    4105   (or (%string-stream-string s)
    4106       (values (stream-is-closed s))))
    4107 
    4108 (defmethod open-stream-p ((s string-stream))
    4109   (not (null (%string-stream-string s))))
    4110 
    4111 (defmethod close  ((s string-stream) &key abort)
    4112   (declare (ignore abort))
    4113   (when (slot-value s 'string)
    4114     (setf (slot-value s 'string) nil)
    4115     t))
     4085(make-built-in-class 'string-stream 'basic-character-stream)
    41164086
    41174087(defmethod print-object ((s string-stream) out)
    … …  
    41194089    (unless (open-stream-p s)  (format out " ~s" :closed))))
    41204090
    4121 (defclass string-output-stream (string-stream fundamental-character-output-stream)
    4122     ((column :initform 0 :accessor %stream-column)))
    4123 
    4124 (defmethod stream-write-char ((s string-output-stream) c)
    4125   (if (eq c #\newline)
    4126     (setf (%stream-column s) 0)
    4127     (incf (%stream-column s)))
    4128   (vector-push-extend c (string-stream-string s)))
    4129 
    4130 (defmethod stream-position ((s string-output-stream) &optional newpos)
     4091(defstruct (string-stream-ioblock (:include ioblock))
     4092  string)
     4093
     4094(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
     4095  (index 0))
     4096
     4097(defglobal *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
     4098
     4099(defglobal *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))
     4100
     4101(defun %%make-string-output-stream (class string write-char-function write-string-function)
     4102  (let* ((stream (allocate-basic-stream class)))
     4103    (initialize-basic-stream stream :element-type 'character)
     4104    (let* ((ioblock (make-string-output-stream-ioblock
     4105                     :stream stream
     4106                     :device nil
     4107                     :string string
     4108                     :element-type 'character
     4109                     :write-char-function write-char-function
     4110                     :write-char-when-locked-function write-char-function
     4111                     :write-simple-string-function write-string-function
     4112                     :force-output-function #'false
     4113                     :close-function #'false)))
     4114      (setf (basic-stream.state stream) ioblock)
     4115      stream)))
     4116
     4117(declaim (inline %string-push-extend))
     4118(defun %string-push-extend (char string)
     4119  (let* ((fill (%svref string target::vectorH.logsize-cell))
     4120         (size (%svref string target::vectorH.physsize-cell)))
     4121    (declare (fixnum fill size))
     4122    (if (< fill size)
     4123      (multiple-value-bind (data offset) (array-data-and-offset string)
     4124        (declare (simple-string data) (fixnum offset))
     4125        (setf (schar data (the fixnum (+ offset fill))) char
     4126              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
     4127      (vector-push-extend char string))))
     4128             
     4129
     4130(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
     4131  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
     4132  (if (eql char #\Newline)
     4133    (setf (ioblock-charpos ioblock) 0)
     4134    (incf (ioblock-charpos ioblock)))
     4135  (%string-push-extend char (string-stream-ioblock-string ioblock)))
     4136
     4137(defmethod stream-force-output ((stream string-output-stream)) nil)
     4138
     4139(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
     4140  (let* ((end (+ start-char num-chars))
     4141         (nlpos (position #\Newline string :start start-char :end end :from-end t)))
     4142    (if nlpos
     4143      (setf (ioblock-charpos ioblock) (- end nlpos))
     4144      (incf (ioblock-charpos ioblock) num-chars))
     4145    (let* ((out (string-stream-ioblock-string ioblock)))
     4146      (do* ((n 0 (1+ n))
     4147            (i start-char (1+ i)))
     4148           ((= n num-chars) num-chars)
     4149        (%string-push-extend (schar string i) out)))))
     4150
     4151(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos)
    41314152  (let* ((string (string-stream-string s)))
    41324153    (if newpos
    … …  
    41404161    (array-total-size (string-stream-string s))))
    41414162
    4142 (defmethod stream-line-column ((s string-output-stream))
    4143   (%stream-column s))
    4144 
    4145 (defmethod stream-set-column ((s string-output-stream) new)
    4146   (setf (%stream-column s) new))
    4147 
     4163;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM.
    41484164(defun %make-string-output-stream (string)
    41494165  (unless (and (typep string 'string)
    41504166               (array-has-fill-pointer-p string))
    41514167    (error "~S must be a string with a fill pointer."))
    4152   (make-instance 'string-output-stream :string  string))
     4168  (%%make-string-output-stream *fill-pointer-string-output-stream-class* string 'fill-pointer-string-output-stream-ioblock-write-char 'fill-pointer-string-output-stream-ioblock-write-simple-string))
     4169
     4170(defun string-output-stream-ioblock-write-char (ioblock char)
     4171  (let* ((string (string-output-stream-ioblock-string ioblock))
     4172         (index (string-output-stream-ioblock-index ioblock))
     4173         (len (length string)))
     4174    (declare (simple-string string)
     4175             (fixnum index len))
     4176  (if (eql char #\Newline)
     4177    (setf (ioblock-charpos ioblock) 0)
     4178    (incf (ioblock-charpos ioblock)))
     4179  (if (= index len)
     4180      (let* ((newlen (+ len len))      ;non-zero !
     4181             (new (make-string newlen)))
     4182        (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
     4183        (setq string new)
     4184        (setf (string-output-stream-ioblock-string ioblock) new)))
     4185    (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))
     4186          (schar string index) char)))
     4187
     4188(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
     4189  (declare (simple-string string)
     4190           (fixnum start-char num-chars))
     4191  (let* ((out (string-output-stream-ioblock-string ioblock))
     4192         (index (string-output-stream-ioblock-index ioblock))
     4193         (len (length out))
     4194         (need (+ index num-chars)))
     4195    (declare (simple-string out)
     4196             (fixnum index len need))
     4197    (if (< len need)
     4198      (let* ((newlen (+ need need))
     4199             (new (make-string newlen)))
     4200        (declare (fixnum newlen))
     4201        (%copy-ivector-to-ivector out 0 new 0 (the fixnum (ash len 2)))
     4202        (setq out new)
     4203        (setf (string-output-stream-ioblock-string ioblock) new)))
     4204    (%copy-ivector-to-ivector string
     4205                              (the fixnum (ash start-char 2))
     4206                              out
     4207                              (the fixnum (ash index 2))
     4208                              (the fixnum (ash num-chars 2)))
     4209    (setf (string-output-stream-ioblock-index ioblock) need)
     4210    (let* ((end (+ start-char num-chars))
     4211           (nlpos (position #\newline string :start start-char :end end :from-end t)))
     4212      (declare (fixnum end))
     4213      (if nlpos
     4214        (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos))))
     4215        (incf (ioblock-charpos ioblock) num-chars)))
     4216    num-chars))
     4217
     4218(defmethod stream-position ((stream string-output-stream) &optional newpos)
     4219  (let* ((ioblock (basic-stream-ioblock stream)))
     4220    (if (null newpos)
     4221      (string-output-stream-ioblock-index ioblock)
     4222      (if (and (typep newpos 'fixnum)
     4223               (>= (the fixnum newpos) 0)
     4224               (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock))))
     4225        (setf (string-output-stream-ioblock-index ioblock) newpos)))))
     4226
     4227(defun make-simple-string-output-stream ()
     4228  (%%make-string-output-stream *string-output-stream-class*
     4229                               (make-string 10)
     4230                               'string-output-stream-ioblock-write-char
     4231                               'string-output-stream-ioblock-write-simple-string))
    41534232
    41544233(defun make-string-output-stream (&key (element-type 'character element-type-p))
    … …  
    41614240      (error "~S argument ~S is not a subtype of ~S."
    41624241             :element-type element-type 'character)))
    4163   (make-instance 'string-output-stream
    4164                  :string (make-array 10 :element-type 'base-char
    4165                                      :fill-pointer 0
    4166                                      :adjustable t)))
     4242  (make-simple-string-output-stream))
     4243
    41674244
    41684245;;;"Bounded" string output streams.
    4169 (defclass truncating-string-stream (string-output-stream)
    4170     ((truncated :initform nil)))
     4246(defglobal *truncating-string-output-stream-class* (make-built-in-class 'truncating-string-stream 'string-output-stream))
     4247
     4248(defun truncating-string-output-stream-ioblock-write-char (ioblock char)
     4249  (let* ((stream (ioblock-stream ioblock))
     4250         (string (string-output-stream-ioblock-string ioblock))
     4251         (index (string-output-stream-ioblock-index ioblock)))
     4252    (declare (fixnum index) (simple-string string))
     4253    (if (< index (the fixnum (length string)))
     4254      (progn
     4255        (setf (schar string index) char
     4256              (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index)))
     4257        (if (eql char #\Newline)
     4258          (setf (ioblock-charpos ioblock) 0)
     4259          (incf (ioblock-charpos ioblock))))
     4260      (setf (getf (basic-stream.info stream) :truncated) t))))
     4261
     4262(defun truncating-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
     4263  (let* ((stream (ioblock-stream ioblock)))
     4264  (do* ((n 0 (1+ n))
     4265        (i start-char (1+ i)))
     4266       ((= n num-chars) num-chars)
     4267    (truncating-string-output-stream-ioblock-write-char ioblock (schar string i))
     4268    (if (getf (basic-stream.info stream) :truncated)
     4269      (return n)))))
     4270
     4271(defun truncating-string-output-stream-truncated-p (stream)
     4272  (getf (basic-stream.info stream) :truncated))
    41714273
    41724274(defun make-truncating-string-stream (len)
    4173   (make-instance 'truncating-string-stream
    4174                  :string (make-array len
     4275  (%%make-string-output-stream *truncating-string-output-stream-class*
     4276                              (make-array len
    41754277                                     :element-type 'character
    41764278                                     :fill-pointer 0
    4177                                      :adjustable nil)))
    4178 
    4179 (defmethod stream-write-char ((s truncating-string-stream) char)
    4180   (or (vector-push char (string-stream-string s))
    4181       (setf (slot-value s 'truncated) t))
    4182   char)
    4183 
    4184 (defmethod stream-write-string ((stream truncating-string-stream)
    4185                                 string &optional (start 0) end)
    4186   (setq end (check-sequence-bounds string start end))
    4187   (locally (declare (fixnum start end))
    4188     (multiple-value-bind (vect offset) (array-data-and-offset string)
    4189       (declare (fixnum offset))
    4190       (unless (zerop offset)
    4191         (incf start offset)
    4192         (incf end offset))
    4193       (do* ((v (string-stream-string stream))
    4194             (i start (1+ i)))
    4195            ((= i end) string)
    4196         (declare (fixnum i))
    4197         (if (slot-value stream 'truncated)
    4198           (return string)
    4199           (or (vector-push (schar vect i) v)
    4200               (progn
    4201                 (setf (slot-value stream 'truncated) t)
    4202                 (return string))))))))
     4279                                     :adjustable nil)
     4280                               'truncating-string-output-stream-ioblock-write-char
     4281                               'truncating-string-output-stream-ioblock-write-simple-string))
     4282                               
    42034283
    42044284;;;One way to indent on newlines:
    42054285
    4206 (defclass indenting-string-output-stream (string-output-stream)
    4207     ((prefixchar :initform nil :initarg :prefixchar)
    4208      (indent :initform nil :initarg :indent :accessor indenting-string-output-stream-indent)))
    4209 
    4210 (defun make-indenting-string-output-stream (prefixchar indent)
    4211   (make-instance 'indenting-string-output-stream
    4212    :string (make-array 10
    4213                      :element-type 'character
    4214                      :fill-pointer 0
    4215                      :adjustable t)
    4216    :prefixchar prefixchar
    4217    :indent indent))
    4218 
    4219 (defmethod stream-write-char ((s indenting-string-output-stream) c)
    4220   (call-next-method)
    4221   (when (eq c #\newline)
    4222     (let* ((indent (slot-value s 'indent))
    4223            (prefixchar (slot-value s 'prefixchar))
    4224            (prefixlen 0))
     4286(defglobal *indenting-string-output-stream-class* (make-built-in-class 'indenting-string-output-stream 'string-output-stream))
     4287
     4288
     4289
     4290(defun indenting-string-stream-ioblock-write-char (ioblock c)
     4291  (string-output-stream-ioblock-write-char ioblock c)
     4292  (if (eql c #\newline)
     4293    (let* ((stream (ioblock-stream ioblock))
     4294           (info (basic-stream.info stream))
     4295           (indent (getf info 'indent))
     4296           (prefixlen 0)
     4297           (prefixchar (getf info 'prefixchar)))
    42254298      (when prefixchar
    42264299        (if (typep prefixchar 'character)
    42274300          (progn
    42284301            (setq prefixlen 1)
    4229             (call-next-method s prefixchar))
     4302            (string-output-stream-ioblock-write-char ioblock prefixchar))
    42304303          (dotimes (i (setq prefixlen (length prefixchar)))
    4231             (call-next-method s (schar prefixchar i)))))
     4304            (string-output-stream-ioblock-write-char ioblock (schar prefixchar i)))))
    42324305      (when indent
    42334306        (dotimes (i (the fixnum (- indent prefixlen)))
    4234           (call-next-method s #\Space)))))
     4307          (string-output-stream-ioblock-write-char ioblock #\Space)))))
    42354308  c)
    42364309
     4310(defun indenting-string-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
     4311  (do* ((n 0 (1+ n))
     4312        (i start-char (1+ i)))
     4313       ((= n num-chars) num-chars)
     4314    (indenting-string-stream-ioblock-write-char ioblock (schar string i))))
     4315
     4316(defun make-indenting-string-output-stream (prefixchar indent)
     4317  (let* ((stream (%%make-string-output-stream
     4318                   *indenting-string-output-stream-class*
     4319                  (make-string 10)
     4320                  'indenting-string-stream-ioblock-write-char
     4321                  'indenting-string-stream-ioblock-write-simple-string)))
     4322    (setf (getf (basic-stream.info stream) 'indent) indent
     4323          (getf (basic-stream.info stream) 'prefixchar) prefixchar)
     4324    stream))
     4325
     4326(defun (setf indenting-string-output-stream-indent) (new stream)
     4327  (if (and (typep stream 'basic-stream)
     4328           (eq (basic-stream.class stream) *indenting-string-output-stream-class*))
     4329    (setf (getf (basic-stream.info stream) 'indent) new)
     4330    (report-bad-arg stream 'indenting-string-output-stream)))
     4331
     4332
    42374333(defun get-output-stream-string (s)
    4238   (unless (typep s 'string-output-stream)
    4239     (report-bad-arg s 'string-output-stream))
    4240   (let* ((string (string-stream-string s)))
    4241     (prog1 (ensure-simple-string string)
    4242       (setf (fill-pointer string) 0))))
     4334  (let* ((class (if (typep s 'basic-stream) (basic-stream.class s))))
     4335    (or (eq class *string-output-stream-class*)
     4336        (eq class *truncating-string-output-stream-class*)
     4337        (eq class *indenting-string-output-stream-class*)
     4338        (eq class *fill-pointer-string-output-stream-class*)
     4339        (report-bad-arg s 'string-output-stream))
     4340    (let* ((ioblock (basic-stream-ioblock s))
     4341           (string (string-stream-ioblock-string ioblock)))
     4342      (if (eq class *fill-pointer-string-output-stream-class*)
     4343        (prog1 (ensure-simple-string string)
     4344          (setf (fill-pointer string) 0))
     4345        (let* ((index (string-output-stream-ioblock-index ioblock))
     4346               (result (make-string index)))
     4347          (declare (fixnum index))
     4348          (%copy-ivector-to-ivector string 0 result 0 (the fixnum (ash index 2)))
     4349          (setf (string-output-stream-ioblock-index ioblock) 0)
     4350          result)))))
    42434351
    42444352;;; String input streams.
    4245 (defclass string-input-stream (string-stream fundamental-character-input-stream)
    4246     ((start :initform 0 :initarg :start :accessor string-input-stream-start)
    4247      (index :initarg :index :accessor string-input-stream-index)
    4248      (end :initarg :end :accessor string-input-stream-end)))
    4249 
    4250 (defmethod stream-read-char ((s string-input-stream))
    4251   (let* ((string (string-stream-string s))
    4252          (idx (string-input-stream-index s))
    4253          (end (string-input-stream-end s)))
    4254     (declare (fixnum idx end))
     4353(defglobal *string-input-stream-class* (make-built-in-class 'string-input-stream 'string-stream 'basic-character-input-stream))
     4354
     4355(defstruct (string-input-stream-ioblock (:include string-stream-ioblock))
     4356  (start 0)
     4357  index
     4358  end
     4359  (offset 0))
     4360
     4361
     4362
     4363(defun string-input-stream-index (s)
     4364  (if (and (typep s 'basic-stream)
     4365           (eq *string-input-stream-class* (basic-stream.class s)))
     4366    (let* ((ioblock (basic-stream-ioblock s)))
     4367      (- (string-input-stream-ioblock-index ioblock)
     4368         (string-input-stream-ioblock-offset ioblock)))
     4369    (report-bad-arg s 'string-input-stream)))
     4370
     4371
     4372
     4373(defun string-input-stream-ioblock-read-char (ioblock)
     4374  (let* ((string (string-stream-ioblock-string ioblock))
     4375         (idx (string-input-stream-ioblock-index ioblock))
     4376         (end (string-input-stream-ioblock-end ioblock)))
     4377    (declare (fixnum idx end)
     4378             (simple-string string))
    42554379    (if (< idx end)
    4256       (prog1 (char string idx) (setf (string-input-stream-index s) (1+ idx)))
     4380      (progn (setf (string-input-stream-ioblock-index ioblock)
     4381                   (the fixnum (1+ idx)))
     4382             (schar string idx))
    42574383      :eof)))
    42584384
    4259 (defmethod stream-peek-char ((s string-input-stream))
    4260   (let* ((string (string-stream-string s))
    4261          (idx (string-input-stream-index s))
    4262          (end (string-input-stream-end s)))
    4263     (declare (fixnum idx end))
     4385(defun string-input-stream-ioblock-read-line (ioblock)
     4386  (let* ((string (string-stream-ioblock-string ioblock))
     4387         (idx (string-input-stream-ioblock-index ioblock))
     4388         (end (string-input-stream-ioblock-end ioblock)))
     4389    (declare (fixnum idx end)
     4390             (simple-string string))
     4391    (if (>= idx end)
     4392      (values "" t)
     4393      (let* ((pos (position #\Newline string :start idx :end end)))
     4394        (if pos
     4395          (locally (declare (type index pos))
     4396            (let* ((new (make-string (the fixnum (- pos idx)))))
     4397              (declare (simple-base-string new))
     4398              (setf (string-input-stream-ioblock-index ioblock)
     4399                    (the fixnum (1+ pos)))
     4400              (do* ((src idx (1+ src))
     4401                    (dest 0 (1+ dest)))
     4402                   ((= src pos) (values new nil))
     4403                (declare (fixnum src dest))
     4404                (setf (schar new dest) (schar string src)))))
     4405          (let* ((new (make-string (the fixnum (- end idx)))))
     4406            (declare (simple-base-string new))
     4407              (setf (string-input-stream-ioblock-index ioblock) end)
     4408              (do* ((src idx (1+ src))
     4409                    (dest 0 (1+ dest)))
     4410                   ((= src end) (values new t))
     4411                (declare (fixnum src dest))
     4412                (setf (schar new dest) (schar string src)))))))))
     4413
     4414
     4415(defun string-input-stream-ioblock-peek-char (ioblock)
     4416  (let* ((string (string-stream-ioblock-string ioblock))
     4417         (idx (string-input-stream-ioblock-index ioblock))
     4418         (end (string-input-stream-ioblock-end ioblock)))
     4419    (declare (fixnum idx end)
     4420             (simple-string string))
    42644421    (if (< idx end)
    4265       (char string idx)
     4422      (schar string idx)
    42664423      :eof)))
    42674424
    4268 (defmethod stream-unread-char ((s string-input-stream) c)
    4269   (let* ((data (string-stream-string s))
    4270          (idx (string-input-stream-index s))
    4271          (start (string-input-stream-start s)))
    4272     (declare (fixnum idx start))
     4425(defun string-input-stream-ioblock-unread-char (ioblock char)
     4426  (let* ((string (string-stream-ioblock-string ioblock))
     4427         (idx (string-input-stream-ioblock-index ioblock))
     4428         (start (string-input-stream-ioblock-start ioblock)))
     4429    (declare (fixnum idx start)
     4430             (simple-string string))
    42734431    (unless (> idx start)
    4274       (error "Nothing has been read from ~s yet." s))
     4432      (error "Nothing has been read from ~s yet." (ioblock-stream ioblock)))
    42754433    (decf idx)
    4276     (unless (eq c (char data idx))
    4277       (error "~a was not the last character read from ~s" c s))
    4278     (setf (string-input-stream-index s) idx)
    4279     c))
    4280 
    4281 
    4282 
     4434    (unless (eq char (schar string idx))
     4435      (error "~a was not the last character read from ~s" char (ioblock-stream ioblock)))
     4436    (setf (string-input-stream-ioblock-index ioblock) idx)
     4437    char))
     4438 
     4439 
    42834440(defmethod stream-eofp ((s string-input-stream))
    4284   (let* ((idx (string-input-stream-index s))
    4285          (end (string-input-stream-end s)))
     4441  (let* ((ioblock (basic-stream-ioblock s))
     4442         (idx (string-input-stream-ioblock-index ioblock))
     4443         (end (string-input-stream-ioblock-end ioblock)))
    42864444    (declare (fixnum idx end))
    42874445    (>= idx end)))
    42884446
    42894447(defmethod stream-listen ((s string-input-stream))
    4290   (let* ((idx (string-input-stream-index s))
    4291          (end (string-input-stream-end s)))
     4448  (let* ((ioblock (basic-stream-ioblock s))
     4449         (idx (string-input-stream-ioblock-index ioblock))
     4450         (end (string-input-stream-ioblock-end ioblock)))
    42924451    (declare (fixnum idx end))
    42934452    (< idx end)))
    42944453
    4295 
    4296 
    4297 (defmethod stream-position ((s string-input-stream) &optional newpos)
    4298   (let* ((start (string-input-stream-start s))
    4299          (end (string-input-stream-end s))
    4300          (len (- end start)))
    4301     (declare (fixnum start end len))
    4302     (if newpos
    4303       (if (and (>= newpos 0) (<= newpos len))
    4304         (setf (string-input-stream-index s) (+ start newpos)))
    4305       (- (string-input-stream-index s) start))))
    4306 
    4307 (defmethod stream-length ((s string-input-stream) &optional newlen)
    4308   (unless newlen
    4309     (- (string-input-stream-end s) (string-input-stream-start s))))
    43104454
    43114455(defun make-string-input-stream (string &optional (start 0)
    … …  
    43144458  START and END in order."
    43154459  (setq end (check-sequence-bounds string start end))
    4316   (make-instance 'string-input-stream
    4317                  :string string
    4318                  :start start
    4319                  :index start
    4320                  :end end))
     4460  (multiple-value-bind (data offset) (array-data-and-offset string)
     4461    (unless (typep data 'simple-base-string)
     4462      (report-bad-arg string 'string))
     4463    (incf start offset)
     4464    (incf end offset)
     4465    (let* ((stream (make-basic-stream-instance
     4466                    *string-input-stream-class*
     4467                    :element-type 'character))
     4468           (ioblock (make-string-input-stream-ioblock
     4469                     :stream stream
     4470                     :device nil
     4471                     :string data
     4472                     :start start
     4473                     :index start
     4474                     :end end
     4475                     :read-char-function 'string-input-stream-ioblock-read-char
     4476                     :read-char-when-locked-function 'string-input-stream-ioblock-read-char
     4477                     :peek-char-function 'string-input-stream-ioblock-peek-char
     4478                     :character-read-vector-function 'generic-character-read-vector
     4479                     :close-function #'false
     4480                     :unread-char-function 'string-input-stream-ioblock-unread-char
     4481                     :read-line-function 'string-input-stream-ioblock-read-line
     4482                     )))
     4483      (setf (basic-stream.state stream) ioblock)
     4484      stream)))
     4485
     4486(defun string-stream-string (s)
     4487  (let* ((class (if (typep s 'basic-stream) (basic-stream.class s))))
     4488    (or (eq class *string-output-stream-class*)
     4489        (eq class *truncating-string-output-stream-class*)
     4490        (eq class *indenting-string-output-stream-class*)
     4491        (report-bad-arg s 'string-output-stream)))
     4492  (string-stream-ioblock-string (basic-stream-ioblock s)))
     4493
    43214494
    43224495
    … …  
    44144587  (let* ((ioblock (stream-ioblock stream nil)))
    44154588    (when ioblock
    4416       (locally (declare (optimize (speed 3)))
    4417         (without-interrupts
    4418          (values
    4419           (%ioblock-close ioblock)))))))
     4589      (%ioblock-close ioblock))))
    44204590
    44214591(defmethod close :before ((stream buffered-output-stream-mixin) &key abort)
    … …  
    44334603  (let* ((ioblock (basic-stream.state stream)))
    44344604    (when ioblock
    4435       (locally (declare (optimize (speed 3)))
    4436         (without-interrupts
    4437          (values
    4438           (%ioblock-close ioblock)))))))
     4605      (%ioblock-close ioblock))))
    44394606
    44404607
    … …  
    44914658(defmethod stream-read-char ((stream buffered-character-input-stream-mixin))
    44924659  (let* ((ioblock (stream-ioblock stream t)))
    4493     (locally (declare (optimize (speed 3)))
    4494       (without-interrupts
    4495        (values
    4496         (funcall (ioblock-read-char-function ioblock) ioblock))))))
     4660    (funcall (ioblock-read-char-function ioblock) ioblock)))
    44974661
    44984662(defmethod stream-read-char-no-hang ((stream buffered-character-input-stream-mixin))
    44994663  (with-stream-ioblock-input (ioblock stream :speedy t)
    4500     (locally (declare (optimize (speed 3)))
    4501       (without-interrupts
    4502        (values
    4503         (%ioblock-tyi-no-hang ioblock))))))
     4664    (%ioblock-tyi-no-hang ioblock)))
    45044665
    45054666(defmethod stream-peek-char ((stream buffered-character-input-stream-mixin))
    45064667  (with-stream-ioblock-input (ioblock stream :speedy t)
    4507     (locally (declare (optimize (speed 3)))
    4508       (without-interrupts
    4509        (values
    4510         (%ioblock-peek-char ioblock))))))
     4668    (values
     4669        (%ioblock-peek-char ioblock))))
    45114670
    45124671(defmethod stream-clear-input ((stream buffered-input-stream-mixin))
    45134672  (with-stream-ioblock-input (ioblock stream :speedy t)
    4514     (locally (declare (optimize (speed 3)))
    4515       (without-interrupts
    4516        (values
    4517         (%ioblock-clear-input ioblock))))))
     4673    (values
     4674     (%ioblock-clear-input ioblock))))
    45184675
    45194676(defmethod stream-unread-char ((stream buffered-character-input-stream-mixin) char)
    45204677  (with-stream-ioblock-input (ioblock stream :speedy t)
    4521     (%ioblock-untyi ioblock char))
     4678    (funcall (ioblock-unread-char-function ioblock) ioblock char))
    45224679  char)
    45234680
    45244681(defmethod stream-read-byte ((stream buffered-binary-input-stream-mixin))
    45254682  (let* ((ioblock (stream-ioblock stream t)))
    4526     (locally (declare (optimize (speed 3)))
    4527       (without-interrupts
    4528        (values
    4529         (funcall (ioblock-read-byte-function ioblock) ioblock))))))
     4683    (funcall (ioblock-read-byte-function ioblock) ioblock)))
    45304684
    45314685(defmethod stream-read-byte ((stream basic-binary-input-stream))
    45324686  (let* ((ioblock (basic-stream-ioblock stream)))
    4533     (locally (declare (optimize (speed 3)))
    4534       (without-interrupts
    4535        (values
    4536         (funcall (ioblock-read-byte-function ioblock) ioblock))))))
     4687    (funcall (ioblock-read-byte-function ioblock) ioblock)))
    45374688
    45384689(defmethod stream-eofp ((stream buffered-input-stream-mixin))
    45394690  (with-stream-ioblock-input (ioblock stream :speedy t)
    4540     (locally (declare (optimize (speed 3)))
    4541       (without-interrupts
    4542        (values
    4543         (%ioblock-eofp ioblock))))))
     4691    (values
     4692     (%ioblock-eofp ioblock))))
    45444693
    45454694(defmethod stream-eofp ((stream basic-input-stream))
    … …  
    45504699(defmethod stream-listen ((stream buffered-input-stream-mixin))
    45514700  (with-stream-ioblock-input (ioblock stream :speedy t)
    4552     (locally (declare (optimize (speed 3)))
    4553       (without-interrupts
    4554        (values
    4555         (%ioblock-listen ioblock))))))
     4701    (values
     4702     (%ioblock-listen ioblock))))
    45564703
    45574704(defmethod stream-listen ((stream basic-input-stream))
    45584705  (let* ((ioblock (basic-stream-ioblock stream)))
    45594706    (with-ioblock-input-locked (ioblock)
    4560       (locally (declare (optimize (speed 3)))
    4561         (without-interrupts
    4562          (values
    4563           (%ioblock-listen ioblock)))))))
     4707      (values
     4708       (%ioblock-listen ioblock)))))
    45644709
    45654710
    … …  
    45674712                              byte)
    45684713  (let* ((ioblock (stream-ioblock stream t)))
    4569     (locally (declare (optimize (speed 3)))
    4570       (without-interrupts
    4571        (values
    4572         (funcall (ioblock-write-byte-function ioblock) ioblock byte))))))
     4714    (funcall (ioblock-write-byte-function ioblock) ioblock byte)))
    45734715
    45744716(defmethod stream-write-byte ((stream basic-binary-output-stream) byte)
    45754717  (let* ((ioblock (basic-stream-ioblock stream)))
    4576     (locally (declare (optimize (speed 3)))
    4577       (without-interrupts
    4578        (values
    4579         (funcall (ioblock-write-byte-function ioblock) ioblock byte))))))
     4718    (funcall (ioblock-write-byte-function ioblock) ioblock byte)))
    45804719
    45814720(defmethod stream-write-char ((stream buffered-character-output-stream-mixin) char)
    45824721  (let* ((ioblock (stream-ioblock stream t)))
    4583     (locally (declare (optimize (speed 3)))
    4584       (without-interrupts
    4585        (values
    4586         (funcall (ioblock-write-char-function ioblock) ioblock char))))))
     4722    (funcall (ioblock-write-char-function ioblock) ioblock char)))
    45874723
    45884724(defmethod stream-write-char ((stream basic-character-output-stream) char)
    45894725  (let* ((ioblock (basic-stream-ioblock stream)))
    4590     (locally (declare (optimize (speed 3)))
    4591       (without-interrupts
    4592        (values
    4593         (funcall (ioblock-write-char-function ioblock) ioblock char))))))
     4726    (funcall (ioblock-write-char-function ioblock) ioblock char)))
    45944727
    45954728
    45964729(defmethod stream-clear-output ((stream buffered-output-stream-mixin))
    45974730  (with-stream-ioblock-output (ioblock stream :speedy t)
    4598     (locally (declare (optimize (speed 3)))
    4599       (without-interrupts
    4600        (values
    4601         (%ioblock-clear-output ioblock)))))
     4731    (%ioblock-clear-output ioblock))
    46024732  nil)
    46034733
    … …  
    46054735  (let* ((ioblock (basic-stream-ioblock stream)))
    46064736    (with-ioblock-output-locked (ioblock)
    4607       (locally (declare (optimize (speed 3)))
    4608         (without-interrupts
    4609          (values
    4610           (%ioblock-clear-output ioblock)))))
     4737      (%ioblock-clear-output ioblock))
    46114738    nil))
    46124739
    … …  
    46334760(defmethod stream-force-output ((stream buffered-output-stream-mixin))
    46344761  (with-stream-ioblock-output (ioblock stream :speedy t)
    4635     (locally (declare (optimize (speed 3)))
    4636       (without-interrupts
    4637        (values
    4638         (%ioblock-force-output ioblock nil))))
     4762    (%ioblock-force-output ioblock nil)
    46394763    nil))
    46404764
    … …  
    46424766  (let* ((ioblock (basic-stream-ioblock stream)))
    46434767    (with-ioblock-output-locked (ioblock)
    4644       (locally (declare (optimize (speed 3)))
    4645         (without-interrupts
    4646          (values
    4647           (%ioblock-force-output ioblock nil))))
     4768      (%ioblock-force-output ioblock nil)
    46484769      nil)))
    46494770
    46504771(defmethod maybe-stream-force-output ((stream buffered-output-stream-mixin))
    46514772  (with-stream-ioblock-output-maybe (ioblock stream :speedy t)
    4652     (locally (declare (optimize (speed 3)))
    4653       (without-interrupts
    4654        (values
    4655         (%ioblock-force-output ioblock nil))))
     4773    (%ioblock-force-output ioblock nil)
    46564774    nil))
    46574775
    … …  
    46594777  (let* ((ioblock (basic-stream-ioblock stream)))
    46604778    (with-ioblock-output-locked-maybe (ioblock)
    4661       (locally (declare (optimize (speed 3)))
    4662         (without-interrupts
    4663          (values
    4664           (%ioblock-force-output ioblock nil))))
     4779      (%ioblock-force-output ioblock nil)
    46654780      nil)))
    46664781
    46674782(defmethod stream-finish-output ((stream buffered-output-stream-mixin))
    46684783  (with-stream-ioblock-output (ioblock stream :speedy t)
    4669     (locally (declare (optimize (speed 3)))
    4670       (without-interrupts
    4671        (values
    4672         (%ioblock-force-output ioblock t))))
     4784    (%ioblock-force-output ioblock t)
    46734785    nil))
    46744786
    … …  
    46764788  (let* ((ioblock (basic-stream-ioblock stream)))
    46774789    (with-ioblock-output-locked (ioblock)
    4678       (locally (declare (optimize (speed 3)))
    4679         (without-interrupts
    4680          (values
    4681           (%ioblock-force-output ioblock t))))
     4790      (%ioblock-force-output ioblock t)
    46824791      nil)))
    46834792
    … …  
    46904799    (if (and (typep string 'simple-string)
    46914800             (not start-p))
    4692       (locally (declare (optimize (speed 3)))
    4693         (without-interrupts
    4694          (values
    4695           (funcall (ioblock-write-simple-string-function ioblock)
    4696                    ioblock string 0 (length string)))))
     4801      (funcall (ioblock-write-simple-string-function ioblock)
     4802                   ioblock string 0 (length string))
    46974803      (progn
    46984804        (setq end (check-sequence-bounds string start end))
    … …  
    47054811              (incf start offset)
    47064812              (incf end offset))
    4707             (locally (declare (optimize (speed 3)))
    4708               (without-interrupts
    4709                (values
    4710                 (funcall (ioblock-write-simple-string-function ioblock)
    4711                          ioblock arr start (the fixnum (- end start)))))))))))
     4813            (funcall (ioblock-write-simple-string-function ioblock)
     4814                     ioblock arr start (the fixnum (- end start))))))))
    47124815  string)
    47134816
    … …  
    47194822      (if (and (typep string 'simple-string)
    47204823               (not start-p))
    4721         (locally (declare (optimize (speed 3)))
    4722           (without-interrupts
    4723            (values
    4724             (funcall (ioblock-write-simple-string-function ioblock)
    4725                      ioblock string 0 (length string)))))
     4824        (values
     4825         (funcall (ioblock-write-simple-string-function ioblock)
     4826                  ioblock string 0 (length string)))
    47264827        (progn
    47274828          (setq end (check-sequence-bounds string start end))
    … …  
    47344835                (incf start offset)
    47354836                (incf end offset))
    4736               (locally (declare (optimize (speed 3)))
    4737                 (without-interrupts
    4738                  (values
     4837              (values
    47394838                  (funcall (ioblock-write-simple-string-function ioblock)
    4740                            ioblock arr start (the fixnum (- end start))))))))))))
     4839                           ioblock arr start (the fixnum (- end start))))))))))
    47414840  string)
    47424841
    … …  
    47454844                                 iv start length)
    47464845  (with-stream-ioblock-output (ioblock s :speedy t)
    4747     (locally (declare (optimize (speed 3)))
    4748       (without-interrupts
    4749        (values   
    4750         (%ioblock-out-ivect ioblock iv start length))))))
     4846    (values   
     4847        (%ioblock-out-ivect ioblock iv start length))))
    47514848
    47524849(defmethod stream-write-ivector ((s basic-output-stream)
    … …  
    47544851  (let* ((ioblock (basic-stream-ioblock s)))
    47554852    (with-ioblock-output-locked (ioblock)
    4756       (locally (declare (optimize (speed 3)))
    4757         (without-interrupts
    4758          (values
    4759           (%ioblock-out-ivect ioblock iv start length)))))))
     4853      (values
     4854          (%ioblock-out-ivect ioblock iv start length)))))
    47604855
    47614856
    … …  
    47634858                                iv start nb)
    47644859  (with-stream-ioblock-input (ioblock s :speedy t)
    4765     (locally (declare (optimize (speed 3)))
    4766       (without-interrupts
    4767        (values
    4768         (%ioblock-character-in-ivect ioblock iv start nb))))))
     4860    (values
     4861     (%ioblock-character-in-ivect ioblock iv start nb))))
    47694862
    47704863(defmethod stream-read-ivector ((s buffered-binary-input-stream-mixin)
    47714864                                iv start nb)
    47724865  (with-stream-ioblock-input (ioblock s :speedy t)
    4773     (locally (declare (optimize (speed 3)))
    4774       (without-interrupts
    4775        (values
    4776         (%ioblock-binary-in-ivect ioblock iv start nb))))))
     4866    (values
     4867     (%ioblock-binary-in-ivect ioblock iv start nb))))
    47774868
    47784869
    … …  
    47854876      (let* ((total (- end start)))
    47864877        (declare (fixnum total))
    4787         (locally (declare (optimize (speed 3)))
    4788           (without-interrupts
    4789            (values
     4878        (values
    47904879            (funcall (ioblock-write-simple-string-function ioblock)
    4791                      ioblock vector start total))))))))
     4880                     ioblock vector start total))))))
    47924881
    47934882(defmethod stream-write-vector ((stream basic-character-output-stream)
    … …  
    48004889      (declare (fixnum total))
    48014890      (with-ioblock-output-locked (ioblock)
    4802         (locally (declare (optimize (speed 3)))
    4803           (without-interrupts
    4804            (values
     4891        (values
    48054892            (funcall (ioblock-write-simple-string-function ioblock)
    4806                      ioblock vector start total))))))))
     4893                     ioblock vector start total))))))
    48074894
    48084895(defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin)
    … …  
    48104897  (declare (fixnum start end))
    48114898  (with-stream-ioblock-output (ioblock stream :speedy t)
    4812     (without-interrupts
    4813      (let* ((out (ioblock-outbuf ioblock))
    4814             (buf (io-buffer-buffer out))
    4815             (written 0)
    4816             (limit (io-buffer-limit out))
    4817             (total (- end start))
    4818             (buftype (typecode buf)))
    4819        (declare (fixnum buftype written total limit))
    4820        (if (not (= (the fixnum (typecode vector)) buftype))
    4821          (do* ((i start (1+ i))
    4822                (wbf (ioblock-write-byte-function ioblock)))
    4823               ((= i end))
    4824            (let ((byte (uvref vector i)))
    4825              (funcall wbf ioblock byte)))
    4826          (do* ((pos start (+ pos written))
    4827                (left total (- left written)))
    4828               ((= left 0))
    4829            (declare (fixnum pos left))
    4830            (setf (ioblock-dirty ioblock) t)
    4831            (let* ((index (io-buffer-idx out))
    4832                   (count (io-buffer-count out))
    4833                   (avail (- limit index)))
    4834              (declare (fixnum index avail count))
    4835              (cond
    4836                ((= (setq written avail) 0)
    4837                 (%ioblock-force-output ioblock nil))
    4838                (t
    4839                 (if (> written left)
    4840                   (setq written left))
    4841                 (%copy-ivector-to-ivector
    4842                  vector
    4843                  (ioblock-elements-to-octets ioblock pos)
    4844                  buf
    4845                  (ioblock-elements-to-octets ioblock index)
    4846                  (ioblock-elements-to-octets ioblock written))
    4847                 (setf (ioblock-dirty ioblock) t)
    4848                 (incf index written)
    4849                 (if (> index count)
    4850                   (setf (io-buffer-count out) index))
    4851                 (setf (io-buffer-idx out) index)
    4852                 (if (= index  limit)
    4853                   (%ioblock-force-output ioblock nil)))))))))))
     4899    (let* ((out (ioblock-outbuf ioblock))
     4900           (buf (io-buffer-buffer out))
     4901           (written 0)
     4902           (limit (io-buffer-limit out))
     4903           (total (- end start))
     4904           (buftype (typecode buf)))
     4905      (declare (fixnum buftype written total limit))
     4906      (if (not (= (the fixnum (typecode vector)) buftype))
     4907        (do* ((i start (1+ i))
     4908              (wbf (ioblock-write-byte-function ioblock)))
     4909             ((= i end))
     4910          (let ((byte (uvref vector i)))
     4911            (funcall wbf ioblock byte)))
     4912        (do* ((pos start (+ pos written))
     4913              (left total (- left written)))
     4914             ((= left 0))
     4915          (declare (fixnum pos left))
     4916          (setf (ioblock-dirty ioblock) t)
     4917          (let* ((index (io-buffer-idx out))
     4918                 (count (io-buffer-count out))
     4919                 (avail (- limit index)))
     4920            (declare (fixnum index avail count))
     4921            (cond
     4922              ((= (setq written avail) 0)
     4923               (%ioblock-force-output ioblock nil))
     4924              (t
     4925               (if (> written left)
     4926                 (setq written left))
     4927               (%copy-ivector-to-ivector
     4928                vector
     4929                (ioblock-elements-to-octets ioblock pos)
     4930                buf
     4931                (ioblock-elements-to-octets ioblock index)
     4932                (ioblock-elements-to-octets ioblock written))
     4933               (setf (ioblock-dirty ioblock) t)
     4934               (incf index written)
     4935               (if (> index count)
     4936                 (setf (io-buffer-count out) index))
     4937               (setf (io-buffer-idx out) index)
     4938               (if (= index  limit)
     4939                 (%ioblock-force-output ioblock nil))))))))))
    48544940
    48554941(defmethod stream-write-vector ((stream basic-binary-output-stream)
    … …  
    48584944  (let* ((ioblock (basic-stream-ioblock stream)))
    48594945    (with-ioblock-output-locked (ioblock)
    4860       (without-interrupts
    4861        (let* ((out (ioblock-outbuf ioblock))
    4862               (buf (io-buffer-buffer out))
    4863               (written 0)
    4864               (limit (io-buffer-limit out))
    4865               (total (- end start))
    4866               (buftype (typecode buf)))
    4867          (declare (fixnum buftype written total limit))
    4868          (if (not (= (the fixnum (typecode vector)) buftype))
    4869            (do* ((i start (1+ i))
    4870                  (wbf (ioblock-write-byte-function ioblock)))
    4871                 ((= i end))
    4872              (let ((byte (uvref vector i)))
    4873                (when (characterp byte)
    4874                  (setq byte (char-code byte)))
    4875                (funcall wbf ioblock byte)))
    4876            (do* ((pos start (+ pos written))
    4877                  (left total (- left written)))
    4878                 ((= left 0))
    4879              (declare (fixnum pos left))
    4880              (setf (ioblock-dirty ioblock) t)
    4881              (let* ((index (io-buffer-idx out))
    4882                     (count (io-buffer-count out))
    4883                     (avail (- limit index)))
    4884                (declare (fixnum index avail count))
    4885                (cond
    4886                  ((= (setq written avail) 0)
    4887                   (%ioblock-force-output ioblock nil))
    4888                  (t
    4889                   (if (> written left)
    4890                     (setq written left))
    4891                   (%copy-ivector-to-ivector
    4892                    vector
    4893                    (ioblock-elements-to-octets ioblock pos)
    4894                    buf
    4895                    (ioblock-elements-to-octets ioblock index)
    4896                    (ioblock-elements-to-octets ioblock written))
    4897                   (setf (ioblock-dirty ioblock) t)
    4898                   (incf index written)
    4899                   (if (> index count)
    4900                     (setf (io-buffer-count out) index))
    4901                   (setf (io-buffer-idx out) index)
    4902                   (if (= index  limit)
    4903                     (%ioblock-force-output ioblock nil))))))))))))
     4946      (let* ((out (ioblock-outbuf ioblock))
     4947             (buf (io-buffer-buffer out))
     4948             (written 0)
     4949             (limit (io-buffer-limit out))
     4950             (total (- end start))
     4951             (buftype (typecode buf)))
     4952        (declare (fixnum buftype written total limit))
     4953        (if (not (= (the fixnum (typecode vector)) buftype))
     4954          (do* ((i start (1+ i))
     4955                (wbf (ioblock-write-byte-function ioblock)))
     4956               ((= i end))
     4957            (let ((byte (uvref vector i)))
     4958              (when (characterp byte)
     4959                (setq byte (char-code byte)))
     4960              (funcall wbf ioblock byte)))
     4961          (do* ((pos start (+ pos written))
     4962                (left total (- left written)))
     4963               ((= left 0))
     4964            (declare (fixnum pos left))
     4965            (setf (ioblock-dirty ioblock) t)
     4966            (let* ((index (io-buffer-idx out))
     4967                   (count (io-buffer-count out))
     4968                   (avail (- limit index)))
     4969              (declare (fixnum index avail count))
     4970              (cond
     4971                ((= (setq written avail) 0)
     4972                 (%ioblock-force-output ioblock nil))
     4973                (t
     4974                 (if (> written left)
     4975                   (setq written left))
     4976                 (%copy-ivector-to-ivector
     4977                  vector
     4978                  (ioblock-elements-to-octets ioblock pos)
     4979                  buf
     4980                  (ioblock-elements-to-octets ioblock index)
     4981                  (ioblock-elements-to-octets ioblock written))
     4982                 (setf (ioblock-dirty ioblock) t)
     4983                 (incf index written)
     4984                 (if (> index count)
     4985                   (setf (io-buffer-count out) index))
     4986                 (setf (io-buffer-idx out) index)
     4987                 (if (= index  limit)
     4988                   (%ioblock-force-output ioblock nil)))))))))))
    49044989
    49054990
    … …  
    49124997    (let* ((ioblock (basic-stream-ioblock stream)))
    49134998      (with-ioblock-input-locked (ioblock)
    4914         (locally (declare (optimize (speed 3)))
    4915           (without-interrupts
    4916            (values
    4917             (%ioblock-binary-read-vector ioblock vector start end))))))))
     4999        (values
     5000            (%ioblock-binary-read-vector ioblock vector start end))))))
    49185001
    49195002(defmethod stream-read-vector ((stream buffered-character-input-stream-mixin)
    … …  
    49235006    (call-next-method)
    49245007    (with-stream-ioblock-input (ioblock stream :speedy t)
    4925         (locally (declare (optimize (speed 3)))
    4926           (without-interrupts
    4927            (values
    4928             (funcall (ioblock-character-read-vector-function ioblock)
    4929                      ioblock vector start end)))))))
     5008      (values
     5009       (funcall (ioblock-character-read-vector-function ioblock)
     5010                ioblock vector start end)))))
    49305011
    49315012
    … …  
    49375018    (call-next-method)
    49385019    (with-stream-ioblock-input (ioblock stream :speedy t)
    4939         (locally (declare (optimize (speed 3)))
    4940           (without-interrupts
    4941            (values
    4942             (%ioblock-binary-read-vector ioblock vector start end)))))))
     5020      (values
     5021       (%ioblock-binary-read-vector ioblock vector start end)))))
    49435022
    49445023
Note: See TracChangeset for help on using the changeset viewer.