Ignore:
Timestamp:
Sep 27, 2006, 11:46:02 AM (13 years ago)
Author:
gb
Message:

More FILE-STREAM changes. Give BASIC-STREAM classes a class prototype.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-sysio.lisp

    r5265 r5276  
    2121  (fileeof 0 :type fixnum)              ; file length in elements
    2222  (input-filter #'false)
    23   (output-filter #'false))
     23  (output-filter #'false)
     24  (line-termination :unix))
    2425
    2526
     
    311312  (print-file-stream s out))
    312313
    313 (make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
     314(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream)
    314315
    315316(defmethod stream-filename ((s basic-file-stream))
     
    389390(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream)
    390391
     392
     393(defun set-basic-stream-prototype (class)
     394  (when (subtypep class 'basic-stream)
     395    (setf (%class.prototype class) (or (%class.prototype class)
     396                                       (allocate-basic-stream class)))
     397    (dolist (subclass (class-direct-subclasses class))
     398      (set-basic-stream-prototype subclass))))
     399
     400(set-basic-stream-prototype (find-class 'basic-stream))
    391401
    392402;;; This stuff is a lot simpler if we restrict the hair to the
     
    648658          'basic-file-binary-output-stream
    649659          'basic-file-stream)))))
     660
     661
     662(defmethod select-stream-advance-function ((s file-stream) direction)
     663  (ecase direction
     664    (:io 'io-file-ioblock-advance)
     665    (:input 'input-file-ioblock-advance)))
     666
     667(defmethod select-stream-force-output-function ((s file-stream) direction)
     668  (ecase direction
     669    (:io 'io-file-force-output)
     670    (:output 'output-file-force-output)))
     671
     672
     673
    650674
    651675(defun make-file-stream (filename
     
    694718                   (setq native-truename (%create-file filename)))
    695719                  ((memq direction '(:output :io))
    696                    #|;;
    697                    ;; this prevents us from writing a file that is open for anything           
    698                    ;;l but does not protect against reading a file that is open for :output
    699                    (when (and bits (eq direction :output)(neq 0 (logand bits #x81)))
    700                    (signal-file-error EBUSY filename))
    701                    |#
    702720                   (when (eq if-exists :supersede)
    703721                     (let ((truename (native-to-pathname native-truename)))
     
    726744                  (setq basic (subtypep (find-class class) 'basic-stream)))
    727745                (let* ((in-p (member direction '(:io :input)))
    728                      (out-p (member direction '(:io :output)))
    729                      (io-p (eq direction :io))
    730                      (char-p (or (eq element-type 'character)
    731                                  (subtypep element-type 'character)))
    732                      (infer nil)
    733                      (real-external-format
    734                       (if (and char-p in-p)
    735                         (progn
    736                           (if (eq external-format :default)
    737                             (setq external-format *default-external-format*))
    738                           (if (eq external-format :inferred)
    739                             (setq infer t external-format :unix)
    740                             (unless (assoc external-format
    741                                            *external-format-translations*
    742                                            :test #'eq)
    743                               (setq external-format :unix)))
    744                           external-format)
    745                         :binary))
    746                      (fstream (make-ioblock-stream
    747                                (select-stream-class class in-p out-p char-p)
    748                                :insize (if in-p elements-per-buffer)
    749                                :outsize (if (and out-p (not io-p))
    750                                           elements-per-buffer)
    751                                :share-buffers-p io-p
    752                                :interactive nil
    753                                :direction direction
    754                                :element-type element-type
    755                                :direction direction
    756                                :listen-function 'fd-stream-listen
    757                                :close-function 'fd-stream-close
    758                                :advance-function
    759                                (if io-p
    760                                  'io-file-ioblock-advance
    761                                  (if in-p
    762                                    'input-file-ioblock-advance))
    763                                :force-output-function
    764                                (if io-p
    765                                  'io-file-force-output
    766                                  (if out-p
    767                                    'output-file-force-output))
    768                                :device fd
    769                                :external-format real-external-format
    770                                :sharing sharing
    771                                :character-p (or (eq element-type 'character)
    772                                                 (subtypep element-type 'character))))
    773                      (ioblock (stream-ioblock fstream t)))
    774                 (setf (stream-filename fstream) (namestring pathname)
    775                       (stream-actual-filename fstream) temp-name)
    776                 (setf (file-ioblock-fileeof ioblock)
    777                       (ioblock-octets-to-elements ioblock (fd-size fd)))
    778                 (if infer
    779                   (infer-external-format fstream))
    780                 (cond ((eq if-exists :append)
    781                        (file-position fstream :end))
    782                       ((and (memq direction '(:io :output))
    783                             (neq if-exists :overwrite))
    784                        (stream-length fstream 0)))
    785                 (if (eq direction :probe)
    786                   (close fstream)
    787                   (push fstream *open-file-streams*))
    788                 fstream)))))))))
     746                       (out-p (member direction '(:io :output)))
     747                       (io-p (eq direction :io))
     748                       (char-p (or (eq element-type 'character)
     749                                   (subtypep element-type 'character)))
     750                       (infer nil)
     751                       (real-external-format
     752                        (if (and char-p in-p)
     753                          (progn
     754                            (if (eq external-format :default)
     755                              (setq external-format *default-external-format*))
     756                            (if (eq external-format :inferred)
     757                              (setq infer t external-format :unix)
     758                              (unless (assoc external-format
     759                                             *external-format-translations*
     760                                             :test #'eq)
     761                                (setq external-format :unix)))
     762                            external-format)
     763                          :binary))
     764                       (class-name (select-stream-class class in-p out-p char-p))
     765                       (class (find-class class-name))
     766                       (fstream (make-ioblock-stream
     767                                 class
     768                                 :insize (if in-p elements-per-buffer)
     769                                 :outsize (if (and out-p (not io-p))
     770                                            elements-per-buffer)
     771                                 :share-buffers-p io-p
     772                                 :interactive nil
     773                                 :direction direction
     774                                 :element-type element-type
     775                                 :direction direction
     776                                 :listen-function 'fd-stream-listen
     777                                 :close-function 'fd-stream-close
     778                                 :advance-function
     779                                 (if in-p (select-stream-advance-function class direction))
     780                                 :force-output-function
     781                                 (if out-p (select-stream-force-output-function
     782                                           class direction))
     783                                 :device fd
     784                                 :external-format real-external-format
     785                                 :sharing sharing
     786                                 :character-p (or (eq element-type 'character)
     787                                                  (subtypep element-type 'character))))
     788                       (ioblock (stream-ioblock fstream t)))
     789                  (setf (stream-filename fstream) (namestring pathname)
     790                        (stream-actual-filename fstream) temp-name)
     791                  (setf (file-ioblock-fileeof ioblock)
     792                        (ioblock-octets-to-elements ioblock (fd-size fd)))
     793                  (if infer
     794                    (infer-external-format fstream))
     795                  (cond ((eq if-exists :append)
     796                         (file-position fstream :end))
     797                        ((and (memq direction '(:io :output))
     798                              (neq if-exists :overwrite))
     799                         (stream-length fstream 0)))
     800                  (if (eq direction :probe)
     801                    (close fstream)
     802                    (push fstream *open-file-streams*))
     803                  fstream)))))))))
    789804
    790805(defmethod stream-external-format ((s fundamental-file-stream))
Note: See TracChangeset for help on using the changeset viewer.