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