/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Diff of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.61 by pmai, Fri Aug 23 18:31:05 2002 UTC revision 1.61.2.1 by pmai, Fri Oct 4 23:13:23 2002 UTC
# Line 16  Line 16 
16  ;;;  ;;;
17  ;;; **********************************************************************  ;;; **********************************************************************
18    
19    ;;;
20    ;;; External Format support hacked in should be rewritten, preferably
21    ;;; with the rest of the streams code [BTS]
22    
23    
24  (in-package "SYSTEM")  (in-package "SYSTEM")
25    
# Line 74  Line 78 
78    ;;    ;;
79    ;;; Number of bytes per element.    ;;; Number of bytes per element.
80    (element-size 1 :type index)    (element-size 1 :type index)
81      #-unicode
82    (element-type 'base-char)   ; The type of element being transfered.    (element-type 'base-char)   ; The type of element being transfered.
83      #+unicode
84      (element-type 'character)   ; The type of element being transfered.
85    (fd -1 :type fixnum)        ; The file descriptor    (fd -1 :type fixnum)        ; The file descriptor
86    ;;    ;;
87    ;; Controls when the output buffer is flushed.    ;; Controls when the output buffer is flushed.
# Line 106  Line 113 
113    (timeout nil :type (or index null))    (timeout nil :type (or index null))
114    ;;    ;;
115    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)    ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
116    (pathname nil :type (or pathname null)))    (pathname nil :type (or pathname null))
117      #+unicode ; at the end to reduce bootstrap problems
118      (external-format :default :type symbol)) ; The identifier for the external-format used.
119    
120  (defun %print-fd-stream (fd-stream stream depth)  (defun %print-fd-stream (fd-stream stream depth)
121    (declare (ignore depth) (stream stream))    (declare (ignore depth) (stream stream))
# Line 271  Line 280 
280                                        (cdr buffering)))))))                                        (cdr buffering)))))))
281            bufferings)))            bufferings)))
282    
283  (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"  #+unicode
284    (def-output-routines ("OUTPUT-BASE-CHAR-~A-BUFFERED"
285                          1
286                          (:none base-char)
287                          (:line base-char)
288                          (:full base-char))
289      (if (char= byte #\Newline)
290          (setf (fd-stream-char-pos stream) 0)
291          (incf (fd-stream-char-pos stream)))
292      (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
293            (char-code byte)))
294    
295    (def-output-routines (#-unicode
296                          "OUTPUT-CHAR-~A-BUFFERED"
297                          #+unicode
298                          "OUTPUT-CHARACTER-~A-BUFFERED"
299                        1                        1
300                        (:none character)                        (:none character)
301                        (:line character)                        (:line character)
# Line 280  Line 304 
304        (setf (fd-stream-char-pos stream) 0)        (setf (fd-stream-char-pos stream) 0)
305        (incf (fd-stream-char-pos stream)))        (incf (fd-stream-char-pos stream)))
306    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))    (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
307          (char-code byte)))          (logand (char-code byte) #xFF)))
308    
309  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"  (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
310                        1                        1
# Line 396  Line 420 
420  ;;; than strings. Therefore, we must make sure we have a string before calling  ;;; than strings. Therefore, we must make sure we have a string before calling
421  ;;; position on it.  ;;; position on it.
422  ;;;  ;;;
423    #-unicode
424  (defun fd-sout (stream thing start end)  (defun fd-sout (stream thing start end)
425    (let ((start (or start 0))    (let ((start (or start 0))
426          (end (or end (length (the vector thing)))))          (end (or end (length (the vector thing)))))
# Line 426  Line 451 
451             (output-raw-bytes stream thing start end))             (output-raw-bytes stream thing start end))
452            (:none            (:none
453             (do-output stream thing start end nil))))))             (do-output stream thing start end nil))))))
454    #+unicode
455    (defun fd-sout (stream thing start end)
456      (declare (type string thing))
457      (let ((start (or start 0))
458            (end (or end (length (the vector thing)))))
459        (declare (type index start end))
460        (cond
461         ((simple-base-string-p thing)
462            (let ((last-newline (and (find #\newline (the simple-string thing)
463                                           :start start :end end)
464                                     (position #\newline (the simple-string thing)
465                                               :from-end t
466                                               :start start
467                                               :end end))))
468              (ecase (fd-stream-buffering stream)
469                (:full
470                 (output-raw-bytes stream thing start end))
471                (:line
472                 (output-raw-bytes stream thing start end)
473                 (when last-newline
474                   (flush-output-buffer stream)))
475                (:none
476                 (do-output stream thing start end nil)))
477              (if last-newline
478                  (setf (fd-stream-char-pos stream)
479                        (- end last-newline 1))
480                  (incf (fd-stream-char-pos stream)
481                        (- end start)))))
482         ((stringp thing) ; FIXME - remove this test
483            (let ((out (fd-stream-out stream)))
484            (do ((index start (+ index 1)))
485                ((>= index end))
486              (funcall out stream (elt thing index))))))))
487    
488    #+unicode ; a lame sout hack to make external-format work quickly
489    (defun fd-sout-each-character (stream thing start end)
490      (declare (type string thing))
491      (let ((start (or start 0))
492            (end (or end (length (the vector thing)))))
493        (declare (type index start end))
494        (let ((out (fd-stream-out stream)))
495          (do ((index start (+ index 1)))
496              ((>= index end))
497            (funcall out stream (elt thing index))))))
498    
499  ;;; PICK-OUTPUT-ROUTINE -- internal  ;;; PICK-OUTPUT-ROUTINE -- internal
500  ;;;  ;;;
# Line 573  Line 642 
642  ;;;  ;;;
643  ;;;   Routine to use in stream-in slot for reading string chars.  ;;;   Routine to use in stream-in slot for reading string chars.
644  ;;;  ;;;
645    #+unicode
646    (def-input-routine input-character
647                       (base-char 1 sap head)
648      (code-char (sap-ref-8 sap head)))
649    
650  (def-input-routine input-character  (def-input-routine input-character
651                     (character 1 sap head)                     (character 1 sap head)
652    (code-char (sap-ref-8 sap head)))    (code-char (sap-ref-8 sap head)))
# Line 818  Line 892 
892  ;;; output-p indicate what slots to fill. The buffering slot must be set prior  ;;; output-p indicate what slots to fill. The buffering slot must be set prior
893  ;;; to calling this routine.  ;;; to calling this routine.
894  ;;;  ;;;
895  (defun set-routines (stream type input-p output-p buffer-p)  (defun set-routines (stream type #+unicode external-format input-p output-p buffer-p)
896    (let ((target-type (case type    (let ((target-type (case type
897                         ((:default unsigned-byte)                         ((:default unsigned-byte)
898                          '(unsigned-byte 8))                          '(unsigned-byte 8))
# Line 848  Line 922 
922          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
923          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
924          (if (subtypep type 'character)          (if (subtypep type 'character)
925              (setf (fd-stream-in stream) routine              (setf (fd-stream-in stream)
926                      #-unicode
927                      routine
928                      #+unicode
929                      (external-format::external-format-wrap-input external-format routine)
930                    (fd-stream-bin stream) #'ill-bin)                    (fd-stream-bin stream) #'ill-bin)
931                ; not a character stream
932              (setf (fd-stream-in stream) #'ill-in              (setf (fd-stream-in stream) #'ill-in
933                    (fd-stream-bin stream) routine))                    (fd-stream-bin stream) routine))
934          (when (or (eql size 1)          (when (or (eql size 1)
# Line 882  Line 961 
961          (setf (fd-stream-obuf-length stream) bytes-per-buffer)          (setf (fd-stream-obuf-length stream) bytes-per-buffer)
962          (setf (fd-stream-obuf-tail stream) 0)          (setf (fd-stream-obuf-tail stream) 0)
963          (if (subtypep type 'character)          (if (subtypep type 'character)
964            (setf (fd-stream-out stream) routine              (setf (fd-stream-out stream)
965                      #-unicode
966                      routine
967                      #+unicode
968                      (external-format::external-format-wrap-output external-format routine)
969                      (fd-stream-bout stream) #'ill-bout)
970                ; not a character stream
971                (setf (fd-stream-out stream)
972                      ; not good to mix base-char and bytes...
973                      (if (eql size 1)
974                          (pick-output-routine 'base-char
975                                               (fd-stream-buffering stream))
976                          #'ill-out)
977                      (fd-stream-bout stream) routine))
978            (if (subtypep type 'character)
979                (setf (fd-stream-out stream)
980                      #-unicode
981                      routine
982                      #+unicode
983                      (external-format::external-format-wrap-output external-format routine)
984                  (fd-stream-bout stream) #'ill-bout)                  (fd-stream-bout stream) #'ill-bout)
985                ; not a character stream
986            (setf (fd-stream-out stream)            (setf (fd-stream-out stream)
987                  (or (if (eql size 1)                    ; not good to mix base-char and bytes...
988                      (if (eql size 1)
989                        (pick-output-routine 'base-char                        (pick-output-routine 'base-char
990                                             (fd-stream-buffering stream)))                                             (fd-stream-buffering stream))
991                      #'ill-out)                      #'ill-out)
992                  (fd-stream-bout stream) routine))                  (fd-stream-bout stream) routine))
993          (setf (fd-stream-sout stream)          (setf (fd-stream-sout stream)
994                (if (eql size 1) #'fd-sout #'ill-out))                #-unicode
995                  (if (eql size 1) #'fd-sout #'ill-out)
996                  #+unicode
997                  (if (eql size 1)
998                      (if (eq external-format :default)
999                          #'fd-sout
1000                          #'fd-sout-each-character)
1001                      #'ill-out))
1002          (setf (fd-stream-char-pos stream) 0)          (setf (fd-stream-char-pos stream) 0)
1003          (setf output-size size)          (setf output-size size)
1004          (setf output-type type)))          (setf output-type type)))
# Line 1148  Line 1255 
1255                         &key                         &key
1256                         (input nil input-p)                         (input nil input-p)
1257                         (output nil output-p)                         (output nil output-p)
1258                           #-unicode
1259                         (element-type 'base-char)                         (element-type 'base-char)
1260                           #+unicode
1261                           (element-type 'character)
1262                           #+unicode
1263                           (external-format :default)
1264                         (buffering :full)                         (buffering :full)
1265                         timeout                         timeout
1266                         file                         file
# Line 1183  Line 1295 
1295                                   :delete-original delete-original                                   :delete-original delete-original
1296                                   :pathname pathname                                   :pathname pathname
1297                                   :buffering buffering                                   :buffering buffering
1298                                     #+unicode :external-format #+unicode external-format
1299                                   :timeout timeout)))                                   :timeout timeout)))
1300      (set-routines stream element-type input output input-buffer-p)      (set-routines stream element-type #+unicode external-format input output input-buffer-p)
1301      (when (and auto-close (fboundp 'finalize))      (when (and auto-close (fboundp 'finalize))
1302        (finalize stream        (finalize stream
1303                  #'(lambda ()                  #'(lambda ()
# Line 1208  Line 1321 
1321    (declare (type simple-string name))    (declare (type simple-string name))
1322    (let ((ext *backup-extension*))    (let ((ext *backup-extension*))
1323      (etypecase ext      (etypecase ext
1324        (simple-string (concatenate 'simple-string name ext))        (simple-base-string (concatenate 'simple-base-string name ext))
1325        (function (funcall ext name)))))        (function (funcall ext name)))))
1326    
1327  ;;; ASSURE-ONE-OF -- internal  ;;; ASSURE-ONE-OF -- internal
# Line 1270  Line 1383 
1383  (defun open (filename  (defun open (filename
1384               &key               &key
1385               (direction :input)               (direction :input)
1386                 #-unicode
1387               (element-type 'base-char)               (element-type 'base-char)
1388                 #+unicode
1389                 (element-type 'character)
1390               (if-exists nil if-exists-given)               (if-exists nil if-exists-given)
1391               (if-does-not-exist nil if-does-not-exist-given)               (if-does-not-exist nil if-does-not-exist-given)
1392               (external-format :default)               (external-format :default)
# Line 1279  Line 1395 
1395               (direction direction)               (direction direction)
1396               (if-does-not-exist if-does-not-exist)               (if-does-not-exist if-does-not-exist)
1397               (if-exists if-exists))               (if-exists if-exists))
1398      #-unicode
1399      "Return a stream which reads from or writes to Filename.
1400      Defined keywords:
1401       :direction - one of :input, :output, :io, or :probe
1402       :element-type - Type of object to read or write, default BASE-CHAR
1403       :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1404                           :overwrite, :append, :supersede or nil
1405       :if-does-not-exist - one of :error, :create or nil
1406      See the manual for details."
1407      #+unicode
1408    "Return a stream which reads from or writes to Filename.    "Return a stream which reads from or writes to Filename.
1409    Defined keywords:    Defined keywords:
1410     :direction - one of :input, :output, :io, or :probe     :direction - one of :input, :output, :io, or :probe
# Line 1286  Line 1412 
1412     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,     :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
1413                         :overwrite, :append, :supersede or nil                         :overwrite, :append, :supersede or nil
1414     :if-does-not-exist - one of :error, :create or nil     :if-does-not-exist - one of :error, :create or nil
1415       :external-format - an external file format designator.
1416    See the manual for details."    See the manual for details."
1417      #-unicode
1418    (declare (ignore external-format))    (declare (ignore external-format))
1419    
1420    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.    ;; First, make sure that DIRECTION is valid. Allow it to be changed if not.
# Line 1410  Line 1538 
1538                                         :input input                                         :input input
1539                                         :output output                                         :output output
1540                                         :element-type element-type                                         :element-type element-type
1541                                           #+unicode :external-format #+unicode external-format
1542                                         :file namestring                                         :file namestring
1543                                         :original original                                         :original original
1544                                         :delete-original delete-original                                         :delete-original delete-original
# Line 1474  Line 1603 
1603  ;;; Called when the cold load is first started up.  ;;; Called when the cold load is first started up.
1604  ;;;  ;;;
1605  (defun stream-init ()  (defun stream-init ()
1606    (stream-reinit)    (let ((external-format::*default-external-file-format-designator* nil))
1607        (stream-reinit))
1608    (setf *terminal-io* (make-synonym-stream '*tty*))    (setf *terminal-io* (make-synonym-stream '*tty*))
1609    (setf *standard-output* (make-synonym-stream '*stdout*))    (setf *standard-output* (make-synonym-stream '*stdout*))
1610    (setf *standard-input*    (setf *standard-input*

Legend:
Removed from v.1.61  
changed lines
  Added in v.1.61.2.1

  ViewVC Help
Powered by ViewVC 1.1.5