From: Rudi Schlatte Date: Tue, 28 Jun 2005 14:22:37 +0000 (+0000) Subject: 0.9.2.3: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=56ee3433c3c2258e48fb799719688f29c71e05d4;p=sbcl.git 0.9.2.3: bivalent streams: streams opened with :element-type :default now allow character and binary (unsigned-byte 8) I/O --- diff --git a/NEWS b/NEWS index 8865378..d453f8b 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,7 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2: + * New feature: Experimental support for bivalent streams: streams + opened with :element-type :default now allow character and binary + (unsigned-byte 8) I/O * Support for the koi8-r external format. (thanks to Ivan Boldyrev) changes in sbcl-0.9.2 relative to sbcl-0.9.1: diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 60aeadb..8e858f4 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1330,19 +1330,34 @@ ;;; Fill in the various routine slots for the given type. INPUT-P and ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be ;;; set prior to calling this routine. -(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p) - (let ((target-type (case type - ((:default unsigned-byte) - '(unsigned-byte 8)) - (signed-byte - '(signed-byte 8)) - (t - type))) - (input-type nil) - (output-type nil) - (input-size nil) - (output-size nil) - (character-stream-p (subtypep type 'character))) +(defun set-fd-stream-routines (fd-stream element-type external-format + input-p output-p buffer-p) + (let* ((target-type (case element-type + (unsigned-byte '(unsigned-byte 8)) + (signed-byte '(signed-byte 8)) + (:default 'character) + (t element-type))) + (character-stream-p (subtypep target-type 'character)) + (bivalent-stream-p (eq element-type :default)) + normalized-external-format + (bin-routine #'ill-bin) + (bin-type nil) + (bin-size nil) + (cin-routine #'ill-in) + (cin-type nil) + (cin-size nil) + (input-type nil) ;calculated from bin-type/cin-type + (input-size nil) ;calculated from bin-size/cin-size + (read-n-characters #'ill-in) + (bout-routine #'ill-bout) + (bout-type nil) + (bout-size nil) + (cout-routine #'ill-out) + (cout-type nil) + (cout-size nil) + (output-type nil) + (output-size nil) + (output-bytes #'ill-bout)) ;; drop buffers when direction changes (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) @@ -1351,101 +1366,121 @@ (when (and (fd-stream-ibuf-sap fd-stream) (not input-p)) (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) (setf (fd-stream-ibuf-sap fd-stream) nil)) + (when input-p + (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer)) + (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer) + (setf (fd-stream-ibuf-tail fd-stream) 0)) + (when output-p + (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer)) + (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer) + (setf (fd-stream-obuf-tail fd-stream) 0) + (setf (fd-stream-char-pos fd-stream) 0)) (when (and character-stream-p - (eq (fd-stream-external-format fd-stream) :default)) + (eq external-format :default)) (/show0 "/getting default external format") - (setf (fd-stream-external-format fd-stream) - (default-external-format)) + (setf external-format (default-external-format)) (/show0 "cold-printing defaulted external-format:") #!+sb-show - (cold-print (fd-stream-external-format fd-stream)) + (cold-print external-format) (/show0 "matching to known aliases") (dolist (entry *external-formats* (restart-case (error "Invalid external-format ~A" - (fd-stream-external-format fd-stream)) + external-format) (use-default () :report "Set external format to LATIN-1" - (setf (fd-stream-external-format fd-stream) :latin-1)))) + (setf external-format :latin-1)))) (/show0 "cold printing known aliases:") #!+sb-show (dolist (alias (first entry)) (cold-print alias)) (/show0 "done cold-printing known aliases") - (when (member (fd-stream-external-format fd-stream) (first entry)) + (when (member external-format (first entry)) (/show0 "matched") (return))) (/show0 "/default external format ok")) (when input-p - (multiple-value-bind (routine type size read-n-characters - normalized-external-format) - (pick-input-routine target-type - (fd-stream-external-format fd-stream)) - (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) - (unless routine - (error "could not find any input routine for ~S" target-type)) - (if character-stream-p - (setf (fd-stream-in fd-stream) routine - (fd-stream-bin fd-stream) #'ill-bin) - (setf (fd-stream-in fd-stream) #'ill-in - (fd-stream-bin fd-stream) routine)) - (when (eql size 1) - (setf (fd-stream-n-bin fd-stream) - (if character-stream-p - read-n-characters - #'fd-stream-read-n-bytes)) - (when (and buffer-p - ;; We only create this buffer for streams of type - ;; (unsigned-byte 8). Because there's no buffer, the - ;; other element-types will dispatch to the appropriate - ;; input (output) routine in fast-read-byte. - (or character-stream-p - (equal target-type '(unsigned-byte 8))) - (not output-p) ; temporary disable on :io streams - #+(or) - (or (eq type 'unsigned-byte) - (eq type :default))) - (if character-stream-p - (setf (ansi-stream-cin-buffer fd-stream) - (make-array +ansi-stream-in-buffer-length+ - :element-type 'character)) - (setf (ansi-stream-in-buffer fd-stream) - (make-array +ansi-stream-in-buffer-length+ - :element-type '(unsigned-byte 8)))))) - (setf input-size size) - (setf input-type type))) + (when (or (not character-stream-p) bivalent-stream-p) + (multiple-value-setq (bin-routine bin-type bin-size read-n-characters + normalized-external-format) + (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) + target-type) + external-format)) + (unless bin-routine + (error "could not find any input routine for ~S" target-type))) + (when character-stream-p + (multiple-value-setq (cin-routine cin-type cin-size read-n-characters + normalized-external-format) + (pick-input-routine target-type external-format)) + (unless cin-routine + (error "could not find any input routine for ~S" target-type))) + (setf (fd-stream-in fd-stream) cin-routine + (fd-stream-bin fd-stream) bin-routine) + ;; character type gets preferential treatment + (setf input-size (or cin-size bin-size)) + (setf input-type (or cin-type bin-type)) + (when normalized-external-format + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) + (when (= (or cin-size 1) (or bin-size 1) 1) + (setf (fd-stream-n-bin fd-stream) ;XXX + (if (and character-stream-p (not bivalent-stream-p)) + read-n-characters + #'fd-stream-read-n-bytes)) + ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on + ;; for character and (unsigned-byte 8) streams. In these + ;; cases, fast-read-* will read from the + ;; ansi-stream-(c)in-buffer, saving function calls. + ;; Otherwise, the various data-reading functions in the stream + ;; structure will be called. + (when (and buffer-p + (not bivalent-stream-p) + ;; temporary disable on :io streams + (not output-p)) + (cond (character-stream-p + (setf (ansi-stream-cin-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type 'character))) + ((equal target-type '(unsigned-byte 8)) + (setf (ansi-stream-in-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type '(unsigned-byte 8)))))))) (when output-p - (multiple-value-bind (routine type size output-bytes - normalized-external-format) + (when (or (not character-stream-p) bivalent-stream-p) + (multiple-value-setq (bout-routine bout-type bout-size output-bytes + normalized-external-format) + (pick-output-routine (if bivalent-stream-p + '(unsigned-byte 8) + target-type) + (fd-stream-buffering fd-stream) + external-format)) + (unless bout-routine + (error "could not find any output routine for ~S buffered ~S" + (fd-stream-buffering fd-stream) + target-type))) + (when character-stream-p + (multiple-value-setq (cout-routine cout-type cout-size output-bytes + normalized-external-format) (pick-output-routine target-type (fd-stream-buffering fd-stream) - (fd-stream-external-format fd-stream)) - (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) - (unless routine + external-format)) + (unless cout-routine (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) - target-type)) - (when character-stream-p - (setf (fd-stream-output-bytes fd-stream) output-bytes)) - (if character-stream-p - (setf (fd-stream-out fd-stream) routine - (fd-stream-bout fd-stream) #'ill-bout) - (setf (fd-stream-out fd-stream) - (or (if (eql size 1) - (pick-output-routine - 'base-char (fd-stream-buffering fd-stream))) - #'ill-out) - (fd-stream-bout fd-stream) routine)) - (setf (fd-stream-sout fd-stream) - (if (eql size 1) #'fd-sout #'ill-out)) - (setf output-size size) - (setf output-type type))) + target-type))) + (when normalized-external-format + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) + (when character-stream-p + (setf (fd-stream-output-bytes fd-stream) output-bytes)) + (setf (fd-stream-out fd-stream) cout-routine + (fd-stream-bout fd-stream) bout-routine + (fd-stream-sout fd-stream) (if (eql cout-size 1) + #'fd-sout #'ill-out)) + (setf output-size (or cout-size bout-size)) + (setf output-type (or cout-type bout-type))) (when (and input-size output-size (not (eq input-size output-size))) @@ -1758,16 +1793,8 @@ :dual-channel-p dual-channel-p :external-format external-format :timeout timeout))) - (when input - (setf (fd-stream-ibuf-sap stream) (next-available-buffer)) - (setf (fd-stream-ibuf-length stream) bytes-per-buffer) - (setf (fd-stream-ibuf-tail stream) 0)) - (when output - (setf (fd-stream-obuf-sap stream) (next-available-buffer)) - (setf (fd-stream-obuf-length stream) bytes-per-buffer) - (setf (fd-stream-obuf-tail stream) 0) - (setf (fd-stream-char-pos stream) 0)) - (set-fd-stream-routines stream element-type input output input-buffer-p) + (set-fd-stream-routines stream element-type external-format + input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream (lambda () diff --git a/tests/bivalent-stream.impure.lisp b/tests/bivalent-stream.impure.lisp new file mode 100644 index 0000000..faf21e3 --- /dev/null +++ b/tests/bivalent-stream.impure.lisp @@ -0,0 +1,37 @@ +;;;; This file is for testing bivalent stream functionality, using +;;;; test machinery which might have side effects (e.g. executing +;;;; DEFUN, writing files). Note that the tests here might reach into +;;;; unexported functionality, and should not be used as a guide for +;;;; users. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; Test character decode restarts. +(with-open-file (s "bivalent-stream-test.txt" :direction :output + :if-exists :supersede + :element-type :default :external-format :utf-8) + (write-byte 65 s) + (write-char #\B s) + (write-byte #xe0 s) + (write-char #\C s)) + +(with-open-file (s "bivalent-stream-test.txt" :direction :input + :element-type :default + :external-format :utf-8) + (assert (eql (read-char s nil s) #\A)) + (assert (eql (read-byte s nil s) 66)) + (assert (eql (read-byte s nil s) #xe0)) + (assert (eql (read-char s nil s) #\C))) + +(delete-file "bivalent-stream-test.txt") + +(sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index c9e0ddc..67b0c76 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.2.2" +"0.9.2.3"