;;; -*- Mode: LISP; Package: CHAOS; BASE: 8 -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;; Very high-level CHAOSnet functions.
;; The NCP and low level functions in LMIO;CHSNCP

;; This does a full "ICP": it sends an RFC, waits for a reply or timeout,
;; and returns a string to get an error, or else the CONN to indicate that
;; the foreign host sent an OPN and we are connected.
;; The first argument gets parsed as an address.
(DEFUN CONNECT (ADDRESS CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
					       (TIMEOUT (* 10. 60.))
			      &AUX CONN REAL-ADDRESS)
    (COND ((NULL (SETQ REAL-ADDRESS (ADDRESS-PARSE ADDRESS)))
	   (FORMAT NIL "~S is not a known address." ADDRESS))
	  (T (ASSURE-ENABLED)
	     (SETQ CONN (OPEN-CONNECTION REAL-ADDRESS CONTACT-NAME WINDOW-SIZE))
	     (WAIT CONN 'RFC-SENT-STATE TIMEOUT)
	     (SELECTQ (STATE CONN)
	       (OPEN-STATE CONN)
	       (RFC-SENT-STATE (CLOSE CONN)
			       "Host not responding.")
	       (ANSWERED-STATE (CLOSE CONN)
			       "Received an ANS instead of an OPN.")
	       (CLS-RECEIVED-STATE (PROG1 (LET ((PKT (GET-NEXT-PKT CONN)))
					    (PROG1 (STRING-APPEND (PKT-STRING PKT))
						   (RETURN-PKT PKT)))
					  (CLOSE CONN)))
	       (OTHERWISE (PROG1 (FORMAT NIL "Bad state in CHAOS:CONNECT: ~A~@[, ~A~]"
					 (STATE CONN) 
					 (AND (READ-PKTS CONN) (PKT-STRING (READ-PKTS CONN))))
				 (REMOVE-CONN CONN)))))))

;; Takes anything anyone might use as a ChaosNet address, and tries to return
;; the corresponding host number.  If it fails, returns NIL.
(DEFUN ADDRESS-PARSE (ADDRESS &AUX HOST)
  (COND ((FIXP ADDRESS) ADDRESS)
	((AND (SETQ HOST (SI:PARSE-HOST ADDRESS T))
	      (FUNCALL HOST ':CHAOS-ADDRESS)))
	((AND (STRINGP ADDRESS)
	      (PARSE-NUMBER ADDRESS 0 NIL 8)))))

;; This is used to perform a "simple connection".  An RFC is sent to the
;; specified address, expecting an ANS.  Returns a string if there was an
;; error, in which case the string is an ASCII explanation.  Otherwise
;; returns the ANS.  When you are done perusing the ANS, RETURN-PKT the PKT.
(DEFUN SIMPLE (ADDRESS CONTACT-NAME &OPTIONAL (TIMEOUT (* 10. 60.))
			     &AUX CONN REAL-ADDRESS)
    (COND ((NULL (SETQ REAL-ADDRESS (ADDRESS-PARSE ADDRESS)))
	   (FORMAT NIL "~S is not a known address." ADDRESS))
	  (T (ASSURE-ENABLED)
	     (SETQ CONN (OPEN-CONNECTION REAL-ADDRESS CONTACT-NAME 5))
	     (WAIT CONN 'RFC-SENT-STATE TIMEOUT)
	     (SELECTQ (STATE CONN)
		      (RFC-SENT-STATE
		       (REMOVE-CONN CONN)
		       "Host not responding.")
		      (CLS-RECEIVED-STATE
		       (LET ((PKT (GET-NEXT-PKT CONN)))
			    (PROG1 (STRING-APPEND (PKT-STRING PKT))
				   (RETURN-PKT PKT))))
		      (OPEN-STATE
		       (CLOSE CONN "I expected an ANS, not an OPN.")
		       "Received an OPN instead of an ANS.")
		      (ANSWERED-STATE (PROG1 (GET-NEXT-PKT CONN)
                                             (CLOSE CONN)))
		      (OTHERWISE (PROG1 (FORMAT NIL "Bad state: ~A" (STATE CONN))
					(REMOVE-CONN CONN)))))))

;;; USER FUNCTIONS: Functions for the user side of a connection.

;; This is called as the first step in opening a connection.  Note the
;; CONNECT function, which is a higher-level frob (like NETWRK's ICP routine)
;; which you may want to use instead.
;;   The first arg is the address of the foreign host.  Next is the contact name.
;; Optionally following are the one-way flag and window size.
(DEFUN OPEN-CONNECTION (ADDRESS CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
		      &AUX PKT CONN)
    (CHECK-ARG ADDRESS (AND (NUMBERP ADDRESS) (>= ADDRESS 0) (<= ADDRESS 177777))
	       "an address")
    (CHECK-ARG CONTACT-NAME
               (AND (STRINGP CONTACT-NAME)
                    (<= (ARRAY-ACTIVE-LENGTH CONTACT-NAME) MAX-DATA-BYTES-PER-PKT))
               "a string")
    (CHECK-ARG WINDOW-SIZE NUMBERP "a number")
    (SETQ CONN (MAKE-CONNECTION))
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN WINDOW-SIZE MAXIMUM-WINDOW-SIZE)))
    (SETF (FOREIGN-ADDRESS CONN) ADDRESS)

    (SETQ PKT (ALLOCATE-PKT))
    (SETF (PKT-OPCODE PKT) RFC-OP)
    (SET-PKT-STRING PKT CONTACT-NAME)
    (SETF (PKT-LINK PKT) NIL)
    (SETF (PKT-SOURCE-ADDRESS PKT) MY-ADDRESS)
    (SETF (PKT-SOURCE-INDEX-NUM PKT) (LOCAL-INDEX-NUM CONN))
    (SETF (PKT-DEST-ADDRESS PKT) (FOREIGN-ADDRESS CONN))
    (SETF (PKT-DEST-INDEX-NUM PKT) (FOREIGN-INDEX-NUM CONN))
    (WITHOUT-INTERRUPTS
      (SETF (SEND-PKTS CONN) PKT)
      (SETF (SEND-PKTS-LAST CONN) PKT)
      (SETF (SEND-PKTS-LENGTH CONN) 1)
      (SETF (WINDOW-AVAILABLE CONN) 1)
      (SETF (TIME-LAST-RECEIVED CONN) (TIME))
      (SETF (STATE CONN) 'RFC-SENT-STATE)
      (SETQ RETRANSMISSION-NEEDED T))
    (TRANSMIT-NORMAL-PKT CONN PKT (PKT-NUM-SENT CONN))
 
    CONN)

;Open up a connection for use with foreign protocols
(DEFUN OPEN-FOREIGN-CONNECTION (FOREIGN-HOST FOREIGN-INDEX
				&OPTIONAL (PKT-ALLOCATION 10.) DISTINGUISHED-PORT
				&AUX CONN)
    (CHECK-ARG FOREIGN-HOST
	       (AND (NUMBERP FOREIGN-HOST) (>= FOREIGN-HOST 0) (<= FOREIGN-HOST 177777))
	       "an address")
    (SETQ CONN (MAKE-CONNECTION))
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN PKT-ALLOCATION MAXIMUM-WINDOW-SIZE)))
    (SETF (FOREIGN-ADDRESS CONN) FOREIGN-HOST)
    (SETF (FOREIGN-INDEX-NUM CONN) FOREIGN-INDEX)
    (SETF (STATE CONN) 'FOREIGN-STATE)
    (COND (DISTINGUISHED-PORT
	   (ASET NIL INDEX-CONN (LDB MAXIMUM-INDEX-LOG-2-MINUS-1 (LOCAL-INDEX-NUM CONN)))
	   (SETF (LOCAL-INDEX-NUM CONN) DISTINGUISHED-PORT)
	   (PUSH (CONS DISTINGUISHED-PORT CONN) DISTINGUISHED-PORT-CONN-TABLE)))
    CONN)

;;; SERVER FUNCTIONS: Functions used by the server side of a connection only.

(DEFUN LISTEN (CONTACT-NAME &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE) (WAIT-FOR-RFC T)
		     &AUX CONN)
    "Listen for an incoming RFC to CONTACT-NAME.  If WAIT-FOR-RFC is NIL, doesn't
     wait for the RFC to arrive, just sets up a queue.  Returns the CONN, ready
     to have ACCEPT, REJECT, ANSWER, or FORWARD done to it."
    (CHECK-ARG CONTACT-NAME STRINGP "a string")
    (CHECK-ARG WINDOW-SIZE NUMBERP "a number")
    (SETQ CONN (MAKE-CONNECTION))
    (SETF (LOCAL-WINDOW-SIZE CONN) (MAX 1 (MIN WINDOW-SIZE MAXIMUM-WINDOW-SIZE)))
    (PROG LISTEN ()
      (WITHOUT-INTERRUPTS			;First try to pick up a pending RFC
	(DO ((PKT PENDING-RFC-PKTS (PKT-LINK PKT))
	     (PREV NIL PKT))
	    ((NULL PKT))
	  (COND ((STRING-EQUAL (CONTACT-NAME-FROM-RFC PKT) CONTACT-NAME)
		 (COND ((NULL PREV) (SETQ PENDING-RFC-PKTS (PKT-LINK PKT)))
		       (T (SETF (PKT-LINK PREV) (PKT-LINK PKT))))
		 (RFC-MEETS-LSN CONN PKT)
		 (RETURN-FROM LISTEN CONN))))
	(SETF (STATE CONN) 'LISTENING-STATE)	;No RFC, let listen pend
	(PUSH (CONS CONTACT-NAME CONN) PENDING-LISTENS))
      (COND (WAIT-FOR-RFC
	     (PROCESS-WAIT "Net Listen"
			   #'(LAMBDA (CONN) (NEQ (STATE CONN) 'LISTENING-STATE))
			   CONN)
	     (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
		 (FERROR NIL "Listening connection ~S entered bad state ~S"
			     CONN (STATE CONN)))))
      (RETURN CONN)))

;; If you have done a LISTEN and the state has changed to RFC-RECEIVED, you
;; call one of the following four functions.

;; Send an OPN, and leave conn in OPEN-STATE.
;; Note that when this returns the other end has not yet acknowledged
;; the OPN, and the window size is still 0.  Transmitting the first packet
;; will wait.
(DEFUN ACCEPT (CONN &AUX PKT)
    (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
        (FERROR NIL "Attempt to accept ~S, which was in ~A, not RFC-RECEIVED-STATE"
		CONN (STATE CONN)))
    (SETQ PKT (READ-PKTS CONN))
    (COND (PKT					;In case the user has not read the RFC
	   (SETF (PKT-NUM-RECEIVED CONN) (PKT-NUM PKT))
	   (SETF (READ-PKTS CONN) (PKT-LINK PKT))
	   (OR (READ-PKTS CONN)
	       (SETF (READ-PKTS-LAST CONN) NIL))
	   (FREE-PKT PKT)))
    (SETQ PKT (ALLOCATE-PKT))
    (SETF (PKT-OPCODE PKT) OPN-OP)
    (SETF (PKT-NBYTES PKT) 4)
    (SETF (PKT-SECOND-DATA-WORD PKT) (LOCAL-WINDOW-SIZE CONN))
    (SETF (PKT-FIRST-DATA-WORD PKT) (PKT-NUM-READ CONN))
    (WITHOUT-INTERRUPTS
      (SETF (SEND-PKTS CONN) PKT)
      (SETF (PKT-LINK PKT) NIL)
      (SETF (SEND-PKTS-LAST CONN) PKT)
      (SETF (SEND-PKTS-LENGTH CONN) 1)
      (SETF (WINDOW-AVAILABLE CONN) 0)
      (SETQ RETRANSMISSION-NEEDED T)
      (SETF (TIME-LAST-RECEIVED CONN) (TIME))
      (SETF (STATE CONN) 'OPEN-STATE))  ;Set this -before- telling other end it's open!
    (TRANSMIT-NORMAL-PKT CONN PKT T)
    T)

;; Send a CLS and leave conn INACTIVE.
(DEFUN REJECT (CONN REASON &AUX PKT)
    (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
        (FERROR NIL "Attempt to reject ~S, which was in ~A, not RFC-RECEIVED-STATE"
		CONN (STATE CONN)))
    (SETQ PKT (ALLOCATE-PKT))
    (SETF (PKT-OPCODE PKT) CLS-OP)
    (SET-PKT-STRING PKT REASON)
    (TRANSMIT-NORMAL-PKT CONN PKT)
    (FREE-PKT PKT)
    (REMOVE-CONN CONN)
    T)

;; Send an ANS, and leave conn INACTIVE.
;; The caller passes in a PKT with data and NBYTES set up.
(DEFUN ANSWER (CONN PKT)
    (COND ((EQ (STATE CONN) 'RFC-RECEIVED-STATE)
	   (SETF (PKT-OPCODE PKT) ANS-OP)
	   (TRANSMIT-NORMAL-PKT CONN PKT)))
    (RETURN-PKT PKT)
    (REMOVE-CONN CONN)
    T)

(DEFUN ANSWER-STRING (CONN STRING)
  (LET ((PKT (GET-PKT)))
    (SETF (PKT-NBYTES PKT) (MIN (STRING-LENGTH STRING) MAX-DATA-BYTES-PER-PKT))
    (COPY-ARRAY-CONTENTS STRING (PKT-STRING PKT))
    (ANSWER CONN PKT)))

;; Minimal-consing simple-transaction answerer.
;; Returns T if succeeds, NIL if fails, although you probably don't care, since
;; a value of T does not assure that the ANS really reached the requestor.
(DEFUN FAST-ANSWER-STRING (CONTACT-NAME STRING)
  (PROG ((PREV NIL) RFC PKT PSTR)
    (WITHOUT-INTERRUPTS
      (SETQ RFC (DO PKT PENDING-RFC-PKTS (PKT-LINK PKT) (NULL PKT)
		    (AND (STRING-EQUAL (CONTACT-NAME-FROM-RFC PKT) CONTACT-NAME)
			 (RETURN PKT))
		    (SETQ PREV PKT)))
      (IF (NULL RFC) (RETURN NIL)
	  (IF (NULL PREV) (SETQ PENDING-RFC-PKTS (PKT-LINK RFC))
	      (SETF (PKT-LINK PREV) (PKT-LINK RFC)))))
    (SETQ PKT (ALLOCATE-INT-PKT))
    (SETF (PKT-NBYTES PKT) (MIN (STRING-LENGTH STRING) MAX-DATA-BYTES-PER-PKT))
    (SETQ PSTR	     ;Create indirect array to reference as a string
	  (MAKE-ARRAY NIL 'ART-STRING MAX-DATA-BYTES-PER-PKT PKT '(0) 16.))
    (COPY-ARRAY-CONTENTS STRING PSTR)
    (RETURN-ARRAY (PROG1 PSTR (SETQ PSTR NIL)))
    (SETF (PKT-SOURCE-ADDRESS PKT) MY-ADDRESS)
    (SETF (PKT-SOURCE-INDEX-NUM PKT) 0)
    (SETF (PKT-DEST-ADDRESS PKT) (PKT-SOURCE-ADDRESS RFC))
    (SETF (PKT-DEST-INDEX-NUM PKT) (PKT-SOURCE-INDEX-NUM RFC))
    (SETF (PKT-OPCODE PKT) ANS-OP)
    (SETF (PKT-NUM PKT) 0)
    (SETF (PKT-ACK-NUM PKT) 0)
    (TRANSMIT-INT-PKT PKT)
    (SETF (PKT-STATUS RFC) NIL)
    (FREE-PKT RFC)
    (RETURN T)))

;; Send a FWD, and leave conn INACTIVE.
;; The caller passes in a PKT with data and NBYTES set up, and the address of
;;  the HOST to whom the RFCer should forward.
(DEFUN FORWARD (CONN PKT HOST)
    (OR (EQ (STATE CONN) 'RFC-RECEIVED-STATE)
        (FERROR NIL "Attempt to forward ~S, which was in ~A, not RFC-RECEIVED-STATE"
		CONN (STATE CONN)))
    (SETF (PKT-OPCODE PKT) FWD-OP)
    (TRANSMIT-NORMAL-PKT CONN PKT 0 HOST)
    (RETURN-PKT PKT)
    (REMOVE-CONN CONN)
    T)

;; CONTROL OPERATIONS USED BY BOTH USERS AND SERVERS.

;; If CONN has received a close, free it up.
;; If CONN is inactive, do nothing.
;; If CONN is open, send a CLS containing the reason, leaving CONN inactive.
(DEFUN CLOSE (CONN &OPTIONAL (REASON "") &AUX PKT)
    (SELECTQ (STATE CONN)
       ((CLS-RECEIVED-STATE ANSWERED-STATE)
        (REMOVE-CONN CONN)
	NIL)
       (INACTIVE-STATE
	(SETQ CONN-LIST (DELQ CONN CONN-LIST))	;Just in case
	NIL)
       (OPEN-STATE
	(SETQ PKT (ALLOCATE-PKT))
	(SETF (PKT-OPCODE PKT) CLS-OP)
	(SET-PKT-STRING PKT REASON)
	(TRANSMIT-NORMAL-PKT CONN PKT)
	(FREE-PKT PKT)
	(REMOVE-CONN CONN)
	NIL)
       ((LOS-RECEIVED-STATE HOST-DOWN-STATE LISTENING-STATE RFC-SENT-STATE)
	(REMOVE-CONN CONN)
	NIL)
       (OTHERWISE
	(FERROR NIL "Attempt to close ~S, which was in ~S, not an acceptable state"
		CONN (STATE CONN)))))

(FSET 'CHAOS-CLOSE (FUNCTION CLOSE))

;; Wait until either:
;;  the state of CONN is not STATE  (return T), or
;;  over TIMEOUT 60ths of a second happen (return NIL).
(DEFUN WAIT (CONN STATE TIMEOUT &OPTIONAL (WHOSTATE "NET WAIT") &AUX START-TIME)
   (SETQ START-TIME (TIME))
   (DO () (NIL)
     (OR (EQ STATE (STATE CONN))
	 (RETURN T))
     (OR (< (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT)
	 (RETURN NIL))
     (PROCESS-WAIT WHOSTATE
		   (FUNCTION (LAMBDA (CONN STATE START-TIME TIMEOUT)
				     (OR (NEQ (STATE CONN) STATE)
					 ( (TIME-DIFFERENCE (TIME) START-TIME) TIMEOUT))))
		   CONN
		   STATE
		   START-TIME
		   TIMEOUT)))

;;; Streams
;;; This is included in all chaosnet streams, input or output
(DEFFLAVOR BASIC-STREAM
	((CONNECTION NIL))
	()
  (:INCLUDED-FLAVORS SI:STREAM)
  (:INITABLE-INSTANCE-VARIABLES CONNECTION))

(DEFMETHOD (BASIC-STREAM :CLOSE) (&OPTIONAL ABORT-P)
  (COND (CONNECTION				;Allowed to keep doing this
	 (CLOSE CONNECTION (IF ABORT-P "Aborted" ""))
	 (REMOVE-CONN (PROG1 CONNECTION (SETQ CONNECTION NIL))))))

;;; This is included in all chaosnet input streams, character and binary
(DEFFLAVOR INPUT-STREAM-MIXIN
	(INPUT-PACKET)
	()
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-INPUT-STREAM))

(DEFMETHOD (INPUT-STREAM-MIXIN :DISCARD-INPUT-BUFFER) (IGNORE)
  (RETURN-PKT INPUT-PACKET))

;;; This is included in all chaosnet output streams, character and binary
(DEFFLAVOR OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	()
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (OUTPUT-STREAM-MIXIN :DISCARD-OUTPUT-BUFFER) (IGNORE)
  (RETURN-PKT OUTPUT-PACKET))

;;; This is included in simple chaosnet input streams, but not file streams, where certain
;;; opcodes have special meaning.
(DEFFLAVOR BASIC-INPUT-STREAM
	((INPUT-PACKET NIL))
	(INPUT-STREAM-MIXIN BASIC-STREAM))

(DEFMETHOD (BASIC-INPUT-STREAM :GET-NEXT-INPUT-PKT) (NO-HANG-P &AUX OP)
  (COND ((AND INPUT-PACKET
	      (OR (= (SETQ OP (PKT-OPCODE INPUT-PACKET)) EOF-OP)
		  (= OP CLS-OP)))
	 NIL)
	((NULL (SETQ INPUT-PACKET (GET-NEXT-PKT CONNECTION NO-HANG-P))) NIL)
	((OR (= (SETQ OP (PKT-OPCODE INPUT-PACKET)) EOF-OP)
	     (= OP CLS-OP))
	 NIL)
	(( OP DAT-OP)
	 T)
	(T
	 (FERROR NIL "Unknown opcode ~O in packet ~S received from connection ~S"
		 OP INPUT-PACKET CONNECTION))))

(DEFMETHOD (BASIC-INPUT-STREAM :CLEAR-EOF) ()
  (COND ((AND INPUT-PACKET (= (PKT-OPCODE INPUT-PACKET) EOF-OP))
	 (RETURN-PKT INPUT-PACKET)
	 (SETQ INPUT-PACKET NIL))))

;;; This is included in simple chaosnet output streams, but not file streams, where a
;;; connection is maintained for longer.
(DEFFLAVOR BASIC-OUTPUT-STREAM
	()
	(OUTPUT-STREAM-MIXIN BASIC-STREAM)
  (:INCLUDED-FLAVORS SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (BASIC-OUTPUT-STREAM :EOF) ()
  (FUNCALL-SELF ':FORCE-OUTPUT)
  (SEND-PKT CONNECTION (GET-PKT) EOF-OP)
  (FINISH CONNECTION))

(DEFMETHOD (BASIC-OUTPUT-STREAM :FINISH) ()
  (FINISH CONNECTION))

(DEFMETHOD (BASIC-OUTPUT-STREAM :BEFORE :CLOSE) (&OPTIONAL ABORT-P)
  (AND CONNECTION (NOT ABORT-P)
       (EQ (STATE CONNECTION) 'OPEN-STATE)
       (FUNCALL-SELF ':EOF)))

(DEFFLAVOR CHARACTER-INPUT-STREAM-MIXIN
	(INPUT-PACKET)
	(INPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-INPUT-STREAM)
  ;;:GET-NEXT-INPUT-PKT returns T if INPUT-PACKET is a valid packet
  (:REQUIRED-METHODS :GET-NEXT-INPUT-PKT))

(DEFMETHOD (CHARACTER-INPUT-STREAM-MIXIN :NEXT-INPUT-BUFFER) (&OPTIONAL NO-HANG-P)
  (AND (FUNCALL-SELF ':GET-NEXT-INPUT-PKT NO-HANG-P)
       (VALUES (PKT-STRING INPUT-PACKET)
	       0
	       (PKT-NBYTES INPUT-PACKET))))

(DEFFLAVOR BINARY-INPUT-STREAM-MIXIN
	(INPUT-PACKET)
	(INPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-INPUT-STREAM)
  (:REQUIRED-METHODS :GET-NEXT-INPUT-PKT))

(DEFMETHOD (BINARY-INPUT-STREAM-MIXIN :NEXT-INPUT-BUFFER) (&OPTIONAL NO-HANG-P)
  (AND (FUNCALL-SELF ':GET-NEXT-INPUT-PKT NO-HANG-P)
       (VALUES INPUT-PACKET
	       FIRST-DATA-WORD-IN-PKT
	       (+ FIRST-DATA-WORD-IN-PKT (// (PKT-NBYTES INPUT-PACKET) 2)))))

(DEFFLAVOR CHARACTER-OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	(OUTPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (CHARACTER-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER) ()
  (SETQ OUTPUT-PACKET (GET-PKT))
  (VALUES (PKT-STRING OUTPUT-PACKET) 0 MAX-DATA-BYTES-PER-PKT))

(DEFMETHOD (CHARACTER-OUTPUT-STREAM-MIXIN :SEND-OUTPUT-BUFFER) SEND-CHARACTER-PKT)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (CHARACTER-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-CHARACTER-PKT (IGNORE IGNORE LENGTH)
  (SETF (PKT-NBYTES OUTPUT-PACKET) LENGTH)
  (SEND-PKT CONNECTION OUTPUT-PACKET)
  (SETQ OUTPUT-PACKET NIL)))

(DEFFLAVOR BINARY-OUTPUT-STREAM-MIXIN
	(OUTPUT-PACKET)
	(OUTPUT-STREAM-MIXIN)
  (:INCLUDED-FLAVORS BASIC-STREAM SI:BASIC-BUFFERED-OUTPUT-STREAM))

(DEFMETHOD (BINARY-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER) ()
  (SETQ OUTPUT-PACKET (GET-PKT))
  (VALUES OUTPUT-PACKET
	  FIRST-DATA-WORD-IN-PKT
	  (+ FIRST-DATA-WORD-IN-PKT (// MAX-DATA-BYTES-PER-PKT 2))))

(DEFMETHOD (BINARY-OUTPUT-STREAM-MIXIN :SEND-OUTPUT-BUFFER) SEND-BINARY-PKT)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BINARY-OUTPUT-STREAM-MIXIN)
(DEFUN SEND-BINARY-PKT (IGNORE IGNORE LENGTH)
  (SETF (PKT-NBYTES OUTPUT-PACKET) (* (- LENGTH FIRST-DATA-WORD-IN-PKT) 2))
  (SEND-PKT CONNECTION OUTPUT-PACKET 300)
  (SETQ OUTPUT-PACKET NIL)))

;;; Now the instantiatable flavors
(DEFFLAVOR INPUT-CHARACTER-STREAM
	()
	(CHARACTER-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM SI:BUFFERED-INPUT-CHARACTER-STREAM))

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

(DEFFLAVOR CHARACTER-STREAM
	()
	(CHARACTER-INPUT-STREAM-MIXIN CHARACTER-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-CHARACTER-STREAM))

;;; This is to make the EVAL server work
(DEFMETHOD (CHARACTER-STREAM :BEEP) (&OPTIONAL IGNORE)
  )

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

(DEFFLAVOR INPUT-BINARY-STREAM
	()
	(BINARY-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM
	 SI:BUFFERED-INPUT-STREAM))

(DEFFLAVOR OUTPUT-BINARY-STREAM
	()
	(BINARY-OUTPUT-STREAM-MIXIN BASIC-OUTPUT-STREAM
	 SI:BUFFERED-OUTPUT-STREAM))

(DEFFLAVOR BINARY-STREAM
	()
	(BINARY-INPUT-STREAM-MIXIN BINARY-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-STREAM))

(COMPILE-FLAVOR-METHODS INPUT-BINARY-STREAM OUTPUT-BINARY-STREAM BINARY-STREAM)

(DEFFLAVOR ASCII-TRANSLATING-INPUT-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-INPUT-STREAM-MIXIN
	 CHARACTER-INPUT-STREAM-MIXIN BASIC-INPUT-STREAM
	 SI:BUFFERED-TYI-INPUT-STREAM))

(DEFFLAVOR ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN
	 CHARACTER-OUTPUT-STREAM-MIXIN BASIC-OUTPUT-STREAM
	 SI:BUFFERED-TYO-OUTPUT-STREAM))

(DEFFLAVOR ASCII-TRANSLATING-CHARACTER-STREAM
	()
	(SI:ASCII-TRANSLATING-INPUT-STREAM-MIXIN SI:ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN
	 CHARACTER-INPUT-STREAM-MIXIN CHARACTER-OUTPUT-STREAM-MIXIN
	 BASIC-INPUT-STREAM BASIC-OUTPUT-STREAM SI:BUFFERED-TYI-TYO-STREAM))

(COMPILE-FLAVOR-METHODS ASCII-TRANSLATING-INPUT-CHARACTER-STREAM
			ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM
			ASCII-TRANSLATING-CHARACTER-STREAM)

(DEFUN OPEN-STREAM (HOST CONTACT-NAME &KEY &OPTIONAL (WINDOW-SIZE DEFAULT-WINDOW-SIZE)
						     (TIMEOUT (* 10. 60.))
						     (DIRECTION ':BIDIRECTIONAL)
						     (ERROR T)
						     (CHARACTERS T)
						     (ASCII-TRANSLATION NIL)
				      &AUX CONN)
  (SETQ CONN (CONNECT HOST CONTACT-NAME WINDOW-SIZE TIMEOUT))
  (IF (STRINGP CONN)
      (IF (NOT ERROR) CONN
	  (FERROR NIL "Cannot connect to ~A: ~A" HOST CONN))
      (MAKE-STREAM CONN ':DIRECTION DIRECTION ':CHARACTERS CHARACTERS
			':ASCII-TRANSLATION ASCII-TRANSLATION)))

(DEFUN MAKE-STREAM (CONNECTION &KEY &OPTIONAL (DIRECTION ':BIDIRECTIONAL)
					      (CHARACTERS T)
					      (ASCII-TRANSLATION NIL))
  (MAKE-INSTANCE (SELECTQ DIRECTION
		   (:INPUT
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-INPUT-CHARACTER-STREAM)
			  (CHARACTERS 'INPUT-CHARACTER-STREAM)
			  (T 'INPUT-BINARY-STREAM)))
		   (:OUTPUT
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-OUTPUT-CHARACTER-STREAM)
			  (CHARACTERS 'OUTPUT-CHARACTER-STREAM)
			  (T 'OUTPUT-BINARY-STREAM)))
		   (:BIDIRECTIONAL
		    (COND (ASCII-TRANSLATION 'ASCII-TRANSLATING-CHARACTER-STREAM)
			  (CHARACTERS 'CHARACTER-STREAM)
			  (T 'BINARY-STREAM))))
		 ':CONNECTION CONNECTION))

(DEFF STREAM 'MAKE-STREAM)

;; The HOSTAT function

;; Print the status of all the hosts and gateways, or specified ones
(DEFUN HOSTAT (&REST HOSTS &AUX CONNECTIONS PKT)
  (UNWIND-PROTECT (PROGN
     (ASSURE-ENABLED)
     ;; Get all hosts to do.  If HOSTS specified use them, else all chaos hosts,
     ;; including more that one address for the same host.
     (SETQ CONNECTIONS (IF HOSTS
			   (LOOP FOR HOST IN HOSTS
				 COLLECT (IF (NUMBERP HOST) (LIST NIL HOST NIL)
					     (SETQ HOST (SI:PARSE-HOST HOST))
					     (LIST HOST (FUNCALL HOST ':CHAOS-ADDRESS) NIL)))
			   (LOOP FOR ELEM IN SI:HOST-ALIST
				 AS ADDRESSES = (GET (LOCF (SI:HOST-ADDRESSES ELEM)) ':CHAOS)
				 WHEN ADDRESSES
				 NCONC (LOOP WITH HOST =
					     (OR (SI:HOST-INSTANCE ELEM)
						 (SI:PARSE-HOST (SI:HOST-NAME ELEM)))
					     FOR ADDRESS IN ADDRESSES
					     COLLECT (LIST HOST ADDRESS NIL)))))
     (LOOP FOR ELEM IN CONNECTIONS
	   DO (SETF (THIRD ELEM) (OPEN-CONNECTION (SECOND ELEM) "STATUS" 1)))
     ;; Now print heading
     (HOSTAT-HEADING)
     ;; Now wait until connections come up with an answer, when they do print it out
     ;Note host-name truncated to 27. characters to make more room for statistics
     (DO () ((NULL CONNECTIONS))
       (COND ((FUNCALL TERMINAL-IO ':TYI-NO-HANG)
	      (RETURN "QUIT")))
       (PROCESS-ALLOW-SCHEDULE)				;Take a few chaos net interrupts
       (DO LIST CONNECTIONS (CDR LIST) (NULL LIST)
	 (LET* ((ELEM (CAR LIST))
		(CONNECTION (THIRD ELEM)))
	   (SELECTQ (STATE CONNECTION)
	     (RFC-SENT-STATE
	      (COND (( (TIME-DIFFERENCE (TIME) (TIME-LAST-RECEIVED CONNECTION))
			600.)			;10-second timeout
		     (FORMAT T "~O~7T~@[~A   ~]host not responding~%"
			     (SECOND ELEM) (FIRST ELEM))
		     (REMOVE-CONN CONNECTION)
		     (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))))
	     (ANSWERED-STATE			;This is what we want
	      (SETQ PKT (GET-NEXT-PKT CONNECTION))
	      (HOSTAT-FORMAT-ANS (SECOND ELEM) PKT)
	      (RETURN-PKT PKT)
	      ;; Delete not only this connection, but every one to this same
	      ;; host, in case it has multiple addresses.  One copy of the
	      ;; answer is enough, but if it fails we would like to see all paths.
	      (COND (HOSTS
		     (REMOVE-CONN CONNECTION)
		     (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))
		    (T (LOOP WITH HOST = (FIRST ELEM)
			     FOR X IN CONNECTIONS
			     WHEN (EQ (CAR X) HOST)
			     DO (REMOVE-CONN (THIRD X))
			     (SETQ CONNECTIONS (DELQ X CONNECTIONS)))))
	      (SETQ LIST NIL))
	     (CLS-RECEIVED-STATE
	      (SETQ PKT (GET-NEXT-PKT CONNECTION))
	      (FORMAT T "~O~7T~@[~A   ~]returned a CLS:~A~%"
		      (SECOND ELEM) (FIRST ELEM) (PKT-STRING PKT))
	      (RETURN-PKT PKT)
	      (CLOSE CONNECTION)
	      (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))
	     (OPEN-STATE
	      (FORMAT T "~O~7T~@[~A   ~]returned an OPN~%"
		      (SECOND ELEM) (FIRST ELEM) )
	      (CLOSE CONNECTION "I expected an ANS, not an OPN.")
	      (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))
	     (LOS-RECEIVED-STATE
	      (SETQ PKT (READ-PKTS-LAST CONNECTION))
	      (FORMAT T "~O~7T~@[~A   ~]returned a LOS:~A~%"
		      (SECOND ELEM) (FIRST ELEM) (PKT-STRING PKT))
	      (CLOSE CONNECTION)
	      (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))
	     (OTHERWISE
	      (FORMAT T "~O~7T~@[~A   ~]connection entered bad state:~A~%"
		      (SECOND ELEM) (FIRST ELEM) (STATE CONNECTION))
	      (CLOSE CONNECTION)
	      (SETQ CONNECTIONS (DELQ ELEM CONNECTIONS)))))))
   ;; Unwind-protect cleanup
   (DO L CONNECTIONS (CDR L) (NULL L)	;Flush any connections that remain
       (REMOVE-CONN (THIRD (CAR L)))))))

(DEFUN HOSTAT-HEADING (&OPTIONAL (STREAM T))
  (FORMAT STREAM "~%~7A~25A" "Site" "Name//Status")
  (DO ((HEADS '("Subnet" "#-in" "#-out" "abort" "lost" "crc" "ram" "bitc" "other")
	      (CDR HEADS))
       (WIDTHS '(6 9 9 8 8 8 4 5 6) (CDR WIDTHS)))
      ((NULL HEADS) (TERPRI STREAM))
    (FORMAT STREAM "~V@A" (CAR WIDTHS) (CAR HEADS))))

(DEFUN HOSTAT-FORMAT-ANS (HOST PKT &OPTIONAL (STREAM T)
			  &AUX (NBYTES (PKT-NBYTES PKT)))
  (FORMAT STREAM "~7@<~O ~>~27A"		;Print host number and name as returned
	  HOST
	  (NSUBSTRING (PKT-STRING PKT) 0
		      (MIN NBYTES 27. (OR (STRING-SEARCH-CHAR 0 (PKT-STRING PKT) 0 32.)
					  ;; This line is temporary! *******
					  (STRING-SEARCH-CHAR 200 (PKT-STRING PKT) 0 32.)
					  32.))))
  (HOSTAT-FORMAT-ANS-1 PKT 34. '(4 9 9 8 8 8 4 5 6) STREAM))

(DEFUN HOSTAT-FORMAT-ANS-1 (PKT START-COLUMN COLUMN-WIDTHS STREAM
			    &AUX (NBYTES (PKT-NBYTES PKT)))
  (DO ((I 24. (+ I 2 CT))		;Now display subnet meters
       (FIRST-LINE T NIL)
       (ID) (CT)
       (MAXI (+ 8 (// NBYTES 2))))
      ((>= I MAXI) (AND FIRST-LINE (TERPRI)))
    (SETQ ID (AREF PKT I) CT (AREF PKT (1+ I)))	;Block header
    (OR FIRST-LINE (FORMAT T "~VA" START-COLUMN ""))
    (COND ((< ID 400)				;Subnet info (old 16-bit format)
	   (FORMAT STREAM "~VO" (CAR COLUMN-WIDTHS) ID)
	   (DO ((J (+ I 2) (1+ J))		;Now print those meters that are present
		(L (CDR COLUMN-WIDTHS) (CDR L))
		(N (MIN CT 8) (1- N)))
	       ((ZEROP N))
	     (FORMAT STREAM "~VD" (CAR L) (AREF PKT J))))
	  ((< ID 1000)				;Subnet info
	   (FORMAT STREAM "~VO" (CAR COLUMN-WIDTHS) (- ID 400))
	   (DO ((J (+ I 2) (+ J 2))		;Now print those meters that are present
		(L (CDR COLUMN-WIDTHS) (CDR L))
		(N (MIN (// CT 2) 8) (1- N)))
	       ((ZEROP N))
	     (FORMAT STREAM "~VD" (CAR L) (DPB (AREF PKT (1+ J)) 2020 (AREF PKT J)))))
	  (T					;I don't know about this
	   (FORMAT STREAM "~O unknown info block ID" ID)))
    (TERPRI STREAM))) 

;; Random server and user routines

;; The infamous LIMERICK getter
(DEFUN LIMERICK (&OPTIONAL (ARGS ""))
  (AND (NUMBERP ARGS) (SETQ ARGS (FORMAT NIL "~D" ARGS)))
  (FORMAT T "~2%")
  (WITH-OPEN-STREAM (STREAM (OPEN-STREAM "MC" (STRING-APPEND "LIMERICK " ARGS)
					 ':DIRECTION ':INPUT))
    (STREAM-COPY-UNTIL-EOF STREAM STANDARD-OUTPUT)))

;;; This function sets up so that all requests for the service indicated
;;; by the contact name given will be forwarded to the indicated host
(DEFUN FORWARD-ALL (CONTACT-NAME HOST)
    (SETQ HOST (ADDRESS-PARSE HOST))
    (PUSH (CONS CONTACT-NAME
		`(PROG (CONN)
		   (SETQ CONN (LISTEN ,CONTACT-NAME))
		   (FORWARD CONN (GET-NEXT-PKT CONN) ,HOST)))
	  SERVER-ALIST)
    NIL)

;;; This isn't DEFINE-SITE-HOST-LIST because this file is loaded too early, as is the SITE
;;; file itself.
(DEFINE-SITE-VARIABLE TIME-SERVER-HOSTS :CHAOS-TIME-SERVER-HOSTS)

(SETQ TIME:*NETWORK-TIME-FUNCTION* 'HOST-TIME)

;; Returns universal time from host over the net, as a 32-bit number
;; or if it can't get the time, returns a string which is the reason why not.
(DEFUN HOST-TIME (&OPTIONAL (HOST TIME-SERVER-HOSTS))
  (COND ((NULL HOST) "No host specified.")
	((LISTP HOST)
	 (DO ((HOSTS HOST (CDR HOSTS))
	      (TIME "No hosts."))
	     ((NULL HOSTS) TIME)
	   ;; Don't ask self for time.
	   (COND ((NEQ (ADDRESS-PARSE (CAR HOSTS)) MY-ADDRESS)
		  (SETQ TIME (HOST-TIME (CAR HOSTS)))
		  (AND (NUMBERP TIME) (RETURN TIME))))))
	(T (LET ((PKT (SIMPLE HOST "TIME" #.(* 10. 60.))))
			;10 second timeout for our paging and server's response delay
	     (IF (STRINGP PKT) PKT
		 (LET ((L16 (AREF PKT 10))
		       (U16 (AREF PKT 11)))
		   (RETURN-PKT PKT)
		   (DPB U16 2020 L16)))))))

(DEFUN PRINT-HOST-TIMES (&OPTIONAL (HOSTS TIME-SERVER-HOSTS) &AUX TIME)
  (DO ((H HOSTS (CDR H)) (COUNT 0) (SUM 0))
      ((NULL H)
       (COND ((NOT (ZEROP COUNT))
	      (FORMAT T "~% Average: ")
	      (TIME:PRINT-UNIVERSAL-TIME (// SUM COUNT)))))
    (FORMAT T "~% ~A:~10T" (CAR H))
    (IF (STRINGP (SETQ TIME (HOST-TIME (CAR H))))
	(FUNCALL STANDARD-OUTPUT ':STRING-OUT TIME)
	(TIME:PRINT-UNIVERSAL-TIME TIME)
	(SETQ SUM (+ SUM TIME) COUNT (1+ COUNT)))))

;;; Network message facility

(DEFVAR SEND-BELLCOUNT 2)	;How many times to ring the bell when a message arrives
(DEFVAR SAVED-SENDS		;Extensible string containing all messages.
	(MAKE-ARRAY NIL 'ART-STRING 100 NIL '(0)))

;USER
(DEFMACRO QSEND (DESTINATION &OPTIONAL MESSAGE)
  `(SEND-MSG ',DESTINATION ',MESSAGE))

(DEFUN SHOUT (&AUX MSG-TEXT HOST PERSON)       ;SHOUT to all Lisp Machines.  
  (FS:FORCE-USER-TO-LOGIN)
  (FORMAT T "~%Message: (terminate with ~:@C)~%" #\END)
  (SETQ MSG-TEXT (STRING-APPEND "Everybody: " (CHAOS:SEND-MSG-GET-MESSAGE))
	PERSON "anyone")
  (DO ((MACHINE SI:MACHINE-LOCATION-ALIST (CDR MACHINE)))
      ((NULL MACHINE))
    (SETQ HOST (CAAR MACHINE))
    (WITH-OPEN-STREAM (STREAM (CHAOS:OPEN-STREAM HOST (STRING-APPEND "SEND " PERSON)
						 ':ERROR NIL ':DIRECTION ':OUTPUT))
		      (COND ((NOT (STRINGP STREAM))
			     (FORMAT STREAM "~A@~A ~\DATIME\~%" USER-ID SI:LOCAL-HOST)
			     (FUNCALL STREAM ':STRING-OUT MSG-TEXT)
			     (FUNCALL STREAM ':CLOSE))))))


(DEFUN PRINT-SENDS (&OPTIONAL (STREAM STANDARD-OUTPUT))
  (PRINC SAVED-SENDS STREAM)
  T)

(DEFVAR POP-UP-QSEND-WINDOW)
(DEFVAR POP-UP-QSEND-LOCK NIL)	;One guy typing at a time

(DEFUN POP-UP-RECEIVE-SEND-MSG (&AUX CONN RECIPIENT RFC SENDER VISP TEM
				     (START (ARRAY-ACTIVE-LENGTH SAVED-SENDS)))
  (UNWIND-PROTECT
    (PROGN
      (SETQ CONN (LISTEN "SEND"))
      (SETQ RFC (PKT-STRING (READ-PKTS CONN)))
      (SETQ RECIPIENT
	    (COND ((SETQ TEM (STRING-SEARCH " " RFC))
		   (NSUBSTRING RFC (1+ TEM)))
		  (T "anyone")))
      (ACCEPT CONN)
      (WITH-OUTPUT-TO-STRING (SSTREAM SAVED-SENDS)
	(FORMAT SSTREAM "~%[Message from ~A for ~A]~%"
		(HOST-DATA (FOREIGN-ADDRESS CONN)) RECIPIENT)
	(WITH-OPEN-STREAM (CSTREAM (MAKE-STREAM CONN ':DIRECTION ':INPUT))
	  (SETQ SENDER (FUNCALL CSTREAM ':LINE-IN))
	  (FUNCALL SSTREAM ':LINE-OUT SENDER)
	  (COND ((SETQ TEM (STRING-SEARCH-CHAR #/@ SENDER))
		 (SETQ SENDER (NSUBSTRING SENDER 0 TEM)))
		((SETQ TEM (STRING-SEARCH "from " SENDER))
		 (SETQ SENDER (NSUBSTRING SENDER (+ TEM 5)
					  (STRING-SEARCH-SET '(#/] #\SP) SENDER (+ TEM 5)))))
		(T
		 (SETQ SENDER "")))
	  (SETQ SENDER (STRING-APPEND SENDER #/@
				      (HOST-SHORT-NAME (FOREIGN-ADDRESS CONN))))
	  (STREAM-COPY-UNTIL-EOF CSTREAM SSTREAM))
	(FORMAT SSTREAM "~2%"))
      (OR (BOUNDP 'POP-UP-QSEND-WINDOW)
	  (SETQ POP-UP-QSEND-WINDOW TV:(MAKE-WINDOW 'POP-UP-TEXT-WINDOW
						    ':NAME "QSend"
						    ':HEIGHT 400	;About 17 lines
						    ':SAVE-BITS T)))
      ;; Ring the bell before the real-time delay of popping it up.
      ;; Also ring it before locking so he knows another message came in.
      (DOTIMES (I SEND-BELLCOUNT) (FUNCALL POP-UP-QSEND-WINDOW ':BEEP))
      ;; This waits until any other message is done
      ;; then seizes the lock.  The effect is to handle only one message at a time.
      (DO ((FIRST-TIME T NIL))
	  ((%STORE-CONDITIONAL (VALUE-CELL-LOCATION 'POP-UP-QSEND-LOCK)
			       NIL CURRENT-PROCESS))
	;; If messages coming in with thing hung up, let user know
	(AND FIRST-TIME (NEQ (FUNCALL POP-UP-QSEND-WINDOW ':STATUS) ':SELECTED)
	     (TV:NOTIFY NIL "Message from ~A waiting for QSend window" SENDER))
	(PROCESS-WAIT "Lock" #'(LAMBDA (X) (NULL (CDR X)))
		      (VALUE-CELL-LOCATION 'POP-UP-QSEND-LOCK)))
      (SETQ VISP (TV:SHEET-EXPOSED-P POP-UP-QSEND-WINDOW))
      (FUNCALL POP-UP-QSEND-WINDOW ':MOUSE-SELECT)
      ;; If the window was not already visible, erase it.
      (COND ((NOT VISP)
	     (SETQ START (1+ START))	;Skip the first CR
	     (FUNCALL POP-UP-QSEND-WINDOW ':CLEAR-SCREEN)))
      (FUNCALL POP-UP-QSEND-WINDOW ':STRING-OUT SAVED-SENDS START)
      (LET ((TERMINAL-IO POP-UP-QSEND-WINDOW))
	(FUNCALL POP-UP-QSEND-WINDOW ':CLEAR-INPUT)
	(COND ((Y-OR-N-P "Reply? " POP-UP-QSEND-WINDOW)
	       (FORMAT POP-UP-QSEND-WINDOW "~&To: ~A" SENDER)
	       (SEND-MSG SENDER)))))
    (COND ((EQ POP-UP-QSEND-LOCK CURRENT-PROCESS)
	   (SETQ POP-UP-QSEND-LOCK NIL)
	   (PROCESS-ALLOW-SCHEDULE)
	   (COND ((NULL POP-UP-QSEND-LOCK)
		  (FUNCALL POP-UP-QSEND-WINDOW ':DESELECT T)
		  (FUNCALL POP-UP-QSEND-WINDOW ':DEACTIVATE)))))))

(ADD-INITIALIZATION "SEND"
                    '(PROCESS-RUN-TEMPORARY-FUNCTION "SEND Server" #'POP-UP-RECEIVE-SEND-MSG)
                    NIL
                    'SERVER-ALIST)

(DEFUN SEND-MSG (DESTINATION &OPTIONAL MSG &AUX HOST PERSON)
  (COND ((AND (NOT (NUMBERP DESTINATION))
	      (SETQ HOST (DO ((@-POS (STRING-SEARCH "@" DESTINATION)
				     (STRING-SEARCH "@" DESTINATION (1+ @-POS)))
			      (LAST-@-POS NIL @-POS))
			     ((NULL @-POS) LAST-@-POS))))
         (SETQ PERSON (STRING-UPCASE (NSUBSTRING DESTINATION 0 HOST))
               HOST (NSUBSTRING DESTINATION (1+ HOST) (STRING-LENGTH DESTINATION))))
        (T (SETQ PERSON "anyone"  HOST DESTINATION)))
  (FS:FORCE-USER-TO-LOGIN)
  (COND ((NULL MSG)
	 (FORMAT T "~%Message: (terminate with ~:@C)~%" #\END)
	 (SETQ MSG (SEND-MSG-GET-MESSAGE))))
  (WITH-OPEN-STREAM (STREAM (OPEN-STREAM HOST (STRING-APPEND "SEND " PERSON)
					 ':ERROR NIL ':DIRECTION ':OUTPUT))
    (COND ((NOT (STRINGP STREAM))
	   (FORMAT STREAM "~A@~A ~\DATIME\~%" USER-ID SI:LOCAL-HOST)
           (FUNCALL STREAM ':STRING-OUT MSG)
	   (FUNCALL STREAM ':CLOSE))
	  ((FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS "~A  Mail instead? " STREAM)
	   (ZWEI:SEND-MESSAGE-STRING PERSON (STRING-APPEND "[This was a failing QSEND]
"
							   MSG))))))

(DEFUN SEND-MSG-GET-MESSAGE (&OPTIONAL (STREAM STANDARD-INPUT))
  (IF (AND (NOT RUBOUT-HANDLER)
	   (MEMQ ':RUBOUT-HANDLER (FUNCALL STREAM ':WHICH-OPERATIONS)))
      (FUNCALL STREAM ':RUBOUT-HANDLER
	       '((:PASS-THROUGH #\END #/c #/C)) #'SEND-MSG-GET-MESSAGE STREAM)
      (DO ((MSG (MAKE-ARRAY NIL 'ART-STRING 100 NIL '(0)))
	   (CH))
	  (NIL)
	(SETQ CH (FUNCALL STREAM ':TYI))
	(AND (MEMQ CH '(#\END #/c #/C NIL))
	     (RETURN MSG))
	(ARRAY-PUSH-EXTEND MSG CH))))

;;; Finger server and NAME user end

(ADD-INITIALIZATION "FINGER" '(GIVE-FINGER) NIL 'SERVER-ALIST)

(DEFVAR GIVE-FINGER-SAVED-STRING NIL)
(DEFVAR GIVE-FINGER-SAVED-IDLE NIL)
(DEFVAR GIVE-FINGER-SAVED-USER-ID NIL)

;This runs in the background task now.
(DEFUN GIVE-FINGER (&AUX IDLE)
  (SETQ IDLE (// (TIME-DIFFERENCE (TIME) TV:KBD-LAST-ACTIVITY-TIME) 3600.)) ;Minutes
  ;; Making the string is expensive in terms of paging, and it is almost
  ;; always the same as last time.  So try to use a saved string.
  (COND ((OR (NEQ GIVE-FINGER-SAVED-IDLE IDLE)
	     (NEQ GIVE-FINGER-SAVED-USER-ID USER-ID))
	 (SETQ GIVE-FINGER-SAVED-IDLE IDLE
	       GIVE-FINGER-SAVED-USER-ID USER-ID
	       GIVE-FINGER-SAVED-STRING
	          (FORMAT NIL "~A~%~A~%~:[~3*~;~:[~D:~2,48D~;~*~D~]~]~%~A~%~C~%"
                          USER-ID
                          SI:LOCAL-FINGER-LOCATION
                          (NOT (ZEROP IDLE))
                          (ZEROP (// IDLE 60.))
                          (// IDLE 60.)
                          (\ IDLE 60.)
			  FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
			  FS:USER-GROUP-AFFILIATION))))
  (FAST-ANSWER-STRING "FINGER" GIVE-FINGER-SAVED-STRING))

;; This can't run in the background process, since it uses a full byte-stream
;; connection, which requires retransmission, which is done by the background process.
(ADD-INITIALIZATION "NAME" '(PROCESS-RUN-TEMPORARY-FUNCTION "NAME Server" 'GIVE-NAME)
		    NIL 'SERVER-ALIST)

(DEFUN GIVE-NAME (&AUX CONN IDLE)
  (SETQ CONN (LISTEN "NAME"))
  (SETQ IDLE (// (TIME-DIFFERENCE (TIME) TV:KBD-LAST-ACTIVITY-TIME) 3600.)) ;Minutes
  (FORMAT-AND-EOF CONN
		  "~6A ~C ~22A ~6A ~:[    ~3*~;~:[~D:~2,48D~;  ~*~D~]~]     ~A"
		  USER-ID
		  FS:USER-GROUP-AFFILIATION
		  FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
		  SI:LOCAL-HOST-NAME
		  (NOT (ZEROP IDLE))
		  (ZEROP (// IDLE 60.))
		  (// IDLE 60.)
		  (\ IDLE 60.)
		  SI:LOCAL-FINGER-LOCATION))

;; Send the specied format string, and eof and close
(DEFUN FORMAT-AND-EOF (CONN &REST FORMAT-ARGS)
  (ACCEPT CONN)
  (WITH-OPEN-STREAM (STREAM (STREAM CONN))
    (LEXPR-FUNCALL #'FORMAT STREAM FORMAT-ARGS)))

(DEFUN FINGER (&OPTIONAL SPEC (STREAM STANDARD-OUTPUT) &AUX HOST INDEX GATEWAY-P)
  (COND ((NULL SPEC)
	 (SETQ HOST SI:ASSOCIATED-MACHINE))
	((SETQ INDEX (STRING-SEARCH-CHAR #/@ SPEC))
	 (SETQ HOST (SUBSTRING SPEC (1+ INDEX)))
	 (IF (LET ((HOST1 (SI:PARSE-HOST HOST T)))
	       ;;Go directly if host is on ChaosNet
	       (AND HOST1 (FUNCALL HOST1 ':NETWORK-TYPEP ':CHAOS)))
	     (SETQ SPEC (SUBSTRING SPEC 0 INDEX))
	     (SETQ HOST NIL GATEWAY-P T)))	;Else use default host
	(T (SETQ HOST SI:ASSOCIATED-MACHINE)))	;No explicit host, use default
  (AND HOST (SETQ HOST (ADDRESS-PARSE HOST)))
  (SETQ SPEC (IF SPEC (STRING-APPEND "NAME" #\SP SPEC) "NAME"))
  (DO ((DEFAULTS (SI:GET-SITE-OPTION ':ARPA-GATEWAYS) (CDR DEFAULTS)))
      ((AND (NULL DEFAULTS) (NULL HOST))
       "No host available")
    (WITH-OPEN-STREAM (CSTREAM (OPEN-STREAM (OR HOST (CAR DEFAULTS)) SPEC
					   ':DIRECTION ':INPUT ':ERROR NIL
					   ;;If going through an ITS gateway, character set is
					   ;;ascii and has to be translated.
					   ':ASCII-TRANSLATION GATEWAY-P))
      (IF (STRINGP CSTREAM)			;If attempt to connect failed
	  (AND HOST				;If explicit host, return reason for failure
	       (RETURN CSTREAM))		; else try next default
	  (FORMAT STREAM "~&")
	  (STREAM-COPY-UNTIL-EOF CSTREAM STREAM)
	  (RETURN NIL)))))

(DEFSUBST FCL-CONN1 (ELEM) (CDADR ELEM))	; First CHAOS CONN in an element
(DEFUN FINGER-ALL-LMS (STREAM &OPTIONAL PRINT-FREE RETURN-FREE &AUX CONNS FREE)
  (DOLIST (HOST SI:MACHINE-LOCATION-ALIST)
    (SETQ HOST (SI:PARSE-HOST (CAR HOST)))
    (PUSH (LIST HOST (OPEN-CONNECTION (FUNCALL HOST ':CHAOS-ADDRESS) "FINGER")) CONNS))
  (DO ((OLD-TIME (TIME)))
      (NIL)
    (DOLIST (CONN CONNS)
      (LET ((STATE (STATE (SECOND CONN))))
	(COND ((NEQ STATE 'RFC-SENT-STATE)	;Still waiting
	       (AND (EQ STATE 'ANSWERED-STATE)	;Got something meaningful
		    (LET ((PKT (GET-NEXT-PKT (SECOND CONN))))
		      (LET ((STR (PKT-STRING PKT))
			    (HOST-NAME (DO ((L (FUNCALL (FIRST CONN) ':HOST-NAMES) (CDR L))
					    (WINNER NIL))
					   ((NULL L) WINNER)
					 (AND (STRING-EQUAL "CADR-" (CAR L) 0 0 5 5)
					      (RETURN (CAR L)))
					 (SETQ WINNER (CAR L))))
			    IDX)
			(COND (( (AREF STR 0) #\CR)	;Logged in
			       (FORMAT STREAM
				 "~&~6A ~4G~C ~3G~22A ~5G~7A ~2G~4@A    ~1G~A~%"
				 (NSUBSTRING STR 0
					     (SETQ IDX (STRING-SEARCH-CHAR #\CR STR)))
				 (NSUBSTRING STR (SETQ IDX (1+ IDX))
					     (SETQ IDX (STRING-SEARCH-CHAR #\CR STR IDX)))
				 (NSUBSTRING STR (SETQ IDX (1+ IDX))
					     (SETQ IDX (STRING-SEARCH-CHAR #\CR STR IDX)))
				 (NSUBSTRING STR (SETQ IDX (1+ IDX))
					     (SETQ IDX (STRING-SEARCH-CHAR #\CR STR IDX)))
				 (AREF STR (1+ IDX))
				 HOST-NAME))
			      ((OR PRINT-FREE RETURN-FREE)
			       (PUSH (SUBSTRING STR 1 (STRING-SEARCH-SET '(#\SP #\CR) STR 1))
				     FREE)
			       (PUSH HOST-NAME FREE))))
		      (RETURN-PKT PKT)))
	       (SETQ CONNS (DELQ CONN CONNS))
	       (CLOSE (SECOND CONN))
	       (REMOVE-CONN (SECOND CONN))))))
    (OR CONNS (RETURN NIL))			;Done with all of them
    (AND (> (TIME-DIFFERENCE (TIME) OLD-TIME) 240.)	;Allow 5 secs for this all
	 (RETURN NIL))
    (PROCESS-WAIT "Finger"
		  #'(LAMBDA (OLD-TIME CONNS)
		      (OR (> (TIME-DIFFERENCE (TIME) OLD-TIME) 240.)
			  (DO ((CONNS CONNS (CDR CONNS)))
			      ((NULL CONNS) NIL)
			    (OR (EQ (STATE (FCL-CONN1 (CAR CONNS))) 'RFC-SENT-STATE)
				(RETURN T)))))
		  OLD-TIME CONNS))
  ;; Flush all outstanding connections
  (DOLIST (ELEM CONNS)
    (REMOVE-CONN (FCL-CONN1 ELEM)))
;;  HOST-LIST
  )

;; missing from original tape :-(
;;
;;; Dummy mail server, rejects all incoming mail
;;; It really should be more clever, and notify the user of something...
(DEFUN DUMMY-MAIL-SERVER (&AUX CONN STREAM RCPT)
  (SETQ CONN (LISTEN "MAIL"))
  (ACCEPT CONN)
  (SETQ STREAM (STREAM CONN))
  (*CATCH 'DONE
    (CONDITION-BIND (((READ-ON-CLOSED-CONNECTION LOS-RECEIVED-STATE HOST-DOWN)
		      #'(LAMBDA (&REST IGNORE) (*THROW 'DONE NIL))))
      (DO () (NIL)				;Read the rcpts
	(SETQ RCPT (FUNCALL STREAM ':LINE-IN NIL))
	(AND (ZEROP (STRING-LENGTH RCPT))	;Blank line = start text
	     (RETURN))
	(FUNCALL STREAM ':LINE-OUT
		 "-Lisp Machines do not accept mail, maybe you want the :LMSEND command."))))
  (CLOSE CONN "all rcpts read"))

(ADD-INITIALIZATION "MAIL" '(PROCESS-RUN-TEMPORARY-FUNCTION "MAIL Server" 'DUMMY-MAIL-SERVER)
		    NIL 'SERVER-ALIST)

;;; Remote disk facilities.

(ADD-INITIALIZATION "REMOTE-DISK"
		    '(PROCESS-RUN-TEMPORARY-FUNCTION "REMOTE-DISK Server" 'REMOTE-DISK-SERVER)
		    NIL 'SERVER-ALIST)

(DEFUN REMOTE-DISK-SERVER (&AUX CONN STREAM LINE CMD CMDX UNIT BLOCK N-BLOCKS RQB
				BLOCK-PKT-1 BLOCK-PKT-2 BLOCK-PKT-3)
    (SETQ CONN (LISTEN "REMOTE-DISK" 25.))
    (ACCEPT CONN)
    (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':ADD-SERVER CONN "REMOTE-DISK")
    (SETQ STREAM (STREAM CONN))
    (DO () (NIL)
      (PROCESS-WAIT "NETI" #'(LAMBDA (CONN) (OR (READ-PKTS CONN)
						(NEQ (STATE CONN) 'OPEN-STATE)))
			   CONN)
      (AND (NEQ (STATE CONN) 'OPEN-STATE) (RETURN NIL))
      (SETQ LINE (READLINE STREAM)		;Get a command line
	    CMDX (STRING-SEARCH-CHAR #\SP LINE)
	    CMD (SUBSTRING LINE 0 CMDX))
      (COND ((OR (STRING-EQUAL CMD "READ") (STRING-EQUAL CMD "WRITE"))
	     (LET ((IBASE 10.)
		   (SI:*IOLST LINE)
		   (SI:*IOCH CMDX))
	       (SETQ UNIT (READ #'SI:READ-FROM-STRING-STREAM)
		     BLOCK (READ #'SI:READ-FROM-STRING-STREAM)
		     N-BLOCKS (READ #'SI:READ-FROM-STRING-STREAM)
		     RQB NIL))
	     (UNWIND-PROTECT
	       (PROGN (SETQ RQB (GET-DISK-RQB N-BLOCKS)
			    BLOCK-PKT-1 (GET-DISK-STRING RQB 0 484. T)
			    BLOCK-PKT-2 (GET-DISK-STRING RQB 121. 484. T)
			    BLOCK-PKT-3 (GET-DISK-STRING RQB 242. 56. T))
		      (COND ((STRING-EQUAL CMD "READ")
			     (DISK-READ RQB UNIT BLOCK)
			     ;; Give to net
			     (DO ((BLOCK BLOCK (1+ BLOCK))
				  (N-BLOCKS N-BLOCKS (1- N-BLOCKS)))
				 ((ZEROP N-BLOCKS))
			       ;; Transmit three packets from block in buffer
			       (SI:TRANSMIT-PARTITION-PACKET CONN BLOCK-PKT-1)
			       (SI:TRANSMIT-PARTITION-PACKET CONN BLOCK-PKT-2)
			       (SI:TRANSMIT-PARTITION-PACKET CONN BLOCK-PKT-3)
			       ;; Advance magic strings to next block
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-1 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-1 3)
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-2 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-2 3)
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-3 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-3 3)))
			    (T
			     ;; Get from net
			     (DO ((BLOCK BLOCK (1+ BLOCK))
				  (N-BLOCKS N-BLOCKS (1- N-BLOCKS)))
				 ((ZEROP N-BLOCKS))
			       ;; Get 3 packets and form a block in the buffer
			       ;; RECEIVE-PARTITION-PACKET will throw if it gets to eof.
			       (SI:RECEIVE-PARTITION-PACKET CONN BLOCK-PKT-1)
			       (SI:RECEIVE-PARTITION-PACKET CONN BLOCK-PKT-2)
			       (SI:RECEIVE-PARTITION-PACKET CONN BLOCK-PKT-3)
			       ;; Advance magic strings to next block
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-1 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-1 3)
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-2 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-2 3)
			       (%P-STORE-CONTENTS-OFFSET
				 (+ (%P-CONTENTS-OFFSET BLOCK-PKT-3 3) (* 4 PAGE-SIZE))
				 BLOCK-PKT-3 3))
			     (DISK-WRITE RQB UNIT BLOCK))))
	       (AND BLOCK-PKT-3 (RETURN-ARRAY BLOCK-PKT-3))
	       (AND BLOCK-PKT-2 (RETURN-ARRAY BLOCK-PKT-2))
	       (AND BLOCK-PKT-1 (RETURN-ARRAY BLOCK-PKT-1))
	       (RETURN-DISK-RQB RQB)))
	    ((STRING-EQUAL CMD "SAY")
	     (TV:NOTIFY NIL "REMOTE-DISK-SERVER:~A" (SUBSTRING LINE CMDX)))))
  (AND CONN (REMOVE-CONN CONN)))

;; Useful information gatherers

;HOST-DATA: returns information about a specified host.  Currently,
; returns name of machine as primary value and host number as second value
(DEFUN HOST-DATA (&OPTIONAL (HOST MY-ADDRESS) &AUX HOST-ADDRESS HOST-NAME TEM)
  (DECLARE (RETURN-LIST HOST-NAME HOST-ADDRESS))
  (OR (SETQ HOST-ADDRESS (ADDRESS-PARSE HOST))
      (FERROR NIL "~S is an illegal host specification" HOST))
  (IF (AND (SETQ HOST-NAME (SI:GET-HOST-FROM-ADDRESS HOST-ADDRESS ':CHAOS))
	   (SETQ HOST-NAME (FUNCALL HOST-NAME ':NAME)))
      (AND (SETQ TEM (ASSOC HOST-NAME SI:MACHINE-LOCATION-ALIST))
	   (SETQ HOST-NAME (SECOND TEM)))
      (IF (SETQ TEM (GET-HOST-STATUS-PACKET HOST-ADDRESS))
	  (LET ((STRING (PKT-STRING TEM)))
	    (SETQ HOST-NAME (SUBSTRING STRING 0
				       (MIN (PKT-NBYTES TEM) 32.
					    (OR (STRING-SEARCH-CHAR 0 STRING) 32.)))))
	  (SETQ HOST-NAME "Unknown")))
  (VALUES HOST-NAME HOST-ADDRESS))

;;; If given a number, this always returns something that ADDRESS-PARSE would make into that
;;; number.
(DEFUN HOST-SHORT-NAME (HOST &AUX HOST1)
  (COND ((NOT (NUMBERP HOST))
	 (SI:HOST-SHORT-NAME HOST))
	((SETQ HOST1 (SI:GET-HOST-FROM-ADDRESS HOST ':CHAOS))
	 (SI:HOST-SHORT-NAME HOST1))
	(T (FORMAT NIL "~O" HOST))))

(FSET 'HOST-SYSTEM-TYPE 'SI:HOST-SYSTEM-TYPE)

;Returns a STATUS packet from the specified host or NIL if couldn't get the packet
(DEFUN GET-HOST-STATUS-PACKET (HOST &AUX CONNECTION PKT ADR)
  (ASSURE-ENABLED)
  (SETQ ADR (OR (ADDRESS-PARSE HOST)
		(FERROR NIL "Not a known Chaos address: ~S" HOST)))
  (SETQ CONNECTION (OPEN-CONNECTION ADR "STATUS" 1))
  (DO () ((NULL CONNECTION))
      (PROCESS-SLEEP 10.)				;Take a few chaos net interrupts
      (SELECTQ (STATE CONNECTION)
	(RFC-SENT-STATE
	  (COND (( (TIME-DIFFERENCE (TIME) (TIME-LAST-RECEIVED CONNECTION))
		    300.)		;5-second timeout
		 (REMOVE-CONN CONNECTION)
		 (RETURN NIL))))
	(ANSWERED-STATE				;This is what we want
	  (SETQ PKT (GET-NEXT-PKT CONNECTION))
	  (CLOSE CONNECTION)
	  (RETURN PKT))
	(CLS-RECEIVED-STATE (CLOSE CONNECTION) (RETURN NIL))
	(OPEN-STATE
	  (CLOSE CONNECTION "I expected an ANS, not an OPN.")
	  (RETURN NIL))
	(LOS-RECEIVED-STATE
	  (CLOSE CONNECTION)
	  (RETURN NIL))
	(OTHERWISE
	  (CLOSE CONNECTION)
	  (RETURN NIL)))))

;; Values can be T, :NOTIFY, or NIL
(DEFVAR EVAL-SERVER-ON NIL)
(DEFVAR EVAL-SERVER-CONNECTIONS NIL)

;Call this if you want to enable the eval server on your machine
(DEFUN EVAL-SERVER-ON (&OPTIONAL (MODE T))
  (SETQ EVAL-SERVER-ON MODE))

(DEFUNP EVAL-SERVER-FUNCTION (&AUX CONN)
  (SETQ CONN (LISTEN "EVAL"))
  (COND ((AND (NULL EVAL-SERVER-ON)
	      (NOT (MEMBER USER-ID '(NIL ""))))
	 (REJECT CONN (FORMAT NIL "This machine is in use by ~A" USER-ID))
	 (RETURN NIL))
	((EQ EVAL-SERVER-ON ':NOTIFY)
	 (TV:NOTIFY NIL "Use of EVAL server by ~A"
		    (HOST-SHORT-NAME (FOREIGN-ADDRESS CONN)))
	 (PROCESS-ALLOW-SCHEDULE)
	 (ACCEPT CONN))
	(T (ACCEPT CONN)))
  (PUSH CONN EVAL-SERVER-CONNECTIONS)
  (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':ADD-SERVER CONN "EVAL")
  (CATCH-ERROR
    (WITH-OPEN-STREAM (STREAM (STREAM CONN))
      (DO ((TERMINAL-IO STREAM)			;Don't blow away machine on lossage
	   (INPUT))
	  (NIL)
	(AND (EQ (SETQ INPUT (READ STREAM 'QUIT)) 'QUIT)
	     (RETURN NIL))
	(CATCH-ERROR (PRINT (MULTIPLE-VALUE-LIST (EVAL INPUT))) T)
	(TERPRI)
	(FUNCALL STREAM ':FORCE-OUTPUT)))
    NIL))

(ADD-INITIALIZATION "EVAL"
                    '(PROCESS-RUN-TEMPORARY-FUNCTION "EVAL Server" 'EVAL-SERVER-FUNCTION)
                    NIL
                    'SERVER-ALIST)


(DEFVAR PACKET-HEADER-ARRAY (MAKE-ARRAY NIL 'ART-16B 8.))
(DEFVAR NUMBER-OF-16B-WORDS (1- MAX-DATA-WORDS-PER-PKT))
(DEFVAR MAX-SCREEN-IDX (// (+ (// (* 1400 1600) 20) (1- NUMBER-OF-16B-WORDS))
			   NUMBER-OF-16B-WORDS))
(DEFVAR SCREEN-ARRAY (MAKE-ARRAY NIL 'ART-16B
				 (* MAX-SCREEN-IDX NUMBER-OF-16B-WORDS)
				 -1000000  ;TV:(SCREEN-BUFFER MAIN-SCREEN)
				 ))
(DEFVAR CURRENT-POINT 0)

(DEFUN SPY-AT-CLOCK-LEVEL (IGNORE)
  (LET ((IP (LET ((FREE-LIST (INT-FREE-LIST)))
	      (COND ((NULL FREE-LIST) NIL)
		    ((%STORE-CONDITIONAL INT-FREE-LIST-POINTER
					 FREE-LIST (INT-PKT-THREAD FREE-LIST))
		     FREE-LIST))))
	;(RN (RANDOM MAX-SCREEN-IDX))
	(RN (SETQ CURRENT-POINT (\ (1+ CURRENT-POINT) MAX-SCREEN-IDX))))
    (COND (IP (SETF (INT-PKT-THREAD IP) NIL)
	      (COPY-ARRAY-PORTION PACKET-HEADER-ARRAY 0 8 IP 0 8)
	      (ASET RN IP 8)
	      (COPY-ARRAY-PORTION SCREEN-ARRAY (* RN NUMBER-OF-16B-WORDS)
				  (* (1+ RN) NUMBER-OF-16B-WORDS)
				  IP 9. (+ 9. NUMBER-OF-16B-WORDS))
	      (TRANSMIT-INT-PKT IP)))))

(DEFUN SPY-START ()
  (LET ((CONN (LISTEN "SPY")))
    (ACCEPT CONN)
    ;; Wait for other end to acknowledge our OPN
    (PROCESS-WAIT "Accept" #'(LAMBDA (CONN) (OR (NEQ (STATE CONN) 'OPEN-STATE)
						(PLUSP (SEND-PKT-ACKED CONN))))
		  CONN)
    (ASET (LSH UNC-OP 8) PACKET-HEADER-ARRAY 0)
    (ASET MAX-DATA-BYTES-PER-PKT PACKET-HEADER-ARRAY 1)
    (ASET (FOREIGN-ADDRESS CONN) PACKET-HEADER-ARRAY 2)
    (ASET (FOREIGN-INDEX-NUM CONN) PACKET-HEADER-ARRAY 3)
    (ASET MY-ADDRESS PACKET-HEADER-ARRAY 4)
    (ASET (LOCAL-INDEX-NUM CONN) PACKET-HEADER-ARRAY 5)
    (ASET 0 PACKET-HEADER-ARRAY 6)
    (ASET 0 PACKET-HEADER-ARRAY 7)
    (PUSH 'SPY-AT-CLOCK-LEVEL SI:CLOCK-FUNCTION-LIST)
    (WAIT CONN 'OPEN-STATE 100000000)
    (SETQ SI:CLOCK-FUNCTION-LIST (DELQ 'SPY-AT-CLOCK-LEVEL SI:CLOCK-FUNCTION-LIST))
    (REMOVE-CONN CONN)))

(ADD-INITIALIZATION "SPY"
                    '(PROCESS-RUN-TEMPORARY-FUNCTION "SPY Server" 'SPY-START)
                    NIL
                    'SERVER-ALIST)

(COMMENT Debugging Stuff)

(DEFUN CD-SEND ( &AUX PKT)
    (DISABLE)
    (SETQ PKT (ALLOCATE-PKT))
    (TERPRI) (TERPRI)
    (SETF (PKT-OPCODE PKT) (CD-GET "Opcode: "))
    (SETF (PKT-DEST-ADDRESS PKT) (CD-GET "Destination: "))
    (SETF (PKT-DEST-INDEX-NUM PKT) (CD-GET "Destination index: "))
    (SETF (PKT-SOURCE-ADDRESS PKT) (CD-GET "Source address: "))
    (SETF (PKT-SOURCE-INDEX-NUM PKT) (CD-GET "Source index: "))
    (SETF (PKT-NUM PKT) (CD-GET  "Packet number: "))
    (SETF (PKT-ACK-NUM PKT) (CD-GET "Ack packet number: "))
    (SETF (PKT-FWD-COUNT PKT) (CD-GET "Forwarding count: "))
    (SET-PKT-STRING PKT (CD-GET "Data (a string):"))
    (TRANSMIT-INT-PKT (CONVERT-TO-INT-PKT PKT))
    (FREE-PKT PKT))

(DEFUN CD-GET (PROMPT &AUX X)
    (PRINC PROMPT)
    (SETQ X (EVAL (READ)))
    (TERPRI)
    X)

(DEFUN CD-RECEIVE ( &AUX PKT)
    (DISABLE)
    (SETQ PKT (CONVERT-TO-PKT (RECEIVE-PROCESS-NEXT-INT-PKT)))
    (COND (PKT (PRINT-PKT PKT))
	  (T NIL)))

(DEFUN SOAK (CONN &AUX PKT)
    (AND (NUMBERP CONN) (SETQ CONN (AR-1 INDEX-CONN CONN)))
    (SETQ PKT (GET-NEXT-PKT CONN))
    (COND ((= (PKT-OPCODE PKT) CLS-OP)
	   (FORMAT T "==> CLOSED!!! <===  ~S" (PKT-STRING PKT)))
	  (PKT
	   (PRINT-PKT PKT)))
    (AND PKT (FREE-PKT PKT)))

(SPECIAL C L)
(DEFUN SETUP (&OPTIONAL (CNAME "FOO"))
   (ENABLE)
   (SETQ C (OPEN-CONNECTION MY-ADDRESS CNAME))
   (SETQ L (LISTEN CNAME 5 NIL))
   (WAIT L 'LISTENING-STATE (* 10. 60.))
   (IF (EQ (STATE L) 'LISTENING-STATE)
       (FORMAT T "Lost")
       (ACCEPT L))
   (PEEK 'K))

;;; Called By PEEK.

(DECLARE (SPECIAL PEEK-SHORT-PKT-DISPLAY))
(SETQ PEEK-SHORT-PKT-DISPLAY T)	;Display packets in short form in peek

(DEFUN PEEK-DISPLAY ( &AUX CONN)
    (FORMAT T "~&ChaosNet Status: ~O" (TIME))
    (FORMAT T (COND (ENABLE "   Active!~%")
		    (T "   Deactivated.~%")))
    (DO I 0 (1+ I) (>= I (ARRAY-LENGTH INDEX-CONN))
      (COND ((ARRAYP (SETQ CONN (AR-1 INDEX-CONN I)))
             (PRINT-CONN CONN PEEK-SHORT-PKT-DISPLAY)
	     (TERPRI))))
    (FORMAT T "~2%Forwarded: ~O  Overforwarded: ~O  Lost: ~O   Made: ~O  Free: ~O (+~O Recorded LOS packets)~%"
	    PKTS-FORWARDED PKTS-OVER-FORWARDED PKTS-LOST PKTS-MADE
	    (DO ((I 0 (1+ I))
		 (FP FREE-PKTS (PKT-LINK FP)))
		((SYMBOLP FP) I))
	    CURRENT-LOS-PKT-COUNT)
    (FORMAT T "Bad Destination: ~O   Bad Bit Count: ~O   Bad CRC-1: ~O  Bad CRC-2: ~O~%"
	    PKTS-BAD-DEST PKTS-BAD-BIT-COUNT PKTS-BAD-CRC-1 PKTS-BAD-CRC-2)
    (COND (PENDING-LISTENS
           (FORMAT T "~%Pending LISTENs:~%")
           (DO L PENDING-LISTENS (CDR L) (NULL L)
             (FORMAT T "   Contact name: ~S~%" (CAR L)))))
    (COND (PENDING-RFC-PKTS
           (FORMAT T "~%Pending RFCs:~%")
           (DO PKT PENDING-RFC-PKTS (PKT-LINK PKT) (NULL PKT)
             (FORMAT T "   Contact name: ~S~%" (PKT-STRING PKT))))))

(DEFUN PRINT-BAD-PKTS ()
   (DO ((LIST BAD-PKT-LIST (CDR LIST)))
       ((NULL LIST))
     (FORMAT T "~&~A" (CAAR LIST))
     (PRINT-PKT (CADAR LIST))
     (TERPRI)))

(DEFUN PRINT-RECENT-HEADERS ( &OPTIONAL (NBR 200))
   (DO ((I (\ (+ 177 RECENT-HEADERS-POINTER) 200) (COND ((ZEROP I) 177) (T (1- I))))
	(COUNT NBR (1- COUNT)))
       ((ZEROP COUNT))
     (FORMAT T "~%Nbr:~O Opcd:~O(~A). Len:~O bytes. "
	        (RCNT-PKT-NUM I)
		(RCNT-OPCODE I)
		(COND ((< (RCNT-OPCODE I) (LENGTH OPCODE-LIST))
		       (NTH (RCNT-OPCODE I) OPCODE-LIST))
		      (( (RCNT-OPCODE I) DAT-OP) 'DAT)
		      (T (FORMAT NIL "==> ~O <==" (RCNT-OPCODE I))))
		(RCNT-NBYTES I))
     (FORMAT T "From ~O-~O to ~O-~O, Fwded ~O Times, Rcrded:~O"
	        (RCNT-SOURCE-ADDRESS I) (RCNT-SOURCE-INDEX I)
		(RCNT-DEST-ADDRESS I) (RCNT-DEST-INDEX I)
		(RCNT-FWD-COUNT I) (RCNT-TIME-RECORDED I))))

;;; Prints as much info as possible
(DEFUN DUMP-GUTS ( &AUX (PEEK-SHORT-PKT-DISPLAY NIL))
       (PEEK-DISPLAY)
       (FORMAT T "~2%Recent headers:")
       (PRINT-RECENT-HEADERS))

(DEFUN HACK-DOOR (COMMAND)
  (LET ((RESULT (SIMPLE "AI" (STRING-APPEND "DOOR " COMMAND))))
    (COND ((STRINGP RESULT)
	   (TV:NOTIFY NIL "Failed trying to hack the door: ~A" RESULT))
	  (T (RETURN-PKT RESULT) T))))

;;; System system transformation
(DEFUN GENERATE-HOST-TABLE-1 (INPUT-FILE OUTPUT-FILE)
  (WITH-OPEN-FILE (INPUT-STREAM INPUT-FILE '(:READ))
    (WITH-OPEN-FILE (OUTPUT-STREAM OUTPUT-FILE '(:PRINT))
      (FORMAT OUTPUT-STREAM "~
;;; -*- Mode: LISP;~@[ Package: ~A;~] Base: 8 -*-
;;; *** THIS FILE WAS AUTOMATICALLY GENERATED BY A PROGRAM, DO NOT EDIT IT ***
;;; Host table made from ~A by ~A at ~\DATIME\~%"
	      SI:*FORCE-PACKAGE* (FUNCALL INPUT-STREAM ':TRUENAME) USER-ID)
      (DO ((LINE) (EOF)
	   (I) (J)
	   (NI) (NJ)
	   (HOSTL) (NAMEL) (DELIM))
	  (NIL)
	(MULTIPLE-VALUE (LINE EOF)
	  (FUNCALL INPUT-STREAM ':LINE-IN NIL))
	(AND EOF (RETURN))
	(MULTIPLE-VALUE (I J)
	  (PARSE-HOST-TABLE-TOKEN LINE 0))
	(COND ((AND I (STRING-EQUAL LINE "HOST" I 0 J NIL))
	       ;; Host name
	       (MULTIPLE-VALUE (NI NJ)
		 (PARSE-HOST-TABLE-TOKEN LINE (1+ J)))
	       (MULTIPLE-VALUE (I J DELIM)
		 (PARSE-HOST-TABLE-TOKEN LINE (1+ NJ)))
	       (SETQ HOSTL (NCONS (SUBSTRING LINE NI NJ)))
	       (IF (= DELIM #/[)
		   (DO ((L NIL)
			(I1) (J1))
		       ((= DELIM #/])
			(SETQ J (1+ J))		;,
			(NREVERSE L))
		     (MULTIPLE-VALUE (I1 J1 DELIM)
		       (PARSE-HOST-TABLE-TOKEN LINE (1+ J)))
		     (IF (= DELIM #\SP)
			 (MULTIPLE-VALUE (I J DELIM)
			   (PARSE-HOST-TABLE-TOKEN LINE (1+ J1)))
			 (SETQ I I1 J J1 J1 I1))
		     (ADD-HOST-TABLE-ADDRESS LINE I1 J1 I J HOSTL))
		   (LET ((I1 I) (J1 J))
		     (IF (= DELIM #\SP)
			 (MULTIPLE-VALUE (I J)
			   (PARSE-HOST-TABLE-TOKEN LINE (1+ J)))
			 (SETQ I I1 J J1 J1 I1))
		     (ADD-HOST-TABLE-ADDRESS LINE I1 J1 I J HOSTL)))
	       (COND ((OR (GET HOSTL ':CHAOS)	;If there were any chaosnet addresses
			  ;; Include some popular ARPA sites for speed in SUPDUP/TELNET
			  (AND (EQ SI:SITE-NAME ':MIT)
			       (MEMBER (CAR HOSTL) '("MIT-DMS" "SU-AI" "S1-A" "CMU-10A"
						     "SRI-KL"))))
		      (DOTIMES (K 2)
			(MULTIPLE-VALUE (I J DELIM)
			  (PARSE-HOST-TABLE-TOKEN LINE (1+ J))))
		      (PUTPROP HOSTL (INTERN (SUBSTRING LINE I J) "") ':SYSTEM-TYPE)
		      (DOTIMES (K 2)
			(MULTIPLE-VALUE (I J DELIM)
			  (PARSE-HOST-TABLE-TOKEN LINE (1+ J)))
			(OR I (RETURN (SETQ DELIM -1))))
		      (SETQ NAMEL (NCONS (CAR HOSTL)))
		      (AND (= DELIM #/[)
			   (DO () ((= DELIM #/])
				   (SETQ NAMEL (STABLE-SORT NAMEL
							    #'(LAMBDA (X Y)
								(< (STRING-LENGTH X)
								   (STRING-LENGTH Y))))))
			     (MULTIPLE-VALUE (I J DELIM)
			       (PARSE-HOST-TABLE-TOKEN LINE (1+ J)))
			     (PUSH (SUBSTRING LINE I J) NAMEL)))
		      (PUTPROP HOSTL NAMEL ':HOST-NAMES)
		      (PKG-BIND (OR SI:*FORCE-PACKAGE* PACKAGE)
			(SI:GRIND-TOP-LEVEL `(SI:DEFINE-HOST ,(CAR HOSTL)
							     . ,(MAPCAR #'(LAMBDA (X) `',X)
									(CDR HOSTL)))
					    95. OUTPUT-STREAM)
			(TERPRI OUTPUT-STREAM))))))))))

(DEFUN PARSE-HOST-TABLE-TOKEN (STRING &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (DO ((IDX START (1+ IDX))
       (SIDX) (CH))
      (( IDX END)
       (VALUES SIDX IDX -1))
    (SETQ CH (AREF STRING IDX))
    (OR SIDX
	(MEMQ CH '(#\SP #\TAB))
	(SETQ SIDX IDX))
    (AND SIDX
	 (MEMQ CH '(#/, #\SP #\TAB #/[ #/]))
	 (RETURN SIDX IDX CH))))

(DEFUN ADD-HOST-TABLE-ADDRESS (LINE NET-START NET-END ADDRESS-START ADDRESS-END HOSTL
			       &AUX SYMBOL PARSER)
  (SETQ SYMBOL (IF (= NET-START NET-END) ':ARPA
		   (INTERN (SUBSTRING LINE NET-START NET-END) "")))
  (COND ((SETQ PARSER (GET SYMBOL 'HOST-ADDRESS-PARSER))
	 (SETF (GET HOSTL SYMBOL)		;Keep addresses in original order
	       (NCONC (GET HOSTL SYMBOL)
		      (NCONS (FUNCALL PARSER SYMBOL LINE ADDRESS-START ADDRESS-END)))))))

;;; For now, this is all we really support
(DEFUN (:CHAOS HOST-ADDRESS-PARSER) (IGNORE LINE START END)
  (ZWEI:PARSE-NUMBER LINE START END 8))

(DEFUN (:ARPA HOST-ADDRESS-PARSER) (IGNORE LINE START END &AUX SLASH)
  (SETQ SLASH (STRING-SEARCH-CHAR #// LINE START END))
  (DPB (ZWEI:PARSE-NUMBER LINE START SLASH) 1110 (ZWEI:PARSE-NUMBER LINE (1+ SLASH) END)))

(DEFUN (:DIAL HOST-ADDRESS-PARSER) (IGNORE LINE START END)
  (SUBSTRING LINE START END))			;A phone number is just characters.

(DEFUN (:LCS HOST-ADDRESS-PARSER) (IGNORE LINE START END &AUX SLASH)
  (SETQ SLASH (STRING-SEARCH-CHAR #// LINE START END))
  (DPB (ZWEI:PARSE-NUMBER LINE START SLASH) 1010 (ZWEI:PARSE-NUMBER LINE (1+ SLASH) END)))

(DEFUN (:SU HOST-ADDRESS-PARSER) (IGNORE LINE START END &AUX SHARP)
  (SETQ SHARP (STRING-SEARCH-CHAR #/# LINE START END))
  (DPB (ZWEI:PARSE-NUMBER LINE START SHARP) 1010 (ZWEI:PARSE-NUMBER LINE (1+ SHARP) END)))

(DEFUN CHAOS-UNKNOWN-HOST-FUNCTION (NAME)
  (DOLIST (HOST (SI:GET-SITE-OPTION ':CHAOS-HOST-TABLE-SERVER-HOSTS))
    (WITH-OPEN-STREAM (STREAM (OPEN-STREAM HOST "HOSTAB" ':ERROR NIL))
      (COND ((NOT (STRINGP STREAM))
	     (FUNCALL STREAM ':LINE-OUT NAME)
	     (FUNCALL STREAM ':FORCE-OUTPUT)
	     (DO ((LIST NIL)
		  (LINE) (EOF)
		  (LEN) (SP) (PROP))
		 (NIL)
	       (MULTIPLE-VALUE (LINE EOF)
		 (FUNCALL STREAM ':LINE-IN))
	       (AND EOF
		    (RETURN (COND (LIST
				   (PUTPROP LIST (STABLE-SORT (GET LIST ':HOST-NAMES)
							      #'(LAMBDA (X Y)
								  (< (STRING-LENGTH X)
								     (STRING-LENGTH Y))))
					    ':HOST-NAMES)
				   (APPLY #'SI:DEFINE-HOST LIST)))))
	       (SETQ LEN (STRING-LENGTH LINE)
		     SP (STRING-SEARCH-CHAR #\SP LINE 0 LEN))
	       (SETQ PROP (INTERN (SUBSTRING LINE 0 SP) "")
		     SP (1+ SP))
	       (SELECTQ PROP
		 (:ERROR
		  (RETURN NIL))
		 (:NAME
		  (LET ((NAME (SUBSTRING LINE SP LEN)))
		    (OR LIST (SETQ LIST (NCONS NAME)))
		    (PUSH NAME (GET LIST ':HOST-NAMES))))
		 (:SYSTEM-TYPE
		  (PUTPROP LIST (INTERN (SUBSTRING LINE SP LEN) "") ':SYSTEM-TYPE))
		 (:MACHINE-TYPE)
		 (OTHERWISE
		  (LET ((FUNCTION (GET PROP 'HOST-ADDRESS-PARSER)))
		    (OR FUNCTION (SETQ FUNCTION (GET ':CHAOS 'HOST-ADDRESS-PARSER)))
		    (PUSH (FUNCALL FUNCTION PROP LINE SP LEN)
			  (GET LIST PROP))))))
	     (RETURN T))))))

(SETQ SI:UNKNOWN-HOST-FUNCTION 'CHAOS-UNKNOWN-HOST-FUNCTION)

;;; Host object support

(DEFPROP :CHAOS HOST-CHAOS-MIXIN SI:NETWORK-TYPE-FLAVOR)

(DEFFLAVOR HOST-CHAOS-MIXIN () ()
  (:INCLUDED-FLAVORS SI:HOST))

(DEFMETHOD (HOST-CHAOS-MIXIN :CHAOS-ADDRESSES) ()
  (GET (LOCF SI:(HOST-ADDRESSES ALIST-ELEM)) ':CHAOS))

(DEFMETHOD (HOST-CHAOS-MIXIN :CHAOS-ADDRESS) ()
  (CAR (FUNCALL-SELF ':CHAOS-ADDRESSES)))

(DEFMETHOD (HOST-CHAOS-MIXIN :CONNECT) (CONTACT-NAME)
  (CONNECT SELF CONTACT-NAME))

;;; This is here to make compile-flavor-methods win before PEEK is loaded.
;;; The function is defined in PEEKCH.
(DEFMETHOD (HOST-CHAOS-MIXIN :PEEK-FILE-SYSTEM-HEADER) HOST-CHAOS-PEEK-FILE-SYSTEM-HEADER)

;;; Hosts whose operating system we don't know anything about.
(SI:COMPILE-HOST-FLAVOR-COMBINATION :DEFAULT :CHAOS)

;;; By default, lisp machines do not have any file computer flavor.
;;; This is added later.
(SI:COMPILE-HOST-FLAVOR-COMBINATION :LISPM :CHAOS)