Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
(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