X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=mim%2Fdevelopment%2Fmim%2Fvax%2Fmimlib%2Fnetbase.mud;fp=mim%2Fdevelopment%2Fmim%2Fvax%2Fmimlib%2Fnetbase.mud;h=6362cac1e7b105582e843d87dd9fbbb21cb865e2;hp=0000000000000000000000000000000000000000;hb=d73ace3f3292e320b461b8fcd2e9f5dc5d9684d7;hpb=d530283ea60fb0ddcc28e9c5bd072456afe06e07

diff --git a/mim/development/mim/vax/mimlib/netbase.mud b/mim/development/mim/vax/mimlib/netbase.mud
new file mode 100644
index 0000000..6362cac
--- /dev/null
+++ b/mim/development/mim/vax/mimlib/netbase.mud
@@ -0,0 +1,300 @@
+<PACKAGE "NETBASE">
+
+<ENTRY NETWORK NET-ADDRESS CONNECTION TIMEOUT CURRENT-CONNECTION NET-CHANNELS
+       TIME-NUM CLOSE-DATA-CHANNEL KILL-CHANNEL INPUT-WAITING DO-TIMEOUT>
+
+<INCLUDE-WHEN <COMPILING? "NETBASE"> "NETDEFS">
+
+<NEW-CHANNEL-TYPE NETWORK <>
+		  OPEN NETWORK-OPEN
+		  CLOSE NETWORK-CLOSE
+		  READ-BUFFER NETWORK-READ
+		  READ-BYTE NETWORK-READ-BYTE
+		  WRITE-BUFFER NETWORK-WRITE
+		  WRITE-BYTE NETWORK-WRITE-BYTE
+		  TIMEOUT NETWORK-TIMEOUT
+		  INPUT-WAITING NETWORK-TYPE-AHEAD?
+		  CLOSE-DATA-CHANNEL NET-CLOSE-ALT
+		  FILE-HANDLE NET-FILE-HANDLE>
+
+<COND (<NOT <VALID-TYPE? CONNECTION>>
+       <NEWTYPE CONNECTION VECTOR>
+       <NEWTYPE NET-ADDRESS UVECTOR>)>
+
+<SETG NET-CHANNELS ()>
+
+<DEFINE NET-FILE-HANDLE (CH:<CHANNEL 'NETWORK> OPER
+			 "AUX" (DATA:CONNECTION <CHANNEL-DATA .CH>))
+   <C-SOCKET .DATA>>
+
+<DEFINE NETWORK-TYPE-AHEAD? (CHANNEL:<CHANNEL 'NETWORK> OPER
+			     "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+			     (BUF:UVECTOR <STACK <IUVECTOR 1>>)
+			     (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
+                              .CHANNEL))
+   <COND (<CALL SYSCALL IOCTL <C-SOCKET .DATA> ,FIONREAD .BUF>
+	  <COND (<G? <1 .BUF> 0>
+		 <1 .BUF>)>)>>
+
+<DEFINE TIME-NUM (UV:<UVECTOR [2 FIX]> "OPT" NEW:<OR FIX FLOAT> "AUX" OLD)
+   <SET OLD
+	<COND (<0? <2 .UV>> <1 .UV>)
+	      (T
+	       <+ <FLOAT <1 .UV>> </ <FLOAT <2 .UV>> 1000000.0>>)>>
+   <COND (<NOT <ASSIGNED? NEW>>)
+	 (<TYPE? .NEW FIX>
+	  <2 .UV 0>
+	  <1 .UV .NEW>)
+	 (T
+	  <1 .UV <FIX .NEW>>
+	  <2 .UV <FIX <* 1000000.0 <- .NEW <1 .UV>>>>>)>
+   .OLD>
+
+<DEFINE NETWORK-TIMEOUT (CHANNEL:<CHANNEL 'NETWORK> OPER
+                         "OPT" NEW:<OR FIX FLOAT FALSE>
+			 "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>) 
+                         UV (OLD <>))
+   <COND (<SET UV <C-TIMEOUT .DATA>>
+	  <SET OLD <TIME-NUM .UV>>)>
+   <COND (<NOT <ASSIGNED? NEW>>)
+	 (<NOT .NEW> <C-TIMEOUT .DATA <>>)
+	 (T
+	  <COND (<NOT .UV><SET UV <IUVECTOR 2>>)>
+	  <TIME-NUM .UV .NEW>
+	  <C-TIMEOUT .DATA .UV>)>
+   .OLD>
+
+<DEFINE NETWORK-OPEN (TYPE OPER NAME:<OR STRING FALSE>
+		      "OPTIONAL" SERVICE:<OR NET-ADDRESS FIX>
+		      (H:<OR NET-ADDRESS FIX> <CALL SYSCALL GETHOSTID>)
+		      (NS:<OR FIX FALSE> <>)
+		      "AUX" S
+		      (FA <STACK <IUVECTOR ,ADDR-WORD-LEN>>)
+		      (ADDR:NET-ADDRESS <CHTYPE .FA NET-ADDRESS>)
+		      ERR KIND:FIX PROT:FIX SERVSOCK:FIX)
+	<COND
+	 (<NOT <ASSIGNED? SERVICE>>
+	  <ERROR TOO-FEW-ARGUMENTS!-ERRORS
+		 CHANNEL-OPEN
+		 NETWORK>)
+	 (<NOT .NS>
+	  <COND (<TYPE? .SERVICE NET-ADDRESS>
+		 <SET SERVSOCK <IN-ADDR-PORT .SERVICE>>
+		 <SET PROT ,PROT-TCP>
+		 <SET KIND ,SOCK-STREAM>
+		 <SET H <NA-HOST .SERVICE>>
+		 <SET ADDR .SERVICE>
+		 <SET SERVICE <PUTLHW .SERVSOCK .PROT>>)
+		(T
+		 <SET PROT <LHW .SERVICE>>
+		 <SET SERVSOCK <RHW .SERVICE>>
+		 <COND (<==? .PROT ,PROT-UDP> <SET KIND ,SOCK-DGRAM>)
+		       (T <SET KIND ,SOCK-STREAM>)>
+		 <BUILD-ADDRESS .SERVICE .H .ADDR>)>
+	  <COND (<SET S <CALL SYSCALL SOCKET ,AF-INET .KIND .PROT>>
+		 <COND (<NOT <SET ERR <CALL SYSCALL CONNECT
+					    .S .ADDR ,ADDR-LEN>>>
+			<CALL SYSCALL CLOSE .S>
+			.ERR)
+		       (T
+			<SETG NET-CHANNELS (.S .CURRENT-CHANNEL
+					    !,NET-CHANNELS)>
+			<CHTYPE [.S <CHTYPE <UVECTOR !.ADDR>
+					    NET-ADDRESS>
+				 .SERVICE 0 <> <>]
+				CONNECTION>)>)>)
+	 (T
+	  <SETG NET-CHANNELS (.NS .CURRENT-CHANNEL
+			      !,NET-CHANNELS)>
+	  <CHTYPE [.NS <CHTYPE <UVECTOR !.H> NET-ADDRESS>
+		   .SERVICE 0 <> <>] CONNECTION>)>>
+
+<DEFINE KILL-CHANNEL (CHANNEL:CHANNEL
+		      "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+		      L:<OR FALSE LIST>)
+   <COND (<SET L <MEMQ <C-SOCKET .DATA> ,NET-CHANNELS>>
+	  <COND (<==? .L ,NET-CHANNELS>
+		 <SETG NET-CHANNELS <REST ,NET-CHANNELS 2>>)
+		(T
+		 <PUTREST <REST ,NET-CHANNELS <- <LENGTH ,NET-CHANNELS>
+						 <LENGTH .L>
+						 1>>
+			  <REST .L 2>>)>)>>
+
+<DEFINE NET-CLOSE-ALT (C:<CHANNEL 'NETWORK> OPER
+		       "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC)
+   <COND (<TYPE? <SET NC <C-ALTCHANNEL .DATA>> CHANNEL>
+	  <COND (<CHANNEL-OPEN? .NC>
+		 <CHANNEL-CLOSE .NC>)>
+	  <C-ALTCHANNEL .DATA <>>)
+	 (<TYPE? .NC FIX>
+	  <CALL SYSCALL CLOSE .NC>
+	  <C-ALTCHANNEL .DATA <>>)>>
+
+<DEFINE NETWORK-CLOSE (CHANNEL:<CHANNEL 'NETWORK> OPER
+		       "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>))
+        <COND (<C-ALTCHANNEL .DATA>
+	       <CHANNEL-OP .CHANNEL CLOSE-DATA-CHANNEL>)>
+	<KILL-CHANNEL .CHANNEL>
+	<CALL SYSCALL CLOSE <C-SOCKET .DATA>>
+	<C-SOCKET .DATA -1>
+	.CHANNEL>
+
+<DEFINE NETWORK-WRITE (CHANNEL:<CHANNEL 'NETWORK> OPER
+		       "TUPLE" STUFF
+		       "AUX" (CT:FIX <LENGTH .STUFF>)
+		       (IOV:UVECTOR <STACK <IUVECTOR .CT>>) RLEN
+		       (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+		       FROB:<OR STRING UVECTOR> 
+		       NC:<OR FIX FALSE>
+		       (CURRENT-CONNECTION:<SPECIAL CHANNEL> .CHANNEL))
+   #DECL ((STUFF) <<PRIMTYPE VECTOR>
+				      [REST <OR STRING UVECTOR>
+				       <OR FALSE FIX>]>)
+   <COND
+    (<L=? .CT 2>
+     <SET FROB <1 .STUFF>>
+     <COND (<OR <==? .CT 1> <NOT <2 .STUFF>>>
+	    <COND (<TYPE? .FROB STRING> <SET CT <LENGTH .FROB>>)
+		  (T <SET CT <LENGTH .FROB>>)>)
+	   (T
+	    <SET CT <2 .STUFF>>)>
+     <SET RLEN .CT>
+     <COND (<TYPE? .FROB UVECTOR> <SET CT <* .CT 4>>)>
+     <PROG ()
+	<COND (<SET NC <ISYSCALL WRITE <C-SOCKET .DATA>
+				 .FROB .CT>>
+	       <COND (<L? .NC .CT>
+		      <SET CT <- .CT .NC>>
+		      <COND (<TYPE? .FROB UVECTOR>
+			     <SET FROB <REST .FROB </ .NC 4>>>)
+			    (T
+			     <SET FROB <REST .FROB .NC>>)>
+		      <AGAIN>)>
+	       .RLEN)>>)
+    (T
+     <SET NC <MAKE-ARGS .STUFF .IOV>>
+     <PROG (NEW (RES 0))
+	<COND
+	 (<SET NEW <ISYSCALL WRITEV <C-SOCKET .DATA> .IOV </ .CT 2>>>
+	  <COND (<G? <SET NC <- .NC .NEW>> 0>
+		 <SET RES <+ <GET-COUNT .STUFF .IOV .NEW T> .RES>>
+		 <AGAIN>)
+		(T
+		 <SET RES <+ <GET-COUNT .STUFF .IOV .NEW> .RES>>)>
+	  .RES)>>)>>
+
+<DEFINE NETWORK-READ-BYTE (CHANNEL:<CHANNEL 'NETWORK> OPER "AUX"
+			   (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+			   (BUF <STACK <ISTRING 1>>)
+			   (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
+                            .CHANNEL)
+			   RES:<OR FIX FALSE>)
+   <COND
+    (<OR <NOT <C-TIMEOUT .DATA>>
+	 <DO-TIMEOUT .DATA>>
+     <COND
+      (<AND <SET RES <ISYSCALL READ <C-SOCKET .DATA> .BUF 1>>
+	    <G? .RES 0>>
+       <1 .BUF>)>)>>
+
+<DEFINE NETWORK-WRITE-BYTE (CHANNEL:<CHANNEL 'NETWORK> OPER BYTE:<OR FIX CHARACTER>
+			    "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+			    (BUF1 <STACK <ISTRING 1>>)
+			    (BUF2 <STACK <IUVECTOR 1>>)
+			    (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>> 
+                             .CHANNEL))
+   <COND (<TYPE? .BYTE FIX>
+	  <1 .BUF2 .BYTE>
+	  <COND (<NETWORK-WRITE .CHANNEL .OPER .BUF2 1> .BYTE)>)
+	 (T
+	  <1 .BUF1 .BYTE>
+	  <COND (<ISYSCALL WRITE <C-SOCKET .DATA> .BUF1 1> .BYTE)>)>>
+
+
+
+<DEFINE DO-TIMEOUT (DATA:CONNECTION "AUX" (BUF <STACK <IUVECTOR 1>>)
+		    RES:<OR FIX FALSE>)
+   <1 .BUF <LSH 1 <C-SOCKET .DATA>>>
+   <COND
+    (<SET RES
+	  <ISYSCALL SELECT <+ <C-SOCKET .DATA> 1> .BUF 0 0 <C-TIMEOUT .DATA>>>
+     <COND (<0? .RES> ,TIMED-OUT)
+	   (T)>)>>
+
+<DEFINE NETWORK-READ (CHANNEL:<CHANNEL 'NETWORK> OPER
+		      "TUPLE" STUFF
+		      "AUX" (CT:FIX <LENGTH .STUFF>)
+		      (IOV:UVECTOR <STACK <IUVECTOR .CT>>)
+		      (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+		      LAST FROB:<OR STRING UVECTOR> RES:<OR FIX FALSE>
+		      (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>> 
+                       .CHANNEL))
+   #DECL ((STUFF) <<PRIMTYPE VECTOR>
+		   [REST <OR STRING UVECTOR>
+		    <OR FIX FALSE>]>)
+   <COND (<OR <NOT <C-TIMEOUT .DATA>>
+	      <DO-TIMEOUT .DATA>>
+	  <COND
+	   (<L=? .CT 2>
+	    <SET FROB <1 .STUFF>>
+	    <COND (<OR <==? .CT 1> <NOT <2 .STUFF>>>
+		   <COND (<TYPE? .FROB STRING> <SET CT <LENGTH .FROB>>)
+			 (T <SET CT <LENGTH .FROB>>)>)
+		  (T <SET CT <2 .STUFF>>)>
+	    <COND (<TYPE? .FROB UVECTOR> <SET CT <* .CT 4>>)>
+	    <COND (<SET RES <ISYSCALL READ <C-SOCKET .DATA> .FROB .CT>>
+		   <COND (<TYPE? .FROB UVECTOR>
+			  </ <+ .RES 3> 4>)
+			 (.RES)>)>)
+	   (T
+	    <MAKE-ARGS .STUFF .IOV>
+	    <COND
+	     (<SET RES <ISYSCALL READV <C-SOCKET .DATA> .IOV </ .CT 2>>>
+	      <GET-COUNT .STUFF .IOV .RES>)>)>)>>
+
+<DEFINE GET-COUNT (STUFF:<<PRIMTYPE VECTOR> [REST <OR STRING UVECTOR>
+					     <OR FALSE FIX>]>
+		   IOV:<UVECTOR [REST FIX]>
+		   CT:FIX "OPT" (WRITE?:<OR ATOM FALSE> <>))
+   <REPEAT ((NC 0) FROB LEN NEW)
+      <COND (<OR <EMPTY? .STUFF>
+		 <L=? .CT 0>>
+	     <RETURN .NC>)>
+      <SET LEN <2 .IOV>>
+      <COND (.WRITE?
+	     <2 .IOV <SET NEW <MAX 0 <- .LEN .CT>>>>
+	     <1 .IOV <+ <1 .IOV> <- .LEN .NEW>>>)>
+      <SET NEW <MIN .CT .LEN>>
+      <SET CT <- .CT .NEW>>
+      <COND (<TYPE? <1 .STUFF> UVECTOR>
+	     <SET NEW </ <+ .NEW 3> 4>>)>
+      <SET NC <+ .NC .NEW>>
+      <SET IOV <REST .IOV 2>>
+      <SET STUFF <REST .STUFF 2>>>>
+
+<DEFINE MAKE-ARGS (STUFF:<<PRIMTYPE VECTOR>
+			  [REST <OR STRING UVECTOR> <OR FALSE FIX>]>
+		   IOV:<UVECTOR [REST FIX]>)
+  <COND (<NOT <0? <MOD <LENGTH .STUFF> 2>>>
+	 <ERROR ARGUMENT-VECTOR-IS-BAD-LENGTH!-ERROR
+		.STUFF NETWORK-READ/WRITE>)>
+  <REPEAT (THING LEN (CT 0))
+     <COND (<EMPTY? .STUFF> <RETURN .CT>)>
+     <SET LEN <2 .STUFF>>
+     <COND (<TYPE? <SET THING <1 .STUFF>> UVECTOR>
+	    <COND (<NOT .LEN>
+		   <SET LEN <LENGTH .THING>>
+		   <2 .STUFF .LEN>)>
+	    <SET LEN <* 4 .LEN>>)
+	   (T
+	    <COND (<NOT .LEN>
+		   <SET LEN <LENGTH .THING>>
+		   <2 .STUFF .LEN>)>)>
+     <1 .IOV <CALL VALUE .THING>>
+     <2 .IOV .LEN>
+     <SET CT <+ .CT .LEN>>
+     <SET STUFF <REST .STUFF 2>>
+     <SET IOV <REST .IOV 2>>>>
+
+<ENDPACKAGE>