From 84757efc85a620f271c0dd8a3b22c38e8c5276f3 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Thu, 23 Jul 2009 01:32:23 +0000 Subject: [PATCH] Make simple-streams work with the new Unicode external format support. Add new functions def-ef-macro functions that do the dirty work and use them in the stream functions. We leave the old versions around for now, but they should be removed. %octets-to-char is no longer used. --- pcl/simple-streams/strategy.lisp | 363 +++++++++++++------------------ 1 file changed, 147 insertions(+), 216 deletions(-) diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp index aaafe278e..c2e270982 100644 --- a/pcl/simple-streams/strategy.lisp +++ b/pcl/simple-streams/strategy.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.13 2009/06/11 16:04:02 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.14 2009/07/23 01:32:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -131,6 +131,7 @@ (defconstant +ef-obs-oc+ 0) (defconstant +ef-obs-co+ 1) +#+(or) (defun ef-obs-oc-fn (extfmt) (or (aref (ef-cache extfmt) +ef-obs-oc+) (setf (aref (ef-cache extfmt) +ef-obs-oc+) @@ -141,6 +142,7 @@ (lambda (x) (funcall unput x))) (values code width state))))))) +#+(or) (defmacro %octets-to-char (ef state count input unput) (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym))) `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3) @@ -171,19 +173,19 @@ (defconstant +ss-ef-max+ 4) (def-ef-macro %read-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchar+) - `(lambda (stream refill) + `(lambda (stream max refill) (declare (type simple-stream stream) (type function refill)) (with-stream-class (simple-stream stream) - ,(octets-to-char ef (sm oc-state stream) - (sm last-char-read-size stream) - (prog2 - (when (>= (sm buffpos stream) (sm buf-len stream)) - (funcall refill)) - (bref (sm buffer stream) (sm buffpos stream)) - (incf (sm buffpos stream)) - (incf (sm last-char-read-size stream))) - (lambda (n) (decf (sm buffpos stream) n)))))) + (octets-to-char ,ef + (sm oc-state stream) + (sm last-char-read-size stream) + (prog2 + (when (>= (sm buffpos stream) max) + (setf max (funcall refill))) + (bref (sm buffer stream) (sm buffpos stream)) + (incf (sm buffpos stream))) + (lambda (n) (decf (sm buffpos stream) n)))))) (def-ef-macro %read-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchars+) `(lambda (stream string search start end max refill) @@ -193,37 +195,102 @@ (type fixnum start end) (type lisp::index max) (type function refill)) - (do ((posn start (1+ posn)) - (count 0 (1+ count))) - ((>= posn end) (values count nil)) - (declare (type lisp::index posn count)) - (let* ((char ,(octets-to-char ef (sm oc-state stream) - (sm last-char-read-size stream) - (prog2 - (when (>= (sm buffpos stream) max) - (setq max (funcall refill count))) - (bref (sm buffer stream) - (sm buffpos stream)) - (incf (sm buffpos stream)) - (incf (sm last-char-read-size stream))) - (lambda (n) - (decf (sm buffpos stream) n)))) - (code (char-code char)) - (ctrl (sm control-in stream))) - (when (and (< code 32) ctrl (svref ctrl code)) - (setq char (funcall (the (or symbol function) (svref ctrl code)) - stream char))) - (cond ((null char) - (return (values count :eof))) - ((and search (char= char search)) - (return (values count t))) - (t - (setf (char string posn) char))))))) - + (with-stream-class (simple-stream stream) + (do ((posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) (values count nil)) + (declare (type lisp::index posn count)) + (let* ((char (octets-to-char ,ef + (sm oc-state stream) + (sm last-char-read-size stream) + (prog2 + (when (>= (sm buffpos stream) max) + (setq max (funcall refill count))) + (bref (sm buffer stream) + (sm buffpos stream)) + (incf (sm buffpos stream))) + (lambda (n) + (decf (sm buffpos stream) n)))) + (code (char-code char)) + (ctrl (sm control-in stream))) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (return (values count :eof))) + ((and search (char= char search)) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + +(def-ef-macro %sc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+) + `(lambda (character stream) + (declare (type simple-stream stream)) + (when character + (with-stream-class (simple-stream stream) + (let ((code (char-code character)) + (ctrl (sm control-out stream))) + (unless (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (char-to-octets ,ef + character + (sm oc-state stream) + (lambda (byte) + (when (>= (sm buffpos stream) (sm buffer-ptr stream)) + (setf (sm buffpos stream) (flush-buffer stream t))) + (setf (bref (sm buffer stream) (sm buffpos stream)) byte) + (incf (sm buffpos stream)))) + (sc-set-dirty stream) + (when (sm charpos stream) + (incf (sm charpos stream))))))) + character)) + +(def-ef-macro %dc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+) + `(lambda (character stream) + (declare (type simple-stream stream)) + (when character + (with-stream-class (dual-channel-simple-stream stream) + (let ((code (char-code character)) + (ctrl (sm control-out stream))) + (unless (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (char-to-octets ,ef + character + (sm oc-state stream) + (lambda (byte) + (when (>= (sm outpos stream) (sm max-out-pos stream)) + (setf (sm outpos stream) (flush-out-buffer stream t))) + (setf (bref (sm out-buffer stream) (sm outpos stream)) byte) + (incf (sm outpos stream)))) + (when (sm charpos stream) + (incf (sm charpos stream))))))) + character)) ;;;; Single-Channel-Simple-Stream strategy functions (declaim (ftype j-listen-fn (sc listen :ef))) +#-(or) +(defun (sc listen :ef) (stream) + (with-stream-class (simple-stream stream) + (let ((lcrs (sm last-char-read-size stream)) + (char nil)) + (unwind-protect + (flet ((refill () + (let ((bytes (refill-buffer stream nil))) + (cond ((= bytes 0) + (return-from listen nil)) + ((minusp bytes) + (return-from listen t)) + (t + (+ bytes (sm last-char-read-size stream))))))) + (setq char (funcall (%read-char-fn (sm external-format stream)) + stream (sm buffer-ptr stream) #'refill)) + (characterp char)) + (setf (sm last-char-read-size stream) lcrs))))) + +#+(or) (defun (sc listen :ef) (stream) (with-stream-class (simple-stream stream) (let ((lcrs (sm last-char-read-size stream)) @@ -246,6 +313,7 @@ (incf buffpos))) (unput (n) (decf buffpos n))) + (format t "listen on ~S~%" stream) (setq char (%octets-to-char (sm external-format stream) (sm oc-state stream) cnt #'input #'unput)) @@ -265,9 +333,11 @@ (return-from read-char nil)) ((minusp bytes) (return-from read-char - (lisp::eof-or-lose stream eof-error-p eof-value))))))) + (lisp::eof-or-lose stream eof-error-p eof-value))) + (t + (+ bytes (sm last-char-read-size stream))))))) (let* ((char (funcall (%read-char-fn (sm external-format stream)) - stream #'refill)) + stream (sm buffer-ptr stream) #'refill)) (code (char-code char)) (ctrl (sm control-in stream))) (when (and (< code 32) ctrl (svref ctrl code)) @@ -276,6 +346,7 @@ (if (null char) (lisp::eof-or-lose stream eof-error-p eof-value) char))))) + #+(or) (defun (sc read-char :ef) (stream eof-error-p eof-value blocking) #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# @@ -326,7 +397,7 @@ (return-from read-char (lisp::eof-or-lose stream eof-error-p eof-value)))) (let* ((char (funcall (%read-char-fn (sm external-format stream)) - stream #'refill)) + stream (sm buf-len stream) #'refill)) (code (char-code char)) (ctrl (sm control-in stream))) (when (and (< code 32) ctrl (svref ctrl code)) @@ -335,6 +406,7 @@ (if (null char) (lisp::eof-or-lose stream eof-error-p eof-value) char))))) + #+(or) (defun (sc read-char :ef mapped) (stream eof-error-p eof-value blocking) #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# @@ -382,59 +454,17 @@ #|(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)) - (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 lisp::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)))))))) + (flet ((refill (count) + (let ((bytes (refill-buffer stream blocking))) + (declare (type fixnum bytes)) + (cond ((= bytes 0) + (return-from read-chars (values count nil))) + ((minusp bytes) + (return-from read-chars (values count :eof))) + (t + (+ bytes (sm last-char-read-size stream))))))) + (funcall (%read-chars-fn (sm external-format stream)) + stream string search start end (sm buffer-ptr stream) #'refill)))) (declaim (ftype j-read-chars-fn (sc read-chars :ef mapped))) @@ -453,48 +483,10 @@ #|(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)) - (buffpos (sm buffpos stream)) - (buf-len (sm buf-len 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 lisp::index buffpos buf-len posn count)) - (flet ((input () - (when (>= buffpos buf-len) - (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)))))))) + (flet ((refill (count) + (return-from read-chars (values count :eof)))) + (funcall (%read-chars-fn (sm external-format stream)) + stream string search start end (sm buf-len stream) #'refill)))) (declaim (ftype j-unread-char-fn (sc unread-char :ef))) @@ -508,59 +500,27 @@ (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 write-char 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) - (when (sm charpos stream) - (incf (sm charpos stream)))))) - character) + (with-stream-class (simple-stream stream) + (funcall (%sc-write-char-fn (sm external-format stream)) + character stream))) (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)) - (buffpos (sm buffpos stream)) - (buf-len (sm buf-len stream)) - (ef (sm external-format stream)) + (with-stream-class (simple-stream stream) + (do ((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)) + ((>= posn end) + count) + (declare (type fixnum 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)) - (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) - (when (sm charpos stream) - (incf (sm charpos stream))) - (sc-set-dirty stream)))))) + (funcall (%sc-write-char-fn ef) + char stream)))))) ;;;; Dual-Channel-Simple-Stream strategy functions @@ -569,55 +529,26 @@ (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 ((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 write-char 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) - (incf (sm charpos stream))))) - character) + (with-stream-class (dual-channel-simple-stream stream) + (funcall (%dc-write-char-fn (sm external-format stream)) + character stream))) (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)) - (outpos (sm outpos stream)) - (max-out-pos (sm max-out-pos stream)) - (ef (sm external-format stream)) - (ctrl (sm control-out stream)) + (do ((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)) + ((>= posn end) + count) + (declare (type fixnum 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)) - (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) - (incf (sm charpos stream))))))) + (funcall (%dc-write-char-fn (sm external-format stream)) + char stream)))))) ;;;; String-Simple-Stream strategy functions -- GitLab