--- /dev/null
+<PACKAGE "NETWORK">
+
+<ENTRY GET-HOST GET-SERVICE GET-PROTOCOL GET-ADDR
+ NO-BLOCK? INTERRUPT? CONNECTION-LOST CONNECTION-READY
+ CONNECTION-URGENT CHAN-SELECT SEND RECEIVE NET-SERVER
+ SERVER-INIT SERVER-WAIT
+ GET-ADDRESS LISTEN-ON-DATA CONNECT-DATA-CHANNEL
+ GET-DATA-ADDRESS WRAP-SOCKET>
+
+<USE "NETBASE">
+
+<INCLUDE-WHEN <COMPILING? "NETWORK"> "NETDEFS">
+
+<EXPORT "NETBASE">
+
+<ADD-CHANNEL-OPS NETWORK
+ READ-SAFE-BUFFER NETWORK-READ-SAFE
+ GET-HOST NETWORK-GET ;"DONE"
+ GET-SERVICE NETWORK-GET ;"DONE"
+ GET-PROTOCOL NETWORK-GET ;"DONE"
+ GET-ADDR NETWORK-GET ;"DONE"
+ NO-BLOCK? NETWORK-SET
+ INTERRUPT? NETWORK-SET
+ SEND NETWORK-SEND
+ RECEIVE NETWORK-RECEIVE
+ GET-ADDRESS NET-GET-ADDRESS
+ LISTEN-ON-DATA NET-MAKE-ALT
+ CONNECT-DATA-CHANNEL NET-ACCEPT-CONN
+ GET-DATA-ADDRESS NET-GET-DADDR>
+
+<DEFINE NETWORK-SEND (CHANNEL:<CHANNEL 'NETWORK> OPER BUF:<OR STRING UVECTOR>
+ "OPT" (LEN:FIX <COND (<TYPE? .BUF UVECTOR> <LENGTH .BUF>)
+ (<LENGTH .BUF>)>)
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+ (FLAG:FIX 0) RES:<OR FIX FALSE>)
+ <COND (<N==? <LHW <C-SERVICE .DATA>> ,PROT-UDP>
+ <SET FLAG 1>)>
+ <COND
+ (<SET RES
+ <CALL SYSCALL SEND <C-SOCKET .DATA> .BUF
+ <COND (<TYPE? .BUF UVECTOR> <* 4 .LEN>) (T .LEN)> .FLAG>>
+ <COND (<TYPE? .BUF UVECTOR> </ .RES 4>)
+ (T .RES)>)>>
+
+<DEFINE NETWORK-RECEIVE (CHANNEL:<CHANNEL 'NETWORK> OPER BUF:<OR UVECTOR STRING>
+ "OPT" (LEN:FIX <COND (<TYPE? .BUF STRING>
+ <LENGTH .BUF>)
+ (T <LENGTH .BUF>)>)
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+ (FLAG:FIX 0) RES:<OR FIX FALSE>)
+ <COND (<N==? <LHW <C-SERVICE .DATA>> ,PROT-UDP>
+ <SET FLAG 1>)>
+ <COND
+ (<OR <NOT <C-TIMEOUT .DATA>>
+ <DO-TIMEOUT .DATA>>
+ <COND
+ (<SET RES <ISYSCALL RECV <C-SOCKET .DATA> .BUF
+ <COND (<TYPE? .BUF UVECTOR> <* 4 .LEN>)(T .LEN)>
+ .FLAG>>
+ <COND (<TYPE? .BUF UVECTOR> </ .RES 4>)
+ (T .RES)>)>)>>
+
+<DEFINE NETWORK-SET (CHANNEL:<CHANNEL 'NETWORK> OPER:ATOM "OPT" NEW:<OR ATOM FALSE>
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+ FLAG:FIX)
+ <COND (<==? .OPER INTERRUPT?>
+ <SET FLAG ,FASYNC>)
+ (<==? .OPER NO-BLOCK?>
+ <SET FLAG ,FNDELAY>)>
+ <COND
+ (<NOT <ASSIGNED? NEW>>
+ <NOT <0? <ANDB .FLAG <C-FLAGS .DATA>>>>)
+ (T
+ <C-FLAGS .DATA <ORB .FLAG <C-FLAGS .DATA>>>
+ <PROG ((CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>> .CHANNEL))
+ <COND
+ (<CALL SYSCALL FCNTL <C-SOCKET .DATA> ,F-SETFL <C-FLAGS .DATA>>
+ .NEW)>>)>>
+
+<DEFINE WRAP-SOCKET (S:FIX
+ "AUX" (ADDR:NET-ADDRESS
+ <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
+ NET-ADDRESS>) (TUV <STACK <IUVECTOR 1>>))
+ <COND (<CALL SYSCALL GETSOCKNAME .S .ADDR .TUV>
+ <CHANNEL-OPEN NETWORK "RAND" 0 .ADDR .S>)>>
+
+<DEFINE NETWORK-READ-SAFE (CHANNEL:<CHANNEL 'NETWORK> OPER
+ "TUPLE" STUFF
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+ (BUF:UVECTOR <STACK <IUVECTOR 1>>)
+ RES:<OR FIX FALSE>
+ (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
+ .CHANNEL))
+ #DECL ((STUFF) <<PRIMTYPE VECTOR>
+ [REST <OR STRING UVECTOR>
+ <OR FIX FALES>]>)
+ <COND (<OR <NETWORK-SET .CHANNEL NO-BLOCK?>
+ <AND <SET RES <CALL SYSCALL IOCTL
+ <C-SOCKET .DATA> ,FIONREAD .BUF>>
+ <G? <1 .BUF> 0>>>
+ <NETWORK-READ .CHANNEL .OPER !.STUFF>)
+ (.RES 0)>>
+
+<DEFINE NETWORK-GET (CHANNEL:<CHANNEL 'NETWORK> OPER:ATOM
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
+ (ADDR <C-ADDR .DATA>))
+ <COND (<==? .OPER GET-HOST>
+ <NA-HOST .ADDR>)
+ (<==? .OPER GET-SERVICE>
+ <C-SERVICE .DATA>)
+ (<==? .OPER GET-ADDR>
+ .ADDR)
+ (<==? .OPER GET-PROTOCOL>
+ <LHW <C-SERVICE .DATA>>)>>
+
+<DEFINE NET-PIPE-HANDLER (IGN "AUX" CHN)
+ <COND (<AND <ASSIGNED? CURRENT-CONNECTION>
+ <SET CHN .CURRENT-CONNECTION>>
+ <KILL-CHANNEL .CHN>)>
+ <COND (<NETWORK-SET .CHN INTERRUPT?>
+ <INTERRUPT "NETWORK" .CHN CONNECTION-LOST>)>>
+
+<DEFINE NET-SIGIO-HANDLER (IGN "AUX" (RBUF:UVECTOR <STACK <IUVECTOR 1>>)
+ (EBUF:UVECTOR <STACK <IUVECTOR 1>>) (RFL:FIX 0)
+ (EFL:FIX 0) (MAX:FIX -1) FOUND:<OR FALSE FIX>)
+ <REPEAT ((L:<LIST [REST FIX CHANNEL]> ,NET-CHANNELS) S)
+ <COND (<EMPTY? .L> <RETURN>)>
+ <SET EFL <ORB .EFL <LSH 1 <SET S <1 .L>>>>>
+ <SET RFL <ORB .RFL <LSH 1 .S>>>
+ <SET MAX <MAX .MAX .S>>>
+ <COND (<G=? .MAX 0>
+ <1 .EBUF .EFL>
+ <1 .RBUF .RFL>
+ <COND
+ (<SET FOUND <CALL SYSCALL SELECT <+ .MAX 1> .RBUF 0 .EBUF>>
+ <POKE .EBUF CONNECTION-URGENT .MAX>
+ <POKE .RBUF CONNECTION-READY .MAX>)>)>>
+
+<DEFINE POKE (BUF:<UVECTOR [REST FIX]> WHICH MAX:FIX
+ "AUX" (L:<LIST [REST FIX <CHANNEL 'NETWORK>]> ,NET-CHANNELS))
+ <REPEAT ((CUR 0) (BITS <1 .BUF>) NL:<OR LIST FALSE>)
+ <COND
+ (<NOT <0? <ANDB .BITS <LSH 1 .CUR>>>>
+ <COND
+ (<SET NL <MEMQ .CUR ,NET-CHANNELS>>
+ <INTERRUPT "NETWORK" <2 .NL> .WHICH>)>)>
+ <COND (<G? <SET CUR <+ .CUR 1>> .MAX>
+ <RETURN>)>>>
+
+<DEFINE CHAN-SELECT (TIMEOUT:<OR FIX FLOAT FALSE>
+ "TUPLE" STUFF
+ "AUX" (RBUF <STACK <IUVECTOR 1>>)
+ (EBUF <STACK <IUVECTOR 1>>) (RFL 0)
+ (TIMEVAL <STACK <IUVECTOR 2>>)
+ (HANDLES <STACK <IUVECTOR </ <LENGTH .STUFF> 2> -1>>)
+ (MAX:FIX -1))
+ #DECL ((STUFF) <<PRIMTYPE VECTOR>
+ [REST <CHANNEL 'NETWORK> <OR APPLICABLE FALSE>]>)
+ <COND (.TIMEOUT
+ <TIME-NUM .TIMEVAL .TIMEOUT>)>
+ <REPEAT (CHN:<CHANNEL 'NETWORK> (TST .STUFF) H:FIX (HAND .HANDLES))
+ <COND (<EMPTY? .TST> <RETURN>)>
+ <COND (<SET H <CHANNEL-OP <1 .TST> FILE-HANDLE>>
+ <1 .HAND .H>
+ <SET MAX <MAX .H .MAX>>
+ <SET RFL <ORB .RFL <LSH 1 .H>>>)>
+ <SET TST <REST .TST 2>>
+ <SET HAND <REST .HAND>>>
+ <COND
+ (<G=? .MAX 0>
+ <REPEAT (RES)
+ <1 .RBUF .RFL>
+ <1 .EBUF .RFL>
+ <COND (<SET RES <ISYSCALL SELECT <+ .MAX 1> .RBUF 0 .EBUF
+ <COND (.TIMEOUT .TIMEVAL) (T 0)>>>
+ <COND (<INVOKE <ORB <1 .RBUF> <1 .EBUF>> .STUFF .HANDLES .MAX>
+ <RETURN>)>)
+ (T
+ <RETURN .RES>)>>)>>
+
+<DEFINE INVOKE (BITS:FIX STUFF:<<PRIMTYPE VECTOR> [REST <CHANNEL 'NETWORK>
+ <OR APPLICABLE FALSE>]>
+ HANDLES:<UVECTOR [REST FIX]> MAX:FIX
+ "AUX" (CUR:FIX 0))
+ <REPEAT (HH:UVECTOR TS:<PRIMTYPE VECTOR>)
+ <COND (<NOT <0? <ANDB <LSH 1 .CUR> .BITS>>>
+ <SET HH <MEMQ .CUR .HANDLES>>
+ <SET TS <REST .STUFF <* 2 <- <LENGTH .HANDLES> <LENGTH .HH>>>>>
+ <COND (<NOT <2 .TS>> <RETURN>)>
+ <APPLY <2 .TS> <1 .TS>>)>
+ <COND (<G? <SET CUR <+ .CUR 1>> .MAX> <RETURN <>>)>>>
+
+<COND (<GASSIGNED? NET-PIPE-HANDLER>
+ <ON <HANDLER "PIPE" ,NET-PIPE-HANDLER>>)>
+
+<COND (<GASSIGNED? NET-SIGIO-HANDLER>
+ <ON <HANDLER "IOINT" ,NET-SIGIO-HANDLER>>
+ <ON <HANDLER "SOCKET" ,NET-SIGIO-HANDLER>>)>
+
+\f
+<DEFINE SERVER-WAIT (S:FIX "OPT" (TIMEOUT:<OR FIX FLOAT FALSE> <>)
+ (ADDR:NET-ADDRESS <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
+ NET-ADDRESS>)
+ "AUX" NS (BUF <STACK <IUVECTOR 1>>) RS
+ (TO <STACK <IUVECTOR 2>>) RES
+ (PT <STACK <UVECTOR ,ADDR-LEN>>))
+ <COND (.TIMEOUT
+ <TIME-NUM .TO .TIMEOUT>)
+ (T
+ <SET TO 0>)>
+ <SET RS <RHW .S>>
+ <1 .BUF <LSH 1 .RS>>
+ <COND (<SET RES
+ <ISYSCALL SELECT <+ .RS 1> .BUF 0 0 .TO>:<OR FIX FALSE>>
+ <COND (<0? .RES> ,TIMED-OUT)
+ (T
+ <COND (<==? <LHW .S> ,SOCK-STREAM>
+ <COND (<SET S <ISYSCALL ACCEPT .RS .ADDR .PT>>
+ <CHANNEL-OPEN NETWORK "SERVER" 0
+ .ADDR .S>)>)
+ (T
+ <ERROR NOT-SUPPORTED .S SERVER-WAIT>)>)>)>>
+
+<DEFINE SERVER-INIT (SERVICE:FIX "OPT" (HOST:FIX 0)
+ "AUX" (PROT <LHW .SERVICE>)
+ (SERVSOCK <RHW .SERVICE>) KIND S ERR
+ (ADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
+ NET-ADDRESS>))
+ <COND (<==? .PROT ,PROT-UDP> <SET KIND ,SOCK-DGRAM>)
+ (T <SET KIND ,SOCK-STREAM>)>
+ <COND (<SET S <CALL SYSCALL SOCKET ,AF-INET .KIND .PROT>>
+ <BUILD-ADDRESS .SERVICE .HOST .ADDR>
+ <COND
+ (<==? .KIND ,SOCK-STREAM>
+ <COND (<AND <SET ERR <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
+ <SET ERR <CALL SYSCALL LISTEN .S 5>>>
+ <PUTLHW .S .KIND>)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ .ERR)>)
+ (T
+ <COND (<SET ERR <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
+ <PUTLHW .S .KIND>)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ .ERR)>)>)>>
+
+<DEFINE NET-SERVER (SERVICE:FIX ROUTINE:APPLICABLE "OPTIONAL" (H:FIX 0)
+ "AUX"
+ S NS
+ (NADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
+ NET-ADDRESS>)
+ (PT <STACK <IUVECTOR 1>>))
+ #DECL ((SERVICE H) FIX)
+ <COND (<SET S <SERVER-INIT .SERVICE .H>>
+ <COND (<==? <LHW .S> ,SOCK-STREAM>
+ <REPEAT (CH)
+ <COND (<SET CH <SERVER-WAIT .S <> .NADDR>>
+ <APPLY .ROUTINE .CH>)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ <RETURN .CH>)>>)
+ (T
+ <COND (<NOT <GASSIGNED? MSG-BUF>>
+ <SETG MSG-BUF <ISTRING 512>>)>
+ <SET S <RHW .S>>
+ <REPEAT (LEN)
+ <COND (<SET LEN <ISYSCALL RECVFROM .S ,MSG-BUF 512
+ 0 .NADDR .PT>>
+ <APPLY .ROUTINE ,MSG-BUF .LEN .NADDR .PT>)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ <RETURN .LEN>)>>)>)>>
+
+<GDECL (MSG-BUF) STRING>
+\f
+<DEFINE NET-GET-ADDRESS (CHANNEL:<CHANNEL 'NETWORK> OPER
+ "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>) "AUX"
+ (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>))
+ <GET-ADDRESS <C-SOCKET .DATA> .ADDR>>
+
+<DEFINE GET-ADDRESS (SOCK:FIX "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>)
+ "AUX" (TBUF <STACK <UVECTOR ,ADDR-LEN>>))
+ <COND (<NOT .ADDR> <SET ADDR <CHTYPE <IUVECTOR ,ADDR-WORD-LEN 0>
+ NET-ADDRESS>>)>
+ <CALL SYSCALL GETSOCKNAME .SOCK .ADDR .TBUF>
+ .ADDR>
+
+<DEFINE NET-MAKE-ALT (C:<CHANNEL 'NETWORK> OPER
+ "OPT" (TYPE:FIX ,SOCK-STREAM) (PORT 0)
+ "AUX" S RES NC (DATA:CONNECTION <CHANNEL-DATA .C>)
+ (ADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN 0>>
+ NET-ADDRESS>))
+ <COND (<C-ALTCHANNEL .DATA>)
+ (<SET S <CALL SYSCALL SOCKET ,AF-INET
+ .TYPE
+ <COND (<==? .TYPE ,SOCK-STREAM> ,PROT-TCP)
+ (T ,PROT-UDP)>>>
+ <CHANNEL-OP .C GET-ADDRESS .ADDR>
+ <IN-ADDR-PORT .ADDR .PORT>
+ <COND (<SET RES <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
+ <COND (<SET RES <CALL SYSCALL LISTEN .S 1>>
+ <C-ALTCHANNEL .DATA .S>
+ .C)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ .RES)>)
+ (T
+ <CALL SYSCALL CLOSE .S>
+ .RES)>)>>
+
+<DEFINE NET-GET-DADDR (C:<CHANNEL 'NETWORK> OPER
+ "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>)
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC)
+ <COND (<SET NC <C-ALTCHANNEL .DATA>>
+ <COND (<TYPE? .NC FIX>
+ <GET-ADDRESS .NC .ADDR>)
+ (T
+ <CHANNEL-OP .NC GET-ADDRESS .ADDR>)>)>>
+
+<DEFINE NET-ACCEPT-CONN (C:<CHANNEL 'NETWORK> OPER "OPT" (SERVICE:FIX 0)
+ "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC
+ (NADDR:NET-ADDRESS
+ <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN 0>>
+ NET-ADDRESS>) (BUF <STACK <IUVECTOR 1>>)
+ (PT:UVECTOR <STACK <IUVECTOR 1>>) RES:<OR FIX FALSE>
+ NS:<OR FIX FALSE> CH)
+ <COND (<TYPE? <SET NC <C-ALTCHANNEL .DATA>> FIX>
+ <COND (<OR <NOT <C-TIMEOUT .DATA>>
+ <AND <SET RES <ISYSCALL SELECT <+ .NC 1>
+ <1 .BUF <LSH 1 .NC>> 0 0
+ <C-TIMEOUT .DATA>>>
+ <NOT <0? .RES>>>>
+ <COND (<SET NS <ISYSCALL ACCEPT .NC .NADDR .PT>>
+ <SET CH <CHANNEL-OPEN NETWORK "DATA" .SERVICE .NADDR .NS>>
+ <C-ALTCHANNEL .DATA .CH>)>
+ <CALL SYSCALL CLOSE .NC>
+ <COND (.NS .CH)>)
+ (<0? .RES> ,TIMED-OUT)
+ (.RES)>)
+ (.NC #FALSE ("ALREADY CONNECTED"))
+ (T #FALSE ("NOT LISTENING"))>>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff