mim/development/mim/vax/mimlib/forks.mud

   1 <PACKAGE "FORKS">
   2
   3 <ENTRY FORK FORK-STATUS? CONTINUE-FORK PASS-TTY-DOWN TAKE-TTY-BACK
   4        WAIT-FORK STOP-FORK RUN-FORK RUN-PIPED>
   5 <ENTRY GET-INPUT GET-OUTPUT>
   6 <ENTRY FORK-STATUS-QUIT FORK-STATUS-KILLED FORK-STATUS-DIED
   7        FORK-STATUS-DEAD FORK-STATUS-RUNNING FORK-STATUS-STOPPED
   8        FORK-STATUS-WAIT>
   9
  10 <USE "NEWSTRUC" "PIPES">
  11
  12 <ENV-COND (("MACHINE" "VAX")
  13            <NEW-CHANNEL-TYPE FORK <>
  14                              GET-INPUT GET-INPUT
  15                              GET-OUTPUT GET-INPUT
  16                              FORK-STATUS? TEST-FORK-STATUS
  17                              READ-BYTE FORK-READ
  18                              READ-BUFFER FORK-READ
  19                              READ-SAFE-BUFFER FORK-READ
  20                              WRITE-BYTE FORK-WRITE
  21                              WRITE-BUFFER FORK-WRITE
  22                              ;"READ-MEMORY ;FORK-READ-MEMORY
  23                              ;WRITE-MEMORY ;FORK-WRITE-MEMORY
  24                              ;READ-ACS ;FORK-READ-ACS
  25                              ;WRITE-ACS ;FORK-WRITE-ACS"
  26                              CONTINUE-FORK CONTINUE-FORK
  27                              KILL-FORK KILL-FORK
  28                              CLOSE KILL-FORK
  29                              PASS-TTY-DOWN PASS-TTY-DOWN
  30                              TAKE-TTY-BACK TAKE-TTY-BACK
  31                              WAIT-FORK WAIT-FORK
  32                              STOP-FORK STOP-FORK
  33                              OPEN OPEN-FORK
  34                              PRINT-DATA FORK-PRINT-DATA>)>
  35
  36 <NEWSTRUC FORK VECTOR
  37           FORK-ID FIX
  38           FORK-GRP FIX
  39           FORK-STS FIX
  40           FORK-DATA FIX
  41           FORK-INPUT <OR CHANNEL FIX FALSE>
  42           FORK-OUTPUT <OR CHANNEL FIX FALSE>>
  43
  44 <MSETG ST-BIT-TTY-WAIT *400000*>
  45 <MSETG ST-BIT-HAD-TTY *200000*>
  46 <MSETG ST-BIT-TTY *100000*>
  47 <MSETG ST-BIT-RUNNING *40000*>
  48 <MSETG ST-BIT-DEAD *20000*>
  49 <MSETG ST-BIT-OTHER *777*>
  50 <MSETG ST-OTH-KILLED *1*>
  51 <MSETG ST-OTH-QUIT 2>
  52 <MSETG ST-OTH-DIED 3>
  53
  54 <MSETG TERM-CONT *177*>
  55
  56 <MSETG STATUS-TTY <CHTYPE <ORB ,ST-BIT-TTY ,ST-BIT-RUNNING> FIX>>
  57 <MSETG STATUS-RUNNING ,ST-BIT-RUNNING>
  58 <MSETG STATUS-KILLED <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-KILLED> FIX>>
  59 <MSETG STATUS-DIED <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-DIED> FIX>>
  60 <MSETG STATUS-QUIT <CHTYPE <ORB ,ST-BIT-DEAD ,ST-OTH-QUIT> FIX>>
  61
  62 <DEFMAC FORK-STS? ('FORK 'BIT)
  63   <FORM NOT
  64         <FORM 0? <FORM ANDB <FORM FORK-STS .FORK> .BIT>>>>
  65
  66 <DEFMAC SET-FORK-STS ('FORK "TUPLE" STATS "AUX" (ON 0) (OFF 0))
  67   <REPEAT (WD)
  68     <COND (<EMPTY? .STATS> <RETURN>)>
  69     <COND (<TYPE? <SET WD <1 .STATS>> LIST>
  70            <SET OFF <ORB .OFF !.WD>>)
  71           (<SET ON <ORB .ON .WD>>)>
  72     <SET STATS <REST .STATS>>>
  73   <SET OFF <CHTYPE .OFF FIX>>
  74   <SET ON <CHTYPE .ON FIX>>
  75   <COND (<NOT <0? <CHTYPE <ANDB .ON ,ST-BIT-DEAD> FIX>>>
  76          <SET OFF <CHTYPE <ORB .OFF ,ST-BIT-RUNNING> FIX>>)>
  77   <FORM BIND ()
  78     <COND (<NOT <0? .OFF>>
  79            <FORM FORK-STS .FORK <FORM ANDB <FORM FORK-STS .FORK>
  80                                       <CHTYPE <XORB .OFF -1> FIX>>>)>
  81     <COND (<NOT <0? .ON>>
  82            <FORM FORK-STS .FORK <FORM ORB <FORM FORK-STS .FORK>
  83                                       .ON>>)>>>
  84
  85 ;"<MSETG PT-READ-I 1>
  86 <MSETG PT-READ-D 2>
  87 <MSETG PT-READ-S 3>
  88 <MSETG PT-WRITE-I 4>
  89 <MSETG PT-WRITE-D 5>
  90 <MSETG PT-WRITE-S 6>
  91 <MSETG PT-CONT 7>
  92 <MSETG PT-TERM 8>
  93 "
  94 <MSETG SIG-INT 2>
  95 <MSETG SIG-QUIT 3>
  96 <MSETG SIG-ILL 4>
  97 <MSETG SIG-FPE 8>
  98 <MSETG SIG-KILL 9>
  99 <MSETG SIG-BUS 10>
 100 <MSETG SIG-SEGV 11>
 101 <MSETG SIG-SYS 12>
 102 <MSETG SIG-PIPE 13>
 103 <MSETG SIG-ALRM 14>
 104 <MSETG SIG-TERM 15>
 105 <MSETG SIG-STOP 17>
 106 <MSETG SIG-TSTP 18>
 107 <MSETG SIG-CONT 19>
 108 <MSETG SIG-CHLD 20>
 109 <MSETG SIG-TTIN 21>
 110 <MSETG SIG-TTOU 22>
 111 <MSETG SIG-XCPU 24>
 112 <MSETG SIG-XFSZ 24>
 113 <MSETG SIG-IGNORE 1>
 114 <MSETG SIG-DEFAULT 0>
 115 <MSETG FORK-INT-LEV 3>
 116 <SETG ALL-FORKS ()>
 117
 118 <SETG BUF <UVECTOR 0>>
 119 <GDECL (BUF) UVECTOR (ALL-FORKS) <LIST [REST FIX CHANNEL]>>
 120
 121 <DEFINE GET-INPUT (CH OPER "AUX" (FORK <CHANNEL-DATA .CH>) FROB)
 122   #DECL ((CH) CHANNEL (OPER) ATOM (FORK) FORK)
 123   <COND (<==? .OPER GET-INPUT>
 124          <SET FROB <FORK-INPUT .FORK>>)
 125         (T
 126          <SET FROB <FORK-OUTPUT .FORK>>)>
 127   <AND <TYPE? .FROB CHANNEL> .FROB>>
 128
 129 <DEFINE RUN-FORK (FILE "OPTIONAL" (INPUT <>) (OUTPUT <>) "TUPLE" ARGS
 130                   "AUX" VAL (OINT <INT-LEVEL>) F)
 131   #DECL ((FILE) STRING (INPUT OUTPUT) <OR ATOM FALSE CHANNEL>
 132          (ARGS) <TUPLE [REST STRING]> (OINT) FIX (VAL) <OR CHANNEL FALSE>
 133          (F) FORK)
 134   <UNWIND
 135    <PROG ()
 136      <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
 137      <COND (<SET VAL <CHANNEL-OPEN FORK .FILE .INPUT .OUTPUT !.ARGS>>
 138             <SET F <CHANNEL-DATA .VAL>>
 139             <SETG ALL-FORKS (<FORK-ID .F> .VAL !,ALL-FORKS)>)>
 140      <COND (<AND .VAL
 141                  <OR <TYPE? .INPUT ATOM>
 142                      <TYPE? .OUTPUT ATOM>>>
 143             <PASS-TTY-DOWN .VAL PASS-TTY-DOWN .OINT>)>
 144      <INT-LEVEL .OINT>
 145      .VAL>
 146    <INT-LEVEL .OINT>>>
 147
 148 <DEFINE RUN-PIPED (FILE "TUPLE" ARGS "AUX" (ICH <>) (OCH <>) VAL)
 149   #DECL ((FILE) STRING (ARGS) <TUPLE [REST STRING]>
 150          (ICH OCH) <OR CHANNEL FALSE>)
 151   <UNWIND
 152    <COND (<SET ICH <CHANNEL-OPEN PIPE <STRING .FILE !\- "IN">>>
 153           <COND (<SET OCH <CHANNEL-OPEN PIPE <STRING .FILE !\- "OUT">>>
 154                  <COND (<NOT <SET VAL <RUN-FORK .FILE .ICH .OCH !.ARGS>>>
 155                         <CLOSE .OCH>
 156                         <CLOSE .ICH>
 157                         .VAL)
 158                        (.VAL)>)
 159                 (T
 160                  <CLOSE .ICH>
 161                  .OCH)>)>
 162    <PROG ()
 163      <COND (.ICH <CLOSE .ICH>)>
 164      <COND (.OCH <CLOSE .OCH>)>>>>
 165
 166 <SETG UV3 <UVECTOR 0 0 0>>
 167
 168 <DEFINE OPEN-FORK RF (STYPE OPER FILE "OPTIONAL" (INPUT <>) (OUTPUT <>)
 169                      "TUPLE" ARGS "AUX" RFILE PID (ENV <CALL GETS ENVIR>)
 170                      PSTR TEMP ARGP ENVP (IJFN <>) (OJFN <>) (KILLJ1 <>)
 171                      (KILLJ2 <>) (WAIT? <>) CF (UV3 ,UV3)
 172                      (BROKEN? <CHANNEL-OP ,OUTCHAN TTY-BROKEN?>))
 173   #DECL ((RFILE FILE) STRING (ARGS) <TUPLE [REST STRING]> (PID) <OR FIX FALSE>
 174          (ENV) VECTOR (INPUT OUTPUT) <OR ATOM FALSE CHANNEL>
 175          (KILLJ1 KILLJ2 IJFN OJFN) <OR FIX FALSE>
 176          (ARGP ENVP UV3) <UVECTOR [REST FIX]> (PSTR) <OR FALSE STRING>
 177          (WAIT?) <OR ATOM FALSE> (CF) FORK)
 178   <SETG MOI <CALL SYSCALL GETPID>>
 179   <SETG MY-GROUP <CALL SYSCALL GETPGRP ,MOI>>
 180   <SETG CURRENT-GROUP ,MY-GROUP>
 181   <1 .UV3 ,SIG-IGNORE>
 182   <2 .UV3 0>
 183   <3 .UV3 0>
 184   <CALL SYSCALL SIGVEC ,SIG-TTOU .UV3 0>
 185   <COND (<NOT <MEMQ !\/ .FILE>>
 186          <COND
 187           (<SET PSTR <GET-ENV-STR "PATH" .ENV>>
 188            <PROG ((OS .PSTR))
 189              <MAPR <>
 190                  <FUNCTION (S "AUX" (C <1 .S>) NS)
 191                    <COND (<==? .C !\:>
 192                           <SET NS <SUBSTRUC .OS 0 <- <LENGTH .OS>
 193                                                      <LENGTH .S>>>>
 194                           <SET OS <REST .S>>
 195                           <COND (<SET TEMP <FILE-EXISTS?
 196                                             <SET NS <STRING .NS !\/ .FILE>>
 197                                             0 0 0 0>>
 198                                  <COND
 199                                   (<NOT
 200                                     <0?
 201                                      <ANDB <STAT-FIELD
 202                                             <FILE-STAT <STANDARD-NAME .NS>>
 203                                             ,MODE-OFFS ,MODE-SIZE>
 204                                            ,FMT-IFDIR>>>
 205                                    <SET TEMP <SYS-ERR .NS #FALSE(13) <>>>)
 206                                   (T
 207                                    <SET RFILE .NS>
 208                                    <MAPLEAVE>)>)>)>>
 209                  .PSTR>
 210              <COND (<NOT .TEMP> <RETURN .TEMP .RF>)>>)
 211           (T
 212            <ERROR SEARCH-PATH-NOT-KNOWN!-ERRORS RUN-FORK>
 213            <RETURN <> .RF>)>)
 214         (<NOT <SET TEMP <FILE-EXISTS? .FILE 0 0 0 0>>>
 215          <RETURN .TEMP .RF>)
 216         (<SET RFILE <PARSE-FILE-NAME .FILE <>>>)>
 217   <SET RFILE <STANDARD-NAME .RFILE>>
 218   <COND (<NOT <SET TEMP <CALL SYSCALL ACCESS .RFILE ,X-OK>>>
 219          ; "Don't have execute access"
 220          <RETURN <SYS-ERR .RFILE .TEMP <>> .RF>)>
 221   ; "Now have file name in standard form, expanded, and it exists"
 222   <SET FILE <STANDARD-NAME .FILE>>
 223   <SET ARGP <IUVECTOR <+ <LENGTH .ARGS> 2> 0>>
 224   <SET ENVP <IUVECTOR <+ <LENGTH .ENV> 1> 0>>
 225   <1 .ARGP <CALL VALUE .FILE>>
 226   <MAPR <>
 227     <FUNCTION (ARGT ARGPTR)
 228       <1 .ARGT <STANDARD-NAME <1 .ARGT>>>
 229       <1 .ARGPTR <CALL VALUE <1 .ARGT>>>>
 230     .ARGS <REST .ARGP>>
 231   <MAPR <>
 232     <FUNCTION (ENVVEC ENVPTR)
 233       <1 .ENVPTR <CALL VALUE <1 .ENVVEC>>>>
 234     .ENV .ENVP>
 235   <COND (<OR <TYPE? .INPUT ATOM>
 236              <TYPE? .OUTPUT ATOM>>
 237          <SET WAIT? T>)>
 238   <COND (<TYPE? .INPUT CHANNEL>
 239          <COND (<==? <CHANNEL-TYPE .INPUT> PIPE>
 240                 <SET IJFN <READ-DESC <CHANNEL-OP .INPUT GET-PIPE>:UVECTOR>>
 241                 <SET KILLJ1 <WRITE-DESC <CHANNEL-OP .INPUT GET-PIPE>:UVECTOR>>)
 242                (<SET IJFN <CHANNEL-OP .INPUT FILE-HANDLE>>)>)>
 243   <COND (<TYPE? .OUTPUT CHANNEL>
 244          <COND (<==? <CHANNEL-TYPE .OUTPUT> PIPE>
 245                 <SET OJFN <WRITE-DESC <CHANNEL-OP .OUTPUT GET-PIPE>>>
 246                 <SET KILLJ2 <READ-DESC <CHANNEL-OP .OUTPUT GET-PIPE>>>)
 247                (<SET OJFN <CHANNEL-OP .OUTPUT FILE-HANDLE>>)>)>
 248   ; "IJFN and OJFN can be closed by the superior; KILLJ1 and KILLJ2,
 249      by the inferior"
 250   <COND (<NOT <GASSIGNED? INF-HANDLER>>
 251          <CLASS "INFERIOR" ,FORK-INT-LEV T>
 252          <SETG INF-HANDLER <ON <HANDLER "INFERIOR" ,INF-INTERRUPT>>>)>
 253   <UNWIND
 254    <PROG ()
 255      <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN FIX-TTY>)>
 256      ; "Don't leave tty broken"
 257      <COND (<SET PID <CALL SYSCALL VFORK>>
 258             <COND (<N==? <SETG NEW-FORK <CALL SYSCALL GETPID>> ,MOI>
 259                    ; "We're inferior"
 260                    ; "Copy i/o translations, kill excess descriptors"
 261                    <COND (.IJFN
 262                           <CALL SYSCALL DUP <+ *100* .IJFN> ,STDIN>
 263                           <CALL SYSCALL CLOSE .IJFN>)>
 264                    <COND (.OJFN
 265                           <CALL SYSCALL DUP <+ *100* .OJFN> ,STDOUT>
 266                           <CALL SYSCALL CLOSE .OJFN>)>
 267                    <COND (.KILLJ1
 268                           <CALL SYSCALL CLOSE .KILLJ1>)>
 269                    <COND (.KILLJ2
 270                           <CALL SYSCALL CLOSE .KILLJ2>)>
 271                    ; "Set process group as appropriate"
 272                    <COND (.WAIT?
 273                           <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIS
 274                                 <1 ,BIS-BUF ,LTOSTOP>>
 275                           <SETG CURRENT-GROUP ,NEW-FORK>
 276                           <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP
 277                                 <1 ,WAIT-BUF ,NEW-FORK>>
 278                           <CALL SYSCALL SETPGRP ,NEW-FORK ,NEW-FORK>)
 279                          (T
 280                           <CALL SYSCALL SETPGRP ,NEW-FORK ,MY-GROUP>)>
 281                    ; "Now go for it"
 282                    <COND (<CALL SYSCALL EXECVE .RFILE .ARGP .ENVP>
 283                           ; "This never returns")
 284                          (<CALL FATAL "EXEC call failed">)>)
 285                   (T
 286                    <COND (<TYPE? .INPUT CHANNEL>
 287                           <COND (<==? <CHANNEL-TYPE .INPUT> PIPE>
 288                                  <CHANNEL-OP .INPUT CLOSE ,READ-DESC>)
 289                                 (<CLOSE .INPUT>)>)>
 290                    <COND (<TYPE? .OUTPUT CHANNEL>
 291                           <COND (<==? <CHANNEL-TYPE .OUTPUT> PIPE>
 292                                  <CHANNEL-OP .OUTPUT CLOSE ,WRITE-DESC>)
 293                                 (<CLOSE .OUTPUT>)>)>
 294                    <SET CF
 295                         <CHTYPE [.PID
 296                                  <COND (.WAIT? .PID)
 297                                        (T
 298                                         ,MY-GROUP)>
 299                                  <COND (.WAIT?
 300                                         ,STATUS-TTY)
 301                                        (,STATUS-RUNNING)>
 302                                  0
 303                                  <COND (<TYPE? .INPUT CHANNEL>
 304                                         <COND (<CHANNEL-OPEN? .INPUT>
 305                                                .INPUT)
 306                                               (T <>)>)
 307                                        (,STDIN)>
 308                                  <COND (<TYPE? .OUTPUT CHANNEL>
 309                                         <COND (<CHANNEL-OPEN? .OUTPUT>
 310                                                .OUTPUT)
 311                                               (T <>)>)
 312                                        (,STDOUT)>] FORK>>
 313                    <COND (<AND <NOT .WAIT?>
 314                                .BROKEN?>
 315                           <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
 316                    .CF)>)
 317            (T
 318             <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
 319             .PID)>>
 320    <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>>>
 321
 322 <DEFINE FORK-READ (CHANNEL OPER "TUPLE" STUFF
 323                    "AUX" (FORK <CHANNEL-DATA .CHANNEL>)
 324                          (CH <FORK-OUTPUT .FORK>))
 325   #DECL ((CHANNEL) CHANNEL (FORK) FORK)
 326   <COND (<TYPE? .CH CHANNEL>
 327          <CHANNEL-OP .CH .OPER !.STUFF>)
 328         (T
 329          #FALSE ("FORK IS NOT PIPELINED"))>>
 330
 331 <DEFINE FORK-WRITE (CHANNEL OPER "TUPLE" STUFF
 332                            "AUX" (FORK <CHANNEL-DATA .CHANNEL>)
 333                            (CH <FORK-INPUT .FORK>))
 334   #DECL ((CHANNEL) CHANNEL (FORK) FORK)
 335   <COND (<TYPE? .CH CHANNEL>
 336          <CHANNEL-OP .CH .OPER !.STUFF>)
 337         (T
 338          #FALSE ("FORK IS NOT PIPELINED"))>>
 339
 340 ; "Returns stopping signal if process is stopped (non-fatally), otherwise <>"
 341 <DEFMAC STOPPED?('STS)
 342   <FORM COND (<FORM ==? *177* <FORM GETBITS .STS <FORM BITS 8 0>>>
 343               <FORM GETBITS .STS <FORM BITS 8 8>>)>>
 344
 345 ; "Returns exit argument if returned normally"
 346 <DEFMAC QUIT? ('STS)
 347   <FORM COND (<FORM 0? <FORM GETBITS .STS <FORM BITS 8 0>>>
 348               <FORM GETBITS .STS <FORM BITS 8 8>>)>>
 349
 350 ; "Returns fatal signal"
 351 <DEFMAC DIED? ('STS)
 352   <FORM BIND (DAT)
 353     <FORM COND
 354           (<FORM AND
 355             <FORM NOT
 356                   <FORM 0? <FORM SET DAT <FORM GETBITS .STS <FORM BITS 8 0>>>>>
 357             <FORM N==? '.DAT ,TERM-CONT>>
 358            '.DAT)>>>
 359
 360 <MSETG WNOHANG 1>
 361 <MSETG WUNTRACED 2>
 362 <SETG ST-BUF <UVECTOR 0>>
 363 <SETG BIS-BUF <UVECTOR 0>>
 364 <GDECL (BIS-BUF ST-BUF) UVECTOR>
 365 <DEFINE INF-INTERRUPT (ARG "AUX" CID)
 366   #DECL ((CID) <OR FIX FALSE>)
 367   <REPEAT ((BB ,ST-BUF))
 368     <COND (<AND <SET CID <CALL SYSCALL WAIT .BB <+ ,WNOHANG ,WUNTRACED> 0>>
 369                 <NOT <0? .CID>>>
 370            ; "Got status"
 371            <COND (<NOT <PROCESS-FORK .CID <1 .BB>>>
 372                   ; "Not ready to go yet, will try again later"
 373                   <RETURN>)>)
 374           (<RETURN>
 375            ; "Nobody to handle")>>>
 376
 377 <DEFINE PROCESS-FORK (PID STATUS "AUX" (AF ,ALL-FORKS) CC CFORK MISC)
 378   #DECL ((PID STATUS) FIX (AF) <PRIMTYPE LIST> (CC) CHANNEL (CFORK) FORK)
 379   <COND (<SET AF <MEMQ .PID .AF>>
 380          <SET CC <2 .AF>>
 381          <SET CFORK <CHANNEL-DATA .CC>>
 382          <COND (<SET MISC <DIED? .STATUS>>      ; "Fatal interrupt"
 383                 <SET-FORK-STS .CFORK
 384                               ,ST-BIT-DEAD ,ST-OTH-DIED>
 385                 <FORK-DATA .CFORK .MISC>
 386                 <STOP-FORK .CC INTERRUPT>
 387                 <REPORT .CC>)
 388                (<SET MISC <QUIT? .STATUS>>
 389                 <SET-FORK-STS .CFORK
 390                               ,ST-BIT-DEAD ,ST-OTH-QUIT>
 391                 <FORK-DATA .CFORK .MISC>
 392                 <STOP-FORK .CC INTERRUPT>
 393                 <REPORT .CC>)
 394                (<SET MISC <STOPPED? .STATUS>>   ; "Non-fatal interrupt"
 395                 <COND (<==? .MISC ,SIG-CONT>
 396                        <CALL SYSCALL KILL .PID ,SIG-CONT>)
 397                       (<OR <==? .MISC ,SIG-TTOU>
 398                            <==? .MISC ,SIG-TTIN>>
 399                        ; "Trying to use tty when doesn't have it"
 400                        <COND (<FORK-STS? .CFORK ,ST-BIT-TTY>
 401                               ; "We think it has it"
 402                               <SETG CURRENT-GROUP <FORK-ID .CFORK>>
 403                               <CALL SYSCALL IOCTL ,STDIN
 404                                     ,TIOCSPGRP
 405                                     <1 ,GROUP-BUF <FORK-ID .CFORK>>>
 406                               <CALL SYSCALL KILL .PID ,SIG-CONT>)
 407                              (T
 408                               <SET-FORK-STS .CFORK ,ST-BIT-TTY-WAIT>
 409                               <STOP-FORK .CC INTERRUPT>
 410                               <REPORT .CC>)>)
 411                       (<FORK-STS? .CFORK ,ST-BIT-RUNNING>
 412                        ; "Not already stopped"
 413                        <FORK-DATA .CFORK .MISC>
 414                        <STOP-FORK .CC INTERRUPT>
 415                        <REPORT .CC>)>)>)>>
 416
 417 <DEFINE STOP-FORK (CHAN OPER "AUX" (FORK <CHANNEL-DATA .CHAN>)
 418                    (OINT <INT-LEVEL>))
 419   #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
 420   <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
 421   <COND (<AND <NOT <0? <FORK-DATA .FORK>>>
 422               <FORK-STS? .FORK ,ST-BIT-RUNNING>>
 423          <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-STOP>)>
 424   <TAKE-TTY-BACK .CHAN .OPER <>>
 425   <SET-FORK-STS .FORK (,ST-BIT-RUNNING)>
 426   <INT-LEVEL .OINT>
 427   .CHAN>
 428
 429 <DEFINE TAKE-TTY-BACK (CHAN OPER "OPTIONAL" (PERM? T)
 430                        "AUX" (FORK <CHANNEL-DATA .CHAN>) (OINT <INT-LEVEL>))
 431   #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
 432   <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
 433   <COND (<FORK-STS? .FORK ,ST-BIT-TTY>
 434          <SET-FORK-STS .FORK (,ST-BIT-TTY)>
 435          <COND (.PERM?
 436                 <SET-FORK-STS .FORK (,ST-BIT-HAD-TTY)>)
 437                (T
 438                 <SET-FORK-STS .FORK ,ST-BIT-HAD-TTY>)>
 439          <SETG CURRENT-GROUP ,MY-GROUP>
 440          <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP <1 ,GROUP-BUF ,MY-GROUP>>
 441          <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
 442   <INT-LEVEL .OINT>
 443   .CHAN>
 444
 445 <DEFINE PASS-TTY-DOWN (CHAN OPER "OPTIONAL" (OINT <INT-LEVEL>)
 446                        "AUX" (FORK <CHANNEL-DATA .CHAN>))
 447   #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
 448   <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
 449   <SET-FORK-STS .FORK ,ST-BIT-HAD-TTY (,ST-BIT-TTY-WAIT)>
 450   <CONTINUE-FORK .CHAN .OPER .OINT>>
 451
 452 <DEFINE CONTINUE-FORK (CHAN OPER "OPTIONAL" (OINT? <>)
 453                        "AUX" (FORK <CHANNEL-DATA .CHAN>) OINT
 454                              (FIXED? <>)
 455                              (BROKEN? <CHANNEL-OP ,OUTCHAN TTY-BROKEN?>))
 456   #DECL ((CHAN) CHANNEL (OINT?) <OR FIX FALSE> (FORK) FORK (OINT) FIX
 457          (FIXED?) <SPECIAL <OR ATOM FALSE>>)
 458   <UNWIND
 459    <PROG ()
 460      <COND (<FORK-STS? .FORK ,ST-BIT-DEAD>
 461             <RETURN #FALSE ("FORK CAN'T BE CONTINUED")>)>
 462      <COND (<NOT .OINT?>
 463             <SET OINT <INT-LEVEL>>
 464             <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>)
 465            (<SET OINT .OINT?>)>
 466      <COND (<FORK-STS? .FORK ,ST-BIT-HAD-TTY>
 467             <SET-FORK-STS .FORK ,ST-BIT-TTY (,ST-BIT-HAD-TTY)>
 468             <SET FIXED? T>
 469             <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN FIX-TTY>)>
 470             <COND (<==? ,CURRENT-GROUP ,MY-GROUP>
 471                    <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIS <1 ,BIS-BUF ,LTOSTOP>>
 472                    <SETG CURRENT-GROUP <FORK-ID .FORK>>
 473                    <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP
 474                          <1 ,GROUP-BUF <FORK-ID .FORK>>>)>)>
 475      <SET-FORK-STS .FORK ,ST-BIT-RUNNING>
 476      <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-CONT>
 477      <COND (<OR .OINT? .FIXED?>
 478             <WAIT-FORK .CHAN .OPER .OINT>
 479             <SETG CURRENT-GROUP ,MY-GROUP>
 480             <CALL SYSCALL IOCTL ,STDIN ,TIOCSPGRP <1 ,GROUP-BUF ,MY-GROUP>>
 481             <CALL SYSCALL IOCTL ,STDIN ,TIOCLBIC <1 ,BIS-BUF ,LTOSTOP>>
 482             <COND (.BROKEN? <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
 483             <SET FIXED? <>>)>
 484      <INT-LEVEL .OINT>
 485      .CHAN>
 486    <PROG ()
 487      <COND (<AND .FIXED? .BROKEN?>
 488             <CHANNEL-OP ,OUTCHAN BREAK-TTY>)>
 489      <INT-LEVEL .OINT>>>>
 490
 491 <SETG WAIT-BUF <UVECTOR 0>>
 492 <SETG GROUP-BUF <UVECTOR 0>>
 493 <GDECL (GROUP-BUF WAIT-BUF) UVECTOR>
 494 <DEFINE WAIT-FORK WAIT-ACT (CHAN OPER "OPTIONAL" (OINT? <>)
 495                    "AUX" (FORK <CHANNEL-DATA .CHAN>)
 496                          (CURRENT-FORK <FORK-ID .FORK>))
 497   #DECL ((CHAN) CHANNEL (OINT?) <OR FIX FALSE> (FORK) FORK
 498          (CURRENT-FORK) <SPECIAL FIX> (WAIT-ACT) <SPECIAL FRAME>)
 499   <COND (.OINT?
 500          <INT-LEVEL .OINT?>)>
 501   <PROG (CID)
 502     <COND (<NOT <FORK-STS? .FORK ,ST-BIT-RUNNING>>
 503            .CHAN)
 504           (<==? <SET CID <ISYSCALL WAIT ,WAIT-BUF ,WUNTRACED 0>>
 505                 .CURRENT-FORK>
 506            <PROCESS-FORK .CID <1 ,WAIT-BUF>>
 507            .CHAN)
 508           (.CID
 509            <INTERRUPT "INFERIOR">
 510            <AGAIN>)
 511           (<==? <1 .CID> ,EINTR>
 512            <INTERRUPT "INFERIOR">
 513            <AGAIN>)
 514           (T
 515            <SYS-ERR "" .CID <>>)>>>
 516
 517 <DEFINE REPORT (CHAN "AUX" (FORK <CHANNEL-DATA .CHAN>))
 518   #DECL ((CHAN) CHANNEL (FORK) FORK)
 519   <COND (<OR <NOT <ASSIGNED? CURRENT-FORK>>
 520              <N==? .CURRENT-FORK <FORK-ID .FORK>>>
 521          <INTERRUPT "USER-INFERIOR" .CHAN>)
 522         (T
 523          <DISMISS .CHAN .WAIT-ACT>)>>
 524
 525 <DEFINE KILL-FORK (CHAN OPER "AUX" (FORK <CHANNEL-DATA .CHAN>)
 526                    (OINT <INT-LEVEL>) (AF ,ALL-FORKS) L)
 527   #DECL ((CHAN) CHANNEL (FORK) FORK (OINT) FIX)
 528   <INT-LEVEL <MAX .OINT ,FORK-INT-LEV>>
 529   <COND (<NOT <FORK-STS? .FORK ,ST-BIT-DEAD>>
 530          <SET-FORK-STS .FORK ,STATUS-KILLED>
 531          <CALL SYSCALL KILL <FORK-ID .FORK> ,SIG-KILL>)>
 532   <COND (<SET L <MEMQ <FORK-ID .FORK> .AF>>
 533          <COND (<TYPE? <FORK-INPUT .FORK> CHANNEL>
 534                 <CLOSE <FORK-INPUT .FORK>>)>
 535          <COND (<TYPE? <FORK-OUTPUT .FORK> CHANNEL>
 536                 <CLOSE <FORK-OUTPUT .FORK>>)>
 537          <COND (<==? .L .AF>
 538                 <SETG ALL-FORKS <REST .AF 2>>)
 539                (T
 540                 <PUTREST <REST .AF <- <LENGTH .AF> <LENGTH .L> 1>>
 541                          <REST .L 2>>)>)>
 542   <TAKE-TTY-BACK .CHAN .OPER>
 543   <INT-LEVEL .OINT>
 544   .CHAN>
 545
 546 <DEFINE FORK-PRINT-DATA (CHANNEL OPER OUTCHAN
 547                          "AUX" (FORK <CHANNEL-DATA .CHANNEL>) OTH)
 548   #DECL ((CHANNEL) CHANNEL (OUTCHAN) CHANNEL (FORK) FORK)
 549   <PRINC "#FORK [" .OUTCHAN>
 550   <PRINC "PID:" .OUTCHAN>
 551   <PRIN1 <FORK-ID .FORK> .OUTCHAN>
 552   <PRINC " GROUP:" .OUTCHAN>
 553   <PRIN1 <FORK-GRP .FORK> .OUTCHAN>
 554   <PRINC " STATUS:" .OUTCHAN>
 555   <COND (<FORK-STS? .FORK ,ST-BIT-DEAD>
 556          <COND (<==? <SET OTH <ANDB <FORK-STS .FORK> ,ST-BIT-OTHER>>
 557                      ,ST-OTH-KILLED>
 558                 <PRINC "KILLED" .OUTCHAN>)
 559                (<==? .OTH ,ST-OTH-QUIT>
 560                 <PRINC "QUIT" .OUTCHAN>
 561                 <COND (<NOT <0? <FORK-DATA .FORK>>>
 562                        <PRINC !\: .OUTCHAN>
 563                        <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)
 564                (<==? .OTH ,ST-OTH-DIED>
 565                 <PRINC "DIED:" .OUTCHAN>
 566                 <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)
 567         (T
 568          <COND (<FORK-STS? .FORK ,ST-BIT-TTY-WAIT>
 569                 <PRINC "TTYWAIT;" .OUTCHAN>)
 570                (<FORK-STS? .FORK ,ST-BIT-TTY>
 571                 <PRINC "TTY;" .OUTCHAN>)
 572                (T
 573                 <PRINC "NOTTY;" .OUTCHAN>)>
 574          <COND (<FORK-STS? .FORK ,ST-BIT-HAD-TTY>
 575                 <PRINC "HADTTY;" .OUTCHAN>)>
 576          <COND (<FORK-STS? .FORK ,ST-BIT-RUNNING>
 577                 <PRINC "RUNNING" .OUTCHAN>)
 578                (T
 579                 <PRINC "STOPPED" .OUTCHAN>
 580                 <COND (<NOT <0? <FORK-DATA .FORK>>>
 581                        <PRINC !\: .OUTCHAN>
 582                        <PRINC <FORK-DATA .FORK> .OUTCHAN>)>)>)>
 583   <PRINC " INPUT:" .OUTCHAN>
 584   <COND (<TYPE? <SET OTH <FORK-INPUT .FORK>> CHANNEL>
 585          <PRINC <CHANNEL-TYPE .OTH> .OUTCHAN>)
 586         (<TYPE? .OTH FIX>
 587          <PRINC "GIVETTY" .OUTCHAN>)
 588         (T
 589          <PRINC "TTY" .OUTCHAN>)>
 590   <PRINC " OUTPUT:" .OUTCHAN>
 591   <COND (<TYPE? <SET OTH <FORK-OUTPUT .FORK>> CHANNEL>
 592          <PRINC <CHANNEL-TYPE .OTH> .OUTCHAN>)
 593         (<TYPE? .OTH FIX>
 594          <PRINC "GIVETTY" .OUTCHAN>)
 595         (T
 596          <PRINC "TTY" .OUTCHAN>)>
 597   <PRINC !\] .OUTCHAN>>
 598
 599 <MSETG FORK-STATUS-QUIT 1>
 600 <MSETG FORK-STATUS-KILLED 2>
 601 <MSETG FORK-STATUS-DIED 3>
 602 <MSETG FORK-STATUS-DEAD 4>
 603 <MSETG FORK-STATUS-RUNNING 5>
 604 <MSETG FORK-STATUS-STOPPED 6>
 605 <MSETG FORK-STATUS-WAIT 7>
 606 <DEFINE TEST-FORK-STATUS (CHAN OPER WHICH "AUX" (FORK <CHANNEL-DATA .CHAN>)
 607                           (OTH <ANDB <FORK-STS .FORK> ,ST-BIT-OTHER>))
 608   #DECL ((CHAN) CHANNEL (WHICH) FIX (FORK) FORK)
 609   <COND (<==? .WHICH ,FORK-STATUS-QUIT>
 610          <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
 611                      <==? .OTH ,ST-OTH-QUIT>>
 612                 <FORK-DATA .FORK>)>)
 613         (<==? .WHICH ,FORK-STATUS-KILLED>
 614          <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
 615                      <==? .OTH ,ST-OTH-KILLED>>
 616                 T)>)
 617         (<==? .WHICH ,FORK-STATUS-DIED>
 618          <COND (<AND <FORK-STS? .FORK ,ST-BIT-DEAD>
 619                      <==? .OTH ,ST-OTH-DIED>>
 620                 <FORK-DATA .FORK>)>)
 621         (<==? .WHICH ,FORK-STATUS-DEAD>
 622          <FORK-STS? .FORK ,ST-BIT-DEAD>)
 623         (<==? .WHICH ,FORK-STATUS-RUNNING>
 624          <FORK-STS? .FORK ,ST-BIT-RUNNING>)
 625         (<==? .WHICH ,FORK-STATUS-STOPPED>
 626          <COND (<NOT <FORK-STS? .FORK ,ST-BIT-RUNNING>>
 627                 <FORK-DATA .FORK>)>)
 628         (<==? .WHICH ,FORK-STATUS-WAIT>
 629          <FORK-STS? .FORK ,ST-BIT-TTY-WAIT>)>>
 630
 631 <ENDPACKAGE>