Skip to content
Snippets Groups Projects
fd-stream.lisp 87.8 KiB
Newer Older
ram's avatar
ram committed
;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
;;;
;;;   Routine to read in an unsigned 8 bit number.
;;;
(def-input-routine input-unsigned-8bit-byte
		   ((unsigned-byte 8) 1 sap head)
  (sap-ref-8 sap head))
ram's avatar
ram committed

;;; INPUT-SIGNED-8BIT-BYTE -- internal
;;;
;;;   Routine to read in a signed 8 bit number.
;;;
(def-input-routine input-signed-8bit-number
		   ((signed-byte 8) 1 sap head)
  (signed-sap-ref-8 sap head))
ram's avatar
ram committed

;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
;;;
;;;   Routine to read in an unsigned 16 bit number.
;;;
(def-input-routine input-unsigned-16bit-byte
		   ((unsigned-byte 16) 2 sap head)
ram's avatar
ram committed

;;; INPUT-SIGNED-16BIT-BYTE -- internal
;;;
;;;   Routine to read in a signed 16 bit number.
;;;
(def-input-routine input-signed-16bit-byte
		   ((signed-byte 16) 2 sap head)
  (signed-sap-ref-16 sap head))
ram's avatar
ram committed

;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
;;;
;;;   Routine to read in a unsigned 32 bit number.
;;;
(def-input-routine input-unsigned-32bit-byte
		   ((unsigned-byte 32) 4 sap head)
ram's avatar
ram committed

;;; INPUT-SIGNED-32BIT-BYTE -- internal
;;;
;;;   Routine to read in a signed 32 bit number.
;;;
(def-input-routine input-signed-32bit-byte
		   ((signed-byte 32) 4 sap head)
  (signed-sap-ref-32 sap head))
ram's avatar
ram committed

(stream::def-ef-macro ef-cin (extfmt lisp stream::+ef-max+ stream::+ef-cin+)
rtoy's avatar
rtoy committed
  `(lambda (stream eof-error-p eof-value)
     (declare (type fd-stream stream)
rtoy's avatar
rtoy committed
	      #|(optimize (speed 3) (space 0) (debug 0) (safety 0))|#)
     (let* ((head (fd-stream-ibuf-head stream))
	    (ch (catch 'eof-input-catcher
		  (stream::octets-to-char ,extfmt
			      (fd-stream-oc-state stream)
			      (fd-stream-last-char-read-size stream)
			      ;;@@ Note: need proper EOF handling...
			      (progn
				(when (= head (fd-stream-ibuf-tail stream))
				  (let ((sofar (- head (fd-stream-ibuf-head
							stream))))
				    (do-input stream)
				    (setf head (+ (fd-stream-ibuf-head stream)
						  sofar))))
				(bref (fd-stream-ibuf-sap stream)
				      (1- (incf head))))
			      (lambda (n) (decf head n))))))
       (declare (type index head))
       (if ch
	   (progn
	     (setf (fd-stream-ibuf-head stream) head)
	     ch)
	   (eof-or-lose stream eof-error-p eof-value)))))

#+(or)
(stream::def-ef-macro ef-sin (extfmt lisp stream::+ef-max+ stream::+ef-sin+)
  `(lambda (stream string char start end)
     (declare (type fd-stream stream)
	      (type simple-string string)
	      (type (or character null) char)
	      (type index start end)
	      (optimize (speed 3) (space 0) (debug 0) (safety 0)))
     (let ((sap (fd-stream-ibuf-sap stream))
	   (head (fd-stream-ibuf-head stream))
	   (tail (fd-stream-ibuf-tail stream))
	   (curr start))
       (declare (type sys:system-area-pointer sap)
		(type index head tail curr))
       (loop
	 ;;@@ Fix EOF handling
	 (let* ((sz 0)
		(ch (catch 'eof-input-catcher
		      (stream::octets-to-char ,extfmt
rtoy's avatar
rtoy committed
				  (fd-stream-oc-state stream)
				  sz
				  (progn
				    (when (= head tail)
				      (let ((sofar (- head
						      (fd-stream-ibuf-head
						       stream))))
					(do-input stream)
					(setq head
					      (+ (fd-stream-ibuf-head
						  stream)
						 sofar)
					    tail
					    (fd-stream-ibuf-tail
					     stream))))
				    (bref sap (1- (incf head))))
				  (lambda (n) (decf head n))))))
	   (declare (type index sz)
		    (type (or null character) ch))
	   (when (null ch)
	     (return (values (- curr start) :eof)))
	   (setf (fd-stream-last-char-read-size stream) sz)
	   (incf (fd-stream-ibuf-head stream) sz)
	   (when (and char (char= ch char))
	     (return (values (- curr start) t)))
	   (setf (schar string (1- (incf curr))) ch)
	   (when (= curr end)
	     (return (values (- curr start) nil))))))))

ram's avatar
ram committed
;;; PICK-INPUT-ROUTINE -- internal
;;;
;;;   Find an input routine to use given the type. Return as multiple values
;;; the routine, the real type transfered, and the number of bytes per element.
;;;
(defun pick-input-routine (type)
  (dolist (entry *input-routines*)
    (when (subtypep type (car entry))
      (return-from pick-input-routine
	(values (symbol-function (cadr entry))
		(car entry)
		(caddr entry)))))
  ;; FIXME: let's do it the hard way, then (but ignore things like
  ;; endianness, efficiency, and the necessary coupling between these
  ;; and the output routines).  -- CSR, 2004-02-09
  (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
	if (subtypep type `(unsigned-byte ,i))
	do (return-from pick-input-routine
	     (values
	      (lambda (stream eof-error eof-value)
		(input-wrapper (stream (/ i 8) eof-error eof-value)
		  (let ((sap (fd-stream-ibuf-sap stream))
			(head (fd-stream-ibuf-head stream)))
		    (loop for j from 0 below (/ i 8)
			  with result = 0
			  do (setf result
				   (+ (* 256 result)
				      (sap-ref-8 sap (+ head j))))
			  finally (return result)))))
	      `(unsigned-byte ,i)
	      (/ i 8))))
  (loop for i from 40 by 8 to max-stream-element-size ; ARB (well, KLUDGE really)
	if (subtypep type `(signed-byte ,i))
	do (return-from pick-input-routine
	     (values
	      (lambda (stream eof-error eof-value)
		(input-wrapper (stream (/ i 8) eof-error eof-value)
		  (let ((sap (fd-stream-ibuf-sap stream))
			(head (fd-stream-ibuf-head stream)))
		    (loop for j from 0 below (/ i 8)
			  with result = 0
			  do (setf result
				   (+ (* 256 result)
				      (sap-ref-8 sap (+ head j))))
		          finally (return (if (logbitp (1- i) result)
					      (dpb result (byte i 0) -1)
					      result))))))
ram's avatar
ram committed

;;; STRING-FROM-SAP -- internal
;;;
;;;   Returns a string constructed from the sap, start, and end.
;;;
(defun string-from-sap (sap start end)
  (declare (type index start end))
ram's avatar
ram committed
  (let* ((length (- end start))
	 (string (make-string length)))
    (copy-from-system-area sap (* start vm:byte-bits)
			   string (* vm:vector-data-offset vm:word-bits)
			   (* length vm:byte-bits))
ram's avatar
ram committed
    string))

ram's avatar
ram committed
;;; FD-STREAM-READ-N-BYTES -- internal
;;;
dtc's avatar
dtc committed
;;; This version waits using server.  I changed to the non-server version
;;; because it allows this method to be used by CLX w/o confusing serve-event.
;;; The non-server method is also significantly more efficient for large
;;; reads. -- Ram
;;;
ram's avatar
ram committed
;;; The n-bin routine.
;;; 
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
dtc's avatar
dtc committed
  (declare (type stream stream) (type index start requested))
ram's avatar
ram committed
  (let* ((sap (fd-stream-ibuf-sap stream))
	 (elsize (fd-stream-element-size stream))
	 (offset (* elsize start))
	 (bytes (* elsize requested))
	 (result
	  (catch 'eof-input-catcher
	    (loop
	      (input-at-least stream 1)
	      (let* ((head (fd-stream-ibuf-head stream))
		     (tail (fd-stream-ibuf-tail stream))
		     (available (- tail head))
		     (copy (min available bytes)))
		(if (typep buffer 'system-area-pointer)
		    (system-area-copy sap (* head vm:byte-bits)
				      buffer (* offset vm:byte-bits)
				      (* copy vm:byte-bits))
		    (copy-from-system-area sap (* head vm:byte-bits)
					   buffer (+ (* offset vm:byte-bits)
						     (* vm:vector-data-offset
							vm:word-bits))
					   (* copy vm:byte-bits)))
		(incf (fd-stream-ibuf-head stream) copy)
		(incf offset copy)
		(decf bytes copy))
	      (when (zerop bytes)
		(return requested))))))
    (or result
	(eof-or-lose stream eof-error-p 
		     (- requested (/ bytes elsize))))))
dtc's avatar
dtc committed
;;;    The N-Bin method for FD-STREAMs.  This doesn't use the SERVER; it blocks
;;; in UNIX-READ.  This allows the method to be used to implement reading
;;; for CLX.  It is generally used where there is a definite amount of reading
;;; to be done, so blocking isn't too problematical.
;;;
;;;    We copy buffered data into the buffer.  If there is enough, just return.
;;; Otherwise, we see if the amount of additional data needed will fit in the
;;; stream buffer.  If not, inhibit GCing (so we can have a SAP into the Buffer
;;; argument), and read directly into the user supplied buffer.  Otherwise,
;;; read a buffer-full into the stream buffer and then copy the amount we need
;;; out.
;;;
;;;    We loop doing the reads until we either get enough bytes or hit EOF.  We
;;; must loop when eof-errorp is T because some streams (like pipes) may return
;;; a partial amount without hitting EOF.
;;;
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
  (declare (type stream stream) (type index start requested))
  (let* ((sap (fd-stream-ibuf-sap stream))
	 (offset start)
	 (head (fd-stream-ibuf-head stream))
	 (tail (fd-stream-ibuf-tail stream))
	 (available (- tail head))
	 (copy (min requested available)))
    (declare (type index offset head tail available copy))
    ;;
    ;; If something has been unread, put that at buffer + start,
    ;; and read the rest to start + 1.
    (when (fd-stream-unread stream) ;;@@
      (etypecase buffer
	(system-area-pointer
	 (assert (= 1 (fd-stream-element-size stream)))
	 (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
	(string 
	 (setf (aref buffer start) (read-char stream)))
	 (setf (aref buffer start) (char-code(read-char stream)))))
      (return-from fd-stream-read-n-bytes
	(1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
				    eof-error-p))))
    ;;
    (unless (zerop copy)
      (if (typep buffer 'system-area-pointer)
	  (system-area-copy sap (* head vm:byte-bits)
			    buffer (* offset vm:byte-bits)
			    (* copy vm:byte-bits))
	  (copy-from-system-area sap (* head vm:byte-bits)
				 buffer (+ (* offset vm:byte-bits)
					   (* vm:vector-data-offset
					      vm:word-bits))
				 (* copy vm:byte-bits)))
      (incf (fd-stream-ibuf-head stream) copy))
    (cond
     ((or (= copy requested)
	  (and (not eof-error-p) (/= copy 0)))
      copy)
     (t
      (setf (fd-stream-ibuf-head stream) 0)
      (setf (fd-stream-ibuf-tail stream) 0)
      (setf (fd-stream-listen stream) nil)
      (let ((now-needed (- requested copy))
	    (len (fd-stream-ibuf-length stream)))
	(declare (type index now-needed len))
	(cond
	 ((> now-needed len)
	  ;;
	  ;; If the desired amount is greater than the stream buffer size, then
	  ;; read directly into the destination, incrementing the start
	  ;; accordingly.  In this case, we never leave anything in the stream
	  ;; buffer.
	  (system:without-gcing
	    (loop
	      (multiple-value-bind
		  (count err)
		  (unix:unix-read (fd-stream-fd stream)
				  (sap+ (if (typep buffer 'system-area-pointer)
					    buffer
					    (vector-sap buffer))
					(+ offset copy))
				  now-needed)
		(declare (type (or index null) count))
		(unless count
		  (error (intl:gettext "Error reading ~S: ~A") stream
			 (unix:get-unix-error-msg err)))
		(decf now-needed count)
		(if eof-error-p
		    (when (zerop count)
		      (error 'end-of-file :stream stream))
		    (return (- requested now-needed)))
		(when (zerop now-needed) (return requested))
		(incf offset count)))))
	 (t
	  ;;
	  ;; If we want less than the buffer size, then loop trying to fill the
	  ;; stream buffer and copying what we get into the destination.  When
	  ;; we have enough, we leave what's left in the stream buffer.
		(unix:unix-read (fd-stream-fd stream) sap len)
	      (declare (type (or index null) count))
	      (unless count
		(error (intl:gettext "Error reading ~S: ~A") stream
		       (unix:get-unix-error-msg err)))
	      (when (and eof-error-p (zerop count))
		(error 'end-of-file :stream stream))

	      (let* ((copy (min now-needed count))
		     (copy-bits (* copy vm:byte-bits))
		     (buffer-start-bits
		      (* (+ offset available) vm:byte-bits)))
		(declare (type index copy copy-bits buffer-start-bits))
		(if (typep buffer 'system-area-pointer)
		    (system-area-copy sap 0
				      buffer buffer-start-bits
				      copy-bits)
		    (copy-from-system-area sap 0 
					   buffer (+ buffer-start-bits
						     (* vm:vector-data-offset
							vm:word-bits))
					   copy-bits))
		(when (or (zerop now-needed) (not eof-error-p))
		  (setf (fd-stream-ibuf-head stream) copy)
		  (setf (fd-stream-ibuf-tail stream) count)
		  (return (- requested now-needed)))
		(incf offset copy)))))))))))
ram's avatar
ram committed


;;;; Utility functions (misc routines, etc)

;;; SET-ROUTINES -- internal
;;;
;;;   Fill in the various routine slots for the given type. Input-p and
;;; output-p indicate what slots to fill. The buffering slot must be set prior
;;; to calling this routine.
ram's avatar
ram committed
;;;
(defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
ram's avatar
ram committed
  (let ((target-type (case type
		       ((:default unsigned-byte)
			'(unsigned-byte 8))
		       (signed-byte
			'(signed-byte 8))
		       (t
			type)))
	(input-type nil)
	(output-type nil)
	(input-size nil)
	(output-size nil))
    
    (when (fd-stream-obuf-sap stream)
      (push (fd-stream-obuf-sap stream) *available-buffers*)
      (setf (fd-stream-obuf-sap stream) nil))
    (when (fd-stream-ibuf-sap stream)
      (push (fd-stream-ibuf-sap stream) *available-buffers*)
      (setf (fd-stream-ibuf-sap stream) nil))

    #+unicode
    (when (null (fd-stream-external-format stream))
      (setf (fd-stream-external-format stream) :default))
ram's avatar
ram committed
    
    (when input-p
      (multiple-value-bind
	  (routine type size)
	  (pick-input-routine target-type)
	(unless routine
	  (error (intl:gettext "Could not find any input routine for ~S") target-type))
	(setf (fd-stream-ibuf-sap stream) (next-available-buffer))
	(setf (fd-stream-ibuf-length stream) bytes-per-buffer)
	(setf (fd-stream-ibuf-tail stream) 0)

	;; Set the in and bin methods.  Normally put an illegal input
	;; function in, but if we have a binary text stream, pick an
	;; appropriate input routine.
ram's avatar
ram committed
	(if (subtypep type 'character)
	    (setf (fd-stream-in stream) routine
		  (fd-stream-bin stream) (if (and binary-stream-p
						  (eql size 1))
					     (pick-input-routine '(unsigned-byte 8))
					     #'ill-bin))
	    (setf (fd-stream-in stream) (if (and binary-stream-p
						 (eql size 1))
					    (pick-input-routine 'character) 
					    #'ill-in)
		  (fd-stream-bin stream) routine))
	(when (or (eql size 1)
		  (eql size 2)
		  (eql size 4))
	  ;; Support for n-byte operations on 8-, 16-, and 32-bit streams
	  (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
	  (when (and buffer-p (eql size 1)
		     (or
		      ;; FIXME: Do this better.  We want to check for
		      ;; (unsigned-byte 8).  The 8 is unnecessary
		      ;; since we already have size = 1.
		      (or (eq 'unsigned-byte (and (consp type) (car type)))
			  (eq type :default))
		      (eq type 'character)))
	    (when *enable-stream-buffer-p*
	      (when (and (not binary-stream-p)
			 (eq type 'character))
		;; Create the in-buffer for any character (only)
		;; stream.  Don't want one for binary-text-streams!
		(setf (lisp-stream-in-buffer stream)
		      (make-array in-buffer-length
				  :element-type '(unsigned-byte 8))))
	      (when (and (not binary-stream-p)
			 (eq type 'character)
			 (not (eq :iso8859-1 (fd-stream-external-format stream))))
		;; For character streams, we create the string-buffer so
		;; we can convert all available octets at once instead
		;; of for each character.  The string is one element
		;; longer than in-buffer-length to leave room for
		;; unreading.
		;;
		;; For ISO8859-1, we don't want this because it's very
		;; easy and quick to convert octets to iso8859-1.  (See
		;; FAST-READ-CHAR.)
		(setf (lisp-stream-string-buffer stream)
		      (make-string (1+ in-buffer-length)))
		(setf (fd-stream-octet-count stream)
		      (make-array in-buffer-length :element-type '(unsigned-byte 8)))
		(setf (lisp-stream-string-buffer-len stream) 0)
		(setf (lisp-stream-string-index stream) 0)))))
ram's avatar
ram committed
	(setf input-size size)
	(setf input-type type)))

    (when output-p
      (multiple-value-bind
	  (routine type size)
	  (pick-output-routine target-type (fd-stream-buffering stream))
	(unless routine
	  (error (intl:gettext "Could not find any output routine for ~S buffered ~S.")
ram's avatar
ram committed
		 (fd-stream-buffering stream)
		 target-type))
	(setf (fd-stream-obuf-sap stream) (next-available-buffer))
	(setf (fd-stream-obuf-length stream) bytes-per-buffer)
ram's avatar
ram committed
	(setf (fd-stream-obuf-tail stream) 0)
	;; Normally signal errors for reading from a stream with the
	;; wrong element type, but allow binary-text-streams to read
	;; from either.
ram's avatar
ram committed
	(if (subtypep type 'character)
	    (setf (fd-stream-out stream) routine
		  (fd-stream-bout stream)
		    (if (and binary-stream-p
			     (eql size 1))
			(pick-output-routine '(unsigned-byte 8)
					     (fd-stream-buffering stream))
			#'ill-bout))
	    (setf (fd-stream-out stream)
		  (if (and binary-stream-p (eql size 1))
		      (pick-output-routine 'base-char
					   (fd-stream-buffering stream))
		      #'ill-out)
		  (fd-stream-bout stream) routine))
ram's avatar
ram committed
	(setf (fd-stream-sout stream)
	      (if (eql size 1) #'fd-sout #'ill-out))
ram's avatar
ram committed
	(setf (fd-stream-char-pos stream) 0)
	(setf output-size size)
	(setf output-type type)))

    (when (and input-size output-size
	       (not (eql input-size output-size)))
      (error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?")
ram's avatar
ram committed
	     input-type input-size
	     output-type output-size))
    (setf (fd-stream-element-size stream)
	  (or input-size output-size))

    (setf (fd-stream-element-type stream)
	  (cond ((equal input-type output-type)
		 input-type)
		((null output-type)
		 input-type)
		((null input-type)
		 output-type)
		((subtypep input-type output-type)
ram's avatar
ram committed
		 input-type)
		((subtypep output-type input-type)
		 output-type)
		(t
		 (error (intl:gettext "Input type (~S) and output type (~S) are unrelated?")
ram's avatar
ram committed
			input-type
			output-type))))))

;;; REVERT-FILE -- internal
;;;
;;;   Revert a file, if possible; otherwise do nothing.  Used during
;;; CLOSE when the abort flag is set.
;;;
(defun revert-file (filename original)
  (declare (type simple-base-string filename)
	   (type (or simple-base-string null) original))
  (when original
    (multiple-value-bind (okay err)
	(unix:unix-rename original filename)
      (unless okay
	  (cerror (intl:gettext "Go on as if nothing bad happened.")
		  (intl:gettext "Could not restore ~S to its original contents: ~A")
		  filename (unix:get-unix-error-msg err))))))

;;; DELETE-ORIGINAL -- internal
;;;
;;;   Delete a backup file.  Used during CLOSE.
;;;
(defun delete-original (filename original)
  (declare (type simple-base-string filename)
	   (type (or simple-base-string null) original))
  (when original
    (multiple-value-bind (okay err) (unix:unix-unlink original)
      (unless okay
	(cerror "Go on as if nothing bad happened."
		"Could not delete ~S during close of ~S: ~A"
emarsden's avatar
emarsden committed
		original filename (unix:get-unix-error-msg err))))))
ram's avatar
ram committed
;;; FD-STREAM-MISC-ROUTINE -- input
;;;
;;;   Handle the various misc operations on fd-stream.
;;;
(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
  (declare (ignore arg2))
ram's avatar
ram committed
  (case operation
ram's avatar
ram committed
     (or (not (eql (fd-stream-ibuf-head stream)
		   (fd-stream-ibuf-tail stream)))
	 (fd-stream-listen stream)
	 (setf (fd-stream-listen stream)
	       (eql (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
		      (unix:fd-zero read-fds)
		      (unix:fd-set (fd-stream-fd stream) read-fds)
		      (unix:unix-fast-select (1+ (fd-stream-fd stream))
					     (alien:addr read-fds) nil nil
					     0 0))
ram's avatar
ram committed
    (:unread
     #-unicode
     (setf (fd-stream-unread stream) arg1)
     #+unicode
     (cond ((lisp-stream-string-buffer stream)
	    (if (zerop (lisp-stream-string-index stream))
		(setf (fd-stream-unread stream) arg1)
		(decf (lisp-stream-string-index stream))))
	   (t
	    (if (zerop (fd-stream-last-char-read-size stream))
		(setf (fd-stream-unread stream) arg1)
		(decf (fd-stream-ibuf-head stream)
		      (fd-stream-last-char-read-size stream)))))
     ;; Paul says:
     ;; 
     ;; Not needed for unicode when unreading is implemented by backing up in
     ;; the buffer (e.g., with last-char-read-size...)
     ;;
     ;; (AFAICS there's nothing wrong with setting it there, but it
     ;; screws up read-interactive in my toplevel command thing -
     ;; leaves it expecting to read arguments when it shouldn't,
     ;; because LISTEN returns T when there's no input pending, but I
     ;; don't understand why...)
     #-unicode
     (setf (fd-stream-listen stream) t))
ram's avatar
ram committed
    (:close
     (cond (arg1
	    ;; We got us an abort on our hands.
	    (when (fd-stream-handler stream)
		  (system:remove-fd-handler (fd-stream-handler stream))
		  (setf (fd-stream-handler stream) nil))
	    (when (and (fd-stream-file stream) (fd-stream-obuf-sap stream))
	      (revert-file (fd-stream-file stream)
			   (fd-stream-original stream))))
ram's avatar
ram committed
	   (t
	    #+(and unicode (not unicode-bootstrap))
	    (when (and (output-stream-p stream)
		       (eq (stream-element-type stream) 'character))
	      ;; For output character streams, we need to flush out
	      ;; any state that the external format might have.
	      #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
	      (funcall (ef-flush (fd-stream-external-format stream))
		       stream))
ram's avatar
ram committed
	    (fd-stream-misc-routine stream :finish-output)
	    (when (fd-stream-delete-original stream)
	      (delete-original (fd-stream-file stream)
			       (fd-stream-original stream)))))
     (when (fboundp 'cancel-finalization)
       (cancel-finalization stream))
     (unix:unix-close (fd-stream-fd stream))
     (when (fd-stream-obuf-sap stream)
       (push (fd-stream-obuf-sap stream) *available-buffers*)
       (setf (fd-stream-obuf-sap stream) nil))
     (when (fd-stream-ibuf-sap stream)
       (push (fd-stream-ibuf-sap stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap stream) nil))
ram's avatar
ram committed
     (lisp::set-closed-flame stream))
     (setf (fd-stream-unread stream) nil) ;;@@
     #+unicode (setf (fd-stream-last-char-read-size stream) 0)
     (setf (fd-stream-ibuf-head stream) 0)
     (setf (fd-stream-ibuf-tail stream) 0)
ram's avatar
ram committed
     (catch 'eof-input-catcher
       (loop
	(multiple-value-bind
	      (count errno)
	    (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
	      (unix:fd-zero read-fds)
	      (unix:fd-set (fd-stream-fd stream) read-fds)
	      (unix:unix-fast-select (1+ (fd-stream-fd stream))
				     (alien:addr read-fds) nil nil 0 0))
ram's avatar
ram committed
	  (cond ((eql count 1)
		 (do-input stream)
		 (setf (fd-stream-ibuf-head stream) 0)
		 (setf (fd-stream-ibuf-tail stream) 0))
		((and (not count) (eql errno unix:eintr)))
ram's avatar
ram committed
		(t
		 (return t)))))))
ram's avatar
ram committed
    (:force-output
     (flush-output-buffer stream))
    (:finish-output
     (flush-output-buffer stream)
     (do ()
	 ((null (fd-stream-output-later stream)))
       (system:serve-all-events)))
    (:element-type
     (fd-stream-element-type stream))
    (:interactive-p
     (unix:unix-isatty (fd-stream-fd stream)))
ram's avatar
ram committed
    (:line-length
     80)
    (:charpos
     (fd-stream-char-pos stream))
    (:file-length
pw's avatar
pw committed
     (unless (fd-stream-file stream)
       (error 'simple-type-error
	      :datum stream
	      :expected-type 'file-stream
	      :format-control (intl:gettext "~s is not a stream associated with a file.")
pw's avatar
pw committed
	      :format-arguments (list stream)))
ram's avatar
ram committed
     (multiple-value-bind
	 (okay dev ino mode nlink uid gid rdev size
	       atime mtime ctime blksize blocks)
	 (unix:unix-fstat (fd-stream-fd stream))
ram's avatar
ram committed
       (declare (ignore ino nlink uid gid rdev
			atime mtime ctime blksize blocks))
       (unless okay
	 (error 'simple-file-error
                :format-control (intl:gettext "Error fstating ~S: ~A")
		:format-arguments (list stream (unix:get-unix-error-msg dev))))
	   (values (truncate size (fd-stream-element-size stream))))))
ram's avatar
ram committed
    (:file-position
     (fd-stream-file-position stream arg1))
    (:clear-output
     (setf (fd-stream-obuf-tail stream) 0))))
ram's avatar
ram committed

;;; FD-STREAM-FILE-POSITION -- internal.
;;;
(defun fd-stream-file-position (stream &optional newpos)
  (declare (type fd-stream stream)
	   (type (or (integer 0) (member nil :start :end)) newpos))
ram's avatar
ram committed
  (if (null newpos)
      (system:without-interrupts
	;; First, find the position of the UNIX file descriptor in the file.
ram's avatar
ram committed
	(multiple-value-bind
	    (unix:unix-lseek (fd-stream-fd stream) 0 unix:l_incr)
	  (declare (type (or (integer 0) null) posn))
Raymond Toy's avatar
Raymond Toy committed
	  #+nil
	  (format t "lseek returns ~D ~D~%" posn errno)
ram's avatar
ram committed
		 ;; Adjust for buffered output:
		 ;;  If there is any output buffered, the *real* file position
		 ;; will be larger than reported by lseek because lseek
toy's avatar
toy committed
		 ;; obviously cannot take into account output we have not
ram's avatar
ram committed
		 ;; sent yet.
		 (dolist (later (fd-stream-output-later stream))
		   (incf posn (- (the index (caddr later))
				 (the index (cadr later)))))
ram's avatar
ram committed
		 (incf posn (fd-stream-obuf-tail stream))
ram's avatar
ram committed
		 ;; Adjust for unread input:
		 ;;  If there is any input read from UNIX but not supplied to
		 ;; the user of the stream, the *real* file position will
		 ;; smaller than reported, because we want to look like the
		 ;; unread stuff is still available.
		 (decf posn (- (fd-stream-ibuf-tail stream)
			       (fd-stream-ibuf-head stream)))
Raymond Toy's avatar
Raymond Toy committed
		 #+nil
		 (format t "Updated posn = ~D~%" posn)
rtoy's avatar
rtoy committed
		 (when (fd-stream-string-buffer stream)
		   ;; The string buffer contains Lisp characters,
		   ;; not octets!  To figure out how many octets
		   ;; have not been already supplied, we need to
		   ;; count how many octets were consumed for all
		   ;; the characters in the string bbuffer that have
		   ;; not been supplied.
		   (let ((ocount (fd-stream-octet-count stream)))
		     (when ocount
		       ;; Note: string-index starts at 1 (because
		       ;; index 0 is for the unread-char), but
		       ;; octet-count doesn't use that.  Hence,
		       ;; subtract one from string-index and
		       ;; string-buffer-len.
		       #+nil
		       (progn
			 (format t "~&ocount = ~D~%" ocount)
			 (format t "posn = ~D~%" posn))
		       (loop for k of-type fixnum from (1- (fd-stream-string-index stream))
			       below (1- (fd-stream-string-buffer-len stream))
			     do (decf posn (aref ocount k)))
		       #+nil
		       (progn
			 (format t "new posn = ~D~%" posn)
			 (format t "in-buffer-length = ~D~%" in-buffer-length)
Raymond Toy's avatar
Raymond Toy committed
			 (format t "in-length = ~D~%" (fd-stream-in-length stream))
rtoy's avatar
rtoy committed
			 (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream))))))
		 (when (fd-stream-in-buffer stream)
		   ;; When we have an in-buffer (whether we have a
		   ;; string-buffer or not!), we need to adjust for
		   ;; the octets that have not yet been supplied.
		   ;; (This case happens with string-buffer when the
		   ;; in-buffer does not have enough octets to form a
		   ;; complete character.)  If there's no
		   ;; string-buffer and no in-buffer, then the ibuf
		   ;; tail and head pointers contain all the
		   ;; information needed.
		   #+nil
		   (progn
		     (format t "in-buffer-length = ~D~%" in-buffer-length)
Raymond Toy's avatar
Raymond Toy committed
		     (format t "in-length = ~D~%" (fd-stream-in-length stream))
rtoy's avatar
rtoy committed
		     (format t "fd-stream-in-index = ~D~%" (fd-stream-in-index stream)))
Raymond Toy's avatar
Raymond Toy committed
		   (decf posn (- (fd-stream-in-length stream)
rtoy's avatar
rtoy committed
				 (fd-stream-in-index stream))))
		 #+nil
		 (format t "fd-stream-unread = ~S~%" (fd-stream-unread stream))
		 (when (fd-stream-unread stream) ;;@@
ram's avatar
ram committed
		   (decf posn))
		 ;; Divide bytes by element size.
		 (truncate posn (fd-stream-element-size stream)))
		((eq errno unix:espipe)
ram's avatar
ram committed
		 nil)
		(t
		 (system:with-interrupts
		   (error (intl:gettext "Error lseek'ing ~S: ~A")
ram's avatar
ram committed
			  stream
			  (unix:get-unix-error-msg errno)))))))
      (let ((offset 0)
	    origin)
	(declare (type (integer 0) offset))
ram's avatar
ram committed
	;; Make sure we don't have any output pending, because if we move the
	;; file pointer before writing this stuff, it will be written in the
	;; wrong location.
	(flush-output-buffer stream)
	(do ()
	    ((null (fd-stream-output-later stream)))
	  (system:serve-all-events))
	;; Clear out any pending input to force the next read to go to the
	;; disk.
	(setf (fd-stream-unread stream) nil) ;;@@
	#+unicode
	(progn
	  (setf (fd-stream-last-char-read-size stream) 0)
	  (setf (fd-stream-string-index stream)
		(fd-stream-string-buffer-len stream)))
	(setf (fd-stream-ibuf-head stream) 0)
	(setf (fd-stream-ibuf-tail stream) 0)
	;; Trash cached value for listen, so that we check next time.
	(setf (fd-stream-listen stream) nil)
ram's avatar
ram committed
	(cond ((eq newpos :start)
	       (setf offset 0
		     origin unix:l_set))
ram's avatar
ram committed
	      ((eq newpos :end)
	       (setf offset 0
		     origin unix:l_xtnd))
	      ((typep newpos '(integer 0))
ram's avatar
ram committed
	       (setf offset (* newpos (fd-stream-element-size stream))
		     origin unix:l_set))
ram's avatar
ram committed
	      (t
	       (error (intl:gettext "Invalid position given to file-position: ~S") newpos)))
ram's avatar
ram committed
	(multiple-value-bind
	    (posn errno)
	    (unix:unix-lseek (fd-stream-fd stream) offset origin)
ram's avatar
ram committed
		 t)
		((eq errno unix:espipe)
ram's avatar
ram committed
		 nil)
		(t
		 (error (intl:gettext "Error lseek'ing ~S: ~A")
ram's avatar
ram committed
			stream
			(unix:get-unix-error-msg errno))))))))
ram's avatar
ram committed



;;;; Creation routines (MAKE-FD-STREAM and OPEN)

;; The unicode version of this is in fd-stream-extfmt.lisp
#-(and unicode (not unicode-boootstrap))
(defun %set-fd-stream-external-format (stream extfmt &optional (updatep t))
  (declare (ignore stream extfmt updatep))
  (values))

ram's avatar
ram committed
;;; MAKE-FD-STREAM -- Public.
;;;
;;; Returns a FD-STREAM on the given file.
;;;
(defun make-fd-stream (fd
		       &key
		       (input nil input-p)
		       (output nil output-p)
		       (element-type 'base-char)
ram's avatar
ram committed
		       (buffering :full)
ram's avatar
ram committed
		       file
		       original
		       delete-original
		       input-buffer-p
		       ;; DO NOT translate these!  It causes an
		       ;; infinite loop.  We need to open a file for
		       ;; the translations, but if you translate
		       ;; these, then we need to do a lookup which
		       ;; wants to open the mo file which calls this
		       ;; to name which causes a lookup ....
ram's avatar
ram committed
		       (name (if file
				 (format nil "file ~S" file)
				 (format nil "descriptor ~D" fd)))
		       (external-format :default)
		       binary-stream-p
		       decoding-error
		       encoding-error)
  (declare (type index fd) (type (or index null) timeout)
	   (type (member :none :line :full) buffering))
  "Create a stream for the given unix file descriptor.
  If input is non-nil, allow input operations.
  If output is non-nil, allow output operations.
  If neither input nor output are specified, default to allowing input.
  Element-type indicates the element type to use (as for open).
  Buffering indicates the kind of buffering to use.
  Timeout (if true) is the number of seconds to wait for input.  If NIL (the
    default), then wait forever.  When we time out, we signal IO-TIMEOUT.
  File is the name of the file (will be returned by PATHNAME).
rtoy's avatar
rtoy committed
  Name is used to identify the stream when printed.
  External-format is the external format to use for the stream.
  Decoding-error and Encoding-error indicate how decoding/encoding errors on
    the stream should be handled.  The default is to use a replacement character."
ram's avatar
ram committed
  (cond ((not (or input-p output-p))
	 (setf input t))
	((not (or input output))
	 (error (intl:gettext "File descriptor must be opened either for input or output."))))
  (let ((stream (if binary-stream-p
		    (%make-binary-text-stream :fd fd
					      :name name
					      :file file
					      :original original
					      :delete-original delete-original
					      :pathname pathname
					      :buffering buffering
					      :timeout timeout)
		    (let ((e (cond ((characterp encoding-error)
rtoy's avatar
rtoy committed
				    (constantly (char-code encoding-error)))
				   (t
				    encoding-error)))
			  (d (cond ((characterp decoding-error)
				    (constantly (char-code decoding-error)))
				   ((eq t decoding-error)
				    #'(lambda (&rest args)
					(apply 'cerror
					       #+unicode _"Use Unicode replacement character instead"
					       #-unicode _"Use question mark character instead"
					#+unicode
					stream:+replacement-character-code+
					#-unicode
rtoy's avatar
rtoy committed
				   (t
				    decoding-error))))
		      (%make-fd-stream :fd fd
				       :name name
				       :file file
				       :original original
				       :delete-original delete-original
				       :pathname pathname
				       :buffering buffering
				       :timeout timeout
				       :char-to-octets-error e
				       :octets-to-char-error d)))))
    ;; Set the lisp-stream flags appropriately for the kind of stream
    ;; we have (character, binary, binary-text-stream).
    (cond ((typep stream 'binary-text-stream)
	   (setf (fd-stream-flags stream) #b100))
	  ((subtypep element-type 'character)
	   (setf (fd-stream-flags stream) #b001))
	  (t
	   (setf (fd-stream-flags stream) #b010)))

    ;; FIXME: setting the external format here should be better
    ;; integrated into set-routines.  We do it before so that
    ;; set-routines can create an in-buffer if appropriate.  But we
    ;; need to do it after to put the correct input routines for the
    ;; external format.
    ;;#-unicode-bootstrap ; fails in stream-reinit otherwise
    (%set-fd-stream-external-format stream external-format nil)
    (set-routines stream element-type input output input-buffer-p
		  :binary-stream-p binary-stream-p)
    (%set-fd-stream-external-format stream external-format nil)
    (when (and auto-close (fboundp 'finalize))
      (finalize stream
		#'(lambda ()
		    (unix:unix-close fd)
		    (format *terminal-io* (intl:gettext "** Closed ~A~%") name)
toy's avatar
toy committed
		    (when original
		      (revert-file file original)))))
ram's avatar
ram committed
    stream))

;;; PICK-BACKUP-NAME -- internal
ram's avatar
ram committed
;;;
;;; Pick a name to use for the backup file.
;;;
(defvar *backup-extension* ".BAK"
  "This is a string that OPEN tacks on the end of a file namestring to produce
ram's avatar
ram committed
   a name for the :if-exists :rename-and-delete and :rename options.  Also,
   this can be a function that takes a namestring and returns a complete
   namestring.")
;;;
(defun pick-backup-name (name)
  (declare (type simple-string name))
  (let ((ext *backup-extension*))
    (etypecase ext
      (simple-string (concatenate 'simple-string name ext))
      (function (funcall ext name)))))
ram's avatar
ram committed

;;; NEXT-VERSION -- internal
;;;
;;; Find the next available versioned name for a file.
;;;
(defun next-version (name)
  (declare (type simple-string name))
  (let* ((*ignore-wildcards* t)
	 (sep (position #\/ name :from-end t))
	 (base (if sep (subseq name 0 (1+ sep)) ""))
	 (dir (unix:open-dir base)))
    (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 (if type
		       (concatenate 'string name "." type ".~")
		       (concatenate 'string name ".~"))))
	(when dir
	  (unwind-protect
	       (loop
		 (let ((name (unix:read-dir dir)))
		   (cond ((null name) (return))
			 ((and (> (length name) (length match))
			       (string= name match :end1 (length match)))
			  (multiple-value-bind (v e)
			      (parse-integer name :start (length match)
						  :junk-allowed t)
			    (when (and v
				       (= (length name) (1+ e))
				       (char= (schar name e) #\~))