;LISP machine character level I/O stuff -*-LISP-*-
; ** (c) Copyright 1980 Massachusetts Institute of Technology **

; This file documents what a stream is, what the operations to streams
; are, and the initial setup of streams in the Lisp Machine environment.
; It also contains some of the basic declarations and functions.

;An I/O stream is presently a function which is called with first
;argument the symbolic name of an operation to be performed;  and
;succeeding arguments, arguments to that operation.  If you want to
;have more than one stream serviced by the same function, you
;make closures.
;
;Since a stream may find itself being called on any implemented options,
;it should be prepared to take that many arguments.  The correct thing
;to do is to take ARG1 as an optional and the rest of the arguments as a rest-arg.
;
;"Characters" are fixnums usually between 0 and 217, in any case 0-377 .
;Some streams e.g. keyboard input) give characters with control and
;meta bits added to them, producing values as high as 1777 .
;
;Operations are:
;	:WHICH-OPERATIONS returns a list of the operations the specific
;			stream can support.  This is the only operation which
;			every stream is required to support, and is not included
;			in the list WHICH-OPERATIONS returns.
;	:TYI		ARG1 is NIL to return NIL at EOF,
;			anything else to give an error with ARG1 as message.
;			Presently, input read with rubout processing in effect
;			is echoed, and other input is not.  If this doesn't prove
;			to be the right thing, it could be changed in the future.
;	:LISTEN		Returns NIL if no immediately-available input,
;			or non-NIL if one is available.  The character is
;			not removed from the "input stream."  
;	:UNTYI		ARG1 is character to be "put back".
;	:TYO		ARG1 is character to be typed out.
;	:CLOSE		no args.  Closes PDP10 file.
;	:READ-POINTER	return character position in file.
;	:CLEAR-INPUT	discard buffered input
;	:CLEAR-OUTPUT	discard buffered output
;	:FORCE-OUTPUT	Force buffered output to be sent to the device.
;	:FINISH		Await I/O completion.
;	:NAME		Returns the name of the file open.
;	:LINE-IN	read in a line at a time, returning a string.
;			ARG1 is NIL meaning don't bother copying line,
;			T meaning do copy it, or a number meaning
;			copy and return a string with a leader that
;			many words long.  The newline character at
;			the end of the line is not included.  If
;			there is no newline, because the end of the
;			file was reached, a second value of T is
;			returned.
;	:STRING-OUT	ARG1 is a string, whose characters are all
;			TYO'd to the stream.  When it exists, it
;			is faster than repeated TYO operations.
;	:LINE-OUT	ARG1 is a string.  Its characters are all
;			TYO'd, followed by a newline.  Sometimes this
;			is faster than a STRING-OUT;  eg, for buffer-point
;			streams, LINE-OUT of a string with the appropriate
;			size leader simply sticks the string into the buffer.
;	:RUBOUT-HANDLER	ARG1 is an a-list of options, valid ones described below:
;			(:FULL-RUBOUT foo) causes the values NIL and foo
;			to be returned if the user rubs out everything he typed.
;			(:REPROMPT function) calls function on the stream before the
;			buffered input whenever CLEAR, VT, or FORM is typed.  The
;			character typed is the second argument to the function.
;			(:PROMPT function) calls function on the stream
;			when the handler is first entered, as well as in the above cases.
;			(:PASS-THROUGH . chars) causes each of the characters in chars to
;			be treated as self-inserting, thus functions like qsend can read
;			until control-c or control-g.
;
;			ARG2 is a function to be called, and the rest of the
;			arguments will be passed as arguments to it.  While
;			control is inside that function, TYI operations on
;			this stream will be under control of the rubout handler.
;			If characters are rubbed out, control will be thrown
;			back out of that function, and it will be re-entered to
;			rescan the input before the rubbed-out characters.
;			Special care is taken to pass back multiple values correctly.
;			The symbol RUBOUT-HANDLER is T while control is inside
;			the rubout handler, NIL otherwise.  The rubout-handler
;			should not be called recursively.  BREAK binds
;			RUBOUT-HANDLER to NIL so a new catch WILL be established
;			by re-calling of the rubout handler.
;			There is only one RUBOUT-HANDLER variable even though there
;			might be several streams which handle rubout, since you
;			can only be reading from one at a time within a single stack group.
;			The symbol RUBOUT-HANDLER is also used as the catch-tag.
;	:FRESH-LINE	Output a newline unless output is already at the beginning
;			of a new line.
;	:READ-CURSORPOS Takes an argument which is either :CHARACTER or :PIXEL
;			and returns the horizontal and vertical cursorpositions
;			(two values) in the specified units.
;	:SET-CURSORPOS  Takes an argument to specify the units (:CHARACTER or :PIXEL)
;			followed by two arguments which are the X and Y positions to go to.
;	:TRIGGER-MORE	Triggers **MORE** processing on a stream that supports that.
;			A no-op on all other streams.
;       :PC-PPR		Hands back the PC-PPR this stream uses (for those streams which do).
;       :SET-PC-PPR     Simply set the PC-PPR this stream uses to ARG1.  Does not
;			do any TV-ACTIVATE-PC-PPRs or anything.
;The next two operations are special for GRIND, and only work
;on some streams.  GRIND takes an argument for whether to try to use them.
;	:UNTYO-MARK	returns an object which "points to" the current
;			amount of stuff outputted to this stream.
;	:UNTYO		ARG1 is a mark returned by UNTYO-MARK.  Backs up
;			output to that point.
;Other operations will be added in the future.

