--- /dev/null
+<PACKAGE "FORKS">
+
+<ENTRY FORK FORK-STATUS? CONTINUE-FORK PASS-TTY-DOWN TAKE-TTY-BACK
+ WAIT-FORK STOP-FORK RUN-FORK RUN-PIPED>
+<ENTRY GET-INPUT GET-OUTPUT>
+<ENTRY FORK-STATUS-QUIT FORK-STATUS-KILLED FORK-STATUS-DIED
+ FORK-STATUS-DEAD FORK-STATUS-RUNNING FORK-STATUS-STOPPED
+ FORK-STATUS-WAIT>
+
+<USE "NEWSTRUC" "PIPES">
+
+<ENV-COND (("MACHINE" "VAX")
+ <NEW-CHANNEL-TYPE FORK <>
+ GET-INPUT GET-INPUT
+ GET-OUTPUT GET-INPUT
+ FORK-STATUS? TEST-FORK-STATUS
+ READ-BYTE FORK-READ
+ READ-BUFFER FORK-READ
+ READ-SAFE-BUFFER FORK-READ
+ WRITE-BYTE FORK-WRITE
+ WRITE-BUFFER FORK-WRITE
+ ;"READ-MEMORY ;FORK-READ-MEMORY
+ ;WRITE-MEMORY ;FORK-WRITE-MEMORY
+ ;READ-ACS ;FORK-READ-ACS
+ ;WRITE-ACS ;FORK-WRITE-ACS"
+ CONTINUE-FORK CONTINUE-FORK
+ KILL-FORK KILL-FORK
+ CLOSE KILL-FORK
+ PASS-TTY-DOWN PASS-TTY-DOWN
+ TAKE-TTY-BACK TAKE-TTY-BACK
+ WAIT-FORK WAIT-FORK
+ STOP-FORK STOP-FORK
+ OPEN OPEN-FORK
+ PRINT-DATA FORK-PRINT-DATA>)>
+
+<NEWSTRUC FORK VECTOR
+ FORK-ID FIX
+ FORK-GRP FIX
+ FORK-STS FIX
+ FORK-DATA FIX
+ FORK-INPUT <OR CHANNEL FIX FALSE>
+ FORK-OUTPUT <OR CHANNEL FIX FALSE>>
+
+<MSETG ST-BIT-TTY-WAIT *400000*>
+<MSETG ST-BIT-HAD-TTY *200000*>
+<MSETG ST-BIT-TTY *100000*>
+<MSETG ST-BIT-RUNNING *40000*>
+<MSETG ST-BIT-DEAD *20000*>
+<MSETG ST-BIT-OTHER *777*>
+<MSETG ST-OTH-KILLED *1*>
+<MSETG ST-OTH-QUIT 2>
+<MSETG ST-OTH-DIED 3>
+
+<MSETG TERM-CONT *177*>
+
+<MSETG STATUS-TTY <CHTYPE <ORB ,ST-BIT-TTY ,ST-BIT-RUNNING> FIX>>
+<MSETG STATUS-RUNNING ,ST-BIT-RUNNING>
+<MSETG STATUS-KILLED <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-KILLED> FIX>>
+<MSETG STATUS-DIED <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-DIED> FIX>>
+<MSETG STATUS-QUIT <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-QUIT> FIX>>
+
+<DEFMAC FORK-STS? ('FORK 'BIT)
+ <FORM NOT
+ <FORM 0? <FORM ANDB <FORM FORK-STS .FORK> .BIT>>>>
+
+<DEFMAC SET-FORK-STS ('FORK "TUPLE" STATS "AUX" (ON 0) (OFF 0))
+ <REPEAT (WD)
+ <COND (<EMPTY? .STATS> <RETURN>)>
+ <COND (<TYPE? <SET WD <1 .STATS>> LIST>
+ <SET OFF <ORB .OFF !.WD>>)
+ (<SET ON <ORB .ON .WD>>)>
+ <SET STATS <REST .STATS>>>
+ <SET OFF <CHTYPE .OFF FIX>>
+ <SET ON <CHTYPE .ON FIX>>
+ <COND (<NOT <0? <CHTYPE <ANDB .ON ,ST-BIT-DEAD> FIX>>>
+ <SET OFF <CHTYPE <ORB .OFF ,ST-BIT-RUNNING> FIX>>)>
+ <FORM BIND ()
+ <COND (<NOT <0? .OFF>>
+ <FORM FORK-STS .FORK <FORM ANDB <FORM FORK-STS .FORK>
+ <CHTYPE <XORB .OFF -1> FIX>>>)>
+ <COND (<NOT <0? .ON>>
+ <FORM FORK-STS .FORK <FORM ORB <FORM FORK-STS .FORK>
+ .ON>>)>>>
+
+;"<MSETG PT-READ-I 1>
+<MSETG PT-READ-D 2>
+<MSETG PT-READ-S 3>
+<MSETG PT-WRITE-I 4>
+<MSETG PT-WRITE-D 5>
+<MSETG PT-WRITE-S 6>
+<MSETG PT-CONT 7>
+<MSETG PT-TERM 8>
+"
+<MSETG SIG-INT 2>
+<MSETG SIG-QUIT 3>
+<MSETG SIG-ILL 4>
+<MSETG SIG-FPE 8>
+<MSETG SIG-KILL 9>
+<MSETG SIG-BUS 10>
+<MSETG SIG-SEGV 11>
+<MSETG SIG-SYS 12>
+<MSETG SIG-PIPE 13>
+<MSETG SIG-ALRM 14>
+<MSETG SIG-TERM 15>
+<MSETG SIG-STOP 17>
+<MSETG SIG-TSTP 18>
+<MSETG SIG-CONT 19>
+<MSETG SIG-CHLD 20>
+<MSETG SIG-TTIN 21>
+<MSETG SIG-TTOU 22>
+<MSETG SIG-XCPU 24>
+<MSETG SIG-XFSZ 24>
+<MSETG SIG-IGNORE 1>
+<MSETG SIG-DEFAULT 0>
+<MSETG FORK-INT-LEV 3>
+<SETG ALL-FORKS ()>
+
+<SETG BUF <UVECTOR 0>>
+<GDECL (BUF) UVECTOR (ALL-FORKS) <LIST [REST FIX CHANNEL]>>
+
+<DEFINE GET-INPUT (CH OPER "AUX" (FORK <CHANNEL-DATA .CH>) FROB)
+ #DECL ((CH) CHANNEL (OPER) ATOM (FORK) FORK)
+ <COND (<==? .OPER GET-INPUT>
+ <SET FROB <FORK-INPUT .FORK>>)
+ (T
+ <SET FROB <FORK-OUTPUT .FORK>>)>
+ <AND <TYPE? .FROB CHANNEL> .FROB>>
+
+<DEFINE RUN-FORK (FILE "OPTIONAL" (INPUT <>) (OUTPUT <>) "TUPLE" ARGS
+ "AUX" VAL (OINT <INT-LEVEL>) F)
+ #DECL ((FILE) STRING (INPUT OUTPUT) <OR ATOM FALSE CHANNEL>
+ (ARGS) <TUPLE [REST STRING]> (OINT) FIX (VAL) <OR CHANNEL FALSE>
+ (F) FORK)
+ <UNWIND
+ <PROG ()
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
+ <COND (<SET VAL <CHANNEL-OPEN FORK .FILE .INPUT .OUTPUT !.ARGS>>
+ <SET F <CHANNEL-DATA .VAL>>
+ <SETG ALL-FORKS (<FORK-ID .F> .VAL !,ALL-FORKS)>)>
+ <COND (<AND .VAL
+ <OR <TYPE? .INPUT ATOM>
+ <TYPE? .OUTPUT ATOM>>>
+ <PASS-TTY-DOWN .VAL PASS-TTY-DOWN .OINT>)>
+ <INT-LEVEL .OINT>
+ .VAL>
+ <INT-LEVEL .OINT>>>
+
+<DEFINE RUN-PIPED (FILE "TUPLE" ARGS "AUX" (ICH <>) (OCH <>) VAL)
+ #DECL ((FILE) STRING (ARGS) <TUPLE [REST STRING]>
+ (ICH OCH) <OR CHANNEL FALSE>)
+ <UNWIND
+ <COND (<SET ICH <CHANNEL-OPEN PIPE <STRING .FILE !\- "IN">>>
+ <COND (<SET OCH <CHANNEL-OPEN PIPE <STRING .FILE !\- "OUT">>>
+ <COND (<NOT <SET VAL <RUN-FORK .FILE .ICH .OCH !.ARGS>>>
+ <CLOSE .OCH>
+ <CLOSE .ICH>
+ .VAL)
+ (.VAL)>)
+ (T
+ <CLOSE .ICH>
+ .OCH)>)>
+ <PROG ()
+ <COND (.ICH <CLOSE .ICH>)>
+ <COND (.OCH <CLOSE .OCH>)>>>>
+
+<SETG UV3 <UVECTOR 0 0 0>>
+
+<DEFINE OPEN-FORK RF (STYPE OPER FILE "OPTIONAL" (INPUT <>) (OUTPUT <>)
+ "TUPLE" ARGS "AUX" RFILE PID (ENV <CALL GETS ENVIR>)
+ PSTR TEMP ARGP ENVP (IJFN <>) (OJFN <>) (KILLJ1 <>)
+ (KILLJ2 <>) (WAIT? <>) CF (UV3 ,UV3)
+ (BROKEN? <CHANNEL-OP ,OUTCHAN TTY-BROKEN?>))
+ #DECL ((RFILE FILE) STRING (ARGS) <TUPLE [REST STRING]> (PID) <OR FIX FALSE>
+ (ENV) VECTOR (INPUT OUTPUT) <OR ATOM FALSE CHANNEL>
+ (KILLJ1 KILLJ2 IJFN OJFN) <OR FIX FALSE>
+ (ARGP ENVP UV3) <UVECTOR [REST FIX]> (PSTR) <OR FALSE STRING>
+ (WAIT?) <OR ATOM FALSE> (CF) FORK)
+ <SETG MOI <CALL SYSCALL GETPID>>
+ <SETG MY-GROUP <CALL SYSCALL GETPGRP ,MOI>>
+ <SETG CURRENT-GROUP ,MY-GROUP>
+ <1 .UV3 ,SIG-IGNORE>
+ <2 .UV3 0>
+ <3 .UV3 0>
+ <CALL SYSCALL SIGVEC ,SIG-TTOU .UV3 0>
+ <COND (<NOT <MEMQ !\/ .FILE>>
+ <COND
+ (<SET PSTR <GET-ENV-STR "PATH" .ENV>>
+ <PROG ((OS .PSTR))
+ <MAPR <>
+ <FUNCTION (S "AUX" (C <1 .S>) NS)
+ <COND (<==? .C !\:>
+ <SET NS <SUBSTRUC .OS 0 <- <LENGTH .OS>
+ <LENGTH .S>>>>
+ <SET OS <REST .S>>
+ <COND (<SET TEMP <FILE-EXISTS?
+ <SET NS <STRING .NS !\/ .FILE>>
+ 0 0 0 0>>
+ <COND
+ (<NOT
+ <0?
+ <ANDB <STAT-FIELD
+ <FILE-STAT <STANDARD-NAME .NS>>
+ ,MODE-OFFS ,MODE-SIZE>
+ ,FMT-IFDIR>>>
+ <SET TEMP <SYS-ERR .NS #FALSE(13) <>>>)
+ (T
+ <SET RFILE .NS>
+ <MAPLEAVE>)>)>)>>
+ .PSTR>
+ <COND (<NOT .TEMP> <RETURN .TEMP .RF>)>>)
+ (T
+ <ERROR SEARCH-PATH-NOT-KNOWN!-ERRORS RUN-FORK>
+ <RETURN <> .RF>)>)
+ (<NOT <SET TEMP <FILE-EXISTS? .FILE 0 0 0 0>>>
+ <RETURN .TEMP .RF>)
+ (<SET RFILE <PARSE-FILE-NAME .FILE <>>>)>
+ <SET RFILE <STANDARD-NAME .RFILE>>
+ <COND (<NOT <SET TEMP <CALL SYSCALL ACCESS .RFILE ,X-OK>>>
+ ; "Don't have execute access"
+ <RETURN <SYS-ERR .RFILE .TEMP <>> .RF>)>
+ ; "Now have file name in standard form, expanded, and it exists"
+ <SET FILE <STANDARD-NAME .FILE>>
+ <SET ARGP <IUVECTOR <+ <LENGTH .ARGS> 2> 0>>
+ <SET ENVP <IUVECTOR <+ <LENGTH .ENV> 1> 0>>
+ <1 .ARGP <CALL VALUE .FILE>>
+ <MAPR <>
+ <FUNCTION (ARGT ARGPTR)
+ <1 .ARGT <STANDARD-NAME <1 .ARGT>>>
+ <1 .ARGPTR <CALL VALUE <1 .ARGT>>>>
+ .ARGS <REST .ARGP>>
+ <MAPR <>
+ <FUNCTION (ENVVEC ENVPTR)
+ <1 .ENVPTR <CALL VALUE <1 .ENVVEC>>>>
+ .ENV .ENVP>
+ <COND (<OR <TYPE? .INPUT ATOM>
+ <TYPE? .OUTPUT ATOM>>
+ <SET WAIT? T>)>
+ <COND (<TYPE? .INPUT CHANNEL>
+ <COND (<==? <CHANNEL-TYPE .INPUT> PIPE>
+ <SET IJFN <READ-DESC <CHANNEL-OP .INPUT GET-PIPE>:UVECTOR>>
+ <SET KILLJ1 <WRITE-DESC <CHANNEL-OP .INPUT GET-PIPE>:UVECTOR>>)
+ (<SET IJFN <CHANNEL-OP .INPUT FILE-HANDLE>>)>)>
+ <COND (<TYPE? .OUTPUT CHANNEL>
+ <COND (<==? <CHANNEL-TYPE .OUTPUT> PIPE>
+ <SET OJFN <WRITE-DESC <CHANNEL-OP .OUTPUT GET-PIPE>>>
+ <SET KILLJ2 <READ-DESC <CHANNEL-OP .OUTPUT GET-PIPE>>>)
+ (<SET OJFN <CHANNEL-OP .OUTPUT FILE-HANDLE>>)>)>
+ ; "IJFN and OJFN can be closed by the superior; KILLJ1 and KILLJ2,
+ by the inferior"
+ <COND (<NOT <GASSIGNED? INF-HANDLER>>
+ <CLASS "INFERIOR" ,FORK-INT-LEV T>
+ <SETG INF-HANDLER <ON <HANDLER "INFERIOR" ,INF-INTERRUPT>>>)>
+ <UNWIND
+ <PROG ()
+ <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN FIX-TTY>)>
+ ; "Don't leave tty broken"
+ <COND (<SET PID <CALL SYSCALL VFORK>>
+ <COND (<N==? <SETG NEW-FORK <CALL SYSCALL GETPID>> ,MOI>
+ ; "We're inferior"
+ ; "Copy i/o translations, kill excess descriptors"
+ <COND (.IJFN
+ <CALL SYSCALL DUP <+ *100* .IJFN> ,STDIN>
+ <CALL SYSCALL CLOSE .IJFN>)>
+ <COND (.OJFN
+ <CALL SYSCALL DUP <+ *100* .OJFN> ,STDOUT>
+ <CALL SYSCALL CLOSE .OJFN>)>
+ <COND (.KILLJ1
+ <CALL SYSCALL CLOSE .KILLJ1>)>
+ <COND (.KILLJ2
+ <CALL SYSCALL CLOSE .KILLJ2>)>
+ ; "Set process group as appropriate"
+ <COND (.WAIT?
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIS
+ <1 ,BIS-BUF ,LTOSTOP>>
+ <SETG CURRENT-GROUP ,NEW-FORK>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP
+ <1 ,WAIT-BUF ,NEW-FORK>>
+ <CALL SYSCALL SETPGRP ,NEW-FORK ,NEW-FORK>)
+ (T
+ <CALL SYSCALL SETPGRP ,NEW-FORK ,MY-GROUP>)>
+ ; "Now go for it"
+ <COND (<CALL SYSCALL EXECVE .RFILE .ARGP .ENVP>
+ ; "This never returns")
+ (<CALL FATAL "EXEC call failed">)>)
+ (T
+ <COND (<TYPE? .INPUT CHANNEL>
+ <COND (<==? <CHANNEL-TYPE .INPUT> PIPE>
+ <CHANNEL-OP .INPUT CLOSE ,READ-DESC>)
+ (<CLOSE .INPUT>)>)>
+ <COND (<TYPE? .OUTPUT CHANNEL>
+ <COND (<==? <CHANNEL-TYPE .OUTPUT> PIPE>
+ <CHANNEL-OP .OUTPUT CLOSE ,WRITE-DESC>)
+ (<CLOSE .OUTPUT>)>)>
+ <SET CF
+ <CHTYPE [.PID
+ <COND (.WAIT? .PID)
+ (T
+ ,MY-GROUP)>
+ <COND (.WAIT?
+ ,STATUS-TTY)
+ (,STATUS-RUNNING)>
+ 0
+ <COND (<TYPE? .INPUT CHANNEL>
+ <COND (<CHANNEL-OPEN? .INPUT>
+ .INPUT)
+ (T <>)>)
+ (,STDIN)>
+ <COND (<TYPE? .OUTPUT CHANNEL>
+ <COND (<CHANNEL-OPEN? .OUTPUT>
+ .OUTPUT)
+ (T <>)>)
+ (,STDOUT)>] FORK>>
+ <COND (<AND <NOT .WAIT?>
+ .BROKEN?>
+ <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
+ .CF)>)
+ (T
+ <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
+ .PID)>>
+ <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>>>
+
+<DEFINE FORK-READ (CHANNEL OPER "TUPLE" STUFF
+ "AUX" (FORK <CHANNEL-DATA .CHANNEL>)
+ (CH <FORK-OUTPUT .FORK>))
+ #DECL ((CHANNEL) CHANNEL (FORK) FORK)
+ <COND (<TYPE? .CH CHANNEL>
+ <CHANNEL-OP .CH .OPER !.STUFF>)
+ (T
+ #FALSE ("FORK IS NOT PIPELINED"))>>
+
+<DEFINE FORK-WRITE (CHANNEL OPER "TUPLE" STUFF
+ "AUX" (FORK <CHANNEL-DATA .CHANNEL>)
+ (CH <FORK-INPUT .FORK>))
+ #DECL ((CHANNEL) CHANNEL (FORK) FORK)
+ <COND (<TYPE? .CH CHANNEL>
+ <CHANNEL-OP .CH .OPER !.STUFF>)
+ (T
+ #FALSE ("FORK IS NOT PIPELINED"))>>
+
+; "Returns stopping signal if process is stopped (non-fatally), otherwise <>"
+<DEFMAC STOPPED?('STS)
+ <FORM COND (<FORM ==? *177* <FORM GETBITS .STS <FORM BITS 8 0>>>
+ <FORM GETBITS .STS <FORM BITS 8 8>>)>>
+
+; "Returns exit argument if returned normally"
+<DEFMAC QUIT? ('STS)
+ <FORM COND (<FORM 0? <FORM GETBITS .STS <FORM BITS 8 0>>>
+ <FORM GETBITS .STS <FORM BITS 8 8>>)>>
+
+; "Returns fatal signal"
+<DEFMAC DIED? ('STS)
+ <FORM BIND (DAT)
+ <FORM COND
+ (<FORM AND
+ <FORM NOT
+ <FORM 0? <FORM SET DAT <FORM GETBITS .STS <FORM BITS 8 0>>>>>
+ <FORM N==? '.DAT ,TERM-CONT>>
+ '.DAT)>>>
+
+<MSETG WNOHANG 1>
+<MSETG WUNTRACED 2>
+<SETG ST-BUF <UVECTOR 0>>
+<SETG BIS-BUF <UVECTOR 0>>
+<GDECL (BIS-BUF ST-BUF) UVECTOR>
+<DEFINE INF-INTERRUPT (ARG "AUX" CID)
+ #DECL ((CID) <OR FIX FALSE>)
+ <REPEAT ((BB ,ST-BUF))
+ <COND (<AND <SET CID <CALL SYSCALL WAIT .BB <+ ,WNOHANG ,WUNTRACED> 0>>
+ <NOT <0? .CID>>>
+ ; "Got status"
+ <COND (<NOT <PROCESS-FORK .CID <1 .BB>>>
+ ; "Not ready to go yet, will try again later"
+ <RETURN>)>)
+ (<RETURN>
+ ; "Nobody to handle")>>>
+
+<DEFINE PROCESS-FORK (PID STATUS "AUX" (AF ,ALL-FORKS) CC CFORK MISC)
+ #DECL ((PID STATUS) FIX (AF) <PRIMTYPE LIST> (CC) CHANNEL (CFORK) FORK)
+ <COND (<SET AF <MEMQ .PID .AF>>
+ <SET CC <2 .AF>>
+ <SET CFORK <CHANNEL-DATA .CC>>
+ <COND (<SET MISC <DIED? .STATUS>> ; "Fatal interrupt"
+ <SET-FORK-STS .CFORK
+ ,ST-BIT-DEAD ,ST-OTH-DIED>
+ <FORK-DATA .CFORK .MISC>
+ <STOP-FORK .CC INTERRUPT>
+ <REPORT .CC>)
+ (<SET MISC <QUIT? .STATUS>>
+ <SET-FORK-STS .CFORK
+ ,ST-BIT-DEAD ,ST-OTH-QUIT>
+ <FORK-DATA .CFORK .MISC>
+ <STOP-FORK .CC INTERRUPT>
+ <REPORT .CC>)
+ (<SET MISC <STOPPED? .STATUS>> ; "Non-fatal interrupt"
+ <COND (<==? .MISC ,SIG-CONT>
+ <CALL SYSCALL KILL .PID ,SIG-CONT>)
+ (<OR <==? .MISC ,SIG-TTOU>
+ <==? .MISC ,SIG-TTIN>>
+ ; "Trying to use tty when doesn't have it"
+ <COND (<FORK-STS? .CFORK ,ST-BIT-TTY>
+ ; "We think it has it"
+ <SETG CURRENT-GROUP <FORK-ID .CFORK>>
+ <CALL SYSCALL IOCTL ,STDIN
+ ,TIOCSPGRP
+ <1 ,GROUP-BUF <FORK-ID .CFORK>>>
+ <CALL SYSCALL KILL .PID ,SIG-CONT>)
+ (T
+ <SET-FORK-STS .CFORK ,ST-BIT-TTY-WAIT>
+ <STOP-FORK .CC INTERRUPT>
+ <REPORT .CC>)>)
+ (<FORK-STS? .CFORK ,ST-BIT-RUNNING>
+ ; "Not already stopped"
+ <FORK-DATA .CFORK .MISC>
+ <STOP-FORK .CC INTERRUPT>
+ <REPORT .CC>)>)>)>>
+
+<DEFINE STOP-FORK (CHAN OPER "AUX" (FORK <CHANNEL-DATA .CHAN>)
+ (OINT <INT-LEVEL>))
+ #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
+ <COND (<AND <NOT <0? <FORK-DATA .FORK>>>
+ <FORK-STS? .FORK ,ST-BIT-RUNNING>>
+ <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-STOP>)>
+ <TAKE-TTY-BACK .CHAN .OPER <>>
+ <SET-FORK-STS .FORK (,ST-BIT-RUNNING)>
+ <INT-LEVEL .OINT>
+ .CHAN>
+
+<DEFINE TAKE-TTY-BACK (CHAN OPER "OPTIONAL" (PERM? T)
+ "AUX" (FORK <CHANNEL-DATA .CHAN>) (OINT <INT-LEVEL>))
+ #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
+ <COND (<FORK-STS? .FORK ,ST-BIT-TTY>
+ <SET-FORK-STS .FORK (,ST-BIT-TTY)>
+ <COND (.PERM?
+ <SET-FORK-STS .FORK (,ST-BIT-HAD-TTY)>)
+ (T
+ <SET-FORK-STS .FORK ,ST-BIT-HAD-TTY>)>
+ <SETG CURRENT-GROUP ,MY-GROUP>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP <1 ,GROUP-BUF ,MY-GROUP>>
+ <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
+ <INT-LEVEL .OINT>
+ .CHAN>
+
+<DEFINE PASS-TTY-DOWN (CHAN OPER "OPTIONAL" (OINT <INT-LEVEL>)
+ "AUX" (FORK <CHANNEL-DATA .CHAN>))
+ #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
+ <SET-FORK-STS .FORK ,ST-BIT-HAD-TTY (,ST-BIT-TTY-WAIT)>
+ <CONTINUE-FORK .CHAN .OPER .OINT>>
+
+<DEFINE CONTINUE-FORK (CHAN OPER "OPTIONAL" (OINT? <>)
+ "AUX" (FORK <CHANNEL-DATA .CHAN>) OINT
+ (FIXED? <>)
+ (BROKEN? <CHANNEL-OP ,OUTCHAN TTY-BROKEN?>))
+ #DECL ((CHAN) CHANNEL (OINT?) <OR FIX FALSE> (FORK) FORK (OINT) FIX
+ (FIXED?) <SPECIAL <OR ATOM FALSE>>)
+ <UNWIND
+ <PROG ()
+ <COND (<FORK-STS? .FORK ,ST-BIT-DEAD>
+ <RETURN #FALSE ("FORK CAN'T BE CONTINUED")>)>
+ <COND (<NOT .OINT?>
+ <SET OINT <INT-LEVEL>>
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>)
+ (<SET OINT .OINT?>)>
+ <COND (<FORK-STS? .FORK ,ST-BIT-HAD-TTY>
+ <SET-FORK-STS .FORK ,ST-BIT-TTY (,ST-BIT-HAD-TTY)>
+ <SET FIXED? T>
+ <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN FIX-TTY>)>
+ <COND (<==? ,CURRENT-GROUP ,MY-GROUP>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIS <1 ,BIS-BUF ,LTOSTOP>>
+ <SETG CURRENT-GROUP <FORK-ID .FORK>>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP
+ <1 ,GROUP-BUF <FORK-ID .FORK>>>)>)>
+ <SET-FORK-STS .FORK ,ST-BIT-RUNNING>
+ <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-CONT>
+ <COND (<OR .OINT? .FIXED?>
+ <WAIT-FORK .CHAN .OPER .OINT>
+ <SETG CURRENT-GROUP ,MY-GROUP>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP <1 ,GROUP-BUF ,MY-GROUP>>
+ <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIC <1 ,BIS-BUF ,LTOSTOP>>
+ <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
+ <SET FIXED? <>>)>
+ <INT-LEVEL .OINT>
+ .CHAN>
+ <PROG ()
+ <COND (<AND .FIXED? .BROKEN?>
+ <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
+ <INT-LEVEL .OINT>>>>
+
+<SETG WAIT-BUF <UVECTOR 0>>
+<SETG GROUP-BUF <UVECTOR 0>>
+<GDECL (GROUP-BUF WAIT-BUF) UVECTOR>
+<DEFINE WAIT-FORK WAIT-ACT (CHAN OPER "OPTIONAL" (OINT? <>)
+ "AUX" (FORK <CHANNEL-DATA .CHAN>)
+ (CURRENT-FORK <FORK-ID .FORK>))
+ #DECL ((CHAN) CHANNEL (OINT?) <OR FIX FALSE> (FORK) FORK
+ (CURRENT-FORK) <SPECIAL FIX> (WAIT-ACT) <SPECIAL FRAME>)
+ <COND (.OINT?
+ <INT-LEVEL .OINT?>)>
+ <PROG (CID)
+ <COND (<NOT <FORK-STS? .FORK ,ST-BIT-RUNNING>>
+ .CHAN)
+ (<==? <SET CID <ISYSCALL WAIT ,WAIT-BUF ,WUNTRACED 0>>
+ .CURRENT-FORK>
+ <PROCESS-FORK .CID <1 ,WAIT-BUF>>
+ .CHAN)
+ (.CID
+ <INTERRUPT "INFERIOR">
+ <AGAIN>)
+ (<==? <1 .CID> ,EINTR>
+ <INTERRUPT "INFERIOR">
+ <AGAIN>)
+ (T
+ <SYS-ERR "" .CID <>>)>>>
+
+<DEFINE REPORT (CHAN "AUX" (FORK <CHANNEL-DATA .CHAN>))
+ #DECL ((CHAN) CHANNEL (FORK) FORK)
+ <COND (<OR <NOT <ASSIGNED? CURRENT-FORK>>
+ <N==? .CURRENT-FORK <FORK-ID .FORK>>>
+ <INTERRUPT "USER-INFERIOR" .CHAN>)
+ (T
+ <DISMISS .CHAN .WAIT-ACT>)>>
+
+<DEFINE KILL-FORK (CHAN OPER "AUX" (FORK <CHANNEL-DATA .CHAN>)
+ (OINT <INT-LEVEL>) (AF ,ALL-FORKS) L)
+ #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
+ <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
+ <COND (<NOT <FORK-STS? .FORK ,ST-BIT-DEAD>>
+ <SET-FORK-STS .FORK ,STATUS-KILLED>
+ <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-KILL>)>
+ <COND (<SET L <MEMQ <FORK-ID .FORK> .AF>>
+ <COND (<TYPE? <FORK-INPUT .FORK> CHANNEL>
+ <CLOSE <FORK-INPUT .FORK>>)>
+ <COND (<TYPE? <FORK-OUTPUT .FORK> CHANNEL>
+ <CLOSE <FORK-OUTPUT .FORK>>)>
+ <COND (<==? .L .AF>
+ <SETG ALL-FORKS <REST .AF 2>>)
+ (T
+ <PUTREST <REST .AF <- <LENGTH .AF> <LENGTH .L> 1>>
+ <REST .L 2>>)>)>
+ <TAKE-TTY-BACK .CHAN .OPER>
+ <INT-LEVEL .OINT>
+ .CHAN>
+
+<DEFINE FORK-PRINT-DATA (CHANNEL OPER OUTCHAN
+ "AUX" (FORK <CHANNEL-DATA .CHANNEL>) OTH)
+ #DECL ((CHANNEL) CHANNEL (OUTCHAN) CHANNEL (FORK) FORK)
+ <PRINC "#FORK [" .OUTCHAN>
+ <PRINC "PID:" .OUTCHAN>
+ <PRIN1 <FORK-ID .FORK> .OUTCHAN>
+ <PRINC " GROUP:" .OUTCHAN>
+ <PRIN1 <FORK-GRP .FORK> .OUTCHAN>
+ <PRINC " STATUS:" .OUTCHAN>
+ <COND (<FORK-STS? .FORK ,ST-BIT-DEAD>
+ <COND (<==? <SET OTH <ANDB <FORK-STS .FORK> ,ST-BIT-OTHER>>
+ ,ST-OTH-KILLED>
+ <PRINC "KILLED" .OUTCHAN>)
+ (<==? .OTH ,ST-OTH-QUIT>
+ <PRINC "QUIT" .OUTCHAN>
+ <COND (<NOT <0? <FORK-DATA .FORK>>>
+ <PRINC !\: .OUTCHAN>
+ <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)
+ (<==? .OTH ,ST-OTH-DIED>
+ <PRINC "DIED:" .OUTCHAN>
+ <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)
+ (T
+ <COND (<FORK-STS? .FORK ,ST-BIT-TTY-WAIT>
+ <PRINC "TTYWAIT;" .OUTCHAN>)
+ (<FORK-STS? .FORK ,ST-BIT-TTY>
+ <PRINC "TTY;" .OUTCHAN>)
+ (T
+ <PRINC "NOTTY;" .OUTCHAN>)>
+ <COND (<FORK-STS? .FORK ,ST-BIT-HAD-TTY>
+ <PRINC "HADTTY;" .OUTCHAN>)>
+ <COND (<FORK-STS? .FORK ,ST-BIT-RUNNING>
+ <PRINC "RUNNING" .OUTCHAN>)
+ (T
+ <PRINC "STOPPED" .OUTCHAN>
+ <COND (<NOT <0? <FORK-DATA .FORK>>>
+ <PRINC !\: .OUTCHAN>
+ <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)>)>
+ <PRINC " INPUT:" .OUTCHAN>
+ <COND (<TYPE? <SET OTH <FORK-INPUT .FORK>> CHANNEL>
+ <PRINC <CHANNEL-TYPE .OTH> .OUTCHAN>)
+ (<TYPE? .OTH FIX>
+ <PRINC "GIVETTY" .OUTCHAN>)
+ (T
+ <PRINC "TTY" .OUTCHAN>)>
+ <PRINC " OUTPUT:" .OUTCHAN>
+ <COND (<TYPE? <SET OTH <FORK-OUTPUT .FORK>> CHANNEL>
+ <PRINC <CHANNEL-TYPE .OTH> .OUTCHAN>)
+ (<TYPE? .OTH FIX>
+ <PRINC "GIVETTY" .OUTCHAN>)
+ (T
+ <PRINC "TTY" .OUTCHAN>)>
+ <PRINC !\] .OUTCHAN>>
+
+<MSETG FORK-STATUS-QUIT 1>
+<MSETG FORK-STATUS-KILLED 2>
+<MSETG FORK-STATUS-DIED 3>
+<MSETG FORK-STATUS-DEAD 4>
+<MSETG FORK-STATUS-RUNNING 5>
+<MSETG FORK-STATUS-STOPPED 6>
+<MSETG FORK-STATUS-WAIT 7>
+<DEFINE TEST-FORK-STATUS (CHAN OPER WHICH "AUX" (FORK <CHANNEL-DATA .CHAN>)
+ (OTH <ANDB <FORK-STS .FORK> ,ST-BIT-OTHER>))
+ #DECL ((CHAN) CHANNEL (WHICH) FIX (FORK) FORK)
+ <COND (<==? .WHICH ,FORK-STATUS-QUIT>
+ <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
+ <==? .OTH ,ST-OTH-QUIT>>
+ <FORK-DATA .FORK>)>)
+ (<==? .WHICH ,FORK-STATUS-KILLED>
+ <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
+ <==? .OTH ,ST-OTH-KILLED>>
+ T)>)
+ (<==? .WHICH ,FORK-STATUS-DIED>
+ <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
+ <==? .OTH ,ST-OTH-DIED>>
+ <FORK-DATA .FORK>)>)
+ (<==? .WHICH ,FORK-STATUS-DEAD>
+ <FORK-STS? .FORK ,ST-BIT-DEAD>)
+ (<==? .WHICH ,FORK-STATUS-RUNNING>
+ <FORK-STS? .FORK ,ST-BIT-RUNNING>)
+ (<==? .WHICH ,FORK-STATUS-STOPPED>
+ <COND (<NOT <FORK-STS? .FORK ,ST-BIT-RUNNING>>
+ <FORK-DATA .FORK>)>)
+ (<==? .WHICH ,FORK-STATUS-WAIT>
+ <FORK-STS? .FORK ,ST-BIT-TTY-WAIT>)>>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff