diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index f01bf3af84b5425cd4dd33f6b0c2e98acfa6e9ba..0033c6e6f70d11dccd9c2f7406204a80dc2f5413 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.66 2003/06/06 16:23:45 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.67 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -139,7 +139,7 @@ ;;; DO-OUTPUT-LATER -- internal ;;; ;;; Called by the server when we can write to the given file descriptor. -;;; Attemt to write the data again. If it worked, remove the data from the +;;; Attempt to write the data again. If it worked, remove the data from the ;;; output-later list. If it didn't work, something is wrong. ;;; (defun do-output-later (stream) @@ -161,7 +161,7 @@ (error "Write would have blocked, but SERVER told us to go.") (error "While writing ~S: ~A" stream (unix:get-unix-error-msg errno)))) - ((eql count length) ; Hot damn, it workded. + ((eql count length) ; Hot damn, it worked. (when reuse-sap (push base *available-buffers*))) ((not (null count)) ; Sorta worked. @@ -175,7 +175,7 @@ ;;; OUTPUT-LATER -- internal ;;; -;;; Arange to output the string when we can write on the file descriptor. +;;; Arrange to output the string when we can write on the file descriptor. ;;; (defun output-later (stream base start end reuse-sap) (cond ((null (fd-stream-output-later stream)) @@ -1232,7 +1232,9 @@ (multiple-value-bind (name type version) (extract-name-type-and-version name (if sep (1+ sep) 0) (length name)) (let ((version (if (symbolp version) 1 (1+ version))) - (match (concatenate 'string name "." type ".~"))) + (match (if type + (concatenate 'string name "." type ".~") + (concatenate 'string name ".~")))) (when dir (unwind-protect (loop @@ -1515,10 +1517,11 @@ (declare (ignore external-format input-handle output-handle)) ;; First, make sure that DIRECTION is valid. Allow it to be changed if not. - (setf direction + (setq direction (assure-one-of direction '(:input :output :io :probe) :direction)) + (setf (getf options :direction) direction) (when (and if-exists-given (member direction '(:output :io))) (setq if-exists @@ -1536,9 +1539,9 @@ :if-does-not-exist)) (setf (getf options :if-does-not-exist) if-does-not-exist)) - (let ((class (or class 'fd-stream)) + (let ((filespec (pathname filename)) (options (copy-list options)) - (filespec (pathname filename))) + (class (or class 'fd-stream))) (cond ((eq class 'fd-stream) (remf options :class) (remf options :mapped) diff --git a/code/package.lisp b/code/package.lisp index fbb45fee920af3ac5b1dee4d3f3684f90ba9c9cb..998f797de418dfb99471a274c2e18d8b11e19a56 100644 --- a/code/package.lisp +++ b/code/package.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/package.lisp,v 1.67 2003/06/02 16:00:03 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.68 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -149,7 +149,7 @@ "ALIEN-INTERNALS" "UNIX" "CONDITIONS" "DEBUG" "DEBUG-INTERNALS" "SYSTEM" "KERNEL" "EXTENSIONS" #+mp "MULTIPROCESSING" - "WALKER" "XREF"))) + "WALKER" "XREF" "STREAM"))) (dolist (p package-names) (let ((p (find-package p))) (when p @@ -1287,7 +1287,7 @@ (if where (values symbol where) (progn - #+nil + #+(or) (when *enable-package-locked-errors* (when (ext:package-lock package) (restart-case diff --git a/code/pathname.lisp b/code/pathname.lisp index 5b3f800f0c0e9b1846c26bb0f2b820fbc8be4f06..6753fc2c66b10cfb642d546cd21f708c22f1a403 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.60 2003/03/21 21:36:34 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.61 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -426,7 +426,8 @@ (etypecase ,var (pathname ,var) (string (parse-namestring ,var)) - (file-stream (file-name ,var)))))) + (file-stream (file-name ,var)) + (stream:file-simple-stream (file-name ,var)))))) ,@body)) ;;; WITH-HOST -- Internal diff --git a/code/stream.lisp b/code/stream.lisp index c932cc4e34b2be1ba4a0f92a2b4638562af968b3..773b9fe7f2b44b496b8fa4fdba718ab1c58533df 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.61 2003/06/06 16:23:45 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.62 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -698,9 +698,7 @@ (let ((stream (out-synonym-of stream))) (stream-dispatch stream ;; simple-stream - (progn - (stream::%write-char stream character) - character) + (stream::%write-char stream character) ;; lisp-stream (funcall (lisp-stream-out stream) stream character) ;; fundamental-stream @@ -746,20 +744,21 @@ (let ((stream (out-synonym-of stream))) (stream-dispatch stream ;; simple-stream - (progn - (stream::%write-string stream string start end) - string) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (stream::%write-string stream data offset-start offset-end)) + (stream::%write-string stream string start end)) ;; lisp-stream - (progn - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (lisp-stream-sout stream) - stream data offset-start offset-end)) - (funcall (lisp-stream-sout stream) stream string start end)) - string) + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (funcall (lisp-stream-sout stream) + stream data offset-start offset-end)) + (funcall (lisp-stream-sout stream) stream string start end)) ;; fundamental-stream - (stream-write-string stream string start end)))) + (stream-write-string stream string start end))) + string) (defun write-line (string &optional (stream *standard-output*) &key (start 0) (end (length string))) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index c4e87e4e7ed5897b752ccf1000cf5767dcff0efe..7ff63a8d3133137eb140513e61a91a0b30173eb9 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.32 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defsys.lisp,v 1.33 2003/06/07 17:56:28 toy Exp $") ;;; ;;; Some support stuff for compiling and loading PCL. It would be nice if ;;; there was some portable make-system we could all agree to share for a @@ -66,7 +66,7 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "$Date: 2003/06/06 16:23:46 $") +(defvar *pcl-system-date* "$Date: 2003/06/07 17:56:28 $") (setf (getf ext:*herald-items* :pcl) `(" CLOS based on Gerd's PCL " ,(subseq *pcl-system-date* 7 26))) @@ -500,7 +500,8 @@ and load your system with: ;; recompilation ;; of this file ;; - ((iodefs t () () CMU) + ((herald t () () CMU) + (iodefs t () () CMU) (classes t (iodefs) () CMU) (internal t (classes) () CMU) (strategy t (internal) () CMU) diff --git a/pcl/simple-streams/classes.lisp b/pcl/simple-streams/classes.lisp index 7a1b536cc5f448e1a250b0f04070f93fbb7eca59..b12a19ca8649e21155ff4b99b4661c2ff1bc6d1c 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.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/classes.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -43,7 +43,7 @@ (values fixnum &optional (member nil t :eof)))) (deftype j-write-char-fn () - '(function (character simple-stream) character)) + '(function ((or character null) simple-stream) (or character null))) (deftype j-write-chars-fn () '(function (string simple-stream fixnum fixnum) t)) ; return chars-written? @@ -57,12 +57,12 @@ ((%flags :initform 0 :type fixnum) (plist :initform nil :type list :accessor stream-plist) - (j-listen :type j-listen-fn) - (j-read-char :type j-read-char-fn) - (j-read-chars :type j-read-chars-fn) - (j-write-char :type j-write-char-fn) - (j-write-chars :type j-write-chars-fn) - (j-unread-char :type j-unread-char-fn) + (j-listen :initform #'cl::ill-in-any :type j-listen-fn) + (j-read-char :initform #'cl::ill-in-any :type j-read-char-fn) + (j-read-chars :initform #'cl::ill-in-any :type j-read-chars-fn) + (j-unread-char :initform #'cl::ill-in-any :type j-unread-char-fn) + (j-write-char :initform #'cl::ill-out-any :type j-write-char-fn) ;@@ + (j-write-chars :initform #'cl::ill-out-any :type j-write-chars-fn) ;@@ (external-format :initform :default) @@ -101,10 +101,7 @@ (max-out-pos :initform 0 :type fixnum))) (def-stream-class string-simple-stream (simple-stream) - ((buffer :initform nil :type (or simple-stream-buffer null)) - (buffpos :initform 0 :type fixnum) - (buffer-ptr :initform 0 :type fixnum) - (buf-len :initform 0 :type fixnum))) + ()) (def-stream-class file-simple-stream (single-channel-simple-stream) ((pathname :initform nil :initarg :pathname) @@ -145,9 +142,6 @@ (defgeneric device-clear-output (stream) (:documentation "Write me")) -(defgeneric device-extend (stream need action) - (:documentation "Write me")) - (defgeneric device-finish-record (stream blocking action) (:documentation "Write me")) @@ -163,15 +157,19 @@ (defmethod print-object ((object simple-stream) stream) (print-unreadable-object (object stream :type nil :identity nil) - (unless (any-stream-instance-flags object :input :output) - (princ "Closed " stream)) + (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)))) (defmethod print-object ((object file-simple-stream) stream) (print-unreadable-object (object stream :type nil :identity nil) (with-stream-class (file-simple-stream object) - (unless (any-stream-instance-flags object :input :output) - (princ "Closed " stream)) + (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~) for ~S" (type-of object) (sm filename object))))) @@ -184,7 +182,13 @@ (finish-output stream))) (call-next-method) (setf (sm input-handle stream) nil - (sm output-handle stream) nil) + (sm output-handle stream) nil + (sm j-listen stream) #'cl::closed-flame + (sm j-read-char stream) #'cl::closed-flame + (sm j-read-chars stream) #'cl::closed-flame + (sm j-unread-char stream) #'cl::closed-flame + (sm j-write-char stream) #'cl::closed-flame ;@@ + (sm j-write-chars stream) #'cl::closed-flame) ;@@ (remove-stream-instance-flags stream :input :output) (ext:cancel-finalization stream)))) @@ -276,14 +280,3 @@ (defmethod output-stream-p ((stream stream:simple-stream)) (any-stream-instance-flags stream :output)) ) ; WHEN - - - -(setf (getf ext:*herald-items* :simple-streams) - `(" Simple Streams " - #+CMU18E - ,(let ((version "$Revision: 1.1 $")) - (subseq version 11 (- (length version) 2))))) - -(pushnew :simple-streams *features*) -(provide :simple-streams) diff --git a/pcl/simple-streams/direct.lisp b/pcl/simple-streams/direct.lisp index d8b3bc3e59c8cd9d10c6c99e42859db4886563fe..35e25fec894f0db49b78118ec037fa5cbdf5a07c 100644 --- a/pcl/simple-streams/direct.lisp +++ b/pcl/simple-streams/direct.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/direct.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,10 +32,6 @@ ;; return buffer length ) -(defmethod device-extend ((stream direct-simple-stream) need action) - (declare (ignore need action)) - nil) - (defmethod device-open ((stream buffer-input-simple-stream) options) #| do something |# stream) diff --git a/pcl/simple-streams/file.lisp b/pcl/simple-streams/file.lisp index b1854ff0ef034dd8da54f42af922db26e5953cf7..f7aa44868f0c1185a2ca2d4c4b28f5eb9b55d495 100644 --- a/pcl/simple-streams/file.lisp +++ b/pcl/simple-streams/file.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/file.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/file.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -90,8 +90,9 @@ (sm buf-len stream) length))) (when (any-stream-instance-flags stream :output) (setf (sm control-out stream) *std-control-out-table*)) - (install-single-channel-character-strategy - stream (getf options :external-format :default) nil) + (let ((efmt (getf options :external-format :default))) + (compose-encapsulating-streams stream efmt) + (install-single-channel-character-strategy stream efmt nil)) stream))) (defmethod device-close ((stream file-simple-stream) abort) @@ -183,7 +184,7 @@ (unix:unix-munmap (sm buffer stream) (sm buf-len stream)) (setf (sm buffer stream) nil)) (cond (abort - ;; remove any FD handler + ;; remove any fd handler ;; if it has an original name (is this possible for mapped files?) ;; revert the file ) @@ -193,7 +194,3 @@ )) (unix:unix-close (sm input-handle stream))) t) - -(defmethod device-extend ((stream mapped-file-simple-stream) need action) - (declare (ignore need action)) - nil) diff --git a/pcl/simple-streams/herald.lisp b/pcl/simple-streams/herald.lisp new file mode 100644 index 0000000000000000000000000000000000000000..2c2350b0a1d27420b20109bdc3a18b25c0072922 --- /dev/null +++ b/pcl/simple-streams/herald.lisp @@ -0,0 +1,20 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*- +;;; +;;; ********************************************************************** +;;; This code was written by Paul Foley and has been placed in the public +;;; domain. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/herald.lisp,v 1.1 2003/06/07 17:56:28 toy Rel $") +;;; +;;; ********************************************************************** +;;; +;;; + +(in-package "STREAM") + +(setf (getf ext:*herald-items* :simple-streams) + `(" Simple Streams")) + +(pushnew :simple-streams *features*) +(provide :simple-streams) diff --git a/pcl/simple-streams/impl.lisp b/pcl/simple-streams/impl.lisp index bcd650175aec97b714e843bf6e23395468ff85d4..4cb99d8312f37de58f18924cba4b099e39ff3ec9 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.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -136,19 +136,21 @@ (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (type simple-stream stream) (ignore recursive-p)) - (with-stream-class (simple-stream) + (with-stream-class (simple-stream stream) (%check stream :input) - (let* ((cbuf (make-string 80)) ; current buffer + (let* ((encap (sm melded-stream stream)) ; encapsulating stream + (cbuf (make-string 80)) ; current buffer (bufs (list cbuf)) ; list of buffers (tail bufs) ; last cons of bufs list (index 0) ; current index in current buffer (total 0)) ; total characters - (declare (type simple-base-string cbuf) + (declare (type simple-stream encap) + (type simple-base-string cbuf) (type cons bufs tail) (type fixnum index total)) (loop (multiple-value-bind (chars done) - (funcall-stm-handler j-read-chars stream cbuf + (funcall-stm-handler j-read-chars encap cbuf #\Newline index (length cbuf) t) (declare (type fixnum chars)) (incf index chars) @@ -192,116 +194,135 @@ (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p) (declare (type simple-stream stream) (ignore recursive-p)) - (with-stream-class (simple-stream) + (with-stream-class (simple-stream stream) (%check stream :input) - (funcall-stm-handler j-read-char stream eof-error-p eof-value blocking-p))) + (funcall-stm-handler j-read-char (sm melded-stream stream) + eof-error-p eof-value blocking-p))) (defun %unread-char (stream character) (declare (type simple-stream stream) (ignore character)) - (with-stream-class (simple-stream) + (with-stream-class (simple-stream stream) (%check stream :input) (if (zerop (sm last-char-read-size stream)) (error "Nothing to unread.") - (funcall-stm-handler j-unread-char stream nil)))) + (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))) (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p) (declare (type simple-stream stream) (ignore recursive-p)) - (with-stream-class (simple-stream) + (with-stream-class (simple-stream stream) (%check stream :input) - (let ((char (funcall-stm-handler j-read-char stream + (let* ((encap (sm melded-stream stream)) + (char (funcall-stm-handler j-read-char encap eof-error-p stream t))) (cond ((eq char stream) eof-value) ((characterp peek-type) - (do ((char char (funcall-stm-handler j-read-char stream + (do ((char char (funcall-stm-handler j-read-char encap eof-error-p stream t))) ((or (eq char stream) (char= char peek-type)) (unless (eq char stream) - (funcall-stm-handler j-unread-char stream t)) + (funcall-stm-handler j-unread-char encap t)) (if (eq char stream) eof-value char)))) ((eq peek-type t) - (do ((char char (funcall-stm-handler j-read-char stream + (do ((char char (funcall-stm-handler j-read-char encap eof-error-p stream t))) ((or (eq char stream) (not (cl::whitespace-char-p char))) (unless (eq char stream) - (funcall-stm-handler j-unread-char stream t)) + (funcall-stm-handler j-unread-char encap t)) (if (eq char stream) eof-value char)))) (t - (funcall-stm-handler j-unread-char stream t) + (funcall-stm-handler j-unread-char encap t) char))))) (defun %listen (stream width) (declare (type simple-stream stream)) ;; WIDTH is number of octets which must be available; any value ;; other than 1 is treated as 'character. - (with-stream-class (single-channel-simple-stream stream) ;@@ - (%check stream :input) - (if (not (eql width 1)) - (funcall-stm-handler j-listen stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - ;; Note: should try DEVICE-EXTEND for more on buffer streams - (when (>= (sm mode stream) 0) ;; device-connected - (incf (sm last-char-read-size stream)) - (let ((ok (sc-refill-buffer stream nil))) - (decf (sm last-char-read-size stream)) - (plusp ok))))))) + (%check stream :input) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (with-stream-class (single-channel-simple-stream stream) + (if (not (eql width 1)) + (funcall-stm-handler j-listen stream) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + ;; Note: should try DEVICE-EXTEND for more on buffer streams + (when (>= (sm mode stream) 0) ;; device-connected + (incf (sm last-char-read-size stream)) + (let ((ok (sc-refill-buffer stream nil))) + (decf (sm last-char-read-size stream)) + (plusp ok)))))) + ;; dual-channel-simple-stream + (error "Implement %LISTEN") + ;; string-simple-stream + (error "Implement %LISTEN"))) (defun %clear-input (stream buffer-only) (declare (type simple-stream stream)) - (with-stream-class (single-channel-simple-stream stream) ;@@ - (%check stream :input) - (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm last-char-read-size stream) 0) ;; ?? - (device-clear-input stream buffer-only))) + (%check stream :input) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (with-stream-class (single-channel-simple-stream stream) + (setf (sm buffpos stream) 0 + (sm buffer-ptr stream) 0 + (sm last-char-read-size stream) 0)) + ;; dual-channel-simple-stream + (with-stream-class (dual-channel-simple-stream stream) + (setf (sm buffpos stream) 0 + (sm buffer-ptr stream) 0 + (sm last-char-read-size stream) 0)) + ;; string-simple-stream + nil) + (device-clear-input stream buffer-only)) (defun %read-byte (stream eof-error-p eof-value) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) - (cond ((any-stream-instance-flags stream :eof) - (cl::eof-or-lose stream eof-error-p eof-value)) - ((any-stream-instance-flags stream :string) - (with-stream-class (string-simple-stream stream) - (let ((encap (sm input-handle stream))) - (unless encap - (error 'simple-type-error - :datum stream - :expected-type 'stream - :format-control "Can't read-byte on string streams" - :format-arguments '())) - (prog1 - (locally (declare (notinline read-byte)) - (read-byte encap eof-error-p eof-value)) - (setf (sm last-char-read-size stream) 0 - (sm encapsulated-char-read-size stream) 0))))) - ((any-stream-instance-flags stream :dual) - (dc-read-byte stream eof-error-p eof-value t)) - (t ;; single-channel-simple-stream - (sc-read-byte stream eof-error-p eof-value t))))) + (if (any-stream-instance-flags stream :eof) + (cl::eof-or-lose stream eof-error-p eof-value) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (sc-read-byte stream eof-error-p eof-value t) + ;; dual-channel-simple-stream + (dc-read-byte stream eof-error-p eof-value t) + ;; string-simple-stream + (with-stream-class (string-simple-stream stream) + (let ((encap (sm input-handle stream))) + (unless encap + (error 'simple-type-error + :datum stream + :expected-type 'stream + :format-control "Can't read-byte on string streams" + :format-arguments '())) + (prog1 + (locally (declare (notinline read-byte)) + (read-byte encap eof-error-p eof-value)) + (setf (sm last-char-read-size stream) 0 + (sm encapsulated-char-read-size stream) 0)))))))) (defun %write-char (stream character) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - (funcall-stm-handler-2 j-write-char character stream))) + (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) (defun %fresh-line (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) (when (/= (or (sm charpos stream) 1) 0) - (funcall-stm-handler-2 j-write-char #\Newline stream) + (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream)) t))) (defun %write-string (stream string start end) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - (funcall-stm-handler-2 j-write-chars string stream start end))) + (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream) + start end))) (defun %line-length (stream) (declare (type simple-stream stream)) @@ -313,23 +334,25 @@ (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - (cond ((any-stream-instance-flags stream :string) - #| nothing to do |#) - ((any-stream-instance-flags stream :dual) - (dc-flush-buffer stream t)) - (t - (sc-flush-buffer stream t))))) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (sc-flush-buffer stream t) + ;; dual-channel-simple-stream + (dc-flush-buffer stream t) + ;; string-simple-stream + nil))) (defun %force-output (stream) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - (cond ((any-stream-instance-flags stream :string) - #| nothing to do |#) - ((any-stream-instance-flags stream :dual) - (dc-flush-buffer stream nil)) - (t - (sc-flush-buffer stream nil))))) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (sc-flush-buffer stream nil) + ;; dual-channel-simple-stream + (dc-flush-buffer stream nil) + ;; string-simple-stream + nil))) (defun %clear-output (stream) (declare (type simple-stream stream)) @@ -342,28 +365,27 @@ (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :output) - (cond ((any-stream-instance-flags stream :string) - (error 'simple-type-error - :datum stream - :expected-type 'stream - :format-control "Can't write-byte on string streams." - :format-arguments '())) - ((any-stream-instance-flags stream :dual) - (with-stream-class (dual-channel-simple-stream stream) - (let ((ptr (sm outpos stream))) - (when (>= ptr (sm max-out-pos stream)) - (dc-flush-buffer stream t) - (setf ptr (1- (sm outpos stream)))) - (setf (sm outpos stream) (1+ ptr)) - (setf (bref (sm out-buffer stream) ptr) integer)))) - (t ;; single-channel-simple-stream - (with-stream-class (single-channel-simple-stream stream) - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buffer-ptr stream)) - (sc-flush-buffer stream t) - (setf ptr (sm buffpos stream))) - (setf (sm buffpos stream) (1+ ptr)) - (setf (bref (sm buffer stream) ptr) integer))))))) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (with-stream-class (single-channel-simple-stream stream) + (let ((ptr (sm buffpos stream))) + (when (>= ptr (sm buffer-ptr stream)) + (setf ptr (sc-flush-buffer stream t))) + (setf (sm buffpos stream) (1+ ptr)) + (setf (bref (sm buffer stream) ptr) integer))) + ;; dual-channel-simple-stream + (with-stream-class (dual-channel-simple-stream stream) + (let ((ptr (sm outpos stream))) + (when (>= ptr (sm max-out-pos stream)) + (setf ptr (dc-flush-buffer stream t))) + (setf (sm outpos stream) (1+ ptr)) + (setf (bref (sm out-buffer stream) ptr) integer))) + ;; string-simple-stream + (error 'simple-type-error + :datum stream + :expected-type 'stream + :format-control "Can't write-byte on string streams." + :format-arguments '())))) (defun %read-sequence (stream seq start end partial-fill) (declare (type simple-stream stream)) @@ -371,7 +393,7 @@ (%check stream :input) (etypecase seq (string - (funcall-stm-handler j-read-chars stream seq nil + (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil start (or end (length seq)) (if partial-fill :bnb t))) ((or (simple-array (unsigned-byte 8) (*)) @@ -386,7 +408,7 @@ (%check stream :output) (etypecase seq (string - (funcall-stm-handler-2 j-write-chars seq stream + (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream) start (or end (length seq)))) ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) diff --git a/pcl/simple-streams/internal.lisp b/pcl/simple-streams/internal.lisp index b4890d3353552d2e1bf2a4636455935f5b207567..5c9c5be1a7797f770a66d42c1b2f1a7c1b106e5b 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.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/internal.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -48,7 +48,7 @@ (make-array size :element-type '(unsigned-byte 8)))) (defun free-buffer (buffer) - (unless (vectorp buffer) + (when (sys:system-area-pointer-p buffer) (push buffer cl::*available-buffers*)) t) @@ -88,6 +88,11 @@ +(defun find-external-format (name) + nil) + + + (defun vector-elt-width (vector) ;; Return octet-width of vector elements (etypecase vector diff --git a/pcl/simple-streams/iodefs.lisp b/pcl/simple-streams/iodefs.lisp index 7af41bf7c651b07218fb3a49a268699ea8d0b4fd..91202891fa12b6a511532a1126c79e7cfbc23e23 100644 --- a/pcl/simple-streams/iodefs.lisp +++ b/pcl/simple-streams/iodefs.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/iodefs.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/iodefs.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -41,12 +41,19 @@ (defmacro with-stream-class ((class-name &optional stream) &body body) (if stream - (let ((stm (gensym "STREAM"))) - `(let ((,stm ,stream)) - (declare (type ,class-name ,stm) (ignorable ,stm)) + (let ((stm (gensym "STREAM")) + (slt (gensym "SV"))) + `(let* ((,stm ,stream) + (,slt (kernel:%instance-ref ,stm 1))) + (declare (type ,class-name ,stm) + (type simple-vector ,slt) + (ignorable ,slt)) (macrolet ((sm (slot-name stream) (declare (ignore stream)) - `(slot-value ,',stm ',slot-name)) + #-count-sm + `(slot-value ,',stm ',slot-name) + #+count-sm + `(%sm ',slot-name ,',stm)) (add-stream-instance-flags (stream &rest flags) (declare (ignore stream)) `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm) @@ -61,7 +68,10 @@ ,(%flags flags)))))) ,@body))) `(macrolet ((sm (slot-name stream) - `(slot-value ,stream ',slot-name))) + #-count-sm + `(slot-value ,stream ',slot-name) + #+count-sm + `(%sm ',slot-name ,stream))) ,@body))) (defmacro sm (slot-name stream) @@ -102,7 +112,16 @@ (with-stream-class (simple-stream ,s) (any-stream-instance-flags ,s ,@flags))))) -(defun compose-encapsulating-streams (stream external-format) - #| implement me |#) +(defmacro simple-stream-dispatch (stream single dual string) + (let ((s (gensym "STREAM"))) + `(let ((,s ,stream)) + (with-stream-class (simple-stream ,s) + (let ((%flags (sm %flags ,s))) + (cond ((zerop (logand %flags ,(%flags '(:string :dual)))) + ,single) + ((zerop (logand %flags ,(%flags '(:string)))) + ,dual) + (t + ,string))))))) (provide :iodefs) diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp index 12eaf761ba96aba3131f468ea19e5476bae96436..0e780877d525cff231584b09120f4093e4131d0c 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.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -13,6 +13,35 @@ (in-package "STREAM") +;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ext:define-function-name-syntax sc (name) + ;; (sc <name> <external-format> [<access>]) + (if (and (<= 3 (length name) 4) + (symbolp (second name)) + (keywordp (third name))) + (values t (second name)) + (values nil nil))) + + (ext:define-function-name-syntax dc (name) + ;; (dc <name> <external-format>) + (if (and (= (length name) 3) + (symbolp (second name)) + (keywordp (third name))) + (values t (second name)) + (values nil nil))) + + (ext:define-function-name-syntax str (name) + ;; (str <name> [<composing-format>]) + (if (and (<= 2 (length name) 3) + (symbolp (second name)) + (or (null (third name)) + (keywordp (third name)))) + (values t (second name)) + (values nil nil)))) + + ;;;; Helper functions (defun sc-refill-buffer (stream blocking) (with-stream-class (single-channel-simple-stream stream) @@ -34,7 +63,7 @@ (bytes (sm buffpos stream))) (declare (type fixnum ptr bytes)) (loop - (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return)) + (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return 0)) (let ((bytes-written (device-write stream nil ptr nil blocking))) (declare (fixnum bytes-written)) (when (minusp bytes-written) @@ -61,7 +90,7 @@ (bytes (sm outpos stream))) (declare (type fixnum ptr bytes)) (loop - (when (>= ptr bytes) (setf (sm outpos stream) 0) (return)) + (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0)) (let ((bytes-written (device-write stream nil ptr nil blocking))) (declare (fixnum bytes-written)) (when (minusp bytes-written) @@ -71,8 +100,18 @@ ;;;; Single-Channel-Simple-Stream strategy functions -(declaim (ftype j-read-char-fn sc-read-char)) -(defun sc-read-char (stream eof-error-p eof-value blocking) +(declaim (ftype j-listen-fn (sc listen :iso8859-1))) +(defun (sc listen :iso8859-1) (stream) + (with-stream-class (single-channel-simple-stream stream) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + (case (device-read stream nil 0 0 nil) + ((0 -2) nil) + (-1 #| latch EOF |# nil) + (-3 t) + (t (error "DEVICE-READ error.")))))) + +(declaim (ftype j-read-char-fn (sc read-char :iso8859-1))) +(defun (sc read-char :iso8859-1) (stream eof-error-p eof-value blocking) #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# (with-stream-class (single-channel-simple-stream stream) ;; if stream is open for read-write, may need to flush the buffer @@ -100,8 +139,8 @@ (cl::eof-or-lose stream eof-error-p eof-value) char)))) -(declaim (ftype j-read-char-fn sc-read-char--buffer)) -(defun sc-read-char--buffer (stream eof-error-p eof-value blocking) +(declaim (ftype j-read-char-fn (sc read-char :iso8859-1 buffer))) +(defun (sc read-char :iso8859-1 buffer) (stream eof-error-p eof-value blocking) (declare (ignore blocking)) ;; everything is already in the buffer #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# (with-stream-class (single-channel-simple-stream stream) @@ -122,8 +161,8 @@ (cl::eof-or-lose stream eof-error-p eof-value) char)))) -(declaim (ftype j-read-chars-fn sc-read-chars)) -(defun sc-read-chars (stream string search start end blocking) +(declaim (ftype j-read-chars-fn (sc read-chars :iso8859-1))) +(defun (sc read-chars :iso8859-1) (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 @@ -171,8 +210,9 @@ (t (setf (char string posn) char))))))) -(declaim (ftype j-read-chars-fn sc-read-chars--buffer)) -(defun sc-read-chars--buffer (stream string search start end blocking) +(declaim (ftype j-read-chars-fn (sc read-chars :iso8859-1 buffer))) +(defun (sc read-chars :iso8859-1 buffer) (stream string search start end + blocking) (declare (type simple-stream stream) (type string string) (type (or null character) search) @@ -215,8 +255,8 @@ (t (setf (char string posn) char))))))) -(declaim (ftype j-unread-char-fn sc-unread-char)) -(defun sc-unread-char (stream relaxed) +(declaim (ftype j-unread-char-fn (sc unread-char :iso8859-1))) +(defun (sc unread-char :iso8859-1) (stream relaxed) (declare (ignore relaxed)) (with-stream-class (single-channel-simple-stream stream) (let ((unread (sm last-char-read-size stream))) @@ -225,27 +265,26 @@ (error "Unreading needs work")) (setf (sm last-char-read-size stream) 0)))) -(declaim (ftype j-write-char-fn sc-write-char)) -(defun sc-write-char (character stream) - (with-stream-class (single-channel-simple-stream stream) - (let ((code (char-code character)) - (ctrl (sm control-out stream))) - (when (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream character)) - (return-from sc-write-char character)) - (let ((buffer (sm buffer stream)) - (ptr (sm buffpos stream))) - ;; FIXME: Rudi Schlatte reckons this should be BUF-LEN, not BUFFER-PTR - (when (>= ptr (sm buffer-ptr stream)) - (sc-flush-buffer stream t) - (setf ptr (sm buffpos stream))) - (setf (bref buffer ptr) code) - (setf (sm buffpos stream) (1+ ptr))))) +(declaim (ftype j-write-char-fn (sc write-char :iso8859-1))) +(defun (sc write-char :iso8859-1) (character stream) + (when character + (with-stream-class (single-channel-simple-stream stream) + (let ((code (char-code character)) + (ctrl (sm control-out stream))) + (when (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (return-from write-char character)) + (let ((buffer (sm buffer stream)) + (ptr (sm buffpos stream))) + (when (>= ptr (sm buf-len stream)) + (setf ptr (sc-flush-buffer stream t))) + (setf (bref buffer ptr) code) + (setf (sm buffpos stream) (1+ ptr)))))) character) -(declaim (ftype j-write-chars-fn sc-write-chars)) -(defun sc-write-chars (string stream start end) +(declaim (ftype j-write-chars-fn (sc write-chars :iso8859-1))) +(defun (sc write-chars :iso8859-1) (string stream start end) (with-stream-class (single-channel-simple-stream stream) (do ((buffer (sm buffer stream)) (ptr (sm buffpos stream)) @@ -262,20 +301,9 @@ stream char)) (when (>= ptr max) (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) - (with-stream-class (single-channel-simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (case (device-read stream nil 0 0 nil) - ((0 -2) nil) - (-1 #| latch EOF |# nil) - (-3 t) - (t (error "DEVICE-READ error.")))))) + (setf ptr (sc-flush-buffer stream t))) + (setf (bref buffer ptr) code) + (incf ptr)))))) ;;; SC-READ-BYTE doesn't actually live in a strategy slot @@ -296,8 +324,18 @@ ;;;; Dual-Channel-Simple-Stream strategy functions -(declaim (ftype j-read-char-fn dc-read-char)) -(defun dc-read-char (stream eof-error-p eof-value blocking) +(declaim (ftype j-listen-fn (dc listen :iso8859-1))) +(defun (dc listen :iso8859-1) (stream) + (with-stream-class (dual-channel-simple-stream stream) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + (case (device-read stream nil 0 0 nil) + ((0 -2) nil) + (-1 #| latch EOF |# nil) + (-3 t) + (t (error "DEVICE-READ error.")))))) + +(declaim (ftype j-read-char-fn (dc read-char :iso8859-1))) +(defun (dc read-char :iso8859-1) (stream eof-error-p eof-value blocking) #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# (with-stream-class (dual-channel-simple-stream stream) (when (and (any-stream-instance-flags stream :interactive) @@ -327,8 +365,8 @@ (cl::eof-or-lose stream eof-error-p eof-value) char)))) -(declaim (ftype j-read-chars-fn dc-read-chars)) -(defun dc-read-chars (stream string search start end blocking) +(declaim (ftype j-read-chars-fn (dc read-chars :iso8859-1))) +(defun (dc read-chars :iso8859-1) (stream string search start end blocking) (declare (type dual-channel-simple-stream stream) (type string string) (type (or null character) search) @@ -376,8 +414,8 @@ (t (setf (char string posn) char))))))) -(declaim (ftype j-unread-char-fn dc-unread-char)) -(defun dc-unread-char (stream relaxed) +(declaim (ftype j-unread-char-fn (dc unread-char :iso8859-1))) +(defun (dc unread-char :iso8859-1) (stream relaxed) (declare (ignore relaxed)) (with-stream-class (dual-channel-simple-stream stream) (let ((unread (sm last-char-read-size stream))) @@ -386,26 +424,26 @@ (error "Unreading needs work")) (setf (sm last-char-read-size stream) 0)))) -(declaim (ftype j-write-char-fn dc-write-char)) -(defun dc-write-char (character stream) - (with-stream-class (dual-channel-simple-stream stream) - (let ((code (char-code character)) - (ctrl (sm control-out stream))) - (when (and (< code 32) ctrl (svref ctrl code) - (funcall (the (or symbol function) (svref ctrl code)) - stream character)) - (return-from dc-write-char character)) - (let ((buffer (sm out-buffer stream)) - (ptr (sm outpos stream))) - (when (>= ptr (sm max-out-pos stream)) - (dc-flush-buffer stream t) - (setf ptr (sm outpos stream))) - (setf (bref buffer ptr) code) - (setf (sm outpos stream) (1+ ptr))))) +(declaim (ftype j-write-char-fn (dc write-char :iso8859-1))) +(defun (dc write-char :iso8859-1) (character stream) + (when character + (with-stream-class (dual-channel-simple-stream stream) + (let ((code (char-code character)) + (ctrl (sm control-out stream))) + (when (and (< code 32) ctrl (svref ctrl code) + (funcall (the (or symbol function) (svref ctrl code)) + stream character)) + (return-from write-char character)) + (let ((buffer (sm out-buffer stream)) + (ptr (sm outpos stream))) + (when (>= ptr (sm max-out-pos stream)) + (setq ptr (dc-flush-buffer stream t))) + (setf (bref buffer ptr) code) + (setf (sm outpos stream) (1+ ptr)))))) character) -(declaim (ftype j-write-chars-fn dc-write-chars)) -(defun dc-write-chars (string stream start end) +(declaim (ftype j-write-chars-fn (dc write-chars :iso8859-1))) +(defun (dc write-chars :iso8859-1) (string stream start end) (with-stream-class (dual-channel-simple-stream stream) (do ((buffer (sm out-buffer stream)) (ptr (sm outpos stream)) @@ -421,21 +459,10 @@ (funcall (the (or symbol function) (svref ctrl code)) stream char)) (when (>= ptr max) - (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) - (with-stream-class (dual-channel-simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (case (device-read stream nil 0 0 nil) - ((0 -2) nil) - (-1 #| latch EOF |# nil) - (-3 t) - (t (error "DEVICE-READ error.")))))) + (setf (sm outpos stream) ptr) + (setf ptr (dc-flush-buffer stream ptr t))) + (setf (bref buffer ptr) code) + (incf ptr)))))) ;;; DC-READ-BYTE doesn't actually live in a strategy slot @@ -456,9 +483,9 @@ ;;;; String-Simple-Stream strategy functions -(declaim (ftype j-read-char-fn string-read-char)) +(declaim (ftype j-read-char-fn (str read-char))) #+(or) -(defun string-read-char (stream eof-error-p eof-value blocking) +(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))|#) (with-stream-class (string-input-simple-stream stream) @@ -481,9 +508,9 @@ -(declaim (ftype j-read-char-fn composing-crlf-read-char)) -(defun composing-crlf-read-char (stream eof-error-p eof-value blocking) - (with-stream-class (simple-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* ((melded-stream (sm melded-stream stream)) (char (funcall-stm-handler j-read-char melded-stream nil stream blocking))) @@ -508,51 +535,89 @@ ;; do control-in processing on whatever character we've got char))) -(declaim (ftype j-unread-char-fn composing-crlf-unread-char)) -(defun composing-crlf-unread-char (stream relaxed) +(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 (simple-stream stream) + (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 +(defun %find-topmost-stream (stream) + ;; N.B.: the topmost stream in the chain of encapsulations is actually + ;; the bottommost in the "melding" chain + (with-stream-class (simple-stream) + (loop + (when (eq (sm melded-stream stream) (sm melding-base stream)) + (return stream)) + (setq stream (sm melded-stream stream))))) + (defun install-single-channel-character-strategy (stream external-format access) - (declare (ignore external-format)) - ;; ACCESS is usually NIL - ;; May be "undocumented" values: stream::buffer, stream::mapped - ;; to install strategies suitable for direct buffer streams - ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ) - ;; (Avoids checking "mode" flags by installing special strategy) - (with-stream-class (single-channel-simple-stream stream) - (if (or (eq access 'buffer) (eq access 'mapped)) - (setf (sm j-read-char stream) #'sc-read-char--buffer - (sm j-read-chars stream) #'sc-read-chars--buffer - (sm j-unread-char stream) #'sc-unread-char - (sm j-write-char stream) #'sc-write-char - (sm j-write-chars stream) #'sc-write-chars - (sm j-listen stream) #'sc-listen) - (setf (sm j-read-char stream) #'sc-read-char - (sm j-read-chars stream) #'sc-read-chars - (sm j-unread-char stream) #'sc-unread-char - (sm j-write-char stream) #'sc-write-char - (sm j-write-chars stream) #'sc-write-chars - (sm j-listen stream) #'sc-listen))) + (find-external-format external-format) + (let ((stream (%find-topmost-stream stream))) + ;; ACCESS is usually NIL + ;; May be "undocumented" values: stream::buffer, stream::mapped + ;; to install strategies suitable for direct buffer streams + ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ) + ;; (Avoids checking "mode" flags by installing special strategy) + (with-stream-class (simple-stream stream) + (if (or (eq access 'buffer) (eq access 'mapped)) + (setf (sm j-read-char stream) #'(sc read-char :iso8859-1 buffer) + (sm j-read-chars stream) #'(sc read-chars :iso8859-1 buffer) + (sm j-unread-char stream) #'(sc unread-char :iso8859-1) + (sm j-write-char stream) #'(sc write-char :iso8859-1) + (sm j-write-chars stream) #'(sc write-chars :iso8859-1) + (sm j-listen stream) #'(sc listen :iso8859-1)) + (setf (sm j-read-char stream) #'(sc read-char :iso8859-1) + (sm j-read-chars stream) #'(sc read-chars :iso8859-1) + (sm j-unread-char stream) #'(sc unread-char :iso8859-1) + (sm j-write-char stream) #'(sc write-char :iso8859-1) + (sm j-write-chars stream) #'(sc write-chars :iso8859-1) + (sm j-listen stream) #'(sc listen :iso8859-1))))) stream) (defun install-dual-channel-character-strategy (stream external-format) - (declare (ignore external-format)) - (with-stream-class (dual-channel-simple-stream stream) - (setf (sm j-read-char stream) #'dc-read-char - (sm j-read-chars stream) #'dc-read-chars - (sm j-unread-char stream) #'dc-unread-char - (sm j-write-char stream) #'dc-write-char - (sm j-write-chars stream) #'dc-write-chars - (sm j-listen stream) #'dc-listen)) + (find-external-format external-format) + (let ((stream (%find-topmost-stream stream))) + (with-stream-class (simple-stream stream) + (setf (sm j-read-char stream) #'(dc read-char :iso8859-1) + (sm j-read-chars stream) #'(dc read-chars :iso8859-1) + (sm j-unread-char stream) #'(dc unread-char :iso8859-1) + (sm j-write-char stream) #'(dc write-char :iso8859-1) + (sm j-write-chars stream) #'(dc write-chars :iso8859-1) + (sm j-listen stream) #'(dc listen :iso8859-1)))) stream) +;; Deprecated -- use install-string-{input,output}-character-strategy instead! (defun install-string-character-strategy (stream) - (with-stream-class (string-simple-stream stream) - (setf (sm j-read-char stream) #'string-read-char)) + (install-string-input-character-strategy stream) + (when (any-stream-instance-flags stream :output) + (install-string-output-character-strategy stream)) stream) + +(defun install-string-input-character-strategy (stream) + #| implement me |# + (let ((stream (%find-topmost-stream stream))) + (with-stream-class (simple-stream stream) + (setf (sm j-read-char stream) #'(str read-char)))) + stream) + +(defun install-string-output-character-strategy (stream) + #| implement me |#) + +(defun compose-encapsulating-streams (stream external-format) + (when (consp external-format) + (with-stream-class (simple-stream) + (dolist (fmt (butlast external-format)) + (let ((encap (make-instance 'composing-stream :composing-format fmt))) + (setf (sm melding-base encap) stream) + (setf (sm melded-stream encap) (sm melded-stream stream)) + (setf (sm melded-stream stream) encap) + (rotatef (sm j-listen encap) (sm j-listen stream)) + (rotatef (sm j-read-char encap) (sm j-read-char stream)) + (rotatef (sm j-read-chars encap) (sm j-read-chars stream)) + (rotatef (sm j-unread-char encap) (sm j-unread-char stream)) + (rotatef (sm j-write-char encap) (sm j-write-char stream)) + (rotatef (sm j-write-chars encap) (sm j-write-chars stream))))))) diff --git a/pcl/simple-streams/string.lisp b/pcl/simple-streams/string.lisp index 095c2ad1baf955d8e5585857050edca9e9d34998..eca0ba5fc64a4b863d28775af2992ed50cdc46f0 100644 --- a/pcl/simple-streams/string.lisp +++ b/pcl/simple-streams/string.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.1 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/string.lisp,v 1.2 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,18 +18,25 @@ xp-simple-stream annotation-output-simple-stream)) (def-stream-class string-input-simple-stream (string-simple-stream) - ()) + ((buffer :initform nil :type (or simple-stream-buffer null)) + (buffpos :initform 0 :type fixnum) + (buffer-ptr :initform 0 :type fixnum) + (buf-len :initform 0 :type fixnum))) (def-stream-class string-output-simple-stream (string-simple-stream) - ((out-buffer :initform nil :type (or simple-stream-buffer null)) + ((buffer :initform nil :type (or simple-stream-buffer null)) + (buffpos :initform 0 :type fixnum) + (buffer-ptr :initform 0 :type fixnum) + (buf-len :initform 0 :type fixnum) + (out-buffer :initform nil :type (or simple-stream-buffer null)) (outpos :initform 0 :type fixnum) (max-out-pos :initform 0 :type fixnum))) -(def-stream-class fill-pointer-output-simple-stream - (string-output-simple-stream) +(def-stream-class composing-stream (string-simple-stream) ()) -(def-stream-class composing-stream (string-simple-stream) +(def-stream-class fill-pointer-output-simple-stream + (string-output-simple-stream) ()) (def-stream-class xp-simple-stream (string-output-simple-stream) @@ -38,6 +45,33 @@ (def-stream-class annotation-output-simple-stream (string-output-simple-stream) ()) +(defmethod device-open :before ((stream string-input-simple-stream) options) + (with-stream-class (string-input-simple-stream stream) + (let ((string (getf options :string))) + (when (and string (null (sm buffer stream))) + (let ((start (getf options :start)) + (end (or (getf options :end) (length string)))) + (setf (sm buffer stream) string + (sm buffpos stream) start + (sm buffer-ptr stream) end)))) + (install-string-input-character-strategy stream) + (add-stream-instance-flags stream :string :input :simple))) + +(defmethod device-open :before ((stream string-output-simple-stream) options) + (with-stream-class (string-output-simple-stream stream) + (unless (sm out-buffer stream) + (let ((string (getf options :string))) + (if string + (setf (sm out-buffer stream) string + (sm max-out-pos stream) (length string)) + (let ((buflen (max (device-buffer-length stream) 16))) + (setf (sm out-buffer stream) (make-string buflen) + (sm max-out-pos stream) buflen))))) + (unless (sm control-out stream) + (setf (sm control-out stream) *std-control-out-table*)) + (install-string-output-character-strategy stream) + (add-stream-instance-flags stream :string :output :simple))) + (defmethod device-file-position ((stream string-simple-stream)) ;; get string length (of input or output buffer?) ) @@ -54,18 +88,10 @@ #| do something |# stream) -(defmethod device-extend ((stream string-input-simple-stream) need action) - (declare (ignore need action)) - nil) - (defmethod device-open ((stream string-output-simple-stream) options) #| do something |# stream) -(defmethod device-extend ((stream string-output-simple-stream) need action) - ;; @@3 - ) - (defmethod device-open ((stream fill-pointer-output-simple-stream) options) #| do something |# stream) @@ -79,11 +105,6 @@ ;; set fill pointer (of input or output buffer?) ) -(defmethod device-extend ((stream fill-pointer-output-simple-stream) - need action) - ;; @@4 - ) - (defmethod device-open ((stream xp-simple-stream) options) #| do something |# stream) diff --git a/tools/pclcom.lisp b/tools/pclcom.lisp index 4945780462f61f1333991d5fe08ce63dfa383ea6..b041e8ed4057bce9a4e2d713f0795c41e3a3f7d7 100644 --- a/tools/pclcom.lisp +++ b/tools/pclcom.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.28 2003/06/06 16:23:46 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/pclcom.lisp,v 1.29 2003/06/07 17:56:28 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -117,6 +117,7 @@ (cat-if-anything-changed "pcl:simple-streams-library" + "pcl:simple-streams/herald" "pcl:simple-streams/classes" "pcl:simple-streams/internal" "pcl:simple-streams/strategy" @@ -127,3 +128,11 @@ "pcl:simple-streams/string" "pcl:simple-streams/terminal" "pcl:simple-streams/socket") + +(cat-if-anything-changed + "pcl:iodefs-library" + "pcl:simple-streams/iodefs") + +(cat-if-anything-changed + "pcl:gray-compat-library" + "pcl:simple-streams/gray-compat")