(SETQ STREAM-INPUT-OPERATIONS
      '(:TYI :LISTEN :UNTYI :LINE-IN :RUBOUT-HANDLER))

(SETQ STREAM-OUTPUT-OPERATIONS
      '(:TYO :FORCE-OUTPUT :FINISH :STRING-OUT :LINE-OUT :FRESH-LINE :UNTYO-MARK :UNTYO))

; Naming conventions:
;   Symbols whose names end in "-INPUT", "-OUTPUT", or "-IO" should
;      normally be BOUND to streams; which of the three you use depends on
;      what directions the stream normally supports.
;   Symbols whose names end in "-STREAM" are DEFINED as streams.


; Synonyms.
; MAKE-SYN-STREAM takes a symbol, and returns a stream which will forward all operations
;   to the binding of the symbol.  After (SETQ BAR (MAKE-SYN-STREAM 'FOO)), one says
;   that BAR is SYNned to FOO.


; The initial environment.
;   The initial binding of streams (set up by LISP-REINITIALIZE) is
;      as follows:
;   TERMINAL-IO     - This is how to get directly to the user's terminal.  It is set
;                     up to go to the TV initially.  Other places it might go are to
;                     the SUPDUP server, etc.  It is initially bound to a TV-MAKE-STREAM
;                     of CONSOLE-IO-PC-PPR.
;   STANDARD-INPUT  - This is initially bound to SYN to TERMINAL-IO.
;   STANDARD-OUTPUT - This is initially bound to SYN to TERMINAL-IO. STANDARD-INPUT
;                     and STANDARD-OUTPUT are the default streams for READ, PRINT and
;                     other things.  STANDARD-OUTPUT gets hacked when the session is
;                     being scripted, for example.
;   ERROR-OUTPUT    - This is where error messages should eventually get sent. Initially
;                     SYNned to TERMINAL-IO.
;   QUERY-IO        - This is for unexpected user queries
;                     of the "Do you really want to ..." variety.  Initially SYNned to
;                     TERMINAL-IO.  It supersedes "QUERY-INPUT".
;   TRACE-OUTPUT    - Output produced by TRACE goes here.  Initially SYNned to ERROR-OUTPUT.


(DECLARE
(SPECIAL STANDARD-INPUT		;DEFAULT STREAM FOR INPUT
	 STANDARD-OUTPUT	;DEFAULT STREAM FOR OUTPUT
	 TERMINAL-IO		;STREAM GUARANTEED TO BE CONNECTED TO THE TERMINAL
	 ERROR-OUTPUT		;STREAM UNANTICIPATED MESSAGES GO TO (SEE ALSO TRACE-OUTPUT)
	 QUERY-IO		;STREAM UNANTICIPATED QUESTIONS SHOULD GO TO AND GET
							;ANSWERS FROM.
	 RUBOUT-HANDLER		;T IF CONTROL IS INSIDE THE RUBOUT HANDLER, TYI FROM BUFFER
))

;;; For purposes of the arguments to READ, a stream specifier is T or
;;; NIL or a stream.  A stream is an instance, an entity, a closure, a fef,
;;; or a symbol with an SI:IO-STREAM-P property.
;;; T means TERMINAL-IO and NIL means STANDARD-INPUT.
(DEFUN IO-STREAM-P (X)
  (SELECT (%DATA-TYPE X)
    (DTP-INSTANCE T)
    (DTP-ENTITY T)
    (DTP-CLOSURE T)
    (DTP-FEF-POINTER T)
    (DTP-SELECT-METHOD T)
    (DTP-SYMBOL (GET X 'IO-STREAM-P))
    (T NIL)))

;;; Given the 2 arguments to READ (or TYI or READCH or TYIPEEK or READLINE)
;;; in the form of a REST argument this returns the input stream and the eof option.
;;; Note that the first arg would rather be the stream than the eof option.
;;; This is set up for Maclisp compatibility.
;;; HOWEVER, if the second argument is NIL or unsupplied, the first is
;;; assumed to be a stream if that is plausible,
;;; which is not compatible with Maclisp but more winning.
;;; If the user didn't supply an eof-option, the second value returned will
;;; be the symbol NO-EOF-OPTION.
(DEFUN DECODE-READ-ARGS (ARG-LIST)
  (SELECTQ (LENGTH ARG-LIST)
    (0 (VALUES STANDARD-INPUT 'NO-EOF-OPTION))
    (1 (LET ((ARG1 (FIRST ARG-LIST)))
	 (IF (OR (EQ ARG1 NIL) (EQ ARG1 T) (IO-STREAM-P ARG1))
	     ;; The arg is a plausible stream.
	     (VALUES (COND ((EQ ARG1 NIL) STANDARD-INPUT)
			   ((EQ ARG1 T) TERMINAL-IO)
			   (T ARG1))
		     'NO-EOF-OPTION)
	     ;; It is not a stream and must be an EOF option.
	     (VALUES STANDARD-INPUT
		     ARG1))))
    (2 (LET ((ARG1 (FIRST ARG-LIST))
	     (ARG2 (SECOND ARG-LIST)))
	 (COND ((OR (EQ ARG1 NIL) (EQ ARG1 T) (IO-STREAM-P ARG1))
		(VALUES (COND ((EQ ARG1 NIL) STANDARD-INPUT)
			      ((EQ ARG1 T) TERMINAL-IO)
			      (T ARG1))
			ARG2))
	       ((OR (EQ ARG2 NIL) (EQ ARG2 T) (IO-STREAM-P ARG2))
		(VALUES (COND ((EQ ARG2 NIL) STANDARD-INPUT)
			      ((EQ ARG2 T) TERMINAL-IO)
			      (T ARG2))
			ARG1))
	       (T (VALUES ARG1 ARG2)))))
    (OTHERWISE
     (FERROR NIL "Too many arguments were given to one of the READ-like functions: ~S"
	     ARG-LIST))))

;;; Given the second argument to PRINT (and friends), return
;;; a stream, processing for Maclisp compatibility
(DEFUN DECODE-PRINT-ARG (X)
  (COND ((EQ X NIL) STANDARD-OUTPUT)
	((EQ X T) TERMINAL-IO)
	((IO-STREAM-P X) X)
	((AND (LISTP X) (OR (IO-STREAM-P (CAR X)) (EQ (CAR X) NIL) (EQ (CAR X) T)))
	 (FERROR NIL "Output to multiple streams ~S not yet supported." X))
	(T X))) ;Unrecognizable, hope funcalling it works.


(DEFUN MAKE-SYN-STREAM (STREAM-SYMBOL)
  ;; This has to work in the cold-load, where there is no FORMAT, STRING-APPEND, 
  ;; or even GENSYM.
  (LET ((NML (ARRAY-ACTIVE-LENGTH (GET-PNAME STREAM-SYMBOL))))
    (LET ((PNAME (MAKE-ARRAY (+ NML 11.) ':AREA P-N-STRING ':TYPE 'ART-STRING)))
      (COPY-ARRAY-CONTENTS (GET-PNAME STREAM-SYMBOL) PNAME)
      (COPY-ARRAY-PORTION "-SYN-STREAM" 0 11. PNAME NML (+ NML 11.))
      (LET ((PACKAGE (CAR (PACKAGE-CELL-LOCATION STREAM-SYMBOL)))) ;can't give as arg!
	(MULTIPLE-VALUE-BIND (SYM FLAG) (INTERN PNAME)
	  (AND FLAG (RETURN-ARRAY PNAME))
	  (%P-STORE-TAG-AND-POINTER (FUNCTION-CELL-LOCATION SYM)
				    DTP-EXTERNAL-VALUE-CELL-POINTER
				    (VALUE-CELL-LOCATION STREAM-SYMBOL))
	  (PUTPROP SYM T 'IO-STREAM-P)
	  SYM)))))

;This only works for output.
;If a value is needed it is always the value returned by the last stream.
(DEFUN MAKE-BROADCAST-STREAM (&REST STREAMS)
  (LET-CLOSED ((BROADCAST-STREAM-STREAMS (COPYLIST STREAMS))
	       (WHICH-OPERATIONS (LOOP WITH WO = (FUNCALL (CAR STREAMS) ':WHICH-OPERATIONS)
				       WITH COPYP = T
				       FOR STREAM IN (CDR STREAMS)
				       DO (LOOP WITH WO2 = (FUNCALL STREAM ':WHICH-OPERATIONS)
						FOR OP IN WO
						UNLESS (MEMQ OP WO2)
						  DO (IF COPYP (SETQ WO (COPYLIST WO)))
						     (SETQ COPYP NIL)
						     (SETQ WO (DELQ OP WO)))
				       FINALLY (RETURN WO))))
    (FUNCTION (LAMBDA (&REST ARGS)
		(IF (EQ (CAR ARGS) ':WHICH-OPERATIONS) WHICH-OPERATIONS
		    (DO ((L BROADCAST-STREAM-STREAMS (CDR L)))
			((NULL (CDR L))		;Last one gets to return multiple values
			 (APPLY (CAR L) ARGS))
		      (APPLY (CAR L) ARGS)))))))


(DEFUN STREAM-DEFAULT-HANDLER (FCTN OP ARG1 ARGS &AUX TEM)
  (SELECTQ OP
    (:LISTEN
     (COND ((SETQ TEM (FUNCALL FCTN ':TYI NIL))
	    (FUNCALL FCTN ':UNTYI TEM)
	    TEM)))
    ((:CLEAR-OUTPUT :CLEAR-INPUT :FORCE-OUTPUT :FINISH :CLOSE)
     NIL)
    (:FRESH-LINE
     (FUNCALL FCTN ':TYO #\CR))
    ((:STRING-OUT :LINE-OUT)
     (SETQ TEM (STRING ARG1))
     (DO ((LEN (COND ((SECOND ARGS))
		     (T (STRING-LENGTH TEM))))
	  (I (COND ((FIRST ARGS)) (T 0))
	     (1+ I)))
	 ((>= I LEN) NIL)
       (FUNCALL FCTN ':TYO (AR-1 TEM I)))
     (AND (EQ OP ':LINE-OUT)
	  (FUNCALL FCTN ':TYO #\CR)))
    (:LINE-IN
     (LET ((BUF (MAKE-ARRAY 100 ':TYPE ART-STRING
			    ':LEADER-LENGTH (IF (NUMBERP ARG1) ARG1 1))))
       (STORE-ARRAY-LEADER 0 BUF 0)		;Fill pointer
       (VALUES BUF
	       (DO ((TEM (FUNCALL FCTN ':TYI NIL) (FUNCALL FCTN ':TYI NIL)))
		   ((OR (NULL TEM) (= TEM #\CR))
		    (ADJUST-ARRAY-SIZE BUF (ARRAY-ACTIVE-LENGTH BUF))
		    (NULL TEM))
		 (ARRAY-PUSH-EXTEND BUF TEM)))))
    (:OPERATION-HANDLED-P (MEMQ ARG1 (FUNCALL FCTN ':WHICH-OPERATIONS)))
    (:SEND-IF-HANDLES
     (IF (MEMQ ARG1 (FUNCALL FCTN ':WHICH-OPERATIONS))
	 (LEXPR-FUNCALL FCTN ARG1 ARGS)))
    (OTHERWISE
     (FERROR NIL "The stream operation ~S is not supported by ~S"
	     OP FCTN))))