X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Fstrategy.lisp;h=38c4e9345a124f6f7c9c73a05328eb1194bd1966;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=2538f74fb04f236d394b24566b03486fcb17c77f;hpb=ce58e434470b1ebefae6132d9c075c7d8a2c0c13;p=sbcl.git diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp index 2538f74..38c4e93 100644 --- a/contrib/sb-simple-streams/strategy.lisp +++ b/contrib/sb-simple-streams/strategy.lisp @@ -1,25 +1,29 @@ ;;; -*- lisp -*- +;;; +;;; ********************************************************************** +;;; This code was written by Paul Foley and has been placed in the public +;;; domain. +;;; -;;; 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. +;;; Sbcl port by Rudi Schlatte. (in-package "SB-SIMPLE-STREAMS") +;;; +;;; ********************************************************************** +;;; +;;; Strategy functions for base simple-stream classes +;;;; Helper functions -(defun sc-refill-buffer (stream blocking) - (with-stream-class (single-channel-simple-stream stream) - (when (any-stream-instance-flags stream :dirty) - ;; FIXME: Implement flush-buffer failure protocol instead of - ;; blocking here - (sc-flush-buffer stream t)) +(defun refill-buffer (stream blocking) + (declare (type blocking blocking)) + (with-stream-class (simple-stream stream) (let* ((unread (sm last-char-read-size stream)) - (buffer (sm buffer stream))) - (unless (zerop unread) - (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread)) + (buffer (sm buffer stream)) + (bufptr (sm buffer-ptr stream))) + (unless (or (zerop unread) (zerop bufptr)) + (buffer-copy buffer (- bufptr unread) buffer 0 unread)) (let ((bytes (device-read stream nil unread nil blocking))) (declare (type fixnum bytes)) (setf (sm buffpos stream) unread @@ -28,594 +32,639 @@ unread)) bytes)))) +(defun sc-set-dirty (stream) + (with-stream-class (single-channel-simple-stream stream) + (setf (sm mode stream) + (if (<= (sm buffpos stream) + (sm buffer-ptr stream)) + 3 ; read-modify + 1 ; write + )))) + +(defun sc-set-clean (stream) + (with-stream-class (single-channel-simple-stream stream) + (setf (sm mode stream) 0))) -(defun sc-flush-buffer (stream blocking) +(defun sc-dirty-p (stream) + (with-stream-class (single-channel-simple-stream stream) + (> (sm mode stream) 0))) + +(defun flush-buffer (stream blocking) (with-stream-class (single-channel-simple-stream stream) (let ((ptr 0) - (bytes (sm buffpos stream))) + (bytes (sm buffpos stream))) (declare (type fixnum ptr bytes)) - ;; Seek to the left before flushing buffer -- the user could - ;; have set the file-position, and scribbled something in the - ;; data that was read from the file. - (when (> (sm buffer-ptr stream) 0) + (when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0)) + ;; The data read in from the file could have been changed if + ;; the stream is opened in read-write mode -- write back + ;; everything in the buffer at the correct position just in + ;; case. (setf (device-file-position stream) (- (device-file-position stream) (sm buffer-ptr stream)))) (loop - (when (>= ptr bytes) - (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0) - (remove-stream-instance-flags stream :dirty) - (return 0)) - (let ((bytes-written (device-write stream nil ptr nil blocking))) - (declare (fixnum bytes-written)) - (when (minusp bytes-written) - (error "DEVICE-WRITE error.")) - (incf ptr bytes-written)))))) - -(defun dc-refill-buffer (stream blocking) - (with-stream-class (dual-channel-simple-stream stream) - (let* ((unread (sm last-char-read-size stream)) - (buffer (sm buffer stream))) - (unless (zerop unread) - (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread)) - (let ((bytes (device-read stream nil unread nil blocking))) - (declare (type fixnum bytes)) - (setf (sm buffpos stream) unread - (sm buffer-ptr stream) (if (plusp bytes) - (+ bytes unread) - unread)) - bytes)))) - -(defun dc-flush-buffer (stream blocking) + (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0)) + (let ((bytes-written (device-write stream nil ptr nil blocking))) + (declare (fixnum bytes-written)) + (when (minusp bytes-written) + (error "DEVICE-WRITE error.")) + (incf ptr bytes-written)))))) + +(defun flush-out-buffer (stream blocking) (with-stream-class (dual-channel-simple-stream stream) (let ((ptr 0) - (bytes (sm outpos stream))) + (bytes (sm outpos stream))) (declare (type fixnum ptr bytes)) (loop - (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0)) - (let ((bytes-written (device-write stream nil ptr nil blocking))) - (declare (fixnum bytes-written)) - (when (minusp bytes-written) - (error "DEVICE-WRITE error.")) - (incf ptr bytes-written)))))) + (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0)) + (let ((bytes-written (device-write stream nil ptr nil blocking))) + (declare (fixnum bytes-written)) + (when (minusp bytes-written) + (error "DEVICE-WRITE error.")) + (incf ptr bytes-written)))))) + +(defun read-byte-internal (stream eof-error-p eof-value blocking) + (with-stream-class (simple-stream stream) + (let ((ptr (sm buffpos stream))) + (when (>= ptr (sm buffer-ptr stream)) + (let ((bytes (device-read stream nil 0 nil blocking))) + (declare (type fixnum bytes)) + (if (plusp bytes) + (setf (sm buffer-ptr stream) bytes + ptr 0) + (return-from read-byte-internal + (sb-impl::eof-or-lose stream eof-error-p eof-value))))) + (setf (sm buffpos stream) (1+ ptr)) + (setf (sm last-char-read-size stream) 0) + (setf (sm charpos stream) nil) + (bref (sm buffer stream) ptr)))) -;;; -;;; SINGLE-CHANNEL STRATEGY FUNCTIONS -;;; +;;;; Single-Channel-Simple-Stream strategy functions -(declaim (ftype j-read-char-fn sc-read-char)) -(defun sc-read-char (stream eof-error-p eof-value blocking) - (declare (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (with-stream-class (single-channel-simple-stream stream) - ;; if stream is open for read-write, may need to flush the buffer - (let* ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (code (if (< ptr (sm buffer-ptr stream)) - (progn - (setf (sm buffpos stream) (1+ ptr)) - (bref buffer ptr)) - (let ((bytes (sc-refill-buffer stream blocking))) - (declare (type fixnum bytes)) - (unless (minusp bytes) - (let ((ptr (sm buffpos stream))) - (setf (sm buffpos stream) (1+ ptr)) - (bref buffer ptr)))))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when code - (setf (sm last-char-read-size stream) 1) - (when (and (< code 32) ctrl (svref ctrl code)) - ;; Does this have to be a function, or can it be a symbol? - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char)))) - (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))) -(declaim (ftype j-read-char-fn sc-read-char--buffer)) -(defun sc-read-char--buffer (stream eof-error-p eof-value blocking) - (declare (ignore blocking)) ;; everything is already in the buffer - (declare (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (with-stream-class (single-channel-simple-stream stream) +(declaim (ftype j-listen-fn sc-listen-ef)) +(defun sc-listen-ef (stream) + (with-stream-class (simple-stream stream) + (let ((lcrs (sm last-char-read-size stream)) + (buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (cnt 0) + (char nil)) + (unwind-protect + (flet ((input () + (when (>= buffpos (sm buffer-ptr stream)) + (let ((bytes (refill-buffer stream nil))) + (cond ((= bytes 0) + (return-from sc-listen-ef nil)) + ((< bytes 0) + (return-from sc-listen-ef t)) + (t + (setf buffpos (sm buffpos stream)))))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (setq char (octets-to-char (sm external-format stream) + (sm oc-state stream) + cnt #'input #'unput)) + (characterp char)) + (setf (sm last-char-read-size stream) lcrs))))) + +(declaim (ftype j-read-char-fn sc-read-char-ef)) +(defun sc-read-char-ef (stream eof-error-p eof-value blocking) + #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# + (with-stream-class (simple-stream stream) (let* ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (code (when (< ptr (sm buffer-ptr stream)) - (setf (sm buffpos stream) (1+ ptr)) - (bref buffer ptr))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when code - (setf (sm last-char-read-size stream) 1) - (when (and (< code 32) ctrl (svref ctrl code)) - ;; Does this have to be a function, or can it be a symbol? - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char)))) - (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))) - -(declaim (ftype j-read-chars-fn sc-read-chars)) -(defun sc-read-chars (stream string search start end blocking) + (buffpos (sm buffpos stream)) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream))) + (flet ((input () + (when (>= buffpos (sm buffer-ptr stream)) + (when (and (not (any-stream-instance-flags stream :dual :string)) + (sc-dirty-p stream)) + (flush-buffer stream t)) + (let ((bytes (refill-buffer stream blocking))) + (cond ((= bytes 0) + (return-from sc-read-char-ef nil)) + ((minusp bytes) + (return-from sc-read-char-ef + (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (t + (setf buffpos (sm buffpos stream)))))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) cnt + (sm oc-state stream) state) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) + + +(declaim (ftype j-read-char-fn sc-read-char-ef-mapped)) +(defun sc-read-char-ef-mapped (stream eof-error-p eof-value blocking) + #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# + (declare (ignore blocking)) + (with-stream-class (simple-stream stream) + (let* ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream))) + (flet ((input () + (when (>= buffpos (sm buffer-ptr stream)) + (return-from sc-read-char-ef-mapped + (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) cnt + (sm oc-state stream) state) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) + + +(declaim (ftype j-read-chars-fn sc-read-chars-ef)) +(defun sc-read-chars-ef (stream string search start end blocking) ;; string is filled from START to END, or until SEARCH is found ;; Return two values: count of chars read and ;; NIL if SEARCH was not found - ;; T is SEARCH was found + ;; T if SEARCH was found ;; :EOF if eof encountered before end (declare (type simple-stream stream) - (type string string) - (type (or null character) search) - (type fixnum start end) - (type boolean blocking) - (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (with-stream-class (single-channel-simple-stream stream) - (setf (sm last-char-read-size stream) 0) - ;; FIXME: Should arrange for the last character to be unreadable + (type string string) + (type (or null character) search) + (type fixnum start end) + (type boolean blocking) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) + (with-stream-class (simple-stream stream) + (when (and (not (any-stream-instance-flags stream :dual :string)) + (sc-dirty-p stream)) + (flush-buffer stream t)) (do ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (max (sm buffer-ptr stream)) - (posn start (1+ posn)) - (count 0 (1+ count))) - ((= posn end) (setf (sm buffpos stream) ptr) (values count nil)) - (declare (type fixnum ptr max posn count)) - (let* ((code (if (< ptr max) - (prog1 - (bref buffer ptr) - (incf ptr)) - (let ((bytes (sc-refill-buffer stream blocking))) - (declare (type fixnum bytes)) - (setf ptr (sm buffpos stream) - max (sm buffer-ptr stream)) - (when (plusp bytes) - (prog1 - (bref buffer ptr) - (incf ptr)))))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when (and code (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (cond ((null char) - (setf (sm buffpos stream) ptr) - (return (values count :eof))) - ((and search (char= char search)) - (setf (sm buffpos stream) ptr) - (return (values count t))) - (t - (setf (char string posn) char))))))) - -(declaim (ftype j-read-chars-fn sc-read-chars--buffer)) -(defun sc-read-chars--buffer (stream string search start end blocking) + (buffpos (sm buffpos stream)) + (buffer-ptr (sm buffer-ptr stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (values count nil)) + (declare (type sb-int:index buffpos buffer-ptr posn count)) + (flet ((input () + (when (>= buffpos buffer-ptr) + (setf (sm last-char-read-size stream) lcrs) + (let ((bytes (refill-buffer stream blocking))) + (declare (type fixnum bytes)) + (setf buffpos (sm buffpos stream) + buffer-ptr (sm buffer-ptr stream)) + (unless (plusp bytes) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (if (zerop bytes) + (return (values count nil)) + (return (values count :eof)))))) + (prog1 (bref buffer buffpos) + (incf buffpos) + (incf lcrs))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setq lcrs cnt) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + + +(declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped)) +(defun sc-read-chars-ef-mapped (stream string search start end blocking) + ;; string is filled from START to END, or until SEARCH is found + ;; Return two values: count of chars read and + ;; NIL if SEARCH was not found + ;; T if SEARCH was found + ;; :EOF if eof encountered before end (declare (type simple-stream stream) - (type string string) - (type (or null character) search) - (type fixnum start end) - (type boolean blocking) - (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (declare (ignore blocking)) ; everything is in the buffer - (with-stream-class (single-channel-simple-stream stream) + (type string string) + (type (or null character) search) + (type fixnum start end) + (type boolean blocking) + (ignore blocking) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) + (with-stream-class (simple-stream stream) + ;; if stream is single-channel and mode == 3, flush buffer (if dirty) (do ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (max (sm buffer-ptr stream)) - (posn start (1+ posn)) - (count 0 (1+ count))) - ((= posn end) - (setf (sm buffpos stream) ptr) - (unless (zerop count) (setf (sm last-char-read-size stream) 1)) - (values count nil)) - (declare (type fixnum ptr max posn count)) - (let* ((code (when (< ptr max) - (prog1 - (bref buffer ptr) - (incf ptr)))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when (and code (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (cond ((null char) - (setf (sm buffpos stream) ptr) - (unless (zerop count) (setf (sm last-char-read-size stream) 1)) - (return (values count :eof))) - ((and search (char= char search)) - (setf (sm buffpos stream) ptr) - ;; Unread of last char must unread the search character, too - ;; If no characters were read, just add the length of the - ;; search char to that of the previously read char. - (if (zerop count) - (incf (sm last-char-read-size stream)) - (setf (sm last-char-read-size stream) 2)) - (return (values count t))) - (t - (setf (char string posn) char))))))) - -(declaim (ftype j-unread-char-fn sc-unread-char)) -(defun sc-unread-char (stream relaxed) + (buffpos (sm buffpos stream)) + (buffer-ptr (sm buffer-ptr stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (values count nil)) + (declare (type sb-int:index buffpos buffer-ptr posn count)) + (flet ((input () + (when (>= buffpos buffer-ptr) + (return (values count :eof))) + (prog1 (bref buffer buffpos) + (incf buffpos) + (incf lcrs))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setq lcrs cnt) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + + +(declaim (ftype j-unread-char-fn sc-unread-char-ef)) +(defun sc-unread-char-ef (stream relaxed) (declare (ignore relaxed)) - (with-stream-class (single-channel-simple-stream stream) + (with-stream-class (simple-stream stream) (let ((unread (sm last-char-read-size stream))) (if (>= (sm buffpos stream) unread) - (decf (sm buffpos stream) unread) - (error "Unreading needs work")) - (setf (sm last-char-read-size stream) 0)))) + (decf (sm buffpos stream) unread) + (error "This shouldn't happen."))))) -(declaim (ftype j-write-char-fn sc-write-char)) -(defun sc-write-char (character stream) - (with-stream-class (single-channel-simple-stream stream) - (let* ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (code (char-code character)) - (ctrl (sm control-out stream))) - (when (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream character)) - (return-from sc-write-char character)) - (when (>= ptr (sm buf-len stream)) - (setf ptr (sc-flush-buffer stream t))) - (setf (bref buffer ptr) code) - (setf (sm buffpos stream) (1+ ptr)) - (add-stream-instance-flags stream :dirty))) +(declaim (ftype j-write-char-fn sc-write-char-ef)) +(defun sc-write-char-ef (character stream) + (when character + (with-stream-class (single-channel-simple-stream stream) + (let ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (buf-len (sm buf-len stream)) + (code (char-code character)) + (ctrl (sm control-out stream))) + (when (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (return-from sc-write-char-ef character)) + (flet ((output (byte) + (when (>= buffpos buf-len) + (setf (sm buffpos stream) buffpos) + (setq buffpos (flush-buffer stream t))) + (setf (bref buffer buffpos) byte) + (incf buffpos))) + (char-to-octets (sm external-format stream) character + (sm co-state stream) #'output)) + (setf (sm buffpos stream) buffpos) + (sc-set-dirty stream) + (if (sm charpos stream) (incf (sm charpos stream)))))) character) -(declaim (ftype j-write-chars-fn sc-write-chars)) -(defun sc-write-chars (string stream start end) +(declaim (ftype j-write-chars-fn sc-write-chars-ef)) +(defun sc-write-chars-ef (string stream start end) (with-stream-class (single-channel-simple-stream stream) (do ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (max (sm buf-len stream)) - (ctrl (sm control-out stream)) - (posn start (1+ posn)) - (count 0 (1+ count))) - ((>= posn end) - (setf (sm buffpos stream) ptr) - (add-stream-instance-flags stream :dirty) - count) - (declare (type fixnum ptr max posn count)) + (buffpos (sm buffpos stream)) + (buf-len (sm buf-len stream)) + (ef (sm external-format stream)) + (ctrl (sm control-out stream)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) (setf (sm buffpos stream) buffpos) count) + (declare (type fixnum buffpos buf-len posn count)) (let* ((char (char string posn)) - (code (char-code char))) - ;; FIXME: Can functions in the control-out table side-effect - ;; the stream? Section 9.0 prohibits this only for control-in - ;; functions. If they can, update (sm buffpos stream) here, - ;; like around the call to sc-flush-buffer below - (unless (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream char)) - (unless (< ptr max) - ;; need to update buffpos before control leaves this - ;; function in any way - (setf (sm buffpos stream) ptr) - (sc-flush-buffer stream t) - (setf ptr (sm buffpos stream))) - (setf (bref buffer ptr) code) - (incf ptr)))))) - -(declaim (ftype j-listen-fn sc-listen)) -(defun sc-listen (stream) - (with-stream-class (single-channel-simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (case (device-read stream nil 0 0 nil) - ((0 -2) nil) - (-1 #| latch EOF |# nil) - (-3 t) - (t (error "DEVICE-READ error.")))))) - -;;; SC-READ-BYTE doesn't actually live in a strategy slot -(defun sc-read-byte (stream eof-error-p eof-value blocking) - (with-stream-class (single-channel-simple-stream stream) - ;; @@1 - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buffer-ptr stream)) - (let ((bytes (device-read stream nil 0 nil blocking))) - (declare (type fixnum bytes)) - (if (plusp bytes) - (setf (sm buffer-ptr stream) bytes - ptr 0) - (return-from sc-read-byte - (sb-impl::eof-or-lose stream eof-error-p eof-value))))) - (setf (sm buffpos stream) (1+ ptr)) - (setf (sm last-char-read-size stream) 0) - (bref (sm buffer stream) ptr)))) - -;;; -;;; DUAL-CHANNEL STRATEGY FUNCTIONS -;;; - -(declaim (ftype j-read-char-fn dc-read-char)) -(defun dc-read-char (stream eof-error-p eof-value blocking) - ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0))) - (with-stream-class (dual-channel-simple-stream stream) - ;; if interactive flag is set, finish-output first - (let* ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (code (if (< ptr (sm buffer-ptr stream)) - (progn - (setf (sm buffpos stream) (1+ ptr)) - (bref buffer ptr)) - (let ((bytes (dc-refill-buffer stream blocking))) - (declare (type fixnum bytes)) - (unless (minusp bytes) - (let ((ptr (sm buffpos stream))) - (setf (sm buffpos stream) (1+ ptr)) - (bref buffer ptr)))))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when code - (setf (sm last-char-read-size stream) 1) - (when (and (< code 32) ctrl (svref ctrl code)) - ;; Does this have to be a function, or can it be a symbol? - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - #|(let ((column (sm charpos stream))) - (declare (type (or null fixnum) column)) - (when column - (setf (sm charpos stream) (1+ column))))|#) - (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))) - -(declaim (ftype j-read-chars-fn dc-read-chars)) -(defun dc-read-chars (stream string search start end blocking) - (declare (type dual-channel-simple-stream stream) - (type string string) - (type (or null character) search) - (type fixnum start end) - (type boolean blocking) - #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) - (with-stream-class (dual-channel-simple-stream stream) - ;; if interactive flag is set, finish-output first - (setf (sm last-char-read-size stream) 0) - ;; Should arrange for the last character to be unreadable - (do ((buffer (sm buffer stream)) - (ptr (sm buffpos stream)) - (max (sm buffer-ptr stream)) - (posn start (1+ posn)) - (count 0 (1+ count))) - ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil)) - (declare (type fixnum ptr max posn count)) - (let* ((code (if (< ptr max) - (prog1 - (bref buffer ptr) - (incf ptr)) - (let ((bytes (dc-refill-buffer stream blocking))) - (declare (type fixnum bytes)) - (setf ptr (sm buffpos stream) - max (sm buffer-ptr stream)) - (when (plusp bytes) - (prog1 - (bref buffer ptr) - (incf ptr)))))) - (char (if code (code-char code) nil)) - (ctrl (sm control-in stream))) - (when (and code (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - #|(let ((column (sm charpos stream))) - (declare (type (or null fixnum) column)) - (when column - (setf (sm charpos stream) (1+ column))))|# - (cond ((null char) - (setf (sm buffpos stream) ptr) - (return (values count :eof))) - ((and search (char= char search)) - (setf (sm buffpos stream) ptr) - (return (values count t))) - (t - (setf (char string posn) char))))))) - -(declaim (ftype j-unread-char-fn dc-unread-char)) -(defun dc-unread-char (stream relaxed) - (declare (ignore relaxed)) - (with-stream-class (dual-channel-simple-stream stream) - (let ((unread (sm last-char-read-size stream))) - (if (>= (sm buffpos stream) unread) - (decf (sm buffpos stream) unread) - (error "Unreading needs work")) - (setf (sm last-char-read-size stream) 0)))) - -(declaim (ftype j-write-char-fn dc-write-char)) -(defun dc-write-char (character stream) + (code (char-code char))) + (unless (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream char)) + (flet ((output (byte) + (when (>= buffpos buf-len) + (setf (sm buffpos stream) buffpos) + (setq buffpos (flush-buffer stream t))) + (setf (bref buffer buffpos) byte) + (incf buffpos))) + (char-to-octets ef char (sm co-state stream) #'output)) + (setf (sm buffpos stream) buffpos) + (if (sm charpos stream) (incf (sm charpos stream))) + (sc-set-dirty stream)))))) + + +;;;; Dual-Channel-Simple-Stream strategy functions + +;; single-channel read-side functions work for dual-channel streams too + +(declaim (ftype j-write-char-fn dc-write-char-ef)) +(defun dc-write-char-ef (character stream) (when character (with-stream-class (dual-channel-simple-stream stream) - (let* ((buffer (sm out-buffer stream)) - (ptr (sm outpos stream)) - (code (char-code character)) - (ctrl (sm control-out stream))) + (let ((out-buffer (sm out-buffer stream)) + (outpos (sm outpos stream)) + (max-out-pos (sm max-out-pos stream)) + (code (char-code character)) + (ctrl (sm control-out stream))) (when (and (< code 32) ctrl (svref ctrl code) (funcall (the (or symbol function) (svref ctrl code)) stream character)) - (return-from dc-write-char character)) - (when (>= ptr (sm max-out-pos stream)) - (setq ptr (dc-flush-buffer stream t))) - (setf (bref buffer ptr) code) - (setf (sm outpos stream) (1+ ptr))))) + (return-from dc-write-char-ef character)) + (flet ((output (byte) + (when (>= outpos max-out-pos) + (setf (sm outpos stream) outpos) + (setq outpos (flush-out-buffer stream t))) + (setf (bref out-buffer outpos) byte) + (incf outpos))) + (char-to-octets (sm external-format stream) character + (sm co-state stream) #'output)) + (setf (sm outpos stream) outpos) + (if (sm charpos stream) (incf (sm charpos stream)))))) character) -(declaim (ftype j-write-chars-fn dc-write-chars)) -(defun dc-write-chars (string stream start end) + +(declaim (ftype j-write-chars-fn dc-write-chars-ef)) +(defun dc-write-chars-ef (string stream start end) (with-stream-class (dual-channel-simple-stream stream) (do ((buffer (sm out-buffer stream)) - (ptr (sm outpos stream)) - (max (sm max-out-pos stream)) - (ctrl (sm control-out stream)) - (posn start (1+ posn)) - (count 0 (1+ count))) - ((>= posn end) (setf (sm outpos stream) ptr) count) - (declare (type fixnum ptr max posn count)) + (outpos (sm outpos stream)) + (max-out-pos (sm max-out-pos stream)) + (ef (sm external-format stream)) + (ctrl (sm control-out stream)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) (setf (sm outpos stream) outpos) count) + (declare (type fixnum outpos max-out-pos posn count)) (let* ((char (char string posn)) - (code (char-code char))) - (unless (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream char)) - (unless (< ptr max) - (setf (sm outpos stream) ptr) - (dc-flush-buffer stream t) - (setf ptr (sm outpos stream))) - (setf (bref buffer ptr) code) - (incf ptr)) - )))) - -(declaim (ftype j-listen-fn dc-listen)) -(defun dc-listen (stream) - (with-stream-class (dual-channel-simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (case (device-read stream nil 0 0 nil) - ((0 -2) nil) - (-1 #| latch EOF |# nil) - (-3 t) - (t (error "DEVICE-READ error.")))))) - -;;; DC-READ-BYTE doesn't actually live in a strategy slot -(defun dc-read-byte (stream eof-error-p eof-value blocking) - (with-stream-class (dual-channel-simple-stream stream) - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buffer-ptr stream)) - (let ((bytes (device-read stream nil 0 nil blocking))) - (declare (type fixnum bytes)) - (if (plusp bytes) - (setf (sm buffer-ptr stream) bytes - ptr 0) - (return-from dc-read-byte - (sb-impl::eof-or-lose stream eof-error-p eof-value))))) - (setf (sm buffpos stream) (1+ ptr)) - (setf (sm last-char-read-size stream) 0) - (bref (sm buffer stream) ptr)))) - -;;; -;;; STRING STRATEGY FUNCTIONS -;;; - -(declaim (ftype j-read-char-fn string-read-char)) -(defun string-read-char (stream eof-error-p eof-value blocking) + (code (char-code char))) + (unless (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream char)) + (flet ((output (byte) + (when (>= outpos max-out-pos) + (setf (sm outpos stream) outpos) + (setq outpos (flush-out-buffer stream t))) + (setf (bref buffer outpos) byte) + (incf outpos))) + (char-to-octets ef char (sm co-state stream) #'output)) + (setf (sm outpos stream) outpos) + (if (sm charpos stream) (incf (sm charpos stream)))))))) + +;;;; String-Simple-Stream strategy functions + +(declaim (ftype j-read-char-fn str-read-char)) +(defun str-read-char (stream eof-error-p eof-value blocking) (declare (type string-input-simple-stream stream) (ignore blocking) - (optimize (speed 3) (space 2) (safety 0) (debug 0))) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|# + ) (with-stream-class (string-input-simple-stream stream) (when (any-stream-instance-flags stream :eof) (sb-impl::eof-or-lose stream eof-error-p eof-value)) (let* ((ptr (sm buffpos stream)) - (char (if (< ptr (sm buffer-ptr stream)) - (schar (sm buffer stream) ptr) - nil))) + (char (if (< ptr (sm buffer-ptr stream)) + (schar (sm buffer stream) ptr) + nil))) (if (null char) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (progn - (setf (sm last-char-read-size stream) 1) - ;; do string-streams do control-in processing? - #|(let ((column (sm charpos stream))) - (declare (type (or null fixnum) column)) - (when column - (setf (sm charpos stream) (1+ column))))|# - char))))) - - -(declaim (ftype j-read-char-fn composing-crlf-read-char)) -(defun composing-crlf-read-char (stream eof-error-p eof-value blocking) - ;; TODO: what about the eof-error-p parameter? - (declare (ignore eof-error-p eof-value)) - (with-stream-class (simple-stream stream) - (let* ((melded-stream (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char melded-stream nil stream - blocking))) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + (progn + (setf (sm last-char-read-size stream) 1) + ;; do string-streams do control-in processing? + #|(let ((column (sm charpos stream))) + (declare (type (or null fixnum) column)) + (when column + (setf (sm charpos stream) (1+ column)))) + |# + char))))) + +(declaim (ftype j-listen-fn str-listen-e-crlf)) +(defun str-listen-e-crlf (stream) + (with-stream-class (composing-stream stream) + ;; if this says there's a character available, it may be #\Return, + ;; in which case read-char will only return if there's a following + ;; #\Linefeed, so this really has to read the char... + ;; but without precluding the later unread-char of a character which + ;; has already been read. + (funcall-stm-handler j-listen (sm melded-stream stream)))) + +(declaim (ftype j-read-char-fn str-read-char-e-crlf)) +(defun str-read-char-e-crlf (stream eof-error-p eof-value blocking) + (with-stream-class (composing-stream stream) + (let* ((encap (sm melded-stream stream)) + (ctrl (sm control-in stream)) + (char (funcall-stm-handler j-read-char encap nil stream blocking))) ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no ;; character was available... (when (eql char #\Return) - (let ((next (funcall-stm-handler j-read-char melded-stream - nil stream blocking))) - ;; if NEXT is STREAM, we hit EOF, so we should just return the - ;; #\Return (and mark the stream :EOF? At least unread if we - ;; got a soft EOF, from a terminal, etc. - ;; if NEXT is NIL, blocking is NIL and there's a CR but no - ;; LF available on the stream: have to unread the CR and - ;; return NIL, letting the CR be reread later. - ;; - ;; If we did get a linefeed, adjust the last-char-read-size - ;; so that an unread of the resulting newline will unread both - ;; the linefeed _and_ the carriage return. - (if (eql next #\Linefeed) - (setq char #\Newline) - (funcall-stm-handler j-unread-char melded-stream nil)))) - ;; do control-in processing on whatever character we've got - char))) - -(declaim (ftype j-unread-char-fn composing-crlf-unread-char)) -(defun composing-crlf-unread-char (stream relaxed) + (let ((next (funcall-stm-handler j-read-char encap nil stream blocking))) + ;; if NEXT is STREAM, we hit EOF, so we should just return the + ;; #\Return (and mark the stream :EOF? At least unread if we + ;; got a soft EOF, from a terminal, etc. + ;; if NEXT is NIL, blocking is NIL and there's a CR but no + ;; LF available on the stream: have to unread the CR and + ;; return NIL, letting the CR be reread later. + ;; + ;; If we did get a linefeed, adjust the last-char-read-size + ;; so that an unread of the resulting newline will unread both + ;; the linefeed _and_ the carriage return. + (if (eql next #\Linefeed) + (setq char #\Newline) + (funcall-stm-handler j-unread-char encap nil)))) + (when (characterp char) + (let ((code (char-code char))) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))))) + (if (eq char stream) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))) + +(declaim (ftype j-unread-char-fn str-unread-char-e-crlf)) +(defun str-unread-char-e-crlf (stream relaxed) (declare (ignore relaxed)) - (with-stream-class (simple-stream stream) + (with-stream-class (composing-stream stream) (funcall-stm-handler j-unread-char (sm melded-stream stream) nil))) -;;; + ;;; Functions to install the strategy functions in the appropriate slots -;;; -(defun %find-topmost-stream (stream) - ;; N.B.: the topmost stream in the chain of encapsulations is actually - ;; the bottommost in the "melding" chain +(defun melding-stream (stream) (with-stream-class (simple-stream) - (loop - (when (eq (sm melded-stream stream) (sm melding-base stream)) - (return stream)) - (setq stream (sm melded-stream stream))))) + (do ((stm stream (sm melded-stream stm))) + ((eq (sm melded-stream stm) stream) stm)))) + +(defun meld (stream encap) + (with-stream-class (simple-stream) + (setf (sm melding-base encap) (sm melding-base stream)) + (setf (sm melded-stream encap) (sm melded-stream stream)) + (setf (sm melded-stream stream) encap) + (rotatef (sm j-listen encap) (sm j-listen stream)) + (rotatef (sm j-read-char encap) (sm j-read-char stream)) + (rotatef (sm j-read-chars encap) (sm j-read-chars stream)) + (rotatef (sm j-unread-char encap) (sm j-unread-char stream)) + (rotatef (sm j-write-char encap) (sm j-write-char stream)) + (rotatef (sm j-write-chars encap) (sm j-write-chars stream)))) + +(defun unmeld (stream) + (with-stream-class (simple-stream) + (let ((encap (sm melded-stream stream))) + (unless (eq encap (sm melding-base stream)) + (setf (sm melding-base encap) encap) + (setf (sm melded-stream stream) (sm melded-stream encap)) + (setf (sm melded-stream encap) encap) + (rotatef (sm j-listen stream) (sm j-listen encap)) + (rotatef (sm j-read-char encap) (sm j-read-char stream)) + (rotatef (sm j-read-chars stream) (sm j-read-chars encap)) + (rotatef (sm j-unread-char stream) (sm j-unread-char encap)) + (rotatef (sm j-write-char stream) (sm j-write-char encap)) + (rotatef (sm j-write-chars stream) (sm j-write-chars encap)))))) + +;;; In cmucl, this is done with define-function-name-syntax (lists as +;;; function names), we make do with symbol frobbing. +(defun %sf (kind name format &optional access) + (flet ((find-strategy-function (&rest args) + (let ((name + (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args)) + #.*package*))) + (if (fboundp name) (fdefinition name) nil)))) + (or (find-strategy-function kind name format access) + (find-strategy-function kind name format) + (find-strategy-function kind name :ef access) + (find-strategy-function kind name :ef)))) + (defun install-single-channel-character-strategy (stream external-format - access) - (find-external-format external-format) - (let ((stream (%find-topmost-stream stream))) + access) + (let ((format (find-external-format external-format))) ;; ACCESS is usually NIL ;; May be "undocumented" values: stream::buffer, stream::mapped ;; to install strategies suitable for direct buffer streams ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ) ;; (Avoids checking "mode" flags by installing special strategy) - (with-stream-class (single-channel-simple-stream stream) - (if (or (eq access 'buffer) (eq access 'mapped)) - (setf (sm j-read-char stream) #'sc-read-char--buffer - (sm j-read-chars stream) #'sc-read-chars--buffer - (sm j-unread-char stream) #'sc-unread-char - (sm j-write-char stream) #'sc-write-char - (sm j-write-chars stream) #'sc-write-chars - (sm j-listen stream) #'sc-listen) - (setf (sm j-read-char stream) #'sc-read-char - (sm j-read-chars stream) #'sc-read-chars - (sm j-unread-char stream) #'sc-unread-char - (sm j-write-char stream) #'sc-write-char - (sm j-write-chars stream) #'sc-write-chars - (sm j-listen stream) #'sc-listen)))) + (with-stream-class (simple-stream stream) + (setf (sm j-listen stream) + (%sf 'sc 'listen (ef-name format) access) + (sm j-read-char stream) + (%sf 'sc 'read-char (ef-name format) access) + (sm j-read-chars stream) + (%sf 'sc 'read-chars (ef-name format) access) + (sm j-unread-char stream) + (%sf 'sc 'unread-char (ef-name format) access) + (sm j-write-char stream) + (%sf 'sc 'write-char (ef-name format) access) + (sm j-write-chars stream) + (%sf 'sc 'write-chars (ef-name format) access)))) stream) (defun install-dual-channel-character-strategy (stream external-format) - (find-external-format external-format) - (let ((stream (%find-topmost-stream stream))) - (with-stream-class (dual-channel-simple-stream stream) - (setf (sm j-read-char stream) #'dc-read-char - (sm j-read-chars stream) #'dc-read-chars - (sm j-unread-char stream) #'dc-unread-char - (sm j-write-char stream) #'dc-write-char - (sm j-write-chars stream) #'dc-write-chars - (sm j-listen stream) #'dc-listen))) + (let ((format (find-external-format external-format))) + (with-stream-class (simple-stream stream) + (setf (sm j-listen stream) + (%sf 'sc 'listen (ef-name format)) + (sm j-read-char stream) + (%sf 'sc 'read-char (ef-name format)) + (sm j-read-chars stream) + (%sf 'sc 'read-chars (ef-name format)) + (sm j-unread-char stream) + (%sf 'sc 'unread-char (ef-name format)) + (sm j-write-char stream) + (%sf 'dc 'write-char (ef-name format)) + (sm j-write-chars stream) + (%sf 'dc 'write-chars (ef-name format))))) + stream) + +;; Deprecated -- use install-string-{input,output}-character-strategy instead! +(defun install-string-character-strategy (stream) + (when (any-stream-instance-flags stream :input) + (install-string-input-character-strategy stream)) + (when (any-stream-instance-flags stream :output) + (install-string-output-character-strategy stream)) stream) (defun install-string-input-character-strategy (stream) #| implement me |# - (let ((stream (%find-topmost-stream stream))) - (with-stream-class (simple-stream stream) - (setf (sm j-read-char stream) #'string-read-char))) + (with-stream-class (simple-stream stream) + (setf (sm j-read-char stream) #'str-read-char)) stream) (defun install-string-output-character-strategy (stream) #| implement me |# stream) +(defun install-composing-format-character-strategy (stream composing-format) + (let ((format composing-format)) + (with-stream-class (simple-stream stream) + (case format + (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf + (sm j-unread-char stream) #'str-unread-char-e-crlf)))) + #| implement me |#) + stream) + (defun compose-encapsulating-streams (stream external-format) (when (consp external-format) (with-stream-class (simple-stream) - (dolist (fmt (butlast external-format)) - (let ((encap (make-instance 'composing-stream :composing-format fmt))) - (setf (sm melding-base encap) stream) - (setf (sm melded-stream encap) (sm melded-stream stream)) - (setf (sm melded-stream stream) encap) - (rotatef (sm j-listen encap) (sm j-listen stream)) - (rotatef (sm j-read-char encap) (sm j-read-char stream)) - (rotatef (sm j-read-chars encap) (sm j-read-chars stream)) - (rotatef (sm j-unread-char encap) (sm j-unread-char stream)) - (rotatef (sm j-write-char encap) (sm j-write-char stream)) - (rotatef (sm j-write-chars encap) (sm j-write-chars stream))))))) + (let ((encap (if (eq (sm melded-stream stream) stream) + nil + (sm melded-stream stream)))) + (when (null encap) + (setq encap (make-instance 'composing-stream)) + (meld stream encap)) + (setf (stream-external-format encap) (car (last external-format))) + (setf (sm external-format stream) external-format) + (install-composing-format-character-strategy stream + (butlast external-format)) + )))) + +(defmethod (setf stream-external-format) (ef (stream simple-stream)) + (with-stream-class (simple-stream stream) + (setf (sm external-format stream) (find-external-format ef))) + ef) ;;; ;;; NULL STRATEGY FUNCTIONS