;;;; 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.

(defconstant initial-terminal-out-buffer-size 4096)
(defstruct (terminal-stream
	    (:print-function %print-terminal-stream)
	    (:include stream
		      (in #'terminal-in)
		      (readline #'terminal-readline)
		      (listen #'terminal-listen)
		      (out #'terminal-out)
		      (sout #'terminal-sout)
		      (charpos #'terminal-charpos)
		      (misc #'terminal-misc))
	    (:constructor make-terminal-stream (typescript)))
  ;; The typescript we read from and write to.
  typescript
  ;; The buffer containing unread input.
  (in-buffer "")
  ;; Index of the first character available in In-Buffer.
  (in-index 0)
  ;; The buffer containing unsent output.
  (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))

(defun %print-terminal-stream (s stream d)
  (declare (ignore d))
  (format stream "#<Terminal stream, Typescript = ~S>"
	  (terminal-stream-typescript s)))

(defun stream-init ()
  (setq *terminal-io* (make-terminal-stream *user-typescript*))
  (setq *standard-input* (make-synonym-stream '*terminal-io*))
  (setq *standard-output* (make-synonym-stream '*terminal-io*))
  (setq *error-output* (make-synonym-stream '*terminal-io*))
  (setq *query-io* (make-synonym-stream '*terminal-io*))
  (setq *trace-output* (make-synonym-stream '*terminal-io*)))

(defun beep (&optional (stream *terminal-io*))
  (declare (ignore stream))
  (do ((start (%primitive io-get-time)))
      ((/= (%primitive io-get-time) start)))
  (view-color-rect 2 0 0 1024 1024)
  (dotimes (i 2)
    (do ((start (%primitive io-get-time)))
	((/= (%primitive io-get-time) start))))
  (view-color-rect 2 0 0 1024 1024))

;;;; Terminal Stream Methods:
;;;
;;;    EOF-ERRORP & EOF-VALUE are always ignored in terminal functions because
;;; we never allow the terminals to reach eof.
;;;
;;;    The input methods are more general than demanded by the pascal
;;; typescript server, in that they do not assume that the string returned
;;; is exactly a line.  This is so that when the Lisp typescript server is
;;; up, we will not be stuck in linmode.

;;; Get-String-To-Stream  --  Internal
;;;
;;;    This function repeatedly calls sts-get-string on Stream's typescript
;;; until it returns non-empty string.  This function is also responsible
;;; for flushing any unsent output.
;;;
(defun get-string-to-stream (stream)
  (force-output stream)
  (do* ((typescript (terminal-stream-typescript stream))
	(result (sts-get-string typescript) (sts-get-string typescript)))
       ((not (zerop (length result)))
	(setf (terminal-stream-in-buffer stream) result)
	(setf (terminal-stream-in-index stream) 0))
    (declare (simple-string result))))
  
;;; 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 typescript.
;;;
(defun terminal-readline (stream eof-errorp eof-value)
  (declare (ignore eof-errorp eof-value))
  (do* ((start (terminal-stream-in-index stream)
	       (terminal-stream-in-index stream))
	(buffer (terminal-stream-in-buffer stream)
		(terminal-stream-in-buffer stream))
	(end (length buffer) (length buffer))
	(nl (position #\newline buffer :start start  :end end)
	    (position #\newline buffer :start start  :end end))
	(result ""))
       (nl
	(setf (terminal-stream-in-index stream) (1+ nl))
	;; Since we don't have terminal EOF, 2nd value is always nil.
	(values (concatenate 'simple-string result (subseq buffer start nl))
		nil))
    (declare (simple-string buffer))
    (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)
  (declare (ignore eof-errorp eof-value))
  (let ((index (terminal-stream-in-index stream))
	(buffer (terminal-stream-in-buffer stream)))
    (declare (simple-string buffer))
    (when (= index (length buffer))
      (get-string-to-stream stream)
      (setq index (terminal-stream-in-index stream))
      (setq buffer (terminal-stream-in-buffer stream)))
    (setf (terminal-stream-in-index stream) (1+ index))
    (schar buffer index)))

;;; Terminal-Listen  --  Internal
;;;
;;;    The listen method for terminal streams.  We just tell whether
;;; there is any stuff in the input buffer.  We might say whether there
;;; was an unread line if there was a way to find out.
;;;
(defun terminal-listen (stream)
  (/= (terminal-stream-in-index stream)
      (length (the simple-string (terminal-stream-in-buffer stream)))))

;;; 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))
	(typescript (terminal-stream-typescript stream)))
    (declare (simple-string buffer))
    (when (= index (length buffer))
      (let* ((length (length buffer))
	     (new (make-string (* length 2))))
	(%sp-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)
	   (sts-put-char-array typescript 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 everthing in the string up through the last newline.
;;;
(defun terminal-sout (stream string start end)
  (declare (simple-string string))
  (let ((buffer (terminal-stream-out-buffer stream))
	(index (terminal-stream-out-index stream))
	(typescript (terminal-stream-typescript stream)))
    (declare (simple-string buffer))
    (when (%sp-find-character string start end #\newline)
      (let* ((last (position #\newline string :start start :end end
			     :from-end t))
	     (next (1+ last)))
	(sts-put-char-array typescript buffer 0 index)
	(sts-put-char-array typescript string start next)
	(setf (terminal-stream-out-offset stream) 0)
	(setq start next  index 0)))
    (let* ((length (- end start))
	   (new-index (+ index length)))
      (when (> new-index (length buffer))
	(let ((new (make-string (max (* (length buffer) 2) new-index))))
	  (%sp-byte-blt buffer 0 new 0 index)
	  (setq buffer new)
	  (setf (terminal-stream-out-buffer stream) new)))
      (%sp-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.
;;;
(defun terminal-misc (stream operation abort-flag)
  (declare (ignore abort-flag))
  (case operation
    (:clear-input
     (setf (terminal-stream-in-index stream) 0
	   (terminal-stream-in-buffer stream) ""))
    (:clear-output (setf (terminal-stream-out-index stream) 0))
    ((:finish-output :force-output)
     (let ((index (terminal-stream-out-index stream)))     
       (incf (terminal-stream-out-offset stream) index)
       (sts-put-char-array (terminal-stream-typescript stream)       
			   (terminal-stream-out-buffer stream)
			   0 index)
       (setf (terminal-stream-out-index stream) 0)))
    (:element-type 'string-char)
    (:line-length 84)))				; for now...

;;; Terminal-Charpos  --  Internal
;;;
;;;    The charpos method for terminal streams.  We add in the offset to
;;; the amount lying around in the buffer to take into consideration
;;; any stuff that might have been forced out.
;;;
(defun terminal-charpos (stream)
  (+ (terminal-stream-out-index stream) 
     (terminal-stream-out-offset stream)))

;;;; File I/O stuff:
(defconstant cr-code (char-code #\return))

;;;; Error reporting:
(eval-when (compile eval)
(defconstant name-not-found-gr 1201)
(defconstant directory-not-found-gr 1202)
(defconstant directory-not-empty-gr 1203)
(defconstant badname-gr 1204)
(defconstant invalid-version-gr 1205)
(defconstant invalid-directory-version-gr 1206)
(defconstant bad-wild-name-gr 1207)
(defconstant not-a-file-gr 1208)
(defconstant no-access-gr 1209)
(defconstant not-same-partition-gr 1210)
(defconstant improper-entry-type-gr 1211)
(defconstant not-a-directory-gr 1212)
); eval-when (compile eval)

(defun sesame-error (code context)
  (unless (= code rc-success)
    (error (case code
	     (#.name-not-found-gr "Name ~S not found.")
	     (#.directory-not-found-gr "Directory not found: ~A")
	     (#.directory-not-empty-gr "Directory not empty: ~A")
	     (#.badname-gr "Bad filename: ~S")
	     (#.invalid-version-gr "Invalid version: ~A")
	     (#.invalid-directory-version-gr "Invalid directory version: ~A")
	     (#.bad-wild-name-gr "Bad wild name ~S")
	     (#.not-a-file-gr "~A is not a file.")
	     (#.no-access-gr "No access to ~S.")
	     (#.not-same-partition-gr "~A is in the wrong partition.")
	     (#.improper-entry-type-gr "Improper entry type for ~S.")
	     (#.not-a-directory-gr "~S is not a directory.")
	     (t (error "Unknown error ~D for ~S" code context)))
	   context)))

;;;; 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 %print-file-stream))
  ;; 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 element type.
  element-type)

(defun %print-file-stream (s stream d)
  (declare (ignore d))
  (format stream "#<File stream ~S>" (file-stream-filename s)))

;;; File-Position  --  Public
;;;
;;;    Just return or set the file position, checking bounds.
;;;
(defun file-position (file-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 (file-stream-p file-stream)
    (error "Argument ~S is not a stream open to a file."))
  (if (null position)
      (- (file-stream-position file-stream)
	 (- peek-buffer-length (stream-peek-index file-stream)))
      (let ((eof (file-stream-eof file-stream)))
	;; Flush out the peek buffer so that we don't read any stuff in it.
	(setf (stream-peek-index file-stream) peek-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)))

;;; File-Length  --  Public
;;;
;;;    Return the eof field.
;;;
(defun file-length (file-stream)
  "This function returns the length of the file that File-Stream is open to."
  (unless (file-stream-p file-stream)
    (error "Argument ~S is not a stream open to a file."))
  (file-stream-eof file-stream))

;;; File-Listen  --  Internal
;;;
;;;    Check if the position is at EOF.
;;;
(defun file-listen (stream)
  (/= (file-stream-position stream) (file-stream-eof 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)
  (multiple-value-bind (gr address size)
		       (sub-read-file namestring)
    (sesame-error gr namestring)
    (setf (file-stream-sap stream)
	  (%sp-make-misc address))
    (setf (file-stream-address stream) address)
    (let ((len (truncate (* size 8) (file-stream-byte-size stream))))
      (setf (file-stream-eof stream) len)
      (setf (file-stream-length stream) len))))

;;; 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)

;;; Invalidate-File  --  Internal
;;;
;;;    Invalidate the memory validated to hold a file's data.
;;;
(defun invalidate-file (stream)
  (invalidate-memory
   (file-stream-address stream)
   (round-to-pages (convert-to-8bit (file-stream-length stream)
				    (file-stream-byte-size stream)))))

;;; File-Output-Close  --  Internal
;;;
;;;    This function is called by the close methods for files open for
;;; input or io.  It writes the data if abort-flag is false and then
;;; invalidates the memory.
;;;
(defun file-output-close (stream abort-flag data-form)
  (unless abort-flag
    (let ((name (file-stream-filename stream)))
      (sesame-error
       (sub-write-file
	name
	(file-stream-address stream)
	(convert-to-8bit (file-stream-eof stream) (file-stream-byte-size stream))
	data-form)
       name)))
  (invalidate-file 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)

;;; 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 (validate-memory 0 file-grow-size -1)))
    (setf (file-stream-address stream) address)
    (setf (file-stream-sap stream)
	  (%primitive make-immediate-type address %misc-type)))
  (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 (validate-memory 0 new-size -1))
	 (old-address (file-stream-address stream)))
    (move-words old-address      	; address to move from
		new-address		; address to move to
		(ash old-size -1)	; # of 16 bit words to move.
		T 			; invalidate source pages
		()			; create at new-address
		-1			; create mask
		T)			; don't share pages.
    (setf (file-stream-length stream) (truncate (* 8 new-size) byte-size))
    (setf (file-stream-address stream) new-address)
    (setf (file-stream-sap stream)
	  (%primitive make-immediate-type new-address %misc-type))))

;;;; 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 peek 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 peek-buffer is totally 
;;; empty, since read-char wouldn't have called us otherwise.
;;;
(defconstant 1-peek-buffer-length (1- peek-buffer-length))
(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))
	 (peek-buffer *current-peek-buffer*)
	 (dst-idx))
    (declare (simple-array buffer))
    (cond
      ((>= start end)
       (eof-or-lose stream eof-error-p eof-value))
      (t 
       (let ((idx (%sp-find-character buffer start end #\linefeed)))
	 ;; No line breaks thru EOF
	 (cond
	  ((null idx)
	   (setq dst-idx (- peek-buffer-length (- end start)))
	   (if (minusp dst-idx)
	       (setq dst-idx 0  idx (+ start peek-buffer-length))
	       (setq idx end))
	   (%sp-byte-blt buffer start peek-buffer dst-idx peek-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-peek-buffer-length (- idx start)))
	   (if (minusp dst-idx)
	       (setq dst-idx 0  idx (+ start peek-buffer-length))
	       (setq idx (1+ idx)))
	   (%sp-byte-blt buffer start peek-buffer dst-idx peek-buffer-length))
	  ;; Found CRLF, pass through only LF.
	  (t
	   (setq dst-idx (- peek-buffer-length (- idx start)))
	   (cond ((minusp dst-idx)
		  (setq dst-idx 0  idx (+ start peek-buffer-length))
		  (%sp-byte-blt buffer start peek-buffer dst-idx
				peek-buffer-length))
		 (t
		  (setq idx (1+ idx))
		  (%sp-byte-blt buffer start peek-buffer dst-idx
				1-peek-buffer-length)
		  (setf (schar peek-buffer 1-peek-buffer-length) #\linefeed)))))
	 (setf (file-stream-position stream) idx)
	 (setq *current-peek-index* (1+ dst-idx))
	 (schar peek-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)
  (let* ((data (file-stream-sap stream))
	 (eof (file-stream-eof stream))
	 (bol (file-stream-position stream))
	 (idx (%sp-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)
	    (%sp-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)))
	  (%sp-byte-blt data bol res 0 len)
	  (setf (file-stream-position stream) next)
	  (values res (= next eof))))))))

;;; 8bit-vector-out  --  Internal
;;;
;;;    This is the file sout method.  Although primarily for writing strings,
;;; it will write 8bit I-vectors with equal panache.
;;;
(defun 8bit-vector-out (stream vector start end)
  (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))
    (%sp-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)
  (let* ((end (file-stream-position stream))
	 (found (%sp-reverse-find-character (file-stream-sap stream) 0 end
					    #\newline)))
    (if found (- end found) end)))

;;;; Binary methods:

;;; <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 8bit-system-ref-macro (sap index) 
  `(%primitive 8bit-system-ref ,sap ,index))
(defmacro 16bit-system-ref-macro (sap index) 
  `(%primitive 16bit-system-ref ,sap ,index))
(defmacro 32bit-system-ref-macro (sap index)
  `(let ((base (ash ,index 1)))
     (logior (%primitive 16bit-system-ref ,sap base)
	     (ash (%primitive 16bit-system-ref ,sap (1+ base)) 16))))
(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)
  `(let ((res (%primitive 16bit-system-ref ,sap ,index)))
     (if (zerop (logand #x8000 res))
	 res
	 (logior res #x-10000))))
(defmacro 32bit-signed-system-ref-macro (sap index)
  `(let* ((base (ash ,index 1))
	  (res (%primitive 16bit-system-ref ,sap (1+ base))))
     (unless (zerop (logand #x8000 res))
       (setq res (logior res #x-10000)))
     (logior (%primitive 16bit-system-ref ,sap base) (ash res 16))))
); eval-when (compile eval)

(define-bin-method file-8bit-bin 8bit-system-ref-macro)
(define-bin-method file-16bit-bin 16bit-system-ref-macro)
(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)

;;; <n>bit-bout-method  --  Internal
;;;
;;;    These functions read 8, 16, or 32 bit, signed or unsigned bytes
;;; from files.
;;;
(eval-when (compile eval)
(defmacro define-bout-method (name setter)
  `(defun ,name (stream value)
     (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)
  `(let ((base (ash ,index 1)))
     (%primitive 16bit-system-set ,sap base (logand ,value #xFFFF))
     (%primitive 16bit-system-set ,sap (1+ base) (ash ,value -16))))
(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))
    (%sp-byte-blt (file-stream-sap stream) index buffer start (+ start numbytes))
    numbytes))

(eval-when (compile eval)
(defconstant dform-lf-text 264)
(defconstant dform-8-bit 8)
(defconstant dform-16-bit 16)
(defconstant dform-32-bit 32)
); eval-when (compile eval)

;;; File-XXX-Misc  --  Internal
;;;
;;;    The only interesting operations are :close and :element-type.
;;;
(defun file-out-misc (stream operation abort-flag)
  (case operation
    (:close
     (let ((type (file-stream-element-type stream)))
       (if (eq type 'string-char)
	   (file-output-close stream abort-flag dform-lf-text)
	   (file-output-close stream abort-flag
			      (case (cadr type)
				(8 dform-8-bit)
				(16 dform-16-bit)
				(32 dform-32-bit))))))
    (:element-type (file-stream-element-type stream))))
;;;
(defun file-in-misc (stream operation abort-flag)
  (declare (ignore abort-flag))
  (case operation
    (:close (invalidate-file stream))
    (:element-type (file-stream-element-type 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-listen stream) #'file-listen)
    (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
	     (stream-readline stream) #'text-readline
	     (stream-charpos stream) #'text-charpos))
     (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-bin 
		     (stream-n-bin stream) #'file-8bit-n-bin))
	    (16 (setf (stream-bin stream) #'file-16bit-bin))
	    (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 :in-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))
    ;;
    ;; See if the file exists and handle the existential keywords.
    (multiple-value-bind (namestring does-exist) 
			 (predict-name pathname for-input)
      (if does-exist
	  (cond (for-output
		 (case if-exists
		   (:error (error "File ~A already exists." namestring))
		   ((:new-version :supersede :rename :rename-and-delete)
		    (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)))
	  (case if-does-not-exist
	    (:error (error "File ~A does not exist." namestring))
	    (:create (new-file namestring stream))
	    ((nil) (return-from open nil))
	    (t (error "~S is not a valid value for :if-does-not-exist."
		      if-does-not-exist)))))
    stream))