Index: /trunk/ccl/level-1/l1-sysio.lisp =================================================================== --- /trunk/ccl/level-1/l1-sysio.lisp (revision 5275) +++ /trunk/ccl/level-1/l1-sysio.lisp (revision 5276) @@ -21,5 +21,6 @@ (fileeof 0 :type fixnum) ; file length in elements (input-filter #'false) - (output-filter #'false)) + (output-filter #'false) + (line-termination :unix)) @@ -311,5 +312,5 @@ (print-file-stream s out)) -(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream) +(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream) (defmethod stream-filename ((s basic-file-stream)) @@ -389,4 +390,13 @@ (make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream) + +(defun set-basic-stream-prototype (class) + (when (subtypep class 'basic-stream) + (setf (%class.prototype class) (or (%class.prototype class) + (allocate-basic-stream class))) + (dolist (subclass (class-direct-subclasses class)) + (set-basic-stream-prototype subclass)))) + +(set-basic-stream-prototype (find-class 'basic-stream)) ;;; This stuff is a lot simpler if we restrict the hair to the @@ -648,4 +658,18 @@ 'basic-file-binary-output-stream 'basic-file-stream))))) + + +(defmethod select-stream-advance-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-ioblock-advance) + (:input 'input-file-ioblock-advance))) + +(defmethod select-stream-force-output-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-force-output) + (:output 'output-file-force-output))) + + + (defun make-file-stream (filename @@ -694,10 +718,4 @@ (setq native-truename (%create-file filename))) ((memq direction '(:output :io)) - #|;; - ;; this prevents us from writing a file that is open for anything - ;;l but does not protect against reading a file that is open for :output - (when (and bits (eq direction :output)(neq 0 (logand bits #x81))) - (signal-file-error EBUSY filename)) - |# (when (eq if-exists :supersede) (let ((truename (native-to-pathname native-truename))) @@ -726,65 +744,62 @@ (setq basic (subtypep (find-class class) 'basic-stream))) (let* ((in-p (member direction '(:io :input))) - (out-p (member direction '(:io :output))) - (io-p (eq direction :io)) - (char-p (or (eq element-type 'character) - (subtypep element-type 'character))) - (infer nil) - (real-external-format - (if (and char-p in-p) - (progn - (if (eq external-format :default) - (setq external-format *default-external-format*)) - (if (eq external-format :inferred) - (setq infer t external-format :unix) - (unless (assoc external-format - *external-format-translations* - :test #'eq) - (setq external-format :unix))) - external-format) - :binary)) - (fstream (make-ioblock-stream - (select-stream-class class in-p out-p char-p) - :insize (if in-p elements-per-buffer) - :outsize (if (and out-p (not io-p)) - elements-per-buffer) - :share-buffers-p io-p - :interactive nil - :direction direction - :element-type element-type - :direction direction - :listen-function 'fd-stream-listen - :close-function 'fd-stream-close - :advance-function - (if io-p - 'io-file-ioblock-advance - (if in-p - 'input-file-ioblock-advance)) - :force-output-function - (if io-p - 'io-file-force-output - (if out-p - 'output-file-force-output)) - :device fd - :external-format real-external-format - :sharing sharing - :character-p (or (eq element-type 'character) - (subtypep element-type 'character)))) - (ioblock (stream-ioblock fstream t))) - (setf (stream-filename fstream) (namestring pathname) - (stream-actual-filename fstream) temp-name) - (setf (file-ioblock-fileeof ioblock) - (ioblock-octets-to-elements ioblock (fd-size fd))) - (if infer - (infer-external-format fstream)) - (cond ((eq if-exists :append) - (file-position fstream :end)) - ((and (memq direction '(:io :output)) - (neq if-exists :overwrite)) - (stream-length fstream 0))) - (if (eq direction :probe) - (close fstream) - (push fstream *open-file-streams*)) - fstream))))))))) + (out-p (member direction '(:io :output))) + (io-p (eq direction :io)) + (char-p (or (eq element-type 'character) + (subtypep element-type 'character))) + (infer nil) + (real-external-format + (if (and char-p in-p) + (progn + (if (eq external-format :default) + (setq external-format *default-external-format*)) + (if (eq external-format :inferred) + (setq infer t external-format :unix) + (unless (assoc external-format + *external-format-translations* + :test #'eq) + (setq external-format :unix))) + external-format) + :binary)) + (class-name (select-stream-class class in-p out-p char-p)) + (class (find-class class-name)) + (fstream (make-ioblock-stream + class + :insize (if in-p elements-per-buffer) + :outsize (if (and out-p (not io-p)) + elements-per-buffer) + :share-buffers-p io-p + :interactive nil + :direction direction + :element-type element-type + :direction direction + :listen-function 'fd-stream-listen + :close-function 'fd-stream-close + :advance-function + (if in-p (select-stream-advance-function class direction)) + :force-output-function + (if out-p (select-stream-force-output-function + class direction)) + :device fd + :external-format real-external-format + :sharing sharing + :character-p (or (eq element-type 'character) + (subtypep element-type 'character)))) + (ioblock (stream-ioblock fstream t))) + (setf (stream-filename fstream) (namestring pathname) + (stream-actual-filename fstream) temp-name) + (setf (file-ioblock-fileeof ioblock) + (ioblock-octets-to-elements ioblock (fd-size fd))) + (if infer + (infer-external-format fstream)) + (cond ((eq if-exists :append) + (file-position fstream :end)) + ((and (memq direction '(:io :output)) + (neq if-exists :overwrite)) + (stream-length fstream 0))) + (if (eq direction :probe) + (close fstream) + (push fstream *open-file-streams*)) + fstream))))))))) (defmethod stream-external-format ((s fundamental-file-stream))