sumex/main.mcr227

   1 TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES\r
   2 \r
   3 RELOCA\r
   4 \r
   5 .GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE\r
   6 .GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI\r
   7 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN\r
   8 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC\r
   9 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT\r
  10 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1\r
  11 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6\r
  12 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM\r
  13 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM\r
  14 .GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY\r
  15 .GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI\r
  16 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ\r
  17 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG\r
  18 .GLOBAL TYPIC\r
  19 .INSRT MUDDLE >\r
  20 \r
  21 MONITS==1               ; SET TO 1 IF PC DEMON WANTED\r
  22 .VECT.==1               ; BIT TO INDICATE VECTORS FOR GCHACK\r
  23 \r
  24 ;MAIN LOOP AND STARTUP\r
  25 \r
  26 START:  MOVEI   0,0                     ; SET NO HACKS\r
  27         MOVEM   0,WHOAMI                ; HACK FOR TS FOO linked to TS MUDDLE\r
  28         MOVE    PVP,MAINPR              ; MAKE SURE WE START IN THE MAIN PROCESS\r
  29         JUMPE   0,INITIZ                ; MIGHT BE RESTART\r
  30         MOVE    P,PSTO+1(PVP)           ; SET UP FOR BOOTSTRAP HACK\r
  31         MOVE    TP,TPSTO+1(PVP)\r
  32 INITIZ: SKIPN   P                       ; IF NO CURRENT P\r
  33         MOVE    P,PSTO+1(PVP)           ; PDL TO GET OFF THE GROUND\r
  34         SKIPN   TP                      ; SAME FOR TP\r
  35         MOVE    TP,TPSTO+1(PVP)         ; GET A TP TO WORK WITH\r
  36         MOVE    TVP,TVPSTO+1(PVP)       ; GET A TVP\r
  37         SETZB   R,M                     ; RESET RSUBR AC'S\r
  38         PUSHJ   P,%RUNAM\r
  39         PUSHJ   P,%RJNAM\r
  40         PUSHJ   P,TTYOPE                ;OPEN THE TTY\r
  41         MOVEI   B,MUDSTR\r
  42         SKIPE   WHOAMI          ; SKIP IF THIS IS MUDDLE\r
  43         JRST    .+3             ; ELSE NO MESSAGE\r
  44         SKIPN   NOTTY                   ; IF NO TTY, IGNORE\r
  45         PUSHJ   P,MSGTYP                ;TYPE OUT TO USER\r
  46 \r
  47         XCT     MESSAG                  ;MAYBE PRINT A MESSAGE\r
  48         PUSHJ   P,INTINT                ;INITIALIZE INTERRUPT HANDLER\r
  49         XCT     IPCINI\r
  50         PUSHJ   P,PURCLN                ; CLEAN UP PURE SHARED AREA\r
  51 RESTART:                                ;RESTART A PROCESS\r
  52 STP:    MOVEI   C,0\r
  53         MOVE    B,TBINIT+1(PVP)         ;POINT INTO STACK AT START\r
  54         PUSHJ   P,CHUNW                 ; LEAVE WHILE DOING UNWIND CHECK\r
  55         MOVEI   E,TOPLEV\r
  56         MOVEI   A,TFALSE                ; IN CASE FALLS OFF PROCESS\r
  57         MOVEI   B,0\r
  58         MOVEM   E,-1(TB)\r
  59         JRST    CONTIN\r
  60 \r
  61         MQUOTE  TOPLEVEL\r
  62 TOPLEVEL:\r
  63         MCALL   0,LISTEN\r
  64         JRST    TOPLEVEL\r
  65 \f\r
  66 \r
  67 MFUNCTION LISTEN,SUBR\r
  68 \r
  69         ENTRY\r
  70         PUSH    P,[0]           ;FLAG: DON'T PRINT ERROR MSG\r
  71         JRST    ER1\r
  72 \r
  73 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE\r
  74         IMQUOTE ERROR\r
  75 \r
  76 ERROR:  MOVE    B,IMQUOTE ERROR\r
  77         PUSHJ   P,IGVAL         ; GET VALUE\r
  78         GETYP   C,A\r
  79         CAIN    C,TSUBR         ; CHECK FOR NO CHANGE\r
  80         CAIE    B,RERR1         ; SKIP IF NOT CHANGED\r
  81         JRST    .+2\r
  82         JRST    RERR1           ; GO TO THE DEFAULT\r
  83         PUSH    TP,A            ; SAVE VALUE\r
  84         PUSH    TP,B\r
  85         MOVE    C,AB            ; SAVE AB\r
  86         MOVEI   D,1             ; AND COUNTER\r
  87 USER1:  PUSH    TP,(C)          ; PUSH THEM\r
  88         PUSH    TP,1(C)\r
  89         ADD     C,[2,,2]        ; BUMP\r
  90         ADDI    D,1\r
  91         JUMPL   C,USER1\r
  92         ACALL   D,APPLY         ; EVAL USERS ERROR\r
  93         JRST    FINIS\r
  94 \r
  95 \r
  96 TPSUBR==TSUBR+400000\r
  97 \r
  98 MFUNCTION ERROR%,PSUBR,ERROR\r
  99 \r
 100 RMT [EXPUNGE TPSUBR\r
 101 ]\r
 102 RERR1:  ENTRY\r
 103         PUSH    TP,$TATOM\r
 104         PUSH    TP,MQUOTE ERROR,ERROR,INTRUP\r
 105         PUSHJ   P,FRMSTK        ; PUT ERROR'S FRAME ON STACK\r
 106         MOVEI   D,2\r
 107         MOVE    C,AB\r
 108 RERR2:  JUMPGE  C,RERR22\r
 109         PUSH    TP,(C)\r
 110         PUSH    TP,1(C)\r
 111         ADD     C,[2,,2]\r
 112         AOJA    D,RERR2\r
 113 RERR22: ACALL   D,EMERGENCY\r
 114         JRST    RERR\r
 115 \r
 116 IMQUOTE ERROR\r
 117 RERR:   ENTRY\r
 118         PUSH    P,[-1]          ;PRINT ERROR FLAG\r
 119 \r
 120 ER1:    MOVE    B,IMQUOTE INCHAN\r
 121         PUSHJ   P,ILVAL         ; CHECK INPUT CHANNEL IS SOME KIND OF TTY\r
 122         GETYP   A,A\r
 123         CAIE    A,TCHAN         ; SKIP IF IT IS A CHANNEL\r
 124         JRST    ER2             ; NO, MUST REBIND\r
 125         CAMN    B,TTICHN+1(TVP)\r
 126         JRST    NOTINC\r
 127 ER2:    MOVE    B,IMQUOTE INCHAN\r
 128         MOVEI   C,TTICHN(TVP)   ; POINT TO VALU\r
 129         PUSHJ   P,PUSH6         ; PUSH THE BINDING\r
 130         MOVE    B,TTICHN+1(TVP) ; GET IN CHAN\r
 131 NOTINC: SKIPE   NOTTY\r
 132         JRST    NOECHO\r
 133         PUSH    TP,$TCHAN\r
 134         PUSH    TP,B\r
 135         PUSH    TP,$TATOM\r
 136         PUSH    TP,MQUOTE T\r
 137         MCALL   2,TTYECH        ; ECHO INPUT\r
 138 NOECHO: MOVE    B,IMQUOTE OUTCHAN\r
 139         PUSHJ   P,ILVAL         ; GET THE VALUE\r
 140         GETYP   A,A\r
 141         CAIE    A,TCHAN         ; SKIP IF OK CHANNEL\r
 142         JRST    ER3             ; NOT CHANNEL, MUST REBIND\r
 143         CAMN    B,TTOCHN+1(TVP)\r
 144         JRST    NOTOUT\r
 145 ER3:    MOVE    B,IMQUOTE OUTCHAN\r
 146         MOVEI   C,TTOCHN(TVP)\r
 147         PUSHJ   P,PUSH6         ; PUSH THE BINDINGS\r
 148 NOTOUT: MOVE    B,IMQUOTE OBLIST\r
 149         PUSHJ   P,ILVAL ; GET THE VALUE OF OBLIST\r
 150         PUSHJ   P,OBCHK         ; IS IT A WINNER ?\r
 151         SKIPA   A,$TATOM        ; NO, SKIP AND CONTINUE\r
 152         JRST    NOTOBL          ; YES, DO NOT DO REBINDING\r
 153         MOVE    B,IMQUOTE OBLIST\r
 154         PUSHJ   P,IGLOC\r
 155         GETYP   0,A\r
 156         CAIN    0,TUNBOU\r
 157         JRST    MAKOB           ; NO GLOBAL OBLIST, MAKE ONE\r
 158         MOVEI   C,(B)           ; COPY ADDRESS\r
 159         MOVE    A,(C)           ; GET THE GVAL\r
 160         MOVE    B,(C)+1\r
 161         PUSHJ   P,OBCHK         ; IS IT A WINNER ?\r
 162         JRST    MAKOB           ; NO, GO MAKE A NEW ONE\r
 163         MOVE    B,IMQUOTE OBLIST\r
 164         PUSHJ   P,PUSH6\r
 165 \r
 166 NOTOBL: PUSH    TP,[TATOM,,-1]  ;FOR BINDING\r
 167         PUSH    TP,IMQUOTE LER,[LERR ]INTRUP\r
 168         PUSHJ   P,MAKACT\r
 169         HRLI    A,TFRAME        ; CORRCT TYPE\r
 170         PUSH    TP,A\r
 171         PUSH    TP,B\r
 172         PUSH    TP,[0]\r
 173         PUSH    TP,[0]\r
 174         MOVE    A,PVP           ; GET PROCESS\r
 175         ADD     A,[PROCID,,PROCID]      ; POINT TO ID (ALSO LEVEL)\r
 176         PUSH    TP,BNDV\r
 177         PUSH    TP,A\r
 178         MOVE    A,PROCID(PVP)\r
 179         ADDI    A,1             ; BUMP ERROR LEVEL\r
 180         PUSH    TP,A\r
 181         PUSH    TP,PROCID+1(PVP)\r
 182         PUSH    P,A\r
 183 \r
 184         MOVE    B,IMQUOTE READ-TABLE\r
 185         PUSHJ   P,IGVAL\r
 186         PUSH    TP,[TATOM,,-1]\r
 187         PUSH    TP,IMQUOTE READ-TABLE\r
 188         GETYP   C,A             ; TO GVAL OF READ-TABLE ON ERROR AND\r
 189         CAIE    C,TVEC  ; TOP ERRET'S\r
 190         JRST    .+4\r
 191         PUSH    TP,A\r
 192         PUSH    TP,B\r
 193         JRST    .+3\r
 194         PUSH    TP,$TUNBOUND\r
 195         PUSH    TP,[-1]\r
 196         PUSH    TP,[0]\r
 197         PUSH    TP,[0]\r
 198 \r
 199         PUSHJ   P,SPECBIND      ;BIND THE CRETANS\r
 200         MOVE    A,-1(P)         ;RESTORE SWITHC\r
 201         JUMPE   A,NOERR         ;IF 0, DONT PRINT ERROR MESS\r
 202         PUSH    TP,$TATOM\r
 203         PUSH    TP,EQUOTE *ERROR*\r
 204         MCALL   0,TERPRI\r
 205         MCALL   1,PRINC ;PRINT THE MESSAGE\r
 206 NOERR:  MOVE    C,AB            ;GET A COPY OF AB\r
 207 \r
 208 ERRLP:  JUMPGE  C,LEVPRT        ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP\r
 209         PUSH    TP,$TAB\r
 210         PUSH    TP,C\r
 211         MOVEI   B,PRIN1\r
 212         GETYP   A,(C)           ; GET  ARGS TYPE\r
 213         CAIE    A,TATOM\r
 214         JRST    ERROK\r
 215         MOVE    A,1(C)          ; GET ATOM\r
 216         MOVE    A,2(A)\r
 217         CAIE    A,ERROBL+1\r
 218         CAMN    A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST\r
 219         MOVEI   B,PRINC         ; DONT PRINT TRAILER\r
 220 ERROK:  PUSH    P,B             ; SAVE ROUTINE POINTER\r
 221         PUSH    TP,(C)\r
 222         PUSH    TP,1(C)\r
 223         MCALL   0,TERPRI        ; CRLF\r
 224         POP     P,B             ; GET ROUTINE BACK\r
 225         .MCALL  1,(B)\r
 226         POP     TP,C\r
 227         SUB     TP,[1,,1]\r
 228         ADD     C,[2,,2]        ;BUMP SAVED AB\r
 229         JRST    ERRLP           ;AND CONTINUE\r
 230 \r
 231 \r
 232 LEVPRT: XCT     INITFL          ;LOAD MUDDLE INIT FILE IF FIRST TIME\r
 233         MCALL   0,TERPRI\r
 234         PUSH    TP,$TATOM\r
 235         PUSH    TP,EQUOTE [LISTENING-AT-LEVEL ]\r
 236         MCALL   1,PRINC         ;PRINT LEVEL\r
 237         PUSH    TP,$TFIX        ;READY TO PRINT LEVEL\r
 238         HRRZ    A,(P)           ;GET LEVEL\r
 239         SUB     P,[2,,2]        ;AND POP STACK\r
 240         PUSH    TP,A\r
 241         MCALL   1,PRIN1         ;PRINT WITHOUT SPACES ETC.\r
 242         PUSH    TP,$TATOM       ;NOW PROCESS\r
 243         PUSH    TP,EQUOTE [ PROCESS ]\r
 244         MCALL   1,PRINC         ;DONT SLASHIFY SPACES\r
 245         PUSH    TP,PROCID(PVP)  ;NOW ID\r
 246         PUSH    TP,PROCID+1(PVP)\r
 247         MCALL   1,PRIN1\r
 248         SKIPN   C,CURPRI\r
 249         JRST    MAINLP\r
 250         PUSH    TP,$TFIX\r
 251         PUSH    TP,C\r
 252         PUSH    TP,$TATOM\r
 253         PUSH    TP,EQUOTE [ INT-LEVEL ]\r
 254         MCALL   1,PRINC\r
 255         MCALL   1,PRIN1\r
 256         JRST    MAINLP          ; FALL INTO MAIN LOOP\r
 257         \r
 258 \f;ROUTINES FOR ERROR-LISTEN\r
 259 \r
 260 OBCHK:  GETYP   0,A\r
 261         CAIN    0,TOBLS\r
 262         JRST    CPOPJ1          ; WIN FOR SINGLE OBLIST\r
 263         CAIE    0,TLIST         ; IF LIST, MAKE SURE EACH IS AN OBLIST\r
 264         JRST    CPOPJ           ; ELSE, LOSE\r
 265 \r
 266         JUMPE   B,CPOPJ         ; NIL ,LOSE\r
 267         PUSH    TP,A\r
 268         PUSH    TP,B\r
 269         PUSH    P,[0]           ;FLAG FOR DEFAULT CHECKING\r
 270         MOVEI   0,1000          ; VERY BIG NUMBER FOR CIRCULARITY TEST\r
 271 \r
 272 OBCHK0: INTGO\r
 273         SOJE    0,OBLOSE        ; CIRCULARITY TEST\r
 274         HRRZ    B,(TP)          ; GET LIST POINTER\r
 275         GETYP   A,(B)\r
 276         CAIE    A,TOBLS         ; SKIP IF WINNER\r
 277         JRST    DEFCHK          ; CHECK FOR SPECIAL ATOM DEFAULT\r
 278         HRRZ    B,(B)\r
 279         MOVEM   B,(TP)\r
 280         JUMPN   B,OBCHK0\r
 281 OBWIN:  AOS     (P)-1\r
 282 OBLOSE: SUB     TP,[2,,2]\r
 283         SUB     P,[1,,1]\r
 284         POPJ    P,\r
 285 \r
 286 DEFCHK: SKIPN   (P)             ; BEEN HERE BEFORE ?\r
 287         CAIE    A,TATOM         ; OR, NOT AN ATOM ?\r
 288         JRST    OBLOSE          ; YES, LOSE\r
 289         MOVE    A,(B)+1\r
 290         CAME    A,MQUOTE DEFAULT\r
 291         JRST    OBLOSE          ; LOSE\r
 292         SETOM   (P)             ; SET FLAG\r
 293         HRRZ    B,(B)           ; CHECK FOR END OF LIST\r
 294         MOVEM   B,(TP)\r
 295         JUMPN   B,OBCHK0                ; NOT THE END, CONTINUE LOOKING\r
 296         JRST    OBLOSE          ; LOSE FOR DEFAULT AT THE END\r
 297 \r
 298 \r
 299 \r
 300 PUSH6:  PUSH    TP,[TATOM,,-1]\r
 301         PUSH    TP,B\r
 302         PUSH    TP,(C)\r
 303         PUSH    TP,1(C)\r
 304         PUSH    TP,[0]\r
 305         PUSH    TP,[0]\r
 306         POPJ    P,\r
 307 \r
 308 \r
 309 MAKOB:  PUSH    TP,INITIAL(TVP)\r
 310         PUSH    TP,INITIAL+1(TVP)\r
 311         PUSH    TP,ROOT(TVP)\r
 312         PUSH    TP,ROOT+1(TVP)\r
 313         MCALL   2,LIST\r
 314         PUSH    TP,$TATOM\r
 315         PUSH    TP,IMQUOTE OBLIST\r
 316         PUSH    TP,A\r
 317         PUSH    TP,B\r
 318         MCALL   2,SETG\r
 319         PUSH    TP,[TATOM,,-1]\r
 320         PUSH    TP,IMQUOTE OBLIST\r
 321         PUSH    TP,A\r
 322         PUSH    TP,B\r
 323         PUSH    TP,[0]\r
 324         PUSH    TP,[0]\r
 325         JRST    NOTOBL\r
 326 \f\r
 327 \r
 328 ;THIS IS IT FOLKS...THE MAIN LOOP.  READ, EVAL, PRINT\r
 329 \r
 330 MAINLP: MOVE    A,$TATOM        ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE\r
 331         MOVE    B,MQUOTE REP\r
 332         PUSHJ   P,ILVAL         ;GET ITS LVAL TO SEE IF REDEFINED\r
 333         GETYP   C,A\r
 334         CAIE    C,TUNBOUND\r
 335         JRST    REPCHK\r
 336         MOVE    A,$TATOM        ;SEE IF IT HAS GVAL SINCE NO LVAL\r
 337         MOVE    B,MQUOTE REP\r
 338         PUSHJ   P,IGVAL\r
 339         GETYP   C,A\r
 340         CAIN    C,TUNBOUN\r
 341         JRST    IREPER\r
 342 REPCHK: CAIN    C,TSUBR\r
 343         CAIE    B,REPER\r
 344         JRST    .+2\r
 345         JRST    IREPER\r
 346 REREPE: PUSH    TP,A\r
 347         PUSH    TP,B\r
 348         GETYP   A,-1(TP)\r
 349         PUSHJ   P,APLQ\r
 350         JRST    ERRREP\r
 351         MCALL   1,APPLY         ;LOOSER HAS REDEFINED SO CALL HIS\r
 352         JRST    MAINLP\r
 353 IREPER: PUSH    P,[0]           ;INDICATE FALL THROUGH\r
 354         JRST    REPERF\r
 355 \r
 356 ERRREP: PUSH    TP,[TATOM,,-1]\r
 357         PUSH    TP,MQUOTE REP\r
 358         PUSH    TP,$TSUBR\r
 359         PUSH    TP,[REPER]\r
 360         PUSH    TP,[0]\r
 361         PUSH    TP,[0]\r
 362         PUSHJ   P,SPECBIN\r
 363         PUSH    TP,$TATOM\r
 364         PUSH    TP,EQUOTE NON-APPLICABLE-REP\r
 365         PUSH    TP,-11(TP)\r
 366         PUSH    TP,-11(TP)\r
 367         MCALL   2,ERROR\r
 368         SUB     TP,[6,,6]\r
 369         PUSHJ   P,SSPECS\r
 370         JRST    REREPE\r
 371 \r
 372 \r
 373 MFUNCTION REPER,SUBR,REP\r
 374 REPER:  ENTRY   0\r
 375         PUSH    P,[1]           ;INDICATE DIRECT CALL\r
 376 REPERF: MCALL   0,TERPRI\r
 377         MCALL   0,READ\r
 378         PUSH    TP,A\r
 379         PUSH    TP,B\r
 380         MCALL   0,TERPRI\r
 381         MCALL   1,EVAL\r
 382         PUSH    TP,$TATOM\r
 383         PUSH    TP,IMQUOTE LAST-OUT\r
 384         PUSH    TP,A\r
 385         PUSH    TP,B\r
 386         MCALL   2,SET\r
 387         PUSH    TP,A\r
 388         PUSH    TP,B\r
 389         MCALL   1,PRIN1\r
 390         POP     P,C             ;FLAG FOR FALL THROUGH OR CALL\r
 391         JUMPN   C,FINIS         ;IN CASE LOOSER CALLED REP\r
 392         JRST    MAINLP\r
 393 \r
 394 \f\r
 395 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL\r
 396 \r
 397 MFUNCTION RETRY,SUBR\r
 398 \r
 399         ENTRY\r
 400         JUMPGE  AB,RETRY1       ; USE MOST RECENT\r
 401         CAMGE   AB,[-2,,0]\r
 402         JRST    TMA\r
 403         GETYP   A,(AB)          ; CHECK TYPE\r
 404         CAIE    A,TFRAME\r
 405         JRST    WTYP1\r
 406         MOVEI   B,(AB)          ; POINT TO ARG\r
 407         JRST    RETRY2\r
 408 RETRY1: MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
 409         PUSHJ   P,ILOC          ; LOCATIVE TO FRAME\r
 410 RETRY2: PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY\r
 411         HRRZ    0,OTBSAV(B)     ; CHECK FOR TOP\r
 412         JUMPE   0,RESTAR        ; YES RE-ENTER TOP LEVEL\r
 413         PUSH    TP,$TTB\r
 414         PUSH    TP,B            ; SAVE FRAME\r
 415         MOVE    B,OTBSAV(B)     ; GET PRVIOUS FOR UNBIND HACK\r
 416         MOVEI   C,-1(TP)\r
 417         PUSHJ   P,CHUNW         ; CHECK ANY UNWINDING\r
 418         CAME    SP,SPSAV(TB)    ; UNBINDING NEEDED?\r
 419         PUSHJ   P,SPECSTORE\r
 420         MOVE    P,PSAV(TB)      ; GET OTHER STUFF\r
 421         MOVE    AB,ABSAV(B)\r
 422         HLRE    A,AB            ; COMPUTE # OF ARGS\r
 423         MOVNI   A,-FRAMLN(A)    ; MAKE TP POINT PAST FRAME\r
 424         HRLI    A,(A)\r
 425         MOVE    C,TPSAV(TB)     ; COMPUTE TP\r
 426         ADD     C,A\r
 427         MOVE    TP,C\r
 428         MOVE    TB,B            ; FIX UP TB\r
 429         HRRZ    C,FSAV(TB)      ; GET FUNCTION\r
 430         CAMGE   C,VECTOP        ; CHECK FOR RSUBR\r
 431         CAMG    C,VECBOT\r
 432         JRST    (C)             ; GO\r
 433         GETYP   0,(C)           ; RSUBR OR ENTRY?\r
 434         CAIE    0,TATOM\r
 435         CAIN    0,TRSUBR\r
 436         JRST    RETRNT\r
 437         MOVS    R,(C)           ; SET UP R\r
 438         HRRI    R,(C)\r
 439         MOVEI   C,0\r
 440         JRST    RETRN3\r
 441 \r
 442 RETRNT: CAIE    0,TRSUBR\r
 443         JRST    RETRN1\r
 444         MOVE    R,1(C)\r
 445 RETRN4: HRRZ    C,2(C)          ; OFFSET\r
 446 RETRN3: SKIPL   M,1(R)\r
 447         JRST    RETRN5\r
 448 RETRN7: ADDI    C,(M)\r
 449         JRST    (C)\r
 450 \r
 451 RETRN5: MOVEI   D,(M)           ; TOTAL OFFSET\r
 452         MOVSS   M\r
 453         ADD     M,PURVEC+1(TVP)\r
 454         SKIPL   M,1(M)\r
 455         JRST    RETRN6\r
 456         ADDI    M,(D)\r
 457         JRST    RETRN7\r
 458 RETRN6: HLRZ    A,1(R)\r
 459         PUSH    P,D\r
 460         PUSH    P,C\r
 461         PUSHJ   P,PLOAD\r
 462         JRST    RETRER          ; LOSER\r
 463         POP     P,C\r
 464         POP     P,D\r
 465         MOVE    M,B\r
 466         JRST    RETRN7\r
 467 \r
 468 RETRN1: MOVE    B,1(C)\r
 469         PUSH    TP,$TVEC\r
 470         PUSH    TP,C\r
 471         PUSHJ   P,IGVAL\r
 472         GETYP   0,A\r
 473         MOVE    C,(TP)\r
 474         SUB     TP,[2,,2]\r
 475         CAIE    0,TRSUBR\r
 476         JRST    RETRN2\r
 477         MOVE    R,B\r
 478         JRST    RETRN3\r
 479 \r
 480 RETRN2: PUSH    TP,$TATOM\r
 481         PUSH    TP,EQUOTE CANT-RETRY-ENTRY-GONE\r
 482         JRST    CALER1\r
 483 \r
 484 RETRER: PUSH    TP,$TATOM\r
 485         PUSH    TP,EQUOTE PURE-LOAD-FAILURE\r
 486         JRST    CALER1\r
 487 \r
 488 \f\r
 489 ;FUNCTION TO DO ERROR RETURN\r
 490 \r
 491 MFUNCTION ERRET,SUBR\r
 492 \r
 493         ENTRY\r
 494         HLRE    A,AB            ; -2*# OF ARGS\r
 495         JUMPGE  A,STP           ; RESTART PROCESS\r
 496         ASH     A,-1            ; -# OF ARGS\r
 497         AOJE    A,ERRET2        ; NO FRAME SUPPLIED\r
 498         AOJL    A,TMA\r
 499         ADD     AB,[2,,2]\r
 500         PUSHJ   P,OKFRT\r
 501         JRST    WTYP2\r
 502         SUB     AB,[2,,2]\r
 503         PUSHJ   P,CHPROC        ; POINT TO FRAME SLOT\r
 504         JRST    ERRET3\r
 505 ERRET2: MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
 506         PUSHJ   P,ILVAL         ; GET ITS VALUE\r
 507 ERRET3: PUSH    TP,A\r
 508         PUSH    TP,B\r
 509         MOVEI   B,-1(TP)\r
 510         PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY\r
 511         HRRZ    0,OTBSAV(B)     ; TOP LEVEL?\r
 512         JUMPE   0,TOPLOS\r
 513         PUSHJ   P,CHUNW         ; ANY UNWINDING\r
 514         JRST    CHFINIS\r
 515 \r
 516 \r
 517 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME\r
 518 \r
 519 MFUNCTION       FRAME,SUBR\r
 520         ENTRY\r
 521         SETZB   A,B\r
 522         JUMPGE  AB,FRM1         ; DEFAULT CASE\r
 523         CAMG    AB,[-3,,0]      ; SKIP IF OK ARGS\r
 524         JRST    TMA\r
 525         PUSHJ   P,OKFRT         ; A FRAME OR SIMILAR THING?\r
 526         JRST    WTYP1\r
 527 \r
 528 FRM1:   PUSHJ   P,CFRAME        ; GO TO INTERNAL\r
 529         JRST    FINIS\r
 530 \r
 531 CFRAME: JUMPN   A,FRM2          ; ARG SUPPLIED?\r
 532         MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
 533         PUSHJ   P,ILVAL\r
 534         JRST    FRM3\r
 535 FRM2:   PUSHJ   P,CHPROC        ; CHECK FOR PROCESS\r
 536         PUSH    TP,A\r
 537         PUSH    TP,B\r
 538         MOVEI   B,-1(TP)        ; POINT TO SLOT\r
 539         PUSHJ   P,CHFRM         ; CHECK IT\r
 540         MOVE    C,(TP)          ; GET FRAME BACK\r
 541         MOVE    B,OTBSAV(C)     ;GET PREVIOUS FRAME\r
 542         SUB     TP,[2,,2]\r
 543         TRNN    B,-1            ; SKIP IF OK\r
 544         JRST    TOPLOSE\r
 545 \r
 546 FRM3:   JUMPN   B,FRM4  ; JUMP IF WINNER\r
 547         MOVE    B,IMQUOTE THIS-PROCESS\r
 548         PUSHJ   P,ILVAL         ; GET PROCESS OF INTEREST\r
 549         GETYP   A,A             ; CHECK IT\r
 550         CAIN    A,TUNBOU\r
 551         MOVE    B,PVP           ; USE CURRENT\r
 552         MOVEI   A,PVLNT*2+1(B)  ; POINT TO DOPE WORDS\r
 553         MOVE    B,TBINIT+1(B)   ; AND BASE FRAME\r
 554 FRM4:   HLL     B,OTBSAV(B)     ;TIME\r
 555         HRLI    A,TFRAME\r
 556         POPJ    P,\r
 557 \r
 558 OKFRT:  AOS     (P)             ;ASSUME WINNAGE\r
 559         GETYP   0,(AB)\r
 560         MOVE    A,(AB)\r
 561         MOVE    B,1(AB)\r
 562         CAIE    0,TFRAME\r
 563         CAIN    0,TENV\r
 564         POPJ    P,\r
 565         CAIE    0,TPVP\r
 566         CAIN    0,TACT\r
 567         POPJ    P,\r
 568         SOS     (P)\r
 569         POPJ    P,\r
 570 \r
 571 CHPROC: GETYP   0,A             ; TYPE\r
 572         CAIE    0,TPVP\r
 573         POPJ    P,              ; OK\r
 574         MOVEI   A,PVLNT*2+1(B)\r
 575         CAMN    B,PVP           ; THIS PROCESS?\r
 576         JRST    CHPRO1\r
 577         MOVE    B,TBSTO+1(B)\r
 578         JRST    FRM4\r
 579 \r
 580 CHPRO1: MOVE    B,OTBSAV(TB)\r
 581         JRST    FRM4\r
 582 \r
 583 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME\r
 584 \r
 585 MFUNCTION       ARGS,SUBR\r
 586         ENTRY   1\r
 587         PUSHJ   P,OKFRT         ; CHECK FRAME TYPE\r
 588         JRST    WTYP1\r
 589         PUSHJ   P,CARGS\r
 590         JRST    FINIS\r
 591 \r
 592 CARGS:  PUSHJ   P,CHPROC\r
 593         PUSH    TP,A\r
 594         PUSH    TP,B\r
 595         MOVEI   B,-1(TP)        ; POINT TO FRAME SLOT\r
 596         PUSHJ   P,CHFRM         ; AND CHECK FOR VALIDITY\r
 597         MOVE    C,(TP)          ; FRAME BACK\r
 598         MOVSI   A,TARGS\r
 599 CARGS1: GETYP   0,FSAV(C)       ; IS THIS A FUNNY ONE\r
 600         CAIE    0,TCBLK         ; SKIP IF FUNNY\r
 601         JRST    .+3             ; NO NORMAL\r
 602         MOVE    C,OTBSAV(C)     ; ASSOCIATE WITH PREVIOUS FRAME\r
 603         JRST    CARGS1\r
 604         HLR     A,OTBSAV(C)     ; TIME IT AND\r
 605         MOVE    B,ABSAV(C)      ; GET POINTER\r
 606         SUB     TP,[2,,2]       ; FLUSH CRAP\r
 607         POPJ    P,\r
 608 \r
 609 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME\r
 610 \r
 611 MFUNCTION       FUNCT,SUBR      ;RETURNS FUNCTION NAME OF\r
 612         ENTRY   1       ; FRAME ARGUMENT\r
 613         PUSHJ   P,OKFRT         ; CHECK TYPE\r
 614         JRST    WTYP1\r
 615         PUSHJ   P,CFUNCT\r
 616         JRST    FINIS\r
 617 \r
 618 CFUNCT: PUSHJ   P,CHPROC\r
 619         PUSH    TP,A\r
 620         PUSH    TP,B\r
 621         MOVEI   B,-1(TP)\r
 622         PUSHJ   P,CHFRM         ; CHECK IT\r
 623         MOVE    C,(TP)          ; RESTORE FRAME\r
 624         HRRZ    A,FSAV(C)       ;FUNCTION POINTER\r
 625         CAMG    A,VECTOP        ;IS THIS AN RSUBR ?\r
 626         CAMGE   A,VECBOT\r
 627         SKIPA   B,@-1(A)        ;NO, GET SUBR'S NAME POINTER\r
 628         MOVE    B,(A)+3         ;YES, GET RSUBR'S NAME ENTRY\r
 629         MOVSI   A,TATOM\r
 630         SUB     TP,[2,,2]\r
 631         POPJ    P,\r
 632 \r
 633 BADFRAME:\r
 634         PUSH    TP,$TATOM\r
 635         PUSH    TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
 636         JRST    CALER1\r
 637 \r
 638 \r
 639 TOPLOSE:\r
 640         PUSH    TP,$TATOM\r
 641         PUSH    TP,EQUOTE TOP-LEVEL-FRAME\r
 642         JRST    CALER1\r
 643 \r
 644 \r
 645 \f\r
 646 \f\r
 647 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED\r
 648 \r
 649 MFUNCTION       HANG,SUBR\r
 650 \r
 651         ENTRY\r
 652 \r
 653         JUMPGE  AB,HANG1        ; NO PREDICATE\r
 654         CAMGE   AB,[-3,,]\r
 655         JRST    TMA\r
 656 REHANG: MOVE    A,[PUSHJ P,CHKPRH]\r
 657         MOVEM   A,ONINT         ; CHECK PREDICATE AFTER ANY INTERRUPT\r
 658         PUSH    TP,(AB)\r
 659         PUSH    TP,1(AB)\r
 660 HANG1:  ENABLE                  ;LET OURSELVES BE INTERRUPTED OUT\r
 661         PUSHJ   P,%HANG\r
 662         DISABLE                 ;PREVENT INTERRUPTS AT RANDOM TIMES\r
 663         SETZM   ONINT\r
 664         MOVE    A,$TATOM\r
 665         MOVE    B,MQUOTE T\r
 666         JRST    FINIS\r
 667 \r
 668 \r
 669 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED\r
 670 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE\r
 671 \r
 672 MFUNCTION       SLEEP,SUBR\r
 673 \r
 674         ENTRY\r
 675 \r
 676         JUMPGE  AB,TFA\r
 677         CAML    AB,[-3,,]\r
 678         JRST    SLEEP1\r
 679         CAMGE   AB,[-5,,]\r
 680         JRST    TMA\r
 681         PUSH    TP,2(AB)\r
 682         PUSH    TP,3(AB)\r
 683 SLEEP1: GETYP   0,(AB)\r
 684         CAIE    0,TFIX\r
 685         JRST    .+5\r
 686         MOVE    B,1(AB)\r
 687         JUMPL   B,OUTRNG        ;ARG SHOULDNT BE NEGATIVE\r
 688         IMULI   B,30.           ;CONVERT TO # OF THIRTIETHS OF A SECOND\r
 689         JRST    SLEEPR          ;GO SLEEP\r
 690         CAIE    0,TFLOAT        ;IF IT WASNT FIX MAKE SURE IT IS FLOAT\r
 691         JRST    WTYP1           ;WRONG TYPE ARG\r
 692         MOVE    B,1(AB)\r
 693         FMPR    B,[30.0]        ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND\r
 694         MULI    B,400           ;KLUDGE TO FIX IT\r
 695         TSC     B,B\r
 696         ASH     C,(B)-243\r
 697         MOVE    B,C             ;MOVE THE FIXED NUMBER INTO B\r
 698         JUMPL   B,OUTRNG        ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER\r
 699 SLEEPR: MOVE    A,B\r
 700 RESLEE: MOVE    B,[PUSHJ P,CHKPRS]\r
 701         CAMGE   AB,[-3,,]\r
 702         MOVEM   B,ONINT\r
 703         ENABLE\r
 704         PUSHJ   P,%SLEEP\r
 705         DISABLE\r
 706         SETZM   ONINT\r
 707         MOVE    A,$TATOM\r
 708         MOVE    B,MQUOTE T\r
 709         JRST    FINIS\r
 710 \r
 711 CHKPRH: PUSH    P,B\r
 712         MOVEI   B,HANGP\r
 713         JRST    .+3\r
 714 \r
 715 CHKPRS: PUSH    P,B\r
 716         MOVEI   B,SLEEPP\r
 717         HRRM    B,LCKINT\r
 718         SETZM   ONINT           ; TURN OFF FEATURE FOR NOW\r
 719         POP     P,B\r
 720         POPJ    P,\r
 721 \r
 722 HANGP:  SKIPA   B,[REHANG]\r
 723 SLEEPP: MOVEI   B,RESLEE\r
 724         PUSH    P,B\r
 725         PUSH    P,A\r
 726         DISABLE\r
 727         PUSH    TP,(TB)\r
 728         PUSH    TP,1(TB)\r
 729         MCALL   1,EVAL\r
 730         GETYP   0,A\r
 731         CAIE    0,TFALSE\r
 732         JRST    FINIS\r
 733         POP     P,A\r
 734         POPJ    P,\r
 735 \r
 736 MFUNCTION       VALRET,SUBR\r
 737 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS\r
 738 \r
 739         ENTRY   1\r
 740         GETYP   A,(AB)          ; GET TYPE OF ARGUMENT\r
 741         CAIE    A,TCHSTR        ; IS IT A CHR STRING?\r
 742         JRST    WTYP1           ; NO...ERROR WRONG TYPE\r
 743         PUSHJ   P,CSTACK        ; COPY THE CHR STRING TO THE STACK\r
 744                                         ; CSTACK IS IN ATOMHK\r
 745         MOVEI   B,0             ; ASCIZ TERMINATOR\r
 746         EXCH    B,(P)           ; STORE AND RETRIEVE COUNT\r
 747 \r
 748 ; CALCULATE THE BEGINNING ADDR OF THE STRING\r
 749         MOVEI   A,-1(P)         ; GET ADDR OF TOP OF STACK\r
 750         SUBI    A,-1(B)         ; GET STARTING ADDR\r
 751         PUSHJ   P,%VALRE        ; PASS UP TO MONITOR\r
 752         JRST    IFALSE          ; IF HE RETURNS, RETURN FALSE\r
 753 \r
 754 \r
 755 MFUNCTION       LOGOUT,SUBR\r
 756 \r
 757 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)\r
 758         ENTRY   0\r
 759         PUSHJ   P,%TOPLQ        ; SKIP IF AT TOP LEVEL\r
 760         JRST    IFALSE\r
 761         PUSHJ   P,CLOSAL\r
 762         PUSHJ   P,%LOGOUT       ; TRY TO FLUSH\r
 763         JRST    IFALSE          ; COULDN'T DO IT...RETURN FALSE\r
 764 \r
 765 ; FUNCTS TO GET UNAME AND JNAME\r
 766 \r
 767 MFUNCTION UNAME,SUBR\r
 768 \r
 769         ENTRY   0\r
 770 \r
 771         PUSHJ   P,%RUNAM\r
 772         JRST    RSUJNM\r
 773 \r
 774 MFUNCTION JNAME,SUBR\r
 775 \r
 776         ENTRY   0\r
 777 \r
 778         PUSHJ   P,%RJNAM\r
 779         JRST    RSUJNM\r
 780 \r
 781 ; FUNCTION TO SET AND READ GLOBAL SNAME\r
 782 \r
 783 MFUNCTION SNAME,SUBR\r
 784 \r
 785         ENTRY\r
 786 \r
 787         JUMPGE  AB,SNAME1\r
 788         CAMG    AB,[-3,,]\r
 789         JRST    TMA\r
 790         GETYP   A,(AB)          ; ARG MUST BE STRING\r
 791         CAIE    A,TCHSTR\r
 792         JRST    WTYP1\r
 793         PUSH    TP,$TATOM\r
 794         PUSH    TP,IMQUOTE SNM\r
 795         PUSH    TP,(AB)\r
 796         PUSH    TP,1(AB)\r
 797         MCALL   2,SETG\r
 798         JRST    FINIS\r
 799 \r
 800 SNAME1: MOVE    B,IMQUOTE SNM\r
 801         PUSHJ   P,IDVAL1\r
 802         GETYP   0,A\r
 803         CAIN    0,TCHSTR\r
 804         JRST    FINIS\r
 805         MOVE    A,$TCHSTR\r
 806         MOVE    B,CHQUOTE\r
 807         JRST    FINIS\r
 808 \r
 809 RSUJNM: PUSHJ   P,6TOCHS        ; CONVERT IT\r
 810         JRST    FINIS\r
 811 \r
 812 \r
 813 SGSNAM: MOVE    B,IMQUOTE SNM\r
 814         PUSHJ   P,IDVAL1\r
 815         GETYP   0,A\r
 816         CAIE    0,TCHSTR\r
 817         JRST    SGSN1\r
 818 \r
 819         PUSH    TP,A\r
 820         PUSH    TP,B\r
 821         PUSHJ   P,STRTO6\r
 822         POP     P,A\r
 823         SUB     TP,[2,,2]\r
 824         JRST    .+2\r
 825 \r
 826 SGSN1:  MOVEI   A,0\r
 827         PUSHJ   P,%SSNAM        ; SET SNAME IN SYSTEM\r
 828         POPJ    P,\r
 829 \r
 830 \f\r
 831 \r
 832 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND\r
 833 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.\r
 834 \r
 835 ICR:    MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP\r
 836         PUSHJ   P,IVECT         ;GOBBLE A VECTOR\r
 837         HRLI    C,PVBASE        ;SETUP A BLT POINTER\r
 838         HRRI    C,(B)           ;GET INTO ADDRESS\r
 839         BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP\r
 840         MOVSI   C,400000+SPVP+.VECT.    ;SET SPECIAL TYPE\r
 841         MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN\r
 842         PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR\r
 843         PUSH    TP,B\r
 844 \r
 845         PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR\r
 846         PUSH    TP,[PLNT]\r
 847         MCALL   1,UVECTOR\r
 848         ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER\r
 849         MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER\r
 850         MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES\r
 851         MOVEM   B,PBASE+1(C)\r
 852 \r
 853 \r
 854         MOVEI   A,TPLNT         ;PREPARE TO CREATE A TEMPORARY PDL\r
 855         PUSHJ   P,IVECT         ;GET THE TEMP PDL\r
 856         ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK\r
 857         MOVE    C,(TP)          ;RE-GOBBLE NEW PVP\r
 858         SUB     B,[1,,1]        ;FIX FOR STACK\r
 859         MOVEM   B,TPBASE+1(C)\r
 860 \r
 861 ;SETUP INITIAL BINDING\r
 862 \r
 863         PUSH    B,$TBIND\r
 864         MOVEM   B,SPBASE+1(C)   ;SAVE AS BASE OF SP\r
 865         MOVEM   B,SPSTO+1(C)    ;AND CURRENT THEREOF\r
 866         MOVEM   B,CURFCN+1(C)   ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC\r
 867         PUSH    B,IMQUOTE THIS-PROCESS\r
 868         PUSH    B,$TPVP ;GIVE IT PROCESS AS VALUE\r
 869         PUSH    B,C\r
 870         ADD     B,[2,,2]        ;FINISH FRAME\r
 871         MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER\r
 872         MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF\r
 873         MOVEM   TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR\r
 874         AOS     A,IDPROC                ;GOBBLE A UNIQUE PROCESS I.D.\r
 875         MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO\r
 876         AOS     A,PTIME         ; GET A UNIQUE BINDING ID\r
 877         MOVEM   A,BINDID+1(C)\r
 878 \r
 879         MOVSI   A,TPVP          ;CLOBBER THE TYPE\r
 880         MOVE    B,(TP)          ;AND POINTER TO PROCESS\r
 881         SUB     TP,[2,,2]\r
 882         POPJ    P,\r
 883 \r
 884 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A\r
 885 \r
 886 IVECT:  PUSH    TP,$TFIX\r
 887         PUSH    TP,A\r
 888         MCALL   1,VECTOR        ;GOBBLE THE VECTOR\r
 889         POPJ    P,\r
 890 \r
 891 \r
 892 ;SUBROUTINE TO SWAP A PROCESS IN\r
 893 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B\r
 894 \r
 895 SWAP:                           ;FIRST STORE ALL THE ACS\r
 896 \r
 897         IRP     A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
 898         MOVEM   A,A!STO+1(PVP)\r
 899         TERMIN\r
 900 \r
 901         SETOM   1(TP)           ; FENCE POST MAIN STACK\r
 902         MOVEM   TP,TPSAV(TB)    ; CORRECT FRAME\r
 903         SETZM   PSAV(TB)        ; CLEAN UP CURRENT FRAME\r
 904         SETZM   SPSAV(TB)\r
 905         SETZM   PCSAV(TB)\r
 906 \r
 907         MOVE    E,PVP   ;RETURN OLD PROCESS IN E\r
 908         MOVE    PVP,D   ;AND MAKE NEW ONE BE D\r
 909 \r
 910 SWAPIN:\r
 911         ;NOW RESTORE NEW PROCESSES AC'S\r
 912 \r
 913         IRP     A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
 914         MOVE    A,A!STO+1(PVP)\r
 915         TERMIN\r
 916 \r
 917         JRST    (C)             ;AND RETURN\r
 918 \r
 919 \r
 920 \f\r
 921 \r
 922 ;SUBRS ASSOCIATED WITH TYPES\r
 923 \r
 924 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE\r
 925 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.\r
 926 \r
 927 SAT:    LSH     A,1             ;TIMES 2 TO REF VECTOR\r
 928         HRLS    A               ;TO BOTH HALVES TO HACK AOBJN POINTER\r
 929         ADD     A,TYPVEC+1(TVP) ;ACCESS THE VECTOR\r
 930         HRR     A,(A)           ;GET PROBABLE SAT\r
 931         JUMPL   A,.+2           ;DID WE REALLY HAVE A VALID TYPE\r
 932         MOVEI   A,0             ;NO RETURN 0\r
 933         ANDI    A,SATMSK\r
 934         POPJ    P,              ;AND RETURN\r
 935 \r
 936 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE\r
 937 ;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.\r
 938 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID\r
 939 ;TYPECODE.\r
 940 MFUNCTION TYPE,SUBR\r
 941 \r
 942         ENTRY   1\r
 943         GETYP   A,(AB)          ;TYPE INTO A\r
 944 TYPE1:  PUSHJ   P,ITYPE         ;GO TO INTERNAL\r
 945         JUMPN   B,FINIS         ;GOOD RETURN\r
 946 TYPERR: PUSH    TP,$TATOM       ;SETUP ERROR CALL\r
 947         PUSH    TP,EQUOTE TYPE-UNDEFINED\r
 948         JRST    CALER1"         ;STANDARD ERROR HACKER\r
 949 \r
 950 CITYPE: GETYP   A,A             ; GET TYPE FOR COMPILER CALL\r
 951 ITYPE:  LSH     A,1             ;TIMES 2\r
 952         HRLS    A               ;TO BOTH SIDES\r
 953         ADD     A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION\r
 954         JUMPGE  A,TYPERR        ;LOST, TYPE OUT OF BOUNDS\r
 955         MOVE    B,1(A)          ;PICKUP TYPE\r
 956         HLLZ    A,(A)\r
 957         POPJ    P,\r
 958 \r
 959 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED\r
 960 \r
 961 MFUNCTION %TYPEQ,SUBR,[TYPE?]\r
 962 \r
 963         ENTRY\r
 964 \r
 965         MOVE    D,AB            ; GET ARGS\r
 966         ADD     D,[2,,2]\r
 967         JUMPGE  D,TFA\r
 968         MOVE    A,(AB)\r
 969         HLRE    C,D\r
 970         MOVMS   C\r
 971         ASH     C,-1            ; FUDGE\r
 972         PUSHJ   P,ITYPQ         ; GO INTERNAL\r
 973         JFCL\r
 974         JRST    FINIS\r
 975 \r
 976 ITYPQ:  GETYP   A,A             ; OBJECT\r
 977         PUSHJ   P,ITYPE\r
 978 TYPEQ0: SOJL    C,CIFALS\r
 979         GETYP   0,(D)\r
 980         CAIE    0,TATOM         ; Type name must be an atom\r
 981         JRST    WRONGT\r
 982         CAMN    B,1(D)          ; Same as the OBJECT?\r
 983         JRST    CPOPJ1          ; Yes, return type name\r
 984         ADD     D,[2,,2]\r
 985         JRST    TYPEQ0          ; No, continue comparing\r
 986 \r
 987 CIFALS: MOVEI   B,0\r
 988         MOVSI   A,TFALSE\r
 989         POPJ    P,\r
 990 \r
 991 CTYPEQ: SOJE    A,CIFALS        ; TREAT NO ARGS AS FALSE\r
 992         MOVEI   D,1(A)          ; FIND BASE OF ARGS\r
 993         ASH     D,1\r
 994         HRLI    D,(D)\r
 995         SUBM    TP,D            ; D POINTS TO BASE\r
 996         MOVE    E,D             ; SAVE FOR TP RESTORE\r
 997         ADD     D,[3,,3]        ; FUDGE\r
 998         MOVEI   C,(A)           ; NUMBER OF TYPES\r
 999         MOVE    A,-2(D)\r
