;;; -*- Mode: Lisp; Package: File-System; Base: 8 -*-

;;; This file contains stream definitions for the magtape.

;;; Entrypoints are:
;;; MAKE-MT-STREAM &rest options
;;; MAKE-MT-FILE-STREAM &rest options
;;; MAKE-MAGTAPE-FILE-PROBE-STREAM &rest options

;;; Lossages:
;;; PAGE-SIZE-IN-BITS

;; Get a buffer of the correct byte size
(DEFUN MT-GET-RQB-ARRAY (RQB BYTE-SIZE &AUX TYPE)
  (COND ((= BYTE-SIZE 20) (RQB-BUFFER RQB))
	((= BYTE-SIZE 10) (RQB-8-BIT-BUFFER RQB))
	((SETQ TYPE (CDR (ASSQ BYTE-SIZE '((4 . ART-4B) (2 . ART-2B) (1 . ART-1B)))))
	 (MAKE-ARRAY (FLOOR (* (RQB-NPAGES RQB) (* PAGE-SIZE 32.)) BYTE-SIZE)
		     ':AREA LOCAL-FILE-SYSTEM-AREA
		     ':TYPE TYPE
		     ':DISPLACED-TO RQB
		     ;; This is a system bug.  Don't try to figure it out.
		     ':DISPLACED-INDEX-OFFSET (* (%P-CONTENTS-OFFSET (RQB-BUFFER RQB) 3)
						 (FLOOR 20 BYTE-SIZE))))
	(T (FERROR NIL "~D is an invalid byte size." BYTE-SIZE))))

(DEFFLAVOR MT-MIXIN
	((STATUS ':OPEN)
	 (UNIT 0)
	 (RECORD-SIZE 10000)
	 (DENSITY 0)
	 (IBM-MODE NIL)
	 (BYTE-SIZE 10)
	 (RQB NIL))
	()
  (:INCLUDED-FLAVORS SI:STREAM)
  (:GETTABLE-INSTANCE-VARIABLES BYTE-SIZE UNIT)
  (:INITABLE-INSTANCE-VARIABLES UNIT RECORD-SIZE DENSITY IBM-MODE BYTE-SIZE RQB))

(DEFMETHOD (MT-MIXIN :ADVANCE-FILE) () NIL)

(DEFMETHOD (MT-MIXIN :CLOSE) (&OPTIONAL ABORTP)
  (OR (EQ ABORTP ':RAW) (FUNCALL-SELF ':ADVANCE-FILE))
  (COND ((NEQ STATUS ':CLOSED)
	 (SETQ STATUS ':CLOSED)
	 (AND RQB (RETURN-DISK-RQB RQB))
	 (SETQ RQB NIL)
	 T)))

(DEFMETHOD (MT-MIXIN :RETURN-RQB) ()
  (COND (RQB (RETURN-DISK-RQB RQB)
	     (SETQ RQB NIL))))

(DEFFLAVOR MT-INPUT-MIXIN
	()
	(MT-MIXIN)
  (:INCLUDED-FLAVORS SI:BUFFERED-INPUT-STREAM))

(DEFFLAVOR MT-OUTPUT-MIXIN
	()
	(MT-MIXIN)
  (:INCLUDED-FLAVORS SI:BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (MT-INPUT-MIXIN :NEXT-INPUT-BUFFER)
	   (&OPTIONAL IGNORE &AUX BUFFER BYTES-TRANSFERRED)
  (COND ((EQ STATUS ':CLOSED)
	 (FERROR NIL "Attempt to get input from ~S, which is closed." SELF))
	((EQ STATUS ':EOF) NIL)
	(T (OR RQB
	       (SETQ RQB (GET-DISK-RQB (QUOTIENT-CEILING RECORD-SIZE PAGE-SIZE-IN-BYTES))))
	   (MT-RUN RQB %MT-COMMAND-READ (MINUS RECORD-SIZE) UNIT DENSITY)
	   (COND ((MT-STATUS-EOF)
		  (SETQ STATUS ':EOF)
		  NIL)
		 (T (SETQ BYTES-TRANSFERRED
			  (- (SIGN-EXTEND-16 (AR-1 RQB %MT-BYTE-COUNT-AFTER))
			     (SIGN-EXTEND-16 (AR-1 RQB %MT-BYTE-COUNT))))
		    (SETQ BUFFER (MT-GET-RQB-ARRAY RQB BYTE-SIZE))
		    (COND ((BIT-TEST BYTES-TRANSFERRED 3)
			   (FORMAT T "~%~D BYTES, YOU LOST DUE TO UNIBUS MAP LOSSAGE!"
				   BYTES-TRANSFERRED)
			   (PRINT-MT-RQB RQB)))
		    (SETQ BYTES-TRANSFERRED (LOGAND BYTES-TRANSFERRED (LOGNOT 3)))
		    ;; If this is a CHARACTERS file, trim the nulls from the end.
		    ;; These will only appear in the last record if the record size
		    ;; wasn't a multiple of 4.  This could possibly be fixed...
		    (COND ((FUNCALL-SELF ':CHARACTERS)
			   (DO () ((OR (ZEROP BYTES-TRANSFERRED)
				       (NOT (ZEROP (AR-1 BUFFER (1- BYTES-TRANSFERRED))))))
			     (SETQ BYTES-TRANSFERRED (1- BYTES-TRANSFERRED)))))
		    (VALUES BUFFER 0 (FLOOR (* 8 BYTES-TRANSFERRED) BYTE-SIZE)))))))

(DEFMETHOD (MT-INPUT-MIXIN :DISCARD-INPUT-BUFFER) IGNORE)

(DEFMETHOD (MT-INPUT-MIXIN :NEXT-FILE) ()
  (IF (EQ STATUS ':EOF)
      (SETQ STATUS ':OPEN)
    (MT-SPACE-TO-EOF UNIT)
    (FUNCALL-SELF ':CLEAR-INPUT)))

(DEFMETHOD (MT-INPUT-MIXIN :ADVANCE-FILE) ()
  (COND ((NOT (MEMQ STATUS '(:EOF :CLOSED)))
	 (MT-SPACE-TO-EOF UNIT)
	 (SETQ STATUS ':EOF))))

(DEFMETHOD (MT-OUTPUT-MIXIN :NEW-OUTPUT-BUFFER) ()
  (OR RQB (SETQ RQB (GET-DISK-RQB (QUOTIENT-CEILING RECORD-SIZE PAGE-SIZE-IN-BYTES))))
  (VALUES (MT-GET-RQB-ARRAY RQB BYTE-SIZE) 0 (FLOOR (* RECORD-SIZE 8) BYTE-SIZE)))

(DEFMETHOD (MT-OUTPUT-MIXIN :SEND-OUTPUT-BUFFER) (BUFFER TO-INDEX)
  (OR (AND (ARRAY-INDIRECT-P BUFFER)
	   (EQ (%P-CONTENTS-OFFSET BUFFER
				   (1+ (%P-LDB-OFFSET %%ARRAY-LONG-LENGTH-FLAG BUFFER 0)))
	       RQB))
      (FERROR NIL "Attempt to :SEND-OUTPUT-BUFFER ~S, which is not indirected into ~S"
	      BUFFER RQB))
  (LET ((COUNT (FLOOR (* TO-INDEX BYTE-SIZE) 8)))
    ;; Always write an even number of 16 bit words to
    ;; Avoid unibus map buffer lossage.
    (COND ((BIT-TEST COUNT 1)
	   (AS-1 0 BUFFER TO-INDEX)
	   (INCF COUNT)
	   (INCF TO-INDEX)))
    (COND ((BIT-TEST COUNT 3)
	   (AS-1 0 BUFFER TO-INDEX)
	   (AS-1 0 BUFFER (1+ TO-INDEX))
	   (INCF COUNT 2)))
    (COND ((PLUSP COUNT)
	   (MT-RUN RQB %MT-COMMAND-WRITE (MINUS COUNT) UNIT DENSITY IBM-MODE)))))

(DEFMETHOD (MT-OUTPUT-MIXIN :DISCARD-OUTPUT-BUFFER) IGNORE)

(DEFMETHOD (MT-OUTPUT-MIXIN :ADVANCE-FILE) ()
  (OR (EQ STATUS ':CLOSED)
      (MT-WRITE-EOF UNIT)))

(DEFFLAVOR MT-INPUT-STREAM
	()
	(MT-INPUT-MIXIN SI:BUFFERED-INPUT-STREAM))

(DEFFLAVOR MT-OUTPUT-STREAM
	()
	(MT-OUTPUT-MIXIN SI:BUFFERED-OUTPUT-STREAM))

(DEFFLAVOR MT-CHARACTER-INPUT-STREAM
	()
	(MT-INPUT-MIXIN SI:BUFFERED-LINE-INPUT-STREAM))

(DEFFLAVOR MT-CHARACTER-OUTPUT-STREAM
	()
	(MT-OUTPUT-MIXIN SI:BUFFERED-OUTPUT-CHARACTER-STREAM))

(COMPILE-FLAVOR-METHODS MT-INPUT-STREAM MT-OUTPUT-STREAM
			MT-CHARACTER-INPUT-STREAM MT-CHARACTER-OUTPUT-STREAM)

(DEFVAR *DEFAULT-RECORD-SIZE* 10000 "The number of bytes for a magtape record.")
(DEFVAR *MT-EOT-HANDLER* () "Funcalled on EOT by SOME functions.
In most cases, you should use something like CONDITION-BIND.")

;; This function makes a simple stream to the magtape.
;; It can be used by programs which want to read arbitrarily formated magtapes.
(DEFUN MAKE-MT-STREAM (&OPTIONAL &KEY (DIRECTION ':INPUT) (BYTE-SIZE 8) (CHARACTERS T)
		       (UNIT 0) (RECORD-SIZE *DEFAULT-RECORD-SIZE*) (DENSITY 0) (IBM-MODE NIL)
		       &ALLOW-OTHER-KEYS)
  (CHECK-ARG DIRECTION (MEMQ DIRECTION '(:INPUT :OUTPUT)) ":INPUT or :OUTPUT")
  (CHECK-ARG-TYPE BYTE-SIZE :NUMBER)
  (CHECK-ARG CHARACTERS (MEMQ CHARACTERS '(T NIL)) "T or NIL")
  (MAKE-INSTANCE (IF (EQ DIRECTION ':INPUT)
		     (IF CHARACTERS
			 'MT-CHARACTER-INPUT-STREAM
		       'MT-INPUT-STREAM)
		   (IF CHARACTERS
		       'MT-CHARACTER-OUTPUT-STREAM
		     'MT-OUTPUT-STREAM))
		 ':BYTE-SIZE BYTE-SIZE
		 ':UNIT UNIT
		 ':RECORD-SIZE RECORD-SIZE
		 ':DENSITY DENSITY
		 ':IBM-MODE IBM-MODE))

;;; Magtapes with headers.

;;; The following function reads a block from the magtape and tries to
;;; determine the header plist.  If it reads an EOF, it returns NIL.
;;; The second value returned is the style of header.
;;; Currently known about are :MIT, :MIT, and :MIT.

;;; this code returns a pure PLIST and does not make any assumptions about
;;; name formats or anything.

(DEFUN READ-MAGTAPE-HEADER (STREAM &AUX BUF LOW COUNT PLIST)
  (UNWIND-PROTECT
    (PROGN (MULTIPLE-VALUE (BUF LOW COUNT)
	     (FUNCALL STREAM ':GET-INPUT-BUFFER))
	   (COND ((NULL BUF) NIL)			;EOF
		 ((AND ( COUNT 4)
		       (STRING-EQUAL BUF "LMFL" LOW 0 (+ LOW 4) 4))
		  ;; MIT format.
		  (LOOP REPEAT 4 DO (FUNCALL STREAM ':TYI))
		  (LET ((BASE 10.) (IBASE 10.)
			(PACKAGE FILE-SYSTEM-PACKAGE))  ;for compatibility with old tapes
				;and also so :s come out.
		    (SETQ PLIST (READ STREAM)))
		  (VALUES PLIST ':MIT))
		 (T (FERROR NIL "Unknown tape header format.  Header is:~%~A"
			    (SUBSTRING BUF LOW (+ LOW COUNT))))))
    (FUNCALL STREAM ':DISCARD-CURRENT-INPUT-BUFFER)))
    
    
(DEFCONST TAPE-HEADER-LENGTH 1024. "Maximum and guaranteed block length for the header.")

(DEFUN WRITE-MAGTAPE-HEADER (STREAM PLIST &OPTIONAL (STYLE ':MIT))
  (UNWIND-PROTECT
      (SELECTQ STYLE
	(:MIT
	 (LET* ((*NOPOINT T)
		(BASE 10.)
		(PACKAGE FILE-SYSTEM-PACKAGE)
		(SI:PRINT-READABLY T)
		(READTABLE SI:INITIAL-READTABLE))
	   (SEND STREAM ':STRING-OUT "LMFL")
	   (PRIN1 PLIST STREAM)
	   (FUNCALL STREAM ':PAD-AND-SEND-BUFFER #\SPACE)))
	(OTHERWISE (FERROR NIL "~S is an unknown tape header format." STYLE)))
    (FUNCALL STREAM ':FINISH)))

(DEFFLAVOR HEADER-MIXIN
	(HEADER-FORMAT
	 (SI:PROPERTY-LIST NIL))
	(SI:PROPERTY-LIST-MIXIN)
  (:INCLUDED-FLAVORS MT-MIXIN)
  :INITABLE-INSTANCE-VARIABLES)

(DEFFLAVOR HEADER-INPUT-MIXIN
	()
	(HEADER-MIXIN))

(DEFFLAVOR HEADER-OUTPUT-MIXIN
	()
	(HEADER-MIXIN))

;; Write the header at the last possible minute.
(DEFMETHOD (HEADER-OUTPUT-MIXIN :BEFORE :NEXT-INPUT-BUFFER) ()
  (AND (EQ STATUS ':OPEN)
       (NULL RQB)
       (WRITE-MAGTAPE-HEADER SELF SI:PROPERTY-LIST HEADER-FORMAT)))

;this tries to responds to pathcomponent stream messages, but may not make any
; assumptions about the exact flavor of path involved (which file system, etc).
(DEFFLAVOR MT-FILE-MIXIN
	()
	()
  (:INCLUDED-FLAVORS HEADER-MIXIN MT-MIXIN))

(DEFFLAVOR MT-FILE-INPUT-MIXIN
	()
	(MT-FILE-MIXIN))

(DEFFLAVOR MT-FILE-OUTPUT-MIXIN
	()
	(MT-FILE-MIXIN))

(DEFFLAVOR MT-FILE-INPUT-STREAM
	()
	(MT-FILE-INPUT-MIXIN HEADER-INPUT-MIXIN MT-INPUT-STREAM))

(DEFFLAVOR MT-FILE-CHARACTER-INPUT-STREAM
	()
	(MT-FILE-INPUT-MIXIN HEADER-INPUT-MIXIN MT-CHARACTER-INPUT-STREAM))

(DEFFLAVOR MT-FILE-OUTPUT-STREAM
	()
	(MT-FILE-OUTPUT-MIXIN HEADER-OUTPUT-MIXIN MT-OUTPUT-STREAM))

(DEFFLAVOR MT-FILE-CHARACTER-OUTPUT-STREAM
	()
	(MT-FILE-OUTPUT-MIXIN HEADER-OUTPUT-MIXIN MT-CHARACTER-OUTPUT-STREAM))

(DEFMETHOD (MT-FILE-MIXIN :DEVICE) ()
  NIL)

(DEFMETHOD (MT-FILE-MIXIN :DIRECTORY) ()
  (GET (LOCF SI:PROPERTY-LIST) ':DIRECTORY))

(DEFMETHOD (MT-FILE-MIXIN :NAME) ()
  (GET (LOCF SI:PROPERTY-LIST) ':NAME))

(DEFMETHOD (MT-FILE-MIXIN :TYPE) ()
  (GET (LOCF SI:PROPERTY-LIST) ':TYPE))

(DEFMETHOD (MT-FILE-MIXIN :VERSION) ()
  (GET (LOCF SI:PROPERTY-LIST) ':VERSION))
  
(DEFMETHOD (MT-FILE-MIXIN :CREATION-DATE) ()
  (GET (LOCF SI:PROPERTY-LIST) ':CREATION-DATE))

(DEFMETHOD (MT-FILE-MIXIN :QFASLP) ()
  (GET (LOCF SI:PROPERTY-LIST) ':QFASLP))

(DEFMETHOD (MT-FILE-OUTPUT-MIXIN :CHANGE-PROPERTIES) (IGNORE &REST PROPERTIES)
  (LOOP FOR (IND PROP) IN PROPERTIES BY #'CDDR
	DO (PUTPROP (LOCF SI:PROPERTY-LIST) PROP IND)))

;; This takes keywords compatibly with OPEN
;; Probe openings are not implemented.
;; This function expects the magtape to be at the beginning of a file header.
;; Errors returned unique to magtape are:
;;  PNA F Probe openings not allowed
;;  EOT F End of Tape

(DEFUN MAKE-MT-FILE-STREAM (&OPTIONAL
			     &REST OPTIONS
			     &KEY
			    (DIRECTION ':INPUT)
			    (CHARACTERS ':DEFAULT)
			    (ERROR T)
			    (BYTE-SIZE ':DEFAULT)
			    (UNIT 0)
			    (RECORD-SIZE *DEFAULT-RECORD-SIZE*)
			    (DENSITY 0)
			    (IBM-MODE NIL)
			    (PLIST NIL)
			    (HEADER-STYLE ':MIT)	;Default for write
			    &ALLOW-OTHER-KEYS
			    &AUX STREAM TEM)
  (COND ((EQ DIRECTION ':INPUT)
	 (MULTIPLE-VALUE (PLIST HEADER-STYLE)
	   (READ-MAGTAPE-HEADER
	     (SETQ STREAM (LEXPR-FUNCALL 'MAKE-MT-STREAM
					 ':CHARACTERS T
					 ':BYTE-SIZE 8
					 ':UNIT UNIT
					 ':DENSITY DENSITY
					 OPTIONS))))
	 (FUNCALL STREAM ':CLOSE ':RAW)
	 (IF (NULL PLIST)
	     (MT-OPEN-ERROR (MAKE-CONDITION 'END-OF-TAPE "End of tape on unit ~D." UNIT)
			    ERROR)
	     (AND (EQ CHARACTERS ':DEFAULT)
		  (IF (SETQ TEM (GETL (LOCF PLIST) '(:CHARACTERS)))
		      (SETQ CHARACTERS (CADR TEM))
		      ;; Kludge for old format tapes.
		      (SETQ CHARACTERS (= (GET (LOCF PLIST) ':BYTE-SIZE) 8))))
	     (AND (EQ BYTE-SIZE ':DEFAULT)
		  (SETQ BYTE-SIZE (GET (LOCF PLIST) ':BYTE-SIZE)))
	     (AND (NULL BYTE-SIZE)
		  (SETQ BYTE-SIZE (IF CHARACTERS 8. 16.)))
	     (MAKE-INSTANCE (IF CHARACTERS
				'MT-FILE-CHARACTER-INPUT-STREAM
				'MT-FILE-INPUT-STREAM)
			    ':BYTE-SIZE BYTE-SIZE
			    ':UNIT UNIT
			    ':RECORD-SIZE RECORD-SIZE
			    ':DENSITY DENSITY
			    ':PROPERTY-LIST PLIST
			    ':HEADER-FORMAT HEADER-STYLE
			    ':IBM-MODE IBM-MODE)))
	((EQ DIRECTION ':OUTPUT)
	 (AND (EQ BYTE-SIZE ':DEFAULT)
	      (SETQ BYTE-SIZE (GET (LOCF PLIST) ':BYTE-SIZE)))
	 (AND (NULL BYTE-SIZE)
	      (SETQ BYTE-SIZE (IF CHARACTERS 8. 16.)))
	 (WRITE-MAGTAPE-HEADER
	   (SETQ STREAM (LEXPR-FUNCALL 'MAKE-MT-STREAM
				       ':DIRECTION ':OUTPUT
				       ':CHARACTERS T
				       ':BYTE-SIZE 8
				       ':UNIT UNIT
				       ':DENSITY DENSITY
				       OPTIONS))
	   PLIST
	   HEADER-STYLE)
	 (FUNCALL STREAM ':CLOSE ':RAW)
	 (MAKE-INSTANCE (IF CHARACTERS
			    'MT-FILE-CHARACTER-OUTPUT-STREAM
			    'MT-FILE-OUTPUT-STREAM)
			':BYTE-SIZE BYTE-SIZE
			':UNIT UNIT
			':RECORD-SIZE RECORD-SIZE
			':DENSITY DENSITY
			':PROPERTY-LIST PLIST
			':HEADER-FORMAT HEADER-STYLE
			':IBM-MODE IBM-MODE))
	(T (FERROR NIL "Probe opens not allowed on magtape."))))

(DEFUN MT-OPEN-ERROR (CONDITION ERROR-P)
  (IF ERROR-P
      (SIGNAL-CONDITION CONDITION)
    CONDITION))

(COMPILE-FLAVOR-METHODS MT-FILE-INPUT-STREAM MT-FILE-CHARACTER-INPUT-STREAM
			MT-FILE-OUTPUT-STREAM MT-FILE-CHARACTER-OUTPUT-STREAM)

;;; RESTORE-MAGTAPE

;; This is the driver for RESTORE-MAGTAPE and friends.
;; The first value returned describes what it found on the magtape.
;; Possible values are:
;;  :EOF		An end of file block was found.
;;  :STREAM		A header block was found and sucessfully decoded.
;;			Second value is an input stream, from which can be found
;;			properties, truenames, partition-p, etc.
;;  :TAPE-HEADER	A block was found which was a tape header.
;;			The plist from this header is the second value.
;;  :HEADER		This is some sort of header which is not a tape header.
;;			The plist from this header is the second value.
;;  :ERROR		A tape header couldn't be decoded.
;;			Reason (a string) is the second value.

;This tries to be just enuf to allow opening MT: for input or output.
; It specifially tries to make no assumptions about pathnames.
(DEFFLAVOR MT-HOST
	(DEVICE-NAME)
	(SI:BASIC-HOST)
  (:GETTABLE-INSTANCE-VARIABLES DEVICE-NAME)
  (:INITABLE-INSTANCE-VARIABLES DEVICE-NAME))

(DEFMETHOD (MT-HOST :NAME) NIL DEVICE-NAME)
(DEFMETHOD (MT-HOST :NAME-AS-FILE-COMPUTER) NIL DEVICE-NAME)
(DEFMETHOD (MT-HOST :PATHNAME-HOST-NAMEP) (NAME)
  (STRING-EQUAL NAME DEVICE-NAME))

(DEFMETHOD (MT-HOST :PATHNAME-FLAVOR) ()
  (VALUES 'MT-PATHNAME NIL))

(DEFFLAVOR MT-PATHNAME () (PATHNAME))

(DEFMETHOD (MT-PATHNAME :PARSE-NAMESTRING)
	   (HOST-SPECIFIED STRING &OPTIONAL (START 0) END)
  HOST-SPECIFIED
  (VALUES ':NO-INTERN (MAKE-INSTANCE 'MT-FILEHANDLE
				     ':NAMESTRING (SUBSTRING STRING START END))))

;NAMESTRING is just for pseudo debugging purposes; Magtape files dont really have names.
(DEFFLAVOR MT-FILEHANDLE (NAMESTRING) ()
  (:INITABLE-INSTANCE-VARIABLES NAMESTRING))

(DEFMETHOD (MT-FILEHANDLE :STRING-FOR-PRINTING) () NAMESTRING)
(DEFMETHOD (MT-FILEHANDLE :PRINT-SELF) (STREAM PRINDEPTH SLASHIFY-P) PRINDEPTH
  (COND (SLASHIFY-P
	 (SEND STREAM ':STRING-OUT "#<")
	 (PRIN1 'MT-FILEHANDLE STREAM)
	 (FORMAT STREAM " ~S ~O>" NAMESTRING (%POINTER SELF)))
	(T
	 (SEND STREAM ':STRING-OUT NAMESTRING))))

;This is a kludge to make the copy-patch-files-of-system work.
(DEFMETHOD (MT-FILEHANDLE :PATCH-FILE-PATHNAME) (&REST IGNORE)
  "MT:")

(DEFUN PUTPROP-MAYBE (PLIST VALUE PROP)
  (WHEN (AND VALUE (NULL (GET PLIST PROP)))
    (PUTPROP PLIST VALUE PROP)))

(DEFMETHOD (MT-FILEHANDLE :OPEN) (IGNORE &REST KEYWORD-ARGS
					 &KEY &OPTIONAL
					 (DIRECTION ':INPUT)
					 DEFAULTS-FROM-STREAM 
					 BYTE-SIZE
					 AUTHOR
					 &ALLOW-OTHER-KEYS)
  (COND ((EQ DIRECTION ':INPUT)
	 (LEXPR-FUNCALL 'MAKE-MT-FILE-STREAM KEYWORD-ARGS))
	((EQ DIRECTION ':OUTPUT)
	 (COND (DEFAULTS-FROM-STREAM
		(LET* ((TRUENAME (FUNCALL DEFAULTS-FROM-STREAM ':TRUENAME))
		       (PLIST
			 (FILTER-PLIST (FUNCALL DEFAULTS-FROM-STREAM ':PLIST)
				       (PLIST TRUENAME)))
		       (REAL-PLIST (LOCF PLIST)))
		  (PUTPROP-MAYBE REAL-PLIST BYTE-SIZE ':BYTE-SIZE)
		  (PUTPROP-MAYBE REAL-PLIST AUTHOR ':AUTHOR)
		  (PUTPROP-MAYBE REAL-PLIST (SEND TRUENAME ':DIRECTORY) ':DIRECTORY)
		  (PUTPROP-MAYBE REAL-PLIST (SEND TRUENAME ':NAME) ':NAME)
		  (PUTPROP-MAYBE REAL-PLIST (SEND TRUENAME ':TYPE) ':TYPE)
		  (PUTPROP-MAYBE REAL-PLIST (SEND TRUENAME ':VERSION) ':VERSION)
   ;:UNSPECIFIC would not win when read back in, so guess.
		  (IF (EQ (GET (LOCF PLIST) ':TYPE)
			  ':UNSPECIFIC)
		      (LET ((FPLIST (FILE-READ-ATTRIBUTE-LIST NIL DEFAULTS-FROM-STREAM)))
			(PUT-ON-ALTERNATING-LIST
			  (COND ((EQ (GET (LOCF FPLIST) ':MODE)
				     ':LISP)
				 "LISP")
				((= BYTE-SIZE 10)
				 "TEXT")
				(T "UNKNOWN"))
			  PLIST
			  ':TYPE)))
		  (LEXPR-FUNCALL 'MAKE-MT-FILE-STREAM
				 ':PLIST PLIST
				 KEYWORD-ARGS)))
	       (T (FERROR NIL "MT: wins only for copying with stream default"))))
	(T (FERROR () "~A not a recognised :OPEN direction (and probes are not allowed"
		   DIRECTION))))

;TRY TO GET RID OF ANY UNPRINTABLE THINGS FROM PLIST-TO-FILTER..
(DEFUN FILTER-PLIST (PLIST-TO-FILTER PLIST-SO-FAR)
  (COND ((NULL PLIST-TO-FILTER) PLIST-SO-FAR)
	((OR (NULL (CADR PLIST-TO-FILTER))
	     (NUMBERP (CADR PLIST-TO-FILTER))
	     (STRINGP (CADR PLIST-TO-FILTER))
	     (LISTP (CADR PLIST-TO-FILTER)))
	 (FILTER-PLIST (CDDR PLIST-TO-FILTER)
		       (CONS (CAR PLIST-TO-FILTER)
			     (CONS (CADR PLIST-TO-FILTER)
				   PLIST-SO-FAR))))
	(T (FILTER-PLIST (CDDR PLIST-TO-FILTER) PLIST-SO-FAR))))

(DEFUN ADD-MT-HOST (&OPTIONAL (NAME "MT"))
  (COND ((NULL (GET-PATHNAME-HOST NAME T))
	 (LET ((HOST (MAKE-INSTANCE 'MT-HOST ':DEVICE-NAME NAME)))
	   (PUSH HOST *PATHNAME-HOST-LIST*)))))
(COMPILE-FLAVOR-METHODS MT-HOST MT-PATHNAME MT-FILEHANDLE)

(ADD-MT-HOST)