From: Christophe Rhodes Date: Tue, 20 May 2003 14:42:25 +0000 (+0000) Subject: 0.8alpha.0.42: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=inline;h=59f1de77587818635573073a14ce80c2d398f56c;p=sbcl.git 0.8alpha.0.42: improvements to sb-simple-streams contrib (from Rudi Schlatte) ... don't spam *features* anymore ... writes of large chunks of data work now, instead of failing silently --- diff --git a/contrib/sb-simple-streams/TODO b/contrib/sb-simple-streams/TODO index 0d4eb4c..2a9cd73 100644 --- a/contrib/sb-simple-streams/TODO +++ b/contrib/sb-simple-streams/TODO @@ -10,3 +10,6 @@ - Implement string streams. +- Make sure the code examples for stream encapsulation from Franz work + +- Test every single output function diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp index c611bff..1ade55e 100644 --- a/contrib/sb-simple-streams/classes.lisp +++ b/contrib/sb-simple-streams/classes.lisp @@ -8,11 +8,7 @@ (in-package "SB-SIMPLE-STREAMS") -;;; -;;; BANNER ADS!! -;;; - -(pushnew :sb-simple-stream *features*) +;;; (pushnew :sb-simple-stream *features*) (eval-when (:compile-toplevel :load-toplevel :execute) #+(or X86) (pushnew :little-endian *features*)) diff --git a/contrib/sb-simple-streams/fndb.lisp b/contrib/sb-simple-streams/fndb.lisp index 20b3d1c..1b28ec5 100644 --- a/contrib/sb-simple-streams/fndb.lisp +++ b/contrib/sb-simple-streams/fndb.lisp @@ -10,25 +10,59 @@ ;; .../compiler/knownfun.lisp -;; TODO: I suppose sbcl internals have sufficiently diverged from -;; cmucl that this does not work after my primitive translation -;; attempt. This is used in the cmucl version to compute (via -;; :derive-type arg to defknown) the return type of open. For the -;; time being, the new defknown form for open does not specify its -;; return type. -#+nil + +#|| + +Paul Foley (private conversation, 2003-05-17): + +BTW, the RESULT-TYPE-OPEN-CLASS function in fndb.lisp is buggy. +Here's a (smarter) replacement: + +;; .../compiler/knownfun.lisp (defun result-type-open-class (call) (declare (type sb-c::combination call)) - (do ((args (sb-c::combination-args call) (cdr args))) - ((null args)) - (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (car args))))) - (when (and (typep leaf 'sb-kernel:constant) - (eq (sb-c::constant-value leaf) :class) - (cdr args)) - (let ((leaf (sb-c::ref-leaf (sb-c::continuation-use (cadr args))))) - (return (if (typep leaf 'sb-kernel:constant) - (find-class (sb-c::constant-value leaf) nil) - nil))))))) + (let* ((not-set '#:not-set) + (not-constant '#:not-constant) + (direction not-set) + (if-exists not-set) + (if-does-not-exist not-set) + (class not-set)) + ;; find (the first occurence of) each interesting keyword argument + (do ((args (cdr (combination-args call)) (cddr args))) + ((null args)) + (macrolet ((maybe-set (var) + `(when (and (eq ,var not-set) (cadr args)) + (if (constant-continuation-p (cadr args)) + (setq ,var (continuation-value (cadr args))) + (setq ,var not-constant))))) + (case (continuation-value (car args)) + (:direction (maybe-set direction)) + (:if-exists (maybe-set if-exists)) + (:if-does-not-exist (maybe-set if-does-not-exist)) + (:class (maybe-set class))))) + ;; and set default values for any that weren't set above + (when (eq direction not-set) (setq direction :input)) + (when (eq if-exists not-constant) (setq if-exists nil)) + (when (eq if-does-not-exist not-constant) (set if-does-not-exist nil)) + (when (or (eq class not-set) (eq class not-constant)) (setq class 'stream)) + ;; now, NIL is a possible result only in the following cases: + ;; direction is :probe or not-constant and :if-does-not-exist is not + ;; :error + ;; direction is :output or :io or not-constant and :if-exists is nil + ;; :if-does-not-exist is nil + (if (or (and (or (eq direction :probe) (eq direction not-constant)) + (not (eq if-does-not-exist :error))) + (and (or (eq direction :output) (eq direction :io) + (eq direction not-constant)) + (eq if-exists nil)) + (eq if-does-not-exist nil)) + (specifier-type `(or null ,class)) + (specifier-type class)))) + +TODO (rudi 2003-05-19): make the above work, make (defknown open) use it. + +||# + (handler-bind ((error #'(lambda (condition) (declare (ignore condition)) (continue)))) diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp index 3d334ee..735b154 100644 --- a/contrib/sb-simple-streams/simple-stream-tests.lisp +++ b/contrib/sb-simple-streams/simple-stream-tests.lisp @@ -97,3 +97,36 @@ (sb-bsd-sockets::connection-refused-error () t)) t) +(deftest write-read-large-sc-1 + ;; Do write and read with more data than the buffer will hold + ;; (single-channel simple-stream) + (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)) + (stream (make-instance 'file-simple-stream + :filename file + :direction :output)) + (content (make-string (1+ (device-buffer-length stream)) + :initial-element #\x))) + (with-open-stream (s stream) + (write-string content s)) + (with-open-stream (s (make-instance 'file-simple-stream + :filename file + :direction :input)) + (prog1 (string= content (read-line s)) + (delete-file file)))) + t) + +(deftest write-read-large-dc-1 + ;; Do write and read with more data than the buffer will hold + ;; (dual-channel simple-stream; we only have socket streams atm) + (handler-case + (let* ((stream (make-instance 'socket-simple-stream + :remote-host #(127 0 0 1) + :remote-port 7)) + (content (make-string (1+ (device-buffer-length stream)) + :initial-element #\x))) + (with-open-stream (s stream) + (string= (prog1 (write-line content s) (finish-output s)) + (read-line s)))) + (sb-bsd-sockets::connection-refused-error () t)) + t) + diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp index 600560e..ea3bfd9 100644 --- a/contrib/sb-simple-streams/strategy.lisp +++ b/contrib/sb-simple-streams/strategy.lisp @@ -248,13 +248,14 @@ (unless (and (< code 32) ctrl (svref ctrl code) (funcall (the (or symbol function) (svref ctrl code)) stream char)) - (if (< ptr max) - (progn - (setf (bref buffer ptr) code) - (incf ptr)) - (progn - (sc-flush-buffer stream t) - (setf ptr (sm buffpos stream))))))))) + (unless (< ptr max) + ;; need to update buffpos before control leaves this + ;; function in any way + (setf (sm buffpos stream) ptr) + (sc-flush-buffer stream t) + (setf ptr (sm buffpos stream))) + (setf (bref buffer ptr) code) + (incf ptr)))))) (declaim (ftype j-listen-fn sc-listen)) (defun sc-listen (stream) @@ -398,13 +399,13 @@ (unless (and (< code 32) ctrl (svref ctrl code) (funcall (the (or symbol function) (svref ctrl code)) stream char)) - (if (< ptr max) - (progn - (setf (bref buffer ptr) code) - (incf ptr)) - (progn - (dc-flush-buffer stream t) - (setf ptr (sm outpos stream))))))))) + (unless (< ptr max) + (setf (sm outpos stream) ptr) + (dc-flush-buffer stream t) + (setf ptr (sm outpos stream))) + (setf (bref buffer ptr) code) + (incf ptr)) + )))) (declaim (ftype j-listen-fn dc-listen)) (defun dc-listen (stream) diff --git a/version.lisp-expr b/version.lisp-expr index 499bd91..4dc6f81 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.8alpha.0.41" +"0.8alpha.0.42"