(FILECREATED "18-DEC-78 18:19:35" <LISPUSERS>NET.;36
 18044  

     changes to:  NETCOMS CHECKFORK

     previous date: "13-NOV-78 18:11:55" <LISPUSERS>NET.;34)


(PRETTYCOMPRINT NETCOMS)

(RPAQQ NETCOMS
 ((FNS MAKENEWCONNECTION STRINGTOCONNECTION CHECKCONNECTION CHECKFORK CHECKTIMING 
		     CHECKBSP CLOSECONNECTION NETUSER NETSERVER ARPAHOSTP ARPAPAIR ARPAOPENF FORCEOUT 
		     OCTAL FOPENP BADHOST ENABLEPROCESSCAPS)
	(P (MOVD? (QUOTE NILL)
		  (QUOTE PUPHOSTP)))
	(VARS NETTIMEOUT (CONNECTIONARRAY (LIST (HARRAY 17))))
	(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS CONNECTION CONNECTIONSPECS)
		  (PROP BLKLIBRARYDEF CLOSEF?)
		  (FILES (SYSLOAD)
			 CJSYS))
	(BLOCKS (CONNECTIONBLOCK (ENTRIES MAKENEWCONNECTION CHECKCONNECTION)
				 ARPAPAIR CHECKCONNECTION MAKENEWCONNECTION (NOLINKFNS . T)
				 (BLKLIBRARY CLOSEF?)
				 (SPECVARS INF OUTF)
				 (GLOBALVARS CONNECTIONARRAY LASTCONNECTION NETTIMEOUT)
				 BADHOST CHECKBSP FOPENP)
		(NIL ENABLEPROCESSCAPS STRINGTOCONNECTION CLOSECONNECTION NETUSER NETSERVER ARPAHOSTP 
		     ARPAOPENF FORCEOUT OCTAL (LOCALVARS . T)
		     (GLOBALVARS CONNECTIONARRAY)))))
