From: Rudi Schlatte Date: Sun, 21 Mar 2004 13:18:43 +0000 (+0000) Subject: 0.8.8.33: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dfc38e049f0a3dca0e5de64f712db47ed9ddedcd;p=sbcl.git 0.8.8.33: * Implement read-sequence, write-sequence for sequences of type (unsigned-byte 8), (signed-byte 8), add test case * Prettier print-object method for socket simple-streams --- diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index a8adfa0..c537300 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -475,38 +475,46 @@ (defun %read-sequence (stream seq start end partial-fill) (declare (type simple-stream stream) (type sequence seq) - (type sb-int:index start) - (type (or null sb-int:index) end) + (type sb-int:index start end) (type boolean partial-fill)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-sequence 0)) + (when (and (not (any-stream-instance-flags stream :dual :string)) + (sc-dirty-p stream)) + (flush-buffer stream t)) (etypecase seq (string (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil - start (or end (length seq)) + start end (if partial-fill :bnb t))) ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) + (when (any-stream-instance-flags stream :string) + (error "Can't read into byte sequence from a string stream.")) ;; "read-vector" equivalent, but blocking if partial-fill is NIL - (error "implement me") - ) + ;; FIXME: this could be implemented faster via buffer-copy + (loop with encap = (sm melded-stream stream) + for index from start below end + for byte = (read-byte-internal encap nil nil t) + then (read-byte-internal encap nil nil partial-fill) + while byte + do (setf (bref seq index) byte) + finally (return index))) ;; extend to work on other sequences: repeated read-byte ))) - (defun %write-sequence (stream seq start end) (declare (type simple-stream stream) (type sequence seq) - (type sb-int:index start) - (type (or null sb-int:index) end)) + (type sb-int:index start end)) (with-stream-class (simple-stream stream) (%check stream :output) (etypecase seq (string (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream) - start (or end (length seq)))) + start end)) ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent @@ -514,31 +522,43 @@ (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (loop with max-ptr = (sm buf-len stream) - with real-end = (or end (length seq)) - for src-pos = start then (+ src-pos count) - for src-rest = (- real-end src-pos) + (loop with max-ptr fixnum = (sm buf-len stream) + for src-pos fixnum = start then (+ src-pos count) + for src-rest fixnum = (- end src-pos) while (> src-rest 0) ; FIXME: this is non-ANSI - for ptr = (let ((ptr (sm buffpos stream))) - (if (>= ptr max-ptr) - (flush-buffer stream t) - ptr)) - for buf-rest = (- max-ptr ptr) - for count = (min buf-rest src-rest) + for ptr fixnum = (let ((ptr (sm buffpos stream))) + (if (>= ptr max-ptr) + (flush-buffer stream t) + ptr)) + for buf-rest fixnum = (- max-ptr ptr) + for count fixnum = (min buf-rest src-rest) do (progn (setf (sm mode stream) 1) (setf (sm buffpos stream) (+ ptr count)) (buffer-copy seq src-pos (sm buffer stream) ptr count))))) (dual-channel-simple-stream - (error "Implement me")) + (with-stream-class (dual-channel-simple-stream stream) + (loop with max-ptr fixnum = (sm max-out-pos stream) + for src-pos fixnum = start then (+ src-pos count) + for src-rest fixnum = (- end src-pos) + while (> src-rest 0) ; FIXME: this is non-ANSI + for ptr fixnum = (let ((ptr (sm outpos stream))) + (if (>= ptr max-ptr) + (flush-out-buffer stream t) + ptr)) + for buf-rest fixnum = (- max-ptr ptr) + for count fixnum = (min buf-rest src-rest) + do (progn (setf (sm outpos stream) (+ ptr count)) + (buffer-copy seq src-pos (sm out-buffer stream) ptr count))))) (string-simple-stream (error 'simple-type-error :datum stream :expected-type 'stream - :format-control "Can't write-byte on string streams." + :format-control "Can't write a byte sequence to a string stream." :format-arguments '()))) ) ;; extend to work on other sequences: repeated write-byte - ))) + )) + seq) (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8)) @@ -549,27 +569,27 @@ (etypecase stream (simple-stream (with-stream-class (simple-stream stream) - (if (stringp vector) - (let* ((start (or start 0)) - (end (or end (length vector))) - (encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap nil nil t))) - (when char - (setf (schar vector start) char) - (incf start) - (+ start (funcall-stm-handler j-read-chars encap vector nil - start end nil)))) - (do* ((j-read-byte (if (any-stream-instance-flags stream :string) - (error "Can't READ-BYTE on string streams.") - #'read-byte-internal)) - (encap (sm melded-stream stream)) - (index (or start 0) (1+ index)) - (end (or end (* (length vector) (vector-elt-width vector)))) - (endian-swap (endian-swap-value vector endian-swap)) - (byte (funcall j-read-byte encap nil nil t) - (funcall j-read-byte encap nil nil nil))) - ((or (null byte) (>= index end)) index) - (setf (bref vector (logxor index endian-swap)) byte))))) + (cond ((stringp vector) + (let* ((start (or start 0)) + (end (or end (length vector))) + (encap (sm melded-stream stream)) + (char (funcall-stm-handler j-read-char encap nil nil t))) + (when char + (setf (schar vector start) char) + (incf start) + (+ start (funcall-stm-handler j-read-chars encap vector nil + start end nil))))) + ((any-stream-instance-flags stream :string) + (error "Can't READ-BYTE on string streams.")) + (t + (do* ((encap (sm melded-stream stream)) + (index (or start 0) (1+ index)) + (end (or end (* (length vector) (vector-elt-width vector)))) + (endian-swap (endian-swap-value vector endian-swap)) + (byte (read-byte-internal encap nil nil t) + (read-byte-internal encap nil nil nil))) + ((or (null byte) (>= index end)) index) + (setf (bref vector (logxor index endian-swap)) byte)))))) ((or ansi-stream fundamental-stream) (unless (typep vector '(or string (simple-array (signed-byte 8) (*)) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 6515a94..3987d08 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -28,6 +28,15 @@ collect val into result finally (return (nconc result rest)))) +(defun create-test-file (&key (filename *test-file*) (content *dumb-string*)) + (with-open-file (s filename :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (write-sequence content s))) + +(defun remove-test-file (&key (filename *test-file*)) + (delete-file filename)) + (defmacro with-test-file ((stream file &rest open-arguments &key (delete-afterwards t) initial-content @@ -51,7 +60,6 @@ (progn ,@body)) ,(when delete-afterwards `(ignore-errors (delete-file ,file)))))) - (deftest create-file-1 ;; Create a file-simple-stream, write data. (prog1 @@ -115,6 +123,7 @@ :direction :io)) (string= (prog1 (write-line "Got it!" s) (finish-output s)) (read-line s))) + ;; Fail gracefully if echo isn't activated on the system (sb-bsd-sockets::connection-refused-error () t)) t) @@ -187,6 +196,7 @@ (with-open-stream (s stream) (string= (prog1 (write-line content s) (finish-output s)) (read-line s)))) + ;; Fail gracefully if echo isn't activated on the system (sb-bsd-sockets::connection-refused-error () t)) t) @@ -308,3 +318,31 @@ "XooX" T) +(deftest write-read-mixed-sc-1 + ;; Test read/write-sequence of types string and (unsigned-byte 8) + (let ((uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 64)) + (svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element -1)) + (result-uvector (make-array '(10) :element-type '(unsigned-byte 8) + :initial-element 0)) + (result-svector (make-array '(10) :element-type '(signed-byte 8) + :initial-element 0)) + (result-string (make-string (length *dumb-string*) + :initial-element #\Space))) + (with-test-file (s *test-file* :class 'file-simple-stream :direction :io + :if-exists :overwrite :if-does-not-exist :create + :delete-afterwards nil) + (write-sequence svector s) + (write-sequence uvector s) + (write-sequence *dumb-string* s)) + (with-test-file (s *test-file* :class 'file-simple-stream + :direction :input :if-does-not-exist :error + :delete-afterwards nil) + (read-sequence result-svector s) + (read-sequence result-uvector s) + (read-sequence result-string s)) + (and (string= *dumb-string* result-string) + (equalp uvector result-uvector) + (equalp svector result-svector))) + T) diff --git a/contrib/sb-simple-streams/socket.lisp b/contrib/sb-simple-streams/socket.lisp index d08cb17..b39fe67 100644 --- a/contrib/sb-simple-streams/socket.lisp +++ b/contrib/sb-simple-streams/socket.lisp @@ -20,6 +20,20 @@ (socket :initform nil :type (or sb-bsd-sockets:socket null) :initarg :socket))) +(defmethod print-object ((object socket-simple-stream) stream) + (print-unreadable-object (object stream :type nil :identity nil) + (with-stream-class (socket-simple-stream object) + (cond ((not (any-stream-instance-flags object :simple)) + (princ "Invalid " stream)) + ((not (any-stream-instance-flags object :input :output)) + (princ "Closed " stream))) + (format stream "~:(~A~)" + (type-of object)) + (when (any-stream-instance-flags object :input :output) + (multiple-value-bind (host port) + (sb-bsd-sockets:socket-peername (sm socket object)) + (format stream " connected to host ~S, port ~S" host port)))))) + (def-stream-class socket-base-simple-stream (dual-channel-simple-stream) ()) @@ -29,7 +43,7 @@ (socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (unless (and remote-host remote-port) - (error "~S requires :remote-host and :remote-port arguments" + (error "device-open on ~S requires :remote-host and :remote-port arguments" 'socket-simple-stream)) (with-stream-class (socket-simple-stream stream) (ecase (getf options :direction :input) diff --git a/version.lisp-expr b/version.lisp-expr index e8e0494..3354bc0 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.8.8.32" +"0.8.8.33"