--- /dev/null
+<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>
projects / pdp10-muddle.git / blobdiff