1000         PUSHJ   P,ITYPQ\r
1001         JFCL            ; IGNORE SKIP FOR NOW\r
1002         MOVE    TP,E            ; SET TP BACK\r
1003         JUMPL   B,CPOPJ1        ; SKIP\r
1004         POPJ    P,\r
1005 \f\r
1006 ; Entries to get type codes for types for fixing up RSUBRs and assembling\r
1007 \r
1008 MFUNCTION %TYPEC,SUBR,[TYPE-C]\r
1009 \r
1010         ENTRY\r
1011 \r
1012         JUMPGE  AB,TFA\r
1013         GETYP   0,(AB)\r
1014         CAIE    0,TATOM\r
1015         JRST    WTYP1\r
1016         MOVE    B,1(AB)\r
1017         CAMGE   AB,[-3,,0]      ; skip if only type name given\r
1018         JRST    GTPTYP\r
1019         MOVE    C,MQUOTE ANY\r
1020 \r
1021 TYPEC1: PUSHJ   P,CTYPEC        ; go to internal\r
1022         JRST    FINIS\r
1023 \r
1024 GTPTYP: CAMGE   AB,[-5,,0]\r
1025         JRST    TMA\r
1026         GETYP   0,2(AB)\r
1027         CAIE    0,TATOM\r
1028         JRST    WTYP2\r
1029         MOVE    C,3(AB)\r
1030         JRST    TYPEC1\r
1031 \r
1032 CTYPEC: PUSH    P,C             ; save primtype checker\r
1033         PUSHJ   P,TYPLOO        ; search type vector\r
1034         POP     P,B\r
1035         CAMN    B,MQUOTE ANY\r
1036         JRST    CTPEC1\r
1037         PUSH    P,D\r
1038         HRRZ    A,(A)\r
1039         ANDI    A,SATMSK\r
1040         PUSH    P,A\r
1041         PUSHJ   P,TYPLOO\r
1042         HRRZ    0,(A)\r
1043         ANDI    0,SATMSK\r
1044         CAME    0,(P)\r
1045         JRST    TYPDIF\r
1046         MOVE    D,-1(P)\r
1047         SUB     P,[2,,2]\r
1048 CTPEC1: MOVEI   B,(D)\r
1049         MOVSI   A,TTYPEC\r
1050         POPJ    P,\r
1051 \r
1052 MFUNCTION %TYPEW,SUBR,[TYPE-W]\r
1053 \r
1054         ENTRY\r
1055 \r
1056         JUMPGE  AB,TFA\r
1057         GETYP   0,(AB)\r
1058         CAIE    0,TATOM\r
1059         JRST    WTYP1\r
1060         MOVEI   D,0\r
1061         MOVE    C,MQUOTE ANY\r
1062         MOVE    B,1(AB)\r
1063         CAMGE   AB,[-3,,0]\r
1064         JRST    CTYPW1\r
1065 \r
1066 CTYPW3: PUSHJ   P,CTYPEW\r
1067         JRST    FINIS\r
1068 \r
1069 CTYPW1: GETYP   0,2(AB)\r
1070         CAIE    0,TATOM\r
1071         JRST    WTYP2\r
1072         CAMGE   AB,[-5,,0]      ; JUMP IF RH IS GIVEN\r
1073         JRST    CTYPW2\r
1074         MOVE    C,3(AB)\r
1075         JRST    CTYPW3\r
1076 \r
1077 CTYPW2: CAMGE   AB,[-7,,0]\r
1078         JRST    TMA\r
1079         GETYP   0,4(AB)\r
1080         CAIE    0,TFIX\r
1081         JRST    WRONGT\r
1082         MOVE    D,5(AB)\r
1083         JRST    CTYPW3\r
1084 \r
1085 CTYPEW: PUSH    P,D\r
1086         PUSHJ   P,CTYPEC        ; GET CODE IN B\r
1087         POP     P,B\r
1088         HRLI    B,(D)\r
1089         MOVSI   A,TTYPEW\r
1090         POPJ    P,\r
1091 \f       \r
1092 ;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS\r
1093 \r
1094 STBL:   REPEAT NUMSAT,MQUOTE INTERNAL-TYPE\r
1095 \r
1096 LOC STBL\r
1097 \r
1098 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]\r
1099 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]\r
1100 [PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]\r
1101 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]\r
1102 IRP B,C,[A]\r
1103 LOC STBL+S!B\r
1104 MQUOTE C\r
1105 \r
1106 .ISTOP\r
1107 \r
1108 TERMIN\r
1109 TERMIN\r
1110 \r
1111 LOC STBL+NUMSAT+1\r
1112 \r
1113 \r
1114 MFUNCTION TYPEPRIM,SUBR\r
1115 \r
1116         ENTRY   1\r
1117         GETYP   A,(AB)\r
1118         CAIE    A,TATOM\r
1119         JRST    NOTATOM\r
1120         MOVE    B,1(AB)\r
1121         PUSHJ   P,CTYPEP\r
1122         JRST    FINIS\r
1123 \r
1124 CTYPEP: PUSHJ   P,TYPLOO        ; CONVERT ATOM TO CODE\r
1125         HRRZ    A,(A)           ; SAT TO A\r
1126         ANDI    A,SATMSK\r
1127         JRST    PTYP1\r
1128 \r
1129 MFUNCTION PRIMTYPE,SUBR\r
1130 \r
1131         ENTRY   1\r
1132 \r
1133         MOVE    A,(AB)          ;GET TYPE\r
1134         PUSHJ   P,CPTYPE\r
1135         JRST    FINIS\r
1136 \r
1137 CPTYPE: GETYP   A,A\r
1138         PUSHJ   P,SAT           ;GET SAT\r
1139 PTYP1:  JUMPE   A,TYPERR\r
1140         MOVE    B,MQUOTE TEMPLATE\r
1141         CAIG    A,NUMSAT        ; IF BIG SAT, THEN TEMPLATE\r
1142         MOVE    B,@STBL(A)\r
1143         MOVSI   A,TATOM\r
1144         POPJ    P,\r
1145 \f\r
1146 \r
1147 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT\r
1148 \r
1149 MFUNCTION RSUBR,SUBR\r
1150         ENTRY   1\r
1151 \r
1152         GETYP   A,(AB)\r
1153         CAIE    A,TVEC          ; MUST BE VECTOR\r
1154         JRST    WTYP1\r
1155         MOVE    B,1(AB)         ; GET IT\r
1156         GETYP   A,(B)           ; CHECK 1ST ELEMENTS TYPE\r
1157         CAIN    A,TPCODE        ; PURE CODE\r
1158         JRST    .+3\r
1159         CAIE    A,TCODE\r
1160         JRST    NRSUBR\r
1161         HLRM    B,(B)           ; CLOBEER SPECIAL COUNT FIELD\r
1162         MOVSI   A,TRSUBR\r
1163         JRST    FINIS\r
1164 \r
1165 NRSUBR: PUSH    TP,$TATOM\r
1166         PUSH    TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE\r
1167         JRST    CALER1\r
1168 \r
1169 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR\r
1170 \r
1171 MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]\r
1172 \r
1173         ENTRY   2\r
1174 \r
1175         GETYP   0,(AB)          ; TYPE OF ARG\r
1176         CAIE    0,TVEC          ; BETTER BE VECTOR\r
1177         JRST    WTYP1\r
1178         GETYP   0,2(AB)\r
1179         CAIE    0,TFIX\r
1180         JRST    WTYP2\r
1181         MOVE    B,1(AB)         ; GET VECTOR\r
1182         CAML    B,[-3,,0]\r
1183         JRST    BENTRY\r
1184         GETYP   0,(B)           ; FIRST ELEMENT\r
1185         CAIE    0,TRSUBR\r
1186         JRST    MENTR1\r
1187 MENTR2: GETYP   0,2(B)\r
1188         CAIE    0,TATOM\r
1189         JRST    BENTRY\r
1190         MOVE    C,3(AB)\r
1191         HRRM    C,2(B)          ; OFFSET INTO VECTOR\r
1192         HLRM    B,(B)\r
1193         MOVSI   A,TENTER\r
1194         JRST    FINIS\r
1195 \r
1196 MENTR1: CAIE    0,TATOM\r
1197         JRST    BENTRY\r
1198         MOVE    B,1(B)          ; GET ATOM\r
1199         PUSHJ   P,IGVAL         ; GET VAL\r
1200         GETYP   0,A\r
1201         CAIE    0,TRSUBR\r
1202         JRST    BENTRY\r
1203         MOVE    B,1(AB)         ; RESTORE B\r
1204         JRST    MENTR2\r
1205 \r
1206 BENTRY: PUSH    TP,$TATOM\r
1207         PUSH    TP,EQUOTE BAD-VECTOR\r
1208         JRST    CALER1\r
1209         \r
1210 ; SUBR TO GET ENTRIES OFFSET\r
1211 \r
1212 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]\r
1213 \r
1214         ENTRY   1\r
1215 \r
1216         GETYP   0,(AB)\r
1217         CAIE    0,TENTER\r
1218         JRST    WTYP1\r
1219         MOVE    B,1(AB)\r
1220         HRRZ    B,2(B)\r
1221         MOVSI   A,TFIX\r
1222         JRST    FINIS\r
1223 \r
1224 ; RETURN FALSE\r
1225 \r
1226 RTFALS: MOVSI   A,TFALSE\r
1227         MOVEI   B,0\r
1228         POPJ    P,\r
1229 \r
1230 ;SUBROUTINE CALL FOR RSUBRs\r
1231 RCALL:  SUBM    M,(P)           ;CALCULATE PC's OFFSET IN THE RSUBR\r
1232         PUSHJ   P,@0            ;GO TO THE PROPER SUBROUTINE\r
1233         SUBM    M,(P)           ;RECONSTITUTE THE RSUBR's PC\r
1234         POPJ    P,\r
1235 \r
1236 \r
1237 ; ERRORS IN COMPILED CODE MAY END UP HERE\r
1238 \r
1239 COMPERR:\r
1240         PUSH    TP,$TATOM\r
1241         PUSH    TP,EQUOTE ERROR-IN-COMPILED-CODE\r
1242         JRST    CALER1\r
1243 \f\r
1244 \r
1245 ;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME\r
1246 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND\r
1247 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND\r
1248 \r
1249 MFUNCTION CHTYPE,SUBR\r
1250 \r
1251         ENTRY   2\r
1252         GETYP   A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM\r
1253         CAIE    A,TATOM \r
1254         JRST    NOTATOM\r
1255         MOVE    B,3(AB)         ;AND TYPE NAME\r
1256         PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE\r
1257 TFOUND: HRRZ    B,(A)           ;GOBBLE THE SAT\r
1258         TRNE    B,CHBIT         ; SKIP IF CHTYPABLE\r
1259         JRST    CANTCH\r
1260         TRNE    B,TMPLBT        ; TEMPLAT\r
1261         HRLI    B,-1\r
1262         AND     B,[-1,,SATMSK]\r
1263         GETYP   A,(AB)          ;NOW GET TYPE TO HACK\r
1264         PUSHJ   P,SAT           ;FIND OUT ITS SAT\r
1265         JUMPE   A,TYPERR        ;COMPLAIN\r
1266         CAILE   A,NUMSAT\r
1267         JRST    CHTMPL          ; JUMP IF TEMPLATE DATA\r
1268         CAIE    A,(B)           ;DO THEY AGREE?\r
1269         JRST    TYPDIF          ;NO, COMPLAIN\r
1270 CHTMP1: MOVSI   A,(D)           ;GET NEW TYPE\r
1271         HRR     A,(AB)          ; FOR DEFERRED GOODIES\r
1272         JUMPL   B,CHMATC        ; CHECK IT\r
1273         MOVE    B,1(AB)         ;AND VALUE\r
1274         JRST    FINIS\r
1275 \r
1276 CHTMPL: MOVE    E,1(AB)         ; GET ARG\r
1277         HLRZ    A,(E)\r
1278         ANDI    A,SATMSK\r
1279         MOVE    0,3(AB)         ; SEE IF TO "TEMPLATE"\r
1280         CAME    0,MQUOTE TEMPLATE\r
1281         CAIN    A,(B)\r
1282         JRST    CHTMP1\r
1283         JRST    TYPDIF\r
1284 \r
1285 CHMATC: PUSH    TP,A\r
1286         PUSH    TP,1(AB)        ; SAVE GOODIE\r
1287         MOVSI   A,TATOM\r
1288         MOVE    B,3(AB)\r
1289         MOVSI   C,TATOM\r
1290         MOVE    D,MQUOTE DECL\r
1291         PUSHJ   P,IGET          ; FIND THE DECL\r
1292         MOVE    C,(AB)\r
1293         MOVE    D,1(AB)         ; NOW GGO TO MATCH\r
1294         PUSHJ   P,TMATCH\r
1295         JRST    TMPLVIO\r
1296         POP     TP,B\r
1297         POP     TP,A\r
1298         JRST    FINIS\r
1299 \r
1300 TYPLOO: PUSHJ   P,TYPFND\r
1301         JRST    .+2\r
1302         POPJ    P,\r
1303         PUSH    TP,$TATOM       ;LOST, GENERATE ERROR\r
1304         PUSH    TP,EQUOTE BAD-TYPE-NAME\r
1305         JRST    CALER1\r
1306 \r
1307 TYPFND: MOVE    A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR\r
1308         MOVEI   D,0             ;INITIALIZE TYPE COUNTER\r
1309 TLOOK:  CAMN    B,1(A)          ;CHECK THIS ONE\r
1310         JRST    CPOPJ1\r
1311         ADDI    D,1             ;BUMP COUNTER\r
1312         AOBJP   A,.+2           ;COUTN DOWN ON VECTOR\r
1313         AOBJN   A,TLOOK\r
1314         POPJ    P,\r
1315 CPOPJ1: AOS     (P)\r
1316         POPJ    P,\r
1317 \r
1318 TYPDIF: PUSH    TP,$TATOM       ;MAKE ERROR MESSAGE\r
1319         PUSH    TP,EQUOTE STORAGE-TYPES-DIFFER\r
1320         JRST    CALER1\r
1321 \r
1322 \r
1323 TMPLVI: PUSH    TP,$TATOM\r
1324         PUSH    TP,EQUOTE DECL-VIOLATION\r
1325         JRST    CALER1\r
1326 \f\r
1327 \r
1328 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE\r
1329 \r
1330 MFUNCTION NEWTYPE,SUBR\r
1331 \r
1332         ENTRY\r
1333 \r
1334         HLRZ    0,AB            ; CHEC # OF ARGS\r
1335         CAILE   0,-4            ; AT LEAST 2\r
1336         JRST    TFA\r
1337         CAIGE   0,-6\r
1338         JRST    TMA             ; NOT MORE THAN 3\r
1339         GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)\r
1340         GETYP   C,2(AB)         ; SAME WITH SECOND\r
1341         CAIN    A,TATOM         ; CHECK\r
1342         CAIE    C,TATOM\r
1343         JRST    NOTATOM\r
1344 \r
1345         MOVE    B,3(AB)         ; GET PRIM TYPE NAME\r
1346         PUSHJ   P,TYPLOO        ; LOOK IT UP\r
1347         HRRZ    A,(A)           ; GOBBLE SAT\r
1348         HRLI    A,TATOM         ; MAKE NEW TYPE\r
1349         PUSH    P,A             ; AND SAVE\r
1350         MOVE    B,1(AB)         ; SEE IF PREV EXISTED\r
1351         PUSHJ   P,TYPFND\r
1352         JRST    NEWTOK          ; DID NOT EXIST BEFORE\r
1353         MOVEI   B,2(A)          ; FOR POSSIBLE TMPLAT BIT\r
1354         HRRZ    A,(A)           ; GET SAT\r
1355         HRRZ    0,(P)           ; AND PROPOSED\r
1356         ANDI    0,SATMSK\r
1357         ANDI    A,SATMSK\r
1358         CAIN    0,(A)           ; SKIP IF LOSER\r
1359         JRST    NEWTFN          ; O.K.\r
1360 \r
1361         PUSH    TP,$TATOM\r
1362         PUSH    TP,EQUOTE TYPE-ALREADY-EXISTS\r
1363         JRST    CALER1\r
1364 \r
1365 NEWTOK: POP     P,A\r
1366         MOVE    B,1(AB)         ; NEWTYPE NAME\r
1367         PUSHJ   P,INSNT         ; MUNG IN NEW TYPE\r
1368 \r
1369 NEWTFN: CAML    AB,[-5,,]       ; SKIP IF TEMPLAT SUPPLIED\r
1370         JRST    NEWTF1\r
1371         MOVEI   0,TMPLBT        ; GET THE BIT\r
1372         IORM    0,-2(B)         ; INTO WORD\r
1373         MOVE    A,(AB)          ; GET TYPE NAME\r
1374         MOVE    B,1(AB)\r
1375         MOVSI   C,TATOM\r
1376         MOVE    D,MQUOTE DECL\r
1377         PUSH    TP,4(AB)        ; GET TEMLAT\r
1378         PUSH    TP,5(AB)\r
1379         PUSHJ   P,IPUT\r
1380 NEWTF1: MOVE    A,(AB)\r
1381         MOVE    B,1(AB)         ; RETURN NAME\r
1382         JRST    FINIS\r
1383 \r
1384 ; SET  UP GROWTH FIELDS\r
1385 \r
1386 IGROWT: SKIPA   A,[111100,,(C)]\r
1387 IGROWB: MOVE    A,[001100,,(C)]\r
1388         HLRE    B,C\r
1389         SUB     C,B             ; POINT TO DOPE WORD\r
1390         MOVE    B,TYPIC ; INDICATED GROW BLOCK\r
1391         DPB     B,A\r
1392         POPJ    P,\r
1393 \r
1394 INSNT:  PUSH    TP,A\r
1395         PUSH    TP,B            ; SAVE NAME OF NEWTYPE\r
1396         MOVE    C,TYPBOT+1(TVP) ; CHECK GROWTH NEED\r
1397         CAMGE   C,TYPVEC+1(TVP)\r
1398         JRST    ADDIT           ; STILL ROOM\r
1399 GAGN:   PUSHJ   P,IGROWB        ; SETUP BOTTOM GROWTH\r
1400         SKIPE   C,EVATYP+1(TVP)\r
1401         PUSHJ   P,IGROWT        ; SET UP TOP GROWTH\r
1402         SKIPE   C,APLTYP+1(TVP)\r
1403         PUSHJ   P,IGROWT\r
1404         MOVE    C,[11.,,5]      ; SET UP INDICATOR FOR AGC\r
1405         PUSHJ   P,AGC           ; GROW THE WORLD\r
1406         AOJL    A,GAGN          ; BAD AGC LOSSAGE\r
1407         MOVE    0,[-101,,-100]\r
1408         ADDM    0,TYPBOT+1(TVP) ; FIX UP POINTER\r
1409 \r
1410 ADDIT:  MOVE    C,TYPVEC+1(TVP)\r
1411         SUB     C,[2,,2]        ; ALLOCATE ROOM\r
1412         MOVEM   C,TYPVEC+1(TVP)\r
1413         HLRE    B,C             ; PREPARE TO BLT\r
1414         SUBM    C,B             ; C POINTS DOPE WORD END\r
1415         HRLI    C,2(C)          ; GET BLT AC READY\r
1416         BLT     C,-3(B)\r
1417         POP     TP,-1(B)        ; CLOBBER IT IN\r
1418         POP     TP,-2(B)\r
1419         POPJ    P,\r
1420 \r
1421 \f\r
1422 ; Interface to interpreter for setting up tables associated with\r
1423 ;       template data structures.\r
1424 ;       A/      <\b-name of type>\b-\r
1425 ;       B/      <\b-length ins>\b-\r
1426 ;       C/      <\b-uvector of length code or 0>\r
1427 ;       D/      <\b-uvector of GETTERs>\b-\r
1428 ;       E/      <\b-uvector of PUTTERs>\b-\r
1429 \r
1430 CTMPLT: SUBM    M,(P)           ; could possibly gc during this stuff\r
1431         SKIPE   C               ; for now dont handle vector of length ins\r
1432         FATAL   TEMPLATE DATA WITH COMPUTED LENGTH\r
1433         PUSH    TP,$TATOM       ; save name of type\r
1434         PUSH    TP,A\r
1435         PUSH    P,B             ; save length instr\r
1436         HLRE    A,TD.LNT+1(TVP) ; check for template slots left?\r
1437         HRRZ    B,TD.LNT+1(TVP)\r
1438         SUB     B,A             ; point to dope words\r
1439         HLRZ    B,1(B)          ; get real length\r
1440         ADDM    B,A             ; any room?\r
1441         JUMPG   A,GOODRM        ; jump if ok\r
1442 \r
1443         PUSH    TP,$TUVEC       ; save getters and putters\r
1444         PUSH    TP,D\r
1445         PUSH    TP,$TUVEC\r
1446         PUSH    TP,E\r
1447         MOVEI   A,6(B)          ; grow it 10 by copying\r
1448         PUSH    P,A             ; save new length\r
1449         PUSHJ   P,CAFRE1        ; get frozen uvector\r
1450         ADD     B,[10,,10]      ; rest it down some\r
1451         HRL     C,TD.LNT+1(TVP) ; prepare to BLT in\r
1452         MOVEM   B,TD.LNT+1(TVP) ; and save as new length vector\r
1453         HRRI    C,(B)           ; destination\r
1454         ADD     B,(P)           ; final destination address\r
1455         BLT     C,-13(B)\r
1456         MOVE    A,(P)           ; length for new getters\r
1457         PUSHJ   P,CAFRE1\r
1458         MOVE    C,TD.GET+1(TVP) ; get old for copy\r
1459         MOVEM   B,TD.GET+1(TVP)\r
1460         HRRI    C,(B)\r
1461         ADD     B,(P)\r
1462         BLT     C,-13(B)        ; zap those guys in\r
1463         MOVE    A,(P)           ; finally putters\r
1464         PUSHJ   P,CAFRE1\r
1465         MOVE    C,TD.PUT+1(TVP)\r
1466         MOVEM   B,TD.PUT+1(TVP)\r
1467         HRRI    C,(B)           ; BLT pointer\r
1468         ADD     B,(P)\r
1469         BLT     C,-13(B)\r
1470         SUB     P,[1,,1]        ; flush stack craft\r
1471         MOVE    E,(TP)\r
1472         MOVE    D,-2(TP)\r
1473         SUB     TP,[4,,4]\r
1474 \r
1475 GOODRM: MOVE    B,TD.LNT+1(TVP) ; move down to fit new guy\r
1476         SUB     B,[1,,1]        ; will always win due to prev checks\r
1477         MOVEM   B,TD.LNT+1(TVP)\r
1478         HRLI    B,1(B)\r
1479         HLRE    A,TD.LNT+1(TVP)\r
1480         MOVNS   A\r
1481         ADDI    A,-1(B)         ; A/ final destination\r
1482         BLT     B,-1(A)\r
1483         POP     P,(A)           ; new length ins munged in\r
1484         HLRE    A,TD.LNT+1(TVP)\r
1485         MOVNS   A               ; A/ offset for other guys\r
1486         PUSH    P,A             ; save it\r
1487         ADD     A,TD.GET+1(TVP) ; point for storing uvs of ins\r
1488         MOVEM   D,-1(A)\r
1489         MOVE    A,(P)\r
1490         ADD     A,TD.PUT+1(TVP)\r
1491         MOVEM   E,-1(A)         ; store putter also\r
1492         POP     P,A             ; compute primtype\r
1493         ADDI    A,NUMSAT\r
1494         HRLI    A,TATOM\r
1495         MOVE    B,(TP)          ; ready to mung type vector\r
1496         SUB     TP,[2,,2]\r
1497         PUSHJ   P,INSNT         ; insert into vector\r
1498         JRST    MPOPJ\r
1499 \f\r
1500 \r
1501 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES\r
1502 \r
1503 MFUNCTION EVALTYPE,SUBR\r
1504 \r
1505         ENTRY   2\r
1506 \r
1507         PUSHJ   P,CHKARG        ; VERIFY WINNAGE IN ARGS\r
1508         MOVEI   A,EVATYP        ; POINT TO TABLE\r
1509         MOVEI   E,EVTYPE        ; POINT TO PURE VERSION\r
1510 TBLCAL: PUSHJ   P,TBLSET        ; SETUP TABLE ENTRY\r
1511         JRST    FINIS\r
1512 \r
1513 MFUNCTION APPLYTYPE,SUBR\r
1514 \r
1515         ENTRY   2\r
1516 \r
1517         PUSHJ   P,CHKARG\r
1518         MOVEI   A,APLTYP        ; POINT TO APPLY TABLE\r
1519         MOVEI   E,APTYPE        ; PURE TABLE\r
1520         JRST    TBLCAL\r
1521 \r
1522 \r
1523 MFUNCTION PRINTTYPE,SUBR\r
1524 \r
1525         ENTRY   2\r
1526 \r
1527         PUSHJ   P,CHKARG\r
1528         MOVEI   A,PRNTYP        ; POINT TO APPLY TABLE\r
1529         MOVEI   E,PRTYPE        ; PURE TABLE\r
1530         JRST    TBLCAL\r
1531 \r
1532 ; CHECK ARGS AND SETUP FOR TABLE HACKER\r
1533 \r
1534 CHKARG: GETYP   A,(AB)          ; 1ST MUST BE TYPE NAME\r
1535         CAIE    A,TATOM\r
1536         JRST    WTYP1\r
1537         MOVE    B,1(AB)         ; GET ATOM\r
1538         PUSHJ   P,TYPLOO        ; VERIFY THAT IT IS A TYPE\r
1539         PUSH    P,D             ; SAVE TYPE NO.\r
1540         HRRZ    A,(A)           ; GET SAT\r
1541         ANDI    A,SATMSK\r
1542         PUSH    P,A\r
1543         GETYP   A,2(AB)         ; GET 2D TYPE\r
1544         CAIE    A,TATOM         ; EITHER TYPE OR APPLICABLE\r
1545         JRST    TRYAPL          ; TRY APPLICABLE\r
1546         MOVE    B,3(AB)         ; VERIFY IT IS A TYPE\r
1547         PUSHJ   P,TYPLOO\r
1548         HRRZ    A,(A)           ; GET SAT\r
1549         ANDI    A,SATMSK\r
1550         POP     P,C             ; RESTORE SAVED SAT\r
1551         CAIE    A,(C)           ; SKIP IF A WINNER\r
1552         JRST    TYPDIF          ; REPORT ERROR\r
1553         POP     P,C             ; GET SAVED TYPE\r
1554         MOVEI   B,0             ; TELL THAT WE ARE A TYPE\r
1555         POPJ    P,\r
1556 \r
1557 TRYAPL: PUSHJ   P,APLQ          ; IS THIS APPLICABLE\r
1558         JRST    NAPT\r
1559         SUB     P,[1,,1]\r
1560         MOVE    B,2(AB)         ; RETURN SAME\r
1561         MOVE    D,3(AB)\r
1562         POP     P,C\r
1563         POPJ    P,\r
1564 \r
1565 \f\r
1566 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE\r
1567 \r
1568 TBLSET: HRLI    A,(A)           ; FOR TVP HACKING\r
1569         ADD     A,TVP           ; POINT TO TVP SLOT\r
1570         PUSH    TP,B\r
1571         PUSH    TP,D            ; SAVE VALUE \r
1572         PUSH    TP,$TVEC\r
1573         PUSH    TP,A\r
1574         PUSH    P,C             ; SAVE TYPE BEING HACKED\r
1575         PUSH    P,E\r
1576         SKIPE   B,1(A)          ; SKIP IF VECTOR DOESN'T EXIST YET\r
1577         JRST    TBL.OK\r
1578         HLRE    A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH\r
1579         MOVNS   A\r
1580         ASH     A,-1\r
1581         PUSHJ   P,IVECT         ; GET VECTOR\r
1582         MOVE    C,(TP)          ; POINT TO RETURN POINT\r
1583         MOVEM   B,1(C)          ; SAVE VECTOR\r
1584 \r
1585 TBL.OK: POP     P,E\r
1586         POP     P,C             ; RESTORE TYPE\r
1587         SUB     TP,[2,,2]\r
1588         POP     TP,D\r
1589         POP     TP,A\r
1590         JUMPN A,TBLOK1  ; JUMP IF FUNCTION ETC. SUPPLIED\r
1591         CAILE   D,NUMPRI        ; SKIP IF ORIGINAL TYPE\r
1592         MOVNI   E,(D)           ; CAUSE E TO ENDUP 0\r
1593         ADDI    E,(D)           ; POINT TO PURE SLOT\r
1594 TBLOK1: ADDI    C,(C)           ; POINT TO VECTOR SLOT\r
1595         ADDI    C,(B)\r
1596         JUMPN   A,OK.SET        ; OK TO CLOBBER\r
1597         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT\r
1598         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT\r
1599         SKIPN   A,(B)           ; SKIP IF WINNER\r
1600         SKIPE   1(B)            ; SKIP IF LOSER\r
1601         SKIPA   D,1(B)          ; SETUP D\r
1602         JRST    CH.PTB          ; CHECK PURE TABLE\r
1603 \r
1604 OK.SET: MOVEM   A,(C)           ; STORE\r
1605         MOVEM   D,1(C)\r
1606         MOVE    A,(AB)          ; RET TYPE\r
1607         MOVE    B,1(AB)\r
1608         JRST    FINIS\r
1609 \r
1610 CH.PTB: MOVEI   A,0\r
1611         MOVE    D,[SETZ NAPT]\r
1612         JUMPE   E,OK.SET\r
1613         MOVE    D,(E)\r
1614         JRST    OK.SET\r
1615 \r
1616 CALLTY: MOVE    A,TYPVEC(TVP)\r
1617         MOVE    B,TYPVEC+1(TVP)\r
1618         POPJ    P,\r
1619 \r
1620 MFUNCTION ALLTYPES,SUBR\r
1621 \r
1622         ENTRY   0\r
1623 \r
1624         MOVE    A,TYPVEC(TVP)\r
1625         MOVE    B,TYPVEC+1(TVP)\r
1626         JRST    FINIS\r
1627 \r
1628 ;\f\r
1629 \r
1630 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR\r
1631 \r
1632 MFUNCTION UTYPE,SUBR\r
1633 \r
1634         ENTRY   1\r
1635 \r
1636         GETYP   A,(AB)          ;GET U VECTOR\r
1637         PUSHJ   P,SAT\r
1638         CAIE    A,SNWORD\r
1639         JRST    WTYP1\r
1640         MOVE    B,1(AB)         ; GET UVECTOR\r
1641         PUSHJ   P,CUTYPE\r
1642         JRST    FINIS\r
1643 \r
1644 CUTYPE: HLRE    A,B             ;GET -LENGTH\r
1645         HRRZS   B\r
1646         SUB     B,A             ;POINT TO TYPE WORD\r
1647         GETYP   A,(B)\r
1648         JRST    ITYPE           ; GET NAME OF TYPE\r
1649 \r
1650 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR\r
1651 \r
1652 MFUNCTION CHUTYPE,SUBR\r
1653 \r
1654         ENTRY   2\r
1655 \r
1656         GETYP   A,2(AB)         ;GET 2D TYPE\r
1657         CAIE    A,TATOM\r
1658         JRST    NOTATO\r
1659         GETYP   A,(AB)          ; CALL WITH UVECTOR?\r
1660         PUSHJ   P,SAT\r
1661         CAIE    A,SNWORD\r
1662         JRST    WTYP1\r
1663         MOVE    A,1(AB)         ; GET UV POINTER\r
1664         MOVE    B,3(AB)         ;GET ATOM\r
1665         PUSHJ   P,CCHUTY\r
1666         MOVE    A,(AB)          ; RETURN UVECTOR\r
1667         MOVE    B,1(AB)\r
1668         JRST    FINIS\r
1669 \r
1670 CCHUTY: PUSH    TP,$TUVEC\r
1671         PUSH    TP,A\r
1672         PUSHJ   P,TYPLOO        ;LOOK IT UP\r
1673         HRRZ    B,(A)           ;GET SAT\r
1674         TRNE    B,CHBIT\r
1675         JRST    CANTCH\r
1676         ANDI    B,SATMSK\r
1677         HLRE    C,(TP)          ;-LENGTH\r
1678         HRRZ    E,(TP)\r
1679         SUB     E,C             ;POINT TO TYPE\r
1680         GETYP   A,(E)           ;GET TYPE\r
1681         JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING\r
1682         PUSHJ   P,SAT           ;GET SAT\r
1683         JUMPE   A,TYPERR\r
1684         CAIE    A,(B)           ;COMPARE\r
1685         JRST    TYPDIF\r
1686 WIN0:   HRLM    D,(E)           ;CLOBBER NEW ONE\r
1687         POP     TP,B\r
1688         POP     TP,A\r
1689         POPJ    P,\r
1690 \r
1691 CANTCH: PUSH    TP,$TATOM\r
1692         PUSH    TP,EQUOTE CANT-CHTYPE-INTO\r
1693         PUSH    TP,2(AB)\r
1694         PUSH    TP,3(AB)\r
1695         MOVEI   A,2\r
1696         JRST    CALER\r
1697 \r
1698 NOTATOM:\r
1699         PUSH    TP,$TATOM\r
1700         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT\r
1701         PUSH    TP,(AB)\r
1702         PUSH    TP,1(AB)\r
1703         MOVEI   A,2\r
1704         JRST    CALER\r
1705 \r
1706 \r
1707 \f\r
1708 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY\r
1709 \r
1710 MFUNCTION QUIT,SUBR\r
1711 \r
1712         ENTRY   0\r
1713 \r
1714 \r
1715         PUSHJ   P,CLOSAL        ; DO THE CLOSES\r
1716         PUSHJ   P,%KILLM\r
1717         JRST    IFALSE          ; JUST IN CASE\r
1718 \r
1719 CLOSAL: MOVE    B,TVP           ; POINT TO XFER VECCTOR\r
1720         ADD     B,[CHNL0+2,,CHNL0+2]    ; POINT TO 1ST (NOT INCLUDING TTY I/O)\r
1721         PUSH    TP,$TVEC\r
1722         PUSH    TP,B\r
1723         PUSH    P,[N.CHNS-1]    ; MAX NO. OF CHANS\r
1724 \r
1725 CLOSA1: MOVE    B,(TP)\r
1726         ADD     B,[2,,2]\r
1727         MOVEM   B,(TP)\r
1728         SKIPN   C,-1(B)         ; THIS ONE OPEN?\r
1729         JRST    CLOSA4          ; NO\r
1730         CAME    C,TTICHN+1(TVP)\r
1731         CAMN    C,TTOCHN+1(TVP)\r
1732         JRST    CLOSA4\r
1733         PUSH    TP,-2(B)        ; PUSH IT\r
1734         PUSH    TP,-1(B)\r
1735         MCALL   1,FCLOSE                ; CLOSE IT\r
1736 CLOSA4: SOSLE   (P)             ; COUNT DOWN\r
1737         JRST    CLOSA1\r
1738 \r
1739 \r
1740         SUB     TP,[2,,2]\r
1741         SUB     P,[1,,1]\r
1742 \r
1743 CLOSA3: SKIPN   B,CHNL0+1(TVP)\r
1744         POPJ    P,\r
1745         PUSH    TP,(B)\r
1746         HLLZS   (TP)\r
1747         PUSH    TP,1(B)\r
1748         HRRZ    B,(B)\r
1749         MOVEM   B,CHNL0+1(TVP)\r
1750         MCALL   1,FCLOSE\r
1751         JRST    CLOSA3\r
1752 \f\r
1753 ; LITTLE ROUTINES USED ALL OVER THE PLACE\r
1754 \r
1755 CRLF:   MOVEI   A,15\r
1756         PUSHJ   P,MTYO\r
1757         MOVEI   A,12\r
1758         JRST    MTYO\r
1759 MSGTYP: HRLI    B,440700        ;MAKE BYTE POINTER\r
1760 MSGTY1: ILDB    A,B             ;GET NEXT CHARACTER\r
1761         JUMPE   A,CPOPJ         ;NULL ENDS STRING\r
1762         CAIE    A,177           ; DONT PRINT RUBOUTS\r
1763         PUSHJ   P,MTYO"\r
1764         JRST    MSGTY1          ;AND GET NEXT CHARACTER\r
1765 CPOPJ:  POPJ    P,\r
1766 \r
1767 IMPURE\r
1768 \r
1769 WHOAMI: 0               ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK\r
1770 \r
1771 \r
1772 ;GARBAGE COLLECTORS PDLS\r
1773 \r
1774 \r
1775 GCPDL:  -GCPLNT,,GCPDL\r
1776 \r
1777         BLOCK   GCPLNT\r
1778 \r
1779 \r
1780 PURE\r
1781 \r
1782 MUDSTR: ASCII /MUDDLE \7f\7f\7f/\r
1783 STRNG:  -1\r
1784         -1\r
1785         -1\r
1786         ASCIZ / IN OPERATION./\r
1787 \r
1788 ;MARKED PDLS FOR GC PROCESS\r
1789 \r
1790 VECTGO\r
1791 ; DUMMY FRAME FOR INITIALIZER CALLS\r
1792 \r
1793         TENTRY,,LISTEN\r
1794         0\r
1795         .-3\r
1796         0\r
1797         0\r
1798         -ITPLNT,,TPBAS-1\r
1799         0\r
1800 \r
1801 TPBAS:  BLOCK   ITPLNT+PDLBUF\r
1802         GENERAL\r
1803         ITPLNT+2+PDLBUF+7,,0\r
1804 \r
1805 \r
1806 VECRET\r
1807 \r
1808 \r
1809 \r
1810 \r
1811 $TMATO: TATOM,,-1\r
1812 \r
1813 \r
1814 PATCH:\r
1815 PAT:    BLOCK   100\r
1816 PATEND: 0\r
1817 \r
1818 END\r
1819 \f\r