head     1.1;
access   ;
symbols  ;
locks    ; strict;
comment  @@;


1.1
date     90.02.06.17.24.59;  author ram;  state Exp;
branches ;
next     ;


desc
@@



1.1
log
@Initial revision
@
text
@;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains the stream-level i/o implementation for Spice Lisp.
;;;    Written by Rob MacLachlan.  Earlier version written by Jim Large.
;;;

(in-package "LISP" :use '("SYSTEM" "EXTENSIONS"))

(export '(file-length file-position open))

(in-package "SYSTEM")
(export '(beep *beep-function* make-terminal-stream
	  make-pointer-input-stream))
(in-package "LISP")



;;;; Terminal streams:
;;;
;;;    In order to minimize message-passing and other communication
;;; overhead, terminal-stream output is buffered.  The buffer is
;;; flushed either when we reach an end-of-line, when we go into an
;;; input wait or when the user does it explicitly by doing a
;;; force-output.  It would be possible to flush the buffer only when
;;; the user explicitly requests it, possibly resulting in better
;;; performance, but then the buffering would become highly
;;; user-visable.  It might be useful to provide a variety of stream
;;; that did this however.
;;; 
;;; Problem note:  EOF-ERRORP & EOF-VALUE are always ignored in terminal
;;; functions because we never allow the terminals to reach eof.
;;;


;;;; Terminal Streams.

(defconstant initial-terminal-out-buffer-size 4096)

(defconstant initial-terminal-in-buffer-size 255)

(defstruct (terminal-stream
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore s d) (stream stream))
	       (format stream "#<Terminal stream>")))
	    (:include stream
		      (in #'terminal-in)
		      (out #'terminal-out)
		      (sout #'terminal-sout)
		      (misc #'terminal-misc))
	    (:constructor %make-terminal-stream (stdin stdout)))
  ;; The buffer containing unread input.
  (read-buffer (make-string initial-terminal-in-buffer-size))
  ;; Index of the first character available in Read-Buffer.
  (read-index 0)
  ;; The buffer containing unsent output.
  ;; The actual number of characters in the read-buffer.
  (read-length 0)
  (out-buffer (make-string initial-terminal-out-buffer-size))
  ;; Index of the first unused character in Out-Buffer.
  (out-index 0)
  ;; Offset added into out-index to find charpos.
  (out-offset 0)
  ;; Unix uses stdin and stdout for terminal I/O.
  (stdin 0)
  (stdout 1)
  (eof-flag nil))

;;; This hash table maps file descriptors to terminal stream objects, so calls
;;; to the input handler can put the input in the appropriate streams read buffer.
;;; 
(defvar *fd-to-terminal-stream* (make-hash-table))

;;; MAKE-TERMINAL-STREAM must setup an input handler for the file descriptor
;;; stdin and return a terminal stream.
;;; 
(defun make-terminal-stream (stdin stdout)
  (let ((stream (%make-terminal-stream stdin stdout)))
    (setf (gethash stdin *fd-to-terminal-stream*) stream)
    stream))

;;; GET-STRING-TO-STREAM waits for input on the stream's file descriptor.
;;; It also is responsible for flushing output on the stream.  When this
;;; function is called, it is assumed that the stream's read-buffer is empty
;;; and can be filled from 0 to its length.  Setting the read-index and
;;; read-length of the stream is a hack for this function to know when input
;;; arrived on this stream's file descriptor, and they are both set to keep
;;; STORE-TERMINAL-INPUT from doing something silly.
;;;
;;; The reason terminal streams use SERVER is to allow client Lisps to receive
;;; messages while in an input wait.  Anonymous client Lisp's *terminal-io* is
;;; bound to a typescript stream which inherently uses SERVER.
;;; 
(defun get-string-to-stream (stream)
  (force-output stream)
  (setf (terminal-stream-read-index stream) 0)
  (setf (terminal-stream-read-length stream) 0)
  (setf (terminal-stream-eof-flag stream) nil)
  (unwind-protect
      (progn
	(push (cons (terminal-stream-stdin stream)
		    #'store-terminal-input)
	      *file-input-handlers*)
	(loop
	  (server)
	  (when (or (terminal-stream-eof-flag stream)
		    (/= (terminal-stream-read-index stream)
			(terminal-stream-read-length stream)))
	    (return))))
    (setf system:*file-input-handlers*
	  (delete (terminal-stream-stdin stream)
		  system:*file-input-handlers*
		  :test #'eql
		  :key #'car)))
  (setf (terminal-stream-out-offset stream) 0))

;;; STORE-TERMINAL-INPUT is the file input handler for file descriptors that
;;; SERVER waits on.  Only buffer-len characters are pulled from fd, but the
;;; buffer is grown to hold any previously stored input as well as the new.
;;; NOTE: This function is not only called as a result of GET-STRING-TO-STREAM,
;;; so we cannot assume that start and end are unimportant.
;;; 
(defun store-terminal-input (fd)
  (let* ((stream (gethash fd *fd-to-terminal-stream*))
	 (buffer (terminal-stream-read-buffer stream))
	 (buffer-len (length buffer))
	 (start (terminal-stream-read-index stream))
	 (end (terminal-stream-read-length stream))
	 (old-len (- end start))
	 (old-buf (if (zerop old-len) nil (subseq buffer start end)))
	 (read-len (mach:unix-read fd buffer buffer-len)))
    (declare (simple-string buffer)
	     (fixnum buffer-len read-len old-len start end))
    (when (zerop read-len)
      (setf (terminal-stream-eof-flag stream) t)
      (when (and (eq fd 0) (not (mach::unix-isatty fd)))
	(format t "~%Fatal error: EOF on stdin when it is not a terminal.~%")
	(quit))
      (return-from store-terminal-input))
    (let* ((result-len (if old-buf (+ old-len read-len) read-len)))
      (when (> result-len buffer-len)
	(let ((new-buffer (make-string
			   (max (* 2 buffer-len)
				(+ buffer-len (- result-len buffer-len))))))
	  (declare (simple-string new-buffer))
	  (replace new-buffer buffer :end1 read-len :end2 read-len)
	  (setf (terminal-stream-read-buffer stream) new-buffer)
	  (setf buffer new-buffer)))
      (when old-buf
	(replace buffer buffer
		 :start1 old-len :start2 0 :end1 result-len :end2 read-len)
	(replace buffer (the simple-string old-buf)
		 :end1 old-len :end2 old-len))
      (setf (terminal-stream-read-index stream) 0)
      (setf (terminal-stream-read-length stream) result-len))))

;;; Terminal-Readline  --  Internal
;;;
;;;    Terminal-readline reads a line of text from a terminal-stream
;;; and returns it as a string.  If necessary, read some characters
;;; from the file descriptor.
;;;
(defun terminal-readline (stream eof-errorp eof-value)
  (let ((result ""))
    (declare (simple-string result))
    (loop
      (let* ((start (terminal-stream-read-index stream))
	     (buffer (terminal-stream-read-buffer stream))
	     (end (terminal-stream-read-length stream))
	     (nl (position #\newline buffer :start start :end end))
	     (eofp (terminal-stream-eof-flag stream)))
	(declare (simple-string buffer))
	(when (or nl eofp)
	  (let ((result (concatenate 'simple-string result
				     (subseq buffer start (or nl end)))))
	    (when (and (not nl) (string= result ""))
	      (setf (terminal-stream-eof-flag stream) nil)
	      (return (eof-or-lose stream eof-errorp eof-value)))
	    (setf (terminal-stream-read-index stream)
		  (if nl (1+ nl) end))
	    (return (values result eofp))))
	(setq result (concatenate 'simple-string result (subseq buffer start end)))
	(get-string-to-stream stream)))))

;;; Terminal-In  --  Internal
;;;
;;;    Read a character from a terminal stream.
;;;
(defun terminal-in (stream eof-errorp eof-value)
  (let ((index (terminal-stream-read-index stream))
	(len (terminal-stream-read-length stream))
	(buffer (terminal-stream-read-buffer stream)))
    (declare (simple-string buffer)
	     (fixnum index len))
    (when (>= index len)
      (get-string-to-stream stream)
      (when (terminal-stream-eof-flag stream)
	(setf (terminal-stream-eof-flag stream) nil)
	(return-from terminal-in
		     (eof-or-lose stream eof-errorp eof-value)))
      (setq index (terminal-stream-read-index stream))
      (setq buffer (terminal-stream-read-buffer stream)))
    (setf (terminal-stream-read-index stream) (1+ index))
    (schar buffer index)))

;;; Unix-Put-String  --  Internal
;;;
;;;    Given a file descriptor, a string and a start and end, writes the string
;;; to the file descriptor in the most expeditious fashion.
;;;
(defun unix-put-string (fd string start end)
  (mach:unix-write fd string start (- end start)))

;;; Terminal-Out  --  Internal
;;;
;;;    Store Character into Stream's Out-Buffer.  If the character is a
;;; newline then we flush the buffer.
;;;
(defun terminal-out (stream character)
  (let ((buffer (terminal-stream-out-buffer stream))
	(index (terminal-stream-out-index stream))
	(fd (terminal-stream-stdout stream)))
    (declare (simple-string buffer)
	     (fixnum index))
    (when (= index (length buffer))
      (let* ((length (length buffer))
	     (new (make-string (* length 2))))
	(declare (simple-string new)
		 (fixnum length))
	(%primitive byte-blt buffer 0 new 0 length)
	(setq buffer new)
	(setf (terminal-stream-out-buffer stream) new)))
    (setf (schar buffer index) character)
    (incf index)
    (cond ((char= character #\newline)
	   (unix-put-string fd buffer 0 index)
	   (setf (terminal-stream-out-offset stream) 0)
	   (setf (terminal-stream-out-index stream) 0))
	  (t
	   (setf (terminal-stream-out-index stream) index)))))

;;; Terminal-Sout  --  Internal
;;;
;;;    This is the write-string method for terminal-streams.  If the string
;;; contains no newlines then we just blt it into the stream's out-buffer.
;;; If the string does contain newlines then we flush the buffer and
;;; send everything in the string up through the last newline.
;;;
(defun terminal-sout (stream string start end)
  (declare (simple-string string)
	   (fixnum start end))
  (let ((buffer (terminal-stream-out-buffer stream))
	(index (terminal-stream-out-index stream))
	(fd (terminal-stream-stdout stream)))
    (declare (simple-string buffer)
	     (fixnum index))
    (when (%primitive find-character string start end #\newline)
      (let* ((last (position #\newline string :start start :end end
			     :from-end t))
	     (next (1+ last)))
	(declare (fixnum next last))
	(unix-put-string fd buffer 0 index)
	(unix-put-string fd string start next)
	(setf (terminal-stream-out-offset stream) 0)
	(setq start next  index 0)))
    (let* ((length (- end start))
	   (new-index (+ index length)))
      (declare (fixnum length new-index))
      (when (> new-index (length buffer))
	(let ((new (make-string (max (* (length buffer) 2) new-index))))
	  (%primitive byte-blt buffer 0 new 0 index)
	  (setq buffer new)
	  (setf (terminal-stream-out-buffer stream) new)))
      (%primitive byte-blt string start buffer index new-index)
      (setf (terminal-stream-out-index stream) new-index))))

;;; Terminal-Misc  --  Internal
;;;
;;;    The misc method for terminal streams.  Suprisingly, many of these
;;; operations mean something.  We have to be careful when accessing the
;;; stdin and stdout slots since these streams are used for RUN-PROGRAM
;;; which uses only one of the fd slots.  The other methods for the wrong
;;; direction don't worry about this since RUN-PROGRAM makes them illegal
;;; operations.
;;;
(defun terminal-misc (stream operation &optional arg1 arg2)
  (case operation
    (:unread (if (plusp (terminal-stream-read-index stream))
		 (decf (terminal-stream-read-index stream))
		 (error "Nothing to unread.")))
    (:read-line (terminal-readline stream arg1 arg2))
    (:listen
     (let ((fd (terminal-stream-stdin stream)))
       (when fd
	 (or (/= (the fixnum (terminal-stream-read-index stream))
		 (the fixnum (terminal-stream-read-length stream)))
	     (mach:with-trap-arg-block mach::int1 nc
	       (multiple-value-bind
		   (val err)
		   (mach:unix-ioctl fd mach:FIONREAD
				    (alien-value-sap mach::int1))
		 (declare (ignore err))
		 (if (null val) NIL
		     (> (alien-access (mach::int1-int (alien-value nc)))
			0))))))))
    (:charpos
     (+ (terminal-stream-out-index stream) 
	(terminal-stream-out-offset stream)))
    (:clear-input
     (let ((fd (terminal-stream-stdin stream)))
       (setf (terminal-stream-read-index stream) 0)
       (setf (terminal-stream-read-length stream) 0)
       (mach:unix-ioctl fd mach:tiocflush 0)))
    (:clear-output (setf (terminal-stream-out-index stream) 0))
    ((:finish-output :force-output)
     (let ((fd (terminal-stream-stdout stream)))
       (when fd
	 (let ((index (terminal-stream-out-index stream)))
	   (incf (terminal-stream-out-offset stream) index)
	   (unix-put-string fd (terminal-stream-out-buffer stream)
			    0 index)
	   (setf (terminal-stream-out-index stream) 0))
	 (if (eq operation :finish-output)
	     (mach:unix-ioctl fd mach:tiocflush 0)))
       nil))
    (:element-type 'string-char)
    (:line-length 80)
    (:close
     (let ((stdin (terminal-stream-stdin stream))
	   (stdout (terminal-stream-stdout stream)))
       (when stdin
	 (mach:unix-close stdin)
	 (remhash stdin *fd-to-terminal-stream*))
       (when stdout (mach:unix-close stdout))
       (setf (terminal-stream-eof-flag stream) t)))))


;;;; Initialization.

(defun stream-init ()
  (setq *terminal-io* (make-terminal-stream 0 1))
  (stream-reinit)
  (setq *standard-input* (make-synonym-stream '*terminal-io*))
  (setq *standard-output* *standard-input*)
  (setq *error-output* (make-synonym-stream '*terminal-io*))
  (setq *query-io* (make-synonym-stream '*terminal-io*))
  (setq *debug-io* (make-synonym-stream '*terminal-io*))
  (setq *trace-output* *standard-output*))

(defun stream-reinit () nil)



;;;; Beeping.

(defun default-beep-function (stream)
  (write-char #\bell stream)
  (finish-output stream))

(defvar *beep-function* #'default-beep-function
  "This is called in BEEP to feep the user.  It takes a stream.")

(defun beep (&optional (stream *terminal-io*))
  (funcall *beep-function* stream))



;;;; File I/O stuff:
(defconstant cr-code (char-code #\return))
(defconstant lf-code (char-code #\linefeed))

;;;; The File-Stream structure:
;;;
;;;    A File-Stream is a structure which includes the stream structure
;;; and has extra slots for the file specific info.  Byte means a byte
;;; of the size specified for the file rather than an 8-Bit byte, unless
;;; otherwise specified.
;;;
(defstruct (file-stream (:include stream)
			(:print-function
			 (lambda (s stream d)
			   (declare (ignore d) (stream stream))
			   (format stream "#<File stream ~S>"
				   (file-stream-filename s)))))
  ;; This is the system-area-pointer to the file's data.
  sap
  ;; The address that is in SAP.
  address
  ;; This is current length of the file in bytes of the specified size.
  eof
  ;; This is the current file position, the place where the next byte is
  ;; written or read.
  position
  ;; This is the length in bytes of the area validated for the file.
  length
  ;; The size of byte the file deals with, in bits.
  byte-size
  ;; The namestring for the open file.
  filename
  ;; The namestring of any file to delete on successful close.
  delete-filename
  ;; The mode bits to use in creating a file to write.
  (mode #o644)
  ;; The element type.
  element-type)

;;; File-Position  --  Public
;;;
;;;    Call the misc method with the :file-position operation.
;;;
(defun file-position (stream &optional position)
  "With one argument returns the current position within the file
  File-Stream is open to.  If the second argument is supplied, then
  this becomes the new file position.  The second argument may also
  be :start or :end for the start and end of the file, respectively."
  (unless (streamp stream)
    (error "Argument ~S is not a stream." stream))
  (funcall (stream-misc stream) stream :file-position position))

;;; File-Stream-File-Position  --  Internal
;;;
;;;    The File-Position method for a file stream.  Just return or set the
;;; file position, checking bounds.
;;;
(defun file-stream-file-position (file-stream position)
  (if (null position)
      (- (file-stream-position file-stream)
	 (- in-buffer-length (stream-in-index file-stream)))
      (let ((eof (file-stream-eof file-stream)))
	;; Flush out the in buffer so that we don't read any stuff in it.
	(setf (stream-in-index file-stream) in-buffer-length)
	;; Set the position.
	(setf (file-stream-position file-stream)
	      (cond ((eq position :start) 0)
		    ((eq position :end) eof)
		    ((<= 0 position eof) position)
		    (t (error "File position ~D out of bounds." position))))
	t)))

;;; File-Length  --  Public
;;;
;;;    Like File-Position, only use :file-length.
;;;
(defun file-length (stream)
  "This function returns the length of the file that File-Stream is open to."
  (unless (streamp stream)
    (error "Argument ~S is not a stream." stream))
  (funcall (stream-misc stream) stream :file-length))

;;; File-Name  --  Internal
;;;
;;;    Kind of like File-Position, but is an internal hack used by the filesys
;;; stuff to get and set the file name.
;;;
(defun file-name (stream &optional new-name)
  (when (file-stream-p stream)
    (if new-name
	(setf (file-stream-filename stream) new-name)
	(file-stream-filename stream))))

;;; Read-File-To-Stream  --  Internal
;;;
;;;    Call sub-read-file on the namestring, and erroring out if it loses.
;;; The SAP, EOF and Length fields are set.  The Byte-Size field must
;;; already have been set for the EOF and Length to be computed from the
;;; number of 8-Bit bytes.
;;;
(defun read-file-to-stream (namestring stream)
  (setf (file-stream-filename stream) namestring)
  (loop
    (multiple-value-bind (fd err) (mach:unix-open namestring mach:o_rdonly 0)
      (if (not (null fd))
	  (multiple-value-bind (res dev ino mode nlnk uid gid rdev len)
			       (mach:unix-fstat fd)
	    (declare (ignore ino mode nlnk uid gid rdev))
	    (setq err NIL)
	    (if (null res)
		(setq err dev)
		(multiple-value-bind (gr addr)
				     (mach::vm_allocate *task-self* 0 len t)
		  (gr-error 'mach::vm_allocate gr 'read-file-to-stream)
		  (setf (file-stream-sap stream) (int-sap addr))
		  (setf (file-stream-address stream) addr)
		  (let ((len (truncate (* len 8)
				       (file-stream-byte-size stream))))
		    (setf (file-stream-eof stream) len)
		    (setf (file-stream-length stream) len))
		  (multiple-value-bind (bytes err3)
				       (mach:unix-read
					fd (int-sap addr) len)
		    (if (or (null bytes) (not (eq len bytes)))
			(setq err err3)))))
	    (mach:unix-close fd)))
      (if (null err)
	  (return nil)
	  (cerror "try to read it again."
		  "Read of ~A failed: ~A."
		  namestring (mach:get-unix-error-msg err))))))

;;; Convert-To-8bit  --  Internal
;;;
;;;    Return the number of 8-Bit bytes it takes to store Bytes Byte-Sized
;;; bytes.
;;;
(eval-when (compile eval)
(defmacro convert-to-8bit (bytes byte-size)
  `(ash (+ (* ,bytes ,byte-size) 7) -3))

;;; Round-To-Pages  --  Internal
;;;
;;;    Round a number of Bytes up to the nearest page multiple.
;;;
(defmacro round-to-pages (bytes)
  `(logandc2 (+ ,bytes #x1FF) #x1FF))
); eval-when (compile eval)

;;; Write-File-From-Stream  --  Internal
;;;
;;;    Given a file stream, write the file.
;;;
(defun write-file-from-stream (stream)
  (let* ((name (file-stream-filename stream))
	 (sap (file-stream-sap stream))
	 (bytes (convert-to-8bit (file-stream-eof stream)
				 (file-stream-byte-size stream)))
	 (mode (file-stream-mode stream)))
    (loop
      (multiple-value-bind (fd err)
			   (mach:unix-creat name (logand mode #o777))
	(when fd
	  (setq err NIL)
	  (mach:unix-fchmod fd (logand mode #o777))
	  (when (> (the fixnum bytes) 0)
	    (multiple-value-bind (len err2) (mach:unix-write fd sap 0 bytes)
	      (if (or (null len) (not (eq len bytes)))
		  (setq err err2))))
	  (mach:unix-close fd))
	(if (null err)
	    (return nil)
	    (cerror "try to write it again."
		    "Write of ~A failed: ~A."
		    name (mach:get-unix-error-msg err)))))))

;;; Invalidate-File  --  Internal
;;;
;;;    Invalidate the memory validated to hold a file's data.
;;;
(defun invalidate-file (stream)
  (gr-call Mach::vm_deallocate *task-self* (file-stream-address stream)
	   (round-to-pages (convert-to-8bit (file-stream-length stream)
					    (file-stream-byte-size stream)))))

;;; When we make a new file, we make it this size, and whenever we grow a file
;;; we always grow it by at least this many 8bit bytes.
(defconstant file-grow-size #x10000)

;;; Do-Validate  --  Internal
;;;
;;;    Do a ValidateMemory on our kernel port and flame out if error.
;;;
(defun do-validate (addr bytes mask)
  (gr-call* mach::vm_allocate *task-self* addr bytes (if (eq mask -1) t NIL)))

;;; New-File  --  Internal
;;;
;;;    Validate some memory for a new file and set up the SAP, Position
;;; and EOF fields.  The Byte-Size must already be correctly set.
;;;
(defun new-file (namestring stream)
  (let ((address (do-validate 0 file-grow-size -1)))
    (setf (file-stream-address stream) address)
    (setf (file-stream-sap stream) (int-sap address)))
  (setf (file-stream-filename stream) namestring)
  (setf (file-stream-position stream) 0)
  (setf (file-stream-eof stream) 0)
  (setf (file-stream-length stream)
	(truncate (* file-grow-size 8) (file-stream-byte-size stream))))

;;; Grow-File  --  Internal
;;;
;;;    Allocate a bigger area to store the file's data, and copy the
;;; current data there.  Afterward the old memory is invalidated.
;;; The new area is at least Increment of the file's bytes larger.
;;;
(defun grow-file (stream increment)
  (let* ((byte-size (file-stream-byte-size stream))
	 (length (file-stream-length stream))
	 (old-size (round-to-pages (convert-to-8bit length byte-size)))
	 (grow-size (max (+ old-size (convert-to-8bit increment byte-size))
			 file-grow-size))
	 (new-size (round-to-pages (* grow-size 2)))
	 (new-address (do-validate 0 new-size -1))
	 (new-sap (int-sap new-address)))
	 
    (%primitive byte-blt (file-stream-sap stream) 0 new-sap 0 old-size)
    (invalidate-file stream)

    (setf (file-stream-length stream) (truncate (* 8 new-size) byte-size))
    (setf (file-stream-address stream) new-address)
    (setf (file-stream-sap stream) new-sap)))

;;;; Text file methods:

;;; Text files are files of 8 bit bytes.  Each byte represents one character
;;; as an ascii code.  The :element-type arg to open was string-char.


;;; Text-in reads a character from a stream.   (slot: stream-in)  If
;;; the character is a return we want to punt the line-feed.
;;;
;;;  STREAM	 -- the stream to read from.
;;;  EOF-ERROR-P -- it true, signal error on eof, else return EOF-VALUE
;;;  EOF-VALUE	 -- value to return on eof.
;;; Returns a character object

;;; Text-In  --  Internal
;;;
;;;    This is the read-char method for text input files.  If we are at
;;; the end of the file we signal an error or return the eof-value, as
;;; specified, Otherwise we stuff the in buffer with characters up to
;;; and including the next LF, or EOF, or as much as it will hold, 
;;; whichever is least.  Check to see if the character before the LF
;;; is a CR, if so gobble it up.  We can assume the in-buffer is totally 
;;; empty, since read-char wouldn't have called us otherwise.
;;;
(defun text-in (stream eof-error-p eof-value)
  (let* ((buffer (file-stream-sap stream))
	 (start (file-stream-position stream))
	 (end (file-stream-eof stream))
	 (in-buffer (stream-in-buffer stream))
	 dst-idx)
    (declare (type (or simple-string null) in-buffer))
    (cond
      ((>= start end)
       (eof-or-lose stream eof-error-p eof-value))
      (t 
       (let ((idx (%primitive find-character buffer start end #\linefeed)))
	 ;; No line breaks thru EOF
	 (cond
	  ((null idx)
	   (setq dst-idx (- in-buffer-length (- end start)))
	   (if (minusp dst-idx)
	       (setq dst-idx 0  idx (+ start in-buffer-length))
	       (setq idx end))
	   (%primitive byte-blt buffer start in-buffer dst-idx in-buffer-length))
	  ;; Just LF.  If at beginning of file, cannot have CR before.
	  ((or (zerop idx)
	       (/= (%primitive 8bit-system-ref buffer (1- idx)) cr-code))
	   (setq dst-idx (- (1- in-buffer-length) (- idx start)))
	   (if (minusp dst-idx)
	       (setq dst-idx 0  idx (+ start in-buffer-length))
	       (setq idx (1+ idx)))
	   (%primitive byte-blt buffer start in-buffer dst-idx in-buffer-length))
	  ;; Found CRLF, pass through only LF.
	  (t
	   (setq dst-idx (- in-buffer-length (- idx start)))
	   (cond ((minusp dst-idx)
		  (setq dst-idx 0  idx (+ start in-buffer-length))
		  (%primitive byte-blt buffer start in-buffer dst-idx
				in-buffer-length))
		 (t
		  (setq idx (1+ idx))
		  (%primitive byte-blt buffer start in-buffer dst-idx
				(1- in-buffer-length))
		  (setf (schar in-buffer (1- in-buffer-length)) #\linefeed)))))
	 (setf (file-stream-position stream) idx)
	 (setf (stream-in-index stream) (1+ dst-idx))
	 (schar in-buffer dst-idx))))))

;;; Text-Readline reads characters from stream THROUGH the next linefeed or
;;;  crlf.  The characters up TO the linefeed or crlf chars are returned as
;;;  a string.   (Slot: stream-readline)
;;;
;;;  STREAM	 -- the stream to read from.
;;;  EOF-ERROR-P -- it true, signal error on eof, else return EOF-VALUE
;;;  EOF-VALUE	 -- value to return on eof.
;;; Returns:
;;;  1st -- A simple string containing the characters.
;;;  2nd -- T if line ended @@ eof, () otherwise.
;;;
(defun text-readline (stream eof-error-p eof-value)
  (unless (eq (file-stream-element-type stream) 'string-char) (ill-in stream))
  (let* ((data (file-stream-sap stream))
	 (eof (file-stream-eof stream))
	 (bol (file-stream-position stream))
	 (idx (%primitive find-character data bol eof #\linefeed)))
    (cond
     ((null idx)
      (if (= bol eof)
	  (eof-or-lose stream eof-error-p eof-value)
	  (let* ((len (- eof bol))
		 (res (make-string len)))
	    (setf (file-stream-position stream) eof)
	    (%primitive byte-blt data bol res 0 len)
	    (values res t))))
     (t
      (let ((len (- idx bol)))
	(when (and (/= bol 0)
		   (= (%primitive 8bit-system-ref data (1- idx)) cr-code))
	  (decf len))
	(let ((next (+ idx 1))
	      (res (make-string len)))
	  (%primitive byte-blt data bol res 0 len)
	  (setf (file-stream-position stream) next)
	  (values res nil)))))))

;;; 8bit-vector-out  --  Internal
;;;
;;;    This is the file sout method.  Although primarily for writing strings,
;;; it will write 8bit I-vectors with equal panache.  We set the in-index
;;; to invalidate any buffer input.
;;;
(defun 8bit-vector-out (stream vector start end)
  (setf (stream-in-index stream) in-buffer-length)
  (let* ((length (- end start))
	 (dst-start (file-stream-position stream))
	 (dst-end (+ length dst-start)))
    (if (> dst-end (file-stream-length stream))
	(grow-file stream length))
    (%primitive byte-blt vector start (file-stream-sap stream) dst-start dst-end)
    (setf (file-stream-position stream) dst-end)
    (if (> dst-end (file-stream-eof stream))
	(setf (file-stream-eof stream) dst-end))))

;;; Text-Charpos  --  Internal
;;;
;;;    Text-Charpos returns the number of characters on the current
;;; output line.  It searches backward from the last char output until it
;;; finds a lf.
;;;
(defun text-charpos (stream)
  (do* ((end (file-stream-position stream))
	(sap (file-stream-sap stream))
	(i (1- end) (1- i)))
       ((minusp i) end)
    (when (= (%primitive 8bit-system-ref sap i) lf-code)
      (return (- end i 1)))))

;;;; Binary methods:

;;; file-<n>bit-buffered-bin-method  --  Internal
;;;
;;;    For unsigned 8 and 16 bit files, we use the in-buffer.
;;;
(defun file-8bit-buffered-bin (stream eof-errorp eof-value)
  (let* ((eof (file-stream-eof stream))
	 (pos (file-stream-position stream))
	 (end (let ((next (+ pos in-buffer-length)))
		(if (> eof next) next eof)))
	 (new (- in-buffer-length (- end pos)))
	 (buffer (stream-in-buffer stream)))
    (cond ((= pos eof)
	   (eof-or-lose stream eof-errorp eof-value))
	  (t
	   (%primitive byte-blt (file-stream-sap stream) pos buffer new
		       in-buffer-length)
	   (setf (file-stream-position stream) end)
	   (setf (stream-in-index stream) (1+ new))
	   (aref buffer new)))))
;;;
(defun file-16bit-buffered-bin (stream eof-errorp eof-value)
  (let* ((eof (file-stream-eof stream))
	 (pos (file-stream-position stream))
	 (end (let ((next (+ pos in-buffer-length)))
		(if (> eof next) next eof)))
	 (new (- in-buffer-length (- end pos)))
	 (buffer (stream-in-buffer stream)))
    (cond ((= pos eof)
	   (eof-or-lose stream eof-errorp eof-value))
	  (t
	   (%primitive byte-blt (file-stream-sap stream)
		       (ash pos 1) buffer (ash new 1) (ash in-buffer-length 1))
	   (setf (file-stream-position stream) end)
	   (setf (stream-in-index stream) (1+ new))
	   (aref buffer new)))))

;;; file-<n>bit[-signed]-bin-method  --  Internal
;;;
;;;    These functions read 8, 16, or 32 bit, signed or unsigned bytes
;;; from files.
;;;
(eval-when (compile eval)
(defmacro define-bin-method (name accessor)
  `(defun ,name (stream eof-errorp eof-value)
     (let ((pos (file-stream-position stream)))
       (if (= pos (file-stream-eof stream))
	   (eof-or-lose stream eof-errorp eof-value)
	   (prog1
	    (,accessor (file-stream-sap stream) pos)
	    (setf (file-stream-position stream) (1+ pos)))))))
(defmacro 32bit-system-ref-macro (sap index)
  `(let ((base (ash ,index 1)))
     (logior (ash (%primitive 16bit-system-ref ,sap base) 16)
	     (%primitive 16bit-system-ref ,sap (1+ base)))))
(defmacro 8bit-signed-system-ref-macro (sap index)
  `(let ((res (%primitive 8bit-system-ref ,sap ,index)))
     (if (zerop (logand #x80 res))
	 res
	 (logior res #x-100))))
(defmacro 16bit-signed-system-ref-macro (sap index)
  `(%primitive signed-16bit-system-ref ,sap ,index))
(defmacro 32bit-signed-system-ref-macro (sap index)
  `(%primitive signed-32bit-system-ref ,sap (ash ,index 1)))
); eval-when (compile eval)

(define-bin-method file-32bit-bin 32bit-system-ref-macro)
(define-bin-method file-8bit-signed-bin 8bit-signed-system-ref-macro)
(define-bin-method file-16bit-signed-bin 16bit-signed-system-ref-macro)
(define-bin-method file-32bit-signed-bin 32bit-signed-system-ref-macro)

;;; file-<n>bit-bout-method  --  Internal
;;;
;;;    These functions write 8, 16, or 32 bit, signed or unsigned bytes
;;; to files.  We clobber the in-index so that a read op won't get bogus
;;; stuff.
;;;
(eval-when (compile eval)
(defmacro define-bout-method (name setter)
  `(defun ,name (stream value)
     (setf (stream-in-index stream) in-buffer-length)
     (let ((pos (file-stream-position stream)))
       (when (= pos (file-stream-length stream))
	 (grow-file stream 42))
       (,setter (file-stream-sap stream) pos value)
       (let ((next (1+ pos)))
	 (setf (file-stream-position stream) next)	 
	 (when (= pos (file-stream-eof stream))
	   (setf (file-stream-eof stream) next))))))
(defmacro 8bit-system-set-macro (sap index value)
  `(%primitive 8bit-system-set ,sap ,index ,value))
(defmacro 16bit-system-set-macro (sap index value)
  `(%primitive 16bit-system-set ,sap ,index ,value))
(defmacro 32bit-system-set-macro (sap index value)
  `(%primitive signed-32bit-system-set ,sap (ash ,index 1) ,value))
(defmacro string-char-system-set-macro (sap index value)
  `(%primitive 8bit-system-set ,sap ,index (char-code ,value)))
); eval-when (compile eval)
(define-bout-method file-8bit-bout 8bit-system-set-macro)
(define-bout-method file-16bit-bout 16bit-system-set-macro)
(define-bout-method file-32bit-bout 32bit-system-set-macro)
(define-bout-method text-out string-char-system-set-macro)

;;; File-8bit-N-Bin  --  Internal
;;;
;;;    File-8bit-N-Bin reads Numbytes bytes from the file and stores them into
;;; Buffer starting at index Start.  If there are not enough bytes left in the
;;; file, then signal an error unless Eof-Errorp is ().  In this case, just 
;;; read as many bytes as you can.
;;;
;;; Always returns the number of bytes read.
;;;
(defun file-8bit-n-bin (stream buffer start numbytes eof-error-p)
  (let* ((index (file-stream-position stream))
	 (left (- (file-stream-eof stream) index)))
    (when (< left numbytes)
      (if eof-error-p
	  (error "End of file ~s" stream)
	  (setq numbytes left)))
    (setf (file-stream-position stream) (+ index numbytes))
    (%primitive byte-blt (file-stream-sap stream) index buffer start
		(+ start numbytes))
    numbytes))

;;; File-Unread  --  Internal
;;;
;;;    Decrement the in-index if we have an in-buffer, otherwise decrement
;;; the current position.
;;;
(defun file-unread  (stream)
  (if (stream-in-buffer stream)
      (if (plusp (stream-in-index stream))
	  (decf (stream-in-index stream))
	  (error "Nothing to unread."))      
      (if (plusp (file-stream-position stream))
	  (decf (file-stream-position stream))
	  (error "Nothing to unread."))))

;;; File-XXX-Misc  --  Internal
;;;
;;;    All kinds of garbage is hung off the Misc operation here...
;;;
(defun file-out-misc (stream operation &optional arg1 arg2)
  (case operation
    (:read-line (text-readline stream arg1 arg2))
    (:listen
     (/= (file-stream-position stream) (file-stream-eof stream)))
    (:unread (file-unread stream))
    (:close
     (unless arg1
       (write-file-from-stream stream)
       (when (file-stream-delete-filename stream)
	 (delete-file (file-stream-delete-filename stream))))
     (invalidate-file stream)
     (set-closed-flame stream))
    ((:finish-output :force-output) (write-file-from-stream stream))
    (:element-type (file-stream-element-type stream))
    (:charpos (text-charpos stream))
    (:file-length (file-stream-eof stream))
    (:file-position (file-stream-file-position stream arg1))
#|
    (:file-name (if arg1
		    (setf (file-stream-filename stream) arg1)
		    (file-stream-filename stream)))
|#
    (:element-type (file-stream-element-type stream))))
;;;
(defun file-in-misc (stream operation &optional arg1 arg2)
  (case operation
    (:read-line (text-readline stream arg1 arg2))
    (:listen
     (/= (file-stream-position stream) (file-stream-eof stream)))
    (:unread (file-unread stream))
    (:close
     (invalidate-file stream)
     (set-closed-flame stream))
    (:element-type (file-stream-element-type stream))
    (:charpos (text-charpos stream))
    (:file-length (file-stream-eof stream))
    (:file-position (file-stream-file-position stream arg1))
#|
    (:file-name (if arg1
		    (setf (file-stream-filename stream) arg1)
		    (file-stream-filename stream)))
|#
    ))

(defun type-gradient (spec n1 s1 n2 s2 n3 s3)
  (let ((num (cadr spec)))
    (cond ((<= num n1) s1) ((<= num n2) s2)
	  ((<= num n3) s3)
	  (t
	   (error "~S is not an element type supported by Open." spec)))))

;;; Canonicalize-File-Element-Type  --  Internal
;;;
;;;    This function crunches the type specifiers allowed for open and
;;; either returns the canonical representaion of a type that is implemented
;;; or signals an error.
;;;
(defun canonicalize-file-element-type (spec)
  (case spec
    (string-char '(string-char 8))
    (unsigned-byte '(unsigned-byte 16))
    (signed-byte '(signed-byte 16))
    (:default '(string-char 8))
    (t
     (unless (and (listp spec) (= (length spec) 2) (integerp (cadr spec))
		  (> (cadr spec) 0))
       (error "~S is not an element type supported by Open." spec))
     (case (car spec)
       (unsigned-byte
	(type-gradient spec 8 '(unsigned-byte 8) 16 '(unsigned-byte 16)
		       32 '(unsigned-byte 32)))
       (signed-byte
	(type-gradient spec 8 '(signed-byte 8) 16 '(signed-byte 16)
		       32 '(signed-byte 32)))
       (mod
	(type-gradient spec #x100 '(unsigned-byte 8) #x10000 '(unsigned-byte 16)
		       #x100000000 '(unsigned-byte 32)))
       (t
	(error "~S is not an element type supported by Open." spec)))))))

;;; Set-Methods-From-Type  --  Internal
;;;
;;;    Take a stream and set up the byte-size and methods.
;;;
(defun set-methods-from-type (stream for-input for-output type)
  (when for-input 
    (setf (stream-misc stream) #'file-in-misc))
  (when for-output
    (setf (stream-misc stream) #'file-out-misc))
  (setf (file-stream-byte-size stream) (cadr type))
  (case (car type)
    (string-char
     (setf (file-stream-element-type stream) 'string-char)
     (when for-input
       (setf (stream-in stream) #'text-in)
       (setf (stream-in-buffer stream) (make-string in-buffer-length)))
     (when for-output
       (setf (stream-out stream) #'text-out
	     (stream-sout stream) #'8bit-vector-out)))
    (t
     (setf (file-stream-element-type stream) type)
     (when for-input
       (case (car type)
	 (unsigned-byte
	  (case (cadr type)
	    (8 (setf (stream-bin stream) #'file-8bit-buffered-bin 
		     (stream-n-bin stream) #'file-8bit-n-bin)
	       (setf (stream-in-buffer stream)
		     (make-array in-buffer-length
				 :element-type '(unsigned-byte 8))))
	    (16 (setf (stream-bin stream) #'file-16bit-buffered-bin)
		(setf (stream-in-buffer stream)
		      (make-array in-buffer-length
				  :element-type '(unsigned-byte 16))))
	    (32 (setf (stream-bin stream) #'file-32bit-bin))))
	 (signed-byte
	  (case (cadr type)
	    (8 (setf (stream-bin stream) #'file-8bit-signed-bin))
	    (16 (setf (stream-bin stream) #'file-16bit-signed-bin))
	    (32 (setf (stream-bin stream) #'file-32bit-signed-bin))))))
     (when for-output
       (case (cadr type)
	 (8 (setf (stream-bout stream) #'file-8bit-bout
		  (stream-out stream) #'text-out
		  (stream-sout stream) #'8bit-vector-out))
	 (16 (setf (stream-bout stream) #'file-16bit-bout))
	 (32 (setf (stream-bout stream) #'file-32bit-bout)))))))

;;; Open  --  Public
;;;
;;;    Do it all.
;;;
(defun open (filename &key (direction :input) (element-type 'string-char)
		      (if-exists nil exists-p)
		      (if-does-not-exist nil does-not-exist-p))
  "Return a stream which reads from or writes to Filename.
  Defined keywords:
   :direction - one of :input, :output or :probe
   :element-type - Type of object to read or write, default String-Char
   :if-exists - one of :error, :new-version, :overwrite, :append or nil
   :if-does-not-exist - one of :error, :create or nil
  See the manual for details."
  (unless (memq direction '(:input :output :io :probe))
    (error "~S is a losing direction for open." direction))
  (let ((pathname (pathname filename))
	(for-input (memq direction '(:io :input)))
	(for-output (memq direction '(:io :output)))
	(stream (make-file-stream)))
    ;;
    ;; Do hairy defaulting of :if-exists and :if-does-not-exist keywords.
    (unless exists-p
      (setq if-exists (if (eq (pathname-version pathname) :newest)
			  :new-version :error)))
    (unless does-not-exist-p
      (setq if-does-not-exist
	    (cond
	     ((or (memq if-exists '(:overwrite :append)) (eq direction :input))
	      :error)
	     ((eq direction :probe) nil)
	     (t :create))))
    ;;
    ;; Set stream methods and byte-size
    (set-methods-from-type stream for-input for-output
			   (canonicalize-file-element-type element-type))
    (loop
     ;;
     ;; See if the file exists and handle the existential keywords.
     (multiple-value-bind (namestring does-exist) 
			  (predict-name pathname for-input)
       (when does-exist
	 (cond (for-output
		(multiple-value-bind (name kind)
				     (mach:unix-subtestname namestring)
		  (declare (ignore name))
		  (when (eq kind :entry_directory)
		    (error "Cannot open directories for output -- ~S."
			   namestring)))
		(multiple-value-bind (noerr dev ino mode)
				     (mach:unix-stat namestring)
		  (declare (ignore dev ino))
		  (when noerr
		    (setf (file-stream-mode stream) mode)))
		(case if-exists
		  (:error
		   (cerror "write it anyway." "File ~A already exists."
			   namestring)
		   (new-file namestring stream))
		  ((:new-version :supersede)
		   (new-file namestring stream))
		  ((:rename :rename-and-delete)
		   (let ((name (concatenate 'string namestring ".BAK")))
		     (when (null (file-writable namestring))
		       (error "Attempt to open read-only file, ~S,~%  ~
			       for output with option, ~S."
			      namestring if-exists))
		     (rename-file namestring name)
		     (when (eq if-exists :rename-and-delete)
		       (setf (file-stream-delete-filename stream) name)))
		   (new-file namestring stream))
		  (:overwrite
		   (read-file-to-stream namestring stream)
		   (setf (file-stream-position stream) 0))
		  (:append
		   (read-file-to-stream namestring stream)
		   (setf (file-stream-position stream)
			 (file-stream-eof stream)))
		  ((nil) (return-from open nil))
		  (t (error "~S is not a valid value for :if-exists."
			    if-exists))))
	       (for-input
		(read-file-to-stream namestring stream)
		(setf (file-stream-position stream) 0))
	       ;; Open for probe.
	       (t
		(setf (file-stream-filename stream) namestring)))
	 (return nil))
       (case if-does-not-exist
	 (:error
	  (cerror "prompt for a new name."
		  "File ~A does not exist." namestring)
	  (format *query-io* "~&New file name: ")
	  (setq pathname (pathname (read-line *query-io*))))
	 (:create
	  (new-file namestring stream)
	  (return nil))
	 ((nil) (return-from open nil))
	 (t
	  (error "~S is not a valid value for :if-does-not-exist."
		 if-does-not-exist)))))
    stream))


;;; Make-Pointer-Input-Stream  --  Public
;;;
;;;    Just use the file input mechanisms.
;;;
(defun make-pointer-input-stream (pointer length &key (element-type 'string-char)
					  (position 0))
  "Make a stream which reads stuff from a system-area pointer.  Kind of
  like Open, only different.  Pointer is the system-area pointer for the
  data.  Length is the length of the data in 8bit bytes.  Element-Type
  is the type of the data elements.  Position is initial file-position
  in units of the element size.  Closing the stream invalidates the data."
  (let ((address (sap-int pointer))
	(stream (make-file-stream)))
    (setf (file-stream-address stream) address)
    (setf (file-stream-sap stream) pointer)
    (setf (file-stream-filename stream) "Pointer Stream")
    ;;
    ;; Set stream methods and byte-size
    (set-methods-from-type stream t nil
			   (canonicalize-file-element-type element-type))
    (let ((len (truncate (* length 8) (file-stream-byte-size stream))))
      (setf (file-stream-eof stream) len)
      (setf (file-stream-length stream) len))
    (setf (file-stream-position stream) position)
    stream))
@