(DEFINEQ

(MAKENEWCONNECTION

  (LAMBDA (HOST TYPE SKT CONN DONTWAIT)                     (* lmm "24-SEP-78 04:03")


          (* makes a new connection. TYPE says what kind. TYPE=SUBSYS means that HOST is really a file name, run it as a 

	  subsys (start at SKT as entry point). TYPE=ARPA means make an arpanet TELNET connection (default socket the "logger"
). TYPE=NIL means either PUP or NET depending on host. If SKT is given, it is the foreigh socket to ICP to.)



    (PROG (INF OUTF TEM PTY SPECS)
      HOSTLP
          (OR TYPE (SETQ TYPE (COND
		  ((AND (SETQ SPECS (GETHASH HOST CONNECTIONARRAY))
			(NULL CONN))
		    (SETQ CONN HOST)
		    (SETQ SKT (fetch
 SOCKET of
 SPECS))
		    (SETQ HOST (fetch
 NAME of
 SPECS))
		    (fetch
 CNTYPE of
 CONN))
		  ((PUPHOSTP HOST)
		    (QUOTE PUP))
		  ((ARPAHOSTP
 HOST)
		    (QUOTE NET))
		  (T (SETQ HOST (BADHOST
 HOST))
		     (GO HOSTLP)))))
          (COND
	    (CONN (OR (SETQ SPECS (GETHASH CONN CONNECTIONARRAY))
		      (ERROR CONN "not connection"))
		  (AND (EQ CONN LASTCONNECTION)
		       (SETQ LASTCONNECTION))

          (* LASTCONNECTION isn't the same; this logic is for TELNET which wants to know if a connection has changed by 

	  checking if it is EQ to the global LASTCONNECTION)



		  (CLOSECONNECTION
 CONN)                    (* incase still open)

		  )
	    (T (PUTHASH (SETQ CONN (create
 CONNECTION))
			(SETQ SPECS (create
 CONNECTIONSPECS))
			CONNECTIONARRAY)))
          (SELECTQ TYPE
		   ((SUBSYS JOB FORK)                       (* more complicated than it logically should be, to talk

							    to a lower fork.)

                                                            (* if MAXC had PTY's, then this would use them rather 

							    than PUP connections.)

		     (PROGN 

          (* doing for NET instead doesn't quite work (ARPAPAIR 2 NIL NIL NIL T) (MAKENEWCONNECTION (HOSTNAME) 

	  (QUOTE NETCHARS) (JS CVSKT (OPNJFN OUTF) NIL NIL 2) CONN NIL) (CHECKBSP INF) (CHECKBSP OUTF) 

	  (SETQQ TYPE NET))



			    (PUPPAIR NIL NIL NIL T T)

          (* first make a server (but don't wait) -

	  PUPPAIR sets INF and OUTF to the files involved -

	  note that this is the same call to PUPPAIR as in PUPSERVER clause below)



			    (MAKENEWCONNECTION
 (HOSTNAME)
					       (QUOTE PUP)
					       (JS CVSKT (OPNJFN INF)
						   NIL NIL 3)
					       CONN)        (* now make a USER for the SERVER we just made -

							    wait for response)

			    )
		     (COND
		       ((PROG1 (NOT (ILESSP (SETQ PTY (JS ATPTY (OPNJFN INF)
							  (OPNJFN OUTF)
							  NIL 1))
					    131583))
			       (CLOSEF? INF)
			       (CLOSEF? OUTF))
			 (CLOSECONNECTION
 CONN)
			 (ERROR (ERSTR PTY))))              (* INF and OUTF are closed because the JFN's went away)

		     (JS ASND PTY)
		     (replace
 JOBFORK of
 CONN
			with
 (SELECTQ TYPE
				      (JOB (MAKEJOB HOST SKT PTY))
				      (PROGN (PUT (SETQ OUTF (fetch
 OUT of
 CONN))
						  (QUOTE PTY)
						  PTY)      (* remember to deassign the PTY when the connection 

							    closes)

					     (WHENCLOSE OUTF (QUOTE BEFORE)
							(FUNCTION (LAMBDA (X)
							    (AND (SETQ X (GETP X (QUOTE PTY)))
								 (JS RELD X)))))
					     (SETQ TEM (MAKESUBSYS HOST SKT PTY))
					     (SELECTQ TYPE
						      (FORK (ENABLEPROCESSCAPS
)
							    (JS SCTTY (XWD 200000Q TEM)
								PTY))
						      NIL)
					     TEM)))
		     (GO RET))
		   ((PUP CHAT)
		     (SETQQ TYPE PUP)
		     (PUPPAIR NIL HOST SKT NIL DONTWAIT))
		   (PUPSERVER (PUPPAIR SKT NIL NIL T DONTWAIT))
		   ((NET TELNET ARPA)
		     (SETQQ TYPE NET)
		     (ARPAPAIR
 4 HOST (PROG1 (JS BIN (OPNJFN (SETQ TEM (ARPAOPENF 2 HOST SKT
										  (QUOTE INPUT)
										  40Q NIL)))
						 NIL NIL 2)
					     (CLOSEF TEM))
			       DONTWAIT T))
		   (NETSERVER
 (ARPAPAIR
 SKT NIL NIL DONTWAIT NIL))
		   (NETUSER
 (ARPAPAIR
 4 HOST SKT DONTWAIT NIL))
		   (NETCHARS (ARPAPAIR
 4 HOST SKT DONTWAIT T))
		   (ERROR TYPE "unknown connection type"))
          (WHENCLOSE INF (QUOTE CLOSEALL)
		     (QUOTE NO))
          (WHENCLOSE OUTF (QUOTE CLOSEALL)
		     (QUOTE NO))
          (replace
 IN of
 CONN with
 INF)
          (replace
 OUT of
 CONN with
 OUTF)
      RET (replace
 SOCKET of
 SPECS with
 SKT)
          (replace
 NAME of
 SPECS with
 HOST)
          (replace
 CNTYPE of
 CONN with
 TYPE)
          (RETURN CONN))))

(STRINGTOCONNECTION

  (LAMBDA (STRING CONNECTION)                               (* lmm "24-SEP-78 04:02")

    (SELECTQ (fetch
 CNTYPE of
 CONNECTION)
	     ((NET NETUSER NETSERVER NETCHARS)              (* these expect CRLF as standard EOL convention, so 

							    PRIN3 will work reasonably)

	       (PRIN3 STRING (fetch
 OUT of
 CONNECTION)))
	     (ASSEMBLE
 NIL
		       (CQ (VAG (OPNJFN (fetch
 OUT of
 CONNECTION)
					(QUOTE OUTPUT))))
		       (PUSHN)
		       (CQ (MKSTRING STRING))
		       (FASTCALL UPATM)
		       (POPN)                               (* jfn, string, length in 1, 3, 4 respectively)

		       (JRST ENDLP)
		   LP  (ILDB 2 , 3)                         (* get next char)

		       (CAIN 2 , 37Q)                       (* is it EOL?)

		       (MOVEI 2 , 15Q)                      (* turn into CR)

		       (JS BOUT)                            (* send it)

		   ENDLP
		       (SOJG 4 , LP)                        (* and go back if more)

		   ))
    STRING))

(CHECKCONNECTION

  (LAMBDA (CONNECTION)                                      (* lmm " 1-JUN-78 01:27")

    (COND
      ((AND (OR (NULL (fetch
 JOBFORK of
 CONNECTION))
		(CHECKFORK (fetch
 JOBFORK of
 CONNECTION)))
	    (CHECKBSP
 (fetch
 IN of
 CONNECTION))
	    (CHECKBSP
 (fetch
 OUT of
 CONNECTION)))
	CONNECTION)
      (T (CLOSECONNECTION
 CONNECTION)
	 NIL))))

(CHECKFORK

  (LAMBDA (FORK START UNFREEZE)                             (* lmm "31-MAY-78 17:51")

                                                            (* check if FORK is OK and starts it if START is set)

    (COND
      ((SMALLP FORK)
	(NOT (MINUSP (GETAB (QUOTE JOBTTY)
			    FORK))))
      (T (AND FORK (GETHASH FORK USERFORKS)
	      (ASSEMBLE
 NIL
		        (CV FORK)
		        (PUSHN)
		    RF  (JS RFSTS)                          (* get fork status)

		        (HLRZ 1 , 1)                        (* from left-half)

		        (CAIN 1 , -1)                       (* left half -1 means fork dead)

		        (JRST LOSE)
		        (VAR (HRRZ 3 , UNFREEZE))
		        (TRZE 1 , 400000Q)                  (* sign bit off, not frozen)

		        (CAMN 3 , ' NIL)                    (* UNFREEZE not NIL means to unfreeze if frozen)

		        (JRST NOTFROZEN)
		        (NREF (MOVE 1 , 0))
		        (JS RFORK)                          (* resume it)

		        (JRST RF)                           (* and try again)

		    NOTFROZEN
		        (CAIE 1 , 0)                        (* running?)

		        (CAIN 1 , 1)                        (* not in I/O wait?)

		        (JRST WIN)                          (* running or I/O WAIT, looks good)

		        (CAIN 1 , 4)                        (* fork wait is OK too)

		        (JRST WIN)
		        (CAIE 1 , 2)                        (* not halted?)

		        (JRST LOSE)                         (* doesn't look good)

		        (VAR (HRRZ 3 , START))
		        (CAMN 3 , ' NIL)                    (* start it?)

		        (JRST WIN)                          (* no, just return)

		        (NREF (MOVE 1 , 0))                 (* get fork handle back)

		        (JS SFORK)                          (* restore at PC in AC2 (from RFSTS))

		        (MOVEI 1 , 0)
		        (JRST WIN)
		    LOSE(CQ (KFORK FORK))
		        (SKIPA 1 , ' NIL)
		    WIN (MOVEI 1 , ASZ (1))                 (* return fork status as small number 

							    (0 thru 4))

		        (POPNN 1)))))))

(CHECKTIMING

  [LAMBDA (CONNECTION)                                      (* edited: "13-NOV-78 18:11")


          (* CHECK FOR TIMING AND DATA MARKS ON CONNECTION. IF ONE IS FOUND, TAKES CARE OF IT AND RETURNS THE TYPE OF MARK 

	  FOUND. OTHERWISE RETURNS NIL)



    (PROG ((IJFN (OPNJFN (CAR CONNECTION)))
	   (OJFN (OPNJFN (CADR CONNECTION)))
	   ST)
          (COND
	    ((BIT 4 (SETQ ST (JS GDSTS IJFN 0 0 2)))
	      (JS SDSTS IJFN (LOGXOR (BIT 4)
				     ST)
		  0)
	      (SELECTQ (JS MTOPR IJFN 23Q NIL 3)
		       (1                                   (* DATAMARK)

			  (RETURN (QUOTE DATAMARK)))
		       (5                                   (* TIMINGMARK)

			  (JS DOBE 101Q)
			  (JS MTOPR OJFN 3 6)
			  (RETURN (QUOTE TIMINGMARK)))
		       (HELP "Unknown net condition"])

(CHECKBSP

  (LAMBDA (FILE)                                            (* lmm "13-NOV-78 08:22")

    (AND FILE (FOPENP
 FILE)
	 (PROG ((JFN (OPNJFN FILE)))
	       (COND
		 ((IEQP (LOGAND (JS GTSTS JFN 0 NIL 2)
				(CONSTANT (LOGOR (BIT 0)
						 (BIT 9)
						 (BIT 10)
						 (BIT 11))))
			(CONSTANT (LOGOR (BIT 0)
					 (BIT 10))))        (* bits 0, 10 on, 9, 11 off)

		   (AND (PROG (TELFLG (DELTA 20)
				      (LEFT NETTIMEOUT))
			      (SELECTQ (BITS 3 17 (JS DVCHR JFN NIL NIL 1))
				       (14 (SETQ TELFLG T))
				       (258 NIL)
				       (RETURN))
			  LP  (COND
				(TELFLG                     (* NET:)

					(SELECTQ (BITS 0 3 (JS GDSTS JFN 0 0 2))
						 (7         (* OPND)

						    (RETURN T))
						 ((3 6)     (* LSNG or RFCS)

						   )
						 (4         (* RFCR)

						    (JS MTOPR JFN 20Q)
						    (GO LP))
						 (RETURN)))
				(T                          (* PUP:)

				   (SELECTQ (BITS 32 35 (JS GDSTS JFN 0 0 2))
					    ((3 4 5)        (* OPEN ENDI ENDO)

					      (RETURN T))
					    ((1 2)          (* RFCO LIST)

					      )
					    (RETURN))))
			      (COND
				((NULL LEFT)                (* wait indefinitly)

				  )
				((IGREATERP LEFT 0)
				  (COND
				    ((ILESSP LEFT DELTA)
				      (SETQ DELTA LEFT))
				    (T DELTA))
				  (SETQ LEFT (IDIFFERENCE LEFT DELTA)))
				(T (RETURN)))
			      (DISMISS DELTA)
			      (SETQ DELTA (IPLUS DELTA DELTA))
			      (GO LP))
			(RETURN FILE))))
	       (CLOSEF FILE)
	       (RETURN)))))

(CLOSECONNECTION

  (LAMBDA (CONNECTION)                                      (* lmm "24-SEP-78 03:43")

    (COND
      ((EQ CONNECTION T)
	(MAPHASH CONNECTIONARRAY (FUNCTION (LAMBDA (DUMMY CONN)
		     (CLOSECONNECTION
 CONN))))
	T)
      ((GETHASH CONNECTION CONNECTIONARRAY)
	(AND (fetch
 IN of
 CONNECTION)
	     (CLOSEF? (PROG1 (fetch
 IN of
 CONNECTION)
			     (replace
 IN of
 CONNECTION with
 NIL))))
	(AND (fetch
 OUT of
 CONNECTION)
	     (CLOSEF? (PROG1 (fetch
 OUT of
 CONNECTION)
			     (replace
 OUT of
 CONNECTION with
 NIL))))
	(COND
	  ((fetch
 JOBFORK of
 CONNECTION)
	    (COND
	      ((SMALLP (fetch
 JOBFORK of
 CONNECTION))
		(JS LGOUT (fetch
 JOBFORK of
 CONNECTION)))
	      (T (KFORK (fetch
 JOBFORK of
 CONNECTION))))
	    (replace
 JOBFORK of
 CONNECTION with
 NIL)))
	CONNECTION))))

(NETUSER

  (LAMBDA (HOST USER ARPA# WAITFLG)                         (* lmm "23-JUN-78 13:06")

    (MAKENEWCONNECTION
 (OR HOST (HOSTNAME))
		       (QUOTE NETUSER)
		       (LOGOR (LLSH (OR (NUMBERP USER)
					(USERNUMBER USER))
				    15)
			      (LLSH (ADD1 (OR ARPA# 0))
				    1))
		       NIL
		       (NOT WAITFLG))))

(NETSERVER

  (LAMBDA (ARPA# WAITFLG)                                   (* lmm "23-JUN-78 13:06")

    (MAKENEWCONNECTION
 NIL (QUOTE NETSERVER)
		       (LLSH (ADD1 (OR ARPA# 0))
			     1)
		       NIL
		       (NOT WAITFLG))))

(ARPAHOSTP

  (LAMBDA (X)                           (* lmm " 3-MAY-78 21:38")

    (INFILEP (PACK* "NET:." X "-1"))))

(ARPAPAIR

  (LAMBDA (LSKT HOST FSKT DONTWAIT NOBUFFER)
                                        (* lmm "23-JUN-78 13:20")

    (SETQ INF (ARPAOPENF
 (AND LSKT (LOGAND LSKT -2))
			 HOST
			 (AND FSKT (LOGOR FSKT 1))
			 (QUOTE INPUT)
			 NIL DONTWAIT NOBUFFER))
    (SETQ OUTF (ARPAOPENF
 (AND LSKT (LOGOR LSKT 1))
			  HOST
			  (AND FSKT (LOGAND FSKT -2))
			  (QUOTE OUTPUT)
			  NIL DONTWAIT NOBUFFER))))

(ARPAOPENF

  (LAMBDA (LSKT HOST FSKT ACCESS BYTESIZE DONTWAIT NOBUFFER)
                                                            (* lmm "24-SEP-78 03:23")

    (PROG (FILE (LSKT (COND
			(LSKT (OCTAL
 LSKT))
			(T "")))
		(FSKT (AND HOST (SELECTQ FSKT
					 ((NIL TELNET)
					   1)
					 (FTP 3)
					 (ECHO 7)
					 (DISCARD "11")
					 (SYSTAT "13")
					 (TIME "15")
					 (TEXT "21")
					 (TTYTST "23")
					 (FINGER "117")
					 (OCTAL
 (OR (FIXP FSKT)
						    (ERROR FSKT "BAD SOCKET")))))))
          (while
 (OPENP (SETQ FILE (COND
			    (HOST (PACK* "NET:" LSKT "." HOST "-" FSKT ";T"))
			    (T (PACK* "NET:<" (USERNAME)
				      ">" LSKT ".")))))
	     do
 (SETQ LSKT (CONCAT "0" LSKT)))
          (AND (NLSETQ (RESETVARS ((ERRORTYPELST (QUOTE ((23 (ERROR!)))))
				   HELPFLAG)
			          (SETQ FILE (OPENFILE FILE ACCESS (QUOTE OLD)
						       (OR BYTESIZE 8)
						       (COND
							 (DONTWAIT (COND
								     (NOBUFFER (QUOTE ((MODE 6))))
								     (T (QUOTE ((MODE 7))))))
							 (NOBUFFER NIL)
							 (T (QUOTE ((MODE 5)))))))))
	       (RETURN FILE))
          (SETQ FSKT (ERSTR))
          (COND
	    ((NULL HOST)
	      (SETQ HOST FILE))
	    ((NOT (ARPAHOSTP
 HOST))
	      (SETQQ FSKT "not valid host name")))
          (ERROR HOST FSKT))))

(FORCEOUT

  (LAMBDA (CONNECTION/FILE)             (* lmm "17-JUN-78 04:15")

                                        (* CONNECTION/FILE is a network 

					connection; forces buffered 

					bytes to go out)

    (JS MTOPR (OPNJFN (COND
			((GETHASH CONNECTION/FILE CONNECTIONARRAY)
			  (fetch OUT of CONNECTION/FILE))
			(T CONNECTION/FILE)))
	17)))

(OCTAL

  (LAMBDA (N)                           (* lmm "30-MAY-78 19:42")

                                        (* converts a number to a string

					of the octal representation of 

					it)

    (PROG ((J -1)
	   (S (CONSTANT (CONCAT "000000000000")))
	   (M N))
      LP  (RPLSTRING S J (LOGAND M 7))
          (COND
	    ((NOT (ZEROP (SETQ M (LRSH M 3))))
	      (SUB1VAR J)
	      (GO LP)))
          (RETURN (COND
		    ((EQ J -1)
		      N)
		    (T (CONCAT (SUBSTRING S J -1 (CONSTANT (CONCAT))))))
		  ))))

(FOPENP

  (LAMBDA (FILE)

          (* Equivalent to (COND ((FMEMB FILE (OPENP)) FILE)) i.e. does 

	  not do recognition)



    (ASSEMBLE NIL
	      (CQ FILE)
	      (MOVSI FX , -40Q)         (* compiled in max # files open)

	  FSC1(HRRZ 4 , FILEA (FX))
	      (CAIN 4 , 0 (1))
	      (JRST OUT)
	      (AOBJN FX , FSC1)
	      (HRRZ 1 , ' NIL)
	  OUT)))

(BADHOST

  (LAMBDA (HOST)                        (* lmm " 6-JUN-78 15:35")

    (ERROR HOST "Invalid host name")))

(ENABLEPROCESSCAPS

  (LAMBDA NIL                           (* lmm " 5-JUL-78 03:44")

    (JS EPCAP 400000Q NIL (XWD -1 0))))
)
(MOVD? (QUOTE NILL)
       (QUOTE PUPHOSTP))

(RPAQQ NETTIMEOUT
 20000)

(RPAQ CONNECTIONARRAY
 (LIST (HARRAY 17)))
(DECLARE: EVAL@COMPILE DONTCOPY 
[DECLARE: EVAL@COMPILE 

(RECORD CONNECTION
 (IN OUT CNTYPE . JOBFORK)
		   (HASHLINK CONNECTION (CONNECTIONSPECS CONNECTIONARRAY 17))
		   CONNECTION @ (GETHASH DATUM CONNECTIONARRAY))

(RECORD CONNECTIONSPECS
 (NAME . SOCKET))
]
(SETUPHASHARRAY (QUOTE CONNECTIONARRAY)
		17)


(PUTPROPS CLOSEF? BLKLIBRARYDEF
 (LAMBDA (X)
					(AND X (SETQ X (OPENP X))
					     (CLOSEF X))))

(LOAD? (QUOTE CJSYS.COM)
       (QUOTE SYSLOAD))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: CONNECTIONBLOCK (ENTRIES MAKENEWCONNECTION CHECKCONNECTION)
	ARPAPAIR CHECKCONNECTION MAKENEWCONNECTION (NOLINKFNS . T)
	(BLKLIBRARY CLOSEF?)
	(SPECVARS INF OUTF)
	(GLOBALVARS CONNECTIONARRAY LASTCONNECTION NETTIMEOUT)
	BADHOST CHECKBSP FOPENP)
(BLOCK: NIL ENABLEPROCESSCAPS STRINGTOCONNECTION CLOSECONNECTION NETUSER NETSERVER ARPAHOSTP 
	ARPAOPENF FORCEOUT OCTAL (LOCALVARS . T)
	(GLOBALVARS CONNECTIONARRAY))
]
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1148 16918 (MAKENEWCONNECTION 1160 . 5830) (STRINGTOCONNECTION 5834 . 6899) (
CHECKCONNECTION 6903 . 7319) (CHECKFORK 7323 . 9465) (CHECKTIMING 9469 . 10301) (CHECKBSP 10305 . 
11886) (CLOSECONNECTION 11890 . 12808) (NETUSER 12812 . 13160) (NETSERVER 13164 . 13408) (ARPAHOSTP 
13412 . 13537) (ARPAPAIR 13541 . 13973) (ARPAOPENF 13977 . 15326) (FORCEOUT 15330 . 15706) (OCTAL 
15710 . 16261) (FOPENP 16265 . 16650) (BADHOST 16654 . 16777) (ENABLEPROCESSCAPS 16781 . 16915)))))
STOP