From 94ed0111948ce36c8c6d78093ede36ae1ae37957 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 10 Aug 2009 16:47:41 +0000 Subject: [PATCH] Fixes from Paul Foley: o Standard streams no longer change formats when *default-external-format* changes. Use stream:set-system-external-format instead, or (setf external-format). o char-to-octets properly handles surrogate characters being written. o Makes simple-streams work again. This change needs to be cross-compiled. 2009-07 binaries work for cross-compiling using the 19e/boot-2008-05-cross-unicode-*.lisp cross-compile script. --- .../boot-2008-05-cross-unicode-common.lisp | 2 + code/exports.lisp | 5 +- code/extfmts.lisp | 246 +++--- code/fd-stream-extfmt.lisp | 70 +- code/fd-stream.lisp | 166 ++-- code/stream.lisp | 41 +- compiler/fndb.lisp | 4 +- pcl/simple-streams/classes.lisp | 10 +- pcl/simple-streams/impl.lisp | 48 +- pcl/simple-streams/internal.lisp | 4 +- .../rt/simple-streams-test.lisp | 44 +- pcl/simple-streams/strategy.lisp | 836 +++++++----------- 12 files changed, 626 insertions(+), 850 deletions(-) diff --git a/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp b/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp index 1a0c4a167..217774df6 100644 --- a/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp +++ b/bootfiles/19e/boot-2008-05-cross-unicode-common.lisp @@ -1,6 +1,8 @@ ;;; Common part for cross-compiling 16-bit strings for Unicode. ;;; This part is independent of the architecture. +(load "target:bootfiles/19f/boot-2009-07") + (pushnew :unicode *features*) (pushnew :unicode-bootstrap *features*) (in-package "C") diff --git a/code/exports.lisp b/code/exports.lisp index 2ca70c8ec..b69328bb5 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.285 2009/07/23 16:17:45 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.286 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1473,7 +1473,8 @@ (:import-from "EXTENSIONS" "FUNDAMENTAL-STREAM") (:import-from "LISP" "LINE-LENGTH" "CHARPOS" "BREF" "BUFFER-COPY" "BUFFER-SAP" "ENDIAN-SWAP-VALUE" - "VECTOR-ELT-WIDTH") + "VECTOR-ELT-WIDTH" + "SURROGATES" "SURROGATES-TO-CODEPOINT") (:export ;; Stream classes "STREAM" "SIMPLE-STREAM" diff --git a/code/extfmts.lisp b/code/extfmts.lisp index 2badddc32..a5eb60b7f 100644 --- a/code/extfmts.lisp +++ b/code/extfmts.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.10 2009/07/23 21:36:51 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.11 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -14,7 +14,7 @@ (in-package "STREAM") (export '(string-to-octets octets-to-string *default-external-format* - string-encode string-decode)) + string-encode string-decode set-system-external-format)) (defvar *default-external-format* :iso8859-1) @@ -30,13 +30,7 @@ (defconstant +ef-so+ 7) (defconstant +ef-en+ 8) (defconstant +ef-de+ 9) -;; For simple-streams support -(defconstant +ss-ef-str+ 10) -(defconstant +ss-ef-rchar+ 11) -(defconstant +ss-ef-rchars+ 12) -(defconstant +ss-ef-wchar+ 13) -(defconstant +ss-ef-wchars+ 14) -(defconstant +ef-max+ 15) +(defconstant +ef-max+ 10) ;; Unicode replacement character U+FFFD (defconstant +replacement-character-code+ #xFFFD) @@ -242,14 +236,17 @@ (defun load-external-format-aliases () (let ((*package* (find-package "KEYWORD")) (unix::*filename-encoding* :iso8859-1)) - (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil :external-format :iso8859-1) + (with-open-file (stm "ext-formats:aliases" :if-does-not-exist nil + :external-format :iso8859-1) (when stm (do ((alias (read stm nil stm) (read stm nil stm)) (value (read stm nil stm) (read stm nil stm))) ((or (eq alias stm) (eq value stm)) (unless (eq alias stm) (warn "External-format aliases file ends early."))) - (if (and (keywordp alias) (keywordp value)) + (if (and (keywordp alias) (or (keywordp value) + (and (consp value) + (every #'keywordp value)))) (setf (gethash alias *external-format-aliases*) value) (warn "Bad entry in external-format aliases file: ~S => ~S." alias value))))))) @@ -276,14 +273,11 @@ (setq name tmp)) (or (gethash name *external-formats*) + (and (consp name) (find-external-format name)) (and (let ((*package* (find-package "STREAM")) - (lisp::*enable-package-locked-errors* nil) - (*default-external-format* :iso8859-1) - (unix::*filename-encoding* :iso8859-1) - (s (open (format nil "ext-formats:~(~A~).lisp" name) :if-does-not-exist nil - :external-format :iso8859-1))) - (when s - (null (nth-value 1 (ext:compile-from-stream s))))) + (lisp::*enable-package-locked-errors* nil)) + (load (format nil "ext-formats:~(~A~).lisp" name) + :if-does-not-exist nil :external-format :iso8859-1)) (gethash name *external-formats*)))) (defun %composed-ef-name (a b) @@ -298,15 +292,23 @@ (%composed-ef-name (ef-name a) (ef-name b)) (make-efx :octets-to-code (lambda (state input unput) - (funcall (ef-octets-to-code b) state - (funcall (ef-octets-to-code a) - state input unput) - unput)) + (let ((nstate (gensym "STATE-"))) + `(let ((,nstate ,state)) + (when (null ,nstate) + (setq ,nstate (setf ,state (cons nil nil)))) + ,(funcall (ef-octets-to-code b) `(car ,nstate) + (funcall (ef-octets-to-code a) + `(cdr ,nstate) input unput) + unput)))) :code-to-octets (lambda (code state output) - (funcall (ef-code-to-octets b) code state - `(lambda (x) - ,(funcall (ef-code-to-octets a) - 'x state output)))) + (let ((nstate (gensym "STATE-"))) + `(let ((,nstate ,state)) + (when (null ,nstate) + (setq ,nstate (setf ,state (cons nil nil)))) + ,(funcall (ef-code-to-octets b) code `(car ,nstate) + `(lambda (x) + ,(funcall (ef-code-to-octets a) + 'x `(cdr ,nstate) output)))))) :cache (make-array +ef-max+ :initial-element nil) :min (* (ef-min-octets a) (ef-min-octets b)) :max (* (ef-max-octets a) (ef-max-octets b))) @@ -404,7 +406,7 @@ (declaim (inline get-inverse)) (defun get-inverse (ntrie code) - (declare (type lisp::ntrie16 ntrie) (type lisp:codepoint code)) + (declare (type lisp::ntrie16 ntrie) (type (integer 0 #x10FFFF) code)) (let ((n (lisp::qref ntrie code))) (and n (let ((m (aref (lisp::ntrie16-lvec ntrie) n))) (if (= m #xFFFF) nil m))))) @@ -466,9 +468,10 @@ ;;; ;;; (defmacro def-ef-macro (name (ef id reqd idx) body) - (let ((tmp1 (gensym)) - (tmp2 (gensym)) - (%name (intern (format nil "%~A" name) (symbol-package name)))) + (let* ((tmp1 (gensym)) + (tmp2 (gensym)) + (blknm (nth-value 1 (lisp::valid-function-name-p name))) + (%name (intern (format nil "%~A" name) #|(symbol-package blknm)|#))) `(progn (defun ,%name (,ef) (let* ((,tmp1 (find-external-format ,ef)) @@ -484,10 +487,11 @@ ;; changing the default format while we're ;; compiling, and we don't know how to output ;; the compiler messages. - (*default-external-format* :iso8859-1)) + #|(*default-external-format* :iso8859-1)|#) (compile nil `(lambda (%slots%) (declare (ignorable %slots%)) - ,,body))))) + (block ,',blknm + ,,body)))))) (ef-slots ,tmp1)))) (declaim (inline ,name)) (defun ,name (,tmp1) @@ -506,61 +510,57 @@ ;;; Read and write one character through an external-format ;;; (defmacro octets-to-char (external-format state count input unput) - (let ((s (gensym "STATE-")) - (code (gensym "CODE-"))) - `(let ((,s ,state)) - (when (null ,s) - ;; Need our own state variable to hold our state and the - ;; state for the external format. - (setq ,s (setf ,state (cons nil nil)))) - (if (car ,s) - ;; Return the trailing surrgate. Must set count to 0 to - ;; tell the stream code we didn't consume any octets! - (prog1 (the character (car ,s)) - (setf (car ,s) nil) - (setf ,count 0)) - (let ((,code (octets-to-codepoint ,external-format - (cdr ,s) ,count ,input ,unput))) - (declare (type (unsigned-byte 31) ,code)) - (cond ((or (lisp::surrogatep ,code) - (> ,code #x10FFFF)) - #-(and unicode (not unicode-bootstrap)) #\? - #+(and unicode (not unicode-bootstrap)) #\U+FFFD) - #+unicode - ((> ,code #xFFFF) - (multiple-value-bind (hi lo) - (lisp::surrogates ,code) - (setf (car ,state) lo) + (let ((nstate (gensym))) + `(let ((,nstate ,state)) + (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) + (if (car ,nstate) + (prog1 (the character (car ,nstate)) + (setf (car ,nstate) nil ,count 0)) + (let ((code (octets-to-codepoint ,external-format + (cdr ,nstate) ,count ,input ,unput))) + (declare (type (unsigned-byte 21) code)) + ;;@@ on non-Unicode builds, limit to 8-bit chars + ;;@@ if unicode-bootstrap, can't use #\u+fffd + (cond ((or (<= #xD800 code #xDFFF) (> code #x10FFFF)) #\U+FFFD) + ((> code #xFFFF) + (multiple-value-bind (hi lo) (surrogates code) + (setf (car ,nstate) lo) hi)) - (t (code-char ,code)))))))) + (t (code-char code)))))))) -;; This doesn't handle surrogate code units correctly. It just -;; outputs the surrogate value to the external format. External -;; formats almost never allow surrogate code points (except UTF-16). (defmacro char-to-octets (external-format char state output) - `(codepoint-to-octets ,external-format (char-code ,char) ,state ,output)) - + (let ((nchar (gensym)) + (nstate (gensym)) + (wryte (gensym)) + (ch (gensym))) + `(let ((,nchar ,char) + (,nstate ,state)) + (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) + (if (<= #xD800 (char-code ,nchar) #xDBFF) + (setf (car ,nstate) ,nchar) + (flet ((,wryte (,ch) + (codepoint-to-octets ,external-format ,ch (cdr ,nstate) + ,output))) + (declare (dynamic-extent #',wryte)) + (if (car ,nstate) + (prog1 (,wryte (surrogates-to-codepoint (car ,nstate) ,nchar)) + (setf (car ,nstate) nil)) + (,wryte (char-code ,nchar)))))))) (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+) - `(lambda (string start end buffer &aux (ptr 0) (state nil) (code 0) (c 0) widep) + `(lambda (string start end buffer &aux (ptr 0) (state nil)) (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|# (type simple-string string) (type kernel:index start end ptr) (type (simple-array (unsigned-byte 8) (*)) buffer) - (type lisp:codepoint code c) - (type (or null fixnum) widep) (ignorable state)) - (loop with i of-type kernel:index = start - while (< i end) - do - (multiple-value-bind (c widep) - (lisp::codepoint string i end) - (incf i (if widep 2 1)) - (codepoint-to-octets ,extfmt c state - (lambda (b) - (when (= ptr (length buffer)) - (setq buffer (adjust-array buffer (* 2 ptr)))) - (setf (aref buffer (1- (incf ptr))) b))))))) + (dotimes (i (- end start) (values buffer ptr)) + (declare (type kernel:index i)) + (char-to-octets ,extfmt (schar string (+ start i)) state + (lambda (b) + (when (= ptr (length buffer)) + (setq buffer (adjust-array buffer (* 2 ptr)))) + (setf (aref buffer (1- (incf ptr))) b)))))) (defun string-to-octets (string &key (start 0) end (external-format :default) (buffer nil bufferp)) @@ -577,27 +577,20 @@ (values (if bufferp buffer (lisp::shrink-vector buffer ptr)) ptr)))) (def-ef-macro ef-octets-to-string (extfmt lisp::lisp +ef-max+ +ef-os+) - `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil) (code 0)) + `(lambda (octets ptr end string &aux (pos -1) (count 0) (state nil)) (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|# (type (simple-array (unsigned-byte 8) (*)) octets) (type kernel:index end count) (type (integer -1 (#.array-dimension-limit)) ptr pos) (type simple-string string) - (type lisp:codepoint code) (ignorable state)) (loop until (>= ptr end) do (when (= pos (length string)) (setq string (adjust-array string (* 2 pos)))) - (setf code - (octets-to-codepoint ,extfmt state count + (setf (schar string (incf pos)) + (octets-to-char ,extfmt state count (aref octets (incf ptr)) ;;@@ EOF?? (lambda (n) (decf ptr n)))) - ;; Convert codepoint to UTF-16 surrogate pairs if needed - (multiple-value-bind (high low) - (surrogates code) - (setf (aref string (incf pos)) high) - (when low - (setf (aref string (incf pos)) low))) finally (return (values string (1+ pos)))))) (defun octets-to-string (octets &key (start 0) end (external-format :default) @@ -621,18 +614,14 @@ (type kernel:index start end ptr) (type simple-base-string result) (ignorable state)) - (do ((k start (1+ k))) - ((>= k end) - (values result ptr)) - (multiple-value-bind (code widep) - (lisp::codepoint string k end) - (when widep (incf k)) - (codepoint-to-octets ,extfmt code state - (lambda (b) - (when (= ptr (length result)) - (setq result (adjust-array result (* 2 ptr)))) - (setf (aref result (1- (incf ptr))) - (code-char b)))))))) + (dotimes (i (- end start) (values result ptr)) + (declare (type kernel:index i)) + (char-to-octets ,extfmt (schar string (+ start i)) state + (lambda (b) + (when (= ptr (length result)) + (setq result (adjust-array result (* 2 ptr)))) + (setf (aref result (1- (incf ptr))) + (code-char b))))))) (defun string-encode (string external-format &optional (start 0) end) "Encode the given String using External-Format and return a new @@ -658,17 +647,13 @@ (loop until (>= ptr end) ;; increasing size of result shouldn't ever be necessary, unless ;; someone implements an encoding smaller than the source string... - do (let ((code (octets-to-codepoint ,extfmt state count - ;; note the need to return NIL for EOF - (if (= (1+ ptr) (length string)) - nil - (char-code (char string (incf ptr)))) - (lambda (n) (decf ptr n))))) - (multiple-value-bind (hi lo) - (lisp::surrogates code) - (setf (schar result (incf pos)) hi) - (when lo - (setf (schar result (incf pos)) lo)))) + do (setf (schar result (incf pos)) + (octets-to-char ,extfmt state count + ;; note the need to return NIL for EOF + (if (= (1+ ptr) (length string)) + nil + (char-code (char string (incf ptr)))) + (lambda (n) (decf ptr n)))) finally (return (values result (1+ pos)))))) (defun string-decode (string external-format &optional (start 0) end) @@ -683,3 +668,44 @@ (funcall (ef-decode external-format) string (1- start) (1- end) (make-string (length string)))) (lisp::shrink-vector result pos))) + + +(defun set-system-external-format (terminal &optional filenames) + (unless (find-external-format terminal) + (error "Can't find external-format ~S." terminal)) + (setf (stream-external-format sys:*stdin*) terminal + (stream-external-format sys:*stdout*) terminal + (stream-external-format sys:*stderr*) terminal) + (when (lisp::fd-stream-p sys:*tty*) + (setf (stream-external-format sys:*tty*) terminal)) + (when filenames + (unless (find-external-format filenames) + (error "Can't find external-format ~S." filenames)) + (when (and unix::*filename-encoding* + (not (eq unix::*filename-encoding* filenames))) + (cerror "Change it anyway." + "The external-format for encoding filenames is already set.") + (setq unix::*filename-encoding* filenames))) + t) + + +;; Despite its name, this doesn't actually compile anything at all. What it +;; does is expand into a lambda expression that can be compiled by the file +;; compiler. +(defmacro precompile-ef-slot (ef slot) + (let* ((ef (find-external-format ef))) + ;; if there's no lambda expression available, flush it and regenerate + (unless (and (aref (ef-cache ef) slot) + (function-lambda-expression (aref (ef-cache ef) slot))) + (setf (aref (ef-cache ef) slot) nil) + (ecase slot + (#.+ef-cin+ (lisp::%ef-cin ef)) + (#.+ef-cout+ (lisp::%ef-cout ef)) + (#.+ef-sout+ (lisp::%ef-sout ef)) + (#.+ef-os+ (%ef-octets-to-string ef)) + (#.+ef-so+ (%ef-string-to-octets ef)) + (#.+ef-en+ (%ef-encode ef)) + (#.+ef-de+ (%ef-decode ef)))) + `(setf (aref (ef-cache (find-external-format ,(ef-name ef))) ,slot) + ,(subst (ef-name ef) ef + (function-lambda-expression (aref (ef-cache ef) slot)))))) diff --git a/code/fd-stream-extfmt.lisp b/code/fd-stream-extfmt.lisp index 05f6f14b8..eda598f17 100644 --- a/code/fd-stream-extfmt.lisp +++ b/code/fd-stream-extfmt.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.2 2009/06/11 16:03:57 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream-extfmt.lisp,v 1.3 2009/08/10 16:47:41 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -13,32 +13,6 @@ (in-package "LISP") -(defun output-char-none-buffered (stream char) - (funcall (ef-cout (fd-stream-external-format stream)) - stream char) - (if (char= char #\Newline) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (flush-output-buffer stream) - (values)) - -(defun output-char-line-buffered (stream char) - (funcall (ef-cout (fd-stream-external-format stream)) - stream char) - (if (char= char #\Newline) - (progn (setf (fd-stream-char-pos stream) 0) - (flush-output-buffer stream)) - (incf (fd-stream-char-pos stream))) - (values)) - -(defun output-char-full-buffered (stream char) - (funcall (ef-cout (fd-stream-external-format stream)) - stream char) - (if (char= char #\Newline) - (setf (fd-stream-char-pos stream) 0) - (incf (fd-stream-char-pos stream))) - (values)) - ;; an fd-sout that works with external-formats; needs slots in fd-stream (defun fd-sout (stream thing start end) (let ((start (or start 0)) @@ -71,24 +45,28 @@ (:none (do-output stream thing start end nil)))))) -(defun input-character (stream eof-error eof-value) - ;; This needs to go away. Unreading a character needs to be done by backing - ;; up the buffer head pointer, so that the external format will re-build the - ;; character - else changing extfmts won't work. But until we get around - ;; to teaching UNREAD-CHAR to DTRT, keep this to maintain compatibility... - (if (fd-stream-unread stream) - (prog1 (fd-stream-unread stream) - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-listen stream) nil)) - (let ((char (funcall (ef-cin (fd-stream-external-format stream)) - stream))) - (if char - char - (eof-or-lose stream eof-error eof-value))))) +(defun (setf stream-external-format) (extfmt stream) + (declare (type stream stream)) + (stream-dispatch stream + ;; simple-stream + (error "Loading simple-streams should redefine this") + ;; lisp-stream + (typecase stream + (fd-stream (%set-fd-stream-external-format stream extfmt)) + (synonym-stream (setf (stream-external-format + (symbol-value (synonym-stream-symbol stream))) + extfmt)) + (t (error "Don't know how to set external-format for ~S." stream))) + ;; fundamental-stream + (error "Setting external-format on Gray streams not supported.")) + extfmt) + + + +(stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cin+) +(stream::precompile-ef-slot :iso8859-1 #.stream::+ef-cout+) +(stream::precompile-ef-slot :iso8859-1 #.stream::+ef-sout+) + -(setf (fd-stream-out *stdout*) #'output-char-line-buffered - (fd-stream-sout *stdout*) #'fd-sout - (fd-stream-out *stderr*) #'output-char-line-buffered - (fd-stream-sout *stderr*) #'fd-sout - (fd-stream-in *stdin*) #'input-character) +;(set-terminal-coding-system :iso8859-1) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 6376c41f1..e3d1e08ca 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.88 2009/06/25 01:48:59 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.89 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -520,7 +520,15 @@ (setq sap (fd-stream-obuf-sap stream) tail 0)) (setf (bref sap (1- (incf tail))) byte))) - (setf (fd-stream-obuf-tail stream) tail)))) + (setf (fd-stream-obuf-tail stream) tail)) + (if (char= char #\Newline) + (setf (fd-stream-char-pos stream) 0) + (incf (fd-stream-char-pos stream))) + (ecase (fd-stream-buffering stream) + (:none (flush-output-buffer stream)) + (:line (when (char= char #\Newline) (flush-output-buffer stream))) + (:full #| do nothing |#)) + (values))) ;;; OUTPUT-RAW-BYTES -- public @@ -616,21 +624,16 @@ (len (fd-stream-obuf-length stream)) (tail (fd-stream-obuf-tail stream))) (declare (type sys:system-area-pointer sap) (type index len tail)) - (do ((i start)) - ((>= i end)) - (declare (type index i)) - (multiple-value-bind (code widep) - (codepoint string i end) - (stream::codepoint-to-octets ,extfmt - code - (fd-stream-co-state stream) - (lambda (byte) - (when (= tail len) - (do-output stream sap 0 tail t) - (setq sap (fd-stream-obuf-sap stream) - tail 0)) - (setf (bref sap (1- (incf tail))) byte))) - (incf i (if widep 2 1)))) + (dotimes (i (- end start)) + (stream::char-to-octets ,extfmt + (schar string (+ i start)) + (fd-stream-co-state stream) + (lambda (byte) + (when (= tail len) + (do-output stream sap 0 tail t) + (setq sap (fd-stream-obuf-sap stream) + tail 0)) + (setf (bref sap (1- (incf tail))) byte)))) (setf (fd-stream-obuf-tail stream) tail)))) @@ -667,6 +670,7 @@ (do-output stream thing start end nil)))))) #+unicode +;; Temporary. The final version is defined in fd-stream-extfmt.lisp (defun fd-sout (stream thing start end) (declare (type string thing)) (let ((start (or start 0)) @@ -960,32 +964,31 @@ (signed-sap-ref-32 sap head)) (stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+) - `(lambda (stream) + `(lambda (stream eof-error-p eof-value) (declare (type fd-stream stream) - (optimize (speed 3) (space 0) (debug 0) (safety 0))) - (catch 'eof-input-catcher - (let* ((head (fd-stream-ibuf-head stream)) - (ch (stream::octets-to-char ,extfmt - (fd-stream-oc-state stream) - (fd-stream-last-char-read-size stream) - ;;@@ Note: need proper EOF handling... - (progn - (when (= head - (fd-stream-ibuf-tail - stream)) - (let ((sofar (- head (fd-stream-ibuf-head stream)))) - (do-input stream) - (setf head - (+ (fd-stream-ibuf-head stream) - sofar)))) - (bref (fd-stream-ibuf-sap stream) - (1- (incf head)))) - (lambda (n) (decf head n))))) - (declare (type index head)) - (when ch - (incf (fd-stream-ibuf-head stream) - (fd-stream-last-char-read-size stream)) - ch))))) + #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#) + (let* ((head (fd-stream-ibuf-head stream)) + (ch (catch 'eof-input-catcher + (stream::octets-to-char ,extfmt + (fd-stream-oc-state stream) + (fd-stream-last-char-read-size stream) + ;;@@ Note: need proper EOF handling... + (progn + (when (= head (fd-stream-ibuf-tail stream)) + (let ((sofar (- head (fd-stream-ibuf-head + stream)))) + (do-input stream) + (setf head (+ (fd-stream-ibuf-head stream) + sofar)))) + (bref (fd-stream-ibuf-sap stream) + (1- (incf head)))) + (lambda (n) (decf head n)))))) + (declare (type index head)) + (if ch + (progn + (setf (fd-stream-ibuf-head stream) head) + ch) + (eof-or-lose stream eof-error-p eof-value))))) #+(or) (stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+) @@ -1006,19 +1009,23 @@ (let* ((sz 0) (ch (catch 'eof-input-catcher (stream::octets-to-char ,extfmt - (fd-stream-oc-state stream) - sz - (progn - (when (= head tail) - (do-input stream) - (setq head - (fd-stream-ibuf-head - stream) - tail - (fd-stream-ibuf-tail - stream))) - (bref sap (1- (incf head)))) - (lambda (n) (decf head n)))))) + (fd-stream-oc-state stream) + sz + (progn + (when (= head tail) + (let ((sofar (- head + (fd-stream-ibuf-head + stream)))) + (do-input stream) + (setq head + (+ (fd-stream-ibuf-head + stream) + sofar) + tail + (fd-stream-ibuf-tail + stream)))) + (bref sap (1- (incf head)))) + (lambda (n) (decf head n)))))) (declare (type index sz) (type (or null character) ch)) (when (null ch) @@ -2120,17 +2127,21 @@ (defun stream-reinit () (setf *available-buffers* nil) (setf *stdin* - (make-fd-stream 0 :name "Standard Input" :input t :buffering :line)) + (make-fd-stream 0 :name "Standard Input" :input t :buffering :line + :external-format :iso8859-1)) (setf *stdout* - (make-fd-stream 1 :name "Standard Output" :output t :buffering :line)) + (make-fd-stream 1 :name "Standard Output" :output t :buffering :line + :external-format :iso8859-1)) (setf *stderr* - (make-fd-stream 2 :name "Standard Error" :output t :buffering :line)) + (make-fd-stream 2 :name "Standard Error" :output t :buffering :line + :external-format :iso8859-1)) (let ((tty (and (not *batch-mode*) (unix:unix-open "/dev/tty" unix:o_rdwr #o666)))) (setf *tty* (if tty (make-fd-stream tty :name "the Terminal" :input t :output t - :buffering :line :auto-close t) + :buffering :line :auto-close t + :external-format :iso8859-1) (make-two-way-stream *stdin* *stdout*)))) nil) @@ -2169,7 +2180,6 @@ (fd-stream-pathname stream)))))) -;;;; Degenerate international character support: #+unicode (stream::def-ef-macro ef-strlen (extfmt lisp stream::+ef-max+ stream::+ef-str+) @@ -2186,28 +2196,20 @@ `(lambda (stream object &aux (count 0)) (declare (type fd-stream stream) (type (or character string) object) - #|(optimize (speed 3) (space 0) (safety 0))|#) - (labels ((eflen (code) - (stream::codepoint-to-octets ,extfmt code - (fd-stream-co-state stream) - (lambda (byte) - (declare (ignore byte)) - (incf count))))) - (etypecase object - (character (eflen (char-code object))) - (string - (do ((k 0) - (end (length object))) - ((>= k end)) - (multiple-value-bind (code widep) - (codepoint object k end) - (eflen code) - (if widep - (incf k 2) - (incf k)))))) - count)))) - - + #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#) + `(labels ((eflen (char) + (stream::char-to-octets ,extfmt char + ;;@@ FIXME: don't alter state! + (fd-stream-co-state stream) + (lambda (byte) + (declare (ignore byte)) + (incf count))))) + (etypecase object + (character (eflen object)) + (string (dovector (ch object) (eflen ch)))) + count)))) + + (defun file-string-length (stream object) (declare (type (or string character) object) (type (or file-stream broadcast-stream stream:simple-stream) stream)) diff --git a/code/stream.lisp b/code/stream.lisp index 83291d8f4..76bec897f 100644 --- a/code/stream.lisp +++ b/code/stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.86 2009/07/17 15:25:10 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.87 2009/08/10 16:47:41 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -298,28 +298,25 @@ ;; fundamental-stream :default)) -#+unicode +(defun %set-fd-stream-external-format (stream extfmt) + (declare (type fd-stream stream)) + (setf (fd-stream-external-format stream) + (stream::ef-name (stream::find-external-format extfmt)) + (fd-stream-oc-state stream) nil + (fd-stream-co-state stream) nil) + (when (fd-stream-ibuf-sap stream) ; input stream + (setf (fd-stream-in stream) (ef-cin extfmt))) + (when (fd-stream-obuf-sap stream) ; output stream + (setf (fd-stream-out stream) (ef-cout extfmt) + ;;@@ (fd-stream-sout stream) (ef-sout extfmt) + )) + extfmt) + +;; This is only used while building; it's reimplemented in +;; fd-stream-extfmt.lisp (defun (setf stream-external-format) (extfmt stream) - (declare (type stream stream)) - (stream-dispatch stream - ;; simple-stream - (error "Loading simple-streams should redefine this") - ;; lisp-stream - (typecase stream - (fd-stream (setf (fd-stream-external-format stream) - (if (eq extfmt :default) - :default - (stream::ef-name - (stream::find-external-format extfmt))) - (fd-stream-oc-state stream) nil - (fd-stream-co-state stream) nil) - extfmt) - (synonym-stream (setf (stream-external-format - (symbol-value (synonym-stream-symbol stream))) - extfmt)) - (t (error "Don't know how to set external-format for ~S." stream))) - ;; fundamental-stream - (error "Setting external-format on Gray streams not supported."))) + (declare (ignore stream)) + extfmt) (defun close (stream &key abort) "Closes the given Stream. No more I/O may be performed, but inquiries diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp index 44b8c282a..99d40075a 100644 --- a/compiler/fndb.lisp +++ b/compiler/fndb.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.138 2009/07/02 21:00:48 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.139 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1083,7 +1083,7 @@ :rename-and-delete :overwrite :append :supersede nil)) (:if-does-not-exist (member :error :create nil)) - (:external-format symbol) + (:external-format (or symbol list)) (:class (or symbol class)) (:mapped boolean) (:input-handle (or null fixnum stream)) diff --git a/pcl/simple-streams/classes.lisp b/pcl/simple-streams/classes.lisp index 3b637d8bd..fafea43f8 100644 --- a/pcl/simple-streams/classes.lisp +++ b/pcl/simple-streams/classes.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.7 2009/06/11 16:04:01 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.8 2009/08/10 16:47:41 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -106,13 +106,7 @@ (fmakunbound '(setf stream-external-format)) (defmethod (setf stream-external-format) (extfmt (stream sys:fd-stream)) - (setf (lisp::fd-stream-external-format stream) - (if (eq extfmt :default) - :default - (ef-name (find-external-format extfmt))) - (lisp::fd-stream-oc-state stream) nil - (lisp::fd-stream-co-state stream) nil) - extfmt) + (lisp::%set-fd-stream-external-format stream extfmt)) (defmethod (setf stream-external-format) (extfmt (stream synonym-stream)) (setf (stream-external-format (symbol-value (synonym-stream-symbol stream))) diff --git a/pcl/simple-streams/impl.lisp b/pcl/simple-streams/impl.lisp index 34c7d10de..86cf55554 100644 --- a/pcl/simple-streams/impl.lisp +++ b/pcl/simple-streams/impl.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.11 2009/07/23 21:37:00 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.12 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,7 @@ (defun %check (stream kind) (declare (type simple-stream stream) - (optimize (speed 3) (space 1) (safety 0))) + (optimize (speed 3) (space 1) (debug 0) (safety 0))) (with-stream-class (simple-stream stream) (cond ((not (any-stream-instance-flags stream :simple)) (%uninitialized stream)) @@ -169,52 +169,12 @@ t) nil)) -;; Stolen from ef-strlen in fd-stream.lisp. Just modified it to work -;; with simple-streams. -(def-ef-macro simple-stream-strlen (extfmt lisp +ef-max+ +ss-ef-str+) - (if (= (ef-min-octets (find-external-format extfmt)) - (ef-max-octets (find-external-format extfmt))) - `(lambda (stream object) - (declare (ignore stream) - (type (or character string) object) - (optimize (speed 3) (space 0) (safety 0))) - (etypecase object - (character ,(ef-min-octets (find-external-format extfmt))) - (string (* ,(ef-min-octets (find-external-format extfmt)) - (length object))))) - `(lambda (stream object &aux (count 0)) - (declare (type simple-stream stream) - (type (or character string) object) - #|(optimize (speed 3) (space 0) (safety 0))|#) - (with-stream-class (simple-stream stream) - (labels ((eflen (code) - (codepoint-to-octets ,extfmt code - (sm co-state stream) - (lambda (byte) - (declare (ignore byte)) - (incf count))))) - (etypecase object - (character (eflen (char-code object))) - (string - (do ((k 0) - (end (length object))) - ((>= k end)) - (multiple-value-bind (code widep) - (codepoint object k end) - (eflen code) - (if widep - (incf k 2) - (incf k)))))) - count))))) - (defun %file-string-length (stream object) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - ;; FIXME: need to account for compositions on the stream... - (with-stream-class (simple-stream stream) - (funcall (simple-stream-strlen (sm external-format stream)) - stream object)))) + (funcall (ef-strlen (sm external-format stream)) + stream object))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (optimize (speed 3) (space 1) (safety 0)) diff --git a/pcl/simple-streams/internal.lisp b/pcl/simple-streams/internal.lisp index 3203eb4e7..40649c19c 100644 --- a/pcl/simple-streams/internal.lisp +++ b/pcl/simple-streams/internal.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.8 2009/07/23 15:49:35 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.9 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -78,7 +78,7 @@ (type (or null kernel:simple-stream-buffer) buffer) (type fixnum start) (type (or null fixnum) end) - (optimize (speed 3) (space 2) (safety 0))) + (optimize (speed 3) (space 2) (safety 0) (debug 0))) (with-stream-class (simple-stream stream) (let ((fd (sm input-handle stream)) (end (or end (sm buf-len stream))) diff --git a/pcl/simple-streams/rt/simple-streams-test.lisp b/pcl/simple-streams/rt/simple-streams-test.lisp index 2d8ce5112..7a9a24fe9 100644 --- a/pcl/simple-streams/rt/simple-streams-test.lisp +++ b/pcl/simple-streams/rt/simple-streams-test.lisp @@ -20,6 +20,8 @@ (defparameter *test-file* (merge-pathnames #p"test-data.tmp" *test-path*)) +(defparameter *echo-server* "127.0.0.1") + (eval-when (:load-toplevel) (ensure-directories-exist *test-path* :verbose t)) @@ -33,6 +35,7 @@ (defun create-test-file (&key (filename *test-file*) (content *dumb-string*)) (with-open-file (s filename :direction :output + :external-format :latin-1 :if-does-not-exist :create :if-exists :supersede) (write-sequence content s))) @@ -51,15 +54,18 @@ (let ((create-file-stream (gensym))) `(progn (with-open-file (,create-file-stream ,file :direction :output + :external-format :latin-1 :if-exists :supersede :if-does-not-exist :create) (write-sequence ,initial-content ,create-file-stream)) (unwind-protect - (with-open-file (,stream ,file ,@open-arguments) + (with-open-file (,stream ,file ,@open-arguments + :external-format :latin-1) (progn ,@body)) ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) `(unwind-protect - (with-open-file (,stream ,file ,@open-arguments) + (with-open-file (,stream ,file ,@open-arguments + :external-format :latin-1) (progn ,@body)) ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) @@ -69,6 +75,7 @@ (with-open-stream (s (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite :if-does-not-exist :create)) (string= (write-string *dumb-string* s) *dumb-string*)) @@ -123,7 +130,7 @@ ;; get it echoed back. Obviously fails if the echo service isn't ;; enabled. (with-open-stream (s (make-instance 'socket-simple-stream - :remote-host "127.0.0.1" + :remote-host *echo-server* :remote-port 7 :direction :io)) (string= (prog1 @@ -137,6 +144,7 @@ ;; (single-channel simple-stream) (let* ((stream (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite :if-does-not-exist :create)) (content (make-string (1+ (device-buffer-length stream)) @@ -151,9 +159,9 @@ (deftest write-read-large-sc-2 (let* ((stream (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite - :if-does-not-exist :create - :external-format :iso8859-1)) + :if-does-not-exist :create)) (length (1+ (* 3 (device-buffer-length stream)))) (content (make-string length))) (dotimes (i (length content)) @@ -161,8 +169,7 @@ (with-open-stream (s stream) (write-string content s)) (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error - :external-format :iso8859-1) + :direction :input :if-does-not-exist :error) (let ((seq (make-string length))) #+nil (read-sequence seq s) #-nil (dotimes (i length) @@ -173,9 +180,9 @@ (deftest write-read-large-sc-read-seq-2 (let* ((stream (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite - :if-does-not-exist :create - :external-format :iso8859-1)) + :if-does-not-exist :create)) (length (1+ (* 3 (device-buffer-length stream)))) (content (make-string length))) (dotimes (i (length content)) @@ -183,8 +190,7 @@ (with-open-stream (s stream) (write-string content s)) (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error - :external-format :iso8859-1) + :direction :input :if-does-not-exist :error) (let ((seq (make-string length))) (read-sequence seq s) (string= content seq)))) @@ -193,9 +199,9 @@ (deftest write-read-large-sc-3 (let* ((stream (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite - :if-does-not-exist :create - :external-format :iso8859-1)) + :if-does-not-exist :create)) (length (1+ (* 3 (device-buffer-length stream)))) (content (make-array length :element-type '(unsigned-byte 8)))) (dotimes (i (length content)) @@ -203,8 +209,7 @@ (with-open-stream (s stream) (write-sequence content s)) (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error - :external-format :iso8859-1) + :direction :input :if-does-not-exist :error) (let ((seq (make-array length :element-type '(unsigned-byte 8)))) #+nil (read-sequence seq s) #-nil (dotimes (i length) @@ -215,9 +220,9 @@ (deftest write-read-large-sc-read-seq-3 (let* ((stream (make-instance 'file-simple-stream :filename *test-file* :direction :output + :external-format :latin-1 :if-exists :overwrite - :if-does-not-exist :create - :external-format :iso8859-1)) + :if-does-not-exist :create)) (length (1+ (* 3 (device-buffer-length stream)))) (content (make-array length :element-type '(unsigned-byte 8)))) (dotimes (i (length content)) @@ -225,8 +230,7 @@ (with-open-stream (s stream) (write-sequence content s)) (with-test-file (s *test-file* :class 'file-simple-stream - :direction :input :if-does-not-exist :error - :external-format :iso8859-1) + :direction :input :if-does-not-exist :error) (let ((seq (make-array length :element-type '(unsigned-byte 8)))) (read-sequence seq s) (equalp content seq)))) @@ -236,7 +240,7 @@ ;; Do write and read with more data than the buffer will hold ;; (dual-channel simple-stream; we only have socket streams atm) (let* ((stream (make-instance 'socket-simple-stream - :remote-host "127.0.0.1" + :remote-host *echo-server* :remote-port 7 :direction :io)) (content (make-string (1+ (device-buffer-length stream)) diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp index 7ee806ab5..9a0adfd62 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.19 2009/07/24 01:08:37 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.20 2009/08/10 16:47:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -127,503 +127,363 @@ (setf (sm last-char-read-size stream) 0) (bref (sm buffer stream) ptr)))) -;;;; -#+(or) -(defconstant +ef-obs-oc+ 0) -#+(or) -(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+) - (compile nil - `(lambda (state count input unput) - (multiple-value-bind (code width) - ,(octets-to-char extfmt state count (funcall input) - (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) - (funcall (ef-obs-oc-fn ,ef) ,state ,count ,input ,unput) - (setf ,state ,tmp3 ,count ,tmp2) - ,tmp1))) - -#+(or) -(defun ef-obs-co-fn (extfmt) - (or (aref (ef-cache extfmt) +ef-obs-co+) - (setf (aref (ef-cache extfmt) +ef-obs-co+) - (compile nil - `(lambda (code state output) - ,(char-to-octets extfmt code state - (lambda (x) (funcall output x))) - state))))) - -#+(or) -(defmacro %char-to-octets (ef char state output) - `(progn - (setf ,state (funcall (ef-obs-co-fn ,ef) ,char ,state ,output)) - nil)) - -#+(or) -(progn -(defconstant +ss-ef-rchar+ 0) -(defconstant +ss-ef-rchars+ 1) -(defconstant +ss-ef-wchar+ 2) -(defconstant +ss-ef-wchars+ 3) -(defconstant +ss-ef-max+ 4)) - -;; Read one character from a simple-stream. -(def-ef-macro %read-char-fn (ef simple-streams +ef-max+ +ss-ef-rchar+) - `(lambda (stream max refill) - (declare (type simple-stream stream) - (type function refill)) +(defconstant +ss-ef-strlen+ 0) +(defconstant +ss-ef-listen+ 1) +(defconstant +ss-ef-listen-mmapped+ 2) +(defconstant +ss-ef-cin+ 3) +(defconstant +ss-ef-cin-mmapped+ 4) +(defconstant +ss-ef-sin+ 5) +(defconstant +ss-ef-sin-mmapped+ 6) +(defconstant +ss-ef-unread+ 7) +(defconstant +ss-ef-out-sc+ 8) +(defconstant +ss-ef-sout-sc+ 9) +(defconstant +ss-ef-out-dc+ 10) +(defconstant +ss-ef-sout-dc+ 11) +(defconstant +ss-ef-max+ 12) + +;; ef-strlen implements file-string-length (see impl.lisp) +(def-ef-macro ef-strlen (ef simple-streams +ss-ef-max+ +ss-ef-strlen+) + (if (= (ef-min-octets (find-external-format ef)) + (ef-max-octets (find-external-format ef))) + `(lambda (stream object) + (declare (ignore stream)) + (etypecase object + (character ,(ef-min-octets (find-external-format ef))) + (string (* ,(ef-min-octets (find-external-format ef)) + (length object))))) + `(lambda (stream object &aux (count 0)) + (labels ((eflen (char) + ;;@@ FIXME: don't mess up stream state + (char-to-octets ,ef char (sm co-state stream) + (lambda (octet) + (declare (ignore octet)) + (incf count))))) + (declare (dynamic-extent #'eflen)) + (etypecase object + (character (eflen object)) + (string (dovector (ch object) (eflen ch))))) + count))) + +(def-ef-macro (sc listen :ef) (ef simple-streams +ss-ef-max+ +ss-ef-listen+) + `(lambda (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)) + (if (>= (- (sm buffer-ptr stream) buffpos) + ,(ef-max-octets (find-external-format ef))) + t + ;;@@ FIXME: don't mess up stream state + (and (octets-to-char ,ef (sm oc-state stream) cnt + (prog2 + (when (>= buffpos (sm buffer-ptr stream)) + (setf (sm last-char-read-size stream) + (+ lcrs cnt)) + (let ((bytes (refill-buffer stream nil))) + (setf (sm last-char-read-size stream) lcrs) + (cond ((= bytes 0) ; no data available + (return-from listen nil)) + ((< bytes 0) ; would block + (return-from listen t)) + ((>= (+ bytes cnt) + ,(ef-max-octets + (find-external-format ef))) + (return-from listen nil)) + (t + (setf buffpos + (sm buffpos stream)))))) + (bref buffer buffpos) + (incf buffpos)) + (lambda (n) + (decf buffpos n))) + nil)))))) + +;; for memory-mapped streams, READ-CHAR will never block: +(def-ef-macro (sc listen :ef mapped) (ef simple-stream +ss-ef-max+ + +ss-ef-listen-mmapped+) + `(lambda (stream) + (declare (ignore stream)) + t)) + +(def-ef-macro (sc read-char :ef) (ef simple-streams +ss-ef-max+ +ss-ef-cin+) + `(lambda (stream eof-error-p eof-value blocking) + (with-stream-class (simple-stream stream) + (let* ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (char (octets-to-char ,ef (sm oc-state stream) + (sm last-char-read-size stream) + (prog2 + (when (>= buffpos (sm buffer-ptr stream)) + (let ((bytes (refill-buffer stream blocking))) + (cond ((= bytes 0) + (return-from read-char nil)) + ((< bytes 0) + (return-from read-char + (lisp::eof-or-lose stream + eof-error-p + eof-value)))) + (setf buffpos (sm buffpos stream)))) + (bref buffer buffpos) + (incf buffpos)) + (lambda (n) (decf buffpos n)))) + (code (char-code char)) + (ctrl (sm control-in stream))) + (setf (sm buffpos stream) buffpos) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (lisp::eof-or-lose stream eof-error-p eof-value) + char))))) + +(def-ef-macro (sc read-char :ef mapped) (ef simple-streams +ss-ef-max+ + +ss-ef-cin-mmapped+) + `(lambda (stream eof-error-p eof-value blocking) + (declare (ignore blocking)) (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) max) - (setf max (funcall refill))) - (bref (sm buffer stream) (sm buffpos stream)) - (incf (sm buffpos stream))) - (lambda (n) (decf (sm buffpos stream) n)))))) - -;; Read many characters from a simple-stream and place them in a string. -(def-ef-macro %read-chars-fn (ef simple-streams +ef-max+ +ss-ef-rchars+) - `(lambda (stream string search start end max refill) - (declare (type simple-stream stream) - (type string string) - (type (or null character) search) - (type fixnum start end) - (type lisp::index max) - (type function refill)) + (let* ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (char (octets-to-char ,ef (sm oc-state stream) + (sm last-char-read-size stream) + (prog2 + (when (>= buffpos (sm buf-len stream)) + (return-from read-char + (lisp::eof-or-lose stream + eof-error-p eof-value))) + (bref buffer buffpos) + (incf buffpos)) + (lambda (n) (decf buffpos n)))) + (code (char-code char)) + (ctrl (sm control-in stream))) + (setf (sm buffpos stream) buffpos) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (lisp::eof-or-lose stream eof-error-p eof-value) + char))))) + +(def-ef-macro (sc read-chars :ef) (ef simple-streams +ss-ef-max+ +ss-ef-sin+) + `(lambda (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 + (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)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs) + (values count nil)) + (declare (type lisp::index buffpos buffer-ptr posn count)) + (let* ((cnt 0) + (char (octets-to-char ,ef (sm oc-state stream) cnt + (prog2 + (when (>= buffpos buffer-ptr) + (setf (sm last-char-read-size stream) lcrs) + (let ((bytes (refill-buffer stream blocking))) + (setf buffpos (sm buffpos stream) + buffer-ptr (sm buffer-ptr stream)) + (unless (plusp bytes) + (if (zerop bytes) + (return (values count nil)) + (return (values count :eof)))))) + (bref buffer buffpos) + (incf buffpos)) + (lambda (n) (decf buffpos n)))) + (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) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + +(def-ef-macro (sc read-chars :ef mapped) (ef simple-streams +ss-ef-max+ + +ss-ef-sin-mmapped+) + `(lambda (stream string search start end blocking) (with-stream-class (simple-stream stream) - (do ((posn start (1+ posn)) + (do ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (buf-len (sm buf-len stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (posn start (1+ posn)) (count 0 (1+ count))) - ((>= posn end) (values count nil)) - (declare (type lisp::index posn count)) - (flet ((output (char code ctrl) - (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))))) - (let ((code (octets-to-codepoint ,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))))) - (multiple-value-bind (hi lo) - (lisp::surrogates code) - (output hi (char-code hi) (sm control-in stream)) - ;; What do we do if the low (trailing surrogate) wants - ;; to be placed after the specified end of the string? - (when lo - (incf posn) - (incf count) - (output lo (char-code lo) (sm control-in stream)))))))))) - -(def-ef-macro %sc-write-char-fn (ef simple-streams +ef-max+ +ss-ef-wchar+) + ((>= posn end) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs) + (values count nil)) + (declare (type lisp::index buffpos buffer-ptr posn count)) + (let* ((cnt 0) + (char (octets-to-char ,ef (sm oc-state stream) cnt + (prog2 + (when (>= buffpos buf-len) + (return (values count :eof))) + (bref buffer buffpos) + (incf buffpos)) + (lambda (n) (decf buffpos n)))) + (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) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + +(def-ef-macro (sc unread-char :ef) (ef simple-streams +ss-ef-max+ + +ss-ef-unread+) + `(lambda (stream relaxed) + (declare (ignore relaxed)) + (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 "This shouldn't happen.")))))) + +(def-ef-macro (sc write-char :ef) (ef simple-streams +ss-ef-max+ + +ss-ef-out-sc+) `(lambda (character stream) - (declare (type simple-stream stream)) - (when character - (with-stream-class (simple-stream stream) + (with-stream-class (single-channel-simple-stream stream) + (when character (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)))) + (char-to-octets ,ef character (sm co-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)) + (incf (sm charpos stream)))))) + character))) -(def-ef-macro %sc-write-chars-fn (ef simple-streams +ef-max+ +ss-ef-wchars+) +(def-ef-macro (sc write-chars :ef) (ef simple-streams +ss-ef-max+ + +ss-ef-sout-sc+) `(lambda (string stream start end) - (declare (string string) - (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (do ((ef (sm external-format stream)) - (len (length string)) + (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)) (ctrl (sm control-out stream)) (posn start (1+ posn)) (count 0 (1+ count))) - ((>= posn end) - count) - (declare (type fixnum posn count)) - (flet ((output (code) - (unless (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream (code-char code))) - (codepoint-to-octets ,ef - code - (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))))) - (multiple-value-bind (code widep) - (lisp::codepoint string posn len) - (output code) - (when widep - (incf posn) - (incf count)))))))) - - -(def-ef-macro %dc-write-char-fn (ef simple-streams +ef-max+ +ss-ef-wchar+) + ((>= 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))) + (unless (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream char)) + (char-to-octets ,ef char (sm co-state stream) + (lambda (byte) + (when (>= buffpos buf-len) + (setf (sm buffpos stream) buffpos) + (setq buffpos (flush-buffer stream t))) + (setf (bref buffer buffpos) byte) + (incf buffpos))) + (setf (sm buffpos stream) buffpos) + (when (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 + +(def-ef-macro (dc write-char :ef) (ef simple-streams +ss-ef-max+ + +ss-ef-out-dc+) `(lambda (character stream) - (declare (type simple-stream stream)) - (when character - (with-stream-class (dual-channel-simple-stream stream) + (with-stream-class (dual-channel-simple-stream stream) + (when character (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)))) + (char-to-octets ,ef character (sm co-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)) + (incf (sm charpos stream)))))) + character))) -(def-ef-macro %dc-write-chars-fn (ef simple-streams +ef-max+ +ss-ef-wchars+) +(def-ef-macro (dc write-chars :ef) (ef simple-streams +ss-ef-max+ + +ss-ef-sout-dc+) `(lambda (string stream start end) - (declare (string string) - (type simple-stream stream)) - (with-stream-class (simple-stream stream) - (do ((ef (sm external-format stream)) - (len (length string)) + (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)) (posn start (1+ posn)) (count 0 (1+ count))) - ((>= posn end) - count) - (declare (type fixnum posn count)) - (flet ((output (code) - (unless (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream (code-char code))) - (codepoint-to-octets ef - code - (sm oc-state stream) - (lambda (byte) - (when (>= (sm buffpos 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))))) - (multiple-value-bind (code widep) - (lisp::codepoint string posn len) - (output code) - (when widep - (incf posn) - (incf count)))))))) - -;;;; 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)) - (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 listen nil)) - ((< bytes 0) - (return-from listen 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))) - (format t "listen on ~S~%" stream) - (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))) -#-(or) -(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) - (flet ((refill () - ;; if stream is single-channel and mode == 3, - ;; flush the buffer (if it's dirty) - (let ((bytes (refill-buffer stream blocking))) - (cond ((= bytes 0) - (return-from read-char nil)) - ((minusp bytes) - (return-from read-char - (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 (sm buffer-ptr stream) #'refill)) - (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))) - (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)))|# - (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)) - ;; if stream is single-channel and mode == 3, - ;; flush the buffer (if it's dirty) - (let ((bytes (refill-buffer stream blocking))) - (cond ((= bytes 0) - (return-from read-char nil)) - ((minusp bytes) - (return-from read-char - (lisp::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) - (lisp::eof-or-lose stream eof-error-p eof-value) - char)))))) - - -(declaim (ftype j-read-char-fn (sc read-char :ef mapped))) -#-(or) -(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) - (flet ((refill () - (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 (sm buf-len stream) #'refill)) - (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))) - (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)))|# - (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 buf-len stream)) - (return-from read-char - (lisp::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) - (lisp::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 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 (simple-stream stream) - ;; if stream is single-channel and mode == 3, flush buffer (if dirty) - (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))) -(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) - (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) - (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))) -(defun (sc unread-char :ef) (stream relaxed) - (declare (ignore relaxed)) - (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 "This shouldn't happen."))))) - -(declaim (ftype j-write-char-fn (sc write-char :ef))) -(defun (sc write-char :ef) (character stream) - (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 (simple-stream stream) - (funcall (%sc-write-chars-fn (sm external-format stream)) - string stream start end))) - - -;;;; 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) - (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) - (funcall (%dc-write-chars-fn (sm external-format stream)) - string stream start end))) + ((>= 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)) + (char-to-octets ,ef char (sm co-state stream) + (lambda (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))) + (setf (sm outpos stream) outpos) + (when (sm charpos stream) + (incf (sm charpos stream))))))))) ;;;; String-Simple-Stream strategy functions (declaim (ftype j-read-char-fn (str read-char))) -#+(or) (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))|#) (with-stream-class (string-input-simple-stream stream) (when (any-stream-instance-flags stream :eof) - (lisp::eof-or-lose stream eof-error-p eof-value)) + (return-from read-char + (lisp::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) @@ -639,56 +499,6 @@ (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 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) - (lisp::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 (composing-stream stream) - (funcall-stm-handler j-unread-char (sm melded-stream stream) nil))) - ;;;; Functions to install the strategy functions in the appropriate slots @@ -726,8 +536,9 @@ (defun %sf (kind name format &optional access) (or (ignore-errors (fdefinition (list kind name format access))) (ignore-errors (fdefinition (list kind name format))) - (ignore-errors (fdefinition (list kind name :ef access))) - (fdefinition (list kind name :ef)))) + (ignore-errors (funcall (fdefinition (list kind name :ef access)) + format)) + (funcall (fdefinition (list kind name :ef)) format))) (defun install-single-channel-character-strategy (stream external-format access) @@ -816,6 +627,7 @@ (setf (sm external-format stream) (find-external-format ef))) ef) +#+(or) ;; this is duplicated in classes.lisp (defmethod (setf stream-external-format) :after (ef (stream single-channel-simple-stream)) (with-stream-class (single-channel-simple-stream stream) @@ -823,9 +635,9 @@ (install-single-channel-character-strategy (melding-stream stream) ef nil))) +#+(or) ;; this is duplicated in classes.lisp (defmethod (setf stream-external-format) :after (ef (stream dual-channel-simple-stream)) (with-stream-class (dual-channel-simple-stream stream) (compose-encapsulating-streams stream ef) (install-dual-channel-character-strategy (melding-stream stream) ef))) - -- GitLab