sumex/muddle.all-750609.1.txt

   1 TITLE AGC MUDDLE GARBAGE COLLECTOR\r
   2 \r
   3 ;SYSTEM WIDE DEFINITIONS GO HERE\r
   4 \r
   5 .GLOBAL RCL,VECTOP,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG\r
   6 .GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR\r
   7 .GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR\r
   8 .GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,SYSMAX,FREDIF,FREMIN,GCHAPN,INTFLG\r
   9 .GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2\r
  10 .GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS\r
  11 .GLOBAL SPBASE,OUTRNG,CISTNG,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1\r
  12 .GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,%GCJOB,%SHWND,%SHFNT,%INFMP,%GETIP\r
  13 .GLOBAL TD.PUT,TD.GET,TD.LNT\r
  14 .GLOBAL CTIME,MTYO,ILOC,GCRSET\r
  15 .GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC\r
  16 ; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR\r
  17 \r
  18 .GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS\r
  19 .GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE\r
  20 \r
  21 .GLOBAL P.TOP,P.CORE,PMAP\r
  22 \r
  23 NGCS==8         ; AFTER NGCS, DO HAIRY VAL/ASSOC FLUSH\r
  24 PDLBUF=100\r
  25 TPMAX==20000    ;PDLS LARGER THAN THIS WILL BE SHRUNK\r
  26 PMAX==4000      ;MAXIMUM PSTACK SIZE\r
  27 TPMIN==1000     ;MINIMUM PDL SIZES\r
  28 PMIN==400\r
  29 TPGOOD==10000   ; A GOOD STACK SIZE\r
  30 PGOOD==1000\r
  31 .ATOM.==200000  ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)\r
  32 \r
  33 GCHN==0         ; CHANNEL FOR FUNNNY INFERIOR\r
  34 STATNO==19.     ; # OF STATISTICS FOR BLOAT-STAT\r
  35 STATGC==8.      ; # OF GC-STATISTICS FOR BLOAT-STAT\r
  36 \r
  37 \r
  38 RELOCATABLE\r
  39 .INSRT MUDDLE >\r
  40 \r
  41 TYPNT=AB        ;SPECIAL AC USAGE DURING GC\r
  42 F=TP                            ;ALSO SPECIAL DURING GC\r
  43 LPVP=SP                         ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN\r
  44 FPTR=TB                         ; POINT TO CURRENT FRONTIER OF INFERIOR\r
  45 \r
  46 \r
  47 ; WINDOW AND FRONTIER PAGES\r
  48 \r
  49 FRONT==776000           ; PAGE 255. IS FRONTIER\r
  50 WIND==774000            ; PAGE 254. IS WINDOW\r
  51 FRNP==FRONT/2000\r
  52 WNDP==WIND/2000\r
  53 \r
  54 \r
  55 \r
  56 \r
  57 \r
  58 \f\r
  59 .GLOBAL FLIST\r
  60 \r
  61 MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]\r
  62 \r
  63 ENTRY\r
  64 \r
  65         JUMPGE  AB,GETUVC       ; SEE IF THERE IS AN ARGUMENT\r
  66         GETYP   A,(AB)\r
  67         CAIE    A,TUVEC         ; SEE IF THE ARGUMENT IS A UVECTOR\r
  68         JRST    WTYP1           ; IF NOT COMPLAIN\r
  69         HLRE    0,1(AB)\r
  70         MOVNS   0\r
  71         CAIGE   0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH\r
  72         JRST    WTYP1\r
  73         CAMGE   AB,[-2,,0]      ; SEE IF THERE ARE TOO MANY ARGUMENTS\r
  74         JRST    TMA\r
  75         MOVE    A,(AB)          ; GET THE UVECTOR\r
  76         MOVE    B,1(AB)\r
  77         JRST    SETUV           ; CONTINUE\r
  78 GETUVC: MOVEI   A,STATNO+STATGC ; CREATE A UVECTOR\r
  79         PUSHJ   P,IBLOCK\r
  80 SETUV:  PUSH    P,A             ; SAVE UVECTOR\r
  81         PUSH    P,B\r
  82         MOVE    0,NOWFRE        ; COMPUTE FREE STORAGE USED SINCE LAST GC\r
  83         SUB     0,VECBOT\r
  84         ADD     0,PARTOP\r
  85         MOVEM   0,CURFRE\r
  86         HLRE    0,TP            ; COMPUTE STACK SPACE USED UP\r
  87         ADD     0,NOWTP\r
  88         SUBI    0,PDLBUF\r
  89         MOVEM   0,CURTP\r
  90         MOVE    B,IMQUOTE THIS-PROCESS\r
  91         PUSHJ   P,ILOC\r
  92         HRRZS   B\r
  93         HRRZ    C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS\r
  94         MOVE    0,B\r
  95         HRRZ    D,SPBASE+1(PVP)         ; COMPUTE CURRENT # OF BINDINGS\r
  96         SUB     0,D\r
  97         IDIVI   0,6\r
  98         MOVEM   0,CURLVL\r
  99         SUB     B,C             ; TOTAL WORDS ATOM STORAGE\r
 100         IDIVI   B,6             ; COMPUTE # OF SLOTS\r
 101         MOVEM   B,NOWLVL\r
 102         HRRZ    A,GLOBASE+1(TVP)        ; COMPUTE TOTAL # OF GLOBAL SLOTS\r
 103         HLRE    0,GLOBASE+1(TVP)\r
 104         SUB     A,0             ; POINT TO DOPE WORD\r
 105         HLRZ    B,1(A)\r
 106         ASH     B,-2            ; # OF GVAL SLOTS\r
 107         MOVEM   B,NOWGVL\r
 108         HRRZ    0,GLOBASE+1(TVP)        ; COMPUTE # OF GVAL SLOTS IN USE\r
 109         HRRZ    A,GLOBSP+1(TVP)\r
 110         SUB     A,0\r
 111         ASH     A,-2            ; NEGATIVE # OF SLOTS USED\r
 112         SUBI    B,(A)\r
 113         MOVEM   B,CURGVL\r
 114         HRRZ    A,TYPBOT+1(TVP) ; GET LENGTH OF TYPE VECTOR\r
 115         HLRE    0,TYPBOT+1(TVP)\r
 116         SUB     A,0\r
 117         HLRZ    B,1(A)          ; # OF WORDS IN TYPE-VECTOR\r
 118         IDIVI   B,2             ; CONVERT TO # OF TYPES\r
 119         MOVEM   B,NOWTYP\r
 120         HLRE    0,TYPVEC+1(TVP) ; LENGTH OF VISABLE TYPE-VECTOR\r
 121         MOVNS   0\r
 122         IDIVI   0,2             ; GET # OF TYPES\r
 123         MOVEM   0,CURTYP\r
 124         MOVE    0,CODTOP        ; GET LENGTH OF STATIONARY IMPURE STORAGE\r
 125         MOVEM   0,NOWSTO\r
 126         SETZB   B,D             ; ZERO OUT MAXIMUM\r
 127         HRRZ    C,FLIST\r
 128 LOOPC:  HLRZ    0,(C)           ; GET BLK LENGTH\r
 129         ADD     D,0             ; ADD # OF WORDS IN BLOCK\r
 130         CAMGE   B,0             ; SEE IF NEW MAXIMUM\r
 131         MOVE    B,0\r
 132         HRRZ    C,(C)           ; POINT TO NEXT BLOCK\r
 133         JUMPN   C,LOOPC         ; REPEAT\r
 134         MOVEM   D,CURSTO\r
 135         MOVEM   B,CURMAX\r
 136         HLRE    0,P             ; GET AMOUNT OF ROOM LEFT ON P\r
 137         ADD     0,NOWP\r
 138         SUBI    0,PDLBUF\r
 139         MOVEM   0,CURP\r
 140         PUSHJ   P,GCSET         ; FIX UP BLOAT-STAT PARAMETERS\r
 141         MOVSI   C,BSTGC         ; SET UP BLT FOR GC FIGURES\r
 142         HRRZ    B,(P)           ; RESTORE B\r
 143         HRR     C,B\r
 144         BLT     C,(B)STATGC-1\r
 145         HRLI    C,BSTAT         ; MODIFY BLT FOR STATS\r
 146         ADDI    C,STATGC                ; B HAS ELEMENTS\r
 147         BLT     C,(B)STATGC+STATNO-1\r
 148         MOVEI   0,TFIX\r
 149         HRLM    0,(B)STATNO+STATGC      ; MOVE IN UTYPE\r
 150         POP     P,B\r
 151         POP     P,A             ; RESTORE TYPE-WORD\r
 152         JRST    FINIS\r
 153 \r
 154 \r
 155 ; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE\r
 156 ; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY\r
 157 ; THEIR MUDDLE.\r
 158 \r
 159 GCRSET: SETZM   GCNO            ; CALL FROM INIT, ZAP ALL 1ST\r
 160         MOVE    0,[GCNO,,GCNO+1]\r
 161         BLT     0,GCCALL\r
 162 \r
 163 GCSET:  MOVE    A,VECBOT        ; COMPUTE FREE SPACE AVAILABLE\r
 164         SUB     A,PARTOP\r
 165         MOVEM   A,NOWFRE\r
 166         CAMLE   A,MAXFRE\r
 167         MOVEM   A,MAXFRE        ; MODIFY MAXIMUM\r
 168         HLRE    A,TP            ; FIND THE DOPE WORD OF THE TP STACK\r
 169         MOVNS   A\r
 170         ADDI    A,1(TP)         ; CLOSE TO DOPE WORD\r
 171         CAME    A,TPGROW\r
 172         ADDI    A,PDLBUF        ; NOW AT REAL DOPE WORD\r
 173         HLRZ    B,(A)           ; GET LENGTH OF TP-STACK\r
 174         MOVEM   B,NOWTP\r
 175         CAMLE   B,CTPMX         ; SEE IF THIS IS THE BIGGEST TP\r
 176         MOVEM   B,CTPMX\r
 177         HLRE    B,P             ; FIND DOPE WORD OF P-STACK\r
 178         MOVNS   B\r
 179         ADDI    B,1(P)          ; CLOSE TO IT\r
 180         CAME    B,PGROW         ; SEE IF THE STACK IS BLOWN\r
 181         ADDI    B,PDLBUF        ; POINTING TO IT\r
 182         HLRZ    A,(B)           ; GET IN LENGTH\r
 183         MOVEM   A,NOWP\r
 184         CAMLE   A,CPMX          ; SEE IF WE HAVE THE BIGGEST P STACK\r
 185         MOVEM   A,CPMX\r
 186         POPJ    P,              ; EXIT\r
 187 \r
 188 \r
 189 .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT\r
 190 \r
 191 ; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A\r
 192 ; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B\r
 193 ; RETURN -1 IN REG B IF NONE FOUND\r
 194 \r
 195 PGFIND:\r
 196         JUMPLE  A,FPLOSS\r
 197         PUSHJ   P,PGFND1        ; SEE IF ALREADY ENOUGH\r
 198         SKIPL   B               ; SKIP IF LOST\r
 199         POPJ    P,\r
 200 \r
 201         SUBM    M,(P)\r
 202         PUSH    P,E\r
 203         PUSH    P,C\r
 204         PUSH    P,D\r
 205         MOVE    C,PURBOT        ; CHECK IF ROOM AT ALL\r
 206         SUB     C,P.TOP         ; TOTAL SPACE\r
 207         MOVEI   D,(C)           ; COPY FOR CONVERSION TO PAGES\r
 208         ASH     D,-10.\r
 209         CAIGE   C,(A)           ; SKIP IF COULD WIN\r
 210         JRST    PGFLOS\r
 211 \r
 212         MOVNS   A               ; MOVE PURE AREA DOWN "A" PAGES\r
 213         PUSHJ   P,MOVPUR\r
 214         MOVE    B,PURTOP        ; GET FIRST PAGE ALLOCATED\r
 215         ASH     B,-10.          ; TO PAGE #\r
 216 PGFLOS: POP     P,D\r
 217         POP     P,C\r
 218         POP     P,E\r
 219         PUSHJ   P,RBLDM         ; GET A NEW VALUE FOR M\r
 220         JRST    MPOPJ\r
 221 \r
 222 PGFND1: PUSH    P,E\r
 223         PUSH    P,D\r
 224         PUSH    P,C\r
 225         PUSH    P,[-1]          ;POSSIBLE CONTENTS FOR REG B\r
 226         PUSH    P,A             ;SAVE LENGTH OF BLOCK DESIRED FOR LATER USE\r
 227         SETZB   B,C             ;INITIAL SECTION AND PAGE NUMBERS\r
 228         MOVEI   0,0             ;COUNT OF PAGES ALREADY FOUND\r
 229         PUSHJ   P,PINIT\r
 230 PLOOP:  TDNE    E,D             ;FREE PAGE ?\r
 231         JRST    NOTFRE          ;NO\r
 232         JUMPN   0,NFIRST        ;FIRST FREE PAGE OF A BLOCK ?\r
 233         MOVEI   A,(B)           ;YES SAVE ADDRESS OF PAGE IN REG A\r
 234         IMULI   A,32.\r
 235         ADDI    A,(C)\r
 236 NFIRST: ADDI    0,1\r
 237         CAML    0,(P)           ;TEST IF ENOUGH PAGES HAVE BEEN FOUND\r
 238         JRST    PWIN            ;YES, FINISHED\r
 239         SKIPA   \r
 240 NOTFRE: MOVEI   0,0             ;RESET COUNT\r
 241         PUSHJ   P,PNEXT ;NEXT PAGE\r
 242         JRST    PLOSE           ;NONE--LOSE RETURNING -1 IN REG B\r
 243         JRST    PLOOP\r
 244 \r
 245 PWIN:   MOVEI   B,(A)           ;GET WINNING ADDRESS\r
 246         MOVEM   B,(P)-1         ;RETURN ADDRESS OF WINNING PAGE\r
 247         MOVE    A,(P)           ;RELOAD LENGTH OF BLOCK OF PAGES\r
 248         MOVE    0,[TDO E,D]     ;INST TO SET "BUSY" BITS\r
 249         JRST    ITAKE\r
 250 \r
 251 ;CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A\r
 252 ;THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B\r
 253 PGGIVE: MOVE    0,[TDZ E,D]     ;INST TO SET "FREE" BITS\r
 254         SKIPA\r
 255 PGTAKE: MOVE    0,[TDO E,D]     ;INST TO SET "BUSY" BITS\r
 256         JUMPLE  A,FPLOSS\r
 257         CAIL    B,0\r
 258         CAILE   B,255.\r
 259         JRST    FPLOSS\r
 260         PUSH    P,E\r
 261         PUSH    P,D\r
 262         PUSH    P,C\r
 263         PUSH    P,B\r
 264         PUSH    P,A\r
 265 ITAKE:  IDIVI   B,32.\r
 266         PUSHJ   P,PINIT\r
 267         SUBI    A,1\r
 268 RTL:    XCT     0               ;SET APPROPRIATE BIT\r
 269         PUSHJ   P,PNEXT ;NEXT PAGE'S BIT\r
 270         JUMPG   A,FPLOSS        ;TOO MANY ?\r
 271         SOJGE   A,RTL\r
 272         MOVEM   E,PMAP(B)       ;REPLACE BIT MASK\r
 273 PLOSE:  POP     P,A\r
 274         POP     P,B\r
 275         POP     P,C\r
 276         POP     P,D\r
 277         POP     P,E\r
 278         POPJ    P,\r
 279 \r
 280 \r
 281 PINIT:  MOVE    E,PMAP(B)       ;GET BITS FOR THIS SECTION\r
 282         HRLZI   D,400000        ;BIT MASK\r
 283         MOVNS   C\r
 284         LSH     D,(C)           ;SHIFT TO APPROPRIATE BIT POSITION\r
 285         MOVNS   C\r
 286         POPJ    P,\r
 287 \r
 288 PNEXT:  AOS     (P)             ;FOR SKIP RETURN ON EXPECTED SUCCESS\r
 289         LSH     D,-1            ;CONSIDER NEXT PAGE\r
 290         CAIGE   C,31.           ;FINISHED WITH THIS SECTION ?\r
 291         AOJA    C,CPOPJ         ;NO, INCREMENT AND CONTINUE\r
 292         MOVEM   E,PMAP(B)       ;REPLACE BIT MASK\r
 293         SETZ    C,\r
 294         CAIGE   B,7.            ;LAST SECTION ?\r
 295         AOJA    B,PINIT         ;NO, INCREMENT AND CONTINUE\r
 296         SOS     (P)             ;YES, UNDO SKIP RETURN\r
 297         POPJ    P,\r
 298 \r
 299 FPLOSS: FATAL PAGE LOSSAGE\r
 300 \r
 301 PGINT:  MOVEI   B,HIBOT         ;INITIALIZE MUDDLE'S PAGE MAP TABLE\r
 302         IDIVI   B,2000          ;FIRST PAGE OF PURE CODE\r
 303         MOVE    C,HITOP\r
 304         IDIVI   C,2000\r
 305         MOVEI   A,(C)+1\r
 306         SUBI    A,(B)           ;NUMBER OF SUCH PAGES\r
 307         PUSHJ   P,PGTAKE        ;MARK THESE PAGES AS TAKEN\r
 308         POPJ    P,\r
 309 ; USER GARBAGE COLLECTOR INTERFACE\r
 310 \r
 311 MFUNCTION GC,SUBR\r
 312         ENTRY\r
 313 \r
 314         JUMPGE  AB,GC1\r
 315         CAMGE   AB,[-4,,0]\r
 316         JRST    TMA\r
 317         PUSHJ   P,GETFIX        ; GET FREEE MIN IF GIVEN\r
 318         MOVEM   A,FREMIN\r
 319         ADD     AB,[2,,2]       ; NEXT ARG\r
 320         JUMPGE  AB,GC1          ; NOT SUPPLIED\r
 321         PUSHJ   P,GETFIX        ; GET FREDIF\r
 322         MOVEM   A,FREDIF\r
 323 GC1:    PUSHJ   P,COMPRM        ; GET CURRENT USED CORE\r
 324         PUSH    P,A\r
 325         MOVEI   A,1\r
 326         MOVEM   A,GCHAIR        ; FORCE FLUSH OF VALS ASSOCS\r
 327         MOVE    C,[11,,0]       ; INDICATOR FOR AGC\r
 328         PUSHJ   P,AGC           ; COLLECT THAT TRASH\r
 329         SKIPGE  A               ; SKIP IF OK\r
 330         PUSHJ   P,FULLOS        ; COMPLAIN ABOUT LACK OF SPACE\r
 331         PUSHJ   P,COMPRM        ; HOW MUCH ROOM NOW?\r
 332         POP     P,B             ; RETURN AMOUNT\r
 333         SUB     B,A\r
 334         MOVSI   A,TFIX\r
 335         JRST    FINIS\r
 336 \r
 337 \r
 338 COMPRM: MOVE    A,PARTOP        ; USED SPACE\r
 339         SUB     A,PARBOT\r
 340         ADD     A,VECTOP\r
 341         SUB     A,VECBOT\r
 342         POPJ    P,\r
 343 \r
 344 MFUNCTION GCDMON,SUBR,[GC-MON]\r
 345 \r
 346         ENTRY   1\r
 347 \r
 348         SETZM   GCMONF          ; ASSUME FALSE\r
 349         GETYP   0,(AB)\r
 350         CAIE    0,TFALSE\r
 351         SETOM   GCMONF\r
 352         MOVE    A,(AB)\r
 353         MOVE    B,1(AB)\r
 354         JRST    FINIS\r
 355 .GLOBAL EVATYP,APLTYP,PRNTYP\r
 356 \r
 357 \fMFUNCTION BLOAT,SUBR\r
 358         ENTRY\r
 359 \r
 360         MOVEI   C,0             ; FLAG TO SAY WHETHER NEED A GC\r
 361         MOVSI   E,-NBLO         ; AOBJN TO BLOATER TABLE\r
 362 \r
 363 BLOAT2: JUMPGE  AB,BLOAT1       ; ALL DONE?\r
 364         PUSHJ   P,NXTFIX        ; GET NEXT BLOAT PARAM\r
 365         PUSHJ   P,@BLOATER(E)   ; DISPATCH\r
 366         AOBJN   E,BLOAT2        ; COUNT PARAMS SET\r
 367 \r
 368         JUMPL   AB,TMA          ; ANY LEFT...ERROR\r
 369 BLOAT1: JUMPE   C,BLOATD        ; DONE, NO GC NEEDED\r
 370         MOVEI   0,1\r
 371         MOVEM   0,GCHAIR        ; FORCE HAIR TO OCCUR\r
 372         MOVE    C,E             ; MOVE IN INDICATOR\r
 373         HRLI    C,1             ; INDICATE THAT IT COMES FROM BLOAT\r
 374         PUSHJ   P,AGC           ; DO ONE\r
 375         SKIPGE  A\r
 376         PUSHJ   P,FULLOS        ; NO CORE LEFT\r
 377         SKIPE   A,TPBINC        ; SMASH POINNTERS\r
 378         ADDM    A,TPBASE+1(PVP)\r
 379         SKIPE   A,GLBINC        ; GLOBAL SP\r
 380         ADDM    A,GLOBASE+1(TVP)\r
 381         SKIPE   A,TYPINC\r
 382         ADDM    A,TYPBOT+1(TVP)\r
 383         SETZM   TPBINC          ; RESET PARAMS\r
 384         SETZM   GLBINC\r
 385         SETZM   TYPINC\r
 386 \r
 387 BLOATD: MOVE    B,VECBOT\r
 388         SUB     B,PARTOP\r
 389         MOVSI   A,TFIX          ; RETURN CORE FOUND\r
 390         JRST    FINIS\r
 391 \r
 392 ; TABLE OF BLOAT ROUTINES\r
 393 \r
 394 BLOATER:\r
 395         MAINB\r
 396         TPBLO\r
 397         LOBLO\r
 398         GLBLO\r
 399         TYBLO\r
 400         STBLO\r
 401         PBLO\r
 402         SFREM\r
 403         SFRED\r
 404         SLVL\r
 405         SGVL\r
 406         STYP\r
 407         SSTO\r
 408         NBLO==.-BLOATER\r
 409 \r
 410 ; BLOAT MAIN STORAGE AREA\r
 411 \r
 412 MAINB:  MOVE    D,VECBOT        ; COMPUTE CURRENT ROOM\r
 413         SUB     D,PARTOP\r
 414         CAMGE   A,D             ; NEED MORE?\r
 415         POPJ    P,              ; NO, LEAVE\r
 416         MOVEM   A,GETNUM                ; SAVE\r
 417         AOJA    C,CPOPJ         ; LEAVE SETTING C\r
 418 \r
 419 ; BLOAT TP STACK (AT TOP)\r
 420 \r
 421 TPBLO:  HLRE    D,TP            ; GET -SIZE\r
 422         MOVNS   B,D\r
 423         ADDI    D,1(TP)         ; POINT TO DOPE (ALMOST)\r
 424         CAME    D,TPGROW        ; BLOWN?\r
 425         ADDI    D,PDLBUF        ; POINT TO REAL DOPE WORD\r
 426         CAMG    A,B             ; SKIP IF GROWTH NEEDED\r
 427         POPJ    P,\r
 428         ASH     A,-6            ; CONVERT TO 64 WD BLOCKS\r
 429         CAILE   A,377\r
 430         JRST    OUTRNG\r
 431         DPB     A,[111100,,-1(D)]       ; SMASH SPECS IN\r
 432         AOJA    C,CPOPJ\r
 433 \r
 434 ; BLOAT TOP LEVEL LOCALS\r
 435 \r
 436 LOBLO:  IMULI   A,6             ; 6 WORDS PER BINDING\r
 437         HRRZ    0,TPBASE+1(PVP)\r
 438         HRRZ    B,SPBASE+1(PVP) ; ROOM AVAIL TO E\r
 439         SUB     B,0\r
 440         SUBI    A,(B)           ; HOW MUCH MORE?\r
 441         JUMPLE  A,CPOPJ         ; NONE NEEDED\r
 442         MOVEI   B,TPBINC\r
 443         PUSHJ   P,NUMADJ\r
 444         DPB     A,[1100,,-1(D)] ; SMASH\r
 445         AOJA    C,CPOPJ\r
 446 \r
 447 ; GLOBAL SLOT GROWER\r
 448 \r
 449 GLBLO:  ASH     A,2             ; 4 WORDS PER VAR\r
 450         MOVE    D,GLOBASE+1(TVP)        ; CURRENT LIMITS\r
 451         HRRZ    B,GLOBSP+1(TVP)\r
 452         SUBI    B,(D)\r
 453         SUBI    A,(B)           ; NEW AMOUNT NEEDED\r
 454         JUMPLE  A,CPOPJ\r
 455         MOVEI   B,GLBINC        ; WHERE TO KEEP UPDATE\r
 456         PUSHJ   P,NUMADJ        ; FIX NUMBER\r
 457         HLRE    0,D\r
 458         SUB     D,0             ; POINT TO DOPE\r
 459         DPB     A,[1100,,(D)]   ; AND SMASH\r
 460         AOJA    C,CPOPJ\r
 461 \r
 462 ; HERE TO GROW TYPE VECTOR (AND FRIENDS)\r
 463 \r
 464 TYBLO:  ASH     A,1             ; TWO WORD PER TYPE\r
 465         HRRZ    B,TYPBOT+1(TVP) ; FIND CURRENT ROOM\r
 466         MOVE    D,TYPVEC+1(TVP)\r
 467         SUBI    B,(D)\r
 468         SUBI    A,(B)           ; EXTRA NEEDED TO A\r
 469         JUMPLE  A,CPOPJ         ; NONE NEEDED, LEAVE\r
 470         MOVEI   B,TYPINC        ; WHERE TO STASH SPEC\r
 471         PUSHJ   P,NUMADJ        ; FIX NUMBER\r
 472         HLRE    0,D             ; POINT TO DOPE\r
 473         SUB     D,0\r
 474         DPB     A,[1100,,(D)]\r
 475         SKIPE   D,EVATYP+1(TVP) ; GROW AUX TYPE VECS IF NEEDED\r
 476         PUSHJ   P,SGROW1\r
 477         SKIPE   D,APLTYP+1(TVP)\r
 478         PUSHJ   P,SGROW1\r
 479         SKIPE   D,PRNTYP+1(TVP)\r
 480         PUSHJ   P,SGROW1\r
 481         AOJA    C,CPOPJ\r
 482 \r
 483 ; HERE TO CREATE STORAGE SPACE\r
 484 \r
 485 STBLO:  MOVE    D,PARBOT        ; HOW MUCH NOW HERE\r
 486         SUB     D,CODTOP\r
 487         SUBI    A,(D)           ; MORE NEEDED?\r
 488         JUMPLE  A,CPOPJ\r
 489         MOVEM   A,PARNEW        ; FORCE PAIR SPACE TO MOVE ON OUT\r
 490         AOJA    C,CPOPJ\r
 491 \r
 492 ; BLOAT P STACK\r
 493 \r
 494 PBLO:   HLRE    D,P\r
 495         MOVNS   B,D\r
 496         SUBI    D,5             ; FUDGE FOR THIS CALL\r
 497         SUBI    A,(D)\r
 498         JUMPLE  A,CPOPJ\r
 499         ADDI    B,1(P)          ; POINT TO DOPE\r
 500         CAME    B,PGROW         ; BLOWN?\r
 501         ADDI    B,PDLBUF        ; NOPE, POIN TO REAL D.W.\r
 502         ASH     A,-6            ; TO 64 WRD BLOCKS\r
 503         CAILE   A,377           ; IN RANGE?\r
 504         JRST    OUTRNG\r
 505         DPB     A,[111100,,-1(B)]\r
 506         AOJA    C,CPOPJ\r
 507                         \r
 508 ; SET FREMIN\r
 509 \r
 510 SFREM:  MOVEM   A,FREMIN\r
 511         POPJ    P,\r
 512 \r
 513 ; SET FREDIF\r
 514 \r
 515 SFRED:  MOVEM   A,FREDIF\r
 516         POPJ    P,\r
 517 \r
 518 ; SET LVAL INCREMENT\r
 519 \r
 520 SLVL:   IMULI   A,6             ; CALCULATE AMOUNT TO GROW B\r
 521         IDIVI   A,64.           ; # OF  GROW BLOCKS NEEDED\r
 522         CAIE    B,0             ; DOES B HAVE A REMAINDER\r
 523         ADDI    A,1             ; IF SO ADD A BLOCK\r
 524         MOVEM   A,LVLINC\r
 525         POPJ P,\r
 526 \r
 527 ; SET GVAL INCREMENT\r
 528 \r
 529 SGVL:   IDIVI   A,16.           ; CALCULATE NUMBER OF GROW BLOCKS NEEDED\r
 530         CAIE    B,0\r
 531         ADDI    A,1             ; COMPENSATE FOR EXTRA\r
 532         MOVEM   A,GVLINC\r
 533         POPJ    P,\r
 534 \r
 535 ; SET TYPE INCREMENT\r
 536 \r
 537 STYP:   IDIVI   A,32.           ; CALCULATE NUMBER OF GROW BLOCKS NEEDED\r
 538         CAIE    B,0\r
 539         ADDI    A,1             ; COMPENSATE FOR EXTRA\r
 540         MOVEM   A,TYPIC\r
 541         POPJ    P,\r
 542 \r
 543 ; SET STORAGE INCREMENT\r
 544 \r
 545 SSTO:   IDIVI   A,2000          ; # OF BLOCKS\r
 546         CAIE    B,0             ; REMAINDER?\r
 547         ADDI    A,1\r
 548         IMULI   A,2000          ; CONVERT BACK TO WORDS\r
 549         MOVEM   A,STORIC\r
 550         POPJ P,\r
 551 \r
 552 \r
 553 ; GET NEXT (FIX) ARG\r
 554 \r
 555 NXTFIX: PUSHJ   P,GETFIX\r
 556         ADD     AB,[2,,2]\r
 557         POPJ    P,\r
 558 \r
 559 ; ROUTINE TO GET POS FIXED ARG\r
 560 \r
 561 GETFIX: GETYP   A,(AB)\r
 562         CAIE    A,TFIX\r
 563         JRST    WRONGT\r
 564         SKIPGE  A,1(AB)\r
 565         JRST    BADNUM\r
 566         POPJ    P,\r
 567 \r
 568 \r
 569 ; GET NUMBERS FIXED UP FOR GROWTH FIELDS\r
 570 \r
 571 NUMADJ: ADDI    A,77            ; ROUND UP\r
 572         ANDCMI  A,77            ; KILL CRAP\r
 573         MOVE    0,A\r
 574         MOVNS   A               ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE\r
 575         HRLI    A,-1(A)\r
 576         MOVEM   A,(B)           ; AND STASH IT\r
 577         MOVE    A,0\r
 578         ASH     A,-6            ; TO 64 WD BLOCKS\r
 579         CAILE   A,377           ; CHECK FIT\r
 580         JRST    OUTRNG\r
 581         POPJ    P,\r
 582 \r
 583 ; DO SYMPATHETIC GROWTHS\r
 584 \r
 585 SGROW1: HLRE    0,D\r
 586         SUB     D,0\r
 587         DPB     A,[111100,,(D)]\r
 588         POPJ    P,\r
 589 \r
 590 \f;FUNCTION TO CONSTRUCT A LIST\r
 591 \r
 592 MFUNCTION CONS,SUBR\r
 593 \r
 594         ENTRY   2\r
 595         GETYP   A,2(AB)         ;GET TYPE OF 2ND ARG\r
 596         CAIE    A,TLIST         ;LIST?\r
 597         JRST    WTYP2           ;NO , COMPLAIN\r
 598         MOVE    C,(AB)          ; GET THING TO CONS IN\r
 599         MOVE    D,1(AB)\r
 600         HRRZ    E,3(AB)         ; AND LIST\r
 601         PUSHJ   P,ICONS         ; INTERNAL CONS\r
 602         JRST    FINIS\r
 603 \r
 604 ; COMPILER CALL TO CONS\r
 605 \r
 606 CICONS: SUBM    M,(P)\r
 607         PUSHJ   P,ICONS\r
 608 MPOPJ:  SUBM    M,(P)\r
 609         POPJ    P,\r
 610 \r
 611 ; INTERNAL CONS TO NIL--INCONS\r
 612 \r
 613 INCONS: MOVEI   E,0\r
 614 \r
 615 ; INTERNAL CONS--ICONS;  C,D VALUE, E CDR\r
 616 \r
 617 ICONS:  GETYP   A,C             ; CHECK TYPE OF VAL\r
 618         PUSHJ   P,NWORDT        ; # OF WORDS\r
 619         SOJN    A,ICONS1        ; JUMP IF DEFERMENT NEEDED\r
 620         PUSHJ   P,ICELL2        ; NO DEFER, GET 2 WORDS FROM PAIR SPACE\r
 621         JRST    ICONS2          ; NO CORE, GO GC\r
 622         HRRI    C,(E)           ; SET UP CDR\r
 623 ICONS3: MOVEM   C,(B)           ; AND STORE\r
 624         MOVEM   D,1(B)\r
 625 TLPOPJ: MOVSI   A,TLIST\r
 626         POPJ    P,\r
 627 \r
 628 ; HERE IF CONSING DEFERRED\r
 629 \r
 630 ICONS1: MOVEI   A,4             ; NEED 4 WORDS\r
 631         PUSHJ   P,ICELL         ; GO GET 'EM\r
 632         JRST    ICONS2          ; NOT THERE, GC\r
 633         HRLI    E,TDEFER        ; CDR AND DEFER\r
 634         MOVEM   E,(B)           ; STORE\r
 635         MOVEI   E,2(B)          ; POINT E TO VAL CELL\r
 636         HRRZM   E,1(B)\r
 637         MOVEM   C,(E)           ; STORE VALUE\r
 638         MOVEM   D,1(E)\r
 639         JRST    TLPOPJ\r
 640 \r
 641 \r
 642 \r
 643 ; HERE TO GC ON A CONS\r
 644 \r
 645 ICONS2: PUSH    TP,C            ; SAVE VAL\r
 646         PUSH    TP,D\r
 647         PUSH    TP,$TLIST\r
 648         PUSH    TP,E            ; SAVE VITAL STUFF\r
 649         MOVEM   A,GETNUM        ; AMOUNT NEEDED\r
 650         MOVE    C,[3,,1]        ; INDICATOR FOR AGC\r
 651         PUSHJ   P,AGC           ; ATTEMPT TO WIN\r
 652         SKIPGE  A               ; SKIP IF WON\r
 653         PUSHJ   P,FULLOS\r
 654         MOVE    D,-2(TP)        ; RESTORE VOLATILE STUFF\r
 655         MOVE    C,-3(TP)\r
 656         MOVE    E,(TP)\r
 657         SUB     TP,[4,,4]\r
 658         JRST    ICONS           ; BACK TO DRAWING BOARD\r
 659 \r
 660 ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE.  CALLS AGC IF NEEDED\r
 661 \r
 662 CELL2:  MOVEI   A,2             ; USUAL CASE\r
 663 CELL:   PUSHJ   P,ICELL         ; INTERNAL\r
 664         JRST    .+2             ; LOSER\r
 665         POPJ    P,\r
 666 \r
 667         MOVEM   A,GETNUM        ; AMOUNT REQUIRED\r
 668         PUSH    P,A             ; PREVENT AGC DESTRUCTION\r
 669         MOVE    C,[3,,1]        ; INDICATOR FOR AGC\r
 670         PUSHJ   P,AGC\r
 671         SKIPGE  A               ; SKIP IF WINNER\r
 672         PUSHJ   P,FULLOS        ; REPORT TROUBLE\r
 673         POP     P,A\r
 674         JRST    CELL            ; AND TRY AGAIN\r
 675 \r
 676 ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T\r
 677 \r
 678 ICELL2: MOVEI   A,2             ; MOST LIKELY CAE\r
 679 ICELL:  SKIPE   B,RCL\r
 680         JRST    ICELRC          ;SEE IF WE CAN RE-USE A RECYCLE CELL\r
 681         MOVE    B,PARTOP        ; GET TOP OF PAIRS\r
 682         ADDI    B,(A)           ; BUMP\r
 683         CAMLE   B,VECBOT        ; SKIP IF OK.\r
 684         POPJ    P,              ; LOSE\r
 685         EXCH    B,PARTOP        ; SETUP NEW PARTOP AND RETURN POINTER\r
 686         PUSH    P,B             ; MODIFY TOTAL # OF FREE WORDS\r
 687         MOVE    B,USEFRE\r
 688         ADDI    B,(A)\r
 689         MOVEM   B,USEFRE\r
 690         POP     P,B\r
 691         JRST    CPOPJ1          ; SKIP RETURN\r
 692 \r
 693 ICELRC: CAIE    A,2\r
 694         JRST    ICELL+2         ;IF HE DOESNT WANT TWO, USE OLD METHOD\r
 695         PUSH    P,A\r
 696         MOVE    A,(B)\r
 697         HRRZM   A,RCL\r
 698         POP     P,A\r
 699         SETZM   (B)             ;GIVE HIM A CLEAN RECYCLED CELL\r
 700         SETZM   1(B)\r
 701         JRST    CPOPJ           ;THAT IT\r
 702 \r
 703 ;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT\r
 704 \r
 705 NWORDT: PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE\r
 706 NWORDS: CAIG    A,NUMSAT        ; TEMPLATE?\r
 707         SKIPL   MKTBS(A)        ;-ENTRY IN TABLE MEANS 2 NEEDED\r
 708         SKIPA   A,[1]           ;NEED ONLY 1\r
 709         MOVEI   A,2             ;NEED 2\r
 710         POPJ    P,\r
 711 \r
 712 \f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS\r
 713 \r
 714 MFUNCTION LIST,SUBR\r
 715         ENTRY\r
 716 \r
 717         PUSH    P,$TLIST\r
 718 LIST12: HLRE    A,AB            ;GET -NUM OF ARGS\r
 719         SKIPE   RCL             ;SEE IF WE WANT TO DO ONE AT A TIME\r
 720         JRST    LST12R          ;TO GET RECYCLED CELLS\r
 721         MOVNS   A               ;MAKE IT +\r
 722         JUMPE   A,LISTN         ;JUMP IF 0\r
 723         PUSHJ   P,CELL          ;GET NUMBER OF CELLS\r
 724         PUSH    TP,$TAB\r
 725         PUSH    TP,AB\r
 726         PUSH    TP,(P)  ;SAVE IT\r
 727         PUSH    TP,B\r
 728         SUB     P,[1,,1]\r
 729         LSH     A,-1            ;NUMBER OF REAL LIST ELEMENTS\r
 730 \r
 731 CHAINL: ADDI    B,2             ;LOOP TO CHAIN ELEMENTS\r
 732         HRRZM   B,-2(B)         ;CHAIN LAST ONE TO NEXT ONE\r
 733         SOJG    A,.-2           ;LOOP TIL ALL DONE\r
 734         CLEARM  B,-2(B)         ;SET THE  LAST CDR TO NIL\r
 735 \r
 736 ; NOW LOBEER THE DATA IN TO THE LIST\r
 737 \r
 738         MOVE    D,AB            ; COPY OF ARG POINTER\r
 739         MOVE    B,(TP)          ;RESTORE LIS POINTER\r
 740 LISTLP: GETYP   A,(D)           ;GET TYPE\r
 741         PUSHJ   P,NWORDT        ;GET NUMBER OF WORDS\r
 742         SOJN    A,LDEFER        ;NEED TO DEFER POINTER\r
 743         GETYP   A,(D)           ;NOW CLOBBER ELEMENTS\r
 744         HRLM    A,(B)\r
 745         MOVE    A,1(D)          ;AND VALUE..\r
 746         MOVEM   A,1(B)\r
 747 LISTL2: HRRZ    B,(B)           ;REST B\r
 748         ADD     D,[2,,2]        ;STEP ARGS\r
 749         JUMPL   D,LISTLP\r
 750 \r
 751         POP     TP,B\r
 752         POP     TP,A\r
 753         SUB     TP,[2,,2]       ; CLEANUP STACK\r
 754         JRST    FINIS\r
 755 \r
 756 \r
 757 LST12R: ASH     A,-1            ;ONE AT A TIME TO GET RECYCLED CELLS\r
 758         JUMPE   A,LISTN\r
 759         PUSH    P,A             ;SAVE COUNT ON STACK\r
 760         SETZB   C,D\r
 761         SETZM   E\r
 762         PUSHJ   P,ICONS\r
 763         MOVE    E,B             ;LOOP AND CHAIN TOGETHER\r
 764         AOSGE   (P)\r
 765         JRST    .-3\r
 766         PUSH    TP,-1(P)        ;PUSH ON THE TYPE WE WANT\r
 767         PUSH    TP,B\r
 768         SUB     P,[2,,2]        ;CLEAN UP AFTER OURSELVES\r
 769         JRST    LISTLP-2        ;AND REJOIN MAIN STREAM\r
 770 \r
 771 \r
 772 ; MAKE A DEFERRED POINTER\r
 773 \r
 774 LDEFER: PUSH    TP,$TLIST       ;SAVE CURRENT POINTER\r
 775         PUSH    TP,B\r
 776         MOVEM   D,1(TB)         ; SAVE ARG HACKER\r
 777         PUSHJ   P,CELL2\r
 778         MOVE    D,1(TB)\r
 779         GETYPF  A,(D)           ;GET FULL DATA\r
 780         MOVE    C,1(D)\r
 781         MOVEM   A,(B)\r
 782         MOVEM   C,1(B)\r
 783         MOVE    C,(TP)          ;RESTORE LIST POINTER\r
 784         MOVEM   B,1(C)          ;AND MAKE THIS BE THE VALUE\r
 785         MOVSI   A,TDEFER\r
 786         HLLM    A,(C)           ;AND STORE IT\r
 787         MOVE    B,C\r
 788         SUB     TP,[2,,2]\r
 789         JRST    LISTL2\r
 790 \r
 791 LISTN:  MOVEI   B,0\r
 792         POP     P,A\r
 793         JRST    FINIS\r
 794 \r
 795 ; BUILD A FORM\r
 796 \r
 797 MFUNCTION FORM,SUBR\r
 798 \r
 799         ENTRY\r
 800 \r
 801         PUSH    P,$TFORM\r
 802         JRST    LIST12\r
 803 \r
 804 \f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK\r
 805 \r
 806 IILIST: SUBM    M,(P)\r
 807         PUSHJ   P,IILST\r
 808         MOVSI   A,TLIST\r
 809         JRST    MPOPJ\r
 810 \r
 811 IIFORM: SUBM    M,(P)\r
 812         PUSHJ   P,IILST\r
 813         MOVSI   A,TFORM\r
 814         JRST    MPOPJ\r
 815 \r
 816 IILST:  JUMPE   A,IILST0        ; NIL WHATSIT\r
 817         PUSH    P,A\r
 818         MOVEI   E,0\r
 819 IILST1: POP     TP,D\r
 820         POP     TP,C\r
 821         PUSHJ   P,ICONS         ; CONS 'EM UP\r
 822         MOVEI   E,(B)\r
 823         SOSE    (P)             ; COUNT\r
 824         JRST    IILST1\r
 825 \r
 826         SUB     P,[1,,1]\r
 827         POPJ    P,\r
 828 \r
 829 IILST0: MOVEI   B,0\r
 830         POPJ    P,\r
 831 \r
 832 \f;FUNCTION TO BUILD AN IMPLICIT LIST\r
 833 \r
 834 MFUNCTION ILIST,SUBR\r
 835         ENTRY\r
 836         PUSH    P,$TLIST\r
 837 ILIST2: JUMPGE  AB,TFA          ;NEED AT LEAST ONE ARG\r
 838         CAMGE   AB,[-4,,0]      ;NO MORE THAN TWO ARGS\r
 839         JRST    TMA\r
 840         PUSHJ   P,GETFIX        ; GET POS FIX #\r
 841         JUMPE   A,LISTN         ;EMPTY LIST ?\r
 842         CAML    AB,[-2,,0]      ;ONLY ONE ARG?\r
 843         JRST    LOSEL           ;YES\r
 844         PUSH    P,A             ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION\r
 845 ILIST0: PUSH    TP,2(AB)\r
 846         PUSH    TP,(AB)3\r
 847         MCALL   1,EVAL\r
 848         PUSH    TP,A\r
 849         PUSH    TP,B\r
 850         SOSLE   (P)\r
 851         JRST    ILIST0\r
 852         POP     P,C\r
 853 ILIST1: MOVE    C,(AB)+1        ;REGOBBLE LENGTH\r
 854         ACALL   C,LIST\r
 855 ILIST3: POP     P,A             ; GET FINAL TYPE\r
 856         JRST    FINIS\r
 857 \r
 858 \r
 859 LOSEL:  PUSH    P,A             ; SAVE COUNT\r
 860         MOVEI   E,0\r
 861 \r
 862 LOSEL1: SETZB   C,D             ; TLOSE,,0\r
 863         PUSHJ   P,ICONS\r
 864         MOVEI   E,(B)\r
 865         SOSLE   (P)\r
 866         JRST    LOSEL1\r
 867 \r
 868         SUB     P,[1,,1]\r
 869         JRST    ILIST3\r
 870 \r
 871 ; IMPLICIT FORM\r
 872 \r
 873 MFUNCTION IFORM,SUBR\r
 874 \r
 875         ENTRY\r
 876         PUSH    P,$TFORM\r
 877         JRST    ILIST2\r
 878 \r
 879 \f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES\r
 880 \r
 881 MFUNCTION VECTOR,SUBR,[IVECTOR]\r
 882 \r
 883         MOVEI   C,1\r
 884         JRST    VECTO3\r
 885 \r
 886 MFUNCTION UVECTOR,SUBR,[IUVECTOR]\r
 887 \r
 888         MOVEI   C,0\r
 889 VECTO3: ENTRY\r
 890         JUMPGE  AB,TFA          ; AT LEAST ONE ARG\r
 891         CAMGE   AB,[-4,,0]      ; NOT MORE THAN 2\r
 892         JRST    TMA\r
 893         PUSHJ   P,GETFIX        ; GET A POS FIXED NUMBER\r
 894         LSH     A,(C)           ; A-> NUMBER OF WORDS\r
 895         PUSH    P,C             ; SAVE FOR LATER\r
 896         PUSHJ   P,IBLOCK        ; GET BLOCK (TURN ON BIT APPROPRIATELY)\r
 897         POP     P,C\r
 898         HLRE    A,B             ; START TO\r
 899         SUBM    B,A             ; FIND DOPE WORD\r
 900         JUMPE   C,VECTO4\r
 901         MOVSI   D,400000        ; GET NOT UNIFORM BIT\r
 902         MOVEM   D,(A)           ; INTO DOPE WORD\r
 903         SKIPA   A,$TVEC         ; GET TYPE\r
 904 VECTO4: MOVSI   A,TUVEC\r
 905         CAML    AB,[-2,,0]      ; SKIP IF ARGS NEED TO BE HACKED\r
 906         JRST    FINIS\r
 907         JUMPGE  B,FINIS         ; DON'T EVAL FOR EMPTY CASE\r
 908 \r
 909         PUSH    TP,A            ; SAVE THE VECTOR\r
 910         PUSH    TP,B\r
 911         PUSH    TP,A\r
 912         PUSH    TP,B\r
 913 \r
 914         JUMPE   C,UINIT\r
 915         JUMPGE  B,FINIS         ; EMPTY VECTOR, LEAVE\r
 916 INLP:   PUSHJ   P,IEVAL         ; EVAL EXPR\r
 917         MOVEM   A,(C)\r
 918         MOVEM   B,1(C)\r
 919         ADD     C,[2,,2]        ; BUMP VECTOR\r
 920         MOVEM   C,(TP)\r
 921         JUMPL   C,INLP          ; IF MORE DO IT\r
 922 \r
 923 GETVEC: MOVE    A,-3(TP)\r
 924         MOVE    B,-2(TP)\r
 925         SUB     TP,[4,,4]\r
 926         JRST    FINIS\r
 927 \r
 928 ; HERE TO FILL UP A UVECTOR\r
 929 \r
 930 UINIT:  PUSHJ   P,IEVAL         ; HACK THE 1ST VALUE\r
 931         GETYP   A,A             ; GET TYPE\r
 932         PUSH    P,A             ; SAVE TYPE\r
 933         PUSHJ   P,NWORDT        ; SEE IF IT CAN BE UNIFORMED\r
 934         SOJN    A,CANTUN        ; COMPLAIN\r
 935 STJOIN: MOVE    C,(TP)          ; RESTORE POINTER\r
 936         ADD     C,1(AB)         ; POINT TO DOPE WORD\r
 937         MOVE    A,(P)           ; GET TYPE\r
 938         HRLZM   A,(C)           ; STORE IN D.W.\r
 939         MOVE    C,(TP)          ; GET BACK VECTOR\r
 940         SKIPE   1(AB)\r
 941         JRST    UINLP1          ; START FILLING UV\r
 942         JRST    GETVE1\r
 943 \r
 944 UINLP:  MOVEM   C,(TP)          ; SAVE PNTR\r
 945         PUSHJ   P,IEVAL         ; EVAL THE EXPR\r
 946         GETYP   A,A             ; GET EVALED TYPE\r
 947         CAIE    A,@(P)          ; WINNER?\r
 948         JRST    WRNGSU          ; SERVICE ERROR FOR UVECTOR,STORAGE\r
 949 UINLP1: MOVEM   B,(C)           ; STORE\r
 950         AOBJN   C,UINLP\r
 951 GETVE1: SUB     P,[1,,1]\r
 952         JRST    GETVEC          ; AND RETURN VECTOR\r
 953 \r
 954 IEVAL:  PUSH    TP,2(AB)\r
 955         PUSH    TP,3(AB)\r
 956         MCALL   1,EVAL\r
 957         MOVE    C,(TP)\r
 958         POPJ    P,\r
 959 \r
 960 ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES\r
 961 \r
 962 MFUNCTION ISTORAGE,SUBR\r
 963         ENTRY\r
 964         JUMPGE  AB,TFA\r
 965         CAMGE   AB,[-4,,0]      ; AT LEAST ONE ARG\r
 966         JRST    TMA\r
 967         PUSHJ   P,GETFIX        ; POSITIVE COUNT FIRST ARG\r
 968         PUSHJ   P,CAFRE ; GET CORE\r
 969         MOVN    B,1(AB) ; -COUNT\r
 970         HRL     A,B     ; PUT IN LHW (A)\r
 971         MOVM    B,B     ; +COUNT\r
 972         HRLI    B,2(B)  ; LENGTH + 2\r
 973         ADDI    B,(A)   ; MAKE POINTER TO DOPE WORDS\r
 974         HLLZM   B,1(B)  ; PUT TOTAL LENGTH IN 2ND DOPE\r
 975         HRRM    A,1(B)  ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).\r
 976         MOVE    B,A\r
 977         MOVSI   A,TSTORAGE\r
 978         CAML    AB,[-2,,0]      ; SECOND ARG TO EVAL?\r
 979         JRST FINIS      ; IF NOT, RETURN EMPTY\r
 980         PUSH    TP,A\r
 981         PUSH    TP,B\r
 982         PUSH    TP,A\r
 983         PUSH    TP,B\r
 984         PUSHJ   P,IEVAL ; EVALUATE FOR FIRST VALUE\r
 985         GETYP   A,A\r
 986         PUSH    P,A     ; FOR COMPARISON LATER\r
 987         PUSHJ   P,SAT\r
 988         CAIN    A,S1WORD\r
 989         JRST    STJOIN  ;TREAT LIKE A UVECTOR\r
 990         ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN\r
 991         PUSHJ   P,FREESV        ; FREE STORAGE VECTOR\r
 992         PUSH    TP,$TATOM\r
 993         PUSH    TP,EQUOTE DATA-CAN'T-GO-IN-STORAGE\r
 994         JRST    CALER1\r
 995 \r
 996 ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)\r
 997 FREESV: MOVE    A,1(AB) ; GET COUNT\r
 998         ADDI    A,2     ; FOR DOPE\r
 999         HRRZ    B,(TP)  ; GET ADDRESS\r
1000         PUSHJ   P,CAFRET        ; FREE THE CORE\r
1001         POPJ    P,\r
1002 \r
1003 \f; INTERNAL VECTOR ALLOCATOR.  A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)\r
1004 \r
1005 IBLOK1: ASH     A,1             ; TIMES 2\r
1006 GIBLOK: TLOA    A,400000        ; FUNNY BIT\r
1007 IBLOCK: TLZ     A,400000        ; NO BIT ON\r
1008         ADDI    A,2             ; COMPENSATE FOR DOPE WORDS\r
1009 IBLOK2: MOVE    B,VECBOT        ; POINT TO BOTTOM OF SPACE\r
1010         SUBI    B,(A)           ; SUBTRACT NEEDED AMOUNT\r
1011         CAMGE   B,PARTOP        ; SKIP IF NO GC NEEDED\r
1012         JRST    IVECT1\r
1013         EXCH    B,VECBOT        ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT\r
1014         PUSH    P,B\r
1015         MOVE    B,USEFRE\r
1016         ADDI    B,(A)\r
1017         MOVEM   B,USEFRE\r
1018         POP     P,B\r
1019         HRLZM   A,-1(B)         ; STORE LENGTH IN DOPE WORD\r
1020         HLLZM   A,-2(B)         ; AND BIT\r
1021         HRRO    B,VECBOT        ; POINT TO START OF VECTOR\r
1022         TLC     B,-3(A)         ; SETUP COUNT\r
1023         HRRI    A,TVEC\r
1024         SKIPL   A\r
1025         HRRI    A,TUVEC\r
1026         MOVSI   A,(A)\r
1027         POPJ    P,\r
1028 \r
1029 ; HERE TO DO A GC ON A VECTOR ALLOCATION\r
1030 \r
1031 IVECT1: PUSH    P,A             ; SAVE DESIRED LENGTH\r
1032         HRRZM   A,GETNUM        ; AND STORE AS DESIRED AMOUNT\r
1033         MOVE    C,[4,,1]        ; GET INDICATOR FOR AGC\r
1034         PUSHJ   P,AGC\r
1035         SKIPGE  A\r
1036         PUSHJ   P,FULLOS        ; LOST, COMPLAIN\r
1037         POP     P,A\r
1038         JRST    IBLOK2\r
1039 \r
1040 \r
1041 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS\r
1042 ; ITEMS ON TOP OF STACK\r
1043 \r
1044 IEVECT: ASH     A,1             ; TO NUMBER OF WORDS\r
1045         PUSH    P,A\r
1046         PUSHJ   P,IBLOCK        ; GET VECTOR\r
1047         HLRE    D,B             ; FIND DW\r
1048         SUBM    B,D             ; A POINTS TO DW\r
1049         MOVSI   0,400000\r
1050         MOVEM   0,(D)           ; CLOBBER NON UNIF BIT\r
1051         POP     P,A             ; RESTORE COUNT\r
1052         JUMPE   A,IVEC1         ; 0 LNTH, DONE\r
1053         MOVEI   C,(TP)          ; BUILD BLT\r
1054         SUBI    C,(A)-1         ; C POINTS TO 1ST ITEM ON STACK\r
1055         MOVSI   C,(C)\r
1056         HRRI    C,(B)           ; B/ SOURCE,,DEST\r
1057         BLT     C,-1(D)         ; XFER THE DATA\r
1058         HRLI    A,(A)\r
1059         SUB     TP,A            ; FLUSH STACKAGE\r
1060 IVEC1:  MOVSI   A,TVEC\r
1061         POPJ    P,\r
1062         \r
1063 \r
1064 ; COMPILERS CALL\r
1065 \r
1066 CIVEC:  SUBM    M,(P)\r
1067         PUSHJ   P,IEVECT\r
1068         JRST    MPOPJ\r
1069 \r
1070 \r
1071 \f; INTERNAL CALL TO EUVECTOR\r
1072 \r
1073 IEUVEC: PUSH    P,A             ; SAVE LENGTH\r
1074         PUSHJ   P,IBLOCK\r
1075         MOVE    A,(P)\r
1076         JUMPE   A,IEUVE1        ; EMPTY, LEAVE\r
1077         ASH     A,1             ; NOW FIND STACK POSITION\r
1078         MOVEI   C,(TP)          ; POINT TO TOP\r
1079         MOVE    D,B             ; COPY VEC POINTER\r
1080         SUBI    C,-1(A)         ; POINT TO 1ST DATUM\r
1081         GETYP   A,(C)           ; CHECK IT\r
1082         PUSHJ   P,NWORDT\r
1083         SOJN    A,CANTUN        ; WONT FIT\r
1084         GETYP   E,(C)\r
1085 \r
1086 IEUVE2: GETYP   0,(C)           ; TYPE OF EL\r
1087         CAIE    0,(E)           ; MATCH?\r
1088         JRST    WRNGUT\r
1089         MOVE    0,1(C)\r
1090         MOVEM   0,(D)           ; CLOBBER\r
1091         ADDI    C,2\r
1092         AOBJN   D,IEUVE2        ; LOOP\r
1093         HRLZM   E,(D)           ; STORE UTYPE\r
1094 IEUVE1: POP     P,A             ; GET COUNY\r
1095         ASH     A,1             ; MUST FLUSH 2 TIMES # OF ELEMENTS\r
1096         HRLI    A,(A)\r
1097         SUB     TP,A            ; CLEAN UP STACK\r
1098         MOVSI   A,TUVEC\r
1099         POPJ    P,\r
1100 \r
1101 ; COMPILER'S CALL\r
1102 \r
1103 CIUVEC: SUBM    M,(P)\r
1104         PUSHJ   P,IEUVEC\r
1105         JRST    MPOPJ\r
1106 \r
1107 MFUNCTION EVECTOR,SUBR,[VECTOR]\r
1108         ENTRY\r
1109         HLRE    A,AB\r
1110         MOVNS   A\r
1111         PUSH    P,A             ;SAVE NUMBER OF WORDS\r
1112         PUSHJ   P,IBLOCK        ; GET WORDS\r
1113         MOVEI   D,-1(B)         ; SETUP FOR BLT AND DOPE CLOBBER\r
1114         JUMPGE  B,FINISV                ;DONT COPY A ZERO LENGTH VECTOR\r
1115 \r
1116         HRLI    C,(AB)          ;START BUILDING BLT POINTER\r
1117         HRRI    C,(B)           ;TO ADDRESS\r
1118         ADDI    D,@(P)          ;SET D TO FINAL ADDRESS\r
1119         BLT     C,(D)\r
1120 FINISV: MOVSI   0,400000\r
1121         MOVEM   0,1(D)          ; MARK AS GENERAL\r
1122         SUB     P,[1,,1]\r
1123         MOVSI   A,TVEC\r
1124         JRST    FINIS\r
1125 \r
1126 \r
1127 \r
1128 \f;EXPLICIT VECTORS FOR THE UNIFORM CSE\r
1129 \r
1130 MFUNCTION EUVECTOR,SUBR,[UVECTOR]\r
1131 \r
1132         ENTRY\r
1133         HLRE    A,AB            ;-NUM OF ARGS\r
1134         MOVNS   A\r
1135         ASH     A,-1            ;NEED HALF AS MANY WORDS\r
1136         PUSH    P,A\r
1137         JUMPGE  AB,EUV1         ; DONT CHECK FOR EMPTY\r
1138         GETYP   A,(AB)          ;GET FIRST ARG\r
1139         PUSHJ   P,NWORDT                ;SEE IF NEEDS EXTRA WORDS\r
1140         SOJN    A,CANTUN\r
1141 EUV1:   POP     P,A\r
1142         PUSHJ   P,IBLOCK        ; GET VECT\r
1143         JUMPGE  B,FINISU\r
1144 \r
1145         GETYP   C,(AB)          ;GET THE FIRST TYPE\r
1146         MOVE    D,AB            ;COPY THE ARG POINTER\r
1147         MOVE    E,B             ;COPY OF RESULT\r
1148 \r
1149 EUVLP:  GETYP   0,(D)           ;GET A TYPE\r
1150         CAIE    0,(C)           ;SAME?\r
1151         JRST    WRNGUT          ;NO , LOSE\r
1152         MOVE    0,1(D)          ;GET GOODIE\r
1153         MOVEM   0,(E)           ;CLOBBER\r
1154         ADD     D,[2,,2]        ;BUMP ARGS POINTER\r
1155         AOBJN   E,EUVLP\r
1156 \r
1157         HRLM    C,(E)           ;CLOBBER UNIFORM TYPE IN\r
1158 FINISU: MOVSI   A,TUVEC\r
1159         JRST    FINIS\r
1160 \r
1161 WRNGSU: GETYP   A,-1(TP)\r
1162         CAIE    A,TSTORAGE\r
1163         JRST    WRNGUT  ;IF UVECTOR\r
1164         PUSHJ   P,FREESV        ;FREE STORAGE VECTOR\r
1165         PUSH    TP,$TATOM\r
1166         PUSH    TP,EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT\r
1167         JRST    CALER1\r
1168 \r
1169         \r
1170 WRNGUT: PUSH    TP,$TATOM\r
1171         PUSH    TP,EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR\r
1172         JRST    CALER1\r
1173 \r
1174 CANTUN: PUSH    TP,$TATOM\r
1175         PUSH    TP,EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR\r
1176         JRST    CALER1\r
1177 \r
1178 BADNUM: PUSH    TP,$TATOM\r
1179         PUSH    TP,EQUOTE NEGATIVE-ARGUMENT\r
1180         JRST    CALER1\r
1181 \f; FUNCTION TO GROW A VECTOR\r
1182 \r
1183 MFUNCTION GROW,SUBR\r
1184 \r
1185         ENTRY   3\r
1186 \r
1187         MOVEI   D,0             ;STACK HACKING FLAG\r
1188         GETYP   A,(AB)          ;FIRST TYPE\r
1189         PUSHJ   P,SAT           ;GET STORAGE TYPE\r
1190         GETYP   B,2(AB)         ;2ND ARG\r
1191         CAIE    A,STPSTK        ;IS IT ASTACK\r
1192         CAIN    A,SPSTK\r
1193         AOJA    D,GRSTCK        ;YES, WIN\r
1194         CAIE    A,SNWORD        ;UNIFORM VECTOR\r
1195         CAIN    A,S2NWORD       ;OR GENERAL\r
1196 GRSTCK: CAIE    B,TFIX          ;IS 2ND FIXED\r
1197         JRST    WTYP2           ;COMPLAIN\r
1198         GETYP   B,4(AB)\r
1199         CAIE    B,TFIX          ;3RD ARG\r
1200         JRST    WTYP3           ;LOSE\r
1201 \r
1202         MOVEI   E,1             ;UNIFORM/GENERAL FLAG\r
1203         CAIE    A,SNWORD        ;SKIP IF UNIFORM\r
1204         CAIN    A,SPSTK         ;DONT SKIP IF UNIFORM PDL\r
1205         MOVEI   E,0\r
1206 \r
1207         HRRZ    B,1(AB)         ;POINT TO START\r
1208         HLRE    A,1(AB)         ;GET -LENGTH\r
1209         SUB     B,A             ;POINT TO DOPE WORD\r
1210         SKIPE   D               ;SKIP IF NOT STACK\r
1211         ADDI    B,PDLBUF        ;FUDGE FOR PDL\r
1212         HLLZS   (B)             ;ZERO OUT GROWTH SPECS\r
1213         SKIPN   A,3(AB)         ;ANY TOP GROWTH?\r
1214         JRST    GROW1           ;NO, LOOK FOR BOTTOM GROWTH\r
1215         ASH     A,(E)           ;MULT BY 2 IF GENERAL\r
1216         ADDI    A,77            ;ROUND TO NEAREST BLOCK\r
1217         ANDCMI  A,77            ;CLEAR LOW ORDER BITS\r
1218         ASH     A,9-6           ;DIVIDE BY 100 AND SHIFT TO POSTION\r
1219         TRZE    A,400000        ;CONVERT TO SIGN MAGNITUDE\r
1220         MOVNS   A\r
1221         TLNE    A,-1            ;SKIP IF NOT TOO BIG\r
1222         JRST    GTOBIG          ;ERROR\r
1223 GROW1:  SKIPN   C,5(AB)         ;CHECK LOW GROWTH\r
1224         JRST    GROW4           ;NONE, SKIP\r
1225         ASH     C,(E)           ;GENRAL FUDGE\r
1226         ADDI    C,77            ;ROUND\r
1227         ANDCMI  C,77            ;FUDGE FOR VALUE RETURN\r
1228         PUSH    P,C             ;AND SAVE\r
1229         ASH     C,-6            ;DIVIDE BY 100\r
1230         TRZE    C,400           ;CONVERT TO SIGN MAGNITUDE\r
1231         MOVNS   C\r
1232         TDNE    C,[-1,,777000]  ;CHECK FOR OVERFLOW\r
1233         JRST    GTOBIG\r
1234 GROW2:  HLRZ    E,1(B)          ;GET TOTAL LENGTH OF VECTOR\r
1235         MOVNI   E,-1(E)\r
1236         HRLI    E,(E)           ;TO BOTH HALVES\r
1237         ADDI    E,1(B)          ;POINTS TO TOP\r
1238         SKIPE   D               ;STACK?\r
1239         ADD     E,[PDLBUF,,0]   ;YES, FUDGE LENGTH\r
1240         SKIPL   D,(P)           ;SHRINKAGE?\r
1241         JRST    GROW3           ;NO, CONTINUE\r
1242         MOVNS   D               ;PLUSIFY\r
1243         HRLI    D,(D)           ;TO BOTH HALVES\r
1244         ADD     E,D             ;POINT TO NEW LOW ADDR\r
1245 GROW3:  IORI    A,(C)           ;OR TOGETHER\r
1246         HRRM    A,(B)           ;DEPOSIT INTO DOPEWORD\r
1247         PUSH    TP,(AB)         ;PUSH TYPE\r
1248         PUSH    TP,E            ;AND VALUE\r
1249         JUMPE   A,.+3           ;DON'T GC FOR NOTHING\r
1250         MOVE    C,[2,,0]        ; GET INDICATOR FOR AGC\r
1251         PUSHJ   P,AGC\r
1252         JUMPL   A,GROFUL\r
1253         POP     P,C             ;RESTORE GROWTH\r
1254         HRLI    C,(C)\r
1255         POP     TP,B            ;GET VECTOR POINTER\r
1256         SUB     B,C             ;POINT TO NEW TOP\r
1257         POP     TP,A\r
1258         JRST    FINIS\r
1259 \r
1260 GROFUL: SUB     P,[1,,1]        ; CLEAN UP STACK\r
1261         SUB     TP,[2,,2]\r
1262         PUSHJ   P,FULLOS\r
1263         JRST    GROW\r
1264 \r
1265 GTOBIG: PUSH    TP,$TATOM\r
1266         PUSH    TP,EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH\r
1267         JRST    CALER1\r
1268 GROW4:  PUSH    P,[0]           ;0 BOTTOM GROWTH\r
1269         JRST    GROW2\r
1270 \r
1271 FULLOS: PUSH    TP,$TATOM       ; GENERATE ERROR\r
1272         PUSH    TP,@ERRTB(A)\r
1273         AOJL    A,CALER1        ; IF BAD, CALL ERROR\r
1274         SKIPN   GCMONF\r
1275         POPJ    P,\r
1276         PUSH    TP,TTOCHN(TVP)  ; FORCE MESSAGES TO TTY\r
1277         PUSH    TP,TTOCHN+1(TVP)\r
1278         PUSH    TP,TTOCHN(TVP)  ; FORCE MESSAGES TO TTY\r
1279         PUSH    TP,TTOCHN+1(TVP)\r
1280         MCALL   1,TERPRI        ; JUST PRINT MESSAGE\r
1281         MCALL   2,PRINC\r
1282         POPJ    P,\r
1283 \r
1284 \r
1285         EQUOTE  STILL-NO-STORAGE\r
1286         EQUOTE  NO-STORAGE\r
1287         EQUOTE  STORAGE-LOW\r
1288 ERRTB==.\r
1289 \f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES\r
1290 \r
1291 MFUNCTION STRING,SUBR\r
1292 \r
1293         ENTRY\r
1294 \r
1295         MOVE    B,AB            ;COPY ARG POINTER\r
1296         MOVEI   C,0             ;INITIALIZE COUNTER\r
1297         PUSH    TP,$TAB         ;SAVE A COPY\r
1298         PUSH    TP,B\r
1299         HLRE    A,B             ; GET # OF ARGS\r
1300         MOVNS   A\r
1301         ASH     A,-1            ; 1/2 FOR # OF ARGS\r
1302         PUSHJ   P,IISTRN\r
1303         JRST    FINIS\r
1304 \r
1305 IISTRN: SKIPN   E,A             ; SKIP IF ARGS EXIST\r
1306         JRST    MAKSTR          ; ALL DONE\r
1307 \r
1308 STRIN2: GETYP   D,(B)           ;GET TYPE CODE\r
1309         CAIN    D,TCHRS         ;SINGLE CHARACTER?\r
1310         AOJA    C,STRIN1\r
1311         CAIE    D,TCHSTR        ;OR STRING\r
1312         JRST    WRONGT          ;NEITHER\r
1313         HRRZ    D,(B)           ; GET CHAR COUNT\r
1314         ADDI    C,(D)           ; AND BUMP\r
1315 \r
1316 STRIN1: ADD     B,[2,,2]\r
1317         SOJG    A,STRIN2\r
1318 \r
1319 ; NOW GET THE NECESSARY VECTOR\r
1320 \r
1321 MAKSTR: PUSH    P,C             ; SAVE CHAR COUNT\r
1322         PUSH    P,E             ; SAVE ARG COUNT\r
1323         MOVEI   A,4(C)          ; LNTH+4 TO A\r
1324         IDIVI   A,5\r
1325         PUSHJ   P,IBLOCK\r
1326 \r
1327         POP     P,A\r
1328         JUMPGE  B,DONEC         ; 0 LENGTH, NO STRING\r
1329         HRLI    B,440700        ;CONVERT B TO A BYTE POINTER\r
1330         MOVE    C,(TP)          ; POINT TO ARGS AGAIN\r
1331 \r
1332 NXTRG1: GETYP   D,(C)           ;GET AN ARG\r
1333         CAIE    D,TCHRS\r
1334         JRST    TRYSTR\r
1335         MOVE    D,1(C)                  ; GET IT\r
1336         IDPB    D,B             ;AND DEPOSIT IT\r
1337         JRST    NXTARG\r
1338 \r
1339 TRYSTR: MOVE    E,1(C)          ;GET BYTER\r
1340         HRRZ    0,(C)           ;AND COUNT\r
1341 NXTCHR: SOJL    0,NXTARG        ; IF RUNOUT, GET NEXT ARG\r
1342         ILDB    D,E             ;AND GET NEXT\r
1343         IDPB    D,B             ; AND DEPOSIT SAME\r
1344         JRST    NXTCHR\r
1345 \r
1346 NXTARG: ADD     C,[2,,2]        ;BUMP ARG POINTER\r
1347         SOJG    A,NXTRG1\r
1348         ADDI    B,1\r
1349 \r
1350 DONEC:  MOVSI   C,TCHRS\r
1351         HLLM    C,(B)           ;AND CLOBBER AWAY\r
1352         HLRZ    C,1(B)          ;GET LENGTH BACK\r
1353         POP     P,A\r
1354         HRLI    A,TCHSTR\r
1355         SUBI    B,-2(C)\r
1356         HRLI    B,440700                ;MAKE A BYTE POINTER\r
1357         POPJ    P,\r
1358 \r
1359 ; COMPILER'S CALL TO MAKE A STRING\r
1360 \r
1361 CISTNG: SUBM    M,(P)\r
1362         MOVEI   C,0             ; INIT CHAR COUNTER\r
1363         MOVEI   B,(A)           ; SET UP STACK POINTER\r
1364         ASH     B,1             ; * 2 FOR NO. OF SLOTS\r
1365         HRLI    B,(B)\r
1366         SUBM    TP,B            ; B POINTS TO ARGS\r
1367         ADD     B,[1,,1]\r
1368         PUSH    TP,$TTP\r
1369         PUSH    TP,B\r
1370         PUSHJ   P,IISTRN        ; MAKE IT HAPPEN\r
1371         POP     TP,TP           ; FLUSH ARGS\r
1372         SUB     TP,[1,,1]\r
1373         JRST    MPOPJ\r
1374 \f;BUILD IMPLICT STRING\r
1375 \r
1376 MFUNCTION ISTRING,SUBR\r
1377 \r
1378         ENTRY\r
1379         JUMPGE  AB,TFA          ; TOO FEW ARGS\r
1380         CAMGE   AB,[-4,,0]      ; VERIFY NOT TOO MANY ARGS\r
1381         JRST    TMA\r
1382         PUSHJ   P,GETFIX\r
1383         ADDI    A,4\r
1384         IDIVI   A,5             ; # OF WORDS NEEDED TO A\r
1385         PUSH    TP,$TFIX\r
1386         PUSH    TP,A\r
1387         MCALL   1,UVECTOR       ; GET SAME\r
1388         HLRE    C,B             ; -LENGTH TO C\r
1389         SUBM    B,C             ; LOCN OF DOPE WORD TO C\r
1390         HRLI    D,TCHRS         ; CLOBBER ITS TYPE\r
1391         HLLM    D,(C)\r
1392         MOVSI   A,TCHSTR\r
1393         HRR     A,1(AB)         ; SETUP TYPE'S RH\r
1394         HRLI    B,440700        ; AND BYTE POINTER\r
1395         SKIPE   (AB)+1          ; SKIP IF NO CHARACTERS TO DEPOSIT\r
1396         CAML    AB,[-2,,0]      ; SKIP IF 2 ARGS GIVEN\r
1397         JRST    FINIS\r
1398         PUSH    TP,A            ;SAVE OUR STRING\r
1399         PUSH    TP,B\r
1400         PUSH    TP,A            ;SAVE A TEMPORARY CLOBBER POINTER\r
1401         PUSH    TP,B\r
1402         PUSH    P,(AB)1         ;SAVE COUNT\r
1403 CLOBST: PUSH    TP,(AB)+2\r
1404         PUSH    TP,(AB)+3\r
1405         MCALL   1,EVAL\r
1406         GETYP   C,A             ; CHECK IT\r
1407         CAIE    C,TCHRS         ; MUST BE A CHARACTER\r
1408         JRST    WTYP2\r
1409         IDPB    B,(TP)          ;CLOBBER\r
1410         SOSLE   (P)             ;FINISHED?\r
1411         JRST    CLOBST          ;NO\r
1412         SUB     P,[1,,1]\r
1413         SUB     TP,[4,,4]\r
1414         MOVE    A,(TP)+1\r
1415         MOVE    B,(TP)+2\r
1416         JRST    FINIS\r
1417 \r
1418 \r
1419 \fAGC":\r
1420 ;SET FLAG FOR INTERRUPT HANDLER\r
1421 \r
1422         SETZB   M,RCL           ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE PNTR\r
1423         PUSH    P,B\r
1424         PUSH    P,A\r
1425         PUSH    P,C             ; SAVE C\r
1426         PUSHJ   P,CTIME         ; GET TIME FOR GIN-GOUT\r
1427         MOVEM   B,GCTIM         ; SAVE FOR LATER\r
1428         MOVEI   B,[ASCIZ /GIN /]\r
1429         SKIPE   GCMONF\r
1430         PUSHJ   P,MSGTYP\r
1431 NOMON1: HRRZ    C,(P)           ; GET CAUSE OF GC INDICATOR\r
1432         MOVE    B,GCNO(C)       ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON\r
1433         ADDI    B,1\r
1434         MOVEM   B,GCNO(C)\r
1435         MOVEM   C,GCCAUS        ; SAVE CAUSE OF GC\r
1436         SKIPN   GCMONF          ; MONITORING\r
1437         JRST    NOMON2\r
1438         MOVE    B,MSGGCT(C)     ; GET CAUSE MESSAGE\r
1439         PUSHJ   P,MSGTYP\r
1440 NOMON2: HLRZ    C,(P)           ; FIND OUT WHO CAUSED THE GC\r
1441         MOVEM   C,GCCALL        ; SAVE CALLER OF GC\r
1442         SKIPN   GCMONF          ; MONITORING\r
1443         JRST    NOMON3\r
1444         MOVE    B,MSGGFT(C)\r
1445         PUSHJ   P,MSGTYP\r
1446 NOMON3: SUB     P,[1,,1]        ; POP OFF C\r
1447         POP     P,A\r
1448         POP     P,B\r
1449         JRST    .+1\r
1450 AAGC:   SETZB   M,RCL           ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION\r
1451 INITGC: SETOM   GCFLG\r
1452 \r
1453 ;SAVE AC'S\r
1454         IRP     AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,PVP]\r
1455         MOVEM   AC,AC!STO"+1(PVP)\r
1456         TERMIN\r
1457 \r
1458 ; FUDGE NOWFRE FOR LATER WINNING\r
1459 \r
1460         MOVE    0,NOWFRE\r
1461         SUB     0,VECBOT\r
1462         ADD     0,PARTOP\r
1463         MOVEM   0,NOWFRE\r
1464 \r
1465 ; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU\r
1466 \r
1467         HRRZ    A,FSAV(TB)      ; GET NAME OF CURRENT GOODIE\r
1468         SETZM   CURPLN          ; CLEAR FOR NONE\r
1469         CAML    A,PURTOP        ; IF LESS THAN TOP OF PURE ASSUME RSUBR\r
1470         JRST    NRSUBR\r
1471         GETYP   0,(A)           ; SEE IF PURE\r
1472         CAIE    0,TPCODE        ; SKIP IF IT IS\r
1473         JRST    NRSUBR\r
1474         HLRZ    B,1(A)          ; GET SLOT INDICATION\r
1475         ADD     B,PURVEC+1(TVP) ; POINT TO SLOT\r
1476         HRROS   2(B)            ; MUNG AGE\r
1477         HLRE    A,1(B)          ; - LENGTH TO A\r
1478         MOVNM   A,CURPLN        ; AND STORE\r
1479 NRSUBR:\r
1480 \r
1481 ;SET UP E TO POINT TO TYPE VECTOR\r
1482         GETYP   E,TYPVEC(TVP)\r
1483         CAIE    E,TVEC\r
1484         JRST    AGCE1\r
1485         HRRZ    TYPNT,TYPVEC+1(TVP)\r
1486         HRLI    TYPNT,B\r
1487 \r
1488 CHPDL:  MOVE    D,P             ; SAVE FOR LATER\r
1489         MOVE    P,GCPDL         ;GET GC'S PDL\r
1490 CORGET: MOVE    A,P.TOP         ; UPDATE CORTOP\r
1491         MOVEM   A,CORTOP\r
1492         MOVE    A,VECTOP        ; ROOM BETWEEN CORTOP AND VECTOP IS GC MARK PDL\r
1493         SUB     A,CORTOP\r
1494         MOVSS   A       ; BUILD A PDL POINTER\r
1495         ADD     A,VECTOP\r
1496         JUMPGE  A,TRYCOR        ; NO ROOM, GO GET SOME\r
1497         MOVE    P,A             ; SET UP PDL POINTER\r
1498 \r
1499 ;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK\r
1500 \r
1501         MOVEI   A,(TB)          ;POINT TO CURRENT FRAME IN PROCESS\r
1502         PUSHJ   P,FRMUNG        ;AND MUNG IT\r
1503         MOVE    A,TP            ;THEN TEMPORARY PDL\r
1504         PUSHJ   P,PDLCHK\r
1505         MOVE    A,PSTO+1(PVP)   ;AND UNMARKED P STACK\r
1506         PUSHJ   P,PDLCHP\r
1507 \r
1508 \f; FIRST CREATE INFERIOR TO HOLD NEW PAGES\r
1509 \r
1510 INFCRT: MOVE    A,PARBOT        ; GENERATE NEW PARBOT AND PARNEW\r
1511         ADD     A,PARNEW\r
1512         ADDI    A,1777\r
1513         ANDCMI  A,1777          ; EVEN PAGE BOUNDARY\r
1514         HRRM    A,BOTNEW        ; INTO POINTER WORD\r
1515         MOVEM   A,WNDBOT\r
1516         MOVEI   0,2000(A)       ; BOUNDS OF WINDOW\r
1517         MOVEM   0,WNDTOP\r
1518         SUB     A,PARBOT\r
1519         MOVEM   A,PARNEW        ; FIXED UP PARNEW\r
1520         HRRZ    A,BOTNEW        ; GET PAGE TO START INF AT\r
1521         ASH     A,-10.          ; TO PAGES\r
1522         PUSHJ   P,%GCJOB        ; GET PAGE HOLDER\r
1523         MOVSI   FPTR,-2000      ; FIX UP FRONTIER POINTER\r
1524 \r
1525 ;MARK PHASE: MARK ALL LISTS AND VECTORS\r
1526 ;POINTED TO WITH ONE BIT IN SIGN BIT\r
1527 ;START AT TRANSFER VECTOR\r
1528 \r
1529         SETZB   LPVP,VECNUM     ;CLEAR NUMBER OF VECTOR WORDS\r
1530         SETZB   PARNUM  ;CLEAR NUMBER OF PAIRS\r
1531         MOVEI   0,NGCS          ; SEE IF NEED HAIR\r
1532         SOSGE   GCHAIR\r
1533         MOVEM   0,GCHAIR        ; RESUME COUNTING\r
1534         SETZM   GREW            ; ASSUME NO GROW/SHRINK\r
1535         SETZM   SHRUNK\r
1536         MOVSI   D,400000        ;SIGN BIT FOR MARKING\r
1537         MOVE    A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW\r
1538         PUSHJ   P,PRMRK         ; PRE-MARK\r
1539         MOVE    A,GLOBSP+1(TVP)\r
1540         PUSHJ   P,PRMRK\r
1541 \r
1542 ; HAIR TO DO AUTO CHANNEL CLOSE\r
1543 \r
1544         MOVEI   0,N.CHNS-1      ; NUMBER OF CHANNELS\r
1545         MOVEI   A,CHNL1(TVP)    ; 1ST SLOT\r
1546 \r
1547         SKIPE   1(A)            ; NOW A CHANNEL?\r
1548         SETZM   (A)             ; DON'T MARK AS CHANNELS\r
1549         ADDI    A,2\r
1550         SOJG    0,.-3\r
1551 \r
1552         MOVE    A,PVP           ;START AT PROCESS VECTOR\r
1553         MOVEI   B,TPVP          ;IT IS A PROCESS VECTOR\r
1554         PUSHJ   P,MARK          ;AND MARK THIS VECTOR\r
1555         MOVEI   B,TPVP\r
1556         MOVE    A,MAINPR        ; MARK MAIN PROCES EVEN IF SWAPPED OUT\r
1557         PUSHJ   P,MARK\r
1558 \r
1559 ; ASSOCIATION AND VALUE FLUSHING PHASE\r
1560 \r
1561         SKIPN   GCHAIR          ; ONLY IF HAIR\r
1562         PUSHJ   P,VALFLS\r
1563 \r
1564         SKIPE   GCHAIR          ; IF NOT HAIR, DO CHANNELS NOW\r
1565         PUSHJ   P,CHNFLS\r
1566 \r
1567 ;OPTIONAL RETIMING PHASE\r
1568 ;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER\r
1569         REPEAT 0,[\r
1570         SKIPE   A,TIMOUT        ;ANY TIME OVERFLOWS\r
1571         PUSHJ   P,RETIME        ;YES, RE-CALIBRATE THEM\r
1572 ]\r
1573 ;UPDATE PARTOP\r
1574 \r
1575         MOVEI   A,@BOTNEW\r
1576         SUB     A,PARNEW\r
1577         MOVEM   A,PARTOP\r
1578 \r
1579 ;CORE ADJUSTMENT PHASE\r
1580         MOVE    P,GCPDL ; GET A PDL\r
1581         SETZM   CORSET          ;CLEAR LATER CORE SETTING\r
1582         PUSHJ   P,CORADJ        ;AND MAKE CORE ADJUSTMENTS\r
1583 \r
1584 ;RELOCATION ESTABLISHMENT PHASE\r
1585 ;1 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE\r
1586         MOVE    A,VECTOP"       ;START AT TOP OF VECTOR SPACE\r
1587         MOVE    B,VECNEW"       ;AND SET TO INITIAL OFFSET\r
1588         SUBI    A,1             ;POINT TO DOPE WORDS\r
1589         ADDI    B,(A)           ; WHERE TOP VECTOR WILL GO\r
1590         PUSHJ   P,VECREL        ;AND ESTABLISH RELOCATION FOR VECTORS\r
1591         SUBI    B,(A)           ; RE-RELATIVIZE VECNEW\r
1592         MOVEM   B,VECNEW        ;SAVE FINAL OFFSET\r
1593 \r
1594 \r
1595 \f; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE\r
1596 \r
1597         MOVE    B,PARTOP        ; POINT TO TOP OF PAIRS\r
1598         ADDI    B,2000\r
1599         ANDCMI  B,1777\r
1600         CAMGE   B,VECBOT        ; OVERLAP VECTORS\r
1601         JRST    DOMAP\r
1602         MOVE    C,VECBOT\r
1603         ANDI    C,1777          ; REL TO PAGE\r
1604         ADDI    C,FRONT         ; 1ST DEST WORD\r
1605         HRL     C,VECBOT\r
1606         BLT     C,FRONT+1777    ; MUNG IT\r
1607 \r
1608 DOMAP:  ASH     B,-10.          ; TO PAGES\r
1609         MOVE    A,PARBOT\r
1610         MOVEI   C,(A)           ; COMPUTE HIS TOP\r
1611         ADD     C,PARNEW\r
1612         ASH     C,-10.\r
1613         ASH     A,-10.\r
1614         SUBM    A,B             ; B==> - # OF PAGES\r
1615         HRLI    A,(B)           ; AOBJN TO SOURCE AND DEST\r
1616         MOVE    B,A             ; IN CASE OF FUNNY\r
1617         HRRI    B,(C)           ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES\r
1618         PUSHJ   P,%INFMP        ; NOW FLUSH INF AND MAKE HIS CORE MINE\r
1619 \r
1620 \f;POINTER UPDATE PHASE\r
1621 ;1 -- UPDATE ALL PAIR POINTERS\r
1622         MOVE    A,PARBOT        ;START AT BOTTOM OF PAIR SPACE\r
1623         PUSHJ   P,PARUPD        ;AND UPDATE ALL PAIR POINTERS\r
1624 \r
1625 ;2 -- UPDATE ALL VECTORS\r
1626         MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE\r
1627         PUSHJ   P,VECUPD        ;AND UPDATE THE POINTERS\r
1628         MOVE    A,CODTOP        ; NOW UPDATE STORAGE STUFF\r
1629         MOVEI   D,0             ; FAKE OUT TO NOT UNMARK\r
1630         PUSHJ   P,STOUP\r
1631         MOVSI   D,400000\r
1632 \r
1633 ;3 -- UPDATE THE PVP AC\r
1634         MOVEI   A,PVP-1         ;SET LOC TO POINT TO PVP\r
1635         MOVE    C,PVP           ;GET THE DATUM\r
1636         PUSHJ   P,NWRDUP        ;AND UPDATE THIS VALUE\r
1637 ;4 -- UPDATE THE MAIN PROCESS POINTER\r
1638         MOVEI   A,MAINPR-1      ;POINT TO MAIN PROCESS POINTER\r
1639         MOVE    C,MAINPR        ;GET CONTENTS IN C\r
1640         PUSHJ   P,NWRDUP        ;AND UPDATE IT\r
1641 ;DATA MOVEMMENT ANDCLEANUP PHASE\r
1642 \r
1643 ;1 -- ADJUST FOR SHRINKING VECTORS\r
1644         MOVE    A,VECTOP        ;VECTOR SHRINKING PHASE\r
1645         SKIPE   SHRUNK          ; SKIP IF NO SHRINKERS\r
1646         PUSHJ   P,VECSH         ;GO SHRINK ANY SHRINKERS\r
1647 \r
1648 ;2 -- MOVE VECTORS (AND LIST ELEMENTS)\r
1649         MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE\r
1650         PUSHJ   P,VECMOVE       ;AND MOVE THE VECTORS\r
1651         MOVE    A,VECNEW        ;GET FINAL CHANGE TO VECBOT\r
1652         ADDM    A,VECBOT        ;OFFSET VECBOT TO ITS NEW PLACE\r
1653         MOVE    A,CORTOP        ;GET NEW VALUE FOR TOP OF VECTOR SPACE\r
1654         SUBI    A,2000          ; FUDGE FOR MARK PDL\r
1655         MOVEM   A,VECTOP        ;AND UPDATE VECTOP\r
1656 \r
1657 ;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP)\r
1658 \r
1659         SKIPE   GREW            ; SKIP IF NO GROWERS\r
1660         PUSHJ   P,VECZER        ;\r
1661         PUSHJ   P,STOGC\r
1662 \r
1663 ;GARBAGE ZEROING PHASE\r
1664 GARZER: MOVE    A,PARTOP        ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE\r
1665         HRLS    A               ;GET FIRST ADDRESS IN LEFT HALF\r
1666         MOVE    B,VECBOT        ;LAST ADDRESS OF GARBAGE + 1\r
1667         CLEARM  (A)             ;ZERO   THE FIRST WORD\r
1668         ADDI    A,1             ;MAKE A A BLT POINTER\r
1669         BLT     A,-1(B)         ;AND COPY ZEROES INTO REST OF AREA\r
1670 \r
1671 ;FINAL CORE ADJUSTMENT\r
1672         SKIPE   A,CORSET        ;IFLESS CORE NEEDED\r
1673         PUSHJ   P,CORADL        ;GIVE SOME AWAY.\r
1674 \r
1675 ;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES\r
1676 \r
1677         PUSHJ   P,REHASH\r
1678 \r
1679 \f;RESTORE AC'S\r
1680 TRYCOX: MOVE    0,VECBOT\r
1681         SUB     0,PARTOP\r
1682         ADDM    0,NOWFRE\r
1683         SKIPN   GCMONF\r
1684         JRST    NOMONO\r
1685         MOVEI   B,[ASCIZ /GOUT /]\r
1686         PUSHJ   P,MSGTYP\r
1687 NOMONO: IRP     AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,PVP,TVP]\r
1688         MOVE    AC,AC!STO+1(PVP)\r
1689         TERMIN\r
1690 ; CLOSING ROUTINE FOR G-C\r
1691         PUSH    P,A             ; SAVE AC'C\r
1692         PUSH    P,B\r
1693         PUSH    P,C\r
1694         PUSH    P,D\r
1695         PUSHJ   P,CTIME\r
1696         PUSHJ   P,FIXSEN        ; OUTPUT TIME\r
1697         SKIPN   GCMONF\r
1698         JRST    GCCONT\r
1699         MOVEI   A,15            ; OUTPUT C/R LINE-FEED\r
1700         PUSHJ   P,MTYO\r
1701         MOVEI   A,12\r
1702         PUSHJ   P,MTYO\r
1703 GCCONT: POP     P,D             ; RESTORE AC'C\r
1704         POP     P,C\r
1705         POP     P,B\r
1706         POP     P,A\r
1707         MOVE    A,GCDANG        ; ERROR LEVELS TO ACS\r
1708         ADD     A,GCDNTG\r
1709         SETZM   GCDANG          ; NOW CLEAR SAME\r
1710         SETZM   GCDNTG\r
1711         JUMPGE  A,AGCWIN\r
1712         SKIPN   GCHAIR          ; WAS IT A FLUSHER?\r
1713         JRST    AGCWIN          ; YES, NO MORE AVAILABLE\r
1714         MOVEI   A,1\r
1715         MOVEM   A,GCHAIR        ; RE-DO WITH HAIR\r
1716         MOVE    A,SPARNW        ; RESET PARNEW\r
1717         MOVEM   A,PARNEW\r
1718         SETZM   SPARNW\r
1719         MOVE    C,[11,10.]      ; INDICATOR FOR AGC\r
1720         JRST    AGC             ; TRY ONCE MORE\r
1721 \r
1722 AGCWIN: SETZM   PARNEW          ;CLEAR FOR NEXT AGC CALL\r
1723         SETZM   GETNUM          ;ALSO CLEAR THIS\r
1724         SETZM   GCFLG\r
1725 \r
1726         JUMPGE  P,RBLDM         ; DONT LOSE ON BLOWN PDLS\r
1727         JUMPGE  TP,RBLDM\r
1728         CAMGE   A,[-1]          ; SKIP IF GOOD NEWS\r
1729         JRST    RBLDM\r
1730         SETZM   PGROW           ; CLEAR GROWTH\r
1731         SETZM   TPGROW\r
1732         SETOM   GCHAPN          ; INDICATE A GC HAS HAPPENED\r
1733         SETOM   INTFLG          ; AND REQUEST AN INTERRUPT\r
1734         SETZM   GCDOWN\r
1735 \r
1736 RBLDM:  JUMPGE  R,CPOPJ\r
1737         SKIPGE  M,1(R)          ; SKIP IF FUNNY\r
1738         POPJ    P,\r
1739 \r
1740         HLRS    M\r
1741         ADD     M,PURVEC+1(TVP)\r
1742         SKIPL   M,1(M)\r
1743         POPJ    P,\r
1744         PUSH    P,0\r
1745         HRRZ    0,1(R)\r
1746         ADD     M,0\r
1747         POP     P,0\r
1748 CPOPJ:  POPJ    P,\r
1749 \r
1750 \r
1751 AGCE1:  FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR\r
1752 \r
1753 \f; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL\r
1754 ; POINT.\r
1755 \r
1756 FIXSEN: PUSH    P,B             ; SAVE TIME\r
1757         MOVEI   B,[ASCIZ /TIME= /]\r
1758         SKIPE   GCMONF\r
1759         PUSHJ   P,MSGTYP        ; PRINT OUT MESSAGE\r
1760         POP     P,B             ; RESTORE B\r
1761         FSBR    B,GCTIM         ; GET TIME ELAPSED\r
1762         MOVEM   B,GCTIM         ; SAVE ELAPSED TIME FOR INT-HANDLER\r
1763         SKIPN   GCMONF\r
1764         POPJ    P,\r
1765         FMPRI   B,(100.0)       ; CONVERT TO FIX\r
1766         MULI    B,400\r
1767         TSC     B,B\r
1768         ASH     C,-163.(B)\r
1769         MOVEI   A,1             ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME\r
1770         PUSH    P,C\r
1771         IDIVI   C,10.           ; START COUNTING\r
1772         JUMPLE  C,.+2\r
1773         AOJA    A,.-2\r
1774         POP     P,C\r
1775         CAIN    A,1             ; SEE IF THERE IS ONLY ONE CHARACTER\r
1776         JRST    DOT1\r
1777 FIXOUT: IDIVI   C,10.           ; RECOVER NUMBER\r
1778         HRLM    D,(P)\r
1779         SKIPE   C\r
1780         PUSHJ   P,FIXOUT\r
1781         PUSH    P,A             ; SAVE A\r
1782         CAIN    A,2             ; DECIMAL POINT HERE?\r
1783         JRST    DOT2\r
1784 FIX1:   HLRZ    A,(P)-1         ; GET NUMBER\r
1785         ADDI    A,60            ; MAKE IT A CHARACTER\r
1786         PUSHJ   P,MTYO          ; OUT IT GOES\r
1787         POP     P,A\r
1788         SOJ     A,\r
1789         POPJ    P,\r
1790 DOT1:   MOVEI   A,".            ; OUTPUT DECIMAL POINT AND PADDING 0\r
1791         PUSHJ   P,MTYO\r
1792         MOVEI   A,"0\r
1793         PUSHJ   P,MTYO\r
1794         JRST    FIXOUT          ; CONTINUE\r
1795 DOT2:   MOVEI   A,".            ; OUTPUT DECIMAL POINT\r
1796         PUSHJ   P,MTYO\r
1797         JRST    FIX1\r
1798 \r
1799 \f; INITIAL CORE ADJUSTMENT TO OBTAIN SPACE\r
1800 ; FOR MARK PHASE PDL\r
1801 \r
1802 TRYCOR: MOVEI   A,2000\r
1803         ADDB    A,CORTOP        ; TRY AND GET 1 BLOCK\r
1804         ASH     A,-10.\r
1805         MOVEI   E,(A)           ; SAVE FOR LOOPER\r
1806         PUSHJ   P,P.CORE        ; GET CORE\r
1807         JRST    TRYCO2          ; FAILED, TAKE MORE ACTION\r
1808         JRST    CORGET\r
1809 \r
1810 TRYCO2: MOVNI   A,2000          ; FIXUP CORTOP\r
1811         ADDM    A,CORTOP\r
1812 TRYCO3: MOVE    0,TPGROW\r
1813         ADD     0,PGROW         ; 0/ NEQ 0 IF STACK BLEW\r
1814         SKIPGE  TP              ; SKIP IF TP BLOWN\r
1815         SKIPL   PSTO+1(PVP)     ; SKIP IF P WINS\r
1816         MOVEI   0,1\r
1817         SKIPN   0\r
1818         MOVEI   B,[ASCIZ /\r
1819 CORE NEEDED:\r
1820         TYPE C TO KEEP TRYING\r
1821         TYPE N TO GET MUDDLE ERROR\r
1822         TYPE V TO RETURN TO MONITOR\r
1823 /]\r
1824         SKIPE   0\r
1825         MOVEI   B,[ASCIZ /\r
1826 CORE NEEDED:\r
1827         TYPE C TO KEEP TRYING\r
1828         TYPE V TO RETURN TO MONITOR\r
1829 /]\r
1830         PUSH    P,0\r
1831         PUSHJ   P,MSGTYP\r
1832         SETOM   GCFLCH          ; TELL INTERRUPT HANDLER TO .ITYIC\r
1833         PUSHJ   P,MTYI\r
1834         PUSHJ   P,UPLO          ; IN CASE LOWER CASE TYPED\r
1835         SETZM   GCFLCH\r
1836         POP     P,0\r
1837         CAIN    A,"C\r
1838         JRST    TRYCO4\r
1839         CAIN    A,"N\r
1840         JUMPE   0,TRYCO5\r
1841         CAIN    A,"V\r
1842         FATAL CORE LOSSAGE\r
1843         JRST    TRYCO3\r
1844 \r
1845 UPLO:   CAIL    A,"a\r
1846         CAILE   A,"z\r
1847         POPJ    P,\r
1848         SUBI    A,40\r
1849         POPJ    P,\r
1850 \r
1851 TRYCO4: MOVEI   A,(E)\r
1852 TRYCO9: MOVEI   B,1             ; SLEEP AND CORE UNTIL WINNAGE\r
1853         EXCH    A,B\r
1854         PUSHJ   P,%SLEEP        ; SLEEP A WHILE\r
1855         EXCH    A,B\r
1856         PUSHJ   P,P.CORE\r
1857         JRST    TRYCO9\r
1858 \r
1859         MOVEI   B,[ASCIZ /\r
1860 WIN!\r
1861 /]\r
1862         PUSHJ   P,MSGTYP\r
1863         JRST    CORGET\r
1864 \r
1865 TRYCO5: MOVNI   A,3             ; GIVE WORST ERROR RETURN\r
1866         MOVEM   A,GCDANG\r
1867         JRST    TRYCOX\r
1868 \r
1869 \r
1870 \f; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING\r
1871 \r
1872 PDLCHK: JUMPGE  A,CPOPJ\r
1873         HLRE    B,A             ;GET NEGATIVE COUNT\r
1874         MOVE    C,A             ;SAVE A COPY OF PDL POINTER\r
1875         SUBI    A,-1(B)         ;LOCATE DOPE WORD PAIR\r
1876         HRRZS   A               ; ISOLATE POINTER\r
1877         CAME    A,TPGROW        ;GROWING?\r
1878         ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD\r
1879         HLRZ    D,(A)           ;GET COUNT FROM DOPE WORD\r
1880         MOVNS   B               ;GET POSITIVE AMOUNT LEFT\r
1881         SUBI    D,2(B)          ; PDL FULL?\r
1882         JUMPE   D,NOFENC        ;YES NO FENCE POSTING\r
1883         SETOM   1(C)            ;CLOBBER TOP WORD\r
1884         SOJE    D,NOFENC        ;STILL MORE?\r
1885         MOVSI   D,1(C)          ;YES, SET UP TO BLT FENCE POSTS\r
1886         HRRI    D,2(C)\r
1887         BLT     D,-2(A)         ;FENCE POST ALL EXCEPT DOPE WORDS\r
1888 \r
1889 \r
1890 NOFENC: CAIG    B,TPMAX         ;NOW CHECK SIZE\r
1891         CAIG    B,TPMIN\r
1892         JRST    MUNGTP          ;TOO BIG OR TOO SMALL\r
1893         POPJ    P,\r
1894 \r
1895 MUNGTP: SUBI    B,TPGOOD        ;FIND DELTA TP\r
1896 MUNG3:  MOVE    C,-1(A)         ;IS GROWTH ALREADY SPECIFIED\r
1897         TRNE    C,777000        ;SKIP IF NOT\r
1898         POPJ    P,              ;ASSUME GROWTH GIVEN WILL WIN\r
1899 \r
1900         ASH     B,-6            ;CONVERT TO NUMBER OF BLOCKS\r
1901         JUMPLE  B,MUNGT1\r
1902         CAILE   B,377           ; SKIP IF BELOW MAX\r
1903         MOVEI   B,377           ; ELSE USE MAX\r
1904         TRO     B,400           ;TURN ON SHRINK BIT\r
1905         JRST    MUNGT2\r
1906 MUNGT1: MOVMS   B\r
1907         ANDI    B,377\r
1908 MUNGT2: DPB     B,[111100,,-1(A)]       ;STORE IN DOPE WORD\r
1909         POPJ    P,\r
1910 \r
1911 ; CHECK UNMARKED STACK (NO NEED TO FENCE POST)\r
1912 \r
1913 PDLCHP: HLRE    B,A             ;-LENGTH TO B\r
1914         MOVE    C,A\r
1915         SUBI    A,-1(B)         ;POINT TO DOPE WORD\r
1916         HRRZS   A               ;ISOLATE POINTER\r
1917         CAME    A,PGROW         ;GROWING?\r
1918         ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD\r
1919         MOVMS   B               ;PLUS LENGTH\r
1920         HLRZ    D,(A)           ; D.W. LENGTH\r
1921         SUBI    D,2(B)          ; PDL FULL\r
1922         JUMPE   D,NOPF\r
1923         SETOM   1(C)            ; START FENECE POST\r
1924         SOJE    D,NOPF          ; 1 WORD?\r
1925         MOVSI   D,1(C)\r
1926         HRRI    D,2(C)\r
1927         BLT     D,-2(A)\r
1928 \r
1929 NOPF:   CAIG    B,PMAX          ;TOO BIG?\r
1930         CAIG    B,PMIN          ;OR TOO LITTLE\r
1931         JRST    .+2             ;YES, MUNG IT\r
1932         POPJ    P,\r
1933         SUBI    B,PGOOD\r
1934         JRST    MUNG3\r
1935 \r
1936 ;THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE\r
1937 FRMUNG: MOVEM   D,PSAV(A)\r
1938         MOVEM   SP,SPSAV(A)\r
1939         MOVEM   TP,TPSAV(A)     ;SAVE FOR MARKING\r
1940         POPJ    P,\r
1941 \r
1942 ; ROUTINE TO PRE MARK SPECIAL HACKS\r
1943 \r
1944 PRMRK:  SKIPE   GCHAIR          ; FLUSH IF NO HAIR\r
1945         POPJ    P,\r
1946         HLRE    B,A\r
1947         SUBI    A,(B)           ;POINT TO DOPE WORD\r
1948         HLRZ    B,1(A)          ; GET LNTH\r
1949         ADDM    B,VECNUM        ; AND UPDATE VECNUM\r
1950         LDB     B,[111100,,(A)] ; GET GROWTHS\r
1951         TRZE    B,400           ; SIGN HACK\r
1952         MOVNS   B\r
1953         ASH     B,6             ; TO WORDS\r
1954         ADDM    B,VECNUM\r
1955         LDB     0,[001100,,(A)]\r
1956         TRZE    0,400\r
1957         MOVNS   0\r
1958         ASH     0,6\r
1959         ADDM    0,VECNUM\r
1960         PUSHJ   P,GSHFLG                ; SET GROW FLAGS\r
1961         IORM    D,1(A)          ;AND MARK\r
1962         POPJ    P,\r
1963 \r
1964 ; SET UP FLAGS FOR OPTIOANAL GROW/SHRINK PHASES\r
1965 \r
1966 GSHFLG: SKIPG   B\r
1967         SKIPLE  0\r
1968         SETOM   GREW\r
1969         SKIPL   B\r
1970         SKIPGE  0\r
1971         SETOM   SHRUNK\r
1972         POPJ    P,\r
1973 \r
1974 \f;GENERAL MARK SUBROUTINE.  CALLED TO MARK ALL THINGS\r
1975 ; A/ GOODIE TO MARK FROM\r
1976 ; B/ TYPE OF A (IN RH)\r
1977 ; C/ TYPE,DATUM PAIR POINTER\r
1978 \r
1979 MARK2:  HLRZ    B,(C)           ;GET TYPE\r
1980 MARK1:  MOVE    A,1(C)          ;GET GOODIE\r
1981 MARK:   JUMPE   A,CPOPJ         ; NEVER MARK 0\r
1982         MOVEI   0,(A)\r
1983         CAIL    0,@PURBOT       ; DONT MARK PURE STUFF\r
1984         POPJ    P,\r
1985         PUSH    P,A             ;SAVE GOODIE\r
1986         HRLM    C,-1(P)         ;AND POINTER TO IT\r
1987         ANDI    B,TYPMSK        ; FLUSH MONITORS\r
1988         LSH     B,1             ;TIMES 2 TO GET SAT\r
1989         HRRZ    B,@TYPNT        ;GET SAT\r
1990         ANDI    B,SATMSK\r
1991         CAIG    B,NUMSAT        ; SKIP IF TEMPLATE DATA\r
1992         JRST    @MKTBS(B)       ;AND GO MARK\r
1993         JRST    TD.MRK\r
1994 \r
1995 ; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)\r
1996 \r
1997 DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK]\r
1998 [STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]\r
1999 [SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]\r
2000 [SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK]\r
2001 [SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]]\r
2002 \r
2003 \r
2004 ;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER\r
2005 \r
2006 DEFMK:  TLOA    TYPNT,400000    ;USE SIGN BIT AS FLAG\r
2007 \r
2008 ;HERE TO MARK LIST ELEMENTS\r
2009 \r
2010 PAIRMK: TLZ     TYPNT,400000    ;TURN OF DEFER BIT\r
2011         PUSH    P,[0]           ; WILL HOLD BACK PNTR\r
2012         MOVEI   C,(A)           ;POINT TO LIST\r
2013 PAIRM1: CAMGE   C,PARTOP        ;CHECK FOR BEING IN BOUNDS\r
2014         CAMGE   C,PARBOT\r
2015         FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE\r
2016         SKIPGE  B,(C)           ;SKIP IF NOT MARKED\r
2017         JRST    RETNEW          ;ALREADY MARKED, RETURN\r
2018         IORM    D,(C)           ;MARK IT\r
2019         AOS     PARNUM\r
2020         MOVEM   B,FRONT(FPTR)   ; STORE 1ST WORD\r
2021         MOVE    0,1(C)          ; AND 2D\r
2022         MOVEM   0,FRONT+1(FPTR)\r
2023         ADD     FPTR,[2,,2]             ; MOVE ALONG IN FRONTIER\r
2024         JUMPL   FPTR,PAIRM2     ; NOD NEED FOR NEW CORE\r
2025 \r
2026 ; HERE TO EXTEND THE FRONTIER\r
2027 \r
2028         HRRZ    A,BOTNEW        ; CURRENT BOTTOM OF WINDOW IN INF\r
2029         ADDI    A,2000          ; MOVE IT UP\r
2030         HRRM    A,BOTNEW\r
2031         ASH     A,-10.          ; TO PAGES\r
2032 SYSLO1: PUSHJ   P,%GETIP        ; GET PAGE\r
2033         PUSHJ   P,%SHFNT        ; AND SHARE IT\r
2034         MOVSI   FPTR,-2000\r
2035 \r
2036 PAIRM2: MOVEI   A,@BOTNEW       ; GET INF ADDR\r
2037         SUBI    A,2\r
2038         HRRM    A,(C)           ; LEAVE A POINTER TO NEW HOME\r
2039         HRRZ    E,(P)           ; GET BACK POINTER\r
2040         JUMPE   E,PAIRM7        ; 1ST ONE, NEW FIXUP\r
2041         MOVSI   0,(HRRM)        ; INS FOR CLOBBER\r
2042         PUSHJ   P,SMINF         ; SMASH INF'S CORE IMAGE\r
2043 PAIRM4: MOVEM   A,(P)           ; NEW BACK POINTER\r
2044         JUMPL   TYPNT,DEFDO     ;GO HANDLE DEFERRED POINTER\r
2045         HRLM    B,(P)           ; SAVE OLD CDR\r
2046         PUSHJ   P,MARK2         ;MARK THIS DATUM\r
2047         HRRZ    E,(P)           ; SMASH CAR IN CASE CHANGED\r
2048         ADDI    E,1\r
2049         MOVSI   0,(MOVEM)\r
2050         PUSHJ   P,SMINF\r
2051         HLRZ    C,(P)           ;GET CDR OF LIST\r
2052         CAIGE   C,@PURBOT       ; SKIP IF PURE (I.E. DONT MARK)\r
2053         JUMPN   C,PAIRM1        ;IF NOT NIL, MARK IT\r
2054 GCRETP: SUB     P,[1,,1]\r
2055 \r
2056 GCRET:  TLZ     TYPNT,400000    ;FOR PAIRMKS BENEFIT\r
2057         HLRZ    C,-1(P)         ;RESTORE C\r
2058         POP     P,A\r
2059         POPJ    P,              ;AND RETURN TO CALLER\r
2060 \r
2061 ;HERE TO MARK DEFERRED POINTER\r
2062 \r
2063 DEFDO:  PUSH    P,B             ; PUSH OLD PAIR ON STACK\r
2064         PUSH    P,1(C)\r
2065         MOVEI   C,-1(P)         ; USE AS NEW DATUM\r
2066         PUSHJ   P,MARK2         ;MARK THE DATUM\r
2067         HRRZ    E,-2(P)         ; GET POINTER IN INF CORE\r
2068         ADDI    E,1\r
2069         MOVSI   0,(MOVEM)\r
2070         PUSHJ   P,SMINF         ; AND CLOBBER\r
2071         SUB     P,[3,,3]\r
2072         JRST    GCRET           ;AND RETURN\r
2073 \r
2074 \r
2075 PAIRM7: MOVEM   A,-1(P)         ; SAVE NEW VAL FOR RETURN\r
2076         JRST    PAIRM4\r
2077 \r
2078 RETNEW: HRRZ    A,(C)           ; POINT TO NEW WORLD LOCN\r
2079         HRRZ    E,(P)           ; BACK POINTER\r
2080         JUMPE   E,RETNW1        ; NONE\r
2081         MOVSI   0,(HRRM)\r
2082         PUSHJ   P,SMINF\r
2083         JRST    GCRETP\r
2084 \r
2085 RETNW1: MOVEM   A,-1(P)\r
2086         JRST    GCRETP\r
2087 \r
2088 ; ROUTINE TO SMASH INFERIORS PPAGES\r
2089 ; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE\r
2090 \r
2091 SMINF:  CAML    E,WNDBOT        ; SEE IF IN WINDOW\r
2092         CAML    E,WNDTOP\r
2093         JRST    SMINF1          ; NO TRY FRONTIER\r
2094 SMINF3: SUB     E,WNDBOT        ; FIX UP\r
2095         IOR     0,[0 A,WIND(E)] ; FIX INS\r
2096         XCT     0\r
2097         POPJ    P,\r
2098 \r
2099 SMINF1: PUSH    P,0\r
2100         HRRZ    0,BOTNEW        ; GET FRONTIER RANGE\r
2101         CAML    E,0             ; SKIP IF BELOW\r
2102         CAIL    E,@BOTNEW\r
2103         JRST    SMINF2\r
2104         SUB     E,0             ; FIXUP E\r
2105         POP     P,0\r
2106         IOR     0,[0 A,FRONT(E)]\r
2107         XCT     0\r
2108         POPJ    P,\r
2109 \r
2110 SMINF2: PUSH    P,A\r
2111         MOVE    A,E\r
2112         ASH     A,-10.          ; TO PAGES\r
2113         PUSHJ   P,%SHWND\r
2114         ASH     A,10.           ; BACK TO WORDS\r
2115         MOVEM   A,WNDBOT\r
2116         ADDI    A,2000\r
2117         MOVEM   A,WNDTOP\r
2118         POP     P,A\r
2119         POP     P,0             ; RESTORE INS OF INTEREST\r
2120         JRST    SMINF3\r
2121         \r
2122 \r
2123 \f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE\r
2124 \r
2125 TPMK:   TLOA    TYPNT,400000    ;SET TP MARK FLAG\r
2126 VECTMK: TLZ     TYPNT,400000\r
2127         MOVEI   E,(A)           ;SAVE A POINTER TO THE VECTOR\r
2128         HLRE    B,A             ;GET -LNTH\r
2129         SUB     A,B             ;LOCATE DOPE WORD\r
2130         MOVEI   A,1(A)          ;ZERO LH AND POINT TO 2ND DOPE WORD\r
2131         PUSHJ   P,VECBND        ; CHECK IN VECTOR SPACE\r
2132         JRST    VECTB1          ;LOSE, COMPLAIN\r
2133 \r
2134         JUMPGE  TYPNT,NOBUFR    ;IF A VECTOR, NO BUFFER CHECK\r
2135         CAME    A,PGROW         ;IS THIS THE BLOWN P\r
2136         CAMN    A,TPGROW        ;IS THIS THE GROWING PDL\r
2137         JRST    NOBUFR          ;YES, DONT ADD BUFFER\r
2138         ADDI    A,PDLBUF        ;POINT TO REAL DOPE WORD\r
2139         MOVSI   0,-PDLBUF       ;ALSO FIX UP POINTER\r
2140         ADDB    0,1(C)\r
2141         MOVEM   0,(P)           ; FIXUP RET'D PNTR\r
2142 \r
2143 NOBUFR: HLRE    B,(A)           ;GET LENGTH FROM DOPE WORD\r
2144         JUMPL   B,GCRET         ; MARKED, LEAVE\r
2145         ANDI    B,377777        ;CLOBBER POSSIBLE MARK BIT\r
2146         MOVEI   F,(A)           ;SAVE A POINTER TO DOPE WORD\r
2147         SUBI    F,1(B)          ;F POINTS TO START OF VECTOR\r
2148         HRRZ    0,-1(A)         ;SEE IF GROWTH SPECIFIED\r
2149         MOVEI   B,0             ; SET GROWTH 0\r
2150         JUMPE   0,NOCHNG        ;NONE, JUST CHECK CURRENT SIZES\r
2151 \r
2152         LDB     B,[001100,,0]   ;GET GROWTH FACTOR\r
2153         TRZE    B,400           ;KILL SIGN BIT AND SKIP IF +\r
2154         MOVNS   B               ;NEGATE\r
2155         ASH     B,6             ;CONVERT TO NUMBER OF WORDS\r
2156         SUB     F,B             ;BOTTOM IS LOWER IN CORE\r
2157         LDB     0,[111100,,0]   ;GET TOP GROWTH\r
2158         TRZE    0,400           ;HACK SIGN BIT\r
2159         MOVNS   0\r
2160         ASH     0,6             ;CONVERT TO WORDS\r
2161         PUSHJ   P,GSHFLG        ; HACK FLAGS FOR GROW/SHRINK\r
2162         ADD     B,0             ;TOTAL GROWTH TO B\r
2163 NOCHNG:\r
2164 VECOK:  HLRE    E,(A)           ;GET LENGTH AND MARKING\r
2165         MOVEI   F,(E)           ;SAVE A COPY\r
2166         ADD     F,B             ;ADD GROWTH\r
2167         SUBI    E,2             ;- DOPE WORD LENGTH\r
2168         IORM    D,(A)           ;MAKE SURE NOW MARKED\r
2169         CAML    A,VECBOT        ; ONLY IF REALLY IN VEC SPACE\r
2170         ADDM    F,VECNUM        ; ADD LENGTH OF VECTOR\r
2171         JUMPLE  E,GCRET         ;ALREADY MARKED OR ZERO LENGTH, LEAVE\r
2172 \r
2173         SKIPGE  B,-1(A)         ;SKIP IF UNIFORM\r
2174         TLNE    B,377777        ;SKIP IF NOT SPECIAL\r
2175         JUMPGE  TYPNT,NOTGEN    ;JUMP IF NOT A GENERAL VECTOR\r
2176 \r
2177 GENRAL: HLRZ    0,B             ;CHECK FOR PSTACK\r
2178         JUMPE   0,NOTGEN        ;IT ISN'T GENERAL\r
2179         SUBI    A,1(E)          ;POINT TO FIRST ELEMENT\r
2180         MOVEI   C,(A)           ;POINT TO FIRST ELEMENT WITH C\r
2181 \r
2182 \f; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR\r
2183         PUSH    P,[0]\r
2184 VECTM2: HLRE    B,(C)           ;GET TYPE AND MARKING\r
2185         JUMPL   B,GCRET1                ;RETURN, (EITHER DOPE WORD OR FENCE POST)\r
2186         MOVE    A,1(C)          ;DATUM TO A\r
2187         ANDI    B,TYPMSK        ; FLUSH MONITORS\r
2188         CAIE    B,TCBLK         ;IS THIS A SAVED FRAME?\r
2189         CAIN    B,TENTRY        ;IS THIS A STACK FRAME\r
2190         JRST    MFRAME          ;YES, MARK IT\r
2191         CAIE    B,TUBIND                ; BIND\r
2192         CAIN    B,TBIND         ;OR A BINDING BLOCK\r
2193         JRST    MBIND\r
2194 \r
2195 VECTM3: PUSHJ   P,MARK          ;MARK DATUM\r
2196         MOVEM   A,1(C)          ; IN CASE WAS FIXED\r
2197 VECTM4: ADDI    C,2\r
2198         JRST    VECTM2\r
2199 \r
2200 MFRAME: HRROI   C,FRAMLN+FSAV-1(C)      ;POINT TO FUNCTION\r
2201         HRRZ    A,1(C)          ; GET IT\r
2202         PUSHJ   P,VECBND        ; CHECK IN VECTOR SPACE\r
2203         JRST    MFRAM1          ; IGNORE, NOT IN VECTOR SPACE\r
2204         HRL     A,(A)           ; GET LENGTH\r
2205         MOVEI   B,TVEC\r
2206         PUSHJ   P,MARK          ; AND MARK IT\r
2207 MFRAM1: HRROI   C,SPSAV-FSAV(C) ;POINT TO SAVED SP\r
2208         MOVEI   B,TSP\r
2209         PUSHJ   P,MARK1         ;MARK THE GOODIE\r
2210         HRROI   C,PSAV-SPSAV(C) ;POINT TO SAVED P\r
2211         MOVEI   B,TPDL\r
2212         PUSHJ   P,MARK1         ;AND MARK IT\r
2213         HRROI   C,TPSAV-PSAV(C) ;POINT TO SAVED TP\r
2214         MOVEI   B,TTP\r
2215         PUSHJ   P,MARK1         ;MARK IT ALS\r
2216         MOVEI   C,-TPSAV+1(C)   ;POINT PAST THE FRAME\r
2217         JRST    VECTM2          ;AND DO MORE MARKING\r
2218 \r
2219 \r
2220 MBIND:  MOVEI   B,TATOM         ;FIRST MARK ATOM\r
2221         SKIPN   GCHAIR          ; IF NO HAIR, MARK ALL NOW\r
2222         SKIPE   (P)             ; PASSED MARKER, IF SO DONT SKIP\r
2223         JRST    MBIND2          ; GO MARK\r
2224         CAME    A,IMQUOTE THIS-PROCESS\r
2225         JRST    MBIND1          ; NOT IT, CONTINUE SKIPPING\r
2226         HRRM    LPVP,2(C)       ; SAVE IN RH OF TPVP,,0\r
2227         MOVEI   LPVP,(C)        ; POINT\r
2228         SETOM   (P)             ; INDICATE PASSAGE\r
2229 MBIND1: ADDI    C,6             ; SKIP BINDING\r
2230         JRST    VECTM2\r
2231 \r
2232 MBIND2: PUSHJ   P,MARK1         ; MARK ATOM\r
2233         ADDI    C,2             ; POINT TO VAL\r
2234         PUSHJ   P,MARK2         ; AND MARK IT\r
2235         MOVEM   A,1(C)\r
2236         ADDI    C,2\r
2237         MOVEI   B,TLIST         ; POINT TO DECL SPECS\r
2238         HLRZ    A,(C)\r
2239         PUSHJ   P,MARK          ; AND MARK IT\r
2240         HRLM    A,(C)           ; LIST FIX UP\r
2241         MOVEI   B,TLOCI         ; NOW MARK LOCATIVE\r
2242         MOVE    A,1(C)\r
2243         JRST    VECTM3\r
2244 \r
2245 VECLOS: JUMPL   C,CCRET         ;JUMP IF CAN'T MUNG TYPE\r
2246         HLLZ    0,(C)           ;GET TYPE\r
2247         MOVEI   B,TILLEG        ;GET ILLEGAL TYPE\r
2248         HRLM    B,(C)\r
2249         MOVEM   0,1(C)          ;AND STORE OLD TYPE AS VALUE\r
2250         JRST    GCRET           ;RETURN WITHOUT MARKING VECTOR\r
2251 \r
2252 CCRET:  CLEARM  1(C)            ;CLOBBER THE DATUM\r
2253         JRST    GCRET\r
2254 \r
2255 \r
2256 IGBLK:  HRRZ    B,(C)           ;SKIP TO END OF PP BLOCK\r
2257         ADDI    C,3(B)\r
2258         JRST    VECTM2\r
2259 \f; MARK ARG POINTERS\r
2260 \r
2261 ARGMK:  HRRZ    A,1(C)          ; GET POINTER\r
2262         HLRE    B,1(C)          ; AND LNTH\r
2263         SUB     A,B             ; POINT TO BASE\r
2264         PUSHJ   P,VECBND\r
2265         JRST    ARGMK0\r
2266         HLRZ    0,(A)           ; GET TYPE\r
2267         ANDI    0,TYPMSK\r
2268         CAIN    0,TCBLK\r
2269         JRST    ARGMK1\r
2270         CAIE    0,TENTRY        ; IS NEXT A WINNER?\r
2271         CAIN    0,TINFO\r
2272         JRST    ARGMK1          ; YES, GO ON TO WIN CODE\r
2273 \r
2274 ARGMK0: SETZB   A,1(C)          ; CLOBBER THE CELL\r
2275         SETZM   (P)             ; AND SAVED COPY\r
2276         JRST    GCRET\r
2277 \r
2278 ARGMK1: MOVE    B,1(A)          ; ASSUME TTB\r
2279         ADDI    B,(A)           ; POINT TO FRAME\r
2280         CAIE    0,TINFO         ; IS IT?\r
2281         MOVEI   B,FRAMLN(A)     ; NO, USE OTHER GOODIE\r
2282         HLRZ    0,OTBSAV(B)     ; GET TIME\r
2283         HRRZ    A,(C)           ; AND FROM POINTER\r
2284         CAIE    0,(A)           ; SKIP IF WINNER\r
2285         JRST    ARGMK0\r
2286         HRROI   C,TPSAV-1(B)    ; MARK FROM TP SLOT\r
2287         MOVEI   B,TTP\r
2288         MOVE    A,1(C)\r
2289 ;       PUSHJ   P,MARK          ; WILL PUT BACK WHEN KNOWN HOW!\r
2290         JRST    GCRET\r
2291 \r
2292 ; MARK FRAME POINTERS\r
2293 \r
2294 FRMK:   SUBI    C,1             ;PREPARE TO MARK PROCESS VECTOR\r
2295         HRRZ    A,1(C)          ;USE AS DATUM\r
2296         SUBI    A,1             ;FUDGE FOR VECTMK\r
2297         MOVEI   B,TPVP          ;IT IS A VECTRO\r
2298         PUSHJ   P,MARK          ;MARK IT\r
2299         JRST    GCRET\r
2300 \r
2301 ; MARK BYTE POINTER\r
2302 \r
2303 BYTMK:  PUSHJ   P,BYTDOP        ; GET DOPE WORD IN A\r
2304         SOJG    A,VECTMK        ;FUDGE DOPE WORD POINTER FOR VECTMK\r
2305 \r
2306         FATAL AGC--BYTE POINTER WITH ZERO DOPE WORD POINTER\r
2307 \r
2308 \f; MARK ATOMS IN GVAL STACK\r
2309 \r
2310 GATOMK: HRRZ    B,(C)           ; POINT TO POSSIBLE GDECL\r
2311         JUMPE   B,ATOMK\r
2312         CAIN    B,-1\r
2313         JRST    ATOMK\r
2314         MOVEI   A,(B)           ; POINT TO DECL FOR MARK\r
2315         MOVEI   B,TLIST\r
2316         MOVEI   C,0\r
2317         PUSHJ   P,MARK\r
2318         HLRZ    C,-1(P)         ; RESTORE HOME POINTER\r
2319         HRRM    A,(C)           ; CLOBBER UPDATED LIST IN\r
2320         MOVE    A,1(C)          ; RESTORE ATOM POINTER\r
2321 \r
2322 ; MARK ATOMS\r
2323 \r
2324 ATOMK:\r
2325 REPEAT 0,[\r
2326         TLO     TYPNT,.ATOM.    ; SAY ATOM WAS MARKED\r
2327         PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS\r
2328         HRRZ    C,(A)           ; IF UNBOUND OR  GLOBAL\r
2329         JUMPE   C,MRKOBL        ; SKIP\r
2330         HRRZ    C,1(A)          ; DONT MARK BUT UPDATE BASED ON TPGROW\r
2331         HLRE    B,1(A)\r
2332         SUB     C,B             ; POINT TO DOPE WORD\r
2333         MOVEI   C,1(C)          ; POINT TO 2D DOPE WORD\r
2334         MOVSI   B,-PDLBUF       ; IN CASE UPDATE\r
2335         CAME    C,TPGROW        ; SKIP IF GROWER\r
2336         ADDM    B,1(A)          ; OTHERWISE UPDATE\r
2337 MRKOBL: MOVEI   C,1(A)          ; POINT TO OBLIST SLOT\r
2338 ]\r
2339         TLO     TYPNT,.ATOM.    ; SAY ATOM WAS MARKED\r
2340         MOVEI   C,1(A)\r
2341         HRRZ    0,(A)\r
2342         PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS\r
2343         JUMPE   0,MRKOBL\r
2344         HRRZ    B,(C)\r
2345         HLRE    0,(C)\r
2346         SUB     B,0\r
2347         MOVEI   B,1(B)\r
2348         MOVSI   0,-PDLBUF\r
2349         CAME    B,TPGROW\r
2350         ADDM    0,(C)\r
2351 MRKOBL: MOVEI   B,TOBLS\r
2352         SKIPGE  1(C)            ; IF > 0, NOT OBL\r
2353         PUSHJ   P,MARK1         ; AND MARK IT\r
2354         JRST    GCRET           ;AND LEAVE\r
2355 \r
2356 GETLNT: HLRE    B,A             ;GET -LNTH\r
2357         SUB     A,B             ;POINT TO 1ST DOPE WORD\r
2358         MOVEI   A,1(A)          ;POINT TO 2ND DOPE WORD\r
2359         PUSHJ   P,VECBND\r
2360         JRST    VECTB1          ;BAD VECTOR, COMPLAIN\r
2361 \r
2362         HLRE    B,(A)           ;GET LENGTH AND MARKING\r
2363         IORM    D,(A)           ;MAKE SURE MARKED\r
2364         JUMPL   B,GCRET1        ;MARKED ALREADY, QUIT\r
2365         SUBI    A,-1(B)         ;POINT TO TOP OF ATOM\r
2366         CAML    A,VECBOT        ; DONT COUNT STORAGE\r
2367         ADDM    B,VECNUM        ;UPDATE VECNUM\r
2368         POPJ    P,              ;AND RETURN\r
2369 \r
2370 GCRET1: SUB     P,[1,,1]        ;FLUSH RETURN ADDRESS\r
2371         JRST    GCRET\r
2372 \r
2373 VECBND: CAMGE   A,VECTOP\r
2374         CAMGE   A,VECBOT\r
2375         JRST    .+2\r
2376         JRST    CPOPJ1\r
2377 \r
2378         CAMG    A,CODTOP\r
2379         CAIGE   A,STOSTR\r
2380         POPJ    P,\r
2381         JRST    CPOPJ1\r
2382 \r
2383 ; MARK NON-GENERAL VECTORS\r
2384 \r
2385 NOTGEN: CAMN    B,[GENERAL+<SPVP,,0>]   ;PROCESS VECTOR?\r
2386         JRST    GENRAL          ;YES, MARK AS A VECTOR\r
2387         JUMPL   B,SPECLS        ; COMPLAIN IF A SPECIAL HACK\r
2388         SUBI    A,1(E)          ;POINT TO TOP OF A UNIFORM VECTOR\r
2389         HLRZS   B               ;ISOLATE TYPE\r
2390         ANDI    E,TYPMSK\r
2391         MOVE    F,B             ; AND COPY IT\r
2392         LSH     B,1             ;FIND OUT WHERE IT WILL GO\r
2393         HRRZ    B,@TYPNT        ;GET SAT IN B\r
2394         ANDI    B,SATMSK\r
2395         MOVEI   C,@MKTBS(B)     ;POINT TO MARK SR\r
2396         CAIN    C,GCRET         ;IF NOT A MARKED FROM GOODIE, IGNORE\r
2397         JRST    GCRET\r
2398         MOVEI   C,-1(A)         ;POINT 1 PRIOR TO VECTOR START\r
2399         PUSH    P,E             ;SAVE NUMBER OF ELEMENTS\r
2400         PUSH    P,F             ;AND UNIFORM TYPE\r
2401 \r
2402 UNLOOP: MOVE    B,(P)           ;GET TYPE\r
2403         MOVE    A,1(C)          ;AND GOODIE\r
2404         TLO     C,400000        ;CAN'T MUNG TYPE\r
2405         PUSHJ   P,MARK          ;MARK THIS ONE\r
2406         MOVEM   A,1(C)          ; LIST FIXUP\r
2407         SOSE    -1(P)           ;COUNT\r
2408         AOJA    C,UNLOOP        ;IF MORE, DO NEXT\r
2409 \r
2410         SUB     P,[2,,2]        ;REMOVE STACK CRAP\r
2411         JRST    GCRET\r
2412 \r
2413 \r
2414 SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR\r
2415 \r
2416 \f;MARK LOCID TYPE GOODIES\r
2417 \r
2418 LOCMK:  HRRZ    B,(C)           ;GET TIME\r
2419         JUMPE   B,LOCMK1        ; SKIP LEGAL CHECK FOR GLOBAL\r
2420         HRRZ    0,2(A)          ; GET OTHER TIME\r
2421         CAIE    0,(B)           ; SAME?\r
2422         SETZB   A,1(C)          ; NO, SMASH LOCATIVE\r
2423         JUMPE   A,GCRET         ; LEAVE IF DONE\r
2424 LOCMK1: PUSH    P,C\r
2425         MOVEI   B,TATOM         ; MARK ATOM\r
2426         MOVEI   C,-2(A)         ; POINT TO ATOM\r
2427         PUSHJ   P,MARK1         ; LET LOCATIVE SAVE THE ATOM\r
2428         POP     P,C\r
2429         HRRZ    B,(C)           ; TIME BACK\r
2430         MOVE    A,1(C)          ; RESTORE POINTER TO STACK\r
2431         JUMPE   B,VECTMK        ;IF ZERO, GLOBAL\r
2432         JRST    TPMK            ;ELSE, ON TP\r
2433 \r
2434 ; MARK ASSOCIATION BLOCKS\r
2435 \r
2436 ASMRK:  HRLI    A,-ASOLNT       ;LOOK LIKE A VECTOR POINTER\r
2437         PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS\r
2438         MOVEI   C,(A)           ;COPY POINTER\r
2439         PUSHJ   P,MARK2         ;MARK ITEM CELL\r
2440         MOVEM   A,1(C)\r
2441         ADDI    C,INDIC-ITEM    ;POINT TO INDICATOR\r
2442         PUSHJ   P,MARK2\r
2443         MOVEM   A,1(C)\r
2444         ADDI    C,VAL-INDIC\r
2445         PUSHJ   P,MARK2\r
2446         MOVEM   A,1(C)\r
2447         SKIPN   GCHAIR          ; IF NO HAIR, MARK ALL FRIENDS\r
2448         JRST    GCRET\r
2449         HRRZ    A,NODPNT-VAL(C) ; NEXT\r
2450         JUMPN   A,ASMRK         ; IF EXISTS, GO\r
2451         JRST    GCRET\r
2452 \r
2453 \r
2454 \r
2455 ;HERE WHEN A VECTOR POINTER IS BAD\r
2456 \r
2457 VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE\r
2458 \r
2459 \f; HERE TO MARK TEMPLATE DATA STRUCTURES\r
2460 \r
2461 TD.MRK: HLRZ    B,(A)           ; GET REAL SPEC TYPE\r
2462         ANDI    B,377777        ; KILL SIGN BIT\r
2463         MOVEI   E,-NUMSAT-1(B)  ; GET REL POINTER TO TABLE\r
2464         HRLI    E,(E)\r
2465         ADD     E,TD.LNT+1(TVP)\r
2466         HRRZS   C,A             ; FLUSH COUNT AND SAVE\r
2467         SKIPL   E               ; WITHIN BOUNDS\r
2468         FATAL   BAD SAT IN AGC\r
2469         PUSHJ   P,GETLNT        ; GOODIE IS NOW MARKED\r
2470 \r
2471         XCT     (E)             ; RET # OF ELEMENTS IN B\r
2472 \r
2473         HLRZ    D,B             ; GET POSSIBLE "BASIC LENGTH" FOR RESTS\r
2474         PUSH    P,[0]           ; TEMP USED IF RESTS EXIST\r
2475         PUSH    P,D\r
2476         MOVEI   B,(B)           ; ZAP TO ONLY LENGTH\r
2477         PUSH    P,C             ; SAVE POINTER TO TEMPLATE STRUCTURE\r
2478         PUSH    P,[0]           ; HOME FOR VALUES\r
2479         PUSH    P,[0]           ; SLOT FOR TEMP\r
2480         PUSH    P,B             ; SAVE\r
2481         SUB     E,TD.LNT+1(TVP)\r
2482         PUSH    P,E             ; SAVE FOR FINDING OTHER TABLES\r
2483         JUMPE   D,TD.MR2        ; NO REPEATING SEQ\r
2484         ADD     E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
2485         HLRE    E,(E)           ; E ==> - LNTH OF TEMPLATE\r
2486         ADDI    E,(D)           ; E ==> -LENGTH OF REP SEQ\r
2487         MOVNS   E\r
2488         HRLM    E,-5(P)         ; SAVE IT AND BASIC\r
2489 \r
2490 TD.MR2: SKIPG   D,-1(P)         ; ANY LEFT?\r
2491         JRST    TD.MR1\r
2492 \r
2493         MOVE    E,TD.GET+1(TVP)\r
2494         ADD     E,(P)\r
2495         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
2496         MOVEM   D,-6(P)         ; SAVE ELMENT #\r
2497         SKIPN   B,-5(P)         ; SKIP IF "RESTS" EXIST\r
2498         SOJA    D,TD.MR3\r
2499 \r
2500         MOVEI   0,(B)           ; BASIC LNT TO 0\r
2501         SUBI    0,(D)           ; SEE IF PAST BASIC\r
2502         JUMPGE  0,.-3           ; JUMP IF O.K.\r
2503         MOVSS   B               ; REP LNT TO RH, BASIC TO LH\r
2504         IDIVI   0,(B)           ; A==> -WHICH REPEATER\r
2505         MOVNS   A\r
2506         ADD     A,-5(P)         ; PLUS BASIC\r
2507         ADDI    A,1             ; AND FUDGE\r
2508         MOVEM   A,-6(P)         ; SAVE FOR PUTTER\r
2509         ADDI    E,-1(A)         ; POINT\r
2510         SOJA    D,.+2\r
2511 \r
2512 TD.MR3: ADDI    E,(D)           ; POINT TO SLOT\r
2513         XCT     (E)             ; GET THIS ELEMENT INTO A AND B\r
2514         MOVEM   A,-3(P)         ; SAVE TYPE FOR LATER PUT\r
2515         MOVEM   B,-2(P)\r
2516         EXCH    A,B             ; REARRANGE\r
2517         GETYP   B,B\r
2518         MOVEI   C,-3(P)         ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG\r
2519         MOVSI   D,400000        ; RESET FOR MARK\r
2520         PUSHJ   P,MARK          ; AND MARK THIS GUY (RET FIXED POINTER IN A)\r
2521         MOVE    C,-4(P)         ; REGOBBLE POINTER TO TEMPLATE\r
2522         MOVE    E,TD.PUT+1(TVP)\r
2523         MOVE    B,-6(P)         ; RESTORE COUNT\r
2524         ADD     E,(P)\r
2525         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
2526         ADDI    E,(B)-1         ; POINT TO SLOT\r
2527         MOVE    B,-3(P)         ; RESTORE TYPE WORD\r
2528         EXCH    A,B\r
2529         SOS     D,-1(P)         ; GET ELEMENT #\r
2530         XCT     (E)             ; SMASH IT BACK\r
2531         FATAL TEMPLATE LOSSAGE\r
2532         MOVE    C,-4(P)         ; RESTORE POINTER IN CASE MUNGED\r
2533         JRST    TD.MR2\r
2534 \r
2535 TD.MR1: SUB     P,[7,,7]\r
2536         MOVSI   D,400000        ; RESTORE MARK/UNMARK BIT\r
2537         JRST    GCRET\r
2538 \r
2539 ;  This phase attempts to remove any unwanted associations.  The program\r
2540 ; loops through the structure marking values of associations.  It can only\r
2541 ; stop when no new values (potential items and/or indicators) are marked.\r
2542 \r
2543 VALFLS: PUSH    P,[0]           ; INDICATE WHETHER ANY ON THIS PASS\r
2544         PUSH    P,[0]           ; OR THIS BUCKET\r
2545 ASOMK1: MOVE    A,ASOVEC+1(TVP) ; GET VECTOR POINTER\r
2546         SETOM   -1(P)           ; INITIALIZE FLAG\r
2547 \r
2548 ASOM6:  SKIPG   C,(A)           ; SKIP IF BUCKET TO BE SCANNED\r
2549         JRST    ASOM1\r
2550         SETOM   (P)             ; SAY BUCKET NOT CHANGED\r
2551 \r
2552 ASOM2:  MOVEI   F,(C)           ; COPY POINTER\r
2553         SKIPG   ASOLNT+1(C)     ; SKIP IF NOT ALREADY MARKED\r
2554         JRST    ASOM4           ; MARKED, GO ON\r
2555         PUSHJ   P,MARKQ         ; SEE IF ITEM IS MARKED\r
2556         JRST    ASOM3           ; IT IS NOT, IGNORE IT\r
2557         MOVEI   F,(C)           ; IN CASE CLOBBERED BY MARK2\r
2558         MOVEI   C,INDIC(C)              ; POINT TO INDICATOR SLOT\r
2559         PUSHJ   P,MARKQ\r
2560         JRST    ASOM3           ; NOT MARKED\r
2561 \r
2562         PUSH    P,A             ; HERE TO MARK VALUE\r
2563         PUSH    P,F\r
2564         HLRE    F,ASOLNT-INDIC+1(C)     ; GET LENGTH\r
2565         JUMPL   F,.+3           ; SKIP IF MARKED\r
2566         CAML    C,VECBOT        ; SKIP IF IN NOT VECT SPACE\r
2567         ADDM    F,VECNUM\r
2568         PUSHJ   P,MARK2         ; AND MARK\r
2569         MOVEM   A,1(C)          ; LIST FIX UP\r
2570         ADDI    C,ITEM-INDIC    ; POINT TO ITEM\r
2571         PUSHJ   P,MARK2\r
2572         MOVEM   A,1(C)\r
2573         ADDI    C,VAL-ITEM      ; POINT TO VALUE\r
2574         PUSHJ   P,MARK2\r
2575         MOVEM   A,1(C)\r
2576         IORM    D,ASOLNT-VAL+1(C)       ; MARK ASOC BLOCK\r
2577         POP     P,F\r
2578         POP     P,A\r
2579         AOSA    -1(P)           ; INDICATE A MARK TOOK PLACE\r
2580 \r
2581 ASOM3:  AOS     (P)             ; INDICATE AN UNMARKED IN THIS BUCKET\r
2582 ASOM4:  HRRZ    C,ASOLNT-1(F)   ; POINT TO NEXT IN BUCKET\r
2583         JUMPN   C,ASOM2         ; IF NOT EMPTY, CONTINUE\r
2584         SKIPGE  (P)             ; SKIP IF ANY NOT MARKED\r
2585         HRROS   (A)             ; MARK BUCKET AS NOT INTERESTING\r
2586 ASOM1:  AOBJN   A,ASOM6         ; GO TO NEXT BUCKET\r
2587         TLZE    TYPNT,.ATOM.    ; ANY ATOMS MARKED?\r
2588         JRST    VALFLA          ; YES, CHECK VALUES\r
2589 VALFL8:\r
2590 \r
2591 ; NOW SEE WHICH CHANNELS STILL POINTED TO\r
2592 \r
2593 CHNFL3: MOVEI   0,N.CHNS-1\r
2594         MOVEI   A,CHNL1(TVP)    ; SLOTS\r
2595         HRLI    A,TCHAN         ; TYPE HERE TOO\r
2596 \r
2597 CHNFL2: SKIPN   B,1(A)\r
2598         JRST    CHNFL1\r
2599         HLRE    C,B\r
2600         SUBI    B,(C)           ; POINT TO DOPE\r
2601         HLLM    A,(A)           ; PUT TYPE BACK\r
2602         SKIPGE  1(B)\r
2603         JRST    CHNFL1\r
2604         HLLOS   (A)             ; MARK AS A LOSER\r
2605         PUSH    P,A\r
2606         PUSH    P,0\r
2607         MOVEI   C,(A)\r
2608         PUSHJ   P,MARK2\r
2609         POP     P,0\r
2610         POP     P,A\r
2611         SETZM   -1(P)           ; SAY MARKED\r
2612 CHNFL1: ADDI    A,2\r
2613         SOJG    0,CHNFL2\r
2614 \r
2615         SKIPE   GCHAIR          ; IF NOT HAIRY CASE\r
2616         POPJ    P,              ; LEAVE\r
2617 \r
2618         SKIPL   -1(P)           ; SKIP IF NOTHING NEW MARKED\r
2619         JRST    ASOMK1\r
2620 \r
2621         SUB     P,[2,,2]        ; REMOVE FLAGS\r
2622 \r
2623 \r
2624 \r
2625 \f; HERE TO REEMOVE UNUSED ASSOCIATIONS\r
2626 \r
2627         MOVE    A,ASOVEC+1(TVP) ; GET ASOVEC BACK FOR FLUSHES\r
2628 \r
2629 ASOFL1: SKIPN   C,(A)           ; SKIP IF BUCKET NOT EMPTY\r
2630         JRST    ASOFL2          ; EMPTY BUCKET, IGNORE\r
2631         HRRZS   (A)             ; UNDO DAMAGE OF BEFORE\r
2632 \r
2633 ASOFL5: SKIPGE  ASOLNT+1(C)     ; SKIP IF UNMARKED\r
2634         JRST    ASOFL3          ; MARKED, DONT FLUSH\r
2635 \r
2636         HRRZ    B,ASOLNT-1(C)   ; GET FORWARD POINTER\r
2637         HLRZ    E,ASOLNT-1(C)   ; AND BACK POINTER\r
2638         JUMPN   E,ASOFL4        ; JUMP IF NO BACK POINTER (FIRST IN BUCKET)\r
2639         HRRZM   B,(A)           ; FIX BUCKET\r
2640         JRST    .+2\r
2641 \r
2642 ASOFL4: HRRM    B,ASOLNT-1(E)   ; FIX UP PREVIOUS\r
2643         JUMPE   B,.+2           ; JUMP IF NO NEXT POINTER\r
2644         HRLM    E,ASOLNT-1(B)   ; FIX NEXT'S BACK POINTER\r
2645         HRRZ    B,NODPNT(C)     ; SPLICE OUT THRAD\r
2646         HLRZ    E,NODPNT(C)\r
2647         SKIPE   E\r
2648         HRRM    B,NODPNT(E)\r
2649         SKIPE   B\r
2650         HRLM    E,NODPNT(B)\r
2651 \r
2652 ASOFL3: HRRZ    C,ASOLNT-1(C)   ; GO TO NEXT\r
2653         JUMPN   C,ASOFL5\r
2654 ASOFL2: AOBJN   A,ASOFL1\r
2655 \r
2656 ; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES\r
2657 \r
2658         MOVE    A,GLOBSP+1(TVP) ; GET GLOBAL PDL\r
2659 \r
2660 GLOFLS: SKIPGE  (A)             ; SKIP IF NOT ALREADY MARKED\r
2661         JRST    .+3             ; VIOLATE CARDINAL RULE #69\r
2662         MOVSI   B,-3\r
2663         PUSHJ   P,ZERSLT        ; CLOBBER THE SLOT\r
2664         ANDCAM  D,(A)           ; UNMARK\r
2665         ADD     A,[4,,4]\r
2666         JUMPL   A,GLOFLS        ; MORE?, KEEP LOOPING\r
2667 \r
2668 LOCFL1: HRRZ    A,(LPVP)        ; NOW CLOBBER LOCAL SLOTS\r
2669         HRRZ    C,2(LPVP)\r
2670         HLLZS   2(LPVP)         ; NOW CLEAR\r
2671         MOVEI   LPVP,(C)\r
2672         JUMPE   A,LOCFL2        ; NONE TO FLUSH\r
2673 \r
2674 LOCFLS: SKIPGE  (A)             ; MARKDE?\r
2675         JRST    .+3\r
2676         MOVSI   B,-5\r
2677         PUSHJ   P,ZERSLT\r
2678         ANDCAM  D,(A)           ;UNMARK\r
2679         HRRZ    A,(A)           ; GO ON\r
2680         JUMPN   A,LOCFLS\r
2681 LOCFL2: JUMPN   LPVP,LOCFL1     ; JUMP IF MORE PROCESS\r
2682         POPJ    P,\r
2683 \r
2684 \r
2685 \r
2686 MARK23: PUSH    P,A             ; SAVE BUCKET POINTER\r
2687         PUSH    P,F\r
2688         PUSHJ   P,MARK2\r
2689         MOVEM   A,1(C)\r
2690         POP     P,F\r
2691         POP     P,A\r
2692         AOS     -2(P)           ; MARKING HAS OCCURRED\r
2693         IORM    D,ASOLNT+1(C)   ; MARK IT\r
2694         JRST    MKD\r
2695 \r
2696 \f; CHANNEL FLUSHER FOR NON HAIRY GC\r
2697 \r
2698 CHNFLS: PUSH    P,[-1]\r
2699         SETOM   (P)             ; RESET FOR RETRY\r
2700         PUSHJ   P,CHNFL3\r
2701         SKIPL   (P)\r
2702         JRST    .-3             ; REDO\r
2703         SUB     P,[1,,1]\r
2704         POPJ    P,\r
2705 \r
2706 ; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP\r
2707 \r
2708 VALFLA: MOVE    C,GLOBSP+1(TVP)\r
2709 \r
2710 VALFL1: SKIPL   (C)             ; SKIP IF NOT MARKED\r
2711         PUSHJ   P,MARKQ         ; SEE IF ATOM IS MARKED\r
2712         JRST    VALFL2\r
2713         IORM    D,(C)\r
2714         AOS     -1(P)           ; INDICATE MARK OCCURRED\r
2715         PUSH    P,C\r
2716         HRRZ    B,(C)           ; GET POSSIBLE GDECL\r
2717         JUMPE   B,VLFL10        ; NONE\r
2718         CAIN    B,-1            ; MAINFIFEST\r
2719         JRST    VLFL10\r
2720         MOVEI   A,(B)\r
2721         MOVEI   B,TLIST\r
2722         MOVEI   C,0\r
2723         PUSHJ   P,MARK          ; MARK IT\r
2724         MOVE    C,(P)           ; POINT\r
2725         HRRM    A,(C)           ; CLOBBER UPDATE IN\r
2726 VLFL10: ADD     C,[2,,2]        ; BUMP TO VALUE\r
2727         PUSHJ   P,MARK2         ; MARK VALUE\r
2728         MOVEM   A,1(C)\r
2729         POP     P,C\r
2730 VALFL2: ADD     C,[4,,4]\r
2731         JUMPL   C,VALFL1        ; JUMP IF MORE\r
2732 \r
2733         HRLM    LPVP,(P)        ; SAVE POINTER\r
2734 VALFL7: MOVEI   C,(LPVP)\r
2735         MOVEI   LPVP,0\r
2736 VALFL6: HRRM    C,(P)\r
2737 \r
2738 VALFL5: HRRZ    C,(C)           ; CHAIN\r
2739         JUMPE   C,VALFL4\r
2740         MOVEI   B,TATOM         ; TREAT LIKE AN ATOM\r
2741         SKIPL   (C)             ; MARKED?\r
2742         PUSHJ   P,MARKQ1        ; NO, SEE\r
2743         JRST    VALFL5          ; LOOP\r
2744         AOS     -1(P)           ; MARK WILL OCCUR\r
2745         IORM    D,(C)\r
2746         ADD     C,[2,,2]        ; POINT TO VALUE\r
2747         PUSHJ   P,MARK2         ; MARK VALUE\r
2748         MOVEM   A,1(C)\r
2749         SUBI    C,2\r
2750         JRST    VALFL5\r
2751 \r
2752 VALFL4: HRRZ    C,(P)           ; GET SAVED LPVP\r
2753         MOVEI   A,(C)\r
2754         HRRZ    C,2(C)          ; POINT TO NEXT\r
2755         JUMPN   C,VALFL6\r
2756         JUMPE   LPVP,VALFL9\r
2757 \r
2758         HRRM    LPVP,2(A)       ; NEW PROCESS WAS MARKED\r
2759         JRST    VALFL7\r
2760 \r
2761 ZERSLT: HRRI    B,(A)           ; COPY POINTER\r
2762         SETZM   1(B)\r
2763         AOBJN   B,.-1\r
2764         POPJ    P,\r
2765 \r
2766 VALFL9: HLRZ    LPVP,(P)        ; RESTORE CHAIN\r
2767         JRST    VALFL8\r
2768 \r
2769 \r
2770 \f;SUBROUTINE TO SEE IF A GOODIE IS MARKED\r
2771 ;RECEIVES POINTER IN C\r
2772 ;SKIPS IF MARKED NOT OTHERWISE\r
2773 \r
2774 MARKQ:  HLRZ    B,(C)           ;TYPE TO B\r
2775 MARKQ1: MOVE    E,1(C)          ;DATUM TO C\r
2776         MOVEI   0,(E)\r
2777         CAIL    0,@PURBOT       ; DONT CHACK PURE\r
2778         JRST    MKD             ; ALWAYS MARKED\r
2779         ANDI    B,TYPMSK        ; FLUSH MONITORS\r
2780         LSH     B,1\r
2781         HRRZ    B,@TYPNT        ;GOBBLE SAT\r
2782         ANDI    B,SATMSK\r
2783         CAIG    B,NUMSAT        ; SKIP FOR TEMPLATE\r
2784         JRST    @MQTBS(B)       ;DISPATCH\r
2785         ANDI    E,-1            ; FLUSH REST HACKS\r
2786         JRST    VECMQ\r
2787 \r
2788 \r
2789 DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]\r
2790 [STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMQ],[SLOCID,LOCMQ]\r
2791 [SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ]\r
2792 [SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,VECMQ]]\r
2793 \r
2794 PAIRMQ: JUMPE   E,MKD           ; NIL ALWAYS MARKED\r
2795         SKIPL   (E)             ; SKIP IF MARKED\r
2796         POPJ    P,\r
2797 CPOPJ1:\r
2798 ARGMQ:\r
2799 MKD:    AOS     (P)\r
2800         POPJ    P,\r
2801 \r
2802 BYTMQ:  HRRZ    E,(C)           ;GET DOPE WORD POINTER\r
2803         SOJA    E,VECMQ1        ;TREAT LIKE VECTOR\r
2804 \r
2805 FRMQ:   HRRZ    E,(C)           ; POINT TO PV DOPE WORD\r
2806         SOJA    E,VECMQ1\r
2807 \r
2808 \r
2809 VECMQ:  HLRE    0,E             ;GET LENGTH\r
2810         SUB     E,0             ;POINT TO DOPE WORDS\r
2811 \r
2812 VECMQ1: SKIPGE  1(E)            ;SKIP IF NOT MARKED\r
2813         AOS     (P)             ;MARKED, CAUSE SKIP RETURN\r
2814         POPJ    P,\r
2815 \r
2816 ASMQ:   SUBI    E,ASOLNT\r
2817         JRST    VECMQ1\r
2818 \r
2819 LOCMQ:  HRRZ    0,(C)           ; GET TIME\r
2820         JUMPE   0,VECMQ         ; GLOBAL, LIKE VECTOR\r
2821         HLRE    0,E             ; FIND DOPE\r
2822         SUB     E,0\r
2823         MOVEI   E,1(E)          ; POINT TO LAST DOPE\r
2824         CAMN    E,TPGROW                ; GROWING?\r
2825         SOJA    E,VECMQ1        ; YES, CHECK\r
2826         ADDI    E,PDLBUF        ; FUDGE\r
2827         MOVSI   0,-PDLBUF\r
2828         ADDM    0,1(C)\r
2829         SOJA    E,VECMQ1\r
2830 \fREPEAT 0,[\r
2831 \r
2832 \r
2833 \r
2834 ;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED\r
2835 ;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A\r
2836 ;LEAVES HIGHEST TIME IN TIMOUT\r
2837 \r
2838 RETIME: HLRE    B,A             ;GET LENGTH IN B\r
2839         SUB     A,B             ;COMPUTE DOPE WORD LOCATION\r
2840         MOVEI   A,1(A)          ;POINT TO 2D DOPE WORD AND CLEAR LH\r
2841         CAME    A,TPGROW        ;IS THIS ONE BLOWN?\r
2842         ADDI    A,PDLBUF        ;NO, POINT TO DOPE WORD\r
2843         LDB     B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT\r
2844         SUBI    A,-1(B)         ;POINT TO PDLS BASE\r
2845         MOVEI   C,1             ;INITIALIZE NEW TIMES\r
2846 \r
2847 RETIM1: SKIPGE  B,(A)           ;IF <0, HIT DOPE WORD OR FENCE POST\r
2848         JRST    RETIM3\r
2849         HLRZS   B               ;ISOLATE TYPE\r
2850         CAIE    B,TENTRY        ;FRAME START?\r
2851         AOJA    A,RETIM2        ;NO, TRY BINDING\r
2852         HRLM    C,FRAMLN+OTBSAV(A)      ;STORE NEW TIME\r
2853         ADDI    A,FRAMLN        ;POINT TO NEXT ELEMENT\r
2854         AOJA    C,RETIM1        ;BUMP TIME AND MOVE ON\r
2855 \r
2856 RETIM2: CAIE    B,TUBIND\r
2857         CAIN    B,TBIND         ;BINDING?\r
2858         HRRM    C,3(A)          ;YES, STORE CURRENT TIME\r
2859         AOJA    A,RETIM1        ;AND GO ON\r
2860 \r
2861 RETIM3: MOVEM   C,TIMOUT        ;SAVE TIME\r
2862         POPJ    P,              ;RETURN\r
2863 \r
2864 \r
2865 ]\r
2866 \r
2867 \f; Core adjustment phase, try to win in all obscure cases!\r
2868 \r
2869 CORADJ: MOVE    A,P.TOP         ; update AGCs core top\r
2870         MOVEM   A,CORTOP\r
2871         MOVE    A,PARBOT        ; figure out all the core needed\r
2872         ADD     A,PARNEW\r
2873         ADD     A,PARNUM\r
2874         ADD     A,PARNUM\r
2875         ADD     A,VECNUM\r
2876         ADDI    A,3777          ; account for gc pdl and round to block\r
2877         ANDCMI  A,1777\r
2878 \r
2879 CORAD3: CAMG    A,PURTOP        ; any way of winning at all?\r
2880         JRST    CORAD1          ; yes, go try\r
2881 CORA33: SETOM   GCDNTG          ; no, can't even grow something\r
2882         SETOM   GCDANG          ; or get current request\r
2883         SKIPL   C,PARNEW        ; or move pairs up\r
2884         SETZM   PARNEW\r
2885         MOVEM   C,SPARNW        ; save attempt in case of retry\r
2886 \r
2887 CORAD6: MOVE    A,CORTOP        ; update core gotton with needed\r
2888         ASH     A,-10.          ; to blocks\r
2889         PUSHJ   P,P.CORE        ; try to get it (any lossage will retry)\r
2890         PUSHJ   P,SLPM1\r
2891 CORA11: MOVE    A,CORTOP        ; compute new home for vectors\r
2892         SUB     A,VECTOP\r
2893         SUBI    A,2000          ; remember gc pdl\r
2894         MOVEM   A,VECNEW\r
2895         POPJ    P,              ; return to main GC loop\r
2896 \r
2897 ; Here if at least enough for growers\r
2898 \r
2899 CORAD1: SKIPN   B,GCDOWN        ; skip if were called to get pure space\r
2900         JRST    CORAD2\r
2901         ADDI    A,2000(B)       ; A/ enough for move down and minimum free\r
2902         CAMG    A,PURTOP        ; any chance of winning?\r
2903         JRST    CORAD4          ; yes, go win some\r
2904 \r
2905 ; Here if cant move down\r
2906 \r
2907         SETOM   GCDANG          ; complain upon return\r
2908         SUBI    A,2000(B)       ; reset for re-entry into loop\r
2909         CAMLE   A,PURTOP        ; win?\r
2910         JRST    CORA33\r
2911 \r
2912 ; Here if may be able to grant current request\r
2913 \r
2914 CORAD2: ADD     A,GETNUM        ; A/  total neede including request\r
2915         ADD     A,CURPLN        ; dont give self away or something\r
2916         ADDI    A,3777          ; at least one free block and round\r
2917         ANDCMI  A,1777          ;   to block boundary\r
2918         CAMG    A,PURTOP        ; any hope of this?\r
2919         JRST    CORAD5          ; yes, now see if some slop space can appear\r
2920 \r
2921         SETOM   GCDANG          ; tell caller we lost\r
2922         MOVE    A,PURTOP        ; try to get as much as possible anyway\r
2923         SUB     A,PURBOT\r
2924         SUB     A,CURPLN\r
2925 CORAD8: ASH     A,-10.          ; to pages\r
2926         PUSHJ   P,GETPAG\r
2927         FATAL   PAGES NOT AVAILABLE\r
2928         MOVSI   D,400000        ; wipes out D\r
2929         MOVE    A,PURBOT        ; and use current PURBOT as new core top\r
2930         SUBI    A,2000          ; for gc pdl\r
2931         MOVEM   A,CORTOP\r
2932         JRST    CORAD6          ; and allocate necessary pages\r
2933 \r
2934 ; Here if real necessities taken care of, try for slop space\r
2935 \r
2936 CORAD5: ADD     A,FREMIN        ; try for minimum\r
2937         SUBI    A,2000-1777     ; round and flush min 2000 of before\r
2938         ANDCMI  A,1777          ; round to block boundary\r
2939         CAMG    A,PURTOP        ; again, do we win?\r
2940         JRST    CORAD7          ; yes, we win totally\r
2941 \r
2942 ; Here if cant get desired free but get some\r
2943 \r
2944         MOVE    A,PURTOP        ; compute pages to flush\r
2945         SUB     A,CURPLN        ; again dont flush current prog\r
2946         SUB     A,PURBOT        ; A/ words to get\r
2947         JRST    CORAD8          ; go do it\r
2948 \r
2949 ; Here if can get all the free we want\r
2950 \r
2951 CORAD7: SUB     A,CURPLN\r
2952         CAMG    A,PURBOT        ; do any pages get the ax?\r
2953         JRST    CORAD9          ; no, see if can give core back!\r
2954         SUB     A,PURBOT        ; words to get purely\r
2955         JRST    CORAD8\r
2956 \r
2957 CORAD9: CAMG    A,CORTOP        ; skip if must get core\r
2958         JRST    CORA10\r
2959         MOVEM   A,CORTOP\r
2960         JRST    CORAD6          ; and go get it\r
2961 \r
2962 ; Here if still may have to give it back\r
2963 \r
2964 CORA10: MOVE    B,CORTOP\r
2965         SUB     B,A\r
2966         CAMG    B,FREDIF        ; skip if giving awy\r
2967         JRST    CORA11\r
2968 \r
2969 CORA12: MOVEM   A,CORTOP\r
2970         ASH     A,-10.\r
2971         MOVEM   A,CORSET        ; leave to shrink later\r
2972         JRST    CORA11\r
2973 \r
2974 ; Here if going down to also get free space\r
2975 \r
2976 CORAD4: SUBI    A,2000          ; uncompensate for min\r
2977         ADD     A,FREMIN\r
2978         CAML    A,CORTOP        ; skip if ok for max\r
2979         MOVE    A,CORTOP        ; else use up to pure\r
2980         SUB     A,GCDOWN        ; new CORTOP to A\r
2981         JRST    CORA12          ; go set up final shrink\r
2982 \r
2983 ; routine to wait for core\r
2984 \r
2985 SLPM1:  MOVEI   0,1\r
2986         .SLEEP  0,\r
2987         SOS     (P)\r
2988         SOS     (P)             ; ret to prev ins\r
2989         POPJ    P,\r
2990 \r
2991 CORADL: PUSHJ   P,P.CORE        ;SET TO NEW CORE VALUE\r
2992         FATAL AGC--CANT CORE DOWN\r
2993         POPJ    P,\r
2994 \f;VECTOR RELOCATE --GETS VECTOP IN A\r
2995 ;AND VECNEW IN B\r
2996 ;FILLS IN RELOCATION FIELDS OF MARKED VECTORS\r
2997 ;AND REUTRNS FINAL VECNEW IN B\r
2998 \r
2999 VECREL: CAMG    A,VECBOT        ;PROCESSED TO BOTTOM OF VECTOR SPACE?\r
3000         POPJ    P,              ;YES, RETURN\r
3001         HLRE    C,(A)           ;GET COUNT FROM DOPE WD, EXTEND MARK BIT\r
3002         JUMPL   C,VECRE1        ;IF MARKED GO PROCESS\r
3003         HRRM    A,(A)           ; INDICATE NON-MOVE BY LEAVING SAME\r
3004         SUBI    A,(C)           ;MOVE ON TO NEXT VECTOR\r
3005         SOJG    C,VECREL        ;AND KEEP SCANNING\r
3006         JSP     D,VCMLOS        ;LOSER, LEAVE TRACKS AS TO WHO LOST\r
3007 \r
3008 VECRE1: HRRZ    E,-1(A)         ;GOBBLE THE GROWTH FILEDS\r
3009         HRRM    B,(A)           ;STORE RELOCATION\r
3010         JUMPE   E,VECRE2        ;NO GROWTH (OR SHRINKAGE), GO AWAY\r
3011         LDB     F,[111100,,E]   ;GET TOP GROWTH IN F\r
3012         TRZN    F,400           ;CHECK AND FLUSH SIGN\r
3013         MOVNS   F               ;WAS ON, NEGATE\r
3014         SKIPE   GCDNTG          ; SKIP IF GROWTH OK\r
3015         JUMPL   F,VECRE3        ; DONT ALLOW POSITIVE GROWTH\r
3016         ASH     F,6             ;CONVERT TO WORDS\r
3017         ADD     B,F             ;UPDATE RELOCATION\r
3018         HRRM    B,(A)           ;AND STORE IT\r
3019 VECRE3: ANDI    E,777           ;ISOLATE BOTTOM GROWTH\r
3020         TRZN    E,400           ;CHECK AND CLEAR SIGN\r
3021         MOVNS   E\r
3022         SKIPE   GCDNTG          ; SKIP IF GROWTH OK\r
3023         JUMPL   E,VECRE2\r
3024         ASH     E,6             ;CONVERT TO WORDS\r
3025         ADD     B,E             ;UPDATE FUTURE RELOCATIONS\r
3026 VECRE2: SUBI    A,400000(C)     ;AND MOVE ON TO NEXT VECTOR\r
3027         ANDI    C,377777        ;KILL MARK\r
3028         SUBI    B,(C)           ; UPDATE WHERE TO GO LOCN\r
3029         SOJG    C,VECREL        ;AND KEEP GOING\r
3030         JSP     D,VCMLOS        ;LOSES, LEAVE TRACKS\r
3031 \r
3032 ;PAIR SPACE UPDATE\r
3033 \r
3034 ;GETS PARBOT IN AC A\r
3035 ;UPDATES VALUES AND CDRS UP TO PARTOP\r
3036 \r
3037 PARUPD: CAML    A,PARTOP        ;ARE THERE MORE PAIRS TO PROCESS\r
3038         POPJ    P,              ;NO -- RETURN\r
3039 \r
3040 ;UPDATE VALUE CELL\r
3041 PARUP1: ANDCAM  D,(A)           ; KILL MARK BIT\r
3042         HLRZ    B,(A)           ;SET RH OF B TO TYPE\r
3043         MOVE    C,1(A)          ;SET C TO VALUE\r
3044         PUSHJ   P,VALUPD        ;UPDATE THIS VALUE\r
3045         ADDI    A,2             ;MOVE ON TO NEXT PAIR\r
3046         JRST    PARUPD          ;AND CONTINUE\r
3047 \r
3048 \r
3049 \f;VECTOR SPACE UPDATE\r
3050 ;GETS VECTOP IN A\r
3051 ;UPDATES ALL VALUE CELLS IN MARKED VECTORS\r
3052 ;ESCAPES WHEN IT GETS TO VECBOT\r
3053 \r
3054 VECUPD: SUBI    A,1             ;MAKE A POINT TO LAST DOPE WD\r
3055         PUSH    P,VECBOT\r
3056         PUSHJ   P,UPD1\r
3057         SUB     P,[1,,1]\r
3058         POPJ    P,\r
3059 \r
3060 ; STORAGE SPACE UPDATE\r
3061 \r
3062 STOUP:  PUSH    P,[STOSTR]\r
3063         PUSHJ   P,UPD1\r
3064         SUB     P,[1,,1]\r
3065         JRST    ENHACK\r
3066 UPD1:\r
3067 VECUP1: CAMG    A,-1(P)         ;ANY MORE VECTORS TO PROCESS?\r
3068         POPJ    P,\r
3069         SKIPGE  B,(A)           ;IS DOPE WORD MARKED?\r
3070         JRST    VECUP2          ;YES -- GO PROCESS VALUES IN THIS VECTOR\r
3071         HLLZS   -1(A)           ;MAKE SURE NO GROWTH ATTEMPTS\r
3072         HLRZS   B               ;NO -- SET RH OF B TO SIZE OF VECTOR\r
3073 VECUP5: SUB     A,B             ;SET A TO POINT TO DOPE WD OF NEXT VECTOR\r
3074         JRST    VECUP1          ;AND CONTINUE\r
3075 \r
3076 VECUP2: PUSH    P,A             ;SAVE DOPE WORD POINTER\r
3077         HLRZ    B,(A)           ;GET LENGTH OF THIS VECTOR\r
3078 VECU11: ANDI    B,377777        ;TURN OFF MARK BIT\r
3079         SKIPGE  E,-1(A)         ;CHECK FOR UNIFORM OR SPECIAL\r
3080         TLNE    E,377777        ;SKIP IF GENERAL\r
3081         JRST    VECUP6          ;UNIFORM OR SPECIAL, GO DO IT\r
3082 VECU10: SUB     A,B             ;SET AC A TO NEXT DOPE WORD\r
3083         ADDI    A,1             ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR\r
3084 VECUP3: HLRZ    B,(A)           ;GET TYPE\r
3085         TRNE    B,400000        ;IF MARK BIT SET\r
3086         JRST    VECUP4          ;DONE WITH THIS VECTOR\r
3087         ANDI    B,TYPMSK\r
3088         CAIE    B,TCBLK\r
3089         CAIN    B,TENTRY        ;SPECIAL HACK FOR ENTRY\r
3090         JRST    ENTRUP\r
3091         CAIE    B,TUNWIN\r
3092         CAIN    B,TSKIP         ; SKIP POINTER\r
3093         JRST    BINDUP          ; HACK APPROPRAITELY\r
3094         CAIE    B,TBVL          ;VECTOR BINDING?\r
3095         CAIN    B,TBIND         ;AND BINDING BLOCK\r
3096         JRST    BINDUP\r
3097         CAIN    B,TUBIND\r
3098         JRST    BINDUP\r
3099 VECU15: MOVE    C,1(A)          ;GET VALUE\r
3100         PUSHJ   P,VALUPD        ;UPDATE THIS VALUE\r
3101 VECU12: ADDI    A,2             ;GO ON TO NEXT VECTOR\r
3102         JRST    VECUP3          ;AND CONTINUE\r
3103 \r
3104 VECUP4: POP     P,A             ;SET TO OLD DOPE WORD\r
3105         ANDCAM  D,(A)           ;TURN OFF MARK BIT\r
3106         HLRZ    B,(A)           ;GET LENGTH\r
3107         ANDI    B,377777        ; IN CASE DING STORAGE\r
3108         JRST    VECUP5          ;GO ON TO NEXT VECTOR\r
3109 \r
3110 \r
3111 \r
3112 ;UPDATE A SAVED SAVE BLOCK\r
3113 ENTSUP: MOVEI   A,FRAMLN+SPSAV-1(A)     ;A POINTS BEFORE SAVED SP\r
3114         MOVEI   B,TSP\r
3115         PUSHJ   P,VALPD1                ;UPDATE SPSAV\r
3116         MOVEI   A,PSAV-SPSAV(A)\r
3117         MOVEI   B,TPDL\r
3118         PUSHJ   P,VALPD1                ;UPDATE PSAV\r
3119         MOVEI   A,TPSAV-PSAV(A)\r
3120         MOVEI   B,TTP\r
3121         PUSHJ   P,VALPD1                ;UPDATE TPSAV\r
3122 ;SKIP TO END OF BLOCK\r
3123         SUBI    A,PSAV-1\r
3124         JRST    VECUP3\r
3125 \r
3126 ;IGNORE A BLOCK\r
3127 IGBLK2: HRRZ    B,(A)           ;GET DISPLACEMENT\r
3128         ADDI    A,3(B)          ;USE IT\r
3129         JRST    VECUP3          ;GO\r
3130 \r
3131 \f; ENTRY PART OF THE STACK UPDATER\r
3132 \r
3133 ENTRUP: ADDI    A,FRAMLN-2      ;POINT PAST FRAME\r
3134         JRST    VECU12          ;NOW REJOIN VECTOR UPDATE\r
3135 \r
3136 ; UPDATE A BINDING BLOCK\r
3137 \r
3138 BINDUP: HRRZ    C,(A)           ;POINT TO CHAIN\r
3139         JUMPE   C,NONEXT        ;JUMP IF NO NEXT BINDING IN CHAIN\r
3140         HRRZ    0,@(P)          ; GET OWN DESTINATION\r
3141         SUBI    0,@(P)          ; RELATIVIZE\r
3142         ADD     C,0             ; AND UPDATE\r
3143         HRRM    C,(A)           ;AND STORE IT BACK\r
3144 NONEXT: CAIN    B,TUBIND\r
3145         JRST    .+3\r
3146         CAIE    B,TBIND         ;SKIP IF VAR BINDING\r
3147         JRST    VECU14          ;NO, MUST BE A VECTOR BIND\r
3148         MOVEI   B,TATOM         ;UPDATE ATOM POINTER\r
3149         PUSHJ   P,VALPD1\r
3150         ADDI    A,2\r
3151         HLRZ    B,(A)           ;TYPE OF VALUE\r
3152         PUSHJ   P,VALPD1\r
3153         ADDI    A,2             ; POINT TO PREV LOCATIVE\r
3154 VECU16: MOVEI   B,TLOCI\r
3155         SKIPN   1(A)            ; IF NO LOCATIVE,\r
3156         MOVEI   B,TUNBOU        ; SAY UNBOUND\r
3157         PUSHJ   P,VALPD1\r
3158         JRST    VECU12\r
3159 \r
3160 VECU14: CAIN    B,TBVL          ; CHANGE BVL TO VEC\r
3161         MOVEI   B,TVEC          ;NOW TREAT LIKE A VECTOR\r
3162         JRST    VECU15\r
3163 \r
3164 ; NOW SAFE TO UPDATE ALL ENTRY BLOCKS\r
3165 \r
3166 ENHACK: HRRZ    F,TBSTO(LPVP)   ;GET POINTER TO TOP FRAME\r
3167         HLLZS   TBSTO(LPVP)     ;CLEAR FIELD\r
3168         HLLZS   TPSTO(LPVP)\r
3169         JUMPE   F,LSTFRM        ;FINISHED\r
3170 \r
3171 ENHCK1: MOVEI   A,FSAV-1(F)     ;POINT PRIOR TO SAVED FUNCTION\r
3172         HRRZ    C,1(A)          ; GET POINTER TO FCN\r
3173         CAML    C,VECBOT        ; SKIP IF A LOSER\r
3174         CAMLE   C,VECTOP        ; SKIP IF A WINNER\r
3175         JRST    ENHCK2\r
3176         HRL     C,(C)           ; MAKE INTO AOBJN\r
3177         MOVEI   B,TVEC\r
3178         PUSHJ   P,VALUPD        ; AND UPDATE\r
3179 ENHCK2: HRRZ    F,2(A)          ;POINT TO PRIOR FRAME\r
3180         MOVEI   B,TTB           ;MARK  SAVED TB\r
3181         PUSHJ   P,[AOJA A,VALPD1]\r
3182         MOVEI   B,TAB           ;MARK ARG POINTER\r
3183         PUSHJ   P,[AOJA A,VALPD1]\r
3184         MOVEI   B,TSP           ;SAVED SP\r
3185         PUSHJ   P,[AOJA A,VALPD1]\r
3186         MOVEI   B,TPDL          ;SAVED P STACK\r
3187         PUSHJ   P,[AOJA A,VALPD1]\r
3188         MOVEI   B,TTP           ;SAVED TP\r
3189         PUSHJ   P,[AOJA A,VALPD1]\r
3190         JUMPN   F,ENHCK1        ;MARK NEXT ONE IF IT EXISTS\r
3191 \r
3192 LSTFRM: HRRZ    A,BINDID(LPVP)  ;NEXT PROCESS\r
3193         HLLZS   BINDID(LPVP)    ;CLOBBER\r
3194         MOVEI   LPVP,(A)\r
3195         JUMPN   LPVP,ENHACK     ;DO NEXT PROCESS\r
3196         POPJ    P,\r
3197 \r
3198 \f; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS\r
3199 \r
3200 VECUP6: JUMPL   E,VECUP7        ;JUMP IF  SPECIAL\r
3201         CAIG    B,2             ;EMPTY UVECTOR ?\r
3202         JRST    VECUP4          ;YES, NOTHING TO UPDATE\r
3203         HLRZS   E               ;ISOLATE TYPE\r
3204         ANDI    E,37777\r
3205         EXCH    E,B             ;TYPE TO B AND LENGTH TO E\r
3206         SUBI    A,(E)           ;POINT TO NEXT DOPE WORD\r
3207         LSH     B,1             ;FIND SAT\r
3208         HRRZ    B,@TYPNT\r
3209         ANDI    B,SATMSK\r
3210         MOVE    B,UPDTBS(B)     ;FIND WHERE POINTS\r
3211         CAIN    B,CPOPJ         ;UNMARKED?\r
3212         JRST    VECUP4          ;YES, GO ON TO NEXT VECTOR\r
3213         PUSH    P,B             ;SAVE SR POINTER\r
3214         SUBI    E,2             ;DON'T COUNT DOPE WORDS\r
3215 \r
3216 VECUP8: MOVE    C,1(A)          ;GET GOODIE\r
3217         MOVEI   0,(C)           ; ISOLATE ADDR\r
3218         JUMPE   0,.+3           ; NEVER 0 PNTR\r
3219         CAIGE   0,@PURBOT       ; OR IF PURE\r
3220         PUSHJ   P,@(P)          ;CALL UPDATE ROUTINE\r
3221         ADDI    A,1\r
3222         SOJG    E,VECUP8        ;LOOP FOR ALL ELEMNTS\r
3223 \r
3224         SUB     P,[1,,1]        ;REMOVE RANDOMNESS\r
3225         JRST    VECUP4\r
3226 \r
3227 ; SPECIAL VECTOR UPDATE\r
3228 \r
3229 VECUP7: HLRZS   E               ;ISOLATE SPECIAL TYPE\r
3230         CAIN    E,SATOM+400000  ;ATOM?\r
3231         JRST    ATOMUP          ;YES, GO DO IT\r
3232         CAIN    E,STPSTK+400000 ;STACK\r
3233         JRST    VECU10          ;TREAT LIKE A VECTOR\r
3234         CAIN    E,SPVP+400000   ;PROCESS VECTOR\r
3235         JRST    PVPUP           ;DO SPECIAL STUFF\r
3236         CAIN    E,SASOC+400000\r
3237         JRST    ASOUP           ;UPDATE ASSOCIATION BLOCK\r
3238 \r
3239         TRZ     E,400000        ; CHECK FOR TEMPLATE VECTOR\r
3240         CAIG    E,NUMSAT        ; SKIP IF POSSIBLE\r
3241         FATAL AGC--UNRECOGNIZED SPECIAL VECTOR (UPDATE)\r
3242         MOVEI   E,-NUMSAT-1(E)\r
3243         HRLI    E,(E)\r
3244         ADD     E,TD.LNT+1(TVP)\r
3245         SKIPL   E\r
3246         FATAL AGC--BAD TEMPLATE TYPE\r
3247 \r
3248 TD.UPD: MOVEI   C,-1(A)         ; POINTER TO OBJECT IN C\r
3249         XCT     (E)\r
3250         HLRZ    D,B             ; POSSIBLE BASIC LENGTH\r
3251         PUSH    P,[0]\r
3252         PUSH    P,D\r
3253         MOVEI   B,(B)           ; ISOLATE LENGTH\r
3254         PUSH    P,C             ; SAVE POINTER TO OBJECT\r
3255 \r
3256         PUSH    P,[0]           ; HOME FOR VALUES\r
3257         PUSH    P,[0]           ; SLOT FOR TEMP\r
3258         PUSH    P,B             ; SAVE\r
3259         SUB     E,TD.LNT+1(TVP)\r
3260         PUSH    P,E             ; SAVE FOR FINDING OTHER TABLES\r
3261         JUMPE   D,TD.UP2        ; NO REPEATING SEQ\r
3262         ADD     E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
3263         HLRE    E,(E)           ; E ==> - LNTH OF TEMPLATE\r
3264         ADDI    E,(D)           ; E ==> -LENGTH OF REP SEQ\r
3265         MOVNS   E\r
3266         HRLM    E,-5(P)         ; SAVE IT AND BASIC\r
3267 \r
3268 TD.UP2: SKIPG   D,-1(P)         ; ANY LEFT?\r
3269         JRST    TD.UP1\r
3270 \r
3271         MOVE    E,TD.GET+1(TVP)\r
3272         ADD     E,(P)\r
3273         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
3274         MOVEM   D,-6(P)         ; SAVE ELMENT #\r
3275         SKIPN   B,-5(P)         ; SKIP IF "RESTS" EXIST\r
3276         SOJA    D,TD.UP3\r
3277 \r
3278         MOVEI   0,(B)           ; BASIC LNT TO 0\r
3279         SUBI    0,(D)           ; SEE IF PAST BASIC\r
3280         JUMPGE  0,.-3           ; JUMP IF O.K.\r
3281         MOVSS   B               ; REP LNT TO RH, BASIC TO LH\r
3282         IDIVI   0,(B)           ; A==> -WHICH REPEATER\r
3283         MOVNS   A\r
3284         ADD     A,-5(P)         ; PLUS BASIC\r
3285         ADDI    A,1             ; AND FUDGE\r
3286         MOVEM   A,-6(P)         ; SAVE FOR PUTTER\r
3287         ADDI    E,-1(A)         ; POINT\r
3288         SOJA    D,.+2\r
3289 \r
3290 TD.UP3: ADDI    E,(D)           ; POINT TO SLOT\r
3291         XCT     (E)             ; GET THIS ELEMENT INTO A AND B\r
3292         MOVEM   A,-3(P)         ; SAVE TYPE FOR LATER PUT\r
3293         MOVEM   B,-2(P)\r
3294         MOVE    C,B             ; VALUE TO C FOR VALUPD\r
3295         GETYP   B,A\r
3296         MOVEI   A,-3(P)         ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG\r
3297         MOVSI   D,400000        ; RESET FOR MARK\r
3298         PUSHJ   P,VALUPD        ; AND MARK THIS GUY (RET FIXED POINTER IN A)\r
3299         MOVE    C,-4(P)         ; GET POINTER FOR UPDATE OF ELEMENT\r
3300         MOVE    E,TD.PUT+1(TVP)\r
3301         SOS     D,-1(P)         ; RESTORE COUNT\r
3302         ADD     E,(P)\r
3303         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
3304         MOVE    B,-6(P)         ; SAVED OFFSET\r
3305         ADDI    E,(B)-1         ; POINT TO SLOT\r
3306         MOVE    A,-3(P)         ; RESTORE TYPE WORD\r
3307         MOVE    B,-2(P)\r
3308         XCT     (E)             ; SMASH IT BACK\r
3309         FATAL TEMPLATE LOSSAGE\r
3310         MOVE    C,-4(P)\r
3311         JRST    TD.UP2\r
3312 \r
3313 TD.UP1: SUB     P,[7,,7]\r
3314         MOVSI   D,400000        ; RESTORE MARK/UNMARK BIT\r
3315         JRST    VECUP4\r
3316 \r
3317 \f; UPDATE ATOM VALUE CELLS\r
3318 \r
3319 ATOMUP: SUBI    A,-1(B)         ; POINT TO VALUE CELL\r
3320         HLRZ    B,(A)\r
3321         HRRZ    0,(A)           ;GOBBLE BINDID\r
3322         JUMPN   0,.+3           ;NOT GLOBAL\r
3323         CAIN    B,TLOCI         ;IS IT A LOCATIVE?\r
3324         MOVEI   B,TVEC          ;MARK AS A VECTOR\r
3325         HRRZ    0,1(A)          ; GET POINTER\r
3326         CAML    0,VECBOT\r
3327         CAMLE   0,VECTOP\r
3328         JRST    .+2             ; OUT OF BOUNDS, DONT UPDATE\r
3329         PUSHJ   P,VALPD1        ;UPDATE IT\r
3330         MOVEI   B,TOBLS         ; TYPE TO OBLIST\r
3331         SKIPGE  2(A)\r
3332         PUSHJ   P,[AOJA A,VALPD1]\r
3333         JRST    VECUP4\r
3334 \r
3335 ; UPDATE PROCESS VECTOR\r
3336 \r
3337 PVPUP:  SUBI    A,-1(B)         ;POINT TO TOP\r
3338         HRRM    LPVP,BINDID(A)  ;CHAIN ALL PROCESSES TOGETHER\r
3339         MOVEI   LPVP,(A)\r
3340         HRRZ    0,TBSTO+1(A)    ;POINT TO CURRENT FRAME\r
3341         HRRM    0,TBSTO(A)      ;SAVE\r
3342         HRRZ    0,TPSTO+1(A)    ;0_SAVED TP POINTER\r
3343         HLRE    B,TPSTO+1(A)\r
3344         SUBI    0,-1(B)         ;0 _ POINTER TO OLD DOPE WORD\r
3345         HRRM    0,TPSTO(A)\r
3346         JRST    VECUP3\r
3347 \r
3348 \r
3349 \f;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS\r
3350 \r
3351 ASOUP:  SUBI    A,-1(B)         ;POINT TO START OF BLOCK\r
3352         HRRZ    B,ASOLNT-1(A)   ;POINT TO NEXT\r
3353         JUMPE   B,ASOUP1\r
3354         HRRZ    C,ASOLNT+1(B)   ;AND GET ITS RELOC IN C\r
3355         SUBI    C,ASOLNT+1(B)   ; RELATIVIZE\r
3356         ADDM    C,ASOLNT-1(A)   ;C NOW HAS UPDATED PONTER\r
3357 ASOUP1: HLRZ    B,ASOLNT-1(A)   ;GET PREV BLOCK POINTER\r
3358         JUMPE   B,ASOUP2\r
3359         HRRZ    F,ASOLNT+1(B)   ;AND ITS RELOCATION\r
3360         SUBI    F,ASOLNT+1(B)   ; RELATIVIZE\r
3361         MOVSI   F,(F)\r
3362         ADDM    F,ASOLNT-1(A)   ;RELOCATE\r
3363 ASOUP2: HRRZ    B,NODPNT(A)             ;UPDATE NODE CHAIN\r
3364         JUMPE   B,ASOUP4\r
3365         HRRZ    C,ASOLNT+1(B)           ;GET RELOC\r
3366         SUBI    C,ASOLNT+1(B)   ; RELATIVIZE\r
3367         ADDM    C,NODPNT(A)     ;ANID UPDATE\r
3368 ASOUP4: HLRZ    B,NODPNT(A)     ;GET PREV POINTER\r
3369         JUMPE   B,ASOUP5\r
3370         HRRZ    F,ASOLNT+1(B)   ;RELOC\r
3371         SUBI    F,ASOLNT+1(B)\r
3372         MOVSI   F,(F)\r
3373         ADDM    F,NODPNT(A)\r
3374 ASOUP5: HRLI    A,-3            ;SET TO UPDATE OTHER CONTENTS\r
3375 \r
3376 ASOUP3: HLRZ    B,(A)           ;GET TYPE\r
3377         PUSHJ   P,VALPD1        ;UPDATE\r
3378         ADD     A,[1,,2]        ;MOVE POINTER\r
3379         JUMPL   A,ASOUP3\r
3380         JRST    VECUP4          ;AND QUIT\r
3381 \r
3382 \f;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE\r
3383 ;GETS POINTER TO TYPE CELL IN RH OF A\r
3384 ;TYPE IN RH OF B (LH MUST BE 0)\r
3385 ;VALUE IN C\r
3386 \r
3387 VALPD1: MOVE    C,1(A)          ;GET VALUE TO UPDATE\r
3388 VALUPD: MOVEI   0,(C)\r
3389         CAIGE   0,@PURBOT       ; SKIP IF PURE, I.E. DONT HACK\r
3390         TRNN    C,-1            ;ANY POINTER PART?\r
3391         JRST    CPOPJ           ;NO, LEAVE\r
3392         ANDI    B,TYPMSK\r
3393         LSH     B,1             ;SET TYPE TIMES 2\r
3394         HRRZ    B,@TYPNT        ;GET STORAGE ALLOCATION TYPE\r
3395         ANDI    B,SATMSK\r
3396         CAIG    B,NUMSAT                ; SKIP IF TEMPLATE\r
3397         JRST    @UPDTBS(B)      ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE\r
3398         AOJA    C,TMPLUP\r
3399 \r
3400 ;SAT DISPATCH TABLE\r
3401 \r
3402 DISTBS UPDTBS,CPOPJ,[[SNWORD,NWRDUP],[STPSTK,STCKUP]\r
3403 [SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP]\r
3404 [SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP]\r
3405 [SLOCA,ARGUP],[SLOCU,NWRDUP],[SLOCN,ASUP],[SLOCS,BYTUP],[SGATOM,NWRDUP]]\r
3406 \r
3407 \r
3408 \r
3409 \r
3410 ;PAIR POINTER UPDATE\r
3411 2WDUP:  MOVEI   0,(C)\r
3412         CAIGE   0,@PURBOT       ; SKIP AND IGNORE IF PURE\r
3413         TRNN    C,-1            ;POINT TO NIL?\r
3414         POPJ    P,              ;YES -- NO UPDATE NEEDED\r
3415         SKIPGE  B,(C)           ;NO -- IS THIS A BROKEN HEART\r
3416         HRRM    B,1(A)          ;YESS -- STORE NEW VALUE\r
3417         SKIPE   B,PARNEW        ;IF LIST SPACE IS MOVING\r
3418         ADDM    B,1(A)          ;THEN ADD OFFSET TO VALUE\r
3419         POPJ    P,              ;FINISHED\r
3420 \r
3421 ; HERE TO UPDATE ASSOCIATIONS\r
3422 \r
3423 ASUP:   HRLI    C,-ASOLNT       ;MAKE INTO VECTOR POINTER\r
3424         JRST    NWRDUP\r
3425 \f;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE\r
3426 \r
3427 LOCUP:  HRRZ    B,(A)           ;CHECK IF IT IS TIMED\r
3428         JUMPN   B,LOCUP1        ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE\r
3429 \r
3430 NWRDUP: HLRE    B,C             ;EXTEND COUNT IN B\r
3431         SUBI    C,-1(B)         ;SET C TO POINT TO DOPE WORD\r
3432 TMPLUP: HRRZ    B,(C)           ;EXTEND RELOCATION IN B\r
3433         SUBI    B,(C)           ; RELATIVIZE\r
3434         ADDM    B,1(A)          ;AND ADD RELOCATION TO STORED DATUM\r
3435         HRRZ    C,-1(C)         ;GET GROWTH SPECS\r
3436         JUMPE   C,CPOPJ         ;NO GROWTH, LEAVE\r
3437         LDB     C,[111100,,C]   ;GET UPWORD GROWTH\r
3438         TRZN    C,400           ;FLUSH SIGN AN NEGATR DIRECTION\r
3439         MOVNS   C\r
3440         SKIPE   GCDNTG          ; SKIP IF GROWTH WINS\r
3441         JUMPL   C,CPOPJ         ; POS GROWTH, LOSE\r
3442         ASH     C,6+18.         ;TO LH AND TIMES 100(8)\r
3443         ADDM    C,1(A)          ;UPDATE POINTER\r
3444         POPJ    P,\r
3445 \r
3446 \r
3447 LOCUP1:\r
3448 STCKUP: MOVSI   B,PDLBUF        ;GET OFFSET FOR PDLS\r
3449         ADDM    B,1(A)          ;AND ADD TO COUNT\r
3450         JRST    NWRDUP          ;NOW TREAT LIKE VECTOR\r
3451 \r
3452 BYTUP:  MOVEI   C,(A)           ; SET TO GET DOPE WORD\r
3453         PUSH    P,A\r
3454         PUSHJ   P,BYTDOP\r
3455         POP     P,C\r
3456         HRRZ    B,(A)           ;SET B TO RELOCATION FOR THIS VEC\r
3457         SUBI    B,(A)           ; RELATIVIZE\r
3458         ADDM    B,1(C)          ;AND UPDATE VALUE\r
3459         MOVE    A,C             ; FIX UP FOR SCANNER\r
3460         POPJ    P,              ;DONE WITH UPDATE\r
3461 \r
3462 ARGUP:\r
3463 ABUP:   HLRE    B,C             ;GET LENGTH\r
3464         SUB     C,B             ;POINT TO FRAME\r
3465         HLRZ    B,(C)           ;GET TYPE OF NEXT GOODIE\r
3466         ANDI    B,TYPMSK\r
3467         CAIN    B,TINFO         ;IS IT A FRAME\r
3468         ADD     C,1(C)          ;NO, POINT TO FRAME\r
3469         CAIE    B,TINFO ;IF IT IS A FRAME\r
3470         ADDI    C,FRAMLN        ;POINT TO ITS BASE\r
3471 TBUP:   MOVE    C,TPSAV(C)      ;GET A ASTACK POINTER TO FIND DOPE WORD\r
3472         HLRE    B,C             ;UPDATE BASED ON THIS POINTER\r
3473         SUBI    C,(B)\r
3474 ABUP1:  HRRZ    B,1(C)          ;GET RELOCATION\r
3475         SUBI    B,1(C)          ; RELATIVIZE\r
3476         ADDM    B,1(A)          ;AND MUNG POINTER\r
3477         POPJ    P,\r
3478 \r
3479 FRAMUP: HRRZ    B,(A)           ;UPDATE PVP\r
3480         HRRZ    C,(B)           ;IN CELL\r
3481         SUBI    C,(B)           ; RELATIVIZE\r
3482         ADDM    C,(A)\r
3483         HLRZ    C,(B)\r
3484         ANDI    C,377777\r
3485         SUBI    B,-1(C)         ;ADDRESS OF PV\r
3486         HRRZ    C,TPSTO(B)              ;IF TPSTO HAS OLD TP DOPE WORD,\r
3487         JUMPN   C,ABUP2         ;USE IT\r
3488         HRRZ    C,TPSTO+1(B)            ;ELSE, GENERATE IT\r
3489         HLRE    B,TPSTO+1(B)\r
3490         SUBI    C,-1(B)\r
3491 ABUP2:  SOJA    C,ABUP1         ; FUDGE AND GO\r
3492 \r
3493 \f;VECTOR SHRINKING PHASE\r
3494 \r
3495 VECSH:  SUBI    A,1             ;POOINT TO 1ST DOPE WORD\r
3496 VECSH1: CAMGE   A,VECBOT        ;FINISHED\r
3497         POPJ    P,              ;YES, QUIT\r
3498         HRRZ    B,-1(A)         ;GET A SPEC\r
3499         JUMPE   B,NXTSHN        ;IGNORE IF NONE\r
3500         PUSHJ   P,GETGRO        ;GET THE SPECS\r
3501         JUMPGE  C,SHRNBT        ;SHRINKIGN AT BOTTOM\r
3502         MOVEI   E,(A)           ;COPY POINTER\r
3503         ADD     A,C             ;POINT TO NEW DOPE LOCATION WITH E\r
3504         MOVE    F,-1(E)         ;GET OLD DOPE\r
3505         ANDCMI  F,777000        ;KILL THIS SPEC\r
3506         MOVEM   F,-1(A)         ;STORE\r
3507         MOVE    F,(E)           ;OTHER DOPE WORD\r
3508         ADD     F,C             ; UPDATE DESTINATION\r
3509         HRLZI   C,(C)           ;TO LH\r
3510         ADD     F,C             ;CHANGE LENGTH\r
3511         MOVEM   F,(A)           ;AND STORE\r
3512         MOVMS   C               ;PLUSIFY\r
3513         HRRI    C,(E)           ; MAKE NOT MOVE\r
3514         MOVEM   C,(E)           ;AND STORE\r
3515         SETZM   -1(E)\r
3516 SHRNBT: JUMPGE  B,NXTSHN        ;GROWTH, IGNOORE\r
3517         MOVM    E,B             ;GET A POSITIVE COPY\r
3518         HRLZI   B,(B)           ;TO LH\r
3519         ADDM    B,(A)           ;ADD INTO DOPE WORD\r
3520         MOVEI   0,777           ;SET TO CLOBBER GROWTH\r
3521         ANDCAM  0,-1(A)         ;CLOBBER\r
3522         HLRZ    B,(A)           ;GET NEW LENGTH\r
3523         SUBI    A,(B)           ;POINT TO LOW END\r
3524         HRLI    E,(A)           ; MAKE NON MOVER\r
3525         MOVSM   E,(A)           ;STORE\r
3526         SETZM   -1(A)\r
3527 \r
3528 NXTSHN: HLRZ    B,(A)           ;GET LENGTH\r
3529         JUMPE   B,VCMLOS        ;LOOSE\r
3530         SUBI    A,(B)           ;STEP\r
3531         JRST    VECSH1\r
3532 \r
3533 GETGRO: LDB     C,[111100,,B]   ;GET UPWARD GROWTH\r
3534         TRZE    C,400           ;CHECK AND MUNG SIGN\r
3535         MOVNS   C\r
3536         ASH     C,6             ;?IMES 100\r
3537         ANDI    B,777           ;AND GET DOWN GROWTH\r
3538         TRZE    B,400           ;CHECK AND MUNG SIGN\r
3539         MOVNS   B\r
3540         ASH     B,6\r
3541         POPJ    P,\r
3542 \f;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF\r
3543 ;VECTORS INDICATE.  MOVES DOPEWDS UP FOR VECTORS GROWING AT\r
3544 ;THE END.\r
3545 ;CALLED WITH VECTOP IN A.  CALLS PARMOV TO MOVE PAIRS\r
3546 \r
3547 VECMOV: SUBI    A,1             ;SET A TO ADDR OF TOP DOPE WD\r
3548         MOVSI   D,400000        ;NEGATIVE D MARKS END OF BACK CHAIN\r
3549         MOVEI   TYPNT,0         ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME\r
3550 VECMO1: CAMGE   A,VECBOT        ;GOT TO BOTTOM OF VECTORS\r
3551         JRST    PARMOV          ;YES, MOVE LIST ELEMENTS AND RETURN\r
3552         MOVEI   C,(A)           ;NO, COPY ADDR OF THIS DOPEWD\r
3553         HRRZ    B,(A)           ;GET RELOCATION OF THIS VECTOR\r
3554         SUBI    B,(A)           ; RELATIVIZE\r
3555         JUMPL   B,VECMO5        ;IF MOVING DOWNWARD, MAKE BACK CHAIN\r
3556         JUMPE   B,VECMO4        ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON\r
3557 \r
3558         ADDI    C,(B)           ;SET ADDR OF LAST DESTINATION WD\r
3559         HRLI    B,A             ;MAKE B INDEX ON A\r
3560         HLL     A,(A)           ;COUNT TO A LEFT HALF\r
3561 \r
3562         POP     A,@B            ;MOVE A WORD\r
3563         TLNE    A,-1            ;REACHED END OF MOVING\r
3564         JRST    .-2             ;NO, REPEAT\r
3565                 ;YES, NOTE A HAS ADDR OF NEXT DOPEWD\r
3566 \f;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY)\r
3567 VECMO2: LDB     B,[111000,,-1(C)]               ;GET HIGH GROWTH FIELD\r
3568         JUMPE   B,VECMO3        ;IF NO GROWTH, DONT MOVE\r
3569         SKIPE   GCDNTG          ; SKIP IF GROWTH PERMITTED\r
3570         JRST    VECMO3\r
3571         ASH     B,6             ;EXPRESS GROWTH IN WORDS\r
3572         HRLI    C,2             ;SET COUNT FOR POPPING 2 DOPEWDS\r
3573         HRLI    B,C             ;MAKE B INDEX ON C\r
3574         POP     C,@B            ;MOVE PRIME DOPEWD\r
3575         POP     C,@B            ;MOVE AUX DOPEWD\r
3576 VECMO3: JUMPL   D,VECMO1        ;IF NO BACK CHAIN THEN MOVE ON\r
3577         JRST    VECMO6          ;YES, BACKCHAINING, CONTINUE SAME\r
3578 \r
3579 ;HERE TO SKIP OVER STILL VECTORS (FORWARDLY)\r
3580 VECMO4: HLRZ    B,(A)           ;GET SIZE OF UNMOVER\r
3581         SUBI    A,(B)           ;UPDATE A TO NEXT VECTOR\r
3582         JRST    VECMO2          ;AND GO CLEAN UP GROWTH\r
3583 ;HERE TO ESTABLISH A BACKWARDS CHAIN\r
3584 VECMO5: EXCH    D,(A)           ;CHAIN FORWARD\r
3585         HLRZ    B,D             ;GET SIZE\r
3586         SUBI    A,(B)           ;GO ON TO NEXT VECOTR\r
3587         CAMGE   A,VECBOT        ;HAVE WE GOT TO END OF VECTORS?\r
3588         JRST    VECMO7          ;YES, GO MOVE PAIRS AND UNCHAIN\r
3589         HRRZ    B,(A)           ;GET RELOCATION OF THIS VECTOR\r
3590         SUBI    B,(A)           ; RELATIVIZE\r
3591         JUMPLE  B,VECMO5        ;IF NOT POSITIVE, CONTINUE CHAINING\r
3592         MOVEM   A,TYPNT         ;SAVE ADDR FOR FORWARD RESUME\r
3593 \r
3594 ;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS\r
3595 VECMO6: HLRZ    B,D             ;GET SIZE\r
3596         MOVEI   F,1(A)          ;GET A COPY OF BEGINNING OF VECTOR\r
3597         ADDI    A,(B)           ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D\r
3598         EXCH    D,(A)           ;AND UNCHAIN\r
3599         HRRZ    B,(A)           ;GET RELOCATION FOR THIS VECTOR\r
3600         SUBI    B,(A)           ; RELATIVIZE\r
3601         MOVEI   C,(A)           ;COPY A POINTER TO DOPEW\r
3602         SKIPGE  D               ;HAVE WE REACHED THE TOP OF THE CHAIN?\r
3603         MOVE    A,TYPNT         ;YES,   RESTORE FORWARD MOVE RESUME ADDR\r
3604         JUMPE   B,VECMO2        ;IF STILL VECTOR,GO ADJUST DOPEWDS\r
3605         ADDI    C,(B)           ;MAKE C POINT TO NEW DOPEW ADDR\r
3606         ADDI    B,(F)           ;B RH NEW 1ST WORD\r
3607         HRLI    B,(F)           ;B LH OLD 1ST WD ADDR\r
3608         BLT     B,(C)           ;COPY THE DATA\r
3609         JRST    VECMO2          ;AND GO ADJUST DOPEWDS\r
3610 \r
3611 ;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE\r
3612 VECMO7: MOVEM   A,TYPNT\r
3613         PUSH    P,D\r
3614         PUSHJ   P,PARMOV\r
3615         POP     P,D\r
3616         MOVE    A,TYPNT\r
3617         JRST    VECMO6\r
3618 \f;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS\r
3619 ;TO NEW HOMES\r
3620 \r
3621 PARMOV: SKIPN   A,PARNEW        ;IS THERE ANY PAIR MOVEMENT?\r
3622         POPJ    P,              ;NO, RETURN\r
3623         JUMPL   A,PARMO2        ;YES -- IF MOVING DOWNWARDS, GO DO A BLT\r
3624         HRLI    A,B             ;MOVING UPWARDS SETAC A TO INDEX OFF AC B\r
3625         MOVE    B,PARTOP        ;GET HIGH PAIR ADDREESS\r
3626         SUB     B,PARBOT        ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS\r
3627         HRLZS   B               ;PUT COUNT IN LEFT HALF\r
3628         HRR     B,PARTOP        ;GET HIGH ADDRESS PLUS ONE IN RH\r
3629         SUBI    B,1             ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED\r
3630 \r
3631 PARMO1: TLNN    B,-1            ;HAS COUNT REACHED ZERO?\r
3632         JRST    PARMO3          ;YES -- FINISH UP\r
3633         POP     B,@A            ;NO -- TRANSFER2Y\eU NEXT WORD\r
3634         JRST    PARMO1          ;AND REPEAT\r
3635 \r
3636 PARMO2: MOVE    B,PARBOT        ;GET ADDRESS OF FIRST SOURCE WD\r
3637         HRLS    B               ;IN BOTH HALVES OF AC B\r
3638         ADD     B,A             ;MAKE RH OF B POINT TO FIRST DESTINATION WORD\r
3639         ADD     A,PARTOP        ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE\r
3640         BLT     B,-1(A)         ;AND TRANSFER THE BLOCK OF PAIRS\r
3641 \r
3642 PARMO3: MOVE    A,PARNEW        ;GET OFFSET FOR PAIR SPACE\r
3643         ADDM    A,PARBOT        ;AND CORRECT BOTTOM\r
3644         ADDM    A,PARTOP        ;AND CORRECT TOP.\r
3645         SETZM   PARNEW          ;CLEAR SO IF CALLED TWICE, NO LOSSAGE\r
3646         POPJ    P,\r
3647 \f;VECZER -- CLEARS DATA IN AREAS JUST GROWN\r
3648 ;UPDATES SIZE OF VECTORS\r
3649 ;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS\r
3650 ;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO)\r
3651 \r
3652 VECZER: SUBI    A,1             ;MAKE A POINT TO HIGH VECTORS\r
3653 VECZE1: CAMGE   A,VECBOT        ;REACHED BOTTOM OF VECTORS?\r
3654         POPJ    P,              ;YES, RETURN\r
3655         HLLZS   F,(A)           ;NO, CLEAR RELOCATION GET SIZE\r
3656         HLRZS   F               ;AND PUT SIZE IN RH OF F\r
3657         HRRZ    B,-1(A)         ;GET GROWTH INTO B\r
3658         JUMPN   B,VECZE3        ;IF THERE IS SOME GROWTH, GO DO IT\r
3659 VECZE2: SUBI    A,(F)           ;GROWTH DONE, MOVE ON TO NEXT VECTOR\r
3660         JRST    VECZE1          ;AND REPEAT\r
3661 \r
3662 VECZE3: HLLZS   -1(A)           ;CLEAR GROWTH IN THE VECTOR\r
3663         LDB     C,[111000,,B]           ;GET HIGH ORDER GROWTH IN C\r
3664         SKIPE   GCDNTG\r
3665         JRST    VECZE5\r
3666         ANDI    B,377           ;AND LIMIT B TO LOW SIDE\r
3667         ASHC    B,6             ;EXPRESS GROWTH IN WORDS\r
3668         JUMPE   C,VECZE4        ;IF NO HIGH GROWTH SKIP TO LOW GROWTH\r
3669         ADDI    F,(C)           ;ADD HIGH GROWTH TO SIZE\r
3670         SUBM    A,C             ;GET ADDR OF 2ND WD TO BE ZEROED\r
3671         SETZM   -1(C)           ;CLEAR 1ST WORD\r
3672         HRLI    C,-1(C)         ;MAKE C A CLEARING BLT POINTER\r
3673         BLT     C,-2(A)         ;AND CLEAR HIGH END DATA\r
3674 \r
3675 VECZE4: JUMPE   B,VECZE5        ;IF NO LOW GROWTH SKIP TO SIZE UPDATE\r
3676         MOVNI   C,(F)           ;GET NEGATIVE SIZE SO FAR\r
3677         ADDI    C,(A)           ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED\r
3678         ADDI    F,(B)           ;UPDATE SIZE\r
3679         SUBM    C,B             ;MAKE B POINT TO LAST WD OF NEXT VECT\r
3680         ADDI    B,2             ;AND NOW TO 2ND DATA WD TO BE CLEARED\r
3681         SETZM   -1(B)           ;CLEAR 1ST DATA WD\r
3682         HRLI    B,-1(B)         ;MAKE B A CLEARING BLT POINTER\r
3683         BLT     B,(C)           ;AND CLEAR THE LOW DATA\r
3684 \r
3685 VECZE5: HRLZM   F,(A)           ;STORE THE NEW SIZE IN DOPEWD\r
3686         JRST    VECZE2\r
3687 \r
3688 \f;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE\r
3689 \r
3690 REHASH: MOVE    TVP,TVPSTO+1(PVP)       ;RESTORE TV POINTER\r
3691         MOVE    D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR\r
3692         MOVEI   E,(D)\r
3693         PUSH    P,E             ;PUSH A POINTER\r
3694         HLRE    A,D             ;GET -LENGTH\r
3695         MOVMS   A               ;AND PLUSIFY\r
3696         PUSH    P,A             ;PUSH IT ALSO\r
3697 \r
3698 REH3:   HRRZ    C,(D)           ;POINT TO FIRST BUCKKET\r
3699         HLRZS   (D)             ;MAKE SURE NEW POINTER IS IN RH\r
3700         JUMPE   C,REH1          ;BUCKET EMPTY, QUIT\r
3701 \r
3702 REH2:   MOVEI   E,(C)           ;MAKE A COPY OF THE POINTER\r
3703         MOVE    A,ITEM(C)       ;START HASHING\r
3704         TLZ     A,TYPMSK#777777 ; KILL MONITORS\r
3705         XOR     A,ITEM+1(C)\r
3706         MOVE    0,INDIC(C)\r
3707         TLZ     0,TYPMSK#777777\r
3708         XOR     A,0\r
3709         XOR     A,INDIC+1(C)\r
3710         TLZ     A,400000        ;MAKE SURE FINAL HASH IS +\r
3711         IDIV    A,(P)           ;DIVIDE BY TOTAL LENGTH\r
3712         ADD     B,-1(P)         ;POINT TO WINNING BUCKET\r
3713 \r
3714         MOVE    C,[002200,,(B)] ;BYTE POINTER TO RH\r
3715         CAILE   B,(D)           ;IF PAST CURRENT POINT\r
3716         MOVE    C,[222200,,(B)] ;USE LH\r
3717         LDB     A,C             ;GET OLD VALUE\r
3718         DPB     E,C             ;STORE NEW VALUE\r
3719         HRRZ    B,ASOLNT-1(E)   ;GET NEXT POINTER\r
3720         HRRZM   A,ASOLNT-1(E)   ;AND CLOBBER IN NEW NEXT\r
3721         SKIPE   A               ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET\r
3722         HRLM    E,ASOLNT-1(A)   ;OTHERWISE CLOBBER\r
3723         SKIPE   C,B             ;SKIP IF END OF CHAIN\r
3724         JRST    REH2\r
3725 REH1:   AOBJN   D,REH3\r
3726 \r
3727         SUB     P,[2,,2]        ;FLUSH THE JUNK\r
3728         POPJ    P,\r
3729 \fVCMLOS:        FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH\r
3730 \r
3731 \r
3732 ; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC\r
3733 \r
3734 MSGGCT: [ASCIZ /USER CALLED- /]\r
3735         [ASCIZ /FREE STORAGE- /]\r
3736         [ASCIZ /TP-STACK- /]\r
3737         [ASCIZ /TOP-LEVEL LOCALS- /]\r
3738         [ASCIZ /GLOBAL VALUES- /]\r
3739         [ASCIZ /TYPES- /]\r
3740         [ASCIZ /STATIONARY IMPURE STORAGE- /]\r
3741         [ASCIZ /P-STACK /]\r
3742         [ASCIZ /BOTH STACKS BLOWN- /]\r
3743         [ASCIZ /PURE STORAGE- /]\r
3744         [ASCIZ /GC-RCALL- /]\r
3745 \r
3746 ; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC\r
3747 \r
3748 MSGGFT: 0\r
3749         [ASCIZ /BLOAT /]\r
3750         [ASCIZ /GROW /]\r
3751         [ASCIZ /LIST /]\r
3752         [ASCIZ /VECTOR /]\r
3753         [ASCIZ /SET /]\r
3754         [ASCIZ /SETG /]\r
3755         [ASCIZ /FREEZE /]\r
3756         [ASCIZ /PURE-PAGE LOADER /]\r
3757         [ASCIZ /GC /]\r
3758         [ASCIZ /INTERRUPT-HANDLER /]\r
3759         [ASCIZ /NEWTYPE /]      \r
3760 \r
3761 \r
3762 \r
3763 \f\r
3764 ;LOCAL VARIABLES\r
3765 \r
3766 IMPURE\r
3767 ; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.\r
3768 ;\r
3769 \r
3770 GCNO:   0                       ; USER-CALLED GC\r
3771 BSTGC:  0                       ; FREE STORAGE\r
3772         0                       ; BLOWN TP\r
3773         0                       ; TOP-LEVEL LVALS\r
3774         0                       ; GVALS\r
3775         0                       ; TYPE\r
3776         0                       ; STORAGE\r
3777         0                       ; P-STACK\r
3778         0                       ; BOTH STATCKS BLOWN\r
3779         0                       ; STORAGE\r
3780 \r
3781 BSTAT:\r
3782 NOWFRE: 0                       ; FREE STORAGE FROM LAST GC\r
3783 CURFRE: 0                       ; STORAGE USED SINCE LAST GC\r
3784 MAXFRE: 0                       ; MAXIMUM FREE STORAGE ALLOCATED\r
3785 USEFRE: 0                       ; TOTAL FREE STORAGE USED\r
3786 NOWTP:  0                       ; TP LENGTH FROM LAST GC\r
3787 CURTP:  0                       ; # WORDS ON TP\r
3788 CTPMX:  0                       ; MAXIMUM SIZE OF TP SO FAR\r
3789 NOWLVL: 0                       ; # OF TOP-LEVEL LVAL-SLOTS\r
3790 CURLVL: 0                       ; # OF TOP-LEVEL LVALS\r
3791 NOWGVL: 0                       ; # OF GVAL SLOTS\r
3792 CURGVL: 0                       ; # OF GVALS\r
3793 NOWTYP: 0                       ; SIZE OF TYPE-VECTOR\r
3794 CURTYP: 0                       ; # OF TYPES\r
3795 NOWSTO: 0                       ; SIZE OF STATIONARY STORAGE\r
3796 CURSTO: 0                       ; STATIONARY STORAGE IN USE\r
3797 CURMAX: 0                       ; MAXIMUM BLOCK OF  CONTIGUOUS STORAGE\r
3798 NOWP:   0                       ; SIZE OF P-STACK\r
3799 CURP:   0                       ; #WORDS ON P\r
3800 CPMX:   0                       ; MAXIMUM P-STACK LENGTH SO FAR\r
3801 GCCAUS: 0                       ; INDICATOR FOR CAUSE OF GC\r
3802 GCCALL: 0                       ; INDICATOR FOR CALLER OF GC\r
3803 \r
3804 \r
3805 ; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW\r
3806 LVLINC: 6                       ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS\r
3807 GVLINC: 4                       ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS\r
3808 TYPIC:  1                       ; TYPE INCREMENT ASSUMED TO BE 32 TYPES\r
3809 STORIC: 2000                    ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)\r
3810 \r
3811 \r
3812 RCL:    0                       ; POINTER TO LIST OF RECYCLEABLE LIST CELLS\r
3813 GCMONF: 0                       ; NON-ZERO SAY GIN/GOUT\r
3814 GCDANG: 0                       ; NON-ZERO, STORAGE IS LOW\r
3815 GCDNTG: 0                       ; NON-ZERO ABORT GROWTHS\r
3816 GETNUM: 0                       ;NO OF WORDS TO GET\r
3817 PARNUM: 0                       ;NO OF PAIRS MARKED\r
3818 VECNUM: 0                       ;NO OF WORDS IN MARKED VECTORS\r
3819 CORSET: 0                       ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY\r
3820 CORTOP: 0                       ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY\r
3821 \r
3822 ;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,\r
3823 ;AND WHEN IT WILL GET UNHAPPY\r
3824 \r
3825 SYSMAX: 50.                     ;MAXIMUM SIZE OF MUDDLE\r
3826 FREMIN: 20000                   ;MINIMUM FREE WORDS\r
3827 FREDIF: 10000                   ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS\r
3828 ;POINTER TO GROWING PDL\r
3829 \r
3830 TPGROW: 0                       ;POINTS TO A BLOWN TP\r
3831 PPGROW: 0                       ;POINTS TO A BLOWN PP\r
3832 TIMOUT: 0                       ;POINTS TO TIMED OUT PDL\r
3833 PGROW:  0                       ;POINTS TO A BLOWN P\r
3834 \r
3835 ;IN GC FLAG\r
3836 \r
3837 GCFLG:  0\r
3838 GCFLCH: 0               ; TELL INT HANDLER TO ITIC CHARS\r
3839 GCHAIR: 1               ; COUNTS GCS AND TELLS WHEN TO HAIRIFY\r
3840 SHRUNK: 0               ; NON-ZERO=> AVECTOR(S) SHRUNK\r
3841 GREW:   0               ; NON-ZERO=> A VECTOR(S) GREW\r
3842 SPARNW: 0               ; SAVED PARNEW\r
3843 GCDOWN: 0               ; AMOUNT TO TRY AND MOVE DOWN\r
3844 CURPLN: 0               ; LENGTH OF CURRENTLY RUNNING PURE RSUBR\r
3845 \r
3846 ; VARS ASSOCIATED WITH BLOAT LOGIC\r
3847 \r
3848 TPBINC: 0\r
3849 GLBINC: 0\r
3850 TYPINC: 0\r
3851 \r
3852 ; VARS FOR PAGE WINDOW HACKS\r
3853 \r
3854 WNDBOT: 0                       ; BOTTOM OF WINDOW\r
3855 WNDTOP: 0\r
3856 BOTNEW: (FPTR)                  ; POINTER TO FRONTIER\r
3857 GCTIM:  0\r
3858 \r
3859 PURE\r
3860 \r
3861 \r
3862 END\r
3863 \r
3864 \r
3865 \r
3866 \r
3867 \r
3868 \fTITLE ARITHMETIC PRIMITIVES FOR MUDDLE\r
3869 \r
3870 .GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT\r
3871 .GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG\r
3872 .GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,SAT,BFLOAT\r
3873 \r
3874 ;BKD\r
3875 \r
3876 ;DEFINES MUDDLE PRIMITIVES:   FIX,FLOAT,ATAN,IEXP,LOG,\r
3877 ;       G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,\r
3878 ;       TIME,SORT.\r
3879 \r
3880 RELOCATABLE\r
3881 \r
3882 .INSRT MUDDLE >\r
3883 \r
3884 O=0\r
3885 \r
3886 \r
3887 DEFINE  TYP1\r
3888         (AB) TERMIN\r
3889 DEFINE VAL1\r
3890         (AB)+1 TERMIN\r
3891 \r
3892 DEFINE  TYP2\r
3893         (AB)+2 TERMIN\r
3894 DEFINE  VAL2\r
3895         (AB)+3 TERMIN\r
3896 \r
3897 DEFINE  TYP3\r
3898         (AB)+4 TERMIN\r
3899 DEFINE  VAL3\r
3900         (AB)+5 TERMIN\r
3901 \r
3902 DEFINE  TYPN\r
3903         (D) TERMIN\r
3904 DEFINE  VALN\r
3905         (D)+1 TERMIN\r
3906 \r
3907 \r
3908 YES:    MOVSI   A,TATOM         ;RETURN PATH FOR 'TRUE'\r
3909         MOVE    B,MQUOTE T\r
3910         AOS     (P)\r
3911         POPJ    P,\r
3912 \r
3913 NO:     MOVSI   A,TFALSE        ;RETURN PATH FOR 'FALSE'\r
3914         MOVEI   B,NIL\r
3915         POPJ    P,\r
3916 \r
3917 \f;ERROR RETURNS AND OTHER UTILITY ROUTINES\r
3918 \r
3919 OVRFLW==10\r
3920 OVRFLD: PUSH    TP,$TATOM\r
3921         PUSH    TP,EQUOTE OVERFLOW\r
3922         JRST    CALER1\r
3923 \r
3924 CARGCH: GETYP   0,A             ; GET TYPE\r
3925         CAIN    0,TFLOAT\r
3926         POPJ    P,\r
3927         JSP     A,BFLOAT\r
3928         POPJ    P,\r
3929 \r
3930 ARGCHK:                 ;CHECK FOR SINGLE FIXED OR FLOATING\r
3931                         ;ARGUMENT IF FIXED CONVERT TO FLOATING\r
3932                         ;RETURN FLOATING ARGRUMENT IN B ALWAYS\r
3933         ENTRY   1\r
3934         GETYP   C,TYP1  \r
3935         MOVE    B,VAL1\r
3936         CAIN    C,TFLOAT        ;FLOATING?\r
3937         POPJ    P,              ;YES, RETURN\r
3938         CAIE    C,TFIX          ;FIXED?\r
3939         JRST    WTYP1           ;NO, ERROR\r
3940         JSP     A,BFLOAT        ;YES, CONVERT TO FLOATING AND RETURN\r
3941         POPJ    P,\r
3942 \r
3943 OUTRNG: PUSH    TP,$TATOM\r
3944         PUSH    TP,EQUOTE ARGUMENT-OUT-OF-RANGE\r
3945         JRST    CALER1\r
3946 \r
3947 NSQRT:  PUSH    TP,$TATOM\r
3948         PUSH    TP,EQUOTE NEGATIVE-ARGUMENT\r
3949         JRST    CALER1\r
3950 \r
3951 DEFINE MFLOAT AC\r
3952         IDIVI   AC,400000\r
3953         FSC     AC+1,233\r
3954         FSC     AC,254\r
3955         FADR    AC,AC+1\r
3956         TERMIN\r
3957 \r
3958 BFLOAT: MFLOAT  B\r
3959         JRST    (A)\r
3960 \r
3961 OFLOAT: MFLOAT  O\r
3962         JRST    (C)\r
3963 \r
3964 BFIX:   MULI    B,400\r
3965         TSC     B,B\r
3966         ASH     C,(B)-243\r
3967         MOVE    B,C\r
3968         JRST    (A)\r
3969 \r
3970 \f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES\r
3971 \r
3972 TABLE2: NO      ;TABLE2 (0)\r
3973 TABLE3: YES     ;TABLE2 (1)  &  TABLE3 (0)\r
3974         NO      ;TABLE2 (2)\r
3975         YES\r
3976         NO\r
3977 \r
3978 TABLE4: NO\r
3979         NO\r
3980         YES\r
3981         YES\r
3982 \r
3983 \r
3984 \r
3985 FUNC:   JSP     A,BFIX\r
3986         JSP     A,BFLOAT\r
3987         SUB     B,VALN\r
3988         IDIV    B,VALN\r
3989         ADD     B,VALN\r
3990         IMUL    B,VALN\r
3991         JSP     C,SWITCH\r
3992         JSP     C,SWITCH\r
3993 \r
3994 \r
3995 \r
3996 FLFUNC==.-2\r
3997         FSBR    B,O\r
3998         FDVR    B,O\r
3999         FADR    B,O\r
4000         FMPR    B,O\r
4001         JSP     C,FLSWCH\r
4002         JSP     C,FLSWCH\r
4003 \r
4004 DEFVAL==.-2\r
4005         0\r
4006         1\r
4007         0\r
4008         1\r
4009         377777,,-1\r
4010         400000,,1\r
4011 \r
4012 DEFTYP==.-2\r
4013         TFIX,,\r
4014         TFIX,,\r
4015         TFIX,,\r
4016         TFIX,,\r
4017         TFLOAT,,\r
4018         TFLOAT,,\r
4019 \f;PRIMITIVES FLOAT AND FIX\r
4020 \r
4021 MFUNCTION       FIX,SUBR\r
4022 \r
4023         ENTRY   1\r
4024 \r
4025         JSP     C,FXFL\r
4026         MOVE    B,1(AB)\r
4027         CAIE    A,TFIX\r
4028         JSP     A,BFIX\r
4029         MOVSI   A,TFIX\r
4030         JRST    FINIS\r
4031 \r
4032 MFUNCTION       FLOAT,SUBR\r
4033 \r
4034         ENTRY   1\r
4035 \r
4036         JSP     C,FXFL\r
4037         MOVE    B,1(AB)\r
4038         CAIE    A,TFLOAT\r
4039         JSP     A,BFLOAT\r
4040         MOVSI   A,TFLOAT\r
4041         JRST    FINIS\r
4042 \r
4043 CFIX:   GETYP   0,A\r
4044         CAIN    0,TFIX\r
4045         POPJ    P,\r
4046         JSP     A,BFIX\r
4047         MOVSI   A,TFIX\r
4048         POPJ    P,\r
4049 \r
4050 CFLOAT: GETYP   0,A\r
4051         CAIN    0,TFLOAT\r
4052         POPJ    P,\r
4053         JSP     A,BFLOAT\r
4054         MOVSI   A,TFLOAT\r
4055         POPJ    P,\r
4056 \r
4057 FXFL:   GETYP   A,(AB)\r
4058         CAIE    A,TFIX\r
4059         CAIN    A,TFLOAT\r
4060         JRST    (C)\r
4061         JRST    WTYP1\r
4062 \r
4063 \r
4064 MFUNCTION       ABS,SUBR\r
4065         ENTRY   1\r
4066         GETYP   A,TYP1\r
4067         CAIE    A,TFIX\r
4068         CAIN    A,TFLOAT\r
4069         JRST    MOVIT\r
4070         JRST    WTYP1\r
4071 MOVIT:  MOVM    B,VAL1          ;GET ABSOLUTE VALUE OF ARGUMENT\r
4072 AFINIS: HRLZS   A               ;MOVE TYPE CODE INTO LEFT HALF\r
4073         JRST    FINIS\r
4074 \r
4075 \r
4076 \r
4077 MFUNCTION       MOD,SUBR\r
4078         ENTRY   2\r
4079         GETYP   A,TYP1\r
4080         CAIE    A,TFIX          ;FIRST ARG FIXED ?\r
4081         JRST    WTYP1\r
4082         GETYP   A,TYP2\r
4083         CAIE    A,TFIX          ;SECOND ARG FIXED ?\r
4084         JRST    WTYP2\r
4085         MOVE    A,VAL1\r
4086         IDIV    A,VAL2          ;FORM QUOTIENT & REMAINDER\r
4087         JUMPGE  B,.+2           ;Only return positive remainders\r
4088         ADD     B,VAL2\r
4089         MOVSI   A,TFIX\r
4090         JRST    FINIS\r
4091 \f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX\r
4092 \r
4093 MFUNCTION       MIN,SUBR\r
4094         \r
4095         ENTRY\r
4096 \r
4097         MOVEI   E,6\r
4098         JRST    GOPT\r
4099 \r
4100 MFUNCTION       MAX,SUBR\r
4101 \r
4102         ENTRY\r
4103 \r
4104         MOVEI   E,7\r
4105         JRST    GOPT\r
4106 \r
4107 MFUNCTION       DIVIDE,SUBR,[/]\r
4108 \r
4109         ENTRY\r
4110 \r
4111         MOVEI   E,3\r
4112         JRST    GOPT\r
4113 \r
4114 MFUNCTION       DIFFERENCE,SUBR,[-]\r
4115 \r
4116         ENTRY\r
4117 \r
4118         MOVEI   E,2\r
4119         JRST    GOPT\r
4120 \r
4121 MFUNCTION       TIMES,SUBR,[*]\r
4122 \r
4123         ENTRY\r
4124 \r
4125         MOVEI   E,5\r
4126         JRST    GOPT\r
4127 \r
4128 MFUNCTION       PLUS,SUBR,[+]\r
4129 \r
4130         ENTRY\r
4131 \r
4132         MOVEI   E,4\r
4133 \r
4134 GOPT:   MOVE    D,AB            ;ARGUMENT POINTER\r
4135         HLRE    A,AB\r
4136         MOVMS   A\r
4137         ASH     A,-1\r
4138         PUSHJ   P,CARITH\r
4139         JRST    FINIS\r
4140 \r
4141 ; BUILD COMPILER ENTRIES TO THESE ROUTINES\r
4142 \r
4143 IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]\r
4144 \r
4145 NAME:   MOVEI   E,CODE\r
4146         JRST    CARIT1\r
4147 TERMIN\r
4148 \f\r
4149 CARIT1: MOVEI   D,(A)\r
4150         ASH     D,1             ; TIMES 2\r
4151         SUBI    D,1\r
4152         HRLI    D,(D)\r
4153         SUBM    TP,D            ; POINT TO ARGS\r
4154         PUSH    TP,$TTP\r
4155         PUSH    TP,D\r
4156         PUSHJ   P,CARITH\r
4157         POP     TP,TP\r
4158         SUB     TP,[1,,1]\r
4159         POPJ    P,\r
4160 \r
4161 CARITH: MOVE    B,DEFVAL(E)     ; GET VAL\r
4162         JFCL    OVRFLW,.+1\r
4163         MOVEI   0,TFIX          ; FIX UNTIL CHANGE\r
4164         JUMPN   A,ARITH0        ; AT LEAST ONE ARG\r
4165         MOVE    A,DEFTYP(E)\r
4166         POPJ    P,\r
4167 \r
4168 ARITH0: SOJE    A,ARITH1        ; FALL IN WITH ONE ARG\r
4169         MOVE    B,1(D)\r
4170         GETYP   C,(D)           ; TYPE OF 1ST ARG\r
4171         ADD     D,[2,,2]        ; GO TO NEXT\r
4172         CAIN    C,TFLOAT\r
4173         JRST    ARITH3\r
4174         CAIN    C,TFIX\r
4175         JRST    ARITH1\r
4176         JRST    WRONGT\r
4177 \r
4178 ARITH1: GETYP   C,(D)           ; GET NEXT TYPE\r
4179         CAIE    C,TFIX\r
4180         JRST    ARITH2          ; TO FLOAT LOOP\r
4181         XCT     FUNC(E)         ; DO IT\r
4182         ADD     D,[2,,2]\r
4183         SOJG    A,ARITH1        ; KEEP ADDING OR WHATEVER\r
4184         JFCL    OVRFLW,OVRFLD\r
4185         MOVSI   A,TFIX\r
4186         POPJ    P,\r
4187 \r
4188 ARITH3: GETYP   C,(D)\r
4189         MOVE    0,1(D)          ; GET ARG\r
4190         CAIE    C,TFIX\r
4191         JRST    ARITH4\r
4192         PUSH    P,A\r
4193         JSP     C,OFLOAT        ; FLOAT IT\r
4194         POP     P,A\r
4195         JRST    ARITH5\r
4196 ARITH4: CAIE    C,TFLOAT\r
4197         JRST    WRONGT\r
4198         JRST    ARITH5\r
4199 \r
4200 ARITH2: CAIE    C,TFLOAT        ; FLOATER?\r
4201         JRST    WRONGT\r
4202         PUSH    P,A\r
4203         JSP     A,BFLOAT\r
4204         POP     P,A\r
4205         MOVE    0,1(D)\r
4206 \r
4207 ARITH5: XCT     FLFUNC(E)\r
4208         ADD     D,[2,,2]\r
4209         SOJG    A,ARITH3\r
4210 \r
4211         JFCL    OVRFLW,OVRFLD\r
4212         MOVSI   A,TFLOAT\r
4213         POPJ    P,\r
4214 \r
4215 SWITCH: XCT     COMPAR(E)       ;FOR MAX & MIN TESTING\r
4216         MOVE    B,VALN\r
4217         JRST    (C)\r
4218 COMPAR==.-6\r
4219         CAMLE   B,VALN\r
4220         CAMGE   B,VALN\r
4221 \r
4222 \r
4223 \r
4224 FLSWCH: XCT     FLCMPR(E)\r
4225         MOVE    B,O\r
4226         JRST    (C)\r
4227 FLCMPR==.-6\r
4228         CAMLE   B,O\r
4229         CAMGE   B,O\r
4230 \f;PRIMITIVES ONEP AND ZEROP\r
4231 \r
4232 MFUNCTION       ONEP,SUBR,[1?]\r
4233         MOVEI   E,1\r
4234         JRST    JOIN\r
4235 \r
4236 MFUNCTION       ZEROP,SUBR,[0?]\r
4237         MOVEI   E,\r
4238 \r
4239 JOIN:   ENTRY 1\r
4240         GETYP   A,TYP1\r
4241         CAIN    A,TFIX  ;fixed ?\r
4242         JRST    TESTFX\r
4243         CAIE    A,TFLOAT        ;floating ?\r
4244         JRST    WTYP1\r
4245         MOVE    B,VAL1\r
4246         CAMN    B,NUMBR(E)      ;equal to correct value ?\r
4247         JRST    YES1\r
4248         JRST    NO1\r
4249 \r
4250 TESTFX: CAMN    E,VAL1  ;equal to correct value ?\r
4251         JRST    YES1\r
4252 \r
4253 NO1:    MOVSI   A,TFALSE\r
4254         MOVEI   B,0\r
4255         JRST    FINIS\r
4256 \r
4257 YES1:   MOVSI   A,TATOM\r
4258         MOVE    B,MQUOTE T\r
4259         JRST    FINIS\r
4260 \r
4261 NUMBR:  0       ;FLOATING PT  ZERO\r
4262         201400,,0       ;FLOATING PT ONE\r
4263 \f;PRIMITIVES LESSP AND GREATERP\r
4264 \r
4265 MFUNCTION       LEQP,SUBR,[L=?]\r
4266         MOVEI   E,3\r
4267         JRST    ARGS\r
4268 \r
4269 MFUNCTION       GEQP,SUBR,[G=?]\r
4270         MOVEI   E,2\r
4271         JRST    ARGS\r
4272 \r
4273 \r
4274 MFUNCTION       LESSP,SUBR,[L?]\r
4275         MOVEI   E,1\r
4276         JRST    ARGS\r
4277 \r
4278 MFUNCTION       GREATERP,SUBR,[G?]\r
4279         MOVEI   E,0\r
4280 \r
4281 ARGS:   ENTRY 2\r
4282         MOVE    B,VAL1\r
4283         MOVE    A,TYP1\r
4284         GETYP   0,A\r
4285         PUSHJ   P,CMPTYP\r
4286         JRST    WTYP1\r
4287         MOVE    D,VAL2\r
4288         MOVE    C,TYP2\r
4289         GETYP   0,C\r
4290         PUSHJ   P,CMPTYP\r
4291         JRST    WTYP2\r
4292         PUSHJ   P,ACOMPS\r
4293         JFCL\r
4294         JRST    FINIS\r
4295 \r
4296 ; COMPILERS ENTRIES TO THESE GUYS\r
4297 \r
4298 IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]\r
4299 \r
4300 NAME:   MOVEI   E,COD\r
4301         JRST    ACOMPS\r
4302 TERMIN\r
4303 \r
4304 ACOMPS: GETYP   A,A\r
4305         GETYP   0,C\r
4306         CAIE    0,(A)\r
4307         JRST    COMPD           ; COMPARING FIX AND FLOAT\r
4308 TEST:   CAMN    B,D\r
4309         JRST    @TABLE4(E)\r
4310         CAMG    B,D\r
4311         JRST    @TABLE2(E)\r
4312         JRST    @TABLE3(E)\r
4313 \r
4314 CMPTYP: CAIE    0,TFIX\r
4315         CAIN    0,TFLOAT\r
4316         AOS     (P)\r
4317         POPJ    P,\r
4318 COMPD:  EXCH    B,D\r
4319         CAIN    A,TFLOAT\r
4320         JSP     A,BFLOAT\r
4321         EXCH    B,D\r
4322         CAIN    0,TFLOAT\r
4323         JSP     A,BFLOAT\r
4324 COMPF:  JRST    TEST\r
4325 \r
4326 MFUNCTION RANDOM,SUBR\r
4327         ENTRY\r
4328         HLRE    A,AB\r
4329         CAMGE   A,[-4]          ;At most two arguments to random to set seeds\r
4330         JRST    TMA\r
4331         JRST    RANDGO(A)\r
4332         MOVE    B,VAL2          ;Set second seed\r
4333         MOVEM   B,RLOW\r
4334         MOVE    A,VAL1          ;Set first seed\r
4335         MOVEM   A,RHI\r
4336 RANDGO: PUSHJ   P,CRAND\r
4337         JRST    FINIS\r
4338 \r
4339 CRAND:  MOVE B,RLOW             ;FREDKIN'S RANDOM NUMBER GENERATOR.\r
4340         MOVE A,RHI\r
4341         MOVEM A,RLOW\r
4342         LSHC A,-43\r
4343         XORB B,RHI\r
4344         MOVSI A,TFIX\r
4345         POPJ    P,\r
4346 \r
4347 \fMFUNCTION SQRT,SUBR\r
4348         PUSHJ   P,ARGCHK\r
4349         JUMPL   B,NSQRT\r
4350         PUSHJ   P,ISQRT\r
4351         JRST    FINIS\r
4352 \r
4353 ISQRT:  MOVE    A,B\r
4354         ASH     B,-1\r
4355         FSC     B,100\r
4356 SQ2:    MOVE    C,B     ;NEWTON'S METHOD, SPECINER'S HACK.\r
4357         FDVRM   A,B\r
4358         FADRM   C,B\r
4359         FSC     B,-1\r
4360         CAME    C,B\r
4361         JRST    SQ2\r
4362         MOVSI   A,TFLOAT\r
4363         POPJ    P,\r
4364 \r
4365 MFUNCTION COS,SUBR\r
4366         PUSHJ   P,ARGCHK\r
4367         FADR    B,[1.570796326]         ;COS(X)=SIN (X+PI/2)\r
4368         PUSHJ   P,.SIN\r
4369         MOVSI   A,TFLOAT\r
4370         JRST    FINIS\r
4371 \r
4372 MFUNCTION SIN,SUBR\r
4373         PUSHJ   P,ARGCHK\r
4374         PUSHJ   P,.SIN\r
4375         MOVSI   A,TFLOAT\r
4376         JRST    FINIS\r
4377 \r
4378 .SIN:   MOVM    A,B\r
4379         CAMG    A,[.0001]\r
4380         POPJ    P,              ;GOSPER'S RECURSIVE SIN.\r
4381         FDVR    B,[-3.0]        ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)\r
4382         PUSHJ   P,.SIN\r
4383         FSC     A,1\r
4384         FMPR    A,A\r
4385         FADR    A,[-3.0]\r
4386         FMPRB   A,B\r
4387         POPJ    P,\r
4388 \r
4389 CSQRT:  PUSHJ   P,CARGCH\r
4390         JUMPL   B,NSQRT\r
4391         JRST    ISQRT\r
4392 \r
4393 CSIN:   PUSHJ   P,CARGCH\r
4394 CSIN1:  PUSHJ   P,.SIN\r
4395         MOVSI   A,TFLOAT\r
4396         POPJ    P,\r
4397 \r
4398 CCOS:   PUSHJ   P,CARGCH\r
4399         FADR    B,[1.570796326]\r
4400         JRST    CSIN1\r
4401 \fMFUNCTION      LOG,SUBR\r
4402         PUSHJ   P,ARGCHK        ;LEAVES ARGUMENT IN B\r
4403         PUSHJ   P,ILOG\r
4404         JRST    FINIS\r
4405 \r
4406 CLOG:   PUSHJ   P,CARGCH\r
4407 \r
4408 ILOG:   JUMPLE  B,OUTRNG\r
4409         LDB     D,[331100,,B]   ;GRAB EXPONENT\r
4410         SUBI    D,201           ;REMOVE BIAS\r
4411         TLZ     B,777000        ;SET EXPONENT\r
4412         TLO     B,201000        ; TO 1\r
4413         MOVE    A,B\r
4414         FSBR    A,RT2\r
4415         FADR    B,RT2\r
4416         FDVB    A,B\r
4417         FMPR    B,B\r
4418         MOVE    C,[0.434259751]\r
4419         FMPR    C,B\r
4420         FADR    C,[0.576584342]\r
4421         FMPR    C,B\r
4422         FADR    C,[0.961800762]\r
4423         FMPR    C,B\r
4424         FADR    C,[2.88539007]\r
4425         FMPR    C,A\r
4426         FADR    C,[0.5]\r
4427         MOVE    B,D\r
4428         FSC     B,233\r
4429         FADR    B,C\r
4430         FMPR    B,[0.693147180] ;LOG E OF 2\r
4431         MOVSI   A,TFLOAT\r
4432         POPJ    P,\r
4433 \r
4434 RT2:    1.41421356\r
4435 \fMFUNCTION      ATAN,SUBR\r
4436         PUSHJ   P,ARGCHK\r
4437         PUSHJ   P,IATAN\r
4438         JRST    FINIS\r
4439 \r
4440 CATAN:  PUSHJ   P,CARGCH\r
4441 \r
4442 IATAN:  PUSH    P,B\r
4443         MOVM    D,B\r
4444         CAMG    D,[0.4^-8]      ;SMALL ENOUGH SO ATAN(X)=X?\r
4445         JRST    ATAN3           ;YES\r
4446         CAML    D,[7.0^7]       ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?\r
4447         JRST    ATAN1           ;YES\r
4448         MOVN    C,[1.0]\r
4449         CAMLE   D,[1.0]         ;IS ABS(X)<1.0?\r
4450         FDVM    C,D             ;NO,SCALE IT DOWN\r
4451         MOVE    B,D\r
4452         FMPR    B,B\r
4453         MOVE    C,[1.44863154]\r
4454         FADR    C,B\r
4455         MOVE    A,[-0.264768620]\r
4456         FDVM    A,C\r
4457         FADR    C,B\r
4458         FADR    C,[3.31633543]\r
4459         MOVE    A,[-7.10676005]\r
4460         FDVM    A,C\r
4461         FADR    C,B\r
4462         FADR    C,[6.76213924]\r
4463         MOVE    B,[3.70925626]\r
4464         FDVR    B,C\r
4465         FADR    B,[0.174655439]\r
4466         FMPR    B,D\r
4467         JUMPG   D,ATAN2         ;WAS ARG SCALED?\r
4468         FADR    B,PI2           ;YES,  ATAN(X)=PI/2-ATAN(1/X)\r
4469         JRST    ATAN2\r
4470 ATAN1:  MOVE    B,PI2\r
4471 ATAN2:  SKIPGE  (P)             ;WAS INPUT NEGATIVE?\r
4472         MOVNS   B               ;YES,COMPLEMENT\r
4473 ATAN3:  MOVSI   A,TFLOAT        \r
4474         SUB     P,[1,,1]\r
4475         POPJ    P,\r
4476 \r
4477 PI2:    1.57079632\r
4478 \fMFUNCTION      IEXP,SUBR,[EXP] \r
4479         PUSHJ   P,ARGCHK        ;LEAVE FLOATING POINT ARG IN B\r
4480         PUSHJ   P,IIEXP\r
4481         JRST    FINIS\r
4482 \r
4483 CEXP:   PUSHJ   P,CARGCH\r
4484 \r
4485 IIEXP:  PUSH    P,B\r
4486         MOVM    A,B\r
4487         SETZM   B\r
4488         FMPR    A,[0.434294481] ;LOG BASE 10 OF E\r
4489         MOVE    D,[1.0]\r
4490         CAMG    A,D\r
4491         JRST    RATEX\r
4492         MULI    A,400\r
4493         ASHC    B,-243(A)\r
4494         CAILE   B,43\r
4495         JRST    OUTRNG\r
4496         CAILE   B,7\r
4497         JRST    EXPR2\r
4498 EXPR1:  FMPR    D,FLOAP1(B)\r
4499         LDB     A,[103300,,C]   \r
4500         SKIPE   A\r
4501         TLO     A,177000\r
4502         FADR    A,A\r
4503 RATEX:  MOVEI   B,7\r
4504         SETZM   C\r
4505 RATEY:  FADR    C,COEF2-1(B)\r
4506         FMPR    C,A\r
4507         SOJN    B,RATEY\r
4508         FADR    C,[1.0] \r
4509         FMPR    C,C\r
4510         FMPR    D,C\r
4511         MOVE    B,[1.0]\r
4512         SKIPL   (P)             ;SKIP IF INPUT NEGATIVE\r
4513         SKIPN   B,D\r
4514         FDVR    B,D\r
4515         MOVSI   A,TFLOAT\r
4516         SUB     P,[1,,1]\r
4517         POPJ    P,\r
4518 \r
4519 EXPR2:  LDB     E,[030300,,B]   \r
4520         ANDI    B,7\r
4521         MOVE    D,FLOAP1(E)\r
4522         FMPR    D,D             ;TO THE 8TH POWER\r
4523         FMPR    D,D\r
4524         FMPR    D,D\r
4525         JRST    EXPR1\r
4526 \r
4527 COEF2:  1.15129278\r
4528         0.662730884\r
4529         0.254393575\r
4530         0.0729517367\r
4531         0.0174211199\r
4532         2.55491796^-3\r
4533         9.3264267^-4\r
4534 \r
4535 FLOAP1: 1.0\r
4536         10.0\r
4537         100.0\r
4538         1000.0\r
4539         10000.0\r
4540         100000.0\r
4541         1000000.0\r
4542         10000000.0\r
4543 \f;BITWISE BOOLEAN FUNCTIONS\r
4544 \r
4545 MFUNCTION %ANDB,SUBR,ANDB\r
4546         ENTRY\r
4547         HRREI   B,-1            ;START ANDING WITH ALL ONES\r
4548         MOVE    D,[AND B,A]     ;LOGICAL INSTRUCTION\r
4549         JRST    LOGFUN          ;DO THE OPERATION\r
4550 \r
4551 MFUNCTION %ORB,SUBR,ORB\r
4552         ENTRY\r
4553         MOVEI   B,0\r
4554         MOVE    D,[IOR B,A]\r
4555         JRST    LOGFUN\r
4556 \r
4557 MFUNCTION %XORB,SUBR,XORB\r
4558         ENTRY\r
4559         MOVEI   B,0\r
4560         MOVE    D,[XOR B,A]\r
4561         JRST    LOGFUN\r
4562 \r
4563 MFUNCTION %EQVB,SUBR,EQVB\r
4564         ENTRY\r
4565         HRREI   B,-1\r
4566         MOVE    D,[EQV B,A]\r
4567 \r
4568 LOGFUN: JUMPGE  AB,ZROARG\r
4569 LOGTYP: GETYP   A,(AB)          ;GRAB THE TYPE\r
4570         PUSHJ   P,SAT           ;STORAGE ALLOCATION TYPE\r
4571         CAIE    A,S1WORD\r
4572         JRST    WRONGT          ;WRONG TYPE...LOSE\r
4573         MOVE    A,1(AB)         ;LOAD ARG INTO A\r
4574         XCT     D               ;DO THE LOGICAL OPERATION\r
4575         AOBJP   AB,.+2          ;ADD ONE TO BOTH HALVES\r
4576         AOBJN   AB,LOGTYP       ;ADD AGAIN AND LOOP IF NEEDED\r
4577 \r
4578 ZROARG: MOVE    A,$TWORD\r
4579         JRST    FINIS\r
4580 \fREPEAT 0,[\r
4581 ;routine to sort lists or vectors of either fixed point or floating numbers\r
4582 ;the components are interchanged repeatedly to acheive the sort\r
4583 ;first arg:     the structure to be sorted\r
4584 ;if no second arg sort in descending order\r
4585 ;second arg:    if false then sort in ascending order\r
4586 ;               else sort in descending order\r
4587 \r
4588 MFUNCTION       SORT,SUBR\r
4589         ENTRY \r
4590         HLRZ    A,AB\r
4591         CAIGE   A,-4            ;Only two arguments allowed\r
4592         JRST    TMA\r
4593         MOVE    O,DESCEND       ;Set up "O" to test for descending order as default condition\r
4594         CAIE    A,-4            ;Optional second argument?\r
4595         JRST    .+4\r
4596         GETYP   B,TYP2          ;See if it is other than false\r
4597         CAIN    B,TFALSE\r
4598         MOVE    O,ASCEND        ;Set up "O" to test for ascending order\r
4599         GETYP   A,TYP1          ;CHECK TYPE OF FIRST ARGUMENT\r
4600         CAIN    A,TLIST\r
4601         JRST    LSORT\r
4602         CAIN    A,TVEC\r
4603         JRST    VSORT\r
4604         JRST    WTYP1\r
4605 \r
4606 \r
4607 \r
4608 \r
4609 GOBACK: MOVE    A,TYP1          ;RETURN THE SORTED ARGUMENT AS VALUE\r
4610         MOVE    B,VAL1\r
4611         JRST    FINIS\r
4612 \r
4613 DESCEND:        CAMG    C,(A)+1\r
4614 ASCEND:         CAML    C,(A)+1\r
4615 \f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER\r
4616 \r
4617 LSORT:  MOVE    A,VAL1\r
4618         JUMPE   A,GOBACK        ;EMPTY LIST?\r
4619         HLRZ    B,(A)           ;TYPE OF FIRST COMPONENT\r
4620         CAIE    B,TFIX\r
4621         CAIN    B,TFLOAT\r
4622         SKIPA\r
4623         JRST    WRONGT\r
4624         MOVEI   E,0             ;FOR COUNT OF LENGTH OF LIST\r
4625 LCOUNT: JUMPE   A,LLSORT        ;REACHED END OF LIST?\r
4626         MOVE    A,(A)           ;NEXT COMPONENT\r
4627         TLZ     A,(B)           ;SAME TYPE AS FIRST COMPONENT?\r
4628         TLNE    A,-1\r
4629         JRST    WRONGT\r
4630         AOJA    E,LCOUNT        ;INCREMENT COUNT AND CONTINUE\r
4631 \r
4632 LLSORT: SOJE    E,GOBACK        ;FINISHED WITH SORTING?\r
4633         HRRZ    A,VAL1          ;START THIS LOOP OF SORTING AT THE BEGINNING\r
4634         MOVEM   E,(P)+1         ;Save the iteration depth\r
4635 CLSORT: HRRZ    B,(A)           ;NEXT COMPONENT\r
4636         MOVE    C,(B)+1         ;ITS VALUE\r
4637         XCT     O               ;ARE THESE TWO COMPONENTS IN ORDER?\r
4638         JRST    .+4\r
4639         MOVE    D,(A)+1         ;INTERCHANGE THEM\r
4640         MOVEM   D,(B)+1\r
4641         MOVEM   C,(A)+1\r
4642         MOVE    A,B             ;MAKE THE COMPONENT IN "B" THE CURRENT ONE\r
4643         SOJG    E,CLSORT\r
4644         MOVE    E,(P)+1         ;Restore the iteration depth\r
4645         JRST    LLSORT\r
4646 \f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER\r
4647 \r
4648 VSORT:  HLRE    D,VAL1          ;GET COUNT FIELD OF VECTOR\r
4649         IDIV    D,[-2]          ;LENGTH\r
4650         JUMPE   D,GOBACK        ;EMPTY VECTOR?\r
4651         MOVE    E,D             ;SAVE LENGTH IN "E"\r
4652         HRRZ    A,VAL1          ;POINTER TO VECTOR\r
4653         MOVE    B,(A)           ;TYPE OF FIRST COMPONENT\r
4654         CAME    B,$TFIX\r
4655         CAMN    B,$TFLOAT\r
4656         SKIPA\r
4657         JRST    WRONGT\r
4658         SOJLE   D,GOBACK        ;IF ONLY ONE COMPONENT THEN FINISHED\r
4659 VCOUNT: ADDI    A,2             ;CHECK NEXT COMPONENT\r
4660         CAME    B,(A)           ;SAME TYPE AS FIRST COMPONENT?\r
4661         JRST    WRONGT\r
4662         SOJG    D,VCOUNT        ;CONTINUE WITH NEXT COMPONENT\r
4663 \r
4664 VVSORT: SOJE    E,GOBACK        ;FINISHED SORTING?\r
4665         HRRZ    A,VAL1          ;START THIS LOOP OF SORTING AT THE BEGINNING\r
4666         MOVEM   E,(P)+1         ;Save the iteration depth\r
4667 CVSORT: MOVE    C,(A)+3         ;VALUE OF NEXT COMPONENT\r
4668         XCT     O               ;ARE THESE TWO COMPONENTS IN ORDER?\r
4669         JRST    .+4\r
4670         MOVE    D,(A)+1         ;INTERCHANGE THEM\r
4671         MOVEM   D,(A)+3\r
4672         MOVEM   C,(A)+1\r
4673         ADDI    A,2             ;UPDATE THE CURRENT COMPONENT\r
4674         SOJG    E,CVSORT\r
4675         MOVE    E,(P)+1         ;Restore the iteration depth\r
4676         JRST    VVSORT\r
4677 ]\r
4678 \r
4679 MFUNCTION TIME,SUBR\r
4680         ENTRY\r
4681         PUSHJ   P,CTIME\r
4682         JRST    FINIS\r
4683 \r
4684 IMPURE\r
4685 \r
4686 RHI:    267762113337\r
4687 RLOW:   155256071112\r
4688 PURE\r
4689 \r
4690 \r
4691 END\r
4692 \f\fTITLE ATOMHACKER FOR MUDDLE\r
4693 \r
4694 RELOCATABLE\r
4695 \r
4696 .INSRT MUDDLE >\r
4697 .GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE\r
4698 .GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP\r
4699 .GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY\r
4700 .GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG\r
4701 \r
4702 .VECT.==40000           ; BIT FOR GCHACK\r
4703 \r
4704 ; FUNCTION TO GENERATE AN EMPTY OBLIST\r
4705 \r
4706 MFUNCTION MOBLIST,SUBR\r
4707 \r
4708         ENTRY\r
4709         CAMGE   AB,[-5,,0]      ;CHECK NUMBER OF ARGS\r
4710         JRST    TMA\r
4711         JUMPGE  AB,MOBL2                ; NO ARGS\r
4712         PUSH    TP,(AB)\r
4713         PUSH    TP,1(AB)\r
4714         PUSH    TP,$TATOM\r
4715         PUSH    TP,IMQUOTE OBLIST\r
4716         MCALL   2,GET           ; CHECK IF IT EXISTS ALREADY\r
4717         CAMN    A,$TOBLS\r
4718         JRST    FINIS\r
4719 MOBL2:  MOVE    A,OBLNT         ;GET DEFAULT LENGTH\r
4720         CAML    AB,[-3,,0]      ;IS LENGTH SUPPLIED\r
4721         JRST    MOBL1           ;NO, USE STANDARD LENGTH\r
4722         GETYP   C,2(AB)         ;GET ARG TYPE\r
4723         CAIE    C,TFIX\r
4724         JRST    WTYP2           ;LOSE\r
4725         MOVE    A,3(AB)         ;GET LENGTH\r
4726 MOBL1:  PUSH    TP,$TFIX\r
4727         PUSH    TP,A\r
4728         MCALL   1,UVECTOR       ;GET A UNIFORM VECTOR\r
4729         MOVSI   C,TLIST+.VECT.  ;IT IS OF TYPE LIST\r
4730         HLRE    D,B             ;-LENGTH TO D\r
4731         SUBM    B,D             ;D POINTS TO DOPE WORD\r
4732         MOVEM   C,(D)           ;CLOBBER TYPE IN\r
4733         MOVSI   A,TOBLS\r
4734         JUMPGE  AB,FINIS        ; IF NO ARGS, DONE\r
4735         GETYP   A,(AB)\r
4736         CAIE    A,TATOM\r
4737         JRST    WTYP1\r
4738         PUSH    TP,$TOBLS\r
4739         PUSH    TP,B\r
4740         PUSH    TP,$TOBLS\r
4741         PUSH    TP,B\r
4742         PUSH    TP,$TATOM\r
4743         PUSH    TP,IMQUOTE OBLIST\r
4744         PUSH    TP,(AB)\r
4745         PUSH    TP,1(AB)\r
4746         MCALL   3,PUT   ; PUT THE NAME ON THE OBLIST\r
4747         PUSH    TP,(AB)\r
4748         PUSH    TP,1(AB)\r
4749         PUSH    TP,$TATOM\r
4750         PUSH    TP,IMQUOTE OBLIST\r
4751         PUSH    TP,(TB)\r
4752         PUSH    TP,1(TB)\r
4753         MCALL   3,PUT   ; PUT THE OBLIST ON THE NAME\r
4754 \r
4755         POP     TP,B\r
4756         POP     TP,A\r
4757         JRST    FINIS\r
4758 \r
4759 MFUNCTION GROOT,SUBR,ROOT\r
4760         ENTRY 0\r
4761         MOVE    A,ROOT(TVP)\r
4762         MOVE    B,ROOT+1(TVP)\r
4763         JRST    FINIS\r
4764 \r
4765 MFUNCTION GINTS,SUBR,INTERRUPTS\r
4766         ENTRY 0\r
4767         MOVE    A,INTOBL(TVP)\r
4768         MOVE    B,INTOBL+1(TVP)\r
4769         JRST FINIS\r
4770 \r
4771 MFUNCTION GERRS,SUBR,ERRORS\r
4772         ENTRY 0\r
4773         MOVE    A,ERROBL(TVP)\r
4774         MOVE    B,ERROBL+1(TVP)\r
4775         JRST    FINIS\r
4776 \r
4777 \r
4778 COBLQ:  SKIPN   B,2(B)          ; SKIP IF EXISTS\r
4779         JRST    IFLS\r
4780         MOVSI   A,TOBLS\r
4781         JUMPL   B,CPOPJ1\r
4782         ADDI    B,(TVP)\r
4783         MOVE    B,(B)\r
4784 CPOPJ1: AOS     (P)\r
4785         POPJ    P,\r
4786 \r
4787 IFLS:   MOVEI   B,0\r
4788         MOVSI   A,TFALSE\r
4789         POPJ    P,\r
4790 \r
4791 MFUNCTION OBLQ,SUBR,[OBLIST?]\r
4792 \r
4793         ENTRY   1\r
4794         GETYP   A,(AB)\r
4795         CAIE    A,TATOM\r
4796         JRST    WTYP1\r
4797         MOVE    B,1(AB)         ; GET ATOM\r
4798         PUSHJ   P,COBLQ\r
4799         JFCL\r
4800         JRST    FINIS\r
4801 \r
4802 \f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME\r
4803 \r
4804 MFUNCTION LOOKUP,SUBR\r
4805 \r
4806         ENTRY   2\r
4807         PUSHJ   P,ILOOKU        ;CALL INTERNAL ROUTINE\r
4808         JRST    FINIS\r
4809 \r
4810 CLOOKU: SUBM    M,(P)\r
4811         PUSH    TP,A\r
4812         PUSH    TP,B\r
4813         MOVEI   B,-1(TP)\r
4814         PUSH    TP,$TOBLS\r
4815         PUSH    TP,C\r
4816         GETYP   A,A\r
4817         PUSHJ   P,CSTAK\r
4818         MOVE    B,(TP)\r
4819         PUSHJ   P,ILOOK\r
4820         POP     P,D\r
4821         HRLI    D,(D)\r
4822         SUB     P,D\r
4823         SKIPE   B\r
4824         SOS     (P)\r
4825         SUB     TP,[4,,4]\r
4826         JRST    MPOPJ\r
4827 \r
4828 ILOOKU: PUSHJ   P,ARGCHK        ;CHECK ARGS\r
4829         PUSHJ   P,CSTACK        ;PUT CHARACTERS ON THE STACK\r
4830 \r
4831 CALLIT: MOVE    B,3(AB)         ;GET OBLIST\r
4832 ILOOKC: PUSHJ   P,ILOOK         ;LOOK IT UP\r
4833         POP     P,D             ;RESTORE COUNT\r
4834         HRLI    D,(D)           ;TO BOTH SIDES\r
4835         SUB     P,D\r
4836         POPJ    P,\r
4837 \r
4838 ;THIS ROUTINE CHECKS ARG TYPES\r
4839 \r
4840 ARGCHK: GETYP   A,(AB)          ;GET TYPES\r
4841         GETYP   C,2(AB)\r
4842         CAIE    A,TCHRS         ;IS IT EITHER CHAR STRING\r
4843         CAIN    A,TCHSTR\r
4844         CAIE    C,TOBLS         ;IS 2ND AN OBLIST\r
4845         JRST    WRONGT          ;TYPES ARE WRONG\r
4846         POPJ    P,\r
4847 \r
4848 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)\r
4849 \r
4850 \r
4851 CSTACK: MOVEI   B,(AB)\r
4852 CSTAK:  POP     P,D             ;RETURN ADDRESS TO D\r
4853         CAIE    A,TCHRS         ;IMMEDIATE?\r
4854         JRST    NOTIMM          ;NO, HAIR\r
4855         MOVE    A,1(B)          ; GET CHAR\r
4856         LSH     A,29.           ; POSITION\r
4857         PUSH    P,A             ;ONTO P\r
4858         PUSH    P,[1]           ;WITH NUMBER\r
4859         JRST    (D)             ;GO CALL SEARCHER\r
4860 \r
4861 NOTIMM: MOVEI   A,1             ; CLEAR CHAR COUNT\r
4862         HRRZ    C,(B)           ; GET COUNT OF CHARS\r
4863         JUMPE   C,NULST ; FLUSH NULL STRING\r
4864         MOVE    B,1(B)          ;GET BYTE POINTER\r
4865 \r
4866 CLOOP1: PUSH    P,[0]           ; STORE CHARS ON STACK\r
4867         MOVSI   E,(<440700,,(P)>)       ; SETUP BYTE POINTER\r
4868 CLOOP:  ILDB    0,B             ;GET A CHARACTER\r
4869         IDPB    0,E             ;STORE IT\r
4870         SOJE    C,CDONE         ; ANY MORE?\r
4871         TLNE    E,760000        ; WORD FULL\r
4872         JRST    CLOOP           ;NO CONTINUE\r
4873         AOJA    A,CLOOP1        ;AND CONTINUE\r
4874 \r
4875 CDONE:\r
4876 CDONE1: PUSH    P,A             ;AND NUMBER OF WORDS\r
4877         JRST    (D)             ;RETURN\r
4878 \r
4879 \r
4880 NULST:  PUSH    TP,$TATOM\r
4881         PUSH    TP,EQUOTE NULL-STRING\r
4882         JRST    CALER1\r
4883 \f; THIS FUNCTION LOOKS FOR ATOMS.  CALLED BY PUSHJ P,ILOOK\r
4884 ;       B/      OBLIST POINTER\r
4885 ;       -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK\r
4886 ;       CHAR STRING IS ON THE STACK\r
4887 \r
4888 ILOOK:  MOVN    A,-1(P)         ;GET -LENGTH\r
4889         HRLI    A,-1(A)         ;<-LENGTH-1>,,-LENGTH\r
4890         PUSH    TP,$TFIX        ;SAVE\r
4891         PUSH    TP,A\r
4892         ADDI    A,-1(P)         ;HAVE AOBJN POINTER TO CHARS\r
4893         MOVEI   D,0             ;HASH WORD\r
4894         XOR     D,(A)\r
4895         AOBJN   A,.-1           ;XOR THEM ALL TOGETHER\r
4896         HLRE    A,B             ;GET LENGTH OF OBLIST\r
4897         MOVNS   A\r
4898         TLZ     D,400000        ; MAKE SURE + HASH CODE\r
4899         IDIVI   D,(A)           ;DIVIDE\r
4900         HRLI    E,(E)           ;TO BOTH HALVES\r
4901         ADD     B,E             ;POINT TO BUCKET\r
4902 \r
4903         MOVEI   0,(B)           ;IN CASE REMOVING 1ST\r
4904         SKIPN   C,(B)           ;BUCKET EMPTY?\r
4905         JRST    NOTFND          ;YES, GIVE UP\r
4906 LOOK2:  SKIPN   A,1(C)          ;NIL CAR ON LIST?\r
4907         JRST    NEXT            ;YES TRY NEXT\r
4908         ADD     A,[3,,3]        ;POINT TO ATOMS PNAME\r
4909         MOVE    D,(TP)          ;GET PSEUDO AOBJN POINTER TO CHARS\r
4910         ADDI    D,-1(P)         ;NOW ITS A REAL AOBJN POINTER\r
4911         JUMPE   D,CHECK0        ;ONE IS EMPTY\r
4912 LOOK1:  MOVE    E,(D)           ;GET A WORD\r
4913         CAME    E,(A)           ;COMPARE\r
4914         JRST    NEXT            ;THIS ONE DOESN'T MATCH\r
4915         AOBJP   D,CHECK         ;ONE RAN OUT\r
4916         AOBJN   A,LOOK1         ;JUMP IF STILL MIGHT WIN\r
4917 \r
4918 NEXT:   MOVEI   0,(C)           ;POINT TO PREVIOUS ELEMENT\r
4919         HRRZ    C,(C)           ;STEP THROUGH\r
4920         JUMPN   C,LOOK2\r
4921 \r
4922 NOTFND: EXCH    C,B             ;RETURN BUCKET IN B\r
4923         MOVSI   A,TFALSE\r
4924 CPOPJT: SUB     TP,[2,,2]       ;REMOVE RANDOM TP STUFF\r
4925         POPJ    P,\r
4926 \r
4927 CHECK0: JUMPN   A,NEXT          ;JUMP IF NOT ALSO EMPTY\r
4928         SKIPA\r
4929 CHECK:  AOBJN   A,NEXT          ;JUMP IF NO MATCH\r
4930         HLLZ    A,(C)\r
4931         MOVE    E,B             ; RETURN BUCKET\r
4932         MOVE    B,1(C)          ;GET ATOM\r
4933         JRST    CPOPJT\r
4934 \r
4935 \r
4936 \f; FUNCTION TO INSERT AN ATOM ON AN OBLIST\r
4937 \r
4938 MFUNCTION INSERT,SUBR\r
4939 \r
4940         ENTRY   2\r
4941         GETYP   A,2(AB)\r
4942         CAIE    A,TOBLS\r
4943         JRST    WTYP2\r
4944         MOVE    A,(AB)\r
4945         MOVE    B,1(AB)\r
4946         MOVE    C,3(AB)\r
4947         PUSHJ   P,IINSRT\r
4948         JRST    FINIS\r
4949 \r
4950 CINSER: SUBM    M,(P)\r
4951         PUSHJ   P,IINSRT\r
4952         JRST    MPOPJ\r
4953 \r
4954 IINSRT: PUSH    TP,A\r
4955         PUSH    TP,B\r
4956         PUSH    TP,$TOBLS\r
4957         PUSH    TP,C\r
4958         GETYP   A,A\r
4959         CAIN    A,TATOM\r
4960         JRST    INSRT0\r
4961 \r
4962 ;INSERT WITH A GIVEN PNAME\r
4963 \r
4964         CAIE    A,TCHRS\r
4965         CAIN    A,TCHSTR\r
4966         JRST    .+2\r
4967         JRST    WTYP1\r
4968 \r
4969         PUSH    TP,$TFIX        ;FLAG CALL\r
4970         PUSH    TP,[0]\r
4971         MOVEI   B,-5(TP)\r
4972         PUSHJ   P,CSTAK         ;COPY ONTO STACK\r
4973         MOVE    B,-2(TP)\r
4974         PUSHJ   P,ILOOK         ;LOOK IT UP (BUCKET RETURNS IN C)\r
4975         JUMPN   B,ALRDY         ;EXISTS, LOSE\r
4976         MOVE    D,-2(TP)        ; GET OBLIST BACK\r
4977 INSRT1: PUSH    TP,$TOBLS       ;SAVE BUCKET POINTER\r
4978         PUSH    TP,C\r
4979         PUSH    TP,$TOBLS\r
4980         PUSH    TP,D            ; SAVE OBLIST\r
4981 INSRT3: PUSHJ   P,IATOM         ; MAKE AN ATOM\r
4982         PUSHJ   P,LINKCK        ; A LINK REALLY NEEDED ?\r
4983         MOVE    E,-2(TP)\r
4984         HRRZ    E,(E)           ; GET BUCKET\r
4985         PUSHJ   P,ICONS\r
4986         MOVE    C,-2(TP)        ;BUCKET AGAIN\r
4987         HRRM    B,(C)           ;INTO NEW BUCKET\r
4988         MOVSI   A,TATOM\r
4989         MOVE    B,1(B)          ;GET ATOM BACK\r
4990         MOVE    D,(TP)          ; GET OBLIST\r
4991         MOVEM   D,2(B)          ; AND CLOBBER\r
4992         MOVE    C,-4(TP)        ;GET FLAG\r
4993         SUB     TP,[6,,6]       ;POP STACK\r
4994         JUMPN   C,(C)\r
4995         SUB     TP,[4,,4]\r
4996         POPJ    P,\r
4997 \r
4998 ;INSERT WITH GIVEN ATOM\r
4999 INSRT0: MOVE    A,-2(TP)        ;GOBBLE PNAME\r
5000         SKIPE   2(A)            ; SKIP IF NOT ON AN OBLIST\r
5001         JRST    ONOBL\r
5002         ADD     A,[3,,3]\r
5003         HLRE    C,A\r
5004         MOVNS   C\r
5005         PUSH    P,(A)           ;FLUSH PNAME ONTO P STACK\r
5006         AOBJN   A,.-1\r
5007         PUSH    P,C\r
5008         MOVE    B,(TP)          ; GET OBLIST FOR LOOKUP\r
5009         PUSHJ   P,ILOOK         ;ALREADY THERE?\r
5010         JUMPN   B,ALRDY\r
5011         PUSH    TP,$TOBLS       ;SAVE NECESSARY STUFF AWAY FROM CONS\r
5012         PUSH    TP,C            ;WHICH WILL MAKE A LIST FROM THE ATOM\r
5013         MOVSI   C,TATOM\r
5014         MOVE    D,-4(TP)\r
5015         PUSHJ   P,INCONS\r
5016         MOVE    C,(TP)          ;RESTORE\r
5017         HRRZ    D,(C)\r
5018         HRRM    B,(C)\r
5019         HRRM    D,(B)\r
5020         MOVE    C,-2(TP)\r
5021         MOVE    B,-4(TP)        ; GET BACK ATOM\r
5022         MOVEM   C,2(B)          ; CLOBBER OBLIST IN\r
5023         MOVSI   A,TATOM\r
5024         SUB     TP,[6,,6]\r
5025         POP     P,C\r
5026         HRLI    C,(C)\r
5027         SUB     P,C\r
5028         POPJ    P,\r
5029 \r
5030 LINKCK: HRRZ    C,FSAV(TB)      ;CALLER'S NAME\r
5031         CAIN    C,LINK\r
5032         SKIPA   C,$TLINK        ;LET US INSERT A LINK INSTEAD OF AN ATOM\r
5033         MOVSI   C,TATOM         ;GET REAL ATOM FOR CALL TO ICONS\r
5034         MOVE    D,B\r
5035         POPJ    P,\r
5036 \r
5037 \r
5038 \r
5039 ALRDY:  PUSH    TP,$TATOM\r
5040         PUSH    TP,EQUOTE ATOM-ALREADY-THERE\r
5041         JRST    CALER1\r
5042 \r
5043 ONOBL:  PUSH    TP,$TATOM\r
5044         PUSH    TP,EQUOTE ON-AN-OBLIST-ALREADY\r
5045         JRST    CALER1\r
5046 \r
5047 ; INTERNAL INSERT CALL\r
5048 \r
5049 INSRTX: POP     P,0             ; GET RET ADDR\r
5050         PUSH    TP,$TFIX\b       \r
5051         PUSH    TP,0\r
5052         PUSH    TP,$TOBLS\r
5053         PUSH    TP,B\r
5054         PUSH    TP,$TOBLS\r
5055         PUSH    TP,B\r
5056         PUSHJ   P,ILOOK\r
5057         JUMPN   B,INSRXT\r
5058         MOVEM   C,-2(TP)\r
5059         JRST    INSRT3          ; INTO INSERT CODE\r
5060 \r
5061 INSRXT: PUSH    P,-4(TP)\r
5062         SUB     TP,[6,,6]\r
5063         POPJ    P,\r
5064         JRST    IATM1\r
5065 \f\r
5066 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST\r
5067 \r
5068 MFUNCTION REMOVE,SUBR\r
5069 \r
5070         ENTRY\r
5071 \r
5072         JUMPGE  AB,TFA\r
5073         CAMGE   AB,[-5,,]\r
5074         JRST    TMA\r
5075         MOVEI   C,0\r
5076         CAML    AB,[-3,,]       ; SKIP IF OBLIST GIVEN\r
5077         JRST    .+5\r
5078         GETYP   0,2(AB)\r
5079         CAIE    0,TOBLS\r
5080         JRST    WTYP2\r
5081         MOVE    C,3(AB)\r
5082         MOVE    A,(AB)\r
5083         MOVE    B,1(AB)\r
5084         PUSHJ   P,IRMV\r
5085         JRST    FINIS\r
5086 \r
5087 CIRMV:  SUBM    M,(P)\r
5088         PUSHJ   P,IRMV\r
5089         JRST    MPOPJ\r
5090 \r
5091 IRMV:   PUSH    TP,A\r
5092         PUSH    TP,B\r
5093         PUSH    TP,$TOBLS\r
5094         PUSH    TP,C\r
5095 IRMV1:  GETYP   0,A             ; CHECK 1ST ARG\r
5096         CAIN    0,TLINK\r
5097         JRST    .+3\r
5098         CAIE    0,TATOM         ; ATOM, TREAT ACCORDINGLY\r
5099         JRST    RMV1\r
5100 \r
5101         SKIPN   D,2(B)          ; SKIP IF ON OBLIST AND GET SAME\r
5102         JRST    IFALSE\r
5103         JUMPL   D,.+3\r
5104         ADDI    D,(TVP)\r
5105         MOVE    D,(D)\r
5106         JUMPE   C,GOTOBL\r
5107         CAME    C,D             ; BETTER BE THE SAME\r
5108         JRST    ONOTH\r
5109 \r
5110 GOTOBL: ADD     B,[3,,3]        ; POINT TO PNAME\r
5111         HLRE    A,B\r
5112         MOVNS   A\r
5113         PUSH    P,(B)           ; PUSH PNAME\r
5114         AOBJN   B,.-1\r
5115         PUSH    P,A\r
5116         MOVEM   D,(TP)          ; SAVE OBLIST\r
5117         JRST    RMV3\r
5118 \r
5119 RMV1:   JUMPE   C,TFA\r
5120         CAIE    0,TCHRS\r
5121         CAIN    0,TCHSTR\r
5122         SKIPA   A,0\r
5123         JRST    WTYP1\r
5124         MOVEI   B,-3(TP)\r
5125         PUSHJ   P,CSTAK\r
5126 RMV3:   MOVE    B,(TP)\r
5127         PUSHJ   P,ILOOK\r
5128         POP     P,D\r
5129         HRLI    D,(D)\r
5130         SUB     P,D\r
5131         JUMPE   B,RMVDON\r
5132         HRRZ    D,0             ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)\r
5133         HRRZ    C,(C)           ;GET NEXT OF LOSING PAIR\r
5134         MOVEI   0,(B)\r
5135         CAIGE   0,HIBOT         ; SKIP IF PURE\r
5136         JRST    RMV2\r
5137         PUSHJ   P,IMPURIFY\r
5138         MOVE    A,-3(TP)\r
5139         MOVE    B,-2(TP)\r
5140         MOVE    C,(TP)\r
5141         JRST    IRMV1\r
5142 RMV2:   HRRM    C,(D)           ;AND SPLICE\r
5143         SETZM   2(B)            ; CLOBBER OBLIST SLOT\r
5144 RMVDON: SUB     TP,[4,,4]\r
5145         POPJ    P,\r
5146 \r
5147 \f\r
5148 ;INTERNAL CALL FROM THE READER\r
5149 \r
5150 RLOOKU: PUSH    TP,$TFIX        ;PUSH A FLAG\r
5151         POP     P,C             ;POP OFF RET ADR\r
5152         PUSH    TP,C            ;AND USE AS A FLAG FOR INTERNAL\r
5153         MOVE    C,(P)           ; CHANGE CHAR COUNT TO WORD\r
5154         ADDI    C,4\r
5155         IDIVI   C,5\r
5156         MOVEM   C,(P)\r
5157 \r
5158         CAMN    A,$TOBLS        ;IS IT ONE OBLIST?\r
5159         JRST    RLOOK1\r
5160         CAME    A,$TLIST        ;IS IT A LIST\r
5161         JRST    BADOBL\r
5162 \r
5163         JUMPE   B,BADLST\r
5164         PUSH    TP,$TOBLS       ; SLOT FOR REMEBERIG\r
5165         PUSH    TP,[0]\r
5166         PUSH    TP,$TOBLS\r
5167         PUSH    TP,[0]\r
5168         PUSH    TP,A\r
5169         PUSH    TP,B\r
5170 \r
5171 RLOOK2: GETYP   A,(B)           ;CHECK THIS IS AN OBLIST\r
5172         MOVE    B,1(B)          ;VALUE\r
5173         CAIE    A,TOBLS\r
5174         JRST    DEFALT\r
5175         PUSHJ   P,ILOOK         ;LOOK IT UP\r
5176         JUMPN   B,RLOOK3        ;WIN\r
5177         SKIPE   -2(TP)          ; SKIP IF DEFAULT NOT STORED\r
5178         JRST    RLOOK4\r
5179         HRRZ    D,(TP)          ; GET CURRENT\r
5180         MOVE    D,1(D)          ; OBLIST\r
5181         MOVEM   D,-2(TP)\r
5182         MOVEM   C,-4(TP)        ; FOR INSERT IF NEEDED\r
5183 RLOOK4: INTGO\r
5184         HRRZ    B,@(TP)         ;CDR THE LIST\r
5185         HRRZM   B,(TP)\r
5186         JUMPN   B,RLOOK2\r
5187         SKIPN   D,-2(TP)        ; RESTORE FOR INSERT\r
5188         JRST    BADDEF          ; NO DEFAULT, USER LOST ON SPECIFICATION\r
5189         MOVE    C,-4(TP)\r
5190         SUB     TP,[6,,6]       ; FLUSH CRAP\r
5191         JRST    INSRT1\r
5192 \r
5193 DEFFLG==1       ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED\r
5194 DEFALT: CAIN    A,TATOM         ;SPECIAL DEFAULT INDICATING ATOM ?\r
5195         CAME    B,MQUOTE DEFAULT\r
5196         JRST    BADDEF          ;NO, LOSE\r
5197         MOVSI   A,DEFFLG\r
5198         XORB    A,-6(TP)        ;SET AND TEST FLAG\r
5199         TLNN    A,DEFFLG        ; HAVE WE BEEN HERE BEFORE ?\r
5200         JRST    BADDEF          ; YES, LOSE\r
5201         SETZM   -2(TP)          ;ZERO OUT PREVIOUS DEFAULT\r
5202         SETZM   -4(TP)\r
5203         JRST    RLOOK4          ;CONTINUE\r
5204 \r
5205 RLOOK1: PUSH    TP,$TOBLS\r
5206         PUSH    TP,B            ; SAVE OBLIST\r
5207         PUSHJ   P,ILOOK ;LOOK IT UP THERE\r
5208         MOVE    D,(TP)          ; GET OBLIST\r
5209         SUB     TP,[2,,2]\r
5210         JUMPE   B,INSRT1        ;GO INSET IT\r
5211 \r
5212 \r
5213 INSRT2: JRST    .+2             ;\r
5214 RLOOK3: SUB     TP,[6,,6]       ;POP OFF LOSSAGE\r
5215         PUSHJ   P,ILINK         ;IF THIS IS A LINK FOLLOW IT\r
5216         PUSH    P,(TP)          ;GET BACK RET ADR\r
5217         SUB     TP,[2,,2]       ;POP TP\r
5218         JRST    IATM1           ;AND RETURN\r
5219 \r
5220 \r
5221 BADOBL: PUSH    TP,$TATOM\r
5222         PUSH    TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF\r
5223         JRST    CALER1\r
5224 \r
5225 BADDEF: PUSH    TP,$TATOM\r
5226         PUSH    TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION\r
5227         JRST    CALER1\r
5228 \r
5229 ONOTH:  PUSH    TP,$TATOM\r
5230         PUSH    TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST\r
5231         JRST    CALER1\r
5232 \f;SUBROUTINE TO MAKE AN ATOM\r
5233 \r
5234 MFUNCTION ATOM,SUBR\r
5235 \r
5236         ENTRY   1\r
5237 \r
5238         MOVE    A,(AB)\r
5239         MOVE    B,1(AB)\r
5240         PUSHJ   P,IATOMI\r
5241         JRST    FINIS\r
5242 \r
5243 CATOM:  SUBM    M,(P)\r
5244         PUSHJ   P,IATOMI\r
5245         JRST    MPOPJ\r
5246 \r
5247 IATOMI: GETYP   0,A             ;CHECK ARG TYPE\r
5248         CAIE    0,TCHRS\r
5249         CAIN    0,TCHSTR\r
5250         JRST    .+2             ;JUMP IF WINNERS\r
5251         JRST    WTYP1\r
5252 \r
5253         PUSH    TP,A\r
5254         PUSH    TP,B\r
5255         MOVEI   B,-1(TP)\r
5256         MOVE    A,0\r
5257         PUSHJ   P,CSTAK         ;COPY ONTO STACK\r
5258         PUSHJ   P,IATOM         ;NOW MAKE THE ATOM\r
5259         POPJ    P,\r
5260 \r
5261 ;INTERNAL ATOM MAKER\r
5262 \r
5263 IATOM:  MOVE    A,-1(P)         ;GET WORDS IN PNAME\r
5264         ADDI    A,3             ;FOR VALUE CELL\r
5265         PUSHJ   P,IBLOCK        ; GET BLOCK\r
5266         MOVSI   C,<(GENERAL)>+SATOM+.VECT.      ;FOR TYPE FIELD\r
5267         MOVE    D,-1(P)         ;RE-GOBBLE LENGTH\r
5268         ADDI    D,3(B)          ;POINT TO DOPE WORD\r
5269         MOVEM   C,(D)\r
5270         SKIPG   -1(P)           ;EMPTY PNAME ?\r
5271         JRST    IATM0           ;YES, NO CHARACTERS TO MOVE\r
5272         MOVE    E,B             ;COPY ATOM POINTER\r
5273         ADD     E,[3,,3]        ;POINT TO PNAME AREA\r
5274         MOVEI   C,-1(P)\r
5275         SUB     C,-1(P)         ;POINT TO STRING ON STACK\r
5276         MOVE    D,(C)           ;GET SOME CHARS\r
5277         MOVEM   D,(E)           ;AND COPY THEM\r
5278         ADDI    C,1\r
5279         AOBJN   E,.-3\r
5280 IATM0:  MOVSI   A,TATOM ;TYPE TO ATOM\r
5281 IATM1:  POP     P,D             ;RETURN ADR\r
5282         POP     P,C\r
5283         HRLI    C,(C)\r
5284         SUB     P,C\r
5285         JRST    (D)             ;RETURN\r
5286 \r
5287 \f;SUBROUTINE TO GET AN ATOM'S PNAME\r
5288 \r
5289 MFUNCTION PNAME,SUBR\r
5290 \r
5291         ENTRY 1\r
5292 \r
5293         GETYP   A,(AB)\r
5294         CAIE    A,TATOM         ;CHECK TYPE IS ATOM\r
5295         JRST    WTYP1\r
5296         MOVE    A,1(AB)\r
5297         PUSHJ   P,IPNAME\r
5298         JRST    FINIS\r
5299 \r
5300 CIPNAM: SUBM    M,(P)\r
5301         PUSHJ   P,IPNAME\r
5302         JRST    MPOPJ\r
5303 \r
5304 IPNAME: ADD     A,[3,,3]\r
5305         HLRE    B,A\r
5306         MOVM    B,B\r
5307         PUSH    P,(A)           ;FLUSH PNAME ONTO P\r
5308         AOBJN   A,.-1\r
5309         IMULI   B,5             ; CHARS TO B\r
5310         MOVE    0,(P)           ; LAST WORD\r
5311         MOVE    A,0\r
5312         SUBI    A,1             ; FIND LAST 1\r
5313         ANDCM   0,A             ; 0 HAS 1ST 1\r
5314         JFFO    0,.+1\r
5315         HRREI   0,-34.(A)       ; FIND HOW MUCH TO ADD\r
5316         IDIVI   0,7\r
5317         ADD     B,0\r
5318         PUSH    P,B\r
5319         PUSHJ   P,CHMAK         ;MAKE A STRING\r
5320         POPJ    P,\r
5321 \r
5322 \f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE\r
5323 \r
5324 MFUNCTION BLK,SUBR,BLOCK\r
5325 \r
5326         ENTRY   1\r
5327 \r
5328         GETYP   A,(AB)  ;CHECK TYPE OF ARG\r
5329         CAIE    A,TOBLS ;IS IT AN OBLIST\r
5330         CAIN    A,TLIST ;OR A LIAT\r
5331         JRST    .+2\r
5332         JRST    WTYP1\r
5333         MOVSI   A,TATOM ;LOOK UP OBLIST\r
5334         MOVE    B,IMQUOTE OBLIST\r
5335         PUSHJ   P,IDVAL ;GET VALUE\r
5336         PUSH    TP,A\r
5337         PUSH    TP,B\r
5338         PUSH    TP,.BLOCK(PVP)  ;HACK THE LIST\r
5339         PUSH    TP,.BLOCK+1(PVP)\r
5340         MCALL   2,CONS  ;CONS THE LIST\r
5341         MOVEM   A,.BLOCK(PVP)   ;STORE IT BACK\r
5342         MOVEM   B,.BLOCK+1(PVP)\r
5343         PUSH    TP,$TATOM\r
5344         PUSH    TP,IMQUOTE OBLIST\r
5345         PUSH    TP,(AB)\r
5346         PUSH    TP,1(AB)\r
5347         MCALL   2,SET   ;SET OBLIST TO ARG\r
5348         JRST    FINIS\r
5349 \r
5350 MFUNCTION ENDBLOCK,SUBR\r
5351 \r
5352         ENTRY   0\r
5353 \r
5354         SKIPN   B,.BLOCK+1(PVP) ;IS THE LIST NIL?\r
5355         JRST    BLKERR  ;YES, LOSE\r
5356         HRRZ    C,(B)   ;CDR THE LIST\r
5357         HRRZM   C,.BLOCK+1(PVP)\r
5358         PUSH    TP,$TATOM       ;NOW RESET OBLIST\r
5359         PUSH    TP,IMQUOTE OBLIST\r
5360         HLLZ    A,(B)   ;PUSH THE TYPE OF THE CAR\r
5361         PUSH    TP,A\r
5362         PUSH    TP,1(B) ;AND VALUE OF CAR\r
5363         MCALL   2,SET\r
5364         JRST    FINIS\r
5365 \r
5366 BLKERR: PUSH    TP,$TATOM\r
5367         PUSH    TP,EQUOTE UNMATCHED\r
5368         JRST    CALER1\r
5369 \r
5370 BADLST: PUSH    TP,$TATOM\r
5371         PUSH    TP,EQUOTE NIL-LIST-OF-OBLISTS\r
5372         JRST    CALER1\r
5373 \f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE\r
5374 \r
5375 CHMAK:  MOVE    A,-1(P)\r
5376         ADDI    A,4\r
5377         IDIVI   A,5\r
5378         PUSHJ   P,IBLOCK\r
5379         MOVEI   C,-1(P)         ;FIND START OF CHARS\r
5380         HLRE    E,B             ; - LENGTH\r
5381         ADD     C,E             ;C POINTS TO START\r
5382         MOVE    D,B             ;COPY VECTOR RESULT\r
5383         JUMPGE  D,NULLST        ;JUMP IF EMPTY\r
5384         MOVE    A,(C)           ;GET ONE\r
5385         MOVEM   A,(D)\r
5386         ADDI    C,1             ;BUMP POINTER\r
5387         AOBJN   D,.-3           ;COPY\r
5388 NULLST: MOVSI   C,TCHRS+.VECT.          ;GET TYPE\r
5389         MOVEM   C,(D)           ;CLOBBER IT IN\r
5390         MOVE    A,-1(P)         ; # WORDS\r
5391         HRLI    A,TCHSTR\r
5392         HRLI    B,440700\r
5393         MOVMM   E,-1(P)         ; SO IATM1 WORKS\r
5394         JRST    IATM1           ;RETURN\r
5395 \r
5396 ; SUBROUTINE TO READ FIVE CHARS FROM STRING.\r
5397 ;   TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,\r
5398 ; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT\r
5399 \r
5400 NXTDCL: GETYP   B,(A)           ;CHECK TYPE\r
5401         CAIE    B,TDEFER                ;LOSE IF NOT DEFERRED\r
5402         POPJ    P,\r
5403 \r
5404         MOVE    B,1(A)          ;GET REAL BYTE POINTER\r
5405 CHRWRD: PUSH    P,C\r
5406         GETYP   C,(B)           ;CHECK IT IS CHSTR\r
5407         CAIE    C,TCHSTR\r
5408         JRST    CPOPJC          ;NO, QUIT\r
5409         PUSH    P,D\r
5410         PUSH    P,E\r
5411         PUSH    P,0\r
5412         MOVEI   E,0             ;INITIALIZE DESTINATION\r
5413         HRRZ    C,(B)           ; GET CHAR COUNT\r
5414         JUMPE   C,GOTDCL        ; NULL, FINISHED\r
5415         MOVE    B,1(B)          ;GET BYTE POINTER\r
5416         MOVE    D,[440700,,E]   ;BYTE POINT TO E\r
5417 CHLOOP: ILDB    0,B             ; GET A CHR\r
5418         IDPB    0,D             ;CLOBBER AWAY\r
5419         SOJE    C,GOTDCL        ; JUMP IF DONE\r
5420         TLNE    D,760000        ; SKIP IF WORD FULL\r
5421         JRST    CHLOOP          ; MORE THAN 5 CHARS\r
5422         TRO     E,1             ; TURN ON FLAG\r
5423 \r
5424 GOTDCL: MOVE    B,E             ;RESULT TO B\r
5425         AOS     -4(P)           ;SKIP RETURN\r
5426 CPOPJ0: POP     P,0\r
5427         POP     P,E\r
5428         POP     P,D\r
5429 CPOPJC: POP     P,C\r
5430         POPJ    P,\r
5431 \r
5432 ; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD\r
5433 ; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A\r
5434 \r
5435 BYTDOP: PUSH    P,B             ; SAVE SOME ACS\r
5436         PUSH    P,D\r
5437         PUSH    P,E\r
5438         MOVE    B,1(C)          ; GET BYTE POINTER\r
5439         LDB     D,[360600,,B]   ; POSITION TO D\r
5440         LDB     E,[300600,,B]   ; AND BYTE SIZE\r
5441         MOVEI   A,(E)           ; A COPY IN A\r
5442         IDIVI   D,(E)           ; D=> # OF BYTES IN WORD 1\r
5443         HRRZ    E,(C)           ; GET LENGTH\r
5444         SUBM    E,D             ; # OF BYTES IN OTHER WORDS\r
5445         JUMPL   D,BYTDO1        ; NEAR DOPE WORD\r
5446         MOVEI   B,36.           ; COMPUTE BYTES PER WORD\r
5447         IDIVM   B,A\r
5448         ADDI    D,-1(A)         ; NOW COMPUTE WORDS\r
5449         IDIVI   D,(A)           ; D/ # NO. OF WORDS PAST 1ST\r
5450         ADD     D,1(C)          ; D POINTS TO DOPE WORD\r
5451         MOVEI   A,2(D)\r
5452 \r
5453 BYTDO2: POP     P,E\r
5454         POP     P,D\r
5455         POP     P,B\r
5456         POPJ    P,\r
5457 BYTDO1: MOVEI   A,1(B)\r
5458         CAME    D,[-5]\r
5459         AOJA    A,BYTDO2\r
5460         JRST    BYTDO2\r
5461 \f;ROUTINES TO DEFINE AND HANDLE LINKS\r
5462 \r
5463 MFUNCTION LINK,SUBR\r
5464         ENTRY\r
5465         CAML    AB,[-6,,0]      ;NO MORE THAN 3 ARGS\r
5466         CAML    AB,[-2,,0]      ;NO LESS THAN 2 ARGS\r
5467         JRST    WNA\r
5468         CAML    AB,[-4,,0]      ;ONLY TWO ARGS SUPPLIED ?\r
5469         JRST    GETOB           ;YES, GET OBLIST FROM CURRENT PATH\r
5470         MOVE    A,2(AB)\r
5471         MOVE    B,3(AB)\r
5472         MOVE    C,5(AB)\r
5473         JRST    LINKIN\r
5474 GETOB:  MOVSI   A,TATOM\r
5475         MOVE    B,IMQUOTE OBLIST\r
5476         PUSHJ   P,IDVAL\r
5477         CAMN    A,$TOBLS\r
5478         JRST    LINKP\r
5479         CAME    A,$TLIST\r
5480         JRST    BADOBL\r
5481         JUMPE   B,BADLST\r
5482         GETYPF  A,(B)\r
5483         MOVE    B,(B)+1\r
5484 LINKP:  MOVE    C,B\r
5485         MOVE    A,2(AB)\r
5486         MOVE    B,3(AB)\r
5487 LINKIN: PUSHJ   P,IINSRT\r
5488         CAMN    A,$TFALSE       ;LINK NAME ALREADY USED ?\r
5489         JRST    ALRDY           ;YES, LOSE\r
5490         MOVE    C,B\r
5491         MOVE    A,(AB)\r
5492         MOVE    B,1(AB)\r
5493         PUSHJ   P,CSETG\r
5494         JRST    FINIS\r
5495 \r
5496 \r
5497 ILINK:  CAME    A,$TLINK        ;FOUND A LINK ?\r
5498         POPJ    P,              ;NO, FINISHED\r
5499         MOVSI   A,TATOM\r
5500         PUSHJ   P,IGVAL         ;GET THE LINK'S DESTINATION\r
5501         CAME    A,$TUNBOUND     ;WELL FORMED LINK ?\r
5502         POPJ    P,              ;YES\r
5503         PUSH    TP,$TATOM\r
5504         PUSH    TP,EQUOTE BAD-LINK\r
5505         JRST    CALER1\r
5506 \r
5507 \f\r
5508 ; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS\r
5509 \r
5510 IMPURIFY:\r
5511         PUSH    TP,$TATOM\r
5512         PUSH    TP,B\r
5513         MOVE    C,B\r
5514         MOVEI   0,(C)\r
5515         CAIGE   0,HIBOT\r
5516         JRST    RTNATM          ; NOT PURE, RETURN\r
5517 \r
5518 ; 1) IMPURIFY ITS OBLIST BUCKET\r
5519 \r
5520         SKIPN   B,2(C)          ; PICKUP OBLIST IF IT EXISTS\r
5521         JRST    IMPUR1          ; NOT ON ONE, IGNORE THIS CODE\r
5522 \r
5523         ADDI    B,(TVP)         ; POINT TO SLOT\r
5524         MOVE    B,(B)           ; GET THE REAL THING\r
5525         ADD     C,[3,,3]        ; POINT TO PNAME\r
5526         HLRE    A,C             ; GET LNTH IN WORDS OF PNAME\r
5527         MOVNS   A\r
5528         PUSH    P,[IMPUR2]      ; FAKE OUT ILOOKC\r
5529         PUSH    P,(C)           ; PUSH UP THE PNAME\r
5530         AOBJN   C,.-1\r
5531         PUSH    P,A             ; NOW THE COUNT\r
5532         JRST    ILOOKC          ; GO FIND BUCKET\r
5533 \r
5534 IMPUR2: JUMPE   B,IMPUR1        ; NOT THERE, GO\r
5535         PUSH    TP,$TOBLS               ; SAVE BUCKET\r
5536         PUSH    TP,E\r
5537 \r
5538         MOVE    B,(E)           ; GET NEXT ONE\r
5539 IMPUR4: MOVEI   0,(B)\r
5540         CAIGE   0,HIBOT         ; SKIP IF PURE\r
5541         JRST    IMPUR3          ; FOUND IMPURE NESS, SKIP IT\r
5542         HLLZ    C,(B)           ; SET UP ICONS CALL\r
5543         HRRZ    E,(B)\r
5544         MOVE    D,1(B)\r
5545         PUSHJ   P,ICONS         ; CONS IT UP\r
5546         HRRZ    E,(TP)          ; RETRV PREV\r
5547         HRRM    B,(E)           ; AND CLOBBER\r
5548 IMPUR3: MOVSI   0,TLIST\r
5549         MOVEM   0,-1(TP)        ; FIX TYPE\r
5550         HRRZM   B,(TP)          ; STORE GOODIE\r
5551         HRRZ    B,(B)           ; CDR IT\r
5552         JUMPN   B,IMPUR4        ; LOOP\r
5553         SUB     TP,[2,,2]       ; FLUSH TP CRUFT\r
5554 \r
5555 ; 2) GENERATE A DUPLICATE ATOM\r
5556 \r
5557 IMPUR1: HLRE    A,(TP)          ; GET LNTH OF ATOM\r
5558         MOVNS   A\r
5559         PUSH    P,A\r
5560         PUSHJ   P,IBLOCK        ; GET NEW BLOCK FOR ATOM\r
5561         PUSH    TP,$TATOM\r
5562         PUSH    TP,B\r
5563         HRL     B,-2(TP)                ; SETUP BLT\r
5564         POP     P,A\r
5565         ADDI    A,(B)           ; END OF BLT\r
5566         BLT     B,(A)           ; CLOBBER NEW ATOM\r
5567         MOVSI   B,.VECT.        ; TURN ON BIT FOR GCHACK\r
5568         IORM    B,(A)\r
5569 \r
5570 ; 3) NOW COPY GLOBAL VALUE\r
5571 \r
5572         MOVE    B,(TP)          ; ATOM BACK\r
5573         GETYP   0,(B)\r
5574         SKIPE   A,1(B)          ; NON-ZER POINTER?\r
5575         CAIN    0,TUNBOU        ; BOUND?\r
5576         JRST    IMPUR5          ; NO, DONT COPY GLOB VAL\r
5577         PUSH    TP,$TATOM\r
5578         PUSH    TP,B\r
5579         PUSH    TP,(A)\r
5580         PUSH    TP,1(A)         \r
5581         SETZM   (B)\r
5582         SETZM   1(B)\r
5583         MCALL   2,SETG\r
5584 IMPUR5: PUSH    TP,$TFIX        ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE\r
5585         PUSH    TP,-3(TP)\r
5586 \r
5587 ; 4) UPDATE ALL POINTERS TO THIS ATOM\r
5588 \r
5589         MOVE    A,[PUSHJ P,ATFIX]       ; INS TO PASS TO GCHACK\r
5590         PUSHJ   P,GCHACK\r
5591         SUB     TP,[4,,4]\r
5592 \r
5593 RTNATM: POP     TP,B\r
5594         POP     TP,A\r
5595         POPJ    P,\r
5596 \r
5597 ; ROUTINE PASSED TO GCHACK\r
5598 \r
5599 ATFIX:  CAIE    C,TGATOM        ; GLOBAL TYPE ATOM\r
5600         CAIN    C,TATOM\r
5601         CAME    D,(TP)          ; SKIP IF WINNER\r
5602         POPJ    P,\r
5603         MOVE    D,-2(TP)\r
5604         SKIPE   B\r
5605         MOVEM   D,1(B)\r
5606         POPJ    P,\r
5607 \r
5608 \r
5609 END\r
5610 \f\f\r
5611 TITLE PROCESS-HACKER FOR MUDDLE\r
5612 \r
5613 RELOCATABLE\r
5614 \r
5615 .INSRT MUDDLE >\r
5616 \r
5617 .GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES\r
5618 .GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS\r
5619 .GLOBAL TBINIT,APLQ\r
5620 \r
5621 MFUNCTION PROCESS,SUBR\r
5622 \r
5623         ENTRY 1\r
5624         GETYP   A,(AB)          ;GET TYPE OF ARG\r
5625                                 ;MUST BE SOME APPLIABLE TYPE\r
5626         PUSHJ   P,APLQ\r
5627         JRST    NAPT            ;NO, ERROR - NON-APPLIABLE TYPE\r
5628 OKFUN:\r
5629 \r
5630         PUSHJ   P,ICR   ;CREATE A NEW PROCESS\r
5631         MOVE    C,TPSTO+1(B)    ;GET ITS SRTACK\r
5632         PUSH    C,[TENTRY,,TOPLEV]\r
5633         PUSH    C,[1,,0]        ;TIME\r
5634         PUSH    C,[0]\r
5635         PUSH    C,SPSTO+1(B)\r
5636         PUSH    C,PSTO+1(B)\r
5637         MOVE    D,C\r
5638         ADD     D,[3,,3]\r
5639         PUSH    C,D     ;SAVED STACK POINTER\r
5640         PUSH    C,[SUICID]\r
5641         MOVEM   C,TPSTO+1(B)    ;STORE NEW TP\r
5642         HRRI    D,1(C)  ;MAKE A TB\r
5643         HRLI    D,2     ;WITH A TIME\r
5644         MOVEM   D,TBINIT+1(B)\r
5645         MOVEM   D,TBSTO+1(B)    ;SAVE ALSO FOR SIMULATED START\r
5646         MOVE    C,(AB)  ;STORE ARG\r
5647         MOVEM   C,RESFUN(B)     ;INTO PV\r
5648         MOVE    C,1(AB)\r
5649         MOVEM   C,RESFUN+1(B)\r
5650         MOVEI   0,RUNABL\r
5651         MOVEM   0,PSTAT+1(B)\r
5652         JRST FINIS\r
5653 \r
5654 REPEAT 0,[\r
5655 MFUNCTION       RETPROC,SUBR\r
5656 ; WHO KNOWS WHAT THIS SHOULD REALLY DO\r
5657 ;PROBABLY, JUST AN EXIT\r
5658 ;FOR NOW, PRINT OUT AN ERROR MESSAGE\r
5659         PUSH    TP,$TATOM\r
5660         PUSH    TP,EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS\r
5661         JRST    CALER1\r
5662 \r
5663 \r
5664 \r
5665 \r
5666 \r
5667 \r
5668 \r
5669 MFUNCTION RESUME,FSUBR\r
5670 ;RESUME IS CALLED WITH TWO ARGS\r
5671 ;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED\r
5672 ;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS\r
5673 ;    (THE PARENT) IS ITSELF RESUMED\r
5674 ;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS\r
5675 ;PLUGGED IN\r
5676 ;\r
5677 ; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE\r
5678 \r
5679         ENTRY   1\r
5680         HRRZ    C,@1(AB)                ;GET CDR ADDRESS\r
5681         JUMPE   C,NOFUN         ;IF NO SECOND ARG, SUPPLY STANDARD\r
5682         HLLZ    A,(C)           ;GET CDR TYPE\r
5683         CAME    A,$TATOM                ;ATOMIC?\r
5684         JRST    RES2            ;NO, MUST EVAL TO GET FUNCTION\r
5685         MOVE    B,1(C)          ;YES\r
5686         PUSHJ   P,IGVAL         ;TRY TO GET GLOBAL VALUE\r
5687         CAMN    A,$TUNBOUND     ;GLOBALLY UNBOUND?\r
5688         JRST    LFUN            ;YES, TRY FOR LOCAL VALUE\r
5689 RES1:   MOVEM   A,RESFUN(PVP)   ;STORE IN THIS PROCESS\r
5690         MOVEM   B,RESFUN+1(PVP)\r
5691 \r
5692         HRRZ    C,1(AB)         ;GET CAR ADDRESS\r
5693         PUSH    TP,(C)          ;PUSH PROCESS FORM\r
5694         PUSH    TP,1(C)\r
5695         JSP     E,CHKARG        ;CHECK FOR DEFERED TYPE\r
5696                                 ;INSERT CHECKS FOR PROCESS FORM\r
5697         MCALL   1,EVAL          ;EVAL PROCESS FORM WHICH WILL SWITCH\r
5698                                 ; PROCESSES\r
5699         JRST    FINIS\r
5700 \r
5701 RES2:   PUSH    TP,(C)          ;PUSH FUNCTION ARG\r
5702         PUSH    TP,1(C)\r
5703         JSP     E,CHKARG        ;CHECK FOR DEFERED\r
5704         MCALL   1,EVAL          ;EVAL TO GET FUNCTION\r
5705         JRST    RES1\r
5706 \r
5707 LFUN:   HRRZ    C,1(AB)         ;GET CDR ADDRESS\r
5708         PUSH    TP,(C)\r
5709         PUSH    TP,1(C)\r
5710         MCALL   1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION\r
5711         JRST    RES1\r
5712 \r
5713 NOFUN:  MOVSI   A,TUNBOUND      ;MAKE RESUME FUNCTION UNBOUND\r
5714         JRST    RES1\r
5715 ]\r
5716 \r
5717 ; PROCHK - SETUP LAST RESUMER SLOT\r
5718 \r
5719 PROCHK: CAME    B,MAINPR        ; MAIN PROCESS?\r
5720         MOVEM   PVP,LSTRES+1(B)\r
5721         POPJ    P,\r
5722 \r
5723 ; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS\r
5724 ; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS\r
5725 ;       RESFUN\r
5726 ; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES)\r
5727 \r
5728 \r
5729 MFUNCTION RESUME,SUBR\r
5730 \r
5731         ENTRY\r
5732         JUMPGE  AB,TFA\r
5733         CAMGE   AB,[-4,,0]\r
5734         JRST    TMA\r
5735         CAMGE   AB,[-2,,0]\r
5736         JRST    CHPROC          ; VALIDITY CHECK ON PROC\r
5737         SKIPN   B,LSTRES+1(PVP) ; ANY RESUMERS?\r
5738         JRST    NORES           ; NO, COMPLAIN\r
5739 GOTPRO: MOVE    C,AB\r
5740         CAMN    B,PVP           ; DO THEY DIFFER?\r
5741         JRST    RETARG\r
5742         MOVE    A,PSTAT+1(B)    ; CHECK STATE\r
5743         CAIE    A,RUNABL        ; MUST BE RUNABL\r
5744         CAIN    A,RESMBL        ; OR RESUMABLE\r
5745         JRST    RESUM1\r
5746 NOTRES:\r
5747 NOTRUN: PUSH    TP,$TATOM\r
5748         PUSH    TP,EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE\r
5749         JRST    CALER1\r
5750 \r
5751 RESUM1: PUSHJ   P,PROCHK        ; FIX LISTS UP\r
5752         MOVEI   A,RESMBL        ; GET NEW STATE\r
5753         MOVE    D,B             ; FOR SWAP\r
5754 STRTN:  JSP     C,SWAP          ; SWAP THEM\r
5755         MOVEM   A,PSTAT+1(E)    ; CLOBBER OTHER STATE\r
5756         MOVE    A,PSTAT+1(PVP)  ; DECIDE HOW TO PROCEED\r
5757         MOVEI   0,RUNING\r
5758         MOVEM   0,PSTAT+1(PVP)  ; NEW STATE\r
5759         MOVE    C,ABSTO+1(E)    ; OLD ARGS\r
5760         CAIE    A,RESMBL\r
5761         JRST    DORUN           ; THEY DO RUN RUN, THEY DO RUN RUN\r
5762 RETARG: MOVE    A,(C)\r
5763         MOVE    B,1(C)          ; RETURN\r
5764         JRST    FINIS\r
5765 \r
5766 DORUN:  PUSH    TP,RESFUN(PVP)\r
5767         PUSH    TP,RESFUN+1(PVP)\r
5768         PUSH    TP,(C)\r
5769         PUSH    TP,1(C)\r
5770         MCALL   2,APPLY\r
5771         PUSH    TP,A            ; CALL SUICIDE WITH THESE ARGS\r
5772         PUSH    TP,B\r
5773         MCALL   1,SUICID        ; IF IT RETURNS, KILL IT\r
5774         JRST    FINIS\r
5775 \r
5776 CHPROC: GETYP   A,2(AB)\r
5777         CAIE    A,TPVP\r
5778         JRST    WTYP2\r
5779         MOVE    B,3(AB)\r
5780         JRST    GOTPRO\r
5781 \r
5782 NORES:  PUSH    TP,$TATOM\r
5783         PUSH    TP,EQUOTE NO-PROCESS-TO-RESUME\r
5784         JRST    CALER1\r
5785 \r
5786 ; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT\r
5787 \r
5788 MFUNCTION SUICIDE,SUBR\r
5789 \r
5790         ENTRY\r
5791 \r
5792         JUMPGE  AB,TFA\r
5793         HLRE    A,AB\r
5794         ASH     A,-1    ; DIV BY 2\r
5795         AOJE    A,NOPROC        ; NO PROCESS GIVEN\r
5796         AOJL    A,TMA\r
5797         GETYP   A,2(AB) ; MAKE SURE OF PROCESS\r
5798         CAIE    A,TPVP\r
5799         JRST    WTYP2\r
5800         MOVE    C,3(AB)\r
5801         JRST    SUIC2\r
5802 \r
5803 NOPROC: SKIPN   C,LSTRES+1(PVP) ; MAKE SURE OF EDLIST\r
5804         MOVE    C,MAINPR        ; IF NOT DEFAULT TO MAIN\r
5805 SUIC2:  CAMN    C,PVP           ; DONT SUICIDE TO SELF\r
5806         JRST    SUSELF\r
5807         MOVE    B,PSTAT+1(C)\r
5808         CAIE    B,RUNABL\r
5809         CAIN    B,RESMBL\r
5810         JRST    .+2\r
5811         JRST    NOTRUN\r
5812         MOVE    B,C\r
5813         PUSHJ   P,PROCHK\r
5814         MOVE    D,B             ; RESTORE NEWPROCESS\r
5815         MOVEI   A,DEAD\r
5816         JRST    STRTN\r
5817 \r
5818 SUSELF: PUSH    TP,$TATOM\r
5819         PUSH    TP,EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF\r
5820         JRST    CALER1\r
5821 \r
5822 \r
5823 MFUNCTION RESER,SUBR,RESUMER\r
5824 \r
5825         ENTRY\r
5826         MOVE    B,PVP\r
5827         JUMPGE  AB,GTLAST\r
5828         CAMGE   AB,[-2,,0]\r
5829         JRST    TMA\r
5830 \r
5831         GETYP   A,(AB)  ; CHECK FOR PROCESS\r
5832         CAIE    A,TPVP\r
5833         JRST    WTYP1\r
5834         MOVE    B,1(AB) ; GET PROCESS\r
5835 GTLAST: MOVSI   A,TFALSE        ; ASSUME NONE\r
5836         SKIPN   B,LSTRES+1(B)   ; GET IT IF IT EXISTS\r
5837         JRST    FINIS\r
5838         MOVSI   A,TPVP          ; GET TYPE\r
5839         JRST    FINIS\r
5840 \r
5841 ; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK\r
5842 \r
5843 MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ\r
5844 \r
5845         ENTRY   2\r
5846 \r
5847         GETYP   A,2(AB)         ; 2D ARG MUST BE PROCESS\r
5848         CAIE    A,TPVP\r
5849         JRST    WTYP2\r
5850 \r
5851         MOVE    B,3(AB)         ; GET PROCESS\r
5852         CAMN    B,PVP           ; SKIP IF NOT ME\r
5853         JRST    BREAKM\r
5854         MOVE    A,PSTAT+1(B)    ; CHECK STATE\r
5855         CAIE    A,RESMBL        ; BEST BE RESUMEABLE\r
5856         JRST    NOTRUN\r
5857         MOVE    C,TBSTO+1(B)    ; GET SAVE ACS TO BUILD UP A DUMMY FRAME\r
5858         MOVE    D,TPSTO+1(B)    ; STACK POINTER\r
5859         MOVE    E,SPSTO+1(B)    ; FIX UP OLD FRAME\r
5860         MOVEM   E,SPSAV(C)\r
5861         MOVEI   E,CALLEV        ; FUNNY PC\r
5862         MOVEM   E,PCSAV(C)\r
5863         MOVE    E,PSTO+1(B)     ; SET UP P,PP AND TP SAVES\r
5864         MOVEM   E,PSAV(C)\r
5865         PUSH    D,[0]           ; ALLOCATES SOME SLOTS\r
5866         PUSH    D,[0]\r
5867         PUSH    D,(AB)          ; NOW THAT WHIC IS TO BE EVALLED\r
5868         PUSH    D,1(AB)\r
5869         MOVEM   D,TPSAV(C)\r
5870         HRRI    E,-1(D)         ; BUILD UP ARG POINTER\r
5871         HRLI    E,-2\r
5872         PUSH    D,[TENTRY,,BREAKE]\r
5873         PUSH    D,C             ; OLD TB\r
5874         PUSH    D,E             ; NEW ARG POINTER\r
5875 REPEAT 4,PUSH   D,[0]           ; OTHER SLOTS\r
5876         MOVEM   D,TPSTO+1(B)\r
5877         MOVEI   C,(D)           ; BUILD NEW AB\r
5878         AOBJN   C,.+1\r
5879         MOVEM   C,TBSTO+1(B)    ; STORE IT\r
5880         MOVE    A,2(AB)         ; RETURN PROCESS\r
5881         MOVE    B,3(AB)\r
5882         JRST    FINIS\r
5883 \r
5884 MQUOTE BREAKER\r
5885 \r
5886 BREAKE: \r
5887 CALLEV: MOVEM   A,-3(TP)        ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT)\r
5888         MOVEM   B,-2(TP)\r
5889         MCALL   1,EVAL\r
5890         POP     TP,B\r
5891         POP     TP,A\r
5892         JRST    FINIS\r
5893 \r
5894 BREAKM: PUSH    TP,$TATOM\r
5895         PUSH    TP,EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE\r
5896         JRST    CALER1\r
5897 \r
5898 ; FUNCTION TOP PUT PROCESS IN 1 STEP MODE\r
5899 \r
5900 MFUNCTION 1STEP,SUBR\r
5901         PUSHJ   P,1PROC\r
5902         MOVEM   PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS\r
5903         JRST    FINIS\r
5904 \r
5905 ; FUNCTION TO UNDO ABOVE\r
5906 \r
5907 MFUNCTION %%FREE,SUBR,FREE-RUN\r
5908         PUSHJ   P,1PROC\r
5909         CAME    PVP,1STEPR+1(B)\r
5910         JRST    FNDBND\r
5911         SETZM   1STEPR+1(B)\r
5912         JRST    FINIS\r
5913 \r
5914 FNDBND: SKIPE   1STEPR+1(B)     ; DOES IT HAVE ANY 1STEPPER?\r
5915         JRST    NOTMIN          ; YES, COMPLAIN\r
5916         MOVE    D,B             ; COPY PROCESS\r
5917         ADD     D,[1STEPR,,1STEPR]      ; POINTER FOR SEARCH\r
5918         HRRZ    C,SPSTO+1(B)    ; GET THIS BINDING STACK\r
5919 \r
5920 FNDLP:  GETYP   0,(C)           ; IS THIS A TBVL?\r
5921         CAIN    0,TBVL\r
5922         CAME    D,1(C)          ; SKIP IF THIS IS SAVED 1STEP SLOT\r
5923         JRST    FNDNXT\r
5924         SKIPN   3(C)            ; IS IT SAVING A REAL 1STEPPER?\r
5925         JRST    FNDNXT\r
5926         CAME    PVP,3(C)        ; IS IT ME?\r
5927         JRST    NOTMIN\r
5928         SETZM   3(C)            ; CLEAR OUT SAVED 1STEPPER\r
5929         JRST    FINIS\r
5930 FNDNXT: HRRZ    C,(C)           ; NEXT BINDING\r
5931         JUMPN   C,FNDLP\r
5932 \r
5933 NOTMIN: MOVE    C,$TCHSTR\r
5934         MOVE    D,CHQUOTE NOT-YOUR-1STEPEE\r
5935         PUSHJ   P,INCONS\r
5936         MOVSI   A,TFALSE\r
5937         JRST    FINIS\r
5938 \r
5939 1PROC:  ENTRY   1\r
5940         GETYP   A,(AB)\r
5941         CAIE    A,TPVP\r
5942         JRST    WTYP1\r
5943         MOVE    B,1(AB)\r
5944         MOVE    A,(AB)\r
5945         POPJ    P,\r
5946 \r
5947 ; FUNCTION TO RETRUN THE MAIN PROCESS\r
5948 \r
5949 MFUNCTION MAIN%%,SUBR,MAIN\r
5950         ENTRY   0\r
5951 \r
5952         MOVE    B,MAINPR\r
5953 MAIN1:  MOVSI   A,TPVP\r
5954         JRST    FINIS\r
5955 \r
5956 ; FUNCTION TO RETURN THE CURRENT PROCESS\r
5957 \r
5958 MFUNCTION ME,SUBR\r
5959         ENTRY   0\r
5960 \r
5961         MOVE    B,PVP\r
5962         JRST    MAIN1\r
5963 \r
5964 ; FUNCTION TO RETURN THE STATE OF A PROCESS\r
5965 \r
5966 MFUNCTION STATE,SUBR\r
5967         ENTRY   1\r
5968         GETYP   A,(AB)\r
5969         CAIE    A,TPVP\r
5970         JRST    WTYP1\r
5971         MOVE    A,1(AB)         ; GET PROCESS\r
5972         MOVE    A,PSTAT+1(A)\r
5973         MOVE    B,@STATES(A)    ; GET STATE\r
5974         MOVSI   A,TATOM\r
5975         JRST    FINIS\r
5976 \r
5977 STATES:\r
5978         IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED]\r
5979         MQUOTE A\r
5980         TERMIN\r
5981 \r
5982 \r
5983 \r
5984 END\r
5985 \f\r
5986 TITLE DECLARATION PROCESSOR\r
5987 \r
5988 RELOCA\r
5989 \r
5990 .INSRT MUDDLE >\r
5991 \r
5992 .GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT\r
5993 .GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC\r
5994 .GLOBAL CHLOCI,INCONS,SPCCHK,WTYP1\r
5995 \r
5996 ; Subr to allow user to access the DECL checking code\r
5997 \r
5998 MFUNCTION CHECKD,SUBR,[DECL?]\r
5999 \r
6000         ENTRY   2\r
6001 \r
6002         MOVE    C,(AB)\r
6003         MOVE    D,1(AB)\r
6004         MOVE    A,2(AB)\r
6005         MOVE    B,3(AB)\r
6006         PUSHJ   P,TMATCX        ; CHECK THEM\r
6007         JRST    IFALS\r
6008 \r
6009 RETT:   MOVSI   A,TATOM\r
6010         MOVE    B,MQUOTE T\r
6011         JRST    FINIS\r
6012 \r
6013 RETF:\r
6014 IFALS:  MOVEI   B,0\r
6015         MOVSI   A,TFALSE\r
6016         JRST    FINIS\r
6017 \r
6018 ; Subr to turn DECL checking on and off.\r
6019 \r
6020 MFUNCTION %DECL,SUBR,[DECL-CHECK]\r
6021 \r
6022         ENTRY   1\r
6023 \r
6024         GETYP   0,(AB)\r
6025         SETZM   IGDECL\r
6026         CAIN    0,TFALSE\r
6027         SETOM   IGDECL\r
6028         MOVE    A,(AB)\r
6029         MOVE    B,1(AB)\r
6030         JRST    FINIS\r
6031 \r
6032 ; Change special unspecial normal mode\r
6033 \r
6034 MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]\r
6035 \r
6036         ENTRY\r
6037 \r
6038         CAMGE   AB,[-3,,]\r
6039         JRST    TMA\r
6040         MOVE    C,SPCCHK        ; GET CURRENT\r
6041         JUMPGE  AB,MODER        ; RET CURRENT\r
6042         GETYP   0,(AB)          ; CHECK IT IS ATOM\r
6043         CAIE    0,TATOM\r
6044         JRST    WTYP1\r
6045         MOVE    0,1(AB)\r
6046         MOVEI   A,1\r
6047         CAMN    0,MQUOTE UNSPECIAL\r
6048         MOVSI   A,(SETZ)\r
6049         CAMN    0,MQUOTE SPECIAL\r
6050         MOVEI   A,0\r
6051         JUMPG   A,WTYP1\r
6052         HLLM    A,SPCCHK\r
6053 \r
6054 MODER:  MOVSI   A,TATOM\r
6055         MOVE    B,MQUOTE SPECIAL\r
6056         SKIPGE  C\r
6057         MOVE    B,MQUOTE UNSPECIAL\r
6058         JRST    FINIS\r
6059 \r
6060 ; Function to turn special checking on and of\r
6061 \r
6062 MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]\r
6063 \r
6064         ENTRY\r
6065         CAMGE   AB,[-3,,]\r
6066         JRST    TMA\r
6067 \r
6068         MOVE    C,SPCCHK\r
6069         JUMPGE  AB,SCHEK1\r
6070 \r
6071         MOVEI   A,0\r
6072         GETYP   0,(AB)\r
6073         CAIE    0,TFALSE\r
6074         MOVEI   A,1\r
6075         HRRM    A,SPCCHK\r
6076 \r
6077 SCHEK1: TRNN    C,1\r
6078         JRST    IFALS\r
6079         JRST    RETT\r
6080 \r
6081 ; Finction to set decls for GLOBAL values.\r
6082 \r
6083 MFUNCTION GDECL,FSUBR\r
6084 \r
6085         ENTRY   1\r
6086 \r
6087         GETYP   0,(AB)\r
6088         CAIE    0,TLIST\r
6089         JRST    WTYP1\r
6090 \r
6091         PUSH    TP,$TLIST\r
6092         PUSH    TP,1(AB)\r
6093         PUSH    TP,$TLIST\r
6094         PUSH    TP,[0]\r
6095         PUSH    TP,$TLIST\r
6096         PUSH    TP,[0]\r
6097 \r
6098 GDECL1: INTGO\r
6099         SKIPN   C,1(TB)\r
6100         JRST    RETT\r
6101         HRRZ    D,(C)           ; MAKE SURE PAIRS\r
6102         JUMPE   D,GDECLL        ; LOSER, GO AWAY\r
6103         GETYP   0,(C)\r
6104         CAIE    0,TLIST\r
6105         JRST    GDECLL\r
6106         HRRZ    0,(D)\r
6107         MOVEM   0,1(TB)         ; READY FOR NEXT CALL\r
6108         MOVE    C,1(C)          ; SAVE ATOM LIST\r
6109         MOVEM   C,5(TB)\r
6110         MOVEM   D,3(TB)\r
6111 \r
6112 GDECL2: INTGO\r
6113         SKIPN   C,5(TB)\r
6114         JRST    GDECL1          ; OUT OF ATOMS\r
6115         GETYP   0,(C)           ; IS THIS AN ATOM\r
6116         CAIE    0,TATOM\r
6117         JRST    GDECLL          ; NO, LOSE\r
6118         MOVE    B,1(C)\r
6119         HRRZ    C,(C)\r
6120         MOVEM   C,5(TB)\r
6121         PUSHJ   P,IIGLOC        ; GET ITS VAL (OR MAKE ONE)\r
6122         GETYP   0,(B)           ; UNBOUND?\r
6123         CAIE    0,TUNBOU\r
6124         JRST    CHKCUR          ; CHECK CURRENT VALUE\r
6125         MOVE    C,3(TB)         ; GET DECL\r
6126         HRRM    C,-2(B)\r
6127         JRST    GDECL2\r
6128 \r
6129 CHKCUR: HRRZ    D,3(TB)\r
6130         GETYP   A,(D)\r
6131         MOVSI   A,(A)\r
6132         MOVE    E,B\r
6133         MOVE    B,1(D)\r
6134         MOVE    C,(E)\r
6135         MOVE    D,1(E)\r
6136         PUSH    TP,$TVEC\r
6137         PUSH    TP,E\r
6138         JSP     E,CHKAB\r
6139         PUSHJ   P,TMATCH\r
6140         JRST    TYPMI3\r
6141         MOVE    E,(TP)\r
6142         SUB     TP,[2,,2]\r
6143         MOVE    D,3(TB)\r
6144         HRRM    D,-2(E)\r
6145         JRST    GDECL2\r
6146 \r
6147 TYPMI3: MOVE    E,(TP)          ; POINT BACK TO SLOT\r
6148         MOVE    A,-1(E)         ; ATOM TO A\r
6149         MOVE    B,1(E)\r
6150         MOVE    D,(E)           ; GET OLD VALUE\r
6151         MOVE    C,3(TB)\r
6152         JRST    TYPMIS          ; GO COMPLAIN\r
6153 \r
6154 GDECLL:         PUSH    TP,$TATOM\r
6155         PUSH    TP,EQUOTE BAD-ARGUMENT-LIST\r
6156         JRST    CALER1\r
6157 \r
6158 MFUNCTION UNMANIFEST,SUBR\r
6159 \r
6160         ENTRY\r
6161 \r
6162         PUSH    P,[HLLZS -2(B)]\r
6163         JRST    MANLP\r
6164 \r
6165 MFUNCTION MANIFEST,SUBR\r
6166 \r
6167         ENTRY\r
6168 \r
6169         PUSH    P,[HLLOS -2(B)]\r
6170 MANLP:  JUMPGE  AB,RETT\r
6171         GETYP   0,(AB)\r
6172         CAIE    0,TATOM\r
6173         JRST    WTYP\r
6174         MOVE    B,1(AB)\r
6175         PUSHJ   P,IIGLOC\r
6176         XCT     (P)\r
6177         ADD     AB,[2,,2]\r
6178         JRST    MANLP\r
6179 \r
6180 MFUNCTION MANIFQ,SUBR,[MANIFEST?]\r
6181 \r
6182         ENTRY   1\r
6183 \r
6184         GETYP   0,(AB)\r
6185         CAIE    0,TATOM\r
6186         JRST    WTYP1\r
6187 \r
6188         MOVE    B,1(AB)\r
6189         PUSHJ   P,IGLOC         ; GET POINTER IF ANY\r
6190         GETYP   0,A\r
6191         CAIN    0,TUNBOU\r
6192         JRST    RETF\r
6193         HRRZ    0,-2(B)\r
6194         CAIE    0,-1\r
6195         JRST    RETF\r
6196         JRST    RETT\r
6197         \r
6198 MFUNCTION GETDECL,SUBR,[GET-DECL]\r
6199 \r
6200         ENTRY   1\r
6201 \r
6202         PUSHJ   P,GTLOC\r
6203         JRST    GTLOCA\r
6204 \r
6205         HRRZ    C,-2(B)         ; GET GLOBAL DECL\r
6206 GETD1:  JUMPE   C,RETF\r
6207         CAIN    C,-1\r
6208         JRST    RETMAN\r
6209         GETYP   A,(C)\r
6210         MOVSI   A,(A)\r
6211         MOVE    B,1(C)\r
6212         JSP     E,CHKAB\r
6213         JRST    FINIS\r
6214 \r
6215 RETMAN: MOVSI   A,TATOM\r
6216         MOVE    B,MQUOTE MANIFEST\r
6217         JRST    FINIS\r
6218 \r
6219 GTLOCA: HLRZ    C,2(B)          ; LOCAL DECL\r
6220         JRST    GETD1\r
6221 \r
6222 MFUNCTION PUTDECL,SUBR,[PUT-DECL]\r
6223 \r
6224         ENTRY   2\r
6225 \r
6226         PUSHJ   P,GTLOC\r
6227         SKIPA   E,[HRLM B,2(C)]\r
6228         MOVE    E,[HRRM B,-2(C)]\r
6229         PUSH    P,E\r
6230         GETYP   0,(B)           ; ANY VALUE\r
6231         CAIN    0,TUNBOU\r
6232         JRST    PUTD1\r
6233         MOVE    C,(B)           ; GET CURRENT VALUE\r
6234         MOVE    D,1(B)\r
6235         MOVE    A,2(AB)\r
6236         MOVE    B,3(AB)\r
6237         PUSHJ   P,TMATCH\r
6238         JRST    TYPMI4\r
6239 PUTD1:  MOVE    C,2(AB)         ; GET DECL BACK\r
6240         MOVE    D,3(AB)\r
6241         PUSHJ   P,INCONS        ; CONS IT UP\r
6242         MOVE    C,1(AB)         ; LOCATIVE BACK\r
6243         XCT     (P)             ; CLOBBER\r
6244         MOVE    A,(AB)\r
6245         MOVE    B,1(AB)\r
6246         JRST    FINIS\r
6247 \r
6248 TYPMI4: MOVE    E,1(AB)         ; GET LOCATIVE\r
6249         MOVE    A,-1(E)         ; NOW ATOM\r
6250         MOVEI   C,2(AB)         ; POINT TO DECL\r
6251         MOVE    D,(E)           ; AND CURRENT VAL\r
6252         MOVE    B,1(E)\r
6253         JRST    TYPMIS\r
6254 \r
6255 GTLOC:  GETYP   0,(AB)\r
6256         CAIE    0,TLOCD\r
6257         JRST    WTYP1\r
6258         MOVEI   B,(AB)\r
6259         PUSHJ   P,CHLOCI\r
6260         HRRZ    0,(AB)          ; LOCAL OR GLOBAL\r
6261         SKIPN   0\r
6262         AOS     (P)\r
6263         MOVE    B,1(AB)         ; RETURN LOCATIVE IN B\r
6264         POPJ    P,\r
6265 \r
6266 ; Interface between EVAL and declaration processor.\r
6267 ; E points into stack at a binding and C points to decl list.\r
6268 \r
6269 CHKDCL: SKIPE   IGDECL          ; IGNORING DECLS?\r
6270         POPJ    P,              ; YUP, JUST LEAVE\r
6271 \r
6272         PUSH    TP,$TTP         ; SAVE BINDING\r
6273         PUSH    TP,E\r
6274         MOVE    A,-4(E)         ; GET ATOM\r
6275         MOVSI   0,TLIST         ; SETUP FOR INTERRUPTABLE\r
6276         MOVEM   0,CSTO(PVP)\r
6277         MOVEM   0,BSTO(PVP)\r
6278         MOVSI   0,TATOM\r
6279         MOVEM   0,ASTO(PVP)\r
6280         SETZB   B,0             ; CLOBBER FOR INTGO\r
6281 \r
6282 DCL2:   INTGO\r
6283         HRRZ    D,(C)           ; MAKE SURE EVEN ELEMENTS\r
6284         JUMPE   D,BADCL\r
6285         GETYP   B,(C)           ; MUST BE LIST OF ATOMS\r
6286         CAIE    B,TLIST\r
6287         JRST    BADCL\r
6288         MOVE    B,1(C)          ; GET LIST\r
6289 \r
6290 DCL1:   INTGO\r
6291         CAMN    A,1(B)          ; SKIP IF NOT WINNER\r
6292         JRST    DCLQ            ; MAY BE WINNER\r
6293 DCL3:   HRRZ    B,(B)           ; CDR ON\r
6294         JUMPN   B,DCL1          ; JUMP IF MORE\r
6295 \r
6296         HRRZ    C,(D)           ; CDR MAIN LIST\r
6297         JUMPN   C,DCL2          ; AND JUMP IF WINNING\r
6298 \r
6299         PUSHJ   P,E.GET         ; GET BINDING BACK\r
6300         SUB     TP,[2,,2]       ; POP OF JUNK\r
6301         POPJ    P,\r
6302 \r
6303 DCLQ:   GETYP   C,(B)           ; CHECK ATOMIC\r
6304         CAIE    C,TATOM\r
6305         JRST    BADCL           ; LOSER\r
6306         PUSHJ   P,E.GET         ; GOT IT\r
6307         PUSH    TP,$TLIST       ; SAVE PATTERN\r
6308         PUSH    TP,D\r
6309         MOVE    B,1(D)          ; GET PATTERN\r
6310         HLLZ    A,(D)\r
6311         MOVE    C,-3(E)         ; PROPOSED VALUE\r
6312         MOVE    D,-2(E)\r
6313         PUSHJ   P,TMATCH        ; MATCH TYPE\r
6314         JRST    TYPMI1          ; LOSER\r
6315 DCLQ1:  MOVE    E,-2(TP)\r
6316         MOVE    C,-5(E)         ; CHECK FOR SPEC CHANGE\r
6317         SKIPE   0               ; MAKE SURE NON ZERO IS -1\r
6318         MOVNI   0,1\r
6319         SKIPL   SPCCHK          ; SKIP IF NORMAL UNSPECIAL\r
6320         SETCM   0               ; COMPLEMENT\r
6321         ANDI    0,1             ; ONE BIT\r
6322         CAMN    C,[TATOM,,-1]\r
6323         JRST    .+3\r
6324         CAME    C,[TATOM,,-2]\r
6325         JRST    .+3\r
6326         ANDCMI  C,1\r
6327         IOR     C,0             ; MUNG BIT\r
6328         MOVEM   C,-5(E)\r
6329         HRRZ    C,(TP)\r
6330         SUB     TP,[4,,4]\r
6331         MOVEM   C,(E)           ; STORE DECLS\r
6332         MOVSI   C,TLIST\r
6333         MOVEM   C,-1(E)\r
6334         POPJ    P,\r
6335 \r
6336 TYPMI1: MOVE    E,-2(TP)\r
6337         GETYP   C,-3(E)\r
6338         CAIN    C,TUNBOU\r
6339         JRST    DCLQ1\r
6340         MOVE    E,-2(TP)        ; GET POINTER TO BIND\r
6341         MOVE    D,-3(E)         ; GET VAL\r
6342         MOVE    B,-2(E)\r
6343         HRRZ    C,(TP)          ; DCL LIST\r
6344         MOVE    A,-4(E)         ; GET ATOM\r
6345         SUB     TP,[4,,4]\r
6346 TYPMIS: PUSH    TP,$TATOM\r
6347         PUSH    TP,EQUOTE TYPE-MISMATCH\r
6348         PUSH    TP,$TATOM\r
6349         PUSH    TP,A\r
6350         PUSH    TP,(C)\r
6351         HLLZS   (TP)\r
6352         PUSH    TP,1(C)\r
6353         JSP     E,CHKARG        ; HACK DEFER\r
6354         PUSH    TP,D\r
6355         PUSH    TP,B\r
6356         MOVEI   A,4             ; 3 ERROR ARGS\r
6357         JRST    CALER\r
6358 \r
6359 BADCL:  PUSHJ   P,E.GET\r
6360         PUSH    TP,$TATOM\r
6361         PUSH    TP,EQUOTE BAD-DECLARATION-LIST\r
6362         JRST    CALER1\r
6363 \r
6364 ; ROUTINE TO RESSET INT STUFF\r
6365 \r
6366 E.GET:  MOVE    E,(TP)\r
6367         SETZM   ASTO(PVP)\r
6368         SETZM   BSTO(PVP)\r
6369         SETZM   CSTO(PVP)\r
6370         POPJ    P,\r
6371 \r
6372 ; Declarations processor for MUDDLE type declarations.\r
6373 ; Receives a pattern in a and B and an object in C and D.\r
6374 ; It skip returns if the object fits otherwise it doesn't.\r
6375 ; Declaration syntax errors are caught and sent to ERROR.\r
6376 \r
6377 TMATCH: MOVEI   0,1             ; RET SPECIAL INDICATOR\r
6378         SKIPE   IGDECL          ; IGNORING DECLS?\r
6379         JRST    CPOPJ1          ; YUP, ACT LIKE THEY WON\r
6380 \r
6381 TMATCX: GETYP   0,A             ; GET PATTERNS TYPE\r
6382         CAIN    0,TFORM         ; MUST BE FORM OR ATOM\r
6383         JRST    TMAT1\r
6384         CAIE    0,TATOM\r
6385         JRST    TERR1           ; WRONG TYPE FOR A DCL\r
6386 \r
6387 ; SIMPLE TYPE MATCHER\r
6388 \r
6389 TYPMAT: GETYP   E,C             ; OBJECTS TYPE TO E\r
6390         PUSH    P,E             ; SAVE IT\r
6391         PUSHJ   P,TYPFND        ; CONVERT TYPE NAME TO CODE\r
6392         JRST    SPECS           ; NOT A TYPE NAME, TRY SPECIALS\r
6393         POP     P,E             ; RESTORE TYPE OF OBJECT\r
6394         MOVEI   0,0             ; SPECIAL INDICATOR\r
6395         CAIN    E,(D)           ; SKIP IF LOSERS\r
6396 CPOPJ1: AOS     (P)             ; GOOD RETURN\r
6397 CPOPJ:  POPJ    P,\r
6398 \r
6399 SPECS:  POP     P,A             ; RESTORE OBJECTS TYPE\r
6400         CAMN    B,MQUOTE ANY\r
6401         JRST    CPOPJ1          ; RETURN IMMEDIATELY IF ANYTHING WINS\r
6402         CAMN    B,MQUOTE STRUCTURED\r
6403         JRST    ISTRUC          ; LET ISTRUC DO THE WORK\r
6404         CAMN    B,MQUOTE APPLICABLE\r
6405         JRST    APLQ\r
6406         CAME    B,MQUOTE LOCATIVE\r
6407         JRST    TERR2\r
6408         JRST    LOCQQ\r
6409 \r
6410 ; ARRIVE HERE FOR A FORM IN THE DCLS\r
6411 \r
6412 TMAT1:  JUMPE   B,TERR3         ; EMPTY FORM LOSES\r
6413         HRRZ    E,(B)           ; CDR IT\r
6414         JUMPE   E,TMAT3         ; CANT BE SPECIAL/UNSPECIAL, LEAVE\r
6415         PUSHJ   P,0ATGET        ; GET POSSIBLE ATOM IN 0\r
6416         JRST    TEXP1           ; NOT ATOM\r
6417         CAME    0,MQUOTE SPECIAL\r
6418         CAMN    0,MQUOTE UNSPECIAL\r
6419         JRST    TMAT2           ; IGNORE SPECIAL/UNSPECIAL\r
6420 TMAT3:  PUSHJ   P,TEXP1\r
6421         JRST    .+2\r
6422         AOS     (P)\r
6423         MOVEI   0,0             ; RET UNSPECIAL INDICATION\r
6424         POPJ    P,\r
6425 \r
6426 TEXP1:  JUMPE   B,TERR3         ; EMPTY FORM\r
6427         GETYP   0,A             ; CHECK CURRENT TYPE\r
6428         CAIN    0,TATOM         ; IF ATOM,\r
6429         JRST    TYPMA1          ; SIMPLE MATCH\r
6430         CAIE    0,TFORM\r
6431         JRST    TERR4\r
6432         GETYP   0,(B)           ; WHAT IS FIRST ELEMEMT\r
6433         CAIE    0,TFORM         ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>\r
6434         JRST    0,TEXP12\r
6435         PUSH    TP,$TLIST       ; SAVE LIST\r
6436         PUSH    TP,B\r
6437         MOVE    B,1(B)          ; GET FORM\r
6438         PUSH    TP,C\r
6439         PUSH    TP,D\r
6440         PUSHJ   P,ACTRT1\r
6441         TDZA    0,0             ; REMEMBER LACK OF SKIP\r
6442         MOVEI   0,1\r
6443         POP     TP,D\r
6444         POP     TP,C\r
6445         MOVE    B,(TP)          ; GET BACK SAVED LIST\r
6446         SUB     TP,[2,,2]\r
6447         JUMPE   0,CPOPJ         ; LOSERS EXIT IMMEDIATELY\r
6448         HRRZ    B,(B)           ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE\r
6449 \r
6450 ; CHECKS TYPES OF ELEMENTS OF STRUCTURES\r
6451 \r
6452 ELETYP: JUMPE   B,CPOPJ1        ; EMPTY=> WON\r
6453         PUSH    TP,$TLIST       ; SAVE DCL LIST\r
6454         PUSH    TP,B\r
6455         MOVE    A,C             ; GET OBJ IN A AND B\r
6456         MOVE    B,D\r
6457         PUSHJ   P,TYPSGR        ; GET REST/NTH CODE\r
6458         JRST    ELETYL          ; LOSER\r
6459         PUSH    TP,DSTO(PVP)\r
6460         PUSH    TP,D\r
6461         PUSH    P,C             ; SAVE CODE\r
6462         PUSH    TP,[0]          ; AND SLOTS\r
6463         PUSH    TP,[0]\r
6464 \r
6465 ; MAIN ELEMENT SCANNING LOOP\r
6466 \r
6467 ELETY1: XCT     TESTR(C)        ; SKIP IF OBJ NOT EMPTY\r
6468         JRST    ELETY2          ; CHEK EMPTY WINNER\r
6469         XCT     TYPG(C)         ; GET ELEMENT\r
6470         XCT     VALG(C)\r
6471         JSP     E,CHKAB         ; CHECK OUT DEFER\r
6472         MOVEM   A,-1(TP)        ; AND SAVE IT\r
6473         MOVEM   B,(TP)\r
6474         MOVE    C,A\r
6475         MOVE    D,B             ; FOR OTHER MATCHERS\r
6476         MOVE    B,-4(TP)        ; GET PATTERN\r
6477         MOVE    A,(B)\r
6478         GETYP   0,(B)           ; GET TYPE OF <1 pattern>\r
6479         MOVE    B,1(B)          ; GET ATOM OR WHATEVER\r
6480         CAIE    0,TATOM         ; ATOM ... SIMPLE TYPE\r
6481         JRST    ELETY3\r
6482         PUSHJ   P,TYPMAT        ; DO SIMPLE TYPE MATCH  \r
6483         JRST    ELETY4          ; LOSER\r
6484 \r
6485 ; HERE TO REST EVERYTHING AND GO ON BACK\r
6486 \r
6487 ELETY6: MOVE    D,-2(TP)        ; GET OBJ POINTER\r
6488         MOVE    C,(P)           ; GET INCREMENT CODE\r
6489         XCT     INCR1(C)\r
6490         MOVEM   D,-2(TP)        ; SAVED INCREMENTED GOODIR\r
6491         MOVE    0,DSTO(PVP)\r
6492         MOVEM   0,-3(TP)\r
6493 \r
6494 ELETY9: HRRZ    B,@-4(TP)       ; CDR IT\r
6495         MOVEM   B,-4(TP)\r
6496         JUMPN   B,ELETY1\r
6497 \r
6498 ; HERE IF PATTERN EMPTY\r
6499 \r
6500 ELETY8: AOS     -1(P)           ; SKIP RETURN\r
6501 ELETY4: SETZM   DSTO(PVP)\r
6502         SUB     P,[1,,1]\r
6503         SUB     TP,[6,,6]\r
6504         POPJ    P,\r
6505 \r
6506 ELETYL: SUB     TP,[2,,2]\r
6507         POPJ    P,\r
6508 \r
6509 ; HERE TO HANDLE EMPTY OBJECT\r
6510 \r
6511 ELETY2: MOVE    B,-4(TP)        ; GET PATTERN\r
6512         GETYP   0,(B)           ; CHECK FOR [REST ...]\r
6513         SETZM   DSTO(PVP)\r
6514         CAIE    0,TVEC\r
6515         JRST    ELETY4          ; LOSER\r
6516         HLRZ    0,1(B)          ; SIZE OF IT\r
6517         CAILE   0,-4            ; MUST BE 2\r
6518         JRST    ELETY4\r
6519         MOVE    B,1(B)          ; GET IT\r
6520         PUSHJ   P,0ATGET        ; LOOK FOR REST\r
6521         JRST    ELETY4\r
6522         CAMN    0,MQUOTE REST\r
6523         JRST    ELETY8          ; WINNER!!!!\r
6524         JRST    ELETY4          ; LOSER\r
6525 \r
6526 ; HERE TO CHECK OUT A FORM ELEMNT\r
6527 \r
6528 ELETY3: CAIE    0,TFORM\r
6529         JRST    ELETY7\r
6530         SETZM   DSTO(PVP)\r
6531         PUSHJ   P,TEXP1         ; AND ANALYSE IT\r
6532         JRST    ELETY4          ; LOSER\r
6533         MOVE    0,-3(TP)        ; RESET DSTO\r
6534         MOVEM   0,DSTO(PVP)\r
6535         JRST    ELETY6          ; WINNER\r
6536 \r
6537 ; CHECK FOR VECTOR IN PATTERN\r
6538 \r
6539 ELETY7: CAIE    0,TVEC          ; SKIP IF WINNER\r
6540         JRST    TERR12          ; YET ANOTHER ERROR\r
6541         HLRE    C,B             ; CHECK LEENGTH\r
6542         CAMLE   C,[-4]          ; MUST BE 2 LONG\r
6543         JRST    TERR13\r
6544         PUSHJ   P,0ATGET        ; 1ST ELEMENT ATOM?\r
6545         JRST    ELET71          ; COULD BE FORM\r
6546         CAME    0,MQUOTE REST\r
6547         JRST    TERR14\r
6548         MOVNI   0,1             ; FLAG USED IN RESTIT\r
6549         PUSHJ   P,RESTIT        ; CHECK REST OF STRUCTUR\r
6550         JRST    ELETY4\r
6551         JRST    ELETY8          ; WIN AND DONE\r
6552 \r
6553 ; CHECK FOR [fix .... ]\r
6554 \r
6555 ELET71: CAIE    0,TFIX\r
6556         JRST    TERR15\r
6557         MOVNS   C\r
6558         ASH     C,-1\r
6559         MOVE    0,1(B)          ; GET NUMBER\r
6560         IMULI   0,-1(C)         ; COUNT MORE\r
6561         PUSHJ   P,RESTIT        ; AND CHECK FIX NUM OF ELEMENTS\r
6562         JRST    ELETY4\r
6563         MOVE    D,-2(TP)        ; GET OBJECT BACK\r
6564         MOVE    0,-3(TP)        ; RESET DSTO\r
6565         MOVEM   0,DSTO(PVP)\r
6566         MOVE    C,(P)           ; RESTORE CODE FOR RESTING ETC.\r
6567         JRST    ELETY9\r
6568 \r
6569 \r
6570 ; HERE TO DO A TASTEFUL TYPMAT\r
6571 \r
6572 TYPMA1: PUSH    TP,C\r
6573         PUSH    TP,D\r
6574         PUSHJ   P,TYPMAT\r
6575         TDZA    0,0             ; REMEMBER LOSSAGE\r
6576         MOVEI   0,1             ; OR WINNAGE\r
6577         POP     TP,D\r
6578         POP     TP,C            ; RESTORE OBJECT\r
6579         JUMPN   0,CPOPJ1        ; SKIPPED BEFORE, SKIP AGAIN\r
6580         POPJ    P,\r
6581 \r
6582 ; HERE TO SKIP SPECIAL/UNSPECIAL\r
6583 \r
6584 TMAT2:  CAME    0,MQUOTE SPECIAL\r
6585         TDZA    0,0\r
6586         MOVEI   0,1\r
6587         PUSH    P,0             ; SAVE INDICATOR\r
6588         GETYP   A,(E)           ; TYPE OF NEW PAT\r
6589         MOVE    B,1(E)          ; VALUE\r
6590         MOVSI   A,(A)\r
6591         PUSHJ   P,TEXP1\r
6592         JRST    .+2\r
6593         AOS     -1(P)\r
6594         POP     P,0\r
6595         POPJ    P,\r
6596 \r
6597 ; LOOK FOR <OR...   OR <PRIMTYPE....\r
6598 \r
6599 TEXP12: CAIE    0,TATOM\r
6600         JRST    TERR5\r
6601         MOVE    0,1(B)          ; GET ATOM\r
6602         CAMN    0,MQUOTE QUOTE\r
6603         JRST    MQUOT           ; MATCH A QUOTED OBJECT\r
6604         CAME    0,MQUOTE OR\r
6605         CAMN    0,MQUOTE PRIMTYPE\r
6606         JRST    ACTORT          ; FALL INTO ACTOR HACKER\r
6607         PUSH    TP,$TLIST\r
6608         PUSH    TP,B\r
6609         MOVE    B,0             ; GET ATOM\r
6610         PUSH    TP,C            ; SAVE OBJ\r
6611         PUSH    TP,D\r
6612         PUSHJ   P,TYPMAT\r
6613         TDZA    0,0\r
6614         MOVEI   0,1\r
6615         MOVE    C,-1(TP)\r
6616         MOVE    D,(TP)\r
6617         MOVE    B,-2(TP)\r
6618         JUMPN   0,.+3           ; TO ELETYP IF WON\r
6619         SUB     TP,[4,,4]\r
6620         POPJ    P,              ; ELSE LOSE\r
6621 \r
6622         HRRZ    0,(B)\r
6623         MOVSI   A,TFORM\r
6624         JUMPE   0,TERR3\r
6625         MOVE    B,0\r
6626         PUSHJ   P,ELETYP\r
6627         TDZA    0,0\r
6628         MOVEI   0,1\r
6629 POPPIT: POP     TP,D\r
6630         POP     TP,C\r
6631         POP     TP,B\r
6632         POP     TP,A\r
6633         JUMPN   0,CPOPJ1\r
6634         POPJ    P,\r
6635         \r
6636 ; THIS CODE HANDLES ORs AND PRIMTYPEs\r
6637 ACTRT1: SKIPA   E,[PACT]\r
6638 \r
6639 ACTORT: MOVEI   E,TEXP1\r
6640         JUMPE   B,TERR6         ; EMPTY, LOSE\r
6641         PUSHJ   P,0ATGET        ; ATOM TO 0\r
6642         JRST    PACT\r
6643         CAME    0,MQUOTE OR\r
6644         JRST    PACT2\r
6645         HRRZ    0,(B)           ; REST IT FLUSHING OR\r
6646         JUMPE   0,TERR7\r
6647         PUSH    TP,$TLIST       ; SAVE LSIT\r
6648         PUSH    TP,0\r
6649         PUSH    P,E             ; SAVE ELEMENT CHECKER\r
6650 \r
6651 ORLP:   SKIPN   B,(TP)          ; ANY LEFT?\r
6652         JRST    ORDON           ; NOPE, LOSE\r
6653         HRRZ    0,(B)           ; SAVE THE REST\r
6654         MOVEM   0,(TP)\r
6655         GETYP   0,(B)           ; WHAT ARE WE ORing\r
6656         MOVE    A,(B)           ; TYPE WORD\r
6657         MOVE    B,1(B)          ; AND ITEM\r
6658         PUSHJ   P,@(P)          ; EITHER PACT OR TEXP1\r
6659         JRST    ORLP            ; HAVEN'T WON YET\r
6660         AOS     -1(P)           ; SKIP RETURN FOR WINNER\r
6661 \r
6662 ORDON:  SUB     TP,[2,,2]       ; FLUSH TEMP\r
6663         SUB     P,[1,,1]\r
6664         POPJ    P,\r
6665 \r
6666 ; HERE TO PRIMTYPE ACTORS\r
6667 \r
6668 PACT:   CAIE    0,TFORM\r
6669         JRST    PACT1\r
6670         JUMPE   B,TERR6         ; EMPTY FORM\r
6671         MOVE    0,1(B)          ; FIRST ELEMENT MUST BE PRIMTYPE\r
6672 PACT2:  CAME    0,MQUOTE PRIMTYPE\r
6673         JRST    TERR7\r
6674         HRRZ    B,(B)           ; GET PRIMTYPE\r
6675         JUMPE   B,TERR7\r
6676         GETYP   A,C             ; GET OBJ TYPE\r
6677         GETYP   0,(B)           ; GET PATTERN TYPE\r
6678         CAIE    0,TATOM         ; BETTER BE ATOM\r
6679         JRST    TERR8\r
6680         PUSH    TP,$TLIST       ; SAVE DCL LIST\r
6681         PUSH    TP,B\r
6682         PUSH    TP,C\r
6683         PUSH    TP,D\r
6684         PUSHJ   P,SAT           ; GET STORAGE TYPE\r
6685         CAILE   A,NUMSAT\r
6686         JRST    PTEMP\r
6687         MOVE    B,@STBL(A)      ; GET PRIM NAME\r
6688         PUSHJ   P,TYPFND\r
6689         JFCL                    ; MUST EXIST\r
6690         MOVSI   C,(D)           ; FAKE OUT TYPMAT\r
6691         MOVE    B,-2(TP)\r
6692         MOVE    B,1(B)\r
6693         PUSHJ   P,TYPMAT\r
6694         JRST    .+2\r
6695         AOS     (P)\r
6696         MOVE    C,-1(TP)\r
6697         MOVE    D,(TP)\r
6698         SUB     TP,[4,,4]\r
6699         POPJ    P,\r
6700 \r
6701 PACT1:  CAIE    0,TATOM\r
6702         JRST    TERR4\r
6703         JRST    TYPMAT\r
6704 \r
6705 PTEMP:  MOVE    B,-2(TP)\r
6706         MOVE    B,1(B)\r
6707         CAMN    B,MQUOTE TEMPLATE\r
6708         AOS     (P)\r
6709         SUB     TP,[4,,4]\r
6710         POPJ    P,\r
6711 \r
6712 ; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE\r
6713 \r
6714 RESTIT: PUSH    TP,$TVEC        ; SAVE TYPE\r
6715         ADD     B,[2,,2]        ; SKIP OVER CRUFT\r
6716         PUSH    TP,B            ; AND VAL\r
6717         PUSH    TP,$TVEC\r
6718         PUSH    TP,B\r
6719 RESTI1: PUSH    P,A             ; SAVE DISP HACK\r
6720         PUSH    P,0             ; AND COUNT HACK\r
6721 RESTI4: SKIPL   (P)             ; SKIP IF DOING ALL\r
6722         SOSL    (P)             ; SKIP IF DONE\r
6723         JRST    RESTI6\r
6724         AOS     -2(P)           ; SKIP RET\r
6725 RESTI5: SUB     P,[2,,2]        ; POP JUNK\r
6726         SUB     TP,[4,,4]\r
6727         POPJ    P,\r
6728 RESTI6: MOVE    C,-3(P)         ; REST CODE\r
6729         MOVE    D,-6(TP)        ; SET UP FOR REST\r
6730         MOVE    E,-7(TP)        ; DONT FORGET DSTO\r
6731         MOVEM   E,DSTO(PVP)\r
6732         XCT     TESTR(C)        ; DONE?\r
6733         JRST    RESTI2          ; YES, CHECK WINNAGE\r
6734         XCT     TYPG(C)\r
6735         XCT     VALG(C)         ; GET VAL ANDTYPE\r
6736         JSP     E,CHKAB         ; CHECK DEFER\r
6737         XCT     INCR1(C)        ; REST IT\r
6738         MOVEM   D,-6(TP)        ; SAVE LIST\r
6739         MOVE    E,DSTO(PVP)\r
6740         MOVEM   E,-7(TP)        ; FIXUP\r
6741         SETZM   DSTO(PVP)\r
6742         MOVE    C,A\r
6743         MOVE    D,B\r
6744         SKIPL   A,(TP)  ; ANY MORE?\r
6745         MOVE    A,-2(TP)        ; NO RECYCLE\r
6746         ADD     A,[2,,2]        ; BUMP\r
6747         MOVEM   A,(TP)          ; AND SAVE\r
6748         MOVE    B,-1(A)         ; GET ELEMENT\r
6749         MOVE    A,-2(A)\r
6750         GETYP   0,A\r
6751         MOVEI   E,TERR15\r
6752         CAIN    0,TATOM\r
6753         MOVEI   E,TYPMAT        ; ATOM --> SIMPLE TYPE\r
6754         CAIN    0,TFORM         ; FORM--> HAIRY PATTERN\r
6755         MOVEI   E,TEXP1\r
6756         PUSHJ   P,(E)           ; DO IT\r
6757         JRST    RESTI5\r
6758         JRST    RESTI4\r
6759 \r
6760 RESTI2: SKIPGE  (P)             ; SKIP IF WON\r
6761         AOS     -2(P)           ; COUNTERACT CPOPJ1\r
6762         JRST    RESTI5\r
6763 \r
6764 RESTI3: TEXP1\r
6765         TYPMAT\r
6766 \r
6767 ; HERE TO MATHC A QUOTED OBJ\r
6768 ;       B/ FORM QUOTE...  C,D/ OBJECT TO MATCH AGAINST\r
6769 \r
6770 MQUOT:  HRRZ    B,(B)           ; LOOK AT NEXT\r
6771         JUMPE   B,TERR7\r
6772         GETYP   A,(B)           ; GET TYPE\r
6773         MOVSI   A,(A)\r
6774         MOVE    B,1(B)          ; AND VALUE\r
6775         JSP     E,CHKAB         ; HACK DEFER\r
6776         PUSH    TP,A\r
6777         PUSH    TP,B\r
6778         PUSH    TP,C\r
6779         PUSH    TP,D\r
6780         MOVEI   D,-3(TP)\r
6781         MOVEI   C,-1(TP)\r
6782         PUSHJ   P,IEQUAL\r
6783         TDZA    0,0\r
6784         MOVEI   0,1\r
6785         JRST    POPPIT\r
6786 \r
6787 \r
6788 ; GET ATOM IN AC 0\r
6789 \r
6790 0ATGET: GETYP   0,(B)\r
6791         CAIE    0,TATOM         ; SKIP IF ATOM\r
6792         POPJ    P,\r
6793         MOVE    0,1(B)          ; GET ATOM\r
6794         JRST    CPOPJ1\r
6795 \r
6796 TERR9:  MOVS    A,0             ; TYPE TO A\r
6797 TERR4:\r
6798 TERR5:\r
6799 TERR15:\r
6800 TERR1:  MOVE    E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM\r
6801         JRST    TERRD\r
6802 \r
6803 TERR2:  MOVSI   A,TATOM\r
6804         MOVE    E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL\r
6805         JRST    TERRD\r
6806 TERR6:\r
6807 TERR3:  MOVE    E,EQUOTE EMPTY-FORM-IN-DECL\r
6808         JRST    TERRD\r
6809 TERR7:  MOVE    E,EQUOTE EMPTY-OR/PRIMTYPE-FORM\r
6810         JRST    TERRD\r
6811 \r
6812 TERR8:  MOVS    A,0             ; TYPE TO A\r
6813         MOVE    E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG\r
6814         JRST    TERRD\r
6815 TERR12: MOVE    E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR\r
6816         JRST    TERRD\r
6817 TERR13: MOVE    E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS\r
6818         JRST    TERRD\r
6819 TERR14: MOVE    E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX\r
6820 \r
6821 TERRD:  PUSH    TP,$TATOM\r
6822         PUSH    TP,EQUOTE BAD-TYPE-SPECIFICATION\r
6823         PUSH    TP,$TATOM\r
6824         PUSH    TP,E\r
6825         PUSH    TP,A\r
6826         PUSH    TP,B\r
6827         MOVEI   A,3\r
6828         JRST    CALER\r
6829 \r
6830 IMPURE\r
6831 \r
6832 IGDECL: 0\r
6833 \r
6834 PURE\r
6835 \r
6836 END\r
6837 \f\fTITLE EVAL -- MUDDLE EVALUATOR\r
6838 \r
6839 RELOCATABLE\r
6840 \r
6841 ; GERALD JAY SUSSMAN, 1971.  REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)\r
6842 \r
6843 \r
6844 .GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM\r
6845 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR\r
6846 .GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS\r
6847 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1\r
6848 .GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL\r
6849 .GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1\r
6850 .GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND\r
6851 .GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS\r
6852 .GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND\r
6853 .GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT\r
6854 .GLOBAL SPECBE\r
6855 .GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2\r
6856 \r
6857 .INSRT MUDDLE >\r
6858 \r
6859 MONITOR\r
6860 \r
6861 \f\r
6862 ; ENTRY TO EXPAND A MACRO\r
6863 \r
6864 MFUNCTION EXPAND,SUBR\r
6865 \r
6866         ENTRY   1\r
6867 \r
6868         MOVEI   A,PVLNT*2+1(PVP)\r
6869         HRLI    A,TFRAME\r
6870         MOVE    B,TBINIT+1(PVP)\r
6871         HLL     B,OTBSAV(B)\r
6872         PUSH    TP,A\r
6873         PUSH    TP,B\r
6874         MOVEI   B,-1(TP)\r
6875         JRST    AEVAL2\r
6876 \r
6877 ; MAIN EVAL ENTRANCE\r
6878 \r
6879 MFUNCTION       EVAL,SUBR\r
6880 \r
6881         ENTRY\r
6882 \r
6883         SKIPE   C,1STEPR+1(PVP) ; BEING 1 STEPPED?\r
6884         JRST    1STEPI          ; YES HANDLE\r
6885 EVALON: HLRZ    A,AB            ;GET NUMBER OF ARGS\r
6886         CAIE    A,-2            ;EXACTLY 1?\r
6887         JRST    AEVAL           ;EVAL WITH AN ALIST\r
6888 SEVAL:  GETYP   A,(AB)          ;GET TYPE OF ARG\r
6889         SKIPE   C,EVATYP+1(TVP) ; USER TYPE TABLE?\r
6890         JRST    EVDISP\r
6891 SEVAL1: CAIG    A,NUMPRI        ;PRIMITIVE?\r
6892         JRST    @EVTYPE(A)      ;YES-DISPATCH\r
6893 \r
6894 SELF:   MOVE    A,(AB)          ;TYPES WHICH EVALUATE \r
6895         MOVE    B,1(AB)\r
6896         JRST    EFINIS          ;TO SELF-EG NUMBERS\r
6897 \r
6898 ; HERE FOR USER EVAL DISPATCH\r
6899 \r
6900 EVDISP: ADDI    C,(A)           ; POINT TO SLOT\r
6901         ADDI    C,(A)\r
6902         SKIPE   (C)             ; SKIP EITHER A LOSER OR JRST DISP\r
6903         JRST    EVDIS1          ; APPLY EVALUATOR\r
6904         SKIPN   C,1(C)          ; GET ADDR OR GO TO PURE DISP\r
6905         JRST    SEVAL1\r
6906         JRST    (C)\r
6907 \r
6908 EVDIS1: PUSH    TP,(C)\r
6909         PUSH    TP,1(C)\r
6910         PUSH    TP,(AB)\r
6911         PUSH    TP,1(AB)\r
6912         MCALL   2,APPLY         ; APPLY HACKER TO OBJECT\r
6913         JRST    EFINIS\r
6914 \r
6915 \r
6916 ; EVAL DISPATCH TABLE\r
6917 \r
6918 DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]\r
6919 [TSEG,ILLSEG]]\r
6920 \f\r
6921 \r
6922 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID\r
6923 AEVAL:\r
6924         CAIE    A,-4            ;EXACTLY 2 ARGS?\r
6925         JRST    WNA             ;NO-ERROR\r
6926         GETYP   A,2(AB)         ;CHECK THAT WE HAVE A FRAME\r
6927         CAIE    A,TACT\r
6928         CAIN    A,TFRAME\r
6929         JRST    .+3\r
6930         CAIE    A,TENV\r
6931         JRST    TRYPRO          ; COULD BE PROCESS\r
6932         MOVEI   B,2(AB)         ; POINT TO FRAME\r
6933 AEVAL2: PUSHJ   P,CHENV         ; HACK ENVIRONMENT CHANGE\r
6934 AEVAL1: PUSH    TP,(AB)\r
6935         PUSH    TP,1(AB)\r
6936         MCALL   1,EVAL\r
6937 AEVAL3: HRRZ    0,FSAV(TB)\r
6938         CAIN    0,EVAL\r
6939         JRST    EFINIS\r
6940         JRST    FINIS\r
6941 \r
6942 TRYPRO: CAIE    A,TPVP          ; SKIP IF IT IS A PROCESS\r
6943         JRST    WTYP2\r
6944         MOVE    C,3(AB)         ; GET PROCESS\r
6945         CAMN    C,PVP           ; DIFFERENT FROM ME?\r
6946         JRST    SEVAL           ; NO, NORMAL EVAL WINS\r
6947         MOVE    B,SPSTO+1(C)    ; GET SP FOR PROCESS\r
6948         MOVE    D,TBSTO+1(C)    ; GET TOP FRAME\r
6949         HLL     D,OTBSAV(D)     ; TIME IT\r
6950         MOVEI   C,PVLNT*2+1(C)  ; CONS UP POINTER TO PROC DOPE WORD\r
6951         HRLI    C,TFRAME        ; LOOK LIK E A FRAME\r
6952         PUSHJ   P,SWITSP        ; SPLICE ENVIRONMENT\r
6953         JRST    AEVAL1\r
6954 \r
6955 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS \r
6956 \r
6957 CHENV:  PUSHJ   P,CHFRM         ; CHECK OUT FRAME\r
6958         MOVE    C,(B)           ; POINT TO PROCESS\r
6959         MOVE    D,1(B)          ; GET TB POINTER FROM FRAME\r
6960         CAMN    SP,SPSAV(D)     ; CHANGE?\r
6961         POPJ    P,              ; NO, JUST RET\r
6962         MOVE    B,SPSAV(D)      ; GET SP OF INTEREST\r
6963 SWITSP: MOVSI   0,TSKIP         ; SET UP SKIP\r
6964         HRRI    0,1(TP)         ; POINT TO UNBIND PATH\r
6965         MOVE    A,PVP\r
6966         ADD     A,[BINDID,,BINDID]      ; BIND THE BINDING ID\r
6967         PUSH    TP,BNDV\r
6968         PUSH    TP,A\r
6969         PUSH    TP,$TFIX\r
6970         AOS     A,PTIME         ; NEW ID\r
6971         PUSH    TP,A\r
6972         MOVE    E,TP            ; FOR SPECBIND\r
6973         PUSH    TP,0\r
6974         PUSH    TP,B\r
6975         PUSH    TP,C            ; SAVE PROCESS\r
6976         PUSH    TP,D\r
6977         PUSHJ   P,SPECBE        ; BIND BINDID\r
6978         MOVE    SP,TP           ; GET NEW SP\r
6979         SUB     SP,[3,,3]       ; SET UP SP FORK\r
6980         POPJ    P,\r
6981 \f\r
6982 \r
6983 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)\r
6984 \r
6985 EVFORM: SKIPN   C,1(AB)         ; EMPTY FORM, RETURN FALSE\r
6986         JRST    EFALSE\r
6987         GETYP   A,(C)           ; 1ST ELEMENT OF FORM\r
6988         CAIE    A,TATOM         ; ATOM?\r
6989         JRST    EV0             ; NO, EVALUATE IT\r
6990         MOVE    B,1(C)          ; GET ATOM\r
6991         PUSHJ   P,IGVAL         ; GET ITS GLOBAL VALUE\r
6992 \r
6993 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS\r
6994 \r
6995         CAIE    B,LVAL\r
6996         CAIN    B,GVAL\r
6997         JRST    ATMVAL          ; FAST ATOM VALUE\r
6998 \r
6999         GETYP   0,A\r
7000         CAIE    0,TUNBOU        ; BOUND?\r
7001         JRST    IAPPLY          ; YES APPLY IT\r
7002 \r
7003         MOVE    C,1(AB)         ; LOOK FOR LOCAL\r
7004         MOVE    B,1(C)\r
7005         PUSHJ   P,ILVAL\r
7006         GETYP   0,A\r
7007         CAIE    0,TUNBOU\r
7008         JRST    IAPPLY          ; WIN, GO APPLY IT\r
7009 \r
7010         PUSH    TP,$TATOM\r
7011         PUSH    TP,EQUOTE UNBOUND-VARIABLE\r
7012         PUSH    TP,$TATOM\r
7013         MOVE    C,1(AB)         ; FORM BACK\r
7014         PUSH    TP,1(C)\r
7015         PUSH    TP,$TATOM\r
7016         PUSH    TP,MQUOTE VALUE\r
7017         MCALL   3,ERROR         ; REPORT THE ERROR\r
7018         JRST    IAPPLY\r
7019 \r
7020 EFALSE: MOVSI   A,TFALSE        ; SPECIAL FALSE FOR EVAL OF EMPTY FORM\r
7021         MOVEI   B,0\r
7022         JRST    EFINIS\r
7023 \r
7024 ATMVAL: HRRZ    D,(C)           ; CDR THE FORM\r
7025         HRRZ    0,(D)           ; AND AGAIN\r
7026         JUMPN   0,IAPPLY\r
7027         GETYP   0,(D)           ; MAKE SURE APPLYING TO ATOM\r
7028         CAIE    0,TATOM\r
7029         JRST    IAPPLY\r
7030         MOVEI   E,IGVAL         ; ASSUME GLOBAAL\r
7031         CAIE    B,GVAL          ; SKIP IF OK\r
7032         MOVEI   E,ILVAL         ; ELSE USE LOCAL\r
7033         PUSH    P,B             ; SAVE SUBR\r
7034         MOVE    B,(D)+1         ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)\r
7035         PUSHJ   P,(E)           ; AND GET VALUE\r
7036         CAME    A,$TUNBOU\r
7037         JRST    EFINIS          ; RETURN FROM EVAL\r
7038         POP     P,B\r
7039         MOVSI   A,TSUBR         ; CAUSE REAL SUBR TO GET EROR\r
7040         JRST    IAPPLY\r
7041 \f\r
7042 ; HERE FOR 1ST ELEMENT NOT A FORM\r
7043 \r
7044 EV0:    PUSHJ   P,FASTEV        ; EVAL IT\r
7045 \r
7046 ; HERE TO APPLY THINGS IN FORMS\r
7047 \r
7048 IAPPLY: PUSH    TP,(AB)         ; SAVE THE FORM\r
7049         PUSH    TP,1(AB)\r
7050         PUSH    TP,A\r
7051         PUSH    TP,B            ; SAVE THE APPLIER\r
7052         PUSH    TP,$TFIX        ; AND THE ARG GETTER\r
7053         PUSH    TP,[ARGCDR]\r
7054         PUSHJ   P,APLDIS        ; GO TO INTERNAL APPLIER\r
7055         JRST    EFINIS          ; LEAVE EVAL\r
7056 \r
7057 ; HERE TO EVAL 1ST ELEMENT OF A FORM\r
7058 \r
7059 FASTEV: SKIPE   1STEPR+1(PVP)   ; BEING 1 STEPPED?\r
7060         JRST    EV02            ; YES, LET LOSER SEE THIS EVAL\r
7061         GETYP   A,(C)           ; GET TYPE\r
7062         SKIPE   D,EVATYP+1(TVP) ; USER TABLE?\r
7063         JRST    EV01            ; YES, HACK IT\r
7064 EV03:   CAIG    A,NUMPRI        ; SKIP IF SELF\r
7065         SKIPA   A,EVTYPE(A)     ; GET DISPATCH\r
7066         MOVEI   A,SELF          ; USE SLEF\r
7067 \r
7068 EV04:   CAIE    A,SELF          ; IF EVAL'S TO SELF, JUST USE IT\r
7069         JRST    EV02\r
7070         MOVSI   A,TLIST\r
7071         MOVEM   A,CSTO(PVP)\r
7072         INTGO\r
7073         SETZM   CSTO(PVP)\r
7074         HLLZ    A,(C)           ; GET IT\r
7075         MOVE    B,1(C)\r
7076         JSP     E,CHKAB         ; CHECK DEFERS\r
7077         POPJ    P,              ; AND RETURN\r
7078 \r
7079 EV01:   ADDI    D,(A)           ; POINT TO SLOT OF USER EVAL TABLE\r
7080         ADDI    D,(A)\r
7081         SKIPE   (D)             ; EITHER NOT GIVEN OR SIMPLE\r
7082         JRST    EV02\r
7083         SKIPN   1(D)            ; SKIP IF SIMPLE\r
7084         JRST    EV03            ; NOT GIVEN\r
7085         MOVE    A,1(D)\r
7086         JRST    EV04\r
7087 \r
7088 EV02:   PUSH    TP,(C)\r
7089         HLLZS   (TP)            ; FIX UP LH\r
7090         PUSH    TP,1(C)\r
7091         JSP     E,CHKARG\r
7092         MCALL   1,EVAL\r
7093         POPJ    P,\r
7094 \r
7095 \f\r
7096 ; MAPF/MAPR CALL TO APPLY\r
7097 \r
7098         MQUOTE APPLY\r
7099 \r
7100 MAPPLY: JRST    APPLY\r
7101 \r
7102 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS\r
7103 \r
7104 MFUNCTION APPLY,SUBR\r
7105 \r
7106         ENTRY\r
7107 \r
7108         JUMPGE  AB,TFA          ; MUST BE AT LEAST 1 ARGUMENT\r
7109         MOVE    A,AB\r
7110         ADD     A,[2,,2]\r
7111         PUSH    TP,$TAB\r
7112         PUSH    TP,A\r
7113         PUSH    TP,(AB)         ; SAVE FCN\r
7114         PUSH    TP,1(AB)\r
7115         PUSH    TP,$TFIX        ; AND ARG GETTER\r
7116         PUSH    TP,[SETZ APLARG]\r
7117         PUSHJ   P,APLDIS\r
7118         JRST    FINIS\r
7119 \r
7120 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS\r
7121 \r
7122 MFUNCTION STACKFORM,FSUBR\r
7123 \r
7124         ENTRY   1\r
7125 \r
7126         GETYP   A,(AB)\r
7127         CAIE    A,TLIST\r
7128         JRST    WTYP1\r
7129         MOVEI   A,3             ; CHECK ALL GOODIES SUPPLIED\r
7130         HRRZ    B,1(AB)\r
7131 \r
7132         JUMPE   B,TFA\r
7133         HRRZ    B,(B)           ; CDR IT\r
7134         SOJG    A,.-2\r
7135 \r
7136         HRRZ    C,1(AB)         ; GET LIST BACK\r
7137         PUSHJ   P,FASTEV        ; DO A FAST EVALUATION\r
7138         PUSH    TP,(AB)\r
7139         HRRZ    C,@1(AB)        ; POINT TO ARG GETTING FORMS\r
7140         PUSH    TP,C\r
7141         PUSH    TP,A            ; AND FCN\r
7142         PUSH    TP,B\r
7143         PUSH    TP,$TFIX\r
7144         PUSH    TP,[SETZ EVALRG]\r
7145         PUSHJ   P,APLDIS\r
7146         JRST    FINIS\r
7147 \r
7148 \f\r
7149 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF\r
7150 \r
7151 E.FRM==0                ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)\r
7152 E.FCN==2                ; FUNCTION/SUBR/RSUBR BEING APPLIED\r
7153 E.ARG==4                ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)\r
7154 E.EXTR==6               ; CONTAINS 1ST ARG IN USER APPLY CASE\r
7155 E.SEG==10               ; POINTS TO SEGMENT IN FORM BEING HACKED\r
7156 E.CNT==12               ; COUNTER FOR TUPLES OF ARGS\r
7157 E.DECL==14              ; POINTS TO DECLARATION LIST IN FUNCTIONS\r
7158 E.ARGL==16              ; POINTS TO ARG LIST IN FUNCTIONS\r
7159 E.HEW==20               ; POINTS TO HEWITT ATOM IF IT EXISTS\r
7160 \r
7161 E.VAL==E.ARGL           ; VALUE TYPE FOR RSUBRS\r
7162 \r
7163 MINTM==E.EXTR+2         ; MIN # OF TEMPS EVER ALLOCATED\r
7164 E.TSUB==E.CNT+2         ; # OF TEMPS FOR SUBR/NUMBER APPLICATION\r
7165 XP.TMP==E.HEW-E.EXTR    ; # EXTRA TEMPS FOR FUNCTION APPLICATION\r
7166 R.TMP==4                ; TEMPS AFTER ARGS ARE BOUND\r
7167 TM.OFF==E.HEW+2-R.TMP   ; TEMPS TO FLUSH AFTER BIND OF ARGS\r
7168 \r
7169 RE.FCN==0               ; AFTER BINDING CONTAINS FCN BODY\r
7170 RE.ARG==2               ; ARG LIST AFTER BINDING\r
7171 \r
7172 ; GENERAL THING APPLYER\r
7173 \r
7174 APLDIS: PUSH    TP,[0]          ; SLOT USED FOR USER APPLYERS\r
7175         PUSH    TP,[0]\r
7176 APLDIX: GETYP   A,E.FCN(TB)     ; GET TYPE\r
7177 \r
7178 APLDI:  SKIPE   D,APLTYP+1(TVP) ; USER TABLE EXISTS?\r
7179         JRST    APLDI1          ; YES, USE IT\r
7180 APLDI2: CAIG    A,NUMPRI        ; SKIP IF NOT PRIM\r
7181         JRST    @APTYPE(A)\r
7182         JRST    NAPT\r
7183 \r
7184 APLDI1: ADDI    D,(A)           ; POINT TO SLOT\r
7185         ADDI    D,(A)\r
7186         SKIPE   (D)             ; SKIP IF NOT GIVEN OR STANDARD\r
7187         JRST    APLDI3\r
7188 APLDI4: SKIPE   D,1(D)          ; GET DISP\r
7189         JRST    (D)\r
7190         JRST    APLDI2          ; USE SYSTEM DISPATCH\r
7191 \r
7192 APLDI3: SKIPE   E.EXTR+1(TB)    ; SKIP IF HAVEN'T BEEN HERE BEFORE\r
7193         JRST    APLDI4\r
7194         MOVE    A,(D)           ; GET ITS HANDLER\r
7195         EXCH    A,E.FCN(TB)     ; AND USE AS FCN\r
7196         MOVEM   A,E.EXTR(TB)    ; SAVE\r
7197         MOVE    A,1(D)\r
7198         EXCH    A,E.FCN+1(TB)\r
7199         MOVEM   A,E.EXTR+1(TB)  ; STASH OLD FCN AS EXTRG\r
7200         GETYP   A,(D)           ; GET TYPE\r
7201         JRST    APLDI\r
7202 \r
7203 \r
7204 ; APPLY DISPATCH TABLE\r
7205 \r
7206 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]\r
7207 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]]\f\r
7208 \r
7209 ; SUBR TO SAY IF TYPE IS APPLICABLE\r
7210 \r
7211 MFUNCTION APPLIC,SUBR,[APPLICABLE?]\r
7212 \r
7213         ENTRY   1\r
7214 \r
7215         GETYP   A,(AB)\r
7216         PUSHJ   P,APLQ\r
7217         JRST    IFALSE\r
7218         JRST    TRUTH\r
7219 \r
7220 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE\r
7221 \r
7222 APLQ:   PUSH    P,B\r
7223         SKIPN   B,APLTYP+1(TVP)\r
7224         JRST    USEPUR          ; USE PURE TABLE\r
7225         ADDI    B,(A)\r
7226         ADDI    B,(A)           ; POINT TO SLOT\r
7227         SKIPG   1(B)            ; SKIP IF WINNER\r
7228         SKIPE   (B)             ; SKIP IF POTENIAL LOSER\r
7229         JRST    CPPJ1B          ; WIN\r
7230         SKIPE   1(B)            ; SKIP IF MUST USE PURE TABBLE\r
7231         JRST    CPOPJB\r
7232 USEPUR: CAIG    A,NUMPRI        ; SKIP IF NOT PRIM\r
7233         SKIPL   APTYPE(A)       ; SKIP IF APLLICABLE\r
7234 CPPJ1B: AOS     -1(P)\r
7235 CPOPJB: POP     P,B\r
7236         POPJ    P,\r
7237 \f\r
7238 ; FSUBR APPLYER\r
7239 \r
7240 APFSUBR:\r
7241         SKIPN   E.EXTR(TB)      ; IF EXTRA ARG\r
7242         SKIPGE  E.ARG+1(TB)     ; OR APPLY/STACKFORM, LOSE\r
7243         JRST    BADFSB\r
7244         MOVE    A,E.FCN+1(TB)   ; GET FCN\r
7245         HRRZ    C,@E.FRM+1(TB)  ; GET ARG LIST\r
7246         SUB     TP,[MINTM,,MINTM]       ; FLUSH UNWANTED TEMPS\r
7247         PUSH    TP,$TLIST\r
7248         PUSH    TP,C            ; ARG TO STACK\r
7249         .MCALL  1,(A)           ; AND CALL\r
7250         POPJ    P,              ; AND LEAVE\r
7251 \r
7252 ; SUBR APPLYER\r
7253 \r
7254 APSUBR: \r
7255         PUSHJ   P,PSH4ZR        ; SET UP ZEROED SLOTS\r
7256         SKIPN   A,E.EXTR(TB)    ; FUNNY ARGS\r
7257         JRST    APSUB1          ; NO, GO\r
7258         MOVE    B,E.EXTR+1(TB)  ; YES , GET VAL\r
7259         JRST    APSUB2          ; AND FALL IN\r
7260 \r
7261 APSUB1: PUSHJ   P,@E.ARG+1(TB)  ; EAT AN ARG\r
7262         JRST    APSUBD          ; DONE\r
7263 APSUB2: PUSH    TP,A\r
7264         PUSH    TP,B\r
7265         AOS     E.CNT+1(TB)     ; COUNT IT\r
7266         JRST    APSUB1\r
7267 \r
7268 APSUBD: MOVE    A,E.CNT+1(TB)   ; FINISHED, GET COUNT\r
7269         MOVE    B,E.FCN+1(TB)   ; AND SUBR\r
7270         GETYP   0,E.FCN(TB)\r
7271         CAIN    0,TENTER\r
7272         JRST    APENDN\r
7273         PUSHJ   P,BLTDN         ; FLUSH CRUFT\r
7274         .ACALL  A,(B)\r
7275         POPJ    P,\r
7276 \r
7277 BLTDN:  MOVEI   C,(TB)          ; POINT TO DEST\r
7278         HRLI    C,E.TSUB(C)     ; AND SOURCE\r
7279         BLT     C,-E.TSUB(TP)   ;BL..............T\r
7280         SUB     TP,[E.TSUB,,E.TSUB]\r
7281         POPJ    P,\r
7282 \r
7283 APENDN: PUSHJ   P,BLTDN\r
7284 APNDN1: .ECALL  A,(B)\r
7285         POPJ    P,\r
7286 \r
7287 ; FLAGS FOR RSUBR HACKER\r
7288 \r
7289 F.STR==1\r
7290 F.OPT==2\r
7291 F.QUO==4\r
7292 F.NFST==10\r
7293 \r
7294 ; APPLY OBJECTS OF TYPE RSUBR\r
7295 \r
7296 APENTR:\r
7297 APRSUBR:\r
7298         MOVE    C,E.FCN+1(TB)   ; GET THE RSUBR\r
7299         CAML    C,[-5,,]        ; IS IT LONG ENOUGH FOR DECLS\r
7300         JRST    APSUBR          ; NO TREAT AS A SUBR\r
7301         GETYP   0,4(C)          ; GET TYPE OF 3D ELEMENT\r
7302         CAIE    0,TDECL         ; DECLARATION?\r
7303         JRST    APSUBR          ; NO, TREAT AS SUBR\r
7304         PUSHJ   P,PSH4ZR        ; ALLOCATE SOME EXTRA ROOM\r
7305         PUSH    TP,$TDECL       ; PUSH UP THE DECLS\r
7306         PUSH    TP,5(C)\r
7307         PUSH    TP,$TLOSE       ; SAVE ROOM FOR VAL DECL\r
7308         PUSH    TP,[0]\r
7309 \r
7310         SKIPN   E.EXTR(TB)      ; "EXTRA" ARG?\r
7311         JRST    APRSU1          ; NO,\r
7312         MOVE    0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN\r
7313         EXCH    0,E.ARG+1(TB)\r
7314         HRRM    0,E.ARG(TB)     ; REMEMBER IT\r
7315 \r
7316 APRSU1: MOVEI   0,0             ; INIT FLAG REGISTER\r
7317         PUSH    P,0             ; SAVE\r
7318 \r
7319 APRSU2: HRRZ    A,E.DECL+1(TB)  ; GET DECL LIST\r
7320         JUMPE   A,APRSU3        ; DONE!\r
7321         HRRZ    B,(A)           ; CDR IT\r
7322         MOVEM   B,E.DECL+1(TB)\r
7323         PUSHJ   P,NXTDCL        ; IS NEXT THING A STRING?\r
7324         JRST    APRSU4          ; NO, BETTER BE A  TYPE\r
7325         CAMN    B,[ASCII /VALUE/]\r
7326         JRST    RSBVAL          ; SAVE VAL DECL\r
7327         TRON    0,F.NFST        ; IF NOT FIRST, LOSE\r
7328         CAME    B,[ASCII /CALL/] ; CALL DECL\r
7329         JRST    APRSU7\r
7330         SKIPGE  E.ARG+1(TB)     ; LEGAL?\r
7331         JRST    MPD\r
7332         MOVE    C,E.FRM(TB)\r
7333         MOVE    D,E.FRM+1(TB)   ; GET FORM\r
7334         JRST    APRS10          ; HACK IT\r
7335 \r
7336 APRSU5: TROE    0,F.STR         ; STRING STRING?\r
7337         JRST    MPD             ; LOSER\r
7338         CAME    B,[<ASCII /OPTIO/>+1]   ; OPTIONA?\r
7339         JRST    APRSU8\r
7340         TROE    0,F.OPT         ; CHECK AND SET\r
7341         JRST    MPD             ; OPTINAL OPTIONAL LOSES\r
7342         JRST    APRSU2  ; TO MAIN LOOP\r
7343 \r
7344 APRSU7: CAME    B,[ASCII /QUOTE/]\r
7345         JRST    APRSU5\r
7346         TRO     0,F.STR\r
7347         TROE    0,F.QUO         ; TURN ON AND CHECK QUOTE\r
7348         JRST    MPD             ; QUOTE QUOTE LOSES\r
7349         JRST    APRSU2          ; GO TO END OF LOOP\r
7350 \f\r
7351 \r
7352 APRSU8: CAME    B,[ASCII /ARGS/]\r
7353         JRST    APRSU9\r
7354         SKIPGE  E.ARG+1(TB)     ; SKIP IF LEGAL\r
7355         JRST    MPD\r
7356         HRRZ    D,@E.FRM+1(TB)  ; GET ARG LIST\r
7357         MOVSI   C,TLIST\r
7358 \r
7359 APRS10: HRRZ    A,(A)           ; GET THE DECL\r
7360         MOVEM   A,E.DECL+1(TB)  ; CLOBBER\r
7361         HRRZ    B,(A)           ; CHECK FOR TOO MUCH\r
7362         JUMPN   B,MPD\r
7363         MOVE    B,1(A)          ; GET DECL\r
7364         HLLZ    A,(A)           ; GOT THE DECL\r
7365         MOVEM   0,(P)           ; SAVE FLAGS\r
7366         JSP     E,CHKAB         ; CHECK DEFER\r
7367         PUSH    TP,C\r
7368         PUSH    TP,D            ; SAVE\r
7369         PUSHJ   P,TMATCH\r
7370         JRST    WTYP\r
7371         AOS     E.CNT+1(TB)     ; COUNT ARG\r
7372         JRST    APRDON          ; GO CALL RSUBR\r
7373 \r
7374 RSBVAL: HRRZ    A,E.DECL+1(TB)  ; GET DECL\r
7375         JUMPE   A,MPD\r
7376         HRRZ    B,(A)           ; POINT TO DECL\r
7377         MOVEM   B,E.DECL+1(TB)  ; SAVE NEW DECL POINTER\r
7378         PUSHJ   P,NXTDCL\r
7379         JRST    .+2\r
7380         JRST    MPD\r
7381         MOVEM   A,E.VAL+1(TB)   ; SAVE VAL DECL\r
7382         MOVSI   A,TDCLI\r
7383         MOVEM   A,E.VAL(TB)     ; SET ITS TYPE\r
7384         JRST    APRSU2\r
7385 \f\r
7386         \r
7387 APRSU9: CAME    B,[ASCII /TUPLE/]\r
7388         JRST    MPD\r
7389         MOVEM   0,(P)           ; SAVE FLAGS\r
7390         HRRZ    A,(A)           ; CDR DECLS\r
7391         MOVEM   A,E.DECL+1(TB)\r
7392         HRRZ    B,(A)\r
7393         JUMPN   B,MPD           ; LOSER\r
7394         PUSH    P,[0]           ; COUNT ELEMENTS IN TUPLE\r
7395 \r
7396 APRTUP: PUSHJ   P,@E.ARG+1(TB)  ; GOBBLE ARGS\r
7397         JRST    APRTPD          ; DONE\r
7398         PUSH    TP,A\r
7399         PUSH    TP,B\r
7400         AOS     (P)             ; COUNT IT\r
7401         JRST    APRTUP          ; AND GO\r
7402 \r
7403 APRTPD: POP     P,C             ; GET COUNT\r
7404         ADDM    C,E.CNT+1(TB)   ; UPDATE MAIN COUNT\r
7405         ASH     C,1             ; # OF WORDS\r
7406         HRLI    C,TINFO         ; BUILD FENCE POST\r
7407         PUSH    TP,C\r
7408         PUSHJ   P,TBTOTP        ; GEN REL OFFSET TO TOP\r
7409         PUSH    TP,D\r
7410         HRROI   D,-1(TP)                ; POINT TO TOP\r
7411         SUBI    D,(C)           ; TO BASE\r
7412         TLC     D,-1(C)\r
7413         MOVSI   C,TARGS         ; BUILD TYPE WORD\r
7414         HLR     C,OTBSAV(TB)\r
7415         MOVE    A,E.DECL+1(TB)\r
7416         MOVE    B,1(A)\r
7417         HLLZ    A,(A)           ; TYPE/VAL\r
7418         JSP     E,CHKAB         ; CHECK\r
7419         PUSHJ   P,TMATCH        ; GOTO TYPE CHECKER\r
7420         JRST    WTYP\r
7421 \r
7422         SUB     TP,[2,,2]       ; REMOVE FENCE POST\r
7423 \r
7424 APRDON: SUB     P,[1,,1]        ; FLUSH CRUFT\r
7425         MOVE    A,E.CNT+1(TB)   ; GET # OF ARGS\r
7426         MOVE    B,E.FCN+1(TB)\r
7427         GETYP   0,E.FCN(TB)     ; COULD BE ENTRY\r
7428         MOVEI   C,(TB)          ; PREPARE TO BLT DOWN\r
7429         HRLI    C,E.TSUB+2(C)\r
7430         BLT     C,-E.TSUB+2(TP)\r
7431         SUB     TP,[E.TSUB+2,,E.TSUB+2]\r
7432         CAIE    0,TRSUBR\r
7433         JRST    APNDN1\r
7434         .ACALL  A,(B)           ; CALL THE RSUBR\r
7435         JRST    PFINIS\r
7436 \f\r
7437 \r
7438 \r
7439 APRSU4: MOVEM   0,(P)           ; SAVE FLAGS\r
7440         MOVE    B,1(A)          ; GET DECL\r
7441         HLLZ    A,(A)\r
7442         JSP     E,CHKAB\r
7443         MOVE    0,(P)           ; RESTORE FLAGS\r
7444         PUSH    TP,A\r
7445         PUSH    TP,B            ; AND SAVE\r
7446         SKIPL   E.ARG+1(TB)     ; ALREADY EVAL'D\r
7447         TRZN    0,F.QUO\r
7448         JRST    APREVA          ; MUST EVAL ARG\r
7449         MOVEM   0,(P)\r
7450         HRRZ    C,@E.FRM+1(TB)  ; GET ARG?\r
7451         TRNE    0,F.OPT         ; OPTIONAL\r
7452         JUMPE   C,APRDN\r
7453         JUMPE   C,TFA           ; NO, TOO FEW ARGS\r
7454         MOVEM   C,E.FRM+1(TB)\r
7455         HLLZ    A,(C)           ; GET ARG\r
7456         MOVE    B,1(C)\r
7457         JSP     E,CHKAB         ; CHECK THEM\r
7458 \r
7459 APRTYC: MOVE    C,A             ; SET UP FOR TMATCH\r
7460         MOVE    D,B\r
7461         EXCH    B,(TP)\r
7462         EXCH    A,-1(TP)        ; SAVE STUFF\r
7463 APRS11: PUSHJ   P,TMATCH        ; CHECK TYPE\r
7464         JRST    WTYP\r
7465 \r
7466         MOVE    0,(P)           ; RESTORE FLAGS\r
7467         TRZ     0,F.STR\r
7468         AOS     E.CNT+1(TB)\r
7469         JRST    APRSU2          ; AND GO ON\r
7470 \r
7471 APREVA: PUSHJ   P,@E.ARG+1(TB)  ; EVAL ONE\r
7472         TDZA    C,C             ; C=0 ==> NONE LEFT\r
7473         MOVEI   C,1\r
7474         MOVE    0,(P)           ; FLAGS\r
7475         JUMPN   C,APRTYC        ; GO CHECK TYPE\r
7476 APRDN:  SUB     TP,[2,,2]       ; FLUSH DECL\r
7477         TRNE    0,F.OPT         ; OPTIONAL?\r
7478         JRST    APRDON  ; ALL DONE\r
7479         JRST    TFA\r
7480 \r
7481 APRSU3: TRNE    0,F.STR         ; END IN STRING?\b       \r
7482         JRST    MPD\r
7483         PUSHJ   P,@E.ARG+1(TB)  ; SEE IF ANYMORE ARGS\r
7484         JRST    APRDON\r
7485         JRST    TMA\r
7486 \r
7487 \f\r
7488 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS\r
7489 \r
7490 ARGCDR: HRRZ    C,@E.FRM+1(TB)  ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)\r
7491         JUMPE   C,CPOPJ         ; LEAVE IF DONE\r
7492         MOVEM   C,E.FRM+1(TB)\r
7493         GETYP   0,(C)           ; GET TYPE OF ARG\r
7494         CAIN    0,TSEG\r
7495         JRST    ARGCD1          ; SEG MENT HACK\r
7496         PUSHJ   P,FASTEV\r
7497         JRST    CPOPJ1\r
7498 \r
7499 ARGCD1: PUSH    TP,$TFORM       ; PRETEND WE ARE A FORM\r
7500         PUSH    TP,1(C)\r
7501         MCALL   1,EVAL\r
7502         MOVEM   A,E.SEG(TB)\r
7503         MOVEM   B,E.SEG+1(TB)\r
7504         PUSHJ   P,TYPSEG                ; GET SEG TYPE CODE\r
7505         HRRM    C,E.ARG(TB)             ; SAVE IT IN OBSCCURE PLACE\r
7506         MOVE    C,[SETZ SGARG]\r
7507         MOVEM   C,E.ARG+1(TB)   ; SET NEW ARG GETTER\r
7508 \r
7509 ; FALL INTO SEGARG\r
7510 \r
7511 SGARG:  INTGO\r
7512         HRRZ    C,E.ARG(TB)     ; SEG CODE TO C\r
7513         MOVE    D,E.SEG+1(TB)\r
7514         MOVE    A,E.SEG(TB)\r
7515         MOVEM   A,DSTO(PVP)\r
7516         PUSHJ   P,NXTLM         ; GET NEXT ELEMENT\r
7517         JRST    SEGRG1          ; DONE\r
7518         MOVEM   D,E.SEG+1(TB)\r
7519         MOVE    D,DSTO(PVP)     ; KEEP TYPE WINNING\r
7520         MOVEM   D,E.SEG(TB)\r
7521         SETZM   DSTO(PVP)\r
7522         JRST    CPOPJ1          ; RETURN\r
7523 \r
7524 SEGRG1: SETZM   DSTO(PVP)\r
7525         MOVEI   C,ARGCDR\r
7526         MOVEM   C,E.ARG+1(TB)   ; RESET ARG GETTER\r
7527         JRST    ARGCDR\r
7528 \r
7529 ; ARGUMENT GETTER FOR APPLY\r
7530 \r
7531 APLARG: INTGO\r
7532         SKIPL   A,E.FRM+1(TB)   ; ANY ARGS LEFT\r
7533         POPJ    P,              ; NO, EXIT IMMEDIATELY\r
7534         ADD     A,[2,,2]\r
7535         MOVEM   A,E.FRM+1(TB)\r
7536         MOVE    B,-1(A)         ; RET NEXT ARG\r
7537         MOVE    A,-2(A)\r
7538         JRST    CPOPJ1\r
7539 \r
7540 ; STACKFORM ARG GETTER\r
7541 \r
7542 EVALRG: SKIPN   C,@E.FRM+1(TB)  ; ANY FORM?\r
7543         POPJ    P,\r
7544         PUSHJ   P,FASTEV\r
7545         GETYP   A,A             ; CHECK FOR FALSE\r
7546         CAIN    A,TFALSE\r
7547         POPJ    P,\r
7548         MOVE    C,E.FRM+1(TB)   ; GET OTHER FORM\r
7549         PUSHJ   P,FASTEV\r
7550         JRST    CPOPJ1\r
7551 \r
7552 \f\r
7553 ; HERE TOO APPLY NUMBERS\r
7554 \r
7555 APNUM:  PUSHJ   P,PSH4ZR        ; TP SLOSTS\r
7556         SKIPN   A,E.EXTR(TB)    ; FUNNY ARG?\r
7557         JRST    APNUM1          ; NOPE\r
7558         MOVE    B,E.EXTR+1(TB)  ; GET ARG\r
7559         JRST    APNUM2\r
7560 \r
7561 APNUM1: PUSHJ   P,@E.ARG+1(TB)  ; GET ARG\r
7562         JRST    TFA\r
7563 APNUM2: PUSH    TP,A\r
7564         PUSH    TP,B\r
7565         PUSH    TP,E.FCN(TB)\r
7566         PUSH    TP,E.FCN+1(TB)\r
7567         PUSHJ   P,@E.ARG+1(TB)\r
7568         JRST    .+2\r
7569         JRST    TMA\r
7570         PUSHJ   P,BLTDN         ; FLUSH JUNK\r
7571         MCALL   2,NTH\r
7572         POPJ    P,\r
7573 \f\r
7574 ; HERE TO APPLY SUSSMAN FUNARGS\r
7575 \r
7576 APFUNARG:\r
7577 \r
7578         SKIPN   C,E.FCN+1(TB)\r
7579         JRST    FUNERR\r
7580         HRRZ    D,(C)           ; MUST BE AT LEAST 2 LONG\r
7581         JUMPE   D,FUNERR\r
7582         GETYP   0,(D)           ; CHECK FOR LIST\r
7583         CAIE    0,TLIST\r
7584         JRST    FUNERR\r
7585         HRRZ    0,(D)           ; SHOULD BE END\r
7586         JUMPN   0,FUNERR\r
7587         GETYP   0,(C)           ; 1ST MUST BE FCN\r
7588         CAIE    0,TEXPR\r
7589         JRST    FUNERR\r
7590         SKIPN   C,1(C)\r
7591         JRST    NOBODY\r
7592         PUSHJ   P,APEXPF        ; BIND THE ARGS AND AUX'S\r
7593         HRRZ    C,RE.FCN+1(TB)  ; GET BODY OF FUNARG\r
7594         MOVE    B,1(C)          ; GET FCN\r
7595         MOVEM   B,RE.FCN+1(TB)  ; AND SAVE\r
7596         HRRZ    C,(C)           ; CDR FUNARG BODY\r
7597         MOVE    C,1(C)\r
7598         MOVSI   0,TLIST         ; SET UP TYPE\r
7599         MOVEM   0,CSTO(PVP)     ; FOR INTS TO WIN\r
7600 \r
7601 FUNLP:  INTGO\r
7602         JUMPE   C,DOF           ; RUN IT\r
7603         GETYP   0,(C)\r
7604         CAIE    0,TLIST         ; BETTER BE LIST\r
7605         JRST    FUNERR\r
7606         PUSH    TP,$TLIST\r
7607         PUSH    TP,C\r
7608         PUSHJ   P,NEXTDC        ; GET POSSIBILITY\r
7609         JRST    FUNERR          ; LOSER\r
7610         CAIE    A,2\r
7611         JRST    FUNERR\r
7612         HRRZ    B,(B)           ; GET TO VALUE\r
7613         MOVE    C,(TP)\r
7614         SUB     TP,[2,,2]\r
7615         PUSH    TP,BNDA\r
7616         PUSH    TP,E\r
7617         HLLZ    A,(B)           ; GET VAL\r
7618         MOVE    B,1(B)\r
7619         JSP     E,CHKAB         ; HACK DEFER\r
7620         PUSHJ   P,PSHAB4        ; PUT VAL IN\r
7621         HRRZ    C,(C)           ; CDR\r
7622         JUMPN   C,FUNLP\r
7623 \r
7624 ; HERE TO RUN FUNARG\r
7625 \r
7626 DOF:    SETZM   CSTO(PVP)       ; DONT CONFUSE GC\r
7627         PUSHJ   P,SPECBIND      ; BIND 'EM UP\r
7628         JRST    RUNFUN\r
7629 \r
7630 \r
7631 \f\r
7632 ; HERE TO DO MACROS\r
7633 \r
7634 APMACR: HRRZ    E,OTBSAV(TB)\r
7635         HRRZ    E,PCSAV(E)      ; SEE WHERE FROM\r
7636         CAIN    E,AEVAL3        ; SKIP IF NOT RIGHT\r
7637         JRST    APMAC1\r
7638         SKIPG   E.ARG+1(TB)     ; SKIP IF REAL FORM EXISTS\r
7639         JRST    BADMAC\r
7640         MOVE    A,E.FRM(TB)\r
7641         MOVE    B,E.FRM+1(TB)\r
7642         SUB     TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK\r
7643         PUSH    TP,A\r
7644         PUSH    TP,B\r
7645         MCALL   1,EXPAND        ; EXPAND THE MACRO\r
7646         PUSH    TP,A\r
7647         PUSH    TP,B\r
7648         MCALL   1,EVAL          ; EVAL THE RESULT\r
7649         POPJ    P,\r
7650 \r
7651 APMAC1: MOVE    C,E.FCN+1(TB)   ; GET MACRO BODY\r
7652         GETYP   A,(C)\r
7653         MOVE    B,1(C)\r
7654         MOVSI   A,(A)\r
7655         JSP     E,CHKAB         ; FIX DEFERS\r
7656         MOVEM   A,E.FCN(TB)\r
7657         MOVEM   B,E.FCN+1(TB)\r
7658         JRST    APLDIX\r
7659         \r
7660 ; HERE TO APPLY EXPRS (FUNCTIONS)\r
7661 \r
7662 APEXPR: PUSHJ   P,APEXP         ; BIND ARGS AND AUX'S\r
7663 RUNFUN: HRRZ    A,RE.FCN(TB)    ; AMOUNT OF FCN TO SKIP\r
7664         MOVEI   C,RE.FCN+1(TB)  ; POINT TO FCN\r
7665         HRRZ    C,(C)           ; SKIP SOMETHING\r
7666         SOJGE   A,.-1           ; UNTIL 1ST FORM\r
7667         MOVEM   C,RE.FCN+1(TB)  ; AND STORE\r
7668         JRST    DOPROG          ; GO RUN PROGRAM\r
7669 \r
7670 APEXP:  SKIPN   C,E.FCN+1(TB)   ; CHECK FRO BODY\r
7671         JRST    NOBODY\r
7672 APEXPF: PUSH    P,[0]           ; COUNT INIT CRAP\r
7673         ADD     TP,[XP.TMP,,XP.TMP]     ; SLOTS FOR HACKING\r
7674         SKIPL   TP\r
7675         PUSHJ   P,TPOVFL\r
7676         SETZM   1-XP.TMP(TP)    ; ZERO OUT\r
7677         MOVEI   A,-XP.TMP+2(TP)\r
7678         HRLI    A,-1(A)\r
7679         BLT     A,(TP)          ; ZERO SLOTS\r
7680         PUSHJ   P,CARATC        ; SEE IF HEWITT ATOM EXISTS\r
7681         JRST    APEXP1          ; NO, GO LOOK FOR ARGLIST\r
7682         MOVEM   E,E.HEW+1(TB)   ; SAVE ATOM\r
7683         MOVSM   0,E.HEW(TB)     ; AND TYPE\r
7684         AOS     (P)             ; COUNT HEWITT ATOM\r
7685 APEXP1: GETYP   0,(C)           ; LOOK AT NEXT THING\r
7686         CAIE    0,TLIST         ; BETTER BE LIST!!!\r
7687         JRST    MPD.0           ; LOSE\r
7688         MOVE    B,1(C)          ; GET LIST\r
7689         MOVEM   B,E.ARGL+1(TB)  ; SAVE\r
7690         MOVSM   0,E.ARGL(TB)    ; WITH TYPE\r
7691         HRRZ    C,(C)           ; CDR THE FCN\r
7692         JUMPE   C,NOBODY        ; BODYLESS FCN\r
7693         GETYP   0,(C)           ; SEE IF DCL LIST SUPPLIED\r
7694         CAIE    0,TDECL\r
7695         JRST    APEXP2          ; NO, START PROCESSING ARGS\r
7696         AOS     (P)             ; COUNT DCL\r
7697         MOVE    B,1(C)\r
7698         MOVEM   B,E.DECL+1(TB)\r
7699         MOVSM   0,E.DECL(TB)\r
7700         HRRZ    C,(C)           ; CDR ON\r
7701         JUMPE   C,NOBODY\r
7702 \r
7703  ; CHECK FOR EXISTANCE OF EXTRA ARG\r
7704 \r
7705 APEXP2: POP     P,A             ; GET COUNT\r
7706         HRRM    A,E.FCN(TB)     ; AND SAVE\r
7707         SKIPN   E.EXTR(TB)      ; SKIP IF FUNNY EXTRA ARG EXISTS\r
7708         JRST    APEXP3\r
7709         MOVE    0,[SETZ EXTRGT]\r
7710         EXCH    0,E.ARG+1(TB)\r
7711         HRRM    0,E.ARG(TB)     ; SAVE OLD GETTER AROUND\r
7712 \r
7713 ; FALL THROUGH\r
7714         \f\r
7715 ; LOOK FOR "BIND" DECLARATION\r
7716 \r
7717 APEXP3: PUSHJ   P,UNPROG        ; UNASSIGN LPROG IF NEC\r
7718 APXP3A: SKIPN   A,E.ARGL+1(TB)  ; GET ARGLIST\r
7719         JRST    APEXP4          ; NONE, VERIFY NONE WERE GIVEN\r
7720         PUSHJ   P,NXTDCL        ; SEE IF A DECL IS THERE\r
7721         JRST    BNDRG           ; NO, GO BIND NORMAL ARGS\r
7722         HRRZ    C,(A)           ; CDR THE DCLS\r
7723         CAME    B,[ASCII /BIND/]\r
7724         JRST    CH.CAL          ; GO LOOK FOR "CALL"\r
7725         PUSHJ   P,CARTMC        ; MUST BE AN ATOM\r
7726         MOVEM   C,E.ARGL+1(TB)  ; AND SAVE CDR'D ARGS\r
7727         PUSHJ   P,MAKENV        ; GENERATE AN ENVIRONMENT\r
7728         PUSHJ   P,PSBND1        ; PUSH THE BINDING AND CHECK THE DCL\r
7729         JRST    APXP3A          ; IN CASE <"BIND" B "BIND" C......\r
7730 \r
7731 \r
7732 ; LOOK FOR "CALL" DCL\r
7733 \r
7734 CH.CAL: CAME    B,[ASCII /CALL/]\r
7735         JRST    CHOPT           ; TRY SOMETHING ELSE\r
7736         SKIPG   E.ARG+1(TB)     ; DONT SKIP IF CANT WIN\r
7737         JRST    MPD.2\r
7738         PUSHJ   P,CARTMC        ; BETTER BE AN ATOM\r
7739         MOVEM   C,E.ARGL+1(TB)\r
7740         MOVE    A,E.FRM(TB)     ; RETURN FORM\r
7741         MOVE    B,E.FRM+1(TB)\r
7742         PUSHJ   P,PSBND1        ; BIND AND CHECK\r
7743         JRST    APEXP5\r
7744         \f\r
7745 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE\r
7746 \r
7747 BNDRG:  PUSHJ   P,BNDEM1        ; GO BIND THEM UP\r
7748         TRNN    A,4             ; SKIP IF HIT A DCL\r
7749         JRST    APEXP4          ; NOT A DCL, MUST BE DONE\r
7750 \r
7751 ; LOOK FOR "OPTIONAL" DECLARATION\r
7752 \r
7753 CHOPT:  CAME    B,[<ASCII /OPTIO/>+1]\r
7754         JRST    CHREST          ; TRY TUPLE/ARGS\r
7755         MOVEM   C,E.ARGL+1(TB)  ; SAVE RESTED ARGLIST\r
7756         PUSHJ   P,BNDEM2        ; DO ALL SUPPLIED OPTIONALS\r
7757         TRNN    A,4             ; SKIP IF NEW DCL READ\r
7758         JRST    APEXP4\r
7759 \r
7760 ; CHECK FOR "ARGS" DCL\r
7761 \r
7762 CHREST: CAME    B,[ASCII /ARGS/]\r
7763         JRST    CHRST1          ; GO LOOK FOR "TUPLE"\r
7764         SKIPGE  E.ARG+1(TB)     ; SKIP IF LEGAL \r
7765         JRST    MPD.3\r
7766         PUSHJ   P,CARTMC        ; GOBBLE ATOM\r
7767         MOVEM   C,E.ARGL+1(TB)  ; SAVE CDR'D ARG\r
7768         HRRZ    B,@E.FRM+1(TB)  ; GET ARG LIST\r
7769         MOVSI   A,TLIST         ; GET TYPE\r
7770         PUSHJ   P,PSBND1\r
7771         JRST    APEXP5\r
7772 \r
7773 ; HERE TO CHECK FOR "TUPLE"\r
7774 \r
7775 CHRST1: CAME    B,[ASCII /TUPLE/]\r
7776         JRST    APXP10\r
7777         PUSHJ   P,CARTMC        ; GOBBLE ATOM\r
7778         MOVEM   C,E.ARGL+1(TB)\r
7779         SETZB   A,B\r
7780         PUSHJ   P,PSHBND        ; SET UP BINDING\r
7781         SETZM   E.CNT+1(TB)     ; ZERO ARG COUNTER\r
7782 \r
7783 TUPLP:  PUSHJ   P,@E.ARG+1(TB)  ; GET AN ARG\r
7784         JRST    TUPDON          ; FINIS\r
7785         AOS     E.CNT+1(TB)\r
7786         PUSH    TP,A\r
7787         PUSH    TP,B\r
7788         JRST    TUPLP\r
7789 \r
7790 TUPDON: PUSHJ   P,MAKINF        ; MAKE INFO CELL\r
7791         PUSH    TP,$TINFO               ; FENCE POST TUPLE\r
7792         PUSHJ   P,TBTOTP\r
7793         ADDI    D,TM.OFF        ; COMPENSATE FOR MOVEMENT\r
7794         PUSH    TP,D\r
7795         MOVE    C,E.CNT+1(TB)   ; GET COUNT\r
7796         ASH     C,1             ; TO WORDS\r
7797         HRRM    C,-1(TP)        ; INTO FENCE POST\r
7798         MOVEI   B,-TM.OFF-1(TP) ; SETUP ARG POINTER\r
7799         SUBI    B,(C)           ; POINT TO BASE OF TUPLE\r
7800         MOVNS   C               ; FOR AOBJN POINTER\r
7801         HRLI    B,(C)           ; GOOD ARGS POINTER\r
7802         MOVEM   A,TM.OFF-4(B)   ; STORE\r
7803         MOVEM   B,TM.OFF-3(B)\r
7804 \r
7805 \f\r
7806 ; CHECK FOR VALID ENDING TO ARGS\r
7807 \r
7808 APEXP5: PUSHJ   P,NEXTD         ; READ NEXT THING IN ARGLIST\r
7809         JRST    APEXP8          ; DONE\r
7810         TRNN    A,4             ; SKIP IF DCL\r
7811         JRST    MPD.4           ; LOSER\r
7812 APEXP7: MOVSI   A,-NWINS        ; CHECK FOR A WINNER\r
7813         CAME    B,WINRS(A)\r
7814         AOBJN   A,.-1\r
7815         JUMPE   A,MPD.6         ; NOT A WINNER\r
7816 \r
7817 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS\r
7818 \r
7819 APEXP8: MOVE    0,E.HEW+1(TB)   ; GET HEWITT ATOM\r
7820         MOVE    E,E.FCN(TB)     ; SAVE COUNTER\r
7821         MOVE    C,E.FCN+1(TB)   ; FCN\r
7822         MOVE    B,E.ARGL+1(TB)  ; ARG LIST\r
7823         MOVE    D,E.DECL+1(TB)  ; AND DCLS\r
7824         MOVEI   A,R.TMP(TB)     ; SET UP BLT\r
7825         HRLI    A,TM.OFF(A)\r
7826         BLT     A,-TM.OFF(TP)   ; BLLLLLLLLLLLLLT\r
7827         SUB     TP,[TM.OFF,,TM.OFF]     ; FLUSH CRUFT\r
7828         MOVEM   E,RE.FCN(TB)\r
7829         MOVEM   C,RE.FCN+1(TB)\r
7830         MOVEM   B,RE.ARGL+1(TB)\r
7831         MOVE    E,TP\r
7832         PUSH    TP,$TATOM\r
7833         PUSH    TP,0\r
7834         PUSH    TP,$TDECL\r
7835         PUSH    TP,D\r
7836         GETYP   A,-5(TP)        ; TUPLE ON TOP?\r
7837         CAIE    A,TINFO         ; SKIP IF YES\r
7838         JRST    APEXP9\r
7839         HRRZ    A,-5(TP)                ; GET SIZE\r
7840         ADDI    A,2\r
7841         HRLI    A,(A)\r
7842         SUB     E,A             ; POINT TO BINDINGS\r
7843         SKIPE   C,(TP)          ; IF DCL\r
7844         PUSHJ   P,CHKDCL        ; CHECK TYPE SPEC ON TUPLE\r
7845 APEXP9: PUSHJ   P,USPCBE        ; DO ACTUAL BINDING\r
7846 \r
7847         MOVE    E,-2(TP)        ; RESTORE HEWITT ATOM\r
7848         MOVE    D,(TP)          ; AND DCLS\r
7849         SUB     TP,[4,,4]\r
7850 \r
7851         JRST    AUXBND          ; GO BIND AUX'S\r
7852 \r
7853 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT\r
7854 \r
7855 APEXP4: PUSHJ   P,@E.ARG+1(TB)\r
7856         JRST    APEXP8          ; WIN\r
7857         JRST    TMA             ; TOO MANY ARGS\r
7858 \r
7859 APXP10: PUSH    P,B\r
7860         PUSHJ   P,@E.ARG+1(TB)\r
7861         JRST    .+2\r
7862         JRST    TMA\r
7863         POP     P,B\r
7864         JRST    APEXP7\r
7865 \r
7866 ; LIST OF POSSIBLE TERMINATING NAMES\r
7867 \r
7868 WINRS:\r
7869 AS.ACT: ASCII /ACT/\r
7870 AS.NAM: ASCII /NAME/\r
7871 AS.AUX: ASCII /AUX/\r
7872 AS.EXT: ASCII /EXTRA/\r
7873 NWINS==.-WINRS\r
7874 \r
7875  \f\r
7876 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS\r
7877 \r
7878 AUXBND: PUSH    P,E             ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK\r
7879                                 ;  WHEN NECESSARY)\r
7880         PUSH    P,D             ; SAME WITH DCL LIST\r
7881         PUSH    P,[-1]          ; FLAG SAYING WE ARE FCN\r
7882         SKIPN   C,RE.ARG+1(TB)  ; GET ARG LIST\r
7883         JRST    AUXDON\r
7884         GETYP   0,(C)           ; GET TYPE\r
7885         CAIE    0,TDEFER        ; SKIP IF CHSTR\r
7886         MOVMS   (P)             ; SAY WE ARE IN OPTIONALS\r
7887         JRST    AUXB1\r
7888 \r
7889 PRGBND: PUSH    P,E\r
7890         PUSH    P,D\r
7891         PUSH    P,[0]           ; WE ARE IN AUXS\r
7892 \r
7893 AUXB1:  HRRZ    C,RE.ARG+1(TB)  ; POINT TO ARGLIST\r
7894         PUSHJ   P,NEXTDC        ; GET NEXT THING OFF OF ARG LIST\r
7895         JRST    AUXDON\r
7896         TRNE    A,4             ; SKIP IF SOME KIND OF ATOM\r
7897         JRST    TRYDCL          ; COUDL BE DCL\r
7898         TRNN    A,1             ; SKIP IF QUOTED\r
7899         JRST    AUXB2\r
7900         SKIPN   (P)             ; SKIP IF QUOTED OK\r
7901         JRST    MPD.11\r
7902 AUXB2:  PUSHJ   P,PSHBND        ; SET UP BINDING\r
7903         PUSH    TP,$TDECL       ; SAVE HEWITT ATOM\r
7904         PUSH    TP,-1(P)\r
7905         PUSH    TP,$TATOM       ; AND DECLS\r
7906         PUSH    TP,-2(P)\r
7907 \r
7908         TRNN    A,2             ; SKIP IF INIT VAL EXISTS\r
7909         JRST    AUXB3           ; NO, USE UNBOUND\r
7910 \r
7911 ; EVALUATE EXPRESSION\r
7912 \r
7913         HRRZ    C,(B)           ; CDR ATOM OFF\r
7914 \r
7915 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>\r
7916 \r
7917         GETYP   0,(C)           ; GET TYPE OF GOODIE\r
7918         CAIE    0,TFORM         ; SMELLS LIKE A FORM\r
7919         JRST    AUXB13\r
7920         HRRZ    D,1(C)          ; GET 1ST ELEMENT\r
7921         GETYP   0,(D)           ; AND ITS VAL\r
7922         CAIE    0,TATOM         ; FEELS LIKE THE RIGHT FORM\r
7923         JRST    AUXB13\r
7924 \r
7925         MOVE    0,1(D)          ; GET THE ATOM\r
7926         CAME    0,MQUOTE TUPLE\r
7927         CAMN    0,MQUOTE ITUPLE\r
7928         JRST    DOTUPL          ; SURE GLAD I DIDN'T STEP IN THAT FORM\r
7929 \r
7930 \r
7931 AUXB13: PUSHJ   P,FASTEV\r
7932 AUXB14: MOVE    E,TP\r
7933 AUXB4:  MOVEM   A,-7(E)         ; STORE VAL IN BINDING\r
7934         MOVEM   B,-6(E)\r
7935 \r
7936 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING\r
7937 \r
7938 AUXB5:  SUB     E,[4,,4]        ; POINT TO BINDING TOP\r
7939         SKIPE   C,-2(TP)        ; POINT TO DECLARATINS\r
7940         PUSHJ   P,CHKDCL        ; CHECK  IT\r
7941         PUSHJ   P,USPCBE        ; AND BIND UP\r
7942         SKIPE   C,RE.ARG+1(TB)  ; CDR DCLS\r
7943         HRRZ    C,(C)           ; IF ANY TO CDR\r
7944         MOVEM   C,RE.ARG+1(TB)\r
7945         MOVE    A,(TP)          ; NOW PUT HEWITT ATOM AND DCL AWAY\r
7946         MOVEM   A,-2(P)\r
7947         MOVE    A,-2(TP)\r
7948         MOVEM   A,-1(P)\r
7949         SUB     TP,[4,,4]       ; FLUSH SLOTS\r
7950         JRST    AUXB1\r
7951 \r
7952 \r
7953 AUXB3:  MOVNI   B,1\r
7954         MOVSI   A,TUNBOU\r
7955         JRST    AUXB14\r
7956 \r
7957 \f\r
7958 \r
7959 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE\r
7960 \r
7961 DOTUPL: PUSH    TP,$TLIST       ; SAVE THE MAGIC FORM\r
7962         PUSH    TP,D\r
7963         CAME    0,MQUOTE TUPLE\r
7964         JRST    DOITUP          ; DO AN ITUPLE\r
7965 \r
7966 ; FALL INTO A TUPLE PUSHING LOOP\r
7967 \r
7968 DOTUP1: HRRZ    C,@(TP)         ; CDR THE FORM\r
7969         JUMPE   C,ATUPDN        ; FINISHED\r
7970         MOVEM   C,(TP)          ; SAVE CDR'D RESULT\r
7971         GETYP   0,(C)           ; CHECK FOR SEGMENT\r
7972         CAIN    0,TSEG\r
7973         JRST    DTPSEG          ; GO PULL IT APART\r
7974         PUSHJ   P,FASTEV        ; EVAL IT\r
7975         PUSHJ   P,CNTARG        ; PUSH IT UP AND COUNT THEM\r
7976         JRST    DOTUP1\r
7977 \r
7978 ; HERE WHEN WE FINISH\r
7979 \r
7980 ATUPDN: SUB     TP,[2,,2]       ; FLUSH THE LIST\r
7981         ASH     E,1             ; E HAS # OF ARGS DOUBLE IT\r
7982         MOVEI   D,(TP)          ; FIND BASE OF STACK AREA\r
7983         SUBI    D,(E)\r
7984         MOVSI   C,-3(D)         ; PREPARE BLT POINTER\r
7985         BLT     C,C             ; HEWITT ATOM AND DECL TO 0,A,B,C\r
7986 \r
7987 ; NOW PREPEARE TO BLT TUPLE DOWN\r
7988 \r
7989         MOVEI   D,-3(D)         ; NEW DEST\r
7990         HRLI    D,4(D)          ; SOURCE\r
7991         BLT     D,-4(TP)        ; SLURP THEM DOWN\r
7992 \r
7993         HRLI    E,TINFO         ; SET UP FENCE POST\r
7994         MOVEM   E,-3(TP)        ; AND STORE\r
7995         PUSHJ   P,TBTOTP        ; GET OFFSET\r
7996         ADDI    D,3             ; FUDGE FOR NOT AT TOP OF STACK\r
7997         MOVEM   D,-2(TP)\r
7998         MOVEM   0,-1(TP)        ; RESTORE HEW ATOM AND  DECLS\r
7999         MOVEM   A,(TP)\r
8000         PUSH    TP,B\r
8001         PUSH    TP,C\r
8002 \r
8003         PUSHJ   P,MAKINF        ; MAKE 1ST WORD OF FUNNYS\r
8004 \r
8005         HRRZ    E,-5(TP)        ; RESTORE WORDS OF TUPLE\r
8006         HRROI   B,-5(TP)        ; POINT TO TOP OF TUPLE\r
8007         SUBI    B,(E)           ; NOW BASE\r
8008         TLC     B,-1(E)         ; FIX UP AOBJN PNTR\r
8009         ADDI    E,2             ; COPNESATE FOR FENCE PST\r
8010         HRLI    E,(E)\r
8011         SUBM    TP,E            ; E POINT TO BINDING\r
8012         JRST    AUXB4           ; GO CLOBBER IT IN\r
8013 \f\r
8014 \r
8015 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS\r
8016 \r
8017 DTPSEG: PUSH    TP,$TFORM       ; SAVE THE HACKER\r
8018         PUSH    TP,1(C)\r
8019         MCALL   1,EVAL          ; AND EVALUATE IT\r
8020         MOVE    D,B             ; GET READY FOR A SEG LOOP\r
8021         MOVEM   A,DSTO(PVP)\r
8022         PUSHJ   P,TYPSEG        ; TYPE AND CHECK IT\r
8023 \r
8024 DTPSG1: INTGO                   ; DONT BLOW YOUR STACK\r
8025         PUSHJ   P,NXTLM         ; ELEMENT TO A AND B\r
8026         JRST    DTPSG2          ; DONE\r
8027         PUSHJ   P,CNTARG        ; PUSH AND COUNT\r
8028         JRST    DTPSG1\r
8029 \r
8030 DTPSG2: SETZM   DSTO(PVP)\r
8031         JRST    DOTUP1          ; REST OF ARGS STILL TO DO\r
8032 \r
8033 ; HERE TO HACK <ITUPLE .....>\r
8034 \r
8035 DOITUP: HRRZ    C,@(TP)         ; GET COUNT FILED\r
8036         JUMPE   C,TUPTFA\r
8037         MOVEM   C,(TP)\r
8038         PUSHJ   P,FASTEV        ; EVAL IT\r
8039         GETYP   0,A\r
8040         CAIE    0,TFIX\r
8041         JRST    WTY1TP\r
8042 \r
8043         JUMPL   B,BADNUM\r
8044 \r
8045         HRRZ    C,@(TP)         ; GET EXP TO EVAL\r
8046         MOVEI   0,0             ; DONT LOSE IN 1 ARG CASE\r
8047         HRRZ    0,(C)           ; VERIFY WINNAGE\r
8048         JUMPN   0,TUPTMA        ; TOO MANY\r
8049 \r
8050         JUMPE   B,DOIDON\r
8051         PUSH    P,B             ; SAVE COUNT\r
8052         PUSH    P,B\r
8053         JUMPE   C,DOILOS\r
8054         PUSHJ   P,FASTEV        ; EVAL IT ONCE\r
8055         MOVEM   A,-1(TP)\r
8056         MOVEM   B,(TP)\r
8057 \r
8058 DOILP:  INTGO\r
8059         PUSH    TP,-1(TP)\r
8060         PUSH    TP,-1(TP)\r
8061         MCALL   1,EVAL\r
8062         PUSHJ   P,CNTRG\r
8063         SOSLE   (P)\r
8064         JRST    DOILP\r
8065 \r
8066 DOIDO1: MOVE    B,-1(P)         ; RESTORE COUNT\r
8067         SUB     P,[2,,2]\r
8068 \r
8069 DOIDON: MOVEI   E,(B)\r
8070         JRST    ATUPDN\r
8071 \r
8072 ; FOR CASE OF NO EVALE\r
8073 \r
8074 DOILOS: SUB     TP,[2,,2]\r
8075 DOILLP: INTGO\r
8076         PUSH    TP,[0]\r
8077         PUSH    TP,[0]\r
8078         SOSL    (P)\r
8079         JRST    DOILLP\r
8080         JRST    DOIDO1\r
8081 \r
8082 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT\r
8083 \r
8084 CNTARG: AOS     E,-1(TP)        ; KEEP ARG COUNT UP TO DATE IN E\r
8085 CNTRG:  EXCH    A,-1(TP)        ; STORE ELEM AND GET SAVED\r
8086         EXCH    B,(TP)\r
8087         PUSH    TP,A\r
8088         PUSH    TP,B\r
8089         POPJ    P,\r
8090 \r
8091 \r
8092 ; DUMMY TUPLE AND ITUPLE \r
8093 \r
8094 MFUNCTION TUPLE,SUBR\r
8095 \r
8096         ENTRY\r
8097         PUSH    TP,$TATOM\r
8098         PUSH    TP,EQUOTE NOT-IN-ARG-LIST\r
8099         JRST    CALER1\r
8100 \r
8101 MFUNCTIO ITUPLE,SUBR\r
8102         JRST    TUPLE\r
8103 \r
8104 \f\r
8105 ; PROCESS A DCL IN THE AUX VAR LISTS\r
8106 \r
8107 TRYDCL: SKIPN   (P)             ; SKIP IF NOT IN AUX'S\r
8108         JRST    AUXB7\r
8109         CAME    B,AS.AUX        ; "AUX" ?\r
8110         CAMN    B,AS.EXT        ; OR "EXTRA"\r
8111         JRST    AUXB9           ; YES\r
8112         CAME    B,[ASCII /TUPLE/]\r
8113         JRST    AUXB10\r
8114         PUSHJ   P,MAKINF        ; BUILD EMPTY TUPLE\r
8115         MOVEI   B,1(TP)\r
8116         PUSH    TP,$TINFO               ; FENCE POST\r
8117         PUSHJ   P,TBTOTP\r
8118         PUSH    TP,D\r
8119 AUXB6:  HRRZ    C,(C)           ; CDR PAST DCL\r
8120         MOVEM   C,RE.ARG+1(TB)\r
8121 AUXB8:  PUSHJ   P,CARTMC        ; GET ATOM\r
8122 AUXB12: PUSHJ   P,PSHBND        ; UP GOES THE BINDING\r
8123         PUSH    TP,$TATOM       ; HIDE HEWITT ATOM AND DCL\r
8124         PUSH    TP,-1(P)\r
8125         PUSH    TP,$TDECL\r
8126         PUSH    TP,-2(P)\r
8127         MOVE    E,TP\r
8128         JRST    AUXB5\r
8129 \r
8130 ; CHECK FOR ARGS\r
8131 \r
8132 AUXB10: CAME    B,[ASCII /ARGS/]\r
8133         JRST    AUXB7\r
8134         MOVEI   B,0             ; NULL ARG LIST\r
8135         MOVSI   A,TLIST\r
8136         JRST    AUXB6           ; GO BIND\r
8137 \r
8138 AUXB9:  SETZM   (P)             ; NOW READING AUX\r
8139         HRRZ    C,(C)\r
8140         MOVEM   C,RE.ARG+1(TB)\r
8141         JRST    AUXB1\r
8142 \r
8143 ; CHECK FOR NAME/ACT\r
8144 \r
8145 AUXB7:  CAME    B,AS.NAM\r
8146         CAMN    B,AS.ACT\r
8147         JRST    .+2\r
8148         JRST    MPD.12          ; LOSER\r
8149         HRRZ    C,(C)           ; CDR ON\r
8150         HRRZ    0,(C)           ; BETTER BE END\r
8151         JUMPN   0,MPD.13\r
8152         PUSHJ   P,CARTMC        ; FORCE ATOM READ\r
8153         SETZM   RE.ARG+1(TB)\r
8154 AUXB11: PUSHJ   P,MAKACT        ; MAKE ACTIVATION\r
8155         JRST    AUXB12          ; AND BIND IT\r
8156 \r
8157 \r
8158 ; DONE BIND HEWITT ATOM IF NECESARY\r
8159 \r
8160 AUXDON: SKIPN   E,-2(P)\r
8161         JRST    AUXD1\r
8162         SETZM   -2(P)\r
8163         JRST    AUXB11\r
8164 \r
8165 ; FINISHED, RETURN\r
8166 \r
8167 AUXD1:  SUB     P,[3,,3]\r
8168         POPJ    P,\r
8169 \r
8170 \r
8171 ; MAKE AN ACTIVATION OR ENVIRONMNENT\r
8172 \r
8173 MAKACT: MOVEI   B,(TB)\r
8174         MOVSI   A,TACT\r
8175 MAKAC1: HRRI    A,PVLNT*2+1(PVP)        ; POINT TO PROCESS\r
8176         HLL     B,OTBSAV(B)     ; GET TIME\r
8177         POPJ    P,\r
8178 \r
8179 MAKENV: MOVSI   A,TENV\r
8180         HRRZ    B,OTBSAV(TB)\r
8181         JRST    MAKAC1\r
8182 \f\r
8183 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF\r
8184 \r
8185 ; CARAT/CARATC/CARATM/CARTMC  ALL LOOK FOR THE NEXT ATOM\r
8186 \r
8187 CARAT:  HRRZ    C,E.ARGL+1(TB)  ; PICK UP ARGLIST\r
8188 CARATC: JUMPE   C,CPOPJ         ; FOUND\r
8189         GETYP   0,(C)           ; GET ITS TYPE\r
8190         CAIE    0,TATOM\r
8191 CPOPJ:  POPJ    P,              ; RETURN, NOT ATOM\r
8192         MOVE    E,1(C)          ; GET ATOM\r
8193         HRRZ    C,(C)           ; CDR DCLS\r
8194         JRST    CPOPJ1\r
8195 \r
8196 CARATM: HRRZ    C,E.ARGL+1(TB)\r
8197 CARTMC: PUSHJ   P,CARATC\r
8198         JRST    MPD.7           ; REALLY LOSE\r
8199         POPJ    P,\r
8200 \r
8201 \r
8202 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK\r
8203 \r
8204 PSBND1: PUSHJ   P,PSHBND        ; PUSH THEBINDING\r
8205         JRST    CHDCL           ; NOW CHECK IT AGAINST DECLARATION\r
8206 \r
8207 PSHBND: SKIPGE  SPCCHK          ; SKIP IF NORMAL SPECIAL\r
8208         PUSH    TP,BNDA1        ; ATOM IN E\r
8209         SKIPL   SPCCHK          ; SKIP IF NORMAL UNSPEC OR NO CHECK\r
8210         PUSH    TP,BNDA\r
8211         PUSH    TP,E            ; PUSH IT\r
8212 PSHAB4: PUSH    TP,A\r
8213         PUSH    TP,B\r
8214         PUSH    TP,[0]\r
8215         PUSH    TP,[0]\r
8216         POPJ    P,\r
8217 \r
8218 ; ROUTINE TO PUSH 4 0'S\r
8219 \r
8220 PSH4ZR: SETZB   A,B\r
8221         JRST    PSHAB4\r
8222 \r
8223 \r
8224 ; EXTRRA ARG GOBBLER\r
8225 \r
8226 EXTRGT: HRRZ    A,E.ARG(TB)     ; RESET SLOT\r
8227         CAIE    A,ARGCDR        ; IF NOT ARGCDR\r
8228         TLO     A,400000        ; SET FLAG\r
8229         MOVEM   A,E.ARG+1(TB)\r
8230         MOVE    A,E.EXTR(TB)    ; RET ARG\r
8231         MOVE    B,E.EXTR+1(TB)\r
8232         JRST    CPOPJ1\r
8233 \r
8234 ; CHECK A/B FOR DEFER\r
8235 \r
8236 CHKAB:  GETYP   0,A\r
8237         CAIE    0,TDEFER        ; SKIP IF DEFER\r
8238         JRST    (E)\r
8239         MOVE    A,(B)\r
8240         MOVE    B,1(B)          ; GET REAL THING\r
8241         JRST    (E)\r
8242 ; IF DECLARATIONS EXIST, DO THEM\r
8243 \r
8244 CHDCL:  MOVE    E,TP\r
8245 CHDCLE: SKIPN   C,E.DECL+1(TB)\r
8246         POPJ    P,\r
8247         JRST    CHKDCL\r
8248 \f\r
8249 ; ROUTINE TO READ NEXT THING FROM ARGLIST\r
8250 \r
8251 NEXTD:  HRRZ    C,E.ARGL+1(TB)  ; GET ARG LIST\r
8252 NEXTDC: JUMPE   C,CPOPJ\r
8253         PUSHJ   P,CARATC        ; TRY FOR AN ATOM\r
8254         JRST    NEXTD1          ; NO\r
8255         MOVEI   A,0             ; SET FLAG\r
8256         JRST    CPOPJ1\r
8257 \r
8258 NEXTD1: CAIE    0,TFORM         ; FORM?\r
8259         JRST    NXT.L           ; COULD BE LIST\r
8260         PUSHJ   P,CHQT          ; VERIFY 'ATOM\r
8261         MOVEI   A,1\r
8262         JRST    CPOPJ1\r
8263 \r
8264 NXT.L:  CAIE    0,TLIST         ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)\r
8265         JRST    NXT.S           ; BETTER BE A DCL\r
8266         PUSHJ   P,LNT.2         ; VERIFY LENGTH IS 2\r
8267         JRST    MPD.8\r
8268         CAIE    0,TATOM         ; TYPE OF 1ST RET IN 0\r
8269         JRST    LST.QT          ; MAY BE 'ATOM\r
8270         MOVE    E,1(B)          ; GET ATOM\r
8271         MOVEI   A,2\r
8272         JRST    CPOPJ1\r
8273 LST.QT: CAIE    0,TFORM         ; FORM?\r
8274         JRST    MPD.9           ; LOSE\r
8275         PUSH    P,C\r
8276         MOVEI   C,(B)           ; VERIFY 'ATOM\r
8277         PUSHJ   P,CHQT\r
8278         MOVEI   B,(C)           ; POINT BACK TO LIST\r
8279         POP     P,C\r
8280         MOVEI   A,3             ; CODE\r
8281         JRST    CPOPJ1\r
8282 \r
8283 NXT.S:  MOVEI   A,(C)           ; LET NXTDCL FIND OUT\r
8284         PUSHJ   P,NXTDCL\r
8285         JRST    MPD.3           ; LOSER\r
8286         MOVEI   A,4             ; SET DCL READ FLAG\r
8287         JRST    CPOPJ1\r
8288 \r
8289 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2\r
8290 \r
8291 LNT.2:  HRRZ    B,1(C)          ; GET LIST/FORM\r
8292         JUMPE   B,CPOPJ\r
8293         HRRZ    B,(B)\r
8294         JUMPE   B,CPOPJ\r
8295         HRRZ    B,(B)           ; BETTER END HERE\r
8296         JUMPN   B,CPOPJ\r
8297         HRRZ    B,1(C)          ; LIST BACK\r
8298         GETYP   0,(B)           ; TYPE OF 1ST ELEMENT\r
8299         JRST    CPOPJ1\r
8300 \r
8301 ; ROUTINE TO  VERIFY FORM IS 'ATOM AND RET ATOM\r
8302 \r
8303 CHQT:   PUSHJ   P,LNT.2         ; 1ST LENGTH CHECK\r
8304         JRST    MPD.5\r
8305         CAIE    0,TATOM\r
8306         JRST    MPD.5\r
8307         MOVE    0,1(B)\r
8308         CAME    0,MQUOTE QUOTE\r
8309         JRST    MPD.5           ; BETTER BE QUOTE\r
8310         HRRZ    E,(B)           ; CDR\r
8311         GETYP   0,(E)           ; TYPE\r
8312         CAIE    0,TATOM\r
8313         JRST    MPD.5\r
8314         MOVE    E,1(E)          ; GET QUOTED ATOM\r
8315         POPJ    P,\r
8316 \f\r
8317 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS\r
8318 \r
8319 BNDEM1: PUSH    P,[0]           ; REGULAR FLAG\r
8320         JRST    .+2\r
8321 BNDEM2: PUSH    P,[1]\r
8322 BNDEM:  PUSHJ   P,NEXTD         ; GET NEXT THING\r
8323         JRST    CCPOPJ          ; END OF THINGS\r
8324         TRNE    A,4             ; CHECK FOR DCL\r
8325         JRST    BNDEM4\r
8326         TRNE    A,2             ; SKIP IF NOT (ATM ..) OR ('ATM ...)\r
8327         SKIPE   (P)             ; SKIP IF REG ARGS\r
8328         JRST    .+2             ; WINNER, GO ON\r
8329         JRST    MPD.6           ; LOSER\r
8330         SKIPGE  SPCCHK\r
8331         PUSH    TP,BNDA1        ; SAVE ATOM\r
8332         SKIPL   SPCCHK\r
8333         PUSH    TP,BNDA\r
8334         PUSH    TP,E\r
8335         SKIPL   E.ARG+1(TB)     ; SKIP IF MUST EVAL ARG\r
8336         TRNN    A,1             ; SKIP IF ARG QUOTED\r
8337         JRST    RGLARG\r
8338         HRRZ    D,@E.FRM+1(TB)  ; GET AND CDR ARG\r
8339         JUMPE   D,TFACHK        ; OH OH MAYBE TOO FEW ARGS\r
8340         MOVEM   D,E.FRM+1(TB)   ; STORE WINNER\r
8341         HLLZ    A,(D)           ; GET ARG\r
8342         MOVE    B,1(D)\r
8343         JSP     E,CHKAB ; HACK DEFER\r
8344         JRST    BNDEM3          ; AND GO ON\r
8345 \r
8346 RGLARG: PUSH    P,A             ; SAVE FLAGS\r
8347         PUSHJ   P,@E.ARG+1(TB)\r
8348         JRST    TFACH1          ; MAY GE TOO FEW\r
8349         SUB     P,[1,,1]\r
8350 BNDEM3: HRRZ    C,@E.ARGL+1(TB) ; CDR THHE ARGS\r
8351         MOVEM   C,E.ARGL+1(TB)\r
8352         PUSHJ   P,PSHAB4        ; PUSH VALUE AND SLOTS\r
8353         PUSHJ   P,CHDCL         ; CHECK DCLS\r
8354         JRST    BNDEM           ; AND BIND ON!\r
8355 \r
8356 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA\r
8357 \r
8358 TFACH1: POP     P,A\r
8359 TFACHK: SUB     TP,[2,,2]       ; FLUSH ATOM\r
8360         SKIPN   (P)             ; SKIP IF OPTIONALS\r
8361         JRST    TFA\r
8362 CCPOPJ: SUB     P,[1,,1]\r
8363         POPJ    P,\r
8364 \r
8365 BNDEM4: HRRZ    C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL\r
8366         JRST    CCPOPJ\r
8367 \f\r
8368 \r
8369 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS\r
8370 \r
8371 EVLIST: PUSH    P,[-1]          ;-1 -- THIS IS A LIST\r
8372         JRST    EVL1            ;GO TO HACKER\r
8373 \r
8374 EVECT:  PUSH    P,[0]           ;0 -- THIS IS A GENERAL VECTOR\r
8375         JRST    EVL1\r
8376 \r
8377 EUVEC:  PUSH    P,[1]           ;1 -- THIS IS A UNIFORM VECTOR\r
8378 \r
8379 EVL1:   PUSH    P,[0]           ;PUSH A COUNTER\r
8380         GETYPF  A,(AB)          ;GET FULL TYPE\r
8381         PUSH    TP,A\r
8382         PUSH    TP,1(AB)        ;AND VALUE\r
8383 \r
8384 EVL2:   INTGO                   ;CHECK INTERRUPTS\r
8385         SKIPN   A,1(TB)         ;ANYMORE\r
8386         JRST    EVL3            ;NO, QUIT\r
8387         SKIPL   -1(P)           ;SKIP IF LIST\r
8388         JUMPG   A,EVL3          ;JUMP IF VECTOR EMPTY\r
8389         GETYPF  B,(A)           ;GET FULL TYPE\r
8390         SKIPGE  C,-1(P)         ;SKIP IF NOT LIST\r
8391         HLLZS   B               ;CLOBBER CDR FIELD\r
8392         JUMPG   C,EVL7          ;HACK UNIFORM VECS\r
8393 EVL8:   PUSH    P,B             ;SAVE TYPE WORD ON P\r
8394         CAMN    B,$TSEG         ;SEGMENT?\r
8395         MOVSI   B,TFORM         ;FAKE OUT EVAL\r
8396         PUSH    TP,B            ;PUSH TYPE\r
8397         PUSH    TP,1(A)         ;AND VALUE\r
8398         JSP     E,CHKARG        ; CHECK DEFER\r
8399         MCALL   1,EVAL          ;AND EVAL IT\r
8400         POP     P,C             ;AND RESTORE REAL TYPE\r
8401         CAMN    C,$TSEG         ;SEGMENT?\r
8402         JRST    DOSEG           ;YES, HACK IT\r
8403         AOS     (P)             ;COUNT ELEMENT\r
8404         PUSH    TP,A            ;AND PUSH IT\r
8405         PUSH    TP,B\r
8406 EVL6:   SKIPGE  A,-1(P) ;DONT SKIP IF LIST\r
8407         HRRZ    B,@1(TB)        ;CDR IT\r
8408         JUMPL   A,ASTOTB        ;AND STORE IT\r
8409         MOVE    B,1(TB)         ;GET VECTOR POINTER\r
8410         ADD     B,AMNT(A)       ;INCR BY APPROPRIATE AMOUNT\r
8411 ASTOTB: MOVEM   B,1(TB)         ;AND STORE BACK\r
8412         JRST    EVL2            ;AND LOOP BACK\r
8413 \r
8414 AMNT:   2,,2                    ;INCR FOR GENERAL VECTOR\r
8415         1,,1                    ;SAME FOR UNIFORM VECTOR\r
8416 \r
8417 CHKARG: GETYP   A,-1(TP)\r
8418         CAIE    A,TDEFER\r
8419         JRST    (E)\r
8420         HRRZS   (TP)            ;MAKE SURE INDIRECT WINS\r
8421         MOVE    A,@(TP)\r
8422         MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT\r
8423         MOVE    A,(TP)          ;NOW GET POINTER\r
8424         MOVE    A,1(A)          ;GET VALUE\r
8425         MOVEM   A,(TP)          ;CLOBBER IN\r
8426         JRST    (E)\r
8427 \r
8428 \f\r
8429 \r
8430 EVL7:   HLRE    C,A             ; FIND TYPE OF UVECTOR\r
8431         SUBM    A,C             ;C POINTS TO DOPE WORD\r
8432         GETYP   B,(C)           ;GET TYPE\r
8433         MOVSI   B,(B)           ;TO LH NOW\r
8434         SOJA    A,EVL8          ;AND RETURN TO DO EVAL\r
8435 \r
8436 EVL3:   SKIPL   -1(P)           ;SKIP IF LIST\r
8437         JRST    EVL4            ;EITHER VECTOR OR UVECTOR\r
8438 \r
8439         MOVEI   B,0             ;GET A NIL\r
8440 EVL9:   MOVSI   A,TLIST         ;MAKE TYPE WIN\r
8441 EVL5:   SOSGE   (P)             ;COUNT DOWN\r
8442         JRST    EVL10           ;DONE, RETURN\r
8443         PUSH    TP,$TLIST       ;SET TO CALL CONS\r
8444         PUSH    TP,B\r
8445         MCALL   2,CONS\r
8446         JRST    EVL5            ;LOOP TIL DONE\r
8447 \r
8448 \r
8449 EVL4:   MOVEI   B,EUVECT        ;UNIFORM CASE\r
8450         SKIPG   -1(P)           ;SKIP IF UNIFORM CASE\r
8451         MOVEI   B,EVECTO        ;NO, GENERAL CASE\r
8452         POP     P,A             ;GET COUNT\r
8453         .ACALL  A,(B)           ;CALL CREATOR\r
8454 EVL10:  GETYPF  A,(AB)          ; USE SENT TYPE\r
8455         JRST    EFINIS\r
8456 \r
8457 \f\r
8458 ; PROCESS SEGMENTS FOR THESE  HACKS\r
8459 \r
8460 DOSEG:  PUSHJ   P,TYPSEG        ; FIND WHAT IS BEING SEGMENTED\r
8461         JUMPE   C,LSTSEG        ; CHECK END SPLICE IF LIST\r
8462 \r
8463 SEG3:   PUSHJ   P,NXTELM        ; GET THE NEXTE ELEMT\r
8464         JRST    SEG4            ; RETURN TO CALLER\r
8465         AOS     (P)             ; COUNT\r
8466         JRST    SEG3            ; TRY AGAIN\r
8467 SEG4:   SETZM   DSTO(PVP)\r
8468         JRST    EVL6\r
8469 \r
8470 TYPSEG: PUSHJ   P,TYPSGR\r
8471         JRST    ILLSEG\r
8472         POPJ    P,\r
8473 \r
8474 TYPSGR: MOVEM   A,DSTO(PVP)     ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D\r
8475         GETYP   A,A             ; TYPE TO RH\r
8476         PUSHJ   P,SAT           ;GET STORAGE TYPE\r
8477         MOVE    D,B             ; GOODIE TO D\r
8478 \r
8479         MOVNI   C,1             ; C <0 IF ILLEGAL\r
8480         CAIN    A,S2WORD        ;LIST?\r
8481         MOVEI   C,0\r
8482         CAIN    A,S2NWORD       ;GENERAL VECTOR?\r
8483         MOVEI   C,1\r
8484         CAIN    A,SNWORD        ;UNIFORM VECTOR?\r
8485         MOVEI   C,2\r
8486         CAIN    A,SCHSTR\r
8487         MOVEI   C,3\r
8488         CAIN    A,SSTORE        ;SPECIAL AFREE STORAGE ?\r
8489         MOVEI   C,2             ;TREAT LIKE A UVECTOR\r
8490         CAIN    A,SARGS         ;ARGS TUPLE?\r
8491         JRST    SEGARG          ;NO, ERROR\r
8492         CAILE   A,NUMSAT        ; SKIP IF NOT TEMPLATE\r
8493         JRST    SEGTMP\r
8494         JUMPGE  C,CPOPJ1\r
8495         SETZM   DSTO(PVP)       ; DON'T CONFUSE AGC LATER!\r
8496         POPJ    P,\r
8497 \r
8498 SEGTMP: MOVEI   C,4\r
8499         HRRM    A,DSTO(PVP)     ; SAVE FOR HACKERS\r
8500         JRST    CPOPJ1\r
8501 \r
8502 SEGARG: PUSH    TP,DSTO(PVP)    ;PREPARE TO CHECK ARGS\r
8503         PUSH    TP,D\r
8504         SETZM   DSTO(PVP)       ;TYPE NOT SPECIAL\r
8505         MOVEI   B,-1(TP)        ;POINT TO SAVED COPY\r
8506         PUSHJ   P,CHARGS        ;CHECK ARG POINTER\r
8507         POP     TP,D            ;AND RESTORE WINNER\r
8508         POP     TP,DSTO(PVP)    ;AND TYPE AND FALL INTO VECTOR CODE\r
8509         MOVEI   C,1\r
8510         JRST    CPOPJ1\r
8511 \r
8512 LSTSEG: SKIPL   -1(P)           ;SKIP IF IN A LIST\r
8513         JRST    SEG3            ;ELSE JOIN COMMON CODE\r
8514         HRRZ    A,@1(TB)        ;CHECK FOR END OF LIST\r
8515         JUMPN   A,SEG3          ;NO, JOIN COMMON CODE\r
8516         SETZM   DSTO(PVP)       ;CLOBBER SAVED GOODIES\r
8517         JRST    EVL9            ;AND FINISH UP\r
8518 \r
8519 NXTELM: INTGO\r
8520         PUSHJ   P,NXTLM         ; GOODIE TO A AND B\r
8521         POPJ    P,              ; DONE\r
8522         PUSH    TP,A\r
8523         PUSH    TP,B\r
8524         JRST    CPOPJ1\r
8525 NXTLM:  XCT     TESTR(C)        ; SKIP IF MORE IN SEGEMNT\r
8526         POPJ    P,\r
8527         XCT     TYPG(C)         ; GET THE TYPE\r
8528         XCT     VALG(C)         ; AND VALUE\r
8529         JSP     E,CHKAB         ; CHECK DEFERRED\r
8530         XCT     INCR1(C)        ; AND INCREMENT TO NEXT\r
8531 CPOPJ1: AOS     (P)             ; SKIP RETURN\r
8532         POPJ    P,\r
8533 \r
8534 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)\r
8535 \r
8536 TESTR:  SKIPN   D\r
8537         SKIPL   D\r
8538         SKIPL   D\r
8539         PUSHJ   P,CHRDON\r
8540         PUSHJ   P,TM1\r
8541 \r
8542 TYPG:   PUSHJ   P,LISTYP\r
8543         GETYPF  A,(D)\r
8544         PUSHJ   P,UTYPE\r
8545         MOVSI   A,TCHRS\r
8546         PUSHJ   P,TM2\r
8547 \r
8548 VALG:   MOVE    B,1(D)\r
8549         MOVE    B,1(D)\r
8550         MOVE    B,(D)\r
8551         PUSHJ   P,1CHGT\r
8552         PUSHJ   P,TM3\r
8553 \r
8554 INCR1:  HRRZ    D,(D)\r
8555         ADD     D,[2,,2]\r
8556         ADD     D,[1,,1]\r
8557         PUSHJ   P,1CHINC\r
8558         ADD     D,[1,,]\r
8559 \r
8560 TM1:    HRRZ    A,DSTO(PVP)     ; GET SAT\r
8561         SUBI    A,NUMSAT+1\r
8562         ADD     A,TD.LNT+1(TVP)\r
8563         EXCH    C,D\r
8564         XCT     (A)\r
8565         HLRZ    0,C             ; GET AMNT RESTED\r
8566         SUB     B,0\r
8567         EXCH    C,D\r
8568         TRNE    B,-1\r
8569         AOS     (P)\r
8570         POPJ    P,\r
8571 \r
8572 TM3:\r
8573 TM2:    HRRZ    0,DSTO(PVP)\r
8574         PUSH    P,C\r
8575         PUSH    P,D\r
8576         PUSH    P,E\r
8577         MOVE    B,D\r
8578         MOVEI   C,0             ; GET "1ST ELEMENT"\r
8579         PUSHJ   P,TMPLNT        ; GET NTH IN A AND B\r
8580         POP     P,E\r
8581         POP     P,D\r
8582         POP     P,C\r
8583         POPJ    P,\r
8584 \r
8585 \r
8586 CHRDON: HRRZ    B,DSTO(PVP)     ; POIT TO DOPE WORD\r
8587         JUMPE   B,CHRFIN\r
8588         AOS     (P)\r
8589 CHRFIN: POPJ    P,\r
8590 \r
8591 LISTYP: GETYP   A,(D)\r
8592         MOVSI   A,(A)\r
8593         POPJ    P,\r
8594 1CHGT:  MOVE    B,D\r
8595         ILDB    B,B\r
8596         POPJ    P,\r
8597 \r
8598 1CHINC: SOS     DSTO(PVP)\r
8599         IBP     D\r
8600         POPJ    P,\r
8601 \r
8602 UTYPE:  HLRE    A,D\r
8603         SUBM    D,A\r
8604         GETYP   A,(A)\r
8605         MOVSI   A,(A)\r
8606         POPJ    P,\r
8607 \r
8608 \r
8609 ;COMPILER's CALL TO DOSEG\r
8610 SEGMNT: PUSHJ   P,TYPSEG\r
8611 SEGLP1: SETZB   A,B\r
8612 SEGLOP: PUSHJ   P,NXTELM\r
8613         JRST    SEGRET\r
8614         AOS     (P)-2           ; INCREMENT COMPILER'S COUNT\r
8615         JRST    SEGLOP\r
8616 \r
8617 SEGRET: SETZM   DSTO(PVP)\r
8618         POPJ    P,\r
8619 \r
8620 SEGLST: PUSHJ   P,TYPSEG\r
8621         JUMPN   C,SEGLS2\r
8622 SEGLS3: SETZM   DSTO(PVP)\r
8623         MOVSI   A,TLIST\r
8624 SEGLS1: SOSGE   -2(P)           ; START COUNT DOWN\r
8625         POPJ    P,\r
8626         MOVEI   E,(B)\r
8627         POP     TP,D\r
8628         POP     TP,C\r
8629         PUSHJ   P,ICONS\r
8630         JRST    SEGLS1\r
8631 \r
8632 SEGLS2: PUSHJ   P,NXTELM\r
8633         JRST    SEGLS4\r
8634         AOS     -2(P)\r
8635         JRST    SEGLS2\r
8636 \r
8637 SEGLS4: MOVEI   B,0\r
8638         JRST    SEGLS3\r
8639 \f\r
8640 \r
8641 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.\r
8642 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.  \r
8643 ;EACH TRIPLET IS AS FOLLOWS:\r
8644 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],\r
8645 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,\r
8646 ;AND THE THIRD IS A PAIR OF ZEROES.\r
8647 \r
8648 BNDA1:  TATOM,,-2\r
8649 BNDA:   TATOM,,-1\r
8650 BNDV:   TVEC,,-1\r
8651 \r
8652 USPECBIND:\r
8653         MOVE    E,TP\r
8654 USPCBE: PUSH    P,$TUBIND\r
8655         JRST    .+3\r
8656 \r
8657 SPECBIND:\r
8658         MOVE    E,TP            ;GET THE POINTER TO TOP\r
8659 SPECBE: PUSH    P,$TBIND\r
8660         ADD     E,[1,,1]        ;BUMP POINTER ONCE\r
8661         SETZB   0,D             ;CLEAR TEMPS\r
8662         PUSH    P,0\r
8663         MOVEI   0,(TB)          ; FOR CHECKS\r
8664 \r
8665 BINDLP: MOVE    A,-4(E)         ; CHECK FOR VEC BIND\r
8666         CAMN    A,BNDV\r
8667         JRST    NONID\r
8668         MOVE    A,-6(E)         ;GET TYPE\r
8669         CAME    A,BNDA1         ; FOR UNSPECIAL\r
8670         CAMN    A,BNDA          ;NORMAL ID BIND?\r
8671         CAILE   0,-6(E)         ; MAKE SURE NOT GOING UNDER FRAME\r
8672         JRST    SPECBD\r
8673         SUB     E,[6,,6]        ;MOVE PTR\r
8674         SKIPE   D               ;LINK?\r
8675         HRRM    E,(D)           ;YES --  LOBBER\r
8676         SKIPN   (P)             ;UPDATED?\r
8677         MOVEM   E,(P)           ;NO -- DO IT\r
8678 \r
8679         MOVE    A,0(E)          ;GET ATOM PTR\r
8680         MOVE    B,1(E)  \r
8681         PUSHJ   P,ILOC          ;GET LAST BINDING\r
8682         MOVS    A,OTBSAV (TB)   ;GET TIME\r
8683         HRL     A,5(E)          ; GET DECL POINTER\r
8684         MOVEM   A,4(E)          ;CLOBBER IT AWAY\r
8685         MOVE    A,(E)           ; SEE IF SPEC/UNSPEC\r
8686         TRNN    A,1             ; SKIP, ALWAYS SPEC\r
8687         SKIPA   A,-1(P)         ; USE SUPPLIED\r
8688         MOVSI   A,TBIND\r
8689         MOVEM   A,(E)           ;IDENTIFY AS BIND BLOCK\r
8690         HRRZ    C,SPBASE(PVP)   ; CHECK FOR CROSS OF PROC\r
8691         MOVEI   A,(TP)\r
8692         CAIL    A,(B)           ; LOSER\r
8693         CAILE   C,(B)           ; SKIP IFF WINNER\r
8694         JRST    .+2\r
8695         MOVEM   B,5(E)          ;IN RESTORE CELLS\r
8696 \r
8697         MOVE    C,1(E)          ;GET ATOM PTR\r
8698         MOVEI   A,(C)\r
8699         MOVEI   B,0             ; FOR SPCUNP\r
8700         CAIL    A,HIBOT         ; SKIP IF IMPURE ATOM\r
8701         PUSHJ   P,SPCUNP\r
8702         HRRZ    A,BINDID+1(PVP) ;GET PROCESS NUMBER\r
8703         HRLI    A,TLOCI         ;MAKE LOC PTR\r
8704         MOVE    B,E             ;TO NEW VALUE\r
8705         ADD     B,[2,,2]\r
8706         MOVEM   A,(C)           ;CLOBBER ITS VALUE\r
8707         MOVEM   B,1(C)          ;CELL\r
8708         MOVE    D,E             ;REMEMBER LINK\r
8709         JRST    BINDLP          ;DO NEXT\r
8710 \r
8711 NONID:  CAILE   0,-4(E)\r
8712         JRST    SPECBD\r
8713         SUB      E,[4,,4]\r
8714         SKIPE   D\r
8715         HRRM    E,(D)\r
8716         SKIPN   (P)\r
8717         MOVEM   E,(P)\r
8718 \r
8719         MOVE    D,1(E)          ;GET PTR TO VECTOR\r
8720         MOVE    C,(D)           ;EXCHANGE TYPES\r
8721         EXCH    C,2(E)\r
8722         MOVEM   C,(D)\r
8723 \r
8724         MOVE    C,1(D)          ;EXCHANGE DATUMS\r
8725         EXCH    C,3(E)\r
8726         MOVEM   C,1(D)\r
8727 \r
8728         MOVEI   A,TBVL  \r
8729         HRLM    A,(E)           ;IDENTIFY BIND BLOCK\r
8730         MOVE    D,E             ;REMEMBER LINK\r
8731         JRST    BINDLP\r
8732 \r
8733 SPECBD: SKIPE   D\r
8734         HRRM    SP,(D)\r
8735         SKIPE   D,(P)\r
8736         MOVE    SP,D\r
8737         SUB     P,[2,,2]\r
8738         POPJ    P,\r
8739 \r
8740 \r
8741 ; HERE TO IMPURIFY THE ATOM\r
8742 \r
8743 SPCUNP: PUSH    TP,$TSP\r
8744         PUSH    TP,E\r
8745         PUSH    TP,$TSP\r
8746         PUSH    TP,-1(P)        ; LINK BACK IS AN SP\r
8747         PUSH    TP,$TSP\r
8748         PUSH    TP,B\r
8749         MOVE    B,C\r
8750         PUSHJ   P,IMPURIFY\r
8751         MOVE    0,-2(TP)        ; RESTORE LINK BACK POINTER\r
8752         MOVEM   0,-1(P)\r
8753         MOVE    E,-4(TP)\r
8754         MOVE    C,B\r
8755         MOVE    B,(TP)\r
8756         SUB     TP,[6,,6]\r
8757         MOVEI   0,(TB)\r
8758         POPJ    P,\r
8759 \r
8760 ; ENTRY FROM COMPILER TO SET UP A BINDING\r
8761 \r
8762 IBIND:  SUBI    E,-5(SP)        ; CHANGE TO PDL POINTER\r
8763         HRLI    E,(E)\r
8764         ADD     E,SP\r
8765         MOVEM   C,-4(E)\r
8766         MOVEM   A,-3(E)\r
8767         MOVEM   B,-2(E)\r
8768         HRLOI   A,TATOM\r
8769         MOVEM   A,-5(E)\r
8770         MOVSI   A,TLIST\r
8771         MOVEM   A,-1(E)\r
8772         MOVEM   D,(E)\r
8773         JRST    SPECB1          ; NOW BIND IT\r
8774 \r
8775 ; "FAST CALL TO SPECBIND"\r
8776 \r
8777 \r
8778 \r
8779 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.\r
8780 \r
8781 SPECBND:\r
8782         MOVE    E,TP            ; POINT TO BINDING WITH E\r
8783 SPECB1: PUSH    P,[0]           ; SLOTS OF INTEREST\r
8784         PUSH    P,[0]\r
8785         SUBM    M,-2(P)\r
8786 \r
8787 SPECB2: MOVEI   0,(TB)          ; FOR FRAME CHECK\r
8788         MOVE    A,-5(E)         ; LOOK AT FIRST THING\r
8789         CAMN    A,BNDA          ; SKIP IF LOSER\r
8790         CAILE   0,-5(E)         ; SKIP IF REAL WINNER\r
8791         JRST    SPECB3\r
8792 \r
8793         SUB     E,[5,,5]        ; POINT TO BINDING\r
8794         SKIPE   A,(P)           ; LINK?\r
8795         HRRM    E,(A)           ; YES DO IT\r
8796         SKIPN   -1(P)           ; FIRST ONE?\r
8797         MOVEM   E,-1(P)         ; THIS IS IT\r
8798 \r
8799         MOVE    A,1(E)          ; POINT TO ATOM\r
8800         MOVE    0,BINDID+1(PVP) ; QUICK CHECK\r
8801         HRLI    0,TLOCI\r
8802         CAMN    0,(A)           ; WINNERE?\r
8803         JRST    SPECB4          ; YES, GO ON\r
8804 \r
8805         PUSH    P,B             ; SAVE REST OF ACS\r
8806         PUSH    P,C\r
8807         PUSH    P,D\r
8808         MOVE    B,A             ; FOR ILOC TO WORK\r
8809         PUSHJ   P,ILOC          ; GO LOOK IT UP\r
8810         HRRZ    C,SPBASE+1(PVP)\r
8811         MOVEI   A,(TP)\r
8812         CAIL    A,(B)           ; SKIP IF LOSER\r
8813         CAILE   C,(B)           ; SKIP IF WINNER\r
8814         MOVEI   B,0             ; SAY NO BACK POINTER\r
8815         MOVE    C,1(E)          ; POINT TO ATOM\r
8816         MOVEI   A,(C)           ; PURE ATOM?\r
8817         CAIGE   A,HIBOT         ; SKIP IF OK\r
8818         JRST    .+4\r
8819         PUSH    P,-4(P)         ; MAKE HAPPINESS\r
8820         PUSHJ   P,SPCUNP        ; IMPURIFY\r
8821         POP     P,-5(P)\r
8822         MOVE    A,BINDID+1(PVP)\r
8823         HRLI    A,TLOCI\r
8824         MOVEM   A,(C)           ; STOR POINTER INDICATOR\r
8825         MOVE    A,B\r
8826         POP     P,D\r
8827         POP     P,C\r
8828         POP     P,B\r
8829         JRST    SPECB5\r
8830 \r
8831 SPECB4: MOVE    A,1(A)          ; GET LOCATIVE\r
8832 SPECB5: EXCH    A,5(E)          ; CLOBBER INTO REBIND SLOT (GET DECL)\r
8833         HLL     A,OTBSAV(TB)    ; TIME IT\r
8834         MOVSM   A,4(E)          ; SAVE DECL AND TIME\r
8835         MOVEI   A,TBIND\r
8836         HRLM    A,(E)           ; CHANGE TO A BINDING\r
8837         MOVE    A,1(E)          ; POINT TO ATOM\r
8838         MOVEM   E,(P)           ; REMEMBER THIS GUY\r
8839         ADD     E,[2,,2]        ; POINT TO VAL CELL\r
8840         MOVEM   E,1(A)          ; INTO ATOM SLOT\r
8841         SUB     E,[3,,3]        ; POINT TO NEXT ONE\r
8842         JRST    SPECB2\r
8843 \r
8844 SPECB3: SKIPE   A,(P)\r
8845         HRRM    SP,(A)          ; LINK OLD STUFF\r
8846         SKIPE   A,-1(P)         ; NEW SP?\r
8847         MOVE    SP,A\r
8848         SUB     P,[2,,2]\r
8849         INTGO                   ; IN CASE BLEW STACK\r
8850         SUBM    M,(P)\r
8851         POPJ    P,\r
8852 \f\r
8853 \r
8854 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN \r
8855 ;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.\r
8856 \r
8857 SPECSTORE:\r
8858         PUSH    P,E\r
8859         HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER\r
8860         PUSHJ   P,STLOOP\r
8861         POP     P,E\r
8862         MOVE    SP,SPSAV(TB)    ; GET NEW SP\r
8863         POPJ    P,\r
8864 \r
8865 STLOOP: PUSH    P,D\r
8866         PUSH    P,C\r
8867 \r
8868 STLOO1: CAIL    E,(SP)          ;ARE WE DONE?\r
8869         JRST    STLOO2\r
8870         HLRZ    C,(SP)          ;GET TYPE OF BIND\r
8871         CAIN    C,TUBIND\r
8872         JRST    .+3\r
8873         CAIE    C,TBIND         ;NORMAL IDENTIFIER?\r
8874         JRST    ISTORE          ;NO -- SPECIAL HACK\r
8875 \r
8876 \r
8877         MOVE    C,1(SP)         ;GET TOP ATOM\r
8878         MOVSI   0,TLOCI         ; MAYBE LOCI OR UNBOUND\r
8879         SKIPN   D,5(SP)\r
8880         MOVSI   0,TUNBOU\r
8881 \r
8882         HRR     0,BINDID+1(PVP) ;STORE SIGNATURE\r
8883         MOVEM   0,(C)           ;CLOBBER INTO ATOM\r
8884         MOVEM   D,1(C)\r
8885         SETZM   4(SP)\r
8886 SPLP:   HRRZ    SP,(SP)         ;FOLOW LINK\r
8887         JUMPN   SP,STLOO1       ;IF MORE\r
8888         SKIPE   E               ; OK IF E=0\r
8889         FATAL SP OVERPOP\r
8890 STLOO2: POP     P,C\r
8891         POP     P,D\r
8892         POPJ    P,\r
8893 \r
8894 ISTORE: CAIE    C,TBVL\r
8895         JRST    CHSKIP\r
8896         MOVE    C,1(SP)\r
8897         MOVE    D,2(SP)\r
8898         MOVEM   D,(C)\r
8899         MOVE    D,3(SP)\r
8900         MOVEM   D,1(C)\r
8901         JRST    SPLP\r
8902 \r
8903 CHSKIP: CAIN    C,TSKIP\r
8904         JRST    SPLP\r
8905         CAIE    C,TUNWIN        ; UNWIND HACK\r
8906         FATAL BAD SP\r
8907         HRRZ    C,-2(P)         ; WHERE FROM?\r
8908         CAIE    C,CHUNPC\r
8909         JRST    SPLP            ; IGNORE\r
8910         MOVEI   E,(TP)          ; FIXUP SP\r
8911         SUBI    E,(SP)\r
8912         MOVSI   E,(E)\r
8913         HLL     SP,TP\r
8914         SUB     SP,E\r
8915         POP     P,C\r
8916         POP     P,D\r
8917         AOS     (P)\r
8918         POPJ    P,\r
8919 \r
8920 ; ENTRY FOR FUNNY COMPILER UNBIND (1)\r
8921 \r
8922 SSPECS: PUSH    P,E\r
8923         MOVEI   E,(TP)\r
8924         PUSHJ   P,STLOOP\r
8925 SSPEC2: SUBI    E,(SP)          ; MAKE SP BE AOBJN\r
8926         MOVSI   E,(E)\r
8927         HLL     SP,TP\r
8928         SUB     SP,E\r
8929         POP     P,E\r
8930         POPJ    P,\r
8931 \r
8932 ; ENTRY FOR FUNNY COMPILER UNBIND (2)\r
8933 \r
8934 SSPEC1: PUSH    P,E\r
8935         SUBI    E,1             ; MAKE SURE GET CURRENT BINDING\r
8936         PUSHJ   P,STLOOP        ; UNBIND\r
8937         MOVEI   E,(TP)          ; NOW RESET SP\r
8938         JRST    SSPEC2\r
8939 \fEFINIS:        SKIPN   C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED\r
8940         JRST    FINIS\r
8941         PUSH    TP,$TATOM\r
8942         PUSH    TP,MQUOTE EVLOUT\r
8943         PUSH    TP,A                    ;SAVE EVAL RESULTS\r
8944         PUSH    TP,B\r
8945         PUSH    TP,[TINFO,,2]   ; FENCE POST\r
8946         PUSHJ   P,TBTOTP\r
8947         PUSH    TP,D\r
8948         PUSHJ   P,MAKINF        ; MAKE ARG BLOCK INFO\r
8949         PUSH    TP,A\r
8950         MOVEI   B,-6(TP)\r
8951         HRLI    B,-4            ; AOBJN TO ARGS BLOCK\r
8952         PUSH    TP,B\r
8953         PUSH    TP,1STEPR(PVP)\r
8954         PUSH    TP,1STEPR+1(PVP)        ; PROCESS DOING THE 1STEPPING\r
8955         MCALL   2,RESUME\r
8956         MOVE    A,-3(TP)        ; GET BACK EVAL VALUE\r
8957         MOVE    B,-2(TP)\r
8958         JRST    FINIS\r
8959 \r
8960 1STEPI: PUSH    TP,$TATOM\r
8961         PUSH    TP,MQUOTE EVLIN\r
8962         PUSH    TP,$TAB         ; PUSH EVALS ARGGS\r
8963         PUSH    TP,AB\r
8964         PUSHJ   P,MAKINF        ; TURN INTO ARGS BLOCK\r
8965         MOVEM   A,-1(TP)        ; AND CLOBBER\r
8966         PUSH    TP,[TINFO,,2]   ; FENCE POST 2D TUPLE\r
8967         PUSHJ   P,TBTOTP\r
8968         PUSH    TP,D\r
8969         PUSHJ   P,MAKINF        ; TURN IT INTO ARGS BLOCK\r
8970         PUSH    TP,A\r
8971         MOVEI   B,-6(TP)        ; SETUP TUPLE\r
8972         HRLI    B,-4\r
8973         PUSH    TP,B\r
8974         PUSH    TP,1STEPR(PVP)\r
8975         PUSH    TP,1STEPR+1(PVP)\r
8976         MCALL   2,RESUME        ; START UP 1STEPERR\r
8977         SUB     TP,[6,,6]       ; REMOVE CRUD\r
8978         GETYP   A,A             ; GET 1STEPPERS TYPE\r
8979         CAIE    A,TDISMI                ; IF DISMISS, STOP 1 STEPPING\r
8980         JRST    EVALON\r
8981 \r
8982 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN\r
8983 \r
8984         MOVE    D,PVP\r
8985         ADD     D,[1STEPR,,1STEPR]      ; POINT TO 1 STEP SLOT\r
8986         PUSH    TP,$TSP         ; SAVE CURRENT SP\r
8987         PUSH    TP,SP\r
8988         PUSH    TP,BNDV\r
8989         PUSH    TP,D            ; BIND IT\r
8990         PUSH    TP,$TPVP\r
8991         PUSH    TP,[0]          ; NO 1 STEPPER UNTIL POPJ\r
8992         PUSHJ   P,SPECBIND\r
8993 \r
8994 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL\r
8995 \r
8996         MOVEI   A,0\r
8997 EFARGL: JUMPGE  AB,EFCALL\r
8998         PUSH    TP,(AB)\r
8999         PUSH    TP,1(AB)\r
9000         ADD     AB,[2,,2]\r
9001         AOJA    A,EFARGL\r
9002 \r
9003 EFCALL: ACALL   A,EVAL          ; NOW DO THE EVAL\r
9004         MOVE    C,(TP)          ; PRE-UNBIND\r
9005         MOVEM   C,1STEPR+1(PVP)\r
9006         MOVE    SP,-4(TP)       ; AVOID THE UNBIND\r
9007         SUB     TP,[6,,6]       ; AND FLUSH LOSERS\r
9008         JRST    EFINIS          ; AND TRY TO FINISH UP\r
9009 \r
9010 MAKINF: HLRZ    A,OTBSAV(TB)    ; TIME IT\r
9011         HRLI    A,TARGS\r
9012         POPJ    P,\r
9013 \r
9014 \r
9015 TBTOTP: MOVEI   D,(TB)          ; COMPUTE REL DIST FROM TP TO TB\r
9016         SUBI    D,(TP)\r
9017         POPJ    P,\r
9018 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE\r
9019 ; D/ LENGTH OF THE TUPLE IN WORDS\r
9020 \r
9021 MAKTU2: MOVE    D,-1(P)         ; GET LENGTH\r
9022 MAKTUP: HRLI    D,TINFO         ; FIRST WORD OF FENCE POST\r
9023         PUSH    TP,D\r
9024         HRROI   B,(TP)          ; TOP OF TUPLE\r
9025         SUBI    B,(D)\r
9026         TLC     B,-1(D)         ; AOBJN IT\r
9027         PUSHJ   P,TBTOTP\r
9028         PUSH    TP,D\r
9029         HLRZ    A,OTBSAV(TB)    ; TIME IT\r
9030         HRLI    A,TARGS\r
9031         POPJ    P,\r
9032 \r
9033 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)\r
9034 \r
9035 TPALOC: HRLI    A,(A)\r
9036         ADD     TP,A\r
9037         SKIPL   TP\r
9038         PUSHJ   P,TPOVFL        ; IN CASE IT LOST\r
9039         INTGO                   ; TAKE THE GC IF NEC\r
9040         PUSH    P,A\r
9041         HRRI    A,2(TP)\r
9042         SUB     A,(P)\r
9043         SETZM   -1(A)   \r
9044         HRLI    A,-1(A)\r
9045         BLT     A,(TP)\r
9046         SUB     P,[1,,1]\r
9047         POPJ    P,\r
9048 \r
9049 NTPALO: PUSH    TP,[0]\r
9050         SOJG    0,.-1\r
9051         POPJ    P,\r
9052 \r
9053 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.\r
9054 \r
9055 MFUNCTION VALUE,SUBR\r
9056         JSP     E,CHKAT\r
9057         PUSHJ   P,IDVAL\r
9058         JRST    FINIS\r
9059 \r
9060 IDVAL:  PUSHJ   P,IDVAL1\r
9061         CAMN    A,$TUNBOU\r
9062         JRST    UNBOU\r
9063         POPJ    P,\r
9064 \r
9065 IDVAL1: PUSH    TP,A\r
9066         PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE\r
9067         PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER\r
9068         CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED\r
9069         JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN\r
9070         POP     TP,B            ;GET ARG BACK\r
9071         POP     TP,A\r
9072         JRST    IGVAL\r
9073 RIDVAL: SUB     TP,[2,,2]\r
9074         POPJ    P,\r
9075 \r
9076 ;GETS THE LOCAL VALUE OF AN IDENTIFIER\r
9077 \r
9078 MFUNCTION LVAL,SUBR\r
9079         JSP     E,CHKAT\r
9080         PUSHJ   P,AILVAL\r
9081         CAME    A,$TUNBOUND\r
9082         JRST    FINIS\r
9083         JUMPN   B,UNAS\r
9084         JRST    UNBOU\r
9085 \r
9086 ; MAKE AN ATOM UNASSIGNED\r
9087 \r
9088 MFUNCTION UNASSIGN,SUBR\r
9089         JSP     E,CHKAT         ; GET ATOM ARG\r
9090         PUSHJ   P,AILOC\r
9091 UNASIT: CAMN    A,$TUNBOU       ; IF UNBOUND\r
9092         JRST    RETATM\r
9093         MOVSI   A,TUNBOU\r
9094         MOVEM   A,(B)\r
9095         SETOM   1(B)            ; MAKE SURE\r
9096 RETATM: MOVE    B,1(AB)\r
9097         MOVE    A,(AB)\r
9098         JRST    FINIS\r
9099 \r
9100 ; UNASSIGN GLOBALLY\r
9101 \r
9102 MFUNCTION GUNASSIGN,SUBR\r
9103         JSP     E,CHKAT2\r
9104         PUSHJ   P,IGLOC\r
9105         CAMN    A,$TUNBOU\r
9106         JRST    RETATM\r
9107         MOVE    B,1(AB)         ; ATOM BACK\r
9108         MOVEI   0,(B)\r
9109         CAIL    0,HIBOT         ; SKIP IF IMPURE\r
9110         PUSHJ   P,IMPURIFY      ; YES, MAKE IT IMPURE\r
9111         PUSHJ   P,IGLOC         ; RESTORE LOCATIVE\r
9112         HRRZ    0,-2(B)         ; SEE IF MANIFEST\r
9113         GETYP   A,(B)           ; AND CURRENT TYPE\r
9114         CAIN    0,-1\r
9115         CAIN    A,TUNBOU\r
9116         JRST    UNASIT\r
9117         SKIPE   IGDECL\r
9118         JRST    UNASIT\r
9119         MOVE    D,B\r
9120         JRST    MANILO\r
9121 \f\r
9122 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.\r
9123 \r
9124 MFUNCTION LLOC,SUBR\r
9125         JSP     E,CHKAT\r
9126         PUSHJ   P,AILOC\r
9127         CAMN    A,$TUNBOUND\r
9128         JRST    UNBOU\r
9129         MOVSI   A,TLOCD\r
9130         HRR     A,2(B)\r
9131         JRST    FINIS\r
9132 \r
9133 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND\r
9134 \r
9135 MFUNCTION BOUND,SUBR,[BOUND?]\r
9136         JSP     E,CHKAT\r
9137         PUSHJ   P,AILVAL\r
9138         CAMN    A,$TUNBOUND\r
9139         JUMPE   B,IFALSE\r
9140         JRST    TRUTH\r
9141 \r
9142 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED\r
9143 \r
9144 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]\r
9145         JSP     E,CHKAT\r
9146         PUSHJ   P,AILVAL\r
9147         CAME    A,$TUNBOUND\r
9148         JRST    TRUTH\r
9149 ;       JUMPE   B,UNBOU\r
9150         JRST    IFALSE\r
9151 \r
9152 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER\r
9153 \r
9154 MFUNCTION GVAL,SUBR\r
9155         JSP     E,CHKAT2\r
9156         PUSHJ   P,IGVAL\r
9157         CAMN    A,$TUNBOUND\r
9158         JRST    UNAS\r
9159         JRST    FINIS\r
9160 \r
9161 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER\r
9162 \r
9163 MFUNCTION GLOC,SUBR\r
9164 \r
9165         JUMPGE  AB,TFA\r
9166         CAMGE   AB,[-5,,]\r
9167         JRST    TMA\r
9168         JSP     E,CHKAT1\r
9169         MOVEI   E,IGLOC\r
9170         CAML    AB,[-2,,]\r
9171         JRST    .+4\r
9172         GETYP   0,2(AB)\r
9173         CAIE    0,TFALSE\r
9174         MOVEI   E,IIGLOC\r
9175         PUSHJ   P,(E)\r
9176         CAMN    A,$TUNBOUND\r
9177         JRST    UNAS\r
9178         MOVSI   A,TLOCD\r
9179         MOVE    C,1(AB)         ; GE ATOM\r
9180         MOVEI   0,(C)\r
9181         CAIGE   0,HIBOT         ; SKIP IF PURE ATOM\r
9182         JRST    FINIS\r
9183 \r
9184 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT\r
9185 \r
9186         MOVE    B,C             ; ATOM TO B\r
9187         PUSHJ   P,IMPURIFY\r
9188         JRST    GLOC            ; AND TRY AGAIN\r
9189 \r
9190 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED\r
9191 \r
9192 MFUNCTION GASSIG,SUBR,[GASSIGNED?]\r
9193         JSP     E,CHKAT2\r
9194         PUSHJ   P,IGVAL\r
9195         CAMN    A,$TUNBOUND\r
9196         JRST    IFALSE\r
9197         JRST    TRUTH\r
9198 \r
9199 ; TEST FOR GLOBALLY BOUND\r
9200 \r
9201 MFUNCTION GBOUND,SUBR,[GBOUND?]\r
9202 \r
9203         JSP     E,CHKAT2\r
9204         PUSHJ   P,IGLOC\r
9205         JUMPE   B,IFALSE\r
9206         JRST    TRUTH\r
9207 \r
9208 \f\r
9209 \r
9210 CHKAT2: ENTRY   1\r
9211 CHKAT1: GETYP   A,(AB)\r
9212         MOVSI   A,(A)\r
9213         CAME    A,$TATOM\r
9214         JRST    NONATM\r
9215         MOVE    B,1(AB)\r
9216         JRST    2,(E)\r
9217 \r
9218 CHKAT:  HLRE    A,AB            ; - # OF ARGS\r
9219         ASH     A,-1            ; TO ACTUAL WORDS\r
9220         JUMPGE  AB,TFA\r
9221         MOVE    C,SP            ; FOR BINDING LOOKUPS\r
9222         AOJE    A,CHKAT1        ; ONLY ONE ARG, NO ENVIRONMENT\r
9223         AOJL    A,TMA           ; TOO MANY\r
9224         GETYP   A,2(AB)         ; MAKE SURE OF TENV OR TFRAME\r
9225         CAIE    A,TFRAME\r
9226         CAIN    A,TENV\r
9227         JRST    CHKAT3\r
9228         CAIN    A,TACT          ; FOR PFISTERS LOSSAGE\r
9229         JRST    CHKAT3\r
9230         CAIE    A,TPVP          ; OR PROCESS\r
9231         JRST    WTYP2\r
9232         MOVE    B,3(AB)         ; GET PROCESS\r
9233         MOVE    C,SP            ; IN CASE ITS ME\r
9234         CAME    B,PVP           ; SKIP IF DIFFERENT\r
9235         MOVE    C,SPSTO+1(B)    ; GET ITS SP\r
9236         JRST    CHKAT1\r
9237 CHKAT3: MOVEI   B,2(AB)         ; POINT TO FRAME POINTER\r
9238         PUSHJ   P,CHFRM         ; VALIDITY CHECK\r
9239         MOVE    B,3(AB)         ; GET TB FROM FRAME\r
9240         MOVE    C,SPSAV(B)      ; GET ENVIRONMENT POINTER\r
9241         JRST    CHKAT1\r
9242 \r
9243 \f\r
9244 \r
9245 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT\r
9246 ;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,\r
9247 ; IT IS CALLED BY PUSHJ P,ILOC.\r
9248 \r
9249 ILOC:   MOVE    C,SP            ; SETUP SEARCH START\r
9250 AILOC:  MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL\r
9251         PUSH    P,E\r
9252         PUSH    P,D\r
9253         MOVEI   E,0             ; FLAG TO CLOBBER ATOM\r
9254         JUMPE   B,SCHSP         ; IF LOOKING FOR SLOT, SEARCH NOW\r
9255         CAME    C,SP            ; ENVIRONMENT CHANGE?\r
9256         JRST    SCHSP           ; YES, MUST SEARCH\r
9257         HRR     A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS\r
9258         CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?\r
9259         JRST    SCHLP           ;NO -- SEARCH THE LOCAL BINDINGS\r
9260         MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER\r
9261         MOVE    C,PVP\r
9262 ILCPJ:  MOVE    E,SPCCHK\r
9263         TRNN    E,1             ; SKIP IF DOING SPEC UNSPEC CHECK\r
9264         JRST    ILOCPJ\r
9265         HLRZ    E,-2(B)\r
9266         CAIE    E,TUBIND\r
9267         JRST    ILOCPJ\r
9268         CAMGE   B,CURFCN+1(PVP)\r
9269         JRST    UNPJ11\r
9270         MOVEI   D,-2(B)\r
9271         CAIG    D,(SP)\r
9272         CAMGE   B,SPBASE+1(PVP)\r
9273         JRST    UNPJ11\r
9274 ILOCPJ: POP     P,D\r
9275         POP     P,E\r
9276         POPJ    P,              ;FROM THE VALUE CELL\r
9277 \r
9278 SCHLP:  MOVEI   D,(B)\r
9279         CAIL    D,HIBOT         ; SKIP IF IMPURE ATOM\r
9280 SCHSP:  MOVEI   E,1             ; DONT STORE LOCATIVE\r
9281 \r
9282         PUSH    P,E             ; PUSH SWITCH\r
9283         MOVE    E,PVP           ; GET PROC\r
9284 SCHLP1: JUMPE   C,UNPJ          ;IF NO MORE -- LOSE\r
9285         CAMN    B,1(C)          ;ARE WE POINTING AT THE WINNER?\r
9286         JRST    SCHFND          ;YES\r
9287         GETYP   D,(C)           ; CHECK SKIP\r
9288         CAIE    D,TSKIP\r
9289         JRST    SCHLP2\r
9290         PUSH    P,B             ; CHECK DETOUR\r
9291         MOVEI   B,2(C)\r
9292         PUSHJ   P,CHFRAM        ; NON-FATAL FRAME CHECKER\r
9293         HRRZ    E,2(C)          ; CONS UP PROCESS\r
9294         SUBI    E,PVLNT*2+1\r
9295         HRLI    E,-2*PVLNT\r
9296         JUMPE   B,SCHLP3        ; LOSER, FIX IT\r
9297         POP     P,B\r
9298         MOVEI   C,1(C)          ; FOLLOW LOOKUP CHAIN\r
9299 SCHLP2: HRRZ    C,(C)           ;FOLLOW LINK\r
9300         JRST    SCHLP1\r
9301 \r
9302 SCHLP3: POP     P,B\r
9303         MOVEI   C,(SP)          ; *** NDR'S BUG ***\r
9304         CAME    E,PVP           ; USE IF CURRENT PROCESS\r
9305         HRRZ    C,SPSTO+1(E)    ; USE CURRENT SP FOR PROC\r
9306         JRST    SCHLP1\r
9307         \r
9308 SCHFND: EXCH    B,C             ;SAVE THE ATOM PTR IN C\r
9309         MOVEI   B,2(B)          ;MAKE UP THE LOCATIVE\r
9310         SUB     B,TPBASE+1(E)\r
9311         HRLI    B,(B)\r
9312         ADD     B,TPBASE+1(E)\r
9313         EXCH    C,E             ; RET PROCESS IN C\r
9314         POP     P,D             ; RESTORE SWITCH\r
9315 \r
9316         JUMPN   D,ILOCPJ                ; DONT CLOBBER  ATOM\r
9317         MOVEM   A,(E)           ;CLOBBER IT AWAY INTO THE\r
9318         MOVEM   B,1(E)          ;ATOM'S VALUE CELL\r
9319         JRST    ILCPJ\r
9320 \r
9321 UNPJ:   SUB     P,[1,,1]        ; FLUSH CRUFT\r
9322 UNPJ1:  MOVE    C,E             ; RET PROCESS ANYWAY\r
9323 UNPJ11: POP     P,D\r
9324         POP     P,E\r
9325 UNPOPJ: MOVSI   A,TUNBOUND\r
9326         MOVEI   B,0\r
9327         POPJ    P,\r
9328 \r
9329 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE \r
9330 ;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY\r
9331 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.\r
9332 \r
9333 \r
9334 IGLOC:  MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO\r
9335         CAME    A,(B)           ;A PROCESS #0 VALUE?\r
9336         JRST    SCHGSP          ;NO -- SEARCH\r
9337         MOVE    B,1(B)          ;YES -- GET VALUE CELL\r
9338         POPJ    P,\r
9339 \r
9340 SCHGSP: MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR\r
9341 \r
9342 SCHG1:  JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE\r
9343         CAMN    B,1(D)          ;ARE WE FOUND?\r
9344         JRST    GLOCFOUND       ;YES\r
9345         ADD     D,[4,,4]        ;NO -- TRY NEXT\r
9346         JRST    SCHG1\r
9347 \r
9348 GLOCFOUND:\r
9349         EXCH    B,D             ;SAVE ATOM PTR\r
9350         ADD     B,[2,,2]        ;MAKE LOCATIVE\r
9351         MOVEI   0,(D)\r
9352         CAIL    0,HIBOT\r
9353         POPJ    P,\r
9354         MOVEM   A,(D)           ;CLOBBER IT AWAY\r
9355         MOVEM   B,1(D)\r
9356         POPJ    P,\r
9357 \r
9358 IIGLOC: PUSH    TP,$TATOM\r
9359         PUSH    TP,B\r
9360         PUSHJ   P,IGLOC\r
9361         MOVE    C,(TP)\r
9362         SUB     TP,[2,,2]\r
9363         GETYP   0,A\r
9364         CAIE    0,TUNBOU\r
9365         POPJ    P,\r
9366         PUSH    TP,$TATOM\r
9367         PUSH    TP,C\r
9368         PUSHJ   P,BSETG         ; MAKE A SLOT\r
9369         SETOM   1(B)            ; UNBOUNDIFY IT\r
9370         MOVSI   A,TLOCD\r
9371         MOVSI   0,TUNBOU\r
9372         MOVEM   0,(B)\r
9373         SUB     TP,[2,,2]\r
9374         POPJ    P,\r
9375         \r
9376 \f\r
9377 \r
9378 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B\r
9379 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF\r
9380 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL\r
9381 \r
9382 AILVAL:\r
9383         PUSHJ   P,AILOC ; USE SUPPLIED SP\r
9384         JRST    CHVAL\r
9385 ILVAL:\r
9386         PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE\r
9387 CHVAL:  CAMN    A,$TUNBOUND     ;BOUND\r
9388         POPJ    P,              ;NO -- RETURN\r
9389         MOVSI   A,TLOCD         ; GET GOOD TYPE\r
9390         HRR     A,2(B)          ; SHOULD BE TIME OR 0\r
9391         PUSH    P,0\r
9392         PUSHJ   P,RMONC0        ; CHECK READ MONITOR\r
9393         POP     P,0\r
9394         MOVE    A,(B)           ;GET THE TYPE OF THE VALUE\r
9395         MOVE    B,1(B)          ;GET DATUM\r
9396         POPJ    P,\r
9397 \r
9398 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES\r
9399 \r
9400 IGVAL:  PUSHJ   P,IGLOC\r
9401         JRST    CHVAL\r
9402 \r
9403 \r
9404 \f\r
9405 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET\r
9406 \r
9407 CILVAL: MOVE    0,BINDID+1(PVP) ; CURRENT BIND\r
9408         HRLI    0,TLOCI\r
9409         CAME    0,(B)           ; HURRAY FOR SPEED\r
9410         JRST    CILVA1          ; TOO BAD\r
9411         MOVE    C,1(B)          ; POINTER\r
9412         MOVE    A,(C)           ; VAL TYPE\r
9413         TLNE    A,.RDMON        ; MONITORS?\r
9414         JRST    CILVA1\r
9415         GETYP   0,A\r
9416         CAIN    0,TUNBOU\r
9417         JRST    CUNAS           ; COMPILER ERROR\r
9418         MOVE    B,1(C)          ; GOT VAL\r
9419         MOVE    0,SPCCHK\r
9420         TRNN    0,1\r
9421         POPJ    P,\r
9422         HLRZ    0,-2(C)         ; SPECIAL CHECK\r
9423         CAIE    0,TUBIND\r
9424         POPJ    P,              ; RETURN\r
9425         CAMGE   C,CURFCN+1(PVP)\r
9426         JRST    CUNAS\r
9427         POPJ    P,\r
9428 \r
9429 CUNAS:\r
9430 CILVA1: SUBM    M,(P)           ; FIX (P)\r
9431         PUSH    TP,$TATOM       ; SAVE ATOM\r
9432         PUSH    TP,B\r
9433         MCALL   1,LVAL          ; GET ERROR/MONITOR\r
9434 MPOPJ:\r
9435 POPJM:  SUBM    M,(P)           ; REPAIR DAMAGE\r
9436         POPJ    P,\r
9437 \r
9438 ; COMPILERS INTERFACE TO SET C/ ATOM  A,B/ NEW VALUE\r
9439 \r
9440 CISET:  MOVE    0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT\r
9441         HRLI    0,TLOCI\r
9442         CAME    0,(C)           ; CAN WE WIN?\r
9443         JRST    CISET1          ; NO, MORE HAIR\r
9444         MOVE    D,1(C)          ; POINT TO SLOT\r
9445         HLLZ    0,(D)           ; MON CHECK\r
9446 CISET3: TLNE    0,.WRMON\r
9447         JRST    CISET4          ; YES, LOSE\r
9448         TLZ     0,TYPMSK\r
9449         IOR     A,0             ; LEAVE MONITOR ON\r
9450         MOVE    0,SPCCHK\r
9451         TRNE    0,1\r
9452         JRST    CISET5          ; SPEC/UNSPEC CHECK\r
9453 CISET6: MOVEM   A,(D)           ; STORE\r
9454         MOVEM   B,1(D)\r
9455         POPJ    P,\r
9456 \r
9457 CISET5: HLRZ    0,-2(D)\r
9458         CAIE    0,TUBIND\r
9459         JRST    CISET6\r
9460         CAMGE   D,CURFCN+1(PVP)\r
9461         JRST    CISET4\r
9462         JRST    CISET6\r
9463         \r
9464 CISET1: SUBM    M,(P)           ; FIX ADDR\r
9465         PUSH    TP,$TATOM       ; SAVE ATOM\r
9466         PUSH    TP,C\r
9467         PUSH    TP,A\r
9468         PUSH    TP,B\r
9469         MOVE    B,C             ; GET ATOM\r
9470         PUSHJ   P,ILOC          ; SEARCH\r
9471         MOVE    D,B             ; POSSIBLE POINTER\r
9472         GETYP   E,A\r
9473         MOVE    0,A\r
9474         MOVE    A,-1(TP)        ; VAL BACK\r
9475         MOVE    B,(TP)\r
9476         CAIE    E,TUNBOU        ; SKIP IF WIN\r
9477         JRST    CISET2          ; GO CLOBBER IT IN\r
9478         MCALL   2,SET\r
9479         JRST    POPJM\r
9480         \r
9481 CISET2: MOVE    C,-2(TP)        ; ATOM BACK\r
9482         SUBM    M,(P)           ; RESET (P)\r
9483         SUB     TP,[4,,4]\r
9484         JRST    CISET3\r
9485 \r
9486 ; HERE TO DO A MONITORED SET\r
9487 \r
9488 CISET4: SUBM    M,(P)           ; AGAIN FIX (P)\r
9489         PUSH    TP,$TATOM\r
9490         PUSH    TP,C\r
9491         PUSH    TP,A\r
9492         PUSH    TP,B\r
9493         MCALL   2,SET\r
9494         JRST    POPJM\r
9495 \r
9496 ; COMPILER LLOC\r
9497 \r
9498 CLLOC:  MOVE    0,BINDID+1(PVP) ; GET CURRENT LOCATIVE\r
9499         HRLI    0,TLOCI\r
9500         CAME    0,(B)           ; WIN?\r
9501         JRST    CLLOC1\r
9502         MOVE    B,1(B)\r
9503         MOVE    0,SPCCHK\r
9504         TRNE    0,1             ; SKIP IF NOT CHECKING\r
9505         JRST    CLLOC9\r
9506 CLLOC3: MOVSI   A,TLOCD\r
9507         HRR     A,2(B)          ; GET BIND TIME\r
9508         POPJ    P,\r
9509 \r
9510 CLLOC1: SUBM    M,(P)\r
9511         PUSH    TP,$TATOM\r
9512         PUSH    TP,B\r
9513         PUSHJ   P,ILOC          ; LOOK IT UP\r
9514         JUMPE   B,CLLOC2\r
9515         SUB     TP,[2,,2]\r
9516 CLLOC4: SUBM    M,(P)\r
9517         JRST    CLLOC3\r
9518 \r
9519 CLLOC2: MCALL   1,LLOC\r
9520         JRST    CLLOC4\r
9521 \r
9522 CLLOC9: HLRZ    0,-2(B)\r
9523         CAIE    0,TUBIND\r
9524         JRST    CLLOC3\r
9525         CAMGE   B,CURFCN+1(PVP)\r
9526         JRST    CLLOC2\r
9527         JRST    CLLOC3\r
9528 \r
9529 ; COMPILER BOUND?\r
9530 \r
9531 CBOUND: SUBM    M,(P)\r
9532         PUSHJ   P,ILOC\r
9533         JUMPE   B,PJFALS        ; IF UNBOUND RET FALSE AND NO SSKIP\r
9534 PJT1:   SOS     (P)\r
9535         MOVSI   A,TATOM\r
9536         MOVE    B,MQUOTE T\r
9537         JRST    POPJM\r
9538 \r
9539 PJFALS: MOVEI   B,0\r
9540         MOVSI   A,TFALSE\r
9541         JRST    POPJM\r
9542 \r
9543 ; COMPILER ASSIGNED?\r
9544 \r
9545 CASSQ:  SUBM    M,(P)\r
9546         PUSHJ   P,ILOC\r
9547         JUMPE   B,PJFALS\r
9548         GETYP   0,(B)\r
9549         CAIE    0,TUNBOU\r
9550         JRST    PJT1\r
9551         JRST    PJFALS\r
9552 \f\r
9553 \r
9554 ; COMPILER GVAL B/ ATOM\r
9555 \r
9556 CIGVAL: MOVE    0,(B)           ; GLOBAL VAL HERE?\r
9557         CAME    0,$TLOCI        ; TIME=0 ,TYPE=TLOCI => GLOB VAL\r
9558         JRST    CIGVA1          ; NO, GO LOOK\r
9559         MOVE    C,1(B)          ; POINT TO SLOT\r
9560         MOVE    A,(C)           ; GET TYPE\r
9561         TLNE    A,.RDMON\r
9562         JRST    CIGVA1\r
9563         GETYP   0,A             ; CHECK FOR UNBOUND\r
9564         CAIN    0,TUNBOU        ; SKIP IF WINNER\r
9565         JRST    CGUNAS\r
9566         MOVE    B,1(C)\r
9567         POPJ    P,\r
9568 \r
9569 CGUNAS:\r
9570 CIGVA1: SUBM    M,(P)\r
9571         PUSH    TP,$TATOM\r
9572         PUSH    TP,B\r
9573         .MCALL  1,GVAL          ; GET ERROR/MONITOR\r
9574         JRST    POPJM\r
9575 \r
9576 ; COMPILER INTERFACET TO SETG\r
9577 \r
9578 CSETG:  MOVE    0,(C)           ; GET V CELL\r
9579         CAME    0,$TLOCI        ; SKIP IF FAST\r
9580         JRST    CSETG1\r
9581         HRRZ    D,1(C)          ; POINT TO SLOT\r
9582         MOVE    0,(D)           ; OLD VAL\r
9583 CSETG3: CAIG    D,HIBOT         ; SKIP IF PURE ATOM\r
9584         TLNE    0,.WRMON        ; MONITOR\r
9585         JRST    CSETG2\r
9586         MOVEM   A,(D)\r
9587         MOVEM   B,1(D)\r
9588         POPJ    P,\r
9589 \r
9590 CSETG1: SUBM    M,(P)           ; FIX UP P\r
9591         PUSH    TP,$TATOM\r
9592         PUSH    TP,C\r
9593         PUSH    TP,A\r
9594         PUSH    TP,B\r
9595         MOVE    B,C\r
9596         PUSHJ   P,IGLOC         ; FIND GLOB LOCATIVE\r
9597         GETYP   E,A\r
9598         MOVE    0,A\r
9599         MOVEI   D,(B)           ; SETUP TO RESTORE NEW VAL\r
9600         MOVE    A,-1(TP)\r
9601         MOVE    B,(TP)\r
9602         CAIE    E,TUNBOU\r
9603         JRST    CSETG4\r
9604         MCALL   2,SETG\r
9605         JRST    POPJM\r
9606 \r
9607 CSETG4: MOVE    C,-2(TP)        ; ATOM BACK\r
9608         SUBM    M,(P)           ; RESET (P)\r
9609         SUB     TP,[4,,4]\r
9610         JRST    CSETG3\r
9611 \r
9612 CSETG2: SUBM    M,(P)\r
9613         PUSH    TP,$TATOM               ; CAUSE A SETG MONITOR\r
9614         PUSH    TP,C\r
9615         PUSH    TP,A\r
9616         PUSH    TP,B\r
9617         MCALL   2,SETG\r
9618         JRST    POPJM\r
9619 \r
9620 ; COMPILER GLOC\r
9621 \r
9622 CGLOC:  MOVE    0,(B)           ; GET CURRENT GUY\r
9623         CAME    0,$TLOCI        ; WIN?\r
9624         JRST    CGLOC1          ; NOPE\r
9625         HRRZ    D,1(B)          ; POINT TO SLOT\r
9626         CAILE   D,HIBOT         ; PURE?\r
9627         JRST    CGLOC1\r
9628         MOVE    A,$TLOCD\r
9629         MOVE    B,1(B)\r
9630         POPJ    P,\r
9631 \r
9632 CGLOC1: SUBM    M,(P)\r
9633         PUSH    TP,$TATOM\r
9634         PUSH    TP,B\r
9635         MCALL   1,GLOC\r
9636         JRST    POPJM\r
9637 \r
9638 ; COMPILERS GASSIGNED?\r
9639 \r
9640 CGASSQ: MOVE    0,(B)\r
9641         SUBM    M,(P)\r
9642         CAMN    0,$TLOCD\r
9643         JRST    PJT1\r
9644         PUSHJ   P,IGLOC\r
9645         JUMPE   B,PJFALS\r
9646         GETYP   0,(B)\r
9647         CAIE    0,TUNBOU\r
9648         JRST    PJT1\r
9649         JRST    PJFALS\r
9650 \r
9651 ; COMPILERS GBOUND?\r
9652 \r
9653 CGBOUN: MOVE    0,(B)\r
9654         SUBM    M,(P)\r
9655         CAMN    0,$TLOCD\r
9656         JRST    PJT1\r
9657         PUSHJ   P,IGLOC\r
9658         JUMPE   B,PJFALS\r
9659         JRST    PJT1\r
9660 \f\r
9661 \r
9662 MFUNCTION REP,FSUBR,[REPEAT]\r
9663         JRST    PROG\r
9664 MFUNCTION PROG,FSUBR\r
9665         ENTRY   1\r
9666         GETYP   A,(AB)          ;GET ARG TYPE\r
9667         CAIE    A,TLIST         ;IS IT A LIST?\r
9668         JRST    WRONGT          ;WRONG TYPE\r
9669         SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT\r
9670         JRST    TFA             ;TOO FEW ARGS\r
9671         SETZB   E,D             ; INIT HEWITT ATOM AND DECL\r
9672         PUSHJ   P,CARATC        ; IS 1ST THING AN ATOM\r
9673         JFCL\r
9674         PUSHJ   P,RSATY1        ; CDR AND GET TYPE\r
9675         CAIE    0,TLIST         ; MUST BE LIST\r
9676         JRST    MPD.13\r
9677         MOVE    B,1(C)          ; GET ARG LIST\r
9678         PUSH    TP,$TLIST\r
9679         PUSH    TP,C\r
9680         PUSHJ   P,RSATYP\r
9681         CAIE    0,TDECL\r
9682         JRST    NOP.DC          ; JUMP IF NO DCL\r
9683         MOVE    D,1(C)\r
9684         MOVEM   C,(TP)\r
9685         PUSHJ   P,RSATYP        ; CDR ON\r
9686 NOP.DC: PUSH    TP,$TLIST       \r
9687         PUSH    TP,B            ; AND ARG LIST\r
9688         PUSHJ   P,PRGBND        ; BIND AUX VARS\r
9689         MOVE    E,MQUOTE LPROG,[LPROG ]INTRUP\r
9690         PUSHJ   P,MAKACT        ; MAKE ACTIVATION\r
9691         PUSHJ   P,PSHBND        ; BIND AND CHECK\r
9692         PUSHJ   P,SPECBI        ; NAD BIND IT\r
9693 \r
9694 ; HERE TO RUN PROGS FUNCTIONS ETC.\r
9695 \r
9696 DOPROG: MOVEI   A,REPROG\r
9697         HRLI    A,TDCLI         ; FLAG AS FUNNY\r
9698         MOVEM   A,(TB)          ; WHERE TO AGAIN TO\r
9699         MOVE    C,1(TB)\r
9700         MOVEM   C,3(TB)         ; RESTART POINTER\r
9701         JRST    .+2             ; START BY SKIPPING DECL\r
9702 \r
9703 DOPRG1: PUSHJ   P,FASTEV\r
9704         HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY\r
9705 DOPRG2: MOVEM   C,1(TB)\r
9706         JUMPN   C,DOPRG1\r
9707 ENDPROG:\r
9708         HRRZ    C,FSAV(TB)\r
9709         CAIN    C,REP\r
9710 REPROG: SKIPN   C,@3(TB)\r
9711         JRST    PFINIS\r
9712         HRRZM   C,1(TB)\r
9713         INTGO\r
9714         MOVE    C,1(TB)\r
9715         JRST    DOPRG1\r
9716 \r
9717 \r
9718 PFINIS: GETYP   0,(TB)\r
9719         CAIE    0,TDCLI         ; DECL'D ?\r
9720         JRST    PFINI1\r
9721         HRRZ    0,(TB)          ; SEE IF RSUBR\r
9722         JUMPE   0,RSBVCK        ; CHECK RSUBR VALUE\r
9723         HRRZ    C,3(TB)         ; GET START OF FCN\r
9724         GETYP   0,(C)           ; CHECK FOR DECL\r
9725         CAIE    0,TDECL\r
9726         JRST    PFINI1          ; NO, JUST RETURN\r
9727         MOVE    E,MQUOTE VALUE\r
9728         PUSHJ   P,PSHBND        ; BUILD FAKE BINDING\r
9729         MOVE    C,1(C)          ; GET DECL LIST\r
9730         MOVE    E,TP\r
9731         PUSHJ   P,CHKDCL        ; AND CHECK IT\r
9732         MOVE    A,-3(TP)                ; GET VAL BAKC\r
9733         MOVE    B,-2(TP)\r
9734         SUB     TP,[6,,6]\r
9735 \r
9736 PFINI1: HRRZ    C,FSAV(TB)\r
9737         CAIE    C,EVAL\r
9738         JRST    FINIS\r
9739         JRST    EFINIS\r
9740 \r
9741 RSATYP: HRRZ    C,(C)\r
9742 RSATY1: JUMPE   C,TFA\r
9743         GETYP   0,(C)\r
9744         POPJ    P,\r
9745 \r
9746 ; HERE TO CHECK RSUBR VALUE\r
9747 \r
9748 RSBVCK: PUSH    TP,A\r
9749         PUSH    TP,B\r
9750         MOVE    C,A\r
9751         MOVE    D,B\r
9752         MOVE    A,1(TB)         ; GET DECL\r
9753         MOVE    B,1(A)\r
9754         HLLZ    A,(A)\r
9755         PUSHJ   P,TMATCH\r
9756         JRST    RSBVC1\r
9757         POP     TP,B\r
9758         POP     TP,A\r
9759         POPJ    P,\r
9760 \r
9761 RSBVC1: MOVE    C,1(TB)\r
9762         POP     TP,B\r
9763         POP     TP,D\r
9764         MOVE    A,MQUOTE VALUE\r
9765         JRST    TYPMIS\r
9766 \f\r
9767 \r
9768 MFUNCTION MRETUR,SUBR,[RETURN]\r
9769         ENTRY\r
9770         HLRE    A,AB            ; GET # OF ARGS\r
9771         ASH     A,-1            ; TO NUMBER\r
9772         AOJL    A,RET2          ; 2 OR MORE ARGS\r
9773         PUSHJ   P,PROGCH        ;CHECK IN A PROG\r
9774         PUSH    TP,A\r
9775         PUSH    TP,B\r
9776         MOVEI   B,-1(TP)        ; VERIFY IT\r
9777 COMRET: PUSHJ   P,CHFSWP\r
9778         SKIPL   C               ; ARGS?\r
9779         MOVEI   C,0             ; REAL NONE\r
9780         PUSHJ   P,CHUNW\r
9781         JUMPN   A,CHFINI        ; WINNER\r
9782         MOVSI   A,TATOM\r
9783         MOVE    B,MQUOTE T\r
9784 \r
9785 ; SEE IF MUST  CHECK RETURNS TYPE\r
9786 \r
9787 CHFINI: GETYP   0,(TB)          ; SPECIAL TYPE IF SO\r
9788         CAIE    0,TDCLI\r
9789         JRST    FINIS           ; NO, JUST FINIS\r
9790         MOVEI   0,PFINIS        ; CAUSE TO FALL INTO FUNCTION CODE\r
9791         HRRM    0,PCSAV(TB)\r
9792         JRST    CONTIN\r
9793 \r
9794 \r
9795 RET2:   AOJL    A,TMA\r
9796         GETYP   A,(AB)+2\r
9797         CAIE    A,TACT          ; AS FOR "EXIT" SHOULD BE ACTIVATION\r
9798         JRST    WTYP2\r
9799         MOVEI   B,(AB)+2        ; ADDRESS OF FRAME POINTER\r
9800         JRST    COMRET\r
9801 \r
9802 \r
9803 \r
9804 MFUNCTION AGAIN,SUBR\r
9805         ENTRY   \r
9806         HLRZ    A,AB            ;GET # OF ARGS\r
9807         CAIN    A,-2            ;1 ARG?\r
9808         JRST    NLCLA           ;YES\r
9809         JUMPN   A,TMA           ;0 ARGS?\r
9810         PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG\r
9811         PUSH    TP,A\r
9812         PUSH    TP,B\r
9813         JRST    AGAD\r
9814 NLCLA:  GETYP   A,(AB)\r
9815         CAIE    A,TACT\r
9816         JRST    WTYP1\r
9817         PUSH    TP,(AB)\r
9818         PUSH    TP,1(AB)\r
9819 AGAD:   MOVEI   B,-1(TP)        ; POINT TO FRAME\r
9820         PUSHJ   P,CHFSWP\r
9821         HRRZ    C,(B)           ; GET RET POINT\r
9822 GOJOIN: PUSH    TP,$TFIX\r
9823         PUSH    TP,C\r
9824         MOVEI   C,-1(TP)\r
9825         PUSHJ   P,CHUNW         ; RESTORE FRAME, UNWIND IF NEC.\r
9826         HRRZM   B,PCSAV(TB)\r
9827         HRRZ    0,FSAV(TB)      ; CHECK FOR RSUBR\r
9828         CAMGE   0,VECTOP\r
9829         CAMG    0,VECBOT\r
9830         JRST    CONTIN\r
9831         HRRZ    E,1(TB)\r
9832         PUSH    TP,$TFIX\r
9833         PUSH    TP,B\r
9834         MOVEI   C,-1(TP)\r
9835         MOVEI   B,(TB)\r
9836         PUSHJ   P,CHUNW1\r
9837         MOVE    TP,1(TB)\r
9838         MOVEM   SP,SPSAV(TB)\r
9839         MOVEM   TP,TPSAV(TB)\r
9840         MOVE    C,OTBSAV(TB)    ; AND RESTORE P FROM FATHER\r
9841         MOVE    P,PSAV(C)\r
9842         MOVEM   P,PSAV(TB)\r
9843         HRLI    B,M\r
9844         MOVEM   B,PCSAV(TB)\r
9845         JRST    CONTIN\r
9846 \r
9847 MFUNCTION GO,SUBR\r
9848         ENTRY   1\r
9849         GETYP   A,(AB)\r
9850         CAIE    A,TATOM\r
9851         JRST    NLCLGO\r
9852         PUSHJ   P,PROGCH        ;CHECK FOR A PROG\r
9853         PUSH    TP,A            ;SAVE\r
9854         PUSH    TP,B\r
9855         MOVEI   B,-1(TP)\r
9856         PUSHJ   P,CHFSWP\r
9857         PUSH    TP,$TATOM\r
9858         PUSH    TP,1(C)\r
9859         PUSH    TP,2(B)\r
9860         PUSH    TP,3(B)\r
9861         MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?\r
9862         JUMPE   B,NXTAG         ;NO -- ERROR\r
9863 FNDGO:  EXCH    B,(TP)          ;SAVE PLACE TO GO\r
9864         MOVSI   D,TLIST\r
9865         MOVEM   D,-1(TP)\r
9866         JRST    GODON\r
9867 \r
9868 NLCLGO: CAIE    A,TTAG          ;CHECK TYPE\r
9869         JRST    WTYP1\r
9870         MOVE    B,1(AB)\r
9871         MOVEI   B,2(B)          ; POINT TO SLOT\r
9872         PUSHJ   P,CHFSWP\r
9873         MOVE    A,1(C)\r
9874         GETYP   0,(A)           ; SEE IF COMPILED\r
9875         CAIE    0,TFIX\r
9876         JRST    GODON1\r
9877         MOVE    C,1(A)\r
9878         JRST    GOJOIN\r
9879 \r
9880 GODON1: PUSH    TP,(A)          ;SAVE BODY\r
9881         PUSH    TP,1(A)\r
9882 GODON:  MOVEI   C,0\r
9883         PUSHJ   P,CHUNW         ;GO BACK TO CORRECT FRAME\r
9884         MOVE    B,(TP)          ;RESTORE ITERATION MARKER\r
9885         MOVEM   B,1(TB)\r
9886         MOVSI   A,TFALSE\r
9887         MOVEI   B,0\r
9888         JRST    CONTIN\r
9889 \r
9890 \f\r
9891 \r
9892 \r
9893 MFUNCTION TAG,SUBR\r
9894         ENTRY\r
9895         JUMPGE  AB,TFA\r
9896         HLRZ    0,AB\r
9897         GETYP   A,(AB)          ;GET TYPE OF ARGUMENT\r
9898         CAIE    A,TFIX          ; FIX ==> COMPILED\r
9899         JRST    ATOTAG\r
9900         CAIE    0,-4\r
9901         JRST    WNA\r
9902         GETYP   A,2(AB)\r
9903         CAIE    A,TACT\r
9904         JRST    WTYP2\r
9905         PUSH    TP,(AB)\r
9906         PUSH    TP,1(AB)\r
9907         PUSH    TP,2(AB)\r
9908         PUSH    TP,3(AB)\r
9909         JRST    GENTV\r
9910 ATOTAG: CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM\r
9911         JRST    WTYP1\r
9912         CAIE    0,-2\r
9913         JRST    TMA\r
9914         PUSHJ   P,PROGCH        ;CHECK PROG\r
9915         PUSH    TP,A            ;SAVE VAL\r
9916         PUSH    TP,B\r
9917         PUSH    TP,$TATOM\r
9918         PUSH    TP,1(AB)\r
9919         PUSH    TP,2(B)\r
9920         PUSH    TP,3(B)\r
9921         MCALL   2,MEMQ\r
9922         JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR\r
9923         EXCH    A,-1(TP)        ;SAVE PLACE\r
9924         EXCH    B,(TP)  \r
9925         HRLI    A,TFRAME\r
9926         PUSH    TP,A\r
9927         PUSH    TP,B\r
9928 GENTV:  MOVEI   A,2\r
9929         PUSHJ   P,IEVECT\r
9930         MOVSI   A,TTAG\r
9931         JRST    FINIS\r
9932 \r
9933 PROGCH: MOVE    B,MQUOTE LPROG,[LPROG ]INTRUP\r
9934         PUSHJ   P,ILVAL         ;GET VALUE\r
9935         GETYP   0,A\r
9936         CAIE    0,TACT\r
9937         JRST    NXPRG\r
9938         POPJ    P,\r
9939 \r
9940 ; HERE TO UNASSIGN LPROG IF NEC\r
9941 \r
9942 UNPROG: MOVE    B,MQUOTE LPROG,[LPROG ]INTRUP\r
9943         PUSHJ   P,ILVAL\r
9944         GETYP   0,A\r
9945         CAIE    0,TACT          ; SKIP IF MUST UNBIND\r
9946         JRST    UNMAP\r
9947         MOVSI   A,TUNBOU\r
9948         MOVNI   B,1\r
9949         MOVE    E,MQUOTE LPROG,[LPROG ]INTRUP\r
9950         PUSHJ   P,PSHBND\r
9951 UNMAP:  HRRZ    0,FSAV(TB)      ; CHECK FOR FUNNY\r
9952         CAIN    0,MAPPLY        ; SKIP IF NOT\r
9953         POPJ    P,\r
9954         MOVE    B,MQUOTE LMAP,[LMAP ]INTRUP\r
9955         PUSHJ   P,ILVAL\r
9956         GETYP   0,A\r
9957         CAIE    0,TFRAME\r
9958         JRST    UNSPEC\r
9959         MOVSI   A,TUNBOU\r
9960         MOVNI   B,1\r
9961         MOVE    E,MQUOTE LMAP,[LMAP ]INTRUP\r
9962         PUSHJ   P,PSHBND\r
9963 UNSPEC: PUSH    TP,BNDV\r
9964         MOVE    B,PVP\r
9965         ADD     B,[CURFCN,,CURFCN]\r
9966         PUSH    TP,B\r
9967         PUSH    TP,$TSP\r
9968         MOVE    E,SP\r
9969         ADD     E,[3,,3]\r
9970         PUSH    TP,E\r
9971         POPJ    P,\r
9972 \r
9973 REPEAT 0,[\r
9974 MFUNCTION MEXIT,SUBR,[EXIT]\r
9975         ENTRY   2\r
9976         GETYP   A,(AB)\r
9977         CAIE    A,TACT\r
9978         JRST    WTYP1\r
9979         MOVEI   B,(AB)\r
9980         PUSHJ   P,CHFSWP\r
9981         ADD     C,[2,,2]\r
9982         PUSHJ   P,CHUNW         ;RESTORE FRAME\r
9983         JRST    CHFINI          ; CHECK FOR WINNING VALUE\r
9984 ]\r
9985 \r
9986 MFUNCTION COND,FSUBR\r
9987         ENTRY   1\r
9988         GETYP   A,(AB)\r
9989         CAIE    A,TLIST\r
9990         JRST    WRONGT\r
9991         PUSH    TP,(AB)\r
9992         PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP\r
9993         MOVEI   B,0             ; SET TO FALSE IN CASE\r
9994 \r
9995 CLSLUP: SKIPN   C,1(TB)         ;IS THE CLAUSELIST NIL?\r
9996         JRST    IFALS1          ;YES -- RETURN NIL\r
9997         GETYP   A,(C)           ;NO -- GET TYPE OF CAR\r
9998         CAIE    A,TLIST         ;IS IT A LIST?\r
9999         JRST    BADCLS          ;\r
10000         MOVE    A,1(C)          ;YES -- GET CLAUSE\r
10001         JUMPE   A,BADCLS\r
10002         GETYPF  B,(A)\r
10003         PUSH    TP,B            ; EVALUATION OF\r
10004         HLLZS   (TP)\r
10005         PUSH    TP,1(A)         ;THE PREDICATE\r
10006         JSP     E,CHKARG\r
10007         MCALL   1,EVAL\r
10008         GETYP   0,A\r
10009         CAIN    0,TFALSE\r
10010         JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE\r
10011         MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE\r
10012         MOVE    C,1(C)\r
10013         HRRZ    C,(C)\r
10014         JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)\r
10015         JRST    DOPRG2          ;AS THOUGH IT WERE A PROG\r
10016 NXTCLS: HRRZ    C,@1(TB)        ;SET THE CLAUSLIST\r
10017         HRRZM   C,1(TB)         ;TO CDR OF THE CLAUSLIST\r
10018         JRST    CLSLUP\r
10019         \r
10020 IFALSE:\r
10021         MOVEI   B,0\r
10022 IFALS1: MOVSI   A,TFALSE        ;RETURN FALSE\r
10023         JRST    FINIS\r
10024 \r
10025 \r
10026 \f\r
10027 MFUNCTION UNWIND,FSUBR\r
10028 \r
10029         ENTRY   1\r
10030 \r
10031         GETYP   0,(AB)          ; CHECK THE ARGS FOR WINNAGE\r
10032         SKIPN   A,1(AB)         ; NONE?\r
10033         JRST    TFA\r
10034         HRRZ    B,(A)           ; CHECK FOR 2D\r
10035         JUMPE   B,TFA\r
10036         HRRZ    0,(B)           ; 3D?\r
10037         JUMPN   0,TMA\r
10038 \r
10039 ; Unbind LPROG and LMAPF so that nothing cute happens\r
10040 \r
10041         PUSHJ   P,UNPROG\r
10042 \r
10043 ; Push thing to do upon UNWINDing\r
10044 \r
10045         PUSH    TP,$TLIST\r
10046         PUSH    TP,[0]\r
10047 \r
10048         MOVEI   C,UNWIN1\r
10049         PUSHJ   P,IUNWIN        ; GOT TO INTERNAL SET UP\r
10050 \r
10051 ; Now EVAL the first form\r
10052 \r
10053         MOVE    A,1(AB)\r
10054         HRRZ    0,(A)           ; SAVE POINTER TO OTHER GUY\r
10055         MOVEM   0,-12(TP)\r
10056         MOVE    B,1(A)\r
10057         GETYP   A,(A)\r
10058         MOVSI   A,(A)\r
10059         JSP     E,CHKAB         ; DEFER?\r
10060         PUSH    TP,A\r
10061         PUSH    TP,B\r
10062         MCALL   1,EVAL          ; EVAL THE LOSER\r
10063 \r
10064         JRST    FINIS\r
10065 \r
10066 ; Now push slots to hold undo info on the way down\r
10067 \r
10068 IUNWIN:\r
10069 REPEAT 0,[\r
10070         JUMPE   M,NOTRSB\r
10071         MOVEI   C,(C)\r
10072         HLRE    0,M\r
10073         SUBM    M,0\r
10074         ANDI    0,-1\r
10075         CAIL    C,HIBOT\r
10076         JRST    NOTRSB\r
10077         CAIL    C,(M)\r
10078         CAML    C,0\r
10079         JRST    .+2\r
10080         SUBI    C,(M)\r
10081 NOTRSB:]\r
10082         PUSH    TP,$TTB         ; DESTINATION FRAME\r
10083         PUSH    TP,[0]\r
10084         PUSH    TP,[0]          ; ARGS TO WHOEVER IS DOING IT\r
10085         PUSH    TP,[0]\r
10086 \r
10087 ; Now bind UNWIND word\r
10088 \r
10089         PUSH    TP,$TUNWIN      ; FIRST WORD OF IT\r
10090         HRRM    SP,(TP)         ; CHAIN\r
10091         MOVE    SP,TP\r
10092         PUSH    TP,TB           ; AND POINT TO HERE\r
10093         PUSH    TP,$TTP\r
10094         PUSH    TP,[0]\r
10095         HRLI    C,TPDL\r
10096         PUSH    TP,C\r
10097         PUSH    TP,P            ; SAVE PDL ALSO\r
10098         MOVEM   TP,-2(TP)       ; SAVE FOR LATER\r
10099         POPJ    P,\r
10100 \r
10101 ; Do a non-local return with UNWIND checking\r
10102 \r
10103 CHUNW:  HRRZ    E,SPSAV(B)      ; GET DESTINATION FRAME\r
10104 CHUNW1: PUSH    TP,(C)          ; FINAL VAL\r
10105         PUSH    TP,1(C)\r
10106         JUMPN   C,.+3           ; WAS THERE REALLY ANYTHING\r
10107         SETZM   (TP)\r
10108         SETZM   -1(TP)\r
10109         PUSHJ   P,STLOOP        ; UNBIND\r
10110 CHUNPC: SKIPA                   ; WILL NOT SKIP UNLESS UNWIND FOUND\r
10111         JRST    GOTUND\r
10112         MOVEI   A,(TP)\r
10113         SUBI    A,(SP)\r
10114         MOVSI   A,(A)\r
10115         HLL     SP,TP\r
10116         SUB     SP,A\r
10117         HRRI    TB,(B)          ; UPDATE TB\r
10118         POP     TP,B\r
10119         POP     TP,A\r
10120         POPJ    P,\r
10121 \r
10122 ; Here if an UNDO found\r
10123 \r
10124 GOTUND: MOVE    TB,1(SP)        ; GET FRAME OF UNDO\r
10125         MOVE    A,-1(TP)        ; GET FUNNY ARG FOR PASS ON\r
10126         MOVE    C,(TP)\r
10127         MOVE    TP,3(SP)        ; GET FUTURE TP\r
10128         MOVEM   C,-6(TP)        ; SAVE ARG\r
10129         MOVEM   A,-7(TP)\r
10130         MOVE    C,(TP)          ; SAVED P\r
10131         SUB     C,[1,,1]\r
10132         MOVEM   C,PSAV(TB)      ; MAKE CONTIN WIN\r
10133         MOVEM   TP,TPSAV(TB)\r
10134         MOVEM   SP,SPSAV(TB)\r
10135         HRRZ    C,(P)           ; PC OF CHUNW CALLER\r
10136         HRRM    C,-11(TP)       ; SAVE ALSO AND GET WHERE TO GO PC\r
10137         MOVEM   B,-10(TP)       ; AND DESTINATION FRAME\r
10138         HRRZ    C,-1(TP)                ; WHERE TO UNWIND PC\r
10139         HRRZ    0,FSAV(TB)      ; RSUBR?\r
10140         CAMG    0,VECTOP\r
10141         CAMGE   0,VECBOT\r
10142         TLZA    C,-1            ; 0 LH OF C AND SKIP\r
10143         HRLI    C,M             ; RELATIVIZE\r
10144         MOVEM   C,PCSAV(TB)\r
10145         JRST    CONTIN\r
10146 \r
10147 UNWIN1: MOVE    B,-12(TP)       ; POINT TO THING TO DO UNWINDING\r
10148         GETYP   A,(B)\r
10149         MOVSI   A,(A)\r
10150         MOVE    B,1(B)\r
10151         JSP     E,CHKAB\r
10152         PUSH    TP,A\r
10153         PUSH    TP,B\r
10154         MCALL   1,EVAL\r
10155 UNWIN2: MOVEI   C,-7(TP)        ; POINT TO SAVED RET VALS\r
10156         MOVE    B,-10(TP)\r
10157         HRRZ    E,-11(TP)\r
10158         PUSH    P,E\r
10159         HRRZ    SP,(SP)         ; UNBIND THIS GUY\r
10160         MOVEI   E,(TP)          ; AND FIXUP SP\r
10161         SUBI    E,(SP)\r
10162         MOVSI   E,(E)\r
10163         HLL     SP,TP\r
10164         SUB     SP,E\r
10165         JRST    CHUNW           ; ANY MORE TO UNWIND?\r
10166 \r
10167 \f\r
10168 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.\r
10169 ; CALLED BY ALL CONTROL FLOW\r
10170 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)\r
10171 \r
10172 CHFSWP: PUSHJ   P,CHFRM         ; CHECK FOR VALID FRAME\r
10173         HRRZ    D,(B)           ; PROCESS VECTOR DOPE WD\r
10174         HLRZ    C,(D)           ; LENGTH\r
10175         SUBI    D,-1(C)         ; POINT TO TOP\r
10176         MOVNS   C               ; NEGATE COUNT\r
10177         HRLI    D,2(C)          ; BUILD PVP\r
10178         MOVE    E,PVP\r
10179         MOVE    C,AB\r
10180         MOVE    A,(B)           ; GET FRAME\r
10181         MOVE    B,1(B)\r
10182         CAMN    E,D             ; SKIP IF SWAP NEEDED\r
10183         POPJ    P,\r
10184         PUSH    TP,A            ; SAVE FRAME\r
10185         PUSH    TP,B\r
10186         MOVE    B,D\r
10187         PUSHJ   P,PROCHK        ; FIX UP PROCESS LISTS\r
10188         MOVE    A,PSTAT+1(B)    ; GET STATE\r
10189         CAIE    A,RESMBL\r
10190         JRST    NOTRES\r
10191         MOVE    D,B             ; PREPARE TO SWAP\r
10192         POP     P,0             ; RET ADDR\r
10193         POP     TP,B\r
10194         POP     TP,A\r
10195         JSP     C,SWAP          ; SWAP IN\r
10196         MOVE    C,ABSTO+1(E)    ; GET OLD ARRGS\r
10197         MOVEI   A,RUNING        ; FIX STATES\r
10198         MOVEM   A,PSTAT+1(PVP)\r
10199         MOVEI   A,RESMBL\r
10200         MOVEM   A,PSTAT+1(E)\r
10201         JRST    @0\r
10202 \r
10203 NOTRES: PUSH    TP,$TATOM\r
10204         PUSH    TP,EQUOTE PROCESS-NOT-RESUMABLE\r
10205         JRST    CALER1\r
10206 \f\r
10207 \r
10208 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,\r
10209 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS\r
10210 ; ITS SECOND ARGUMENT.\r
10211 \r
10212 MFUNCTION SETG,SUBR\r
10213         ENTRY   2\r
10214         GETYP   A,(AB)          ;GET TYPE OF FIRST ARGUMENT\r
10215         CAIE    A,TATOM ;CHECK THAT IT IS AN ATOM\r
10216         JRST    NONATM          ;IF NOT -- ERROR\r
10217         MOVE    B,1(AB)         ;GET POINTER TO ATOM\r
10218         PUSH    TP,$TATOM\r
10219         PUSH    TP,B\r
10220         MOVEI   0,(B)\r
10221         CAIL    0,HIBOT         ; PURE ATOM?\r
10222         PUSHJ   P,IMPURIFY      ; YES IMPURIFY\r
10223         PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE\r
10224         CAMN    A,$TUNBOUND     ;IF BOUND\r
10225         PUSHJ   P,BSETG         ;IF NOT -- BIND IT\r
10226         MOVE    C,2(AB)         ; GET PROPOSED VVAL\r
10227         MOVE    D,3(AB)\r
10228         MOVSI   A,TLOCD         ; MAKE SURE MONCH WINS\r
10229         PUSHJ   P,MONCH0        ; WOULD YOU BELIEVE MONITORS!!!!\r
10230         EXCH    D,B             ;SAVE PTR\r
10231         MOVE    A,C\r
10232         HRRZ    E,-2(D)         ; POINT TO POSSIBLE GDECL (OR MAINIFEST)\r
10233         JUMPE   E,OKSETG        ; NONE ,OK\r
10234         CAIE    E,-1            ; MANIFEST?\r
10235         JRST    SETGTY\r
10236         GETYP   0,(D)           ; IF UNBOUND, LET IT HAPPEN\r
10237         SKIPN   IGDECL\r
10238         CAIN    0,TUNBOU\r
10239         JRST    OKSETG\r
10240 MANILO: GETYP   C,(D)\r
10241         GETYP   0,2(AB)\r
10242         CAIN    0,(C)\r
10243         CAME    B,1(D)\r
10244         JRST    .+2\r
10245         JRST    OKSETG\r
10246         PUSH    TP,$TVEC\r
10247         PUSH    TP,D\r
10248         MOVE    B,MQUOTE REDEFINE\r
10249         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK\r
10250         GETYP   A,A\r
10251         CAIE    A,TUNBOU\r
10252         CAIN    A,TFALSE\r
10253         JRST    .+2\r
10254         JRST    OKSTG\r
10255         PUSH    TP,$TATOM\r
10256         PUSH    TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE\r
10257         PUSH    TP,$TATOM\r
10258         PUSH    TP,1(AB)\r
10259         MOVEI   A,2\r
10260         JRST    CALER\r
10261 \r
10262 SETGTY: PUSH    TP,$TVEC\r
10263         PUSH    TP,D\r
10264         MOVE    C,A\r
10265         MOVE    D,B\r
10266         GETYP   A,(E)\r
10267         MOVSI   A,(A)\r
10268         MOVE    B,1(E)\r
10269         JSP     E,CHKAB\r
10270         PUSHJ   P,TMATCH\r
10271         JRST    TYPMI3\r
10272 \r
10273 OKSTG:  MOVE    D,(TP)\r
10274         MOVE    A,2(AB)\r
10275         MOVE    B,3(AB)\r
10276 \r
10277 OKSETG: MOVEM   A,(D)           ;DEPOSIT INTO THE \r
10278         MOVEM   B,1(D)          ;INDICATED VALUE CELL\r
10279         JRST    FINIS\r
10280 \r
10281 TYPMI3: MOVE    C,(TP)\r
10282         HRRZ    C,-2(C)\r
10283         MOVE    D,2(AB)\r
10284         MOVE    B,3(AB)\r
10285         MOVE    0,(AB)\r
10286         MOVE    A,1(AB)\r
10287         JRST    TYPMIS\r
10288 \r
10289 BSETG:  HRRZ    A,GLOBASE+1(TVP)\r
10290         HRRZ    B,GLOBSP+1(TVP)\r
10291         SUB     B,A\r
10292         CAIL    B,6\r
10293         JRST    SETGIT\r
10294         MOVEI   B,0             ; MAKE SURE OF NO EMPTY SLOTS\r
10295         PUSHJ   P,IGLOC\r
10296         CAMN    A,$TUNBOU       ; SKIP IF SLOT FOUND\r
10297         JRST    BSETG1\r
10298         MOVE    E,(TP)          ; GET ATOM\r
10299         MOVEM   E,-1(B)         ; CLOBBER ATOM SLOT\r
10300         POPJ    P,\r
10301 ; BSETG1:       PUSH    TP,GLOBASE(TVP) ; MUST REALLY GROW STACK\r
10302 ;       PUSH    TP,GLOBASE+1 (TVP)\r
10303 ;       PUSH    TP,$TFIX\r
10304 ;       PUSH    TP,[0]\r
10305 ;       PUSH    TP,$TFIX\r
10306 ;       PUSH    TP,[100]\r
10307 ;       MCALL   3,GROW\r
10308 BSETG1: PUSH    P,0\r
10309         PUSH    P,C\r
10310         MOVE    C,GLOBASE+1(TVP)\r
10311         HLRE    B,C\r
10312         SUB     C,B\r
10313         MOVE    B,GVLINC        ; GROW BY INDICATED GVAL SLOTS\r
10314         DPB     B,[001100,,(C)]\r
10315 ;       MOVEM   A,GLOBASE(TVP)\r
10316         MOVE    C,[6,,4]                ; INDICATOR FOR AGC\r
10317         PUSHJ   P,AGC\r
10318         MOVE    B,GLOBASE+1(TVP)\r
10319         MOVE    0,GVLINC        ; ADJUST GLOBAL SPBASE\r
10320         ASH     0,6\r
10321         SUB     B,0\r
10322         HRLZS   0\r
10323         SUB     B,0\r
10324         MOVEM   B,GLOBASE+1(TVP)\r
10325 ;       MOVEM   B,GLOBASE+1(TVP)\r
10326         POP     P,0\r
10327         POP     P,C\r
10328 SETGIT:\r
10329         MOVE    B,GLOBSP+1(TVP)\r
10330         SUB     B,[4,,4]\r
10331         MOVSI   C,TGATOM\r
10332         MOVEM   C,(B)\r
10333         MOVE    C,(TP)\r
10334         MOVEM   C,1(B)\r
10335         MOVEM   B,GLOBSP+1(TVP)\r
10336         ADD     B,[2,,2]\r
10337         MOVSI   A,TLOCI\r
10338         POPJ    P,\r
10339 \r
10340 \r
10341 MFUNCTION DEFMAC,FSUBR\r
10342 \r
10343         ENTRY   1\r
10344 \r
10345         PUSH    P,.\r
10346         JRST    DFNE2\r
10347 \r
10348 MFUNCTION DFNE,FSUBR,[DEFINE]\r
10349 \r
10350         ENTRY   1\r
10351 \r
10352         PUSH    P,[0]\r
10353 DFNE2:  GETYP   A,(AB)\r
10354         CAIE    A,TLIST\r
10355         JRST    WRONGT\r
10356         SKIPN   B,1(AB)         ; GET ATOM\r
10357         JRST    TFA\r
10358         GETYP   A,(B)           ; MAKE SURE ATOM\r
10359         MOVSI   A,(A)\r
10360         PUSH    TP,A\r
10361         PUSH    TP,1(B)\r
10362         JSP     E,CHKARG\r
10363         MCALL   1,EVAL          ; EVAL IT TO AN ATOM\r
10364         CAME    A,$TATOM\r
10365         JRST    NONATM\r
10366         PUSH    TP,A            ; SAVE TWO COPIES\r
10367         PUSH    TP,B\r
10368         PUSHJ   P,IGVAL         ; SEE IF A VALUE EXISTS\r
10369         CAMN    A,$TUNBOU       ; SKIP IF A WINNER\r
10370         JRST    .+3\r
10371         PUSHJ   P,ASKUSR        ; CHECK WITH USER\r
10372         JRST    DFNE1\r
10373         PUSH    TP,$TATOM\r
10374         PUSH    TP,-1(TP)\r
10375         MOVE    B,1(AB)\r
10376         HRRZ    B,(B)\r
10377         MOVSI   A,TEXPR\r
10378         SKIPN   (P)             ; SKIP IF MACRO\r
10379         JRST    DFNE3\r
10380         MOVEI   D,(B)           ; READY TO CONS\r
10381         MOVSI   C,TEXPR\r
10382         PUSHJ   P,INCONS\r
10383         MOVSI   A,TMACRO\r
10384 DFNE3:  PUSH    TP,A\r
10385         PUSH    TP,B\r
10386         MCALL   2,SETG\r
10387 DFNE1:  POP     TP,B            ; RETURN ATOM\r
10388         POP     TP,A\r
10389         JRST    FINIS\r
10390 \r
10391 \r
10392 ASKUSR: MOVE    B,MQUOTE REDEFINE\r
10393         PUSHJ   P,ILVAL         ; SEE IF REDEFINE OK\r
10394         GETYP   A,A\r
10395         CAIE    A,TUNBOU\r
10396         CAIN    A,TFALSE\r
10397         JRST    ASKUS1\r
10398         JRST    ASKUS2\r
10399 ASKUS1: PUSH    TP,$TATOM\r
10400         PUSH    TP,-1(TP)\r
10401         PUSH    TP,$TATOM\r
10402         PUSH    TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE\r
10403         MCALL   2,ERROR\r
10404         GETYP   0,A\r
10405         CAIE    0,TFALSE\r
10406 ASKUS2: AOS     (P)\r
10407         MOVE    B,1(AB)\r
10408         POPJ    P,\r
10409 \f\r
10410 \r
10411 \r
10412 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS\r
10413 ;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.\r
10414 \r
10415 MFUNCTION SET,SUBR\r
10416         HLRE    D,AB            ; 2 TIMES # OF ARGS TO D\r
10417         ASH     D,-1            ; - # OF ARGS\r
10418         ADDI    D,2\r
10419         JUMPG   D,TFA           ; NOT ENOUGH\r
10420         MOVE    B,PVP\r
10421         MOVE    C,SP\r
10422         JUMPE   D,SET1          ; NO ENVIRONMENT\r
10423         AOJL    D,TMA           ; TOO MANY\r
10424         GETYP   A,4(AB)         ; CHECK ARG IS A FRAME OR PROCESS\r
10425         CAIE    A,TFRAME\r
10426         CAIN    A,TENV\r
10427         JRST    SET2            ; WINNING ENVIRONMENT/FRAME\r
10428         CAIN    A,TACT\r
10429         JRST    SET2            ; TO MAKE PFISTER HAPPY\r
10430         CAIE    A,TPVP\r
10431         JRST    WTYP2\r
10432         MOVE    B,5(AB)         ; GET PROCESS\r
10433         MOVE    C,SPSTO+1(B)\r
10434         JRST    SET1\r
10435 SET2:   MOVEI   B,4(AB)         ; POINT TO FRAME\r
10436         PUSHJ   P,CHFRM ; CHECK IT OUT\r
10437         MOVE    B,5(AB)         ; GET IT BACK\r
10438         MOVE    C,SPSAV(B)      ; GET BINDING POINTER\r
10439         HRRZ    B,4(AB)         ; POINT TO PROCESS\r
10440         HLRZ    A,(B)           ; GET LENGTH\r
10441         SUBI    B,-1(A)         ; POINT TO START THEREOF\r
10442         HLL     B,PVP           ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)\r
10443 SET1:   PUSH    TP,$TPVP        ; SAVE PROCESS\r
10444         PUSH    TP,B\r
10445         PUSH    TP,$TSP         ; SAVE PATH POINTER\r
10446         PUSH    TP,C\r
10447         GETYP   A,(AB)          ;GET TYPE OF FIRST\r
10448         CAIE    A,TATOM ;ARGUMENT -- \r
10449         JRST    WTYP1           ;BETTER BE AN ATOM\r
10450         MOVE    B,1(AB)         ;GET PTR TO IT\r
10451         MOVEI   0,(B)\r
10452         CAIL    0,HIBOT\r
10453         PUSHJ   P,IMPURIFY\r
10454         MOVE    C,(TP)\r
10455         PUSHJ   P,AILOC         ;GET LOCATIVE TO VALUE\r
10456 GOTLOC: CAMN    A,$TUNBOUND     ;BOUND?\r
10457         PUSHJ   P, BSET         ;BIND IT\r
10458         SUB     TP,[4,,4]\r
10459         MOVE    C,2(AB)         ; GET NEW VAL\r
10460         MOVE    D,3(AB)\r
10461         MOVSI   A,TLOCD         ; FOR MONCH\r
10462         HRR     A,2(B)\r
10463         PUSHJ   P,MONCH0        ; HURRAY FOR MONITORS!!!!!\r
10464         MOVE    E,B\r
10465         HLRZ    A,2(E)          ; GET DECLS\r
10466         JUMPE   A,SET3          ; NONE, GO\r
10467         PUSH    TP,$TSP\r
10468         PUSH    TP,E\r
10469         MOVE    B,1(A)\r
10470         HLLZ    A,(A)           ; GET PATTERN\r
10471         PUSHJ   P,TMATCH        ; MATCH TMEM\r
10472         JRST    TYPMI2          ; LOSES\r
10473         MOVE    E,(TP)\r
10474         SUB     TP,[2,,2]\r
10475         MOVE    C,2(AB)\r
10476         MOVE    D,3(AB)\r
10477 SET3:   MOVEM   C,(E)           ;CLOBBER IDENTIFIER\r
10478         MOVEM   D,1(E)\r
10479         MOVE    A,C\r
10480         MOVE    B,D\r
10481         JRST    FINIS\r
10482 BSET:\r
10483         CAMN    PVP,-2(TP)      ; SKIP IF PROC DIFFERS\r
10484         MOVEM   C,-2(TP)        ; ELSE USE RESULT FROM LOC SEARCH\r
10485         MOVE    B,-2(TP)        ; GET PROCESS\r
10486         HRRZ    A,TPBASE+1(B)   ;GET ACTUAL STACK BASE\r
10487         HRRZ    B,SPBASE+1(B)   ;AND FIRST BINDING\r
10488         SUB     B,A             ;ARE THERE 6\r
10489         CAIL    B,6             ;CELLS AVAILABLE?\r
10490         JRST    SETIT           ;YES\r
10491         MOVE    C,(TP)          ; GET POINTER BACK\r
10492         MOVEI   B,0             ; LOOK FOR EMPTY SLOT\r
10493         PUSHJ   P,AILOC\r
10494         CAMN    A,$TUNBOUND     ; SKIP IF FOUND\r
10495         JRST    BSET1\r
10496         MOVE    E,1(AB)         ; GET ATOM\r
10497         MOVEM   E,-1(B)         ; AND STORE\r
10498         JRST    BSET2\r
10499 BSET1:  MOVE    B,-2(TP)        ; GET PROCESS\r
10500 ;       PUSH    TP,TPBASE(B)    ;NO -- GROW THE TP\r
10501 ;       PUSH    TP,TPBASE+1(B)  ;AT THE BASE END\r
10502 ;       PUSH    TP,$TFIX\r
10503 ;       PUSH    TP,[0]\r
10504 ;       PUSH    TP,$TFIX\r
10505 ;       PUSH    TP,[100]\r
10506 ;       MCALL   3,GROW\r
10507 ;       MOVE    C,-2(TP)                ; GET PROCESS\r
10508 ;       MOVEM   A,TPBASE(C)     ;SAVE RESULT\r
10509         PUSH    P,0             ; MANUALLY GROW VECTOR\r
10510         PUSH    P,C\r
10511         MOVE    C,TPBASE+1(B)\r
10512         HLRE    B,C\r
10513         SUB     C,B\r
10514         MOVEI   C,1(C)\r
10515         CAME    C,TPGROW\r
10516         ADDI    C,PDLBUF\r
10517         MOVE    D,LVLINC\r
10518         DPB     D,[001100,,-1(C)]\r
10519         MOVE    C,[5,,3]        ; SET UP INDICATORS FOR AGC\r
10520         PUSHJ   P,AGC\r
10521         MOVE    B,TPBASE+1(PVP) ; MODIFY POINTER\r
10522         MOVE    0,LVLINC        ; ADJUST SPBASE POINTER\r
10523         ASH     0,6\r
10524         SUB     B,0\r
10525         HRLZS   0\r
10526         SUB     B,0\r
10527         MOVEM   B,TPBASE+1(PVP)\r
10528         POP     P,C\r
10529         POP     P,0\r
10530 ;       MOVEM   B,TPBASE+1(C)\r
10531 SETIT:  MOVE    C,-2(TP)                ; GET PROCESS\r
10532         MOVE    B,SPBASE+1(C)\r
10533         MOVEI   A,-6(B)         ;MAKE UP BINDING\r
10534         HRRM    A,(B)           ;LINK PREVIOUS BIND BLOCK\r
10535         MOVSI   A,TBIND\r
10536         MOVEM   A,-6(B)\r
10537         MOVE    A,1(AB)\r
10538         MOVEM   A,-5(B)\r
10539         SUB     B,[6,,6]\r
10540         MOVEM   B,SPBASE+1(C)\r
10541         ADD     B,[2,,2]\r
10542 BSET2:  MOVE    C,-2(TP)        ; GET PROC\r
10543         MOVSI   A,TLOCI\r
10544         HRR     A,BINDID+1(C)\r
10545         HLRZ    D,OTBSAV(TB)    ; TIME IT\r
10546         MOVEM   D,2(B)          ; AND FIX IT\r
10547         POPJ    P,\r
10548 \r
10549 ; HERE TO ELABORATE ON TYPE MISMATCH\r
10550 \r
10551 TYPMI2: MOVE    C,(TP)          ; FIND DECLS\r
10552         HLRZ    C,2(C)\r
10553         MOVE    D,2(AB)\r
10554         MOVE    B,3(AB)\r
10555         MOVE    0,(AB)          ; GET ATOM\r
10556         MOVE    A,1(AB)\r
10557         JRST    TYPMIS\r
10558 \r
10559 \f\r
10560 \r
10561 MFUNCTION NOT,SUBR\r
10562         ENTRY   1\r
10563         GETYP   A,(AB)          ; GET TYPE\r
10564         CAIE    A,TFALSE        ;IS IT FALSE?\r
10565         JRST    IFALSE          ;NO -- RETURN FALSE\r
10566 \r
10567 TRUTH:\r
10568         MOVSI   A,TATOM         ;RETURN T (VERITAS) \r
10569         MOVE    B,MQUOTE T\r
10570         JRST    FINIS\r
10571 \r
10572 MFUNCTION OR,FSUBR\r
10573 \r
10574         PUSH    P,[0]\r
10575         JRST    ANDOR\r
10576 \r
10577 MFUNCTION ANDA,FSUBR,AND\r
10578 \r
10579         PUSH    P,[1]\r
10580 ANDOR:  ENTRY   1\r
10581         GETYP   A,(AB)\r
10582         CAIE    A,TLIST\r
10583         JRST    WRONGT          ;IF ARG DOESN'T CHECK OUT\r
10584         MOVE    E,(P)\r
10585         SKIPN   C,1(AB)         ;IF NIL\r
10586         JRST    TF(E)           ;RETURN TRUTH\r
10587         PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP\r
10588         PUSH    TP,C\r
10589 ANDLP:\r
10590         MOVE    E,(P)\r
10591         JUMPE   C,TFI(E)        ;ANY MORE ARGS?\r
10592         MOVEM   C,1(TB)         ;STORE CRUFT\r
10593         GETYP   A,(C)\r
10594         MOVSI   A,(A)\r
10595         PUSH    TP,A\r
10596         PUSH    TP,1(C)         ;ARGUMENT\r
10597         JSP     E,CHKARG\r
10598         MCALL   1,EVAL\r
10599         GETYP   0,A\r
10600         MOVE    E,(P)\r
10601         XCT     TFSKP(E)\r
10602         JRST    FINIS           ;IF FALSE -- RETURN\r
10603         HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST\r
10604         JRST    ANDLP\r
10605 \r
10606 TF:     JRST    IFALSE\r
10607         JRST    TRUTH\r
10608 \r
10609 TFI:    JRST    IFALS1\r
10610         JRST    FINIS\r
10611 \r
10612 TFSKP:  CAIE    0,TFALSE\r
10613         CAIN    0,TFALSE\r
10614 \r
10615 MFUNCTION FUNCTION,FSUBR\r
10616 \r
10617         ENTRY   1\r
10618 \r
10619         MOVSI   A,TEXPR\r
10620         MOVE    B,1(AB)\r
10621         JRST    FINIS\r
10622 \r
10623 \f\r
10624 \r
10625 MFUNCTION CLOSURE,SUBR\r
10626         ENTRY\r
10627         SKIPL   A,AB            ;ANY ARGS\r
10628         JRST    TFA             ;NO -- LOSE\r
10629         ADD     A,[2,,2]        ;POINT AT IDS\r
10630         PUSH    TP,$TAB\r
10631         PUSH    TP,A\r
10632         PUSH    P,[0]           ;MAKE COUNTER\r
10633 \r
10634 CLOLP:  SKIPL   A,1(TB)         ;ANY MORE IDS?\r
10635         JRST    CLODON          ;NO -- LOSE\r
10636         PUSH    TP,(A)          ;SAVE ID\r
10637         PUSH    TP,1(A)\r
10638         PUSH    TP,(A)          ;GET ITS VALUE\r
10639         PUSH    TP,1(A)\r
10640         ADD     A,[2,,2]        ;BUMP POINTER\r
10641         MOVEM   A,1(TB)\r
10642         AOS     (P)\r
10643         MCALL   1,VALUE\r
10644         PUSH    TP,A\r
10645         PUSH    TP,B\r
10646         MCALL   2,LIST          ;MAKE PAIR\r
10647         PUSH    TP,A\r
10648         PUSH    TP,B\r
10649         JRST    CLOLP\r
10650 \r
10651 CLODON: POP     P,A\r
10652         ACALL   A,LIST          ;MAKE UP LIST\r
10653         PUSH    TP,(AB)         ;GET FUNCTION\r
10654         PUSH    TP,1(AB)\r
10655         PUSH    TP,A\r
10656         PUSH    TP,B\r
10657         MCALL   2,LIST          ;MAKE LIST\r
10658         MOVSI   A,TFUNARG\r
10659         JRST    FINIS\r
10660 \r
10661 \f\r
10662 \r
10663 ;ERROR COMMENTS FOR EVAL\r
10664 TUPTFA: PUSH    TP,$TATOM\r
10665         PUSH    TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE\r
10666         JRST    CALER1\r
10667 \r
10668 TUPTMA: PUSH    TP,$TATOM\r
10669         PUSH    TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE\r
10670         JRST    CALER1\r
10671 \r
10672 BADNUM: PUSH    TP,$TATOM\r
10673         PUSH    TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE\r
10674         JRST    CALER1\r
10675 \r
10676 WTY1TP: PUSH    TP,$TATOM\r
10677         PUSH    TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX\r
10678         JRST    CALER1\r
10679 \r
10680 UNBOU:  PUSH    TP,$TATOM\r
10681         PUSH    TP,EQUOTE UNBOUND-VARIABLE\r
10682         JRST    ER1ARG\r
10683 \r
10684 UNAS:   PUSH    TP,$TATOM\r
10685         PUSH    TP,EQUOTE UNASSIGNED-VARIABLE\r
10686         JRST    ER1ARG\r
10687 \r
10688 BADENV:\r
10689         PUSH    TP,$TATOM\r
10690         PUSH    TP,EQUOTE BAD-ENVIRONMENT\r
10691         JRST    CALER1\r
10692 \r
10693 FUNERR:\r
10694         PUSH    TP,$TATOM\r
10695         PUSH    TP,EQUOTE BAD-FUNARG\r
10696         JRST    CALER1\r
10697 \r
10698 \r
10699 MPD.0:\r
10700 MPD.1:\r
10701 MPD.2:\r
10702 MPD.3:\r
10703 MPD.4:\r
10704 MPD.5:\r
10705 MPD.6:\r
10706 MPD.7:\r
10707 MPD.8:\r
10708 MPD.9:\r
10709 MPD.10:\r
10710 MPD.11:\r
10711 MPD.12:\r
10712 MPD.13:\r
10713 MPD:    PUSH    TP,$TATOM\r
10714         PUSH    TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION\r
10715         JRST    CALER1\r
10716 \r
10717 NOBODY: PUSH    TP,$TATOM\r
10718         PUSH    TP,EQUOTE HAS-EMPTY-BODY\r
10719         JRST    CALER1\r
10720 \r
10721 BADCLS: PUSH    TP,$TATOM\r
10722         PUSH    TP,EQUOTE BAD-CLAUSE\r
10723         JRST    CALER1\r
10724 \r
10725 NXTAG:  PUSH    TP,$TATOM\r
10726         PUSH    TP,EQUOTE NON-EXISTENT-TAG\r
10727         JRST    CALER1\r
10728 \r
10729 NXPRG:  PUSH    TP,$TATOM\r
10730         PUSH    TP,EQUOTE NOT-IN-PROG\r
10731         JRST    CALER1\r
10732 \r
10733 NAPTL:\r
10734 NAPT:   PUSH    TP,$TATOM\r
10735         PUSH    TP,EQUOTE NON-APPLICABLE-TYPE\r
10736         JRST    CALER1\r
10737 \r
10738 NONEVT: PUSH    TP,$TATOM\r
10739         PUSH    TP,EQUOTE NON-EVALUATEABLE-TYPE\r
10740         JRST    CALER1\r
10741 \r
10742 \r
10743 NONATM: PUSH    TP,$TATOM\r
10744         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT\r
10745         JRST    CALER1\r
10746 \r
10747 \r
10748 ILLFRA: PUSH    TP,$TATOM\r
10749         PUSH    TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
10750         JRST    CALER1\r
10751 \r
10752 ILLSEG: PUSH    TP,$TATOM\r
10753         PUSH    TP,EQUOTE ILLEGAL-SEGMENT\r
10754         JRST    CALER1\r
10755 \r
10756 BADMAC: PUSH    TP,$TATOM\r
10757         PUSH    TP,EQUOTE BAD-USE-OF-MACRO\r
10758         JRST    CALER1\r
10759 \r
10760 BADFSB: PUSH    TP,$TATOM\r
10761         PUSH    TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR\r
10762         JRST    CALER1\r
10763 \r
10764 \r
10765 ER1ARG: PUSH    TP,(AB)\r
10766         PUSH    TP,1(AB)\r
10767         MOVEI   A,2\r
10768         JRST    CALER\r
10769 \r
10770 END\r
10771 \f\f\f\f\fTITLE OPEN - CHANNEL OPENER FOR MUDDLE\r
10772 \r
10773 RELOCATABLE\r
10774 \r
10775 ;C. REEVE  MARCH 1973\r
10776 \r
10777 .INSRT MUDDLE >\r
10778 \r
10779 SYSQ\r
10780 \r
10781 IFE ITS,[\r
10782 IF1,    .INSRT MUDSYS;STENEX >\r
10783 ]\r
10784 ;THIS PROGRAM HAS ENTRIES:  FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING,\r
10785 ;                           PRINTSTRING, NETSTATE, NETACC, NETS, AND ACCESS.\r
10786 \r
10787 ;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM.\r
10788 \r
10789 ;       FOPEN   - OPENS A FILE FOR EITHER READING OR WRITING.  IT TAKES\r
10790 ;               FIVE OPTINAL ARGUMENTS AS FOLLOWS:\r
10791 \r
10792 ;               FOPEN (<DIR>,<FILE NAME1>,<FILE NAME2>,<DEVICE>,<SYSTEM NAME>)\r
10793 ;\r
10794 ;               <DIR> - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ\r
10795 \r
10796 ;               <FILE NAME1> - FIRST FILE NAME.  DEFAULT INPUT OR OUTPUT.\r
10797 \r
10798 ;               <FILE NAME2> - SECOND FILE NAME.  DEFAULT MUDDLE.\r
10799 \r
10800 ;               <DEVICE> - DEVICE FROM WHICH TO OPEN.  DEFAULT IS DSK.\r
10801 \r
10802 ;               <SNAME> - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME.\r
10803 \r
10804 ;       FOPEN   RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL\r
10805 \r
10806 \r
10807 ;       FCLOSE  - CLOSES A FILE.  TAKES A CHANNEL OBJECT AS ITS ARGUMENT.  IT ALSO TAKES\r
10808 ;       ACCESS  - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES\r
10809 \r
10810 \r
10811 ; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION\r
10812 \r
10813 ;       CHANNO  ;ITS I/O CHANNEL NUMBER.  0 MEANS NOT A REAL CHANNEL.\r
10814 ;       DIRECT  ;DIRECTION (EITHER READ OR PRINT)\r
10815 ;       NAME1   ;FIRST NAME OF FILE AS OPENED.\r
10816 ;       NAME2   ;SECOND NAME OF FILE\r
10817 ;       DEVICE  ;DEVICE UPON WHICH THE CHANNEL IS OPEN\r
10818 ;       SNAME   ;DIRECTORY NAME\r
10819 ;       RNAME1  ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS)\r
10820 ;       RNAME2  ;REAL SECOND NAME\r
10821 ;       RDEVIC  ;REAL DEVICE\r
10822 ;       RSNAME  ;SYSTEM OR DIRECTORY NAME\r
10823 ;       STATUS  ;VARIOUS STATUS BITS\r
10824 ;       IOINS   ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER\r
10825 ;       ACCESS  ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO)\r
10826 ;       RADX    ;RADIX FOR CHANNELS NUMBER CONVERSION\r
10827 \r
10828 ;       *** THE FOLLOWING FIELDS FOR OUTPUT ONLY ***\r
10829 ;       LINLN   ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE\r
10830 ;       CHRPOS  ;CURRENT POSITION ON CURRENT LINE\r
10831 ;       PAGLN   ;LENGTH OF A PAGE\r
10832 ;       LINPOS  ;CURRENT LINE BEING WRITTEN ON\r
10833 \r
10834 ;       *** THE FOLLOWING FILEDS FOR INPUT ONLY ***\r
10835 ;       EOFCND  ;GETS EVALUATED  ON EOF\r
10836 ;       LSTCH   ;BACKUP CHARACTER\r
10837 ;       WAITNS  ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING\r
10838 ;       EXBUFR  ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST\r
10839 ;       BUFSTR  ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES\r
10840 \r
10841 ; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER\r
10842 BUFLNT==100\r
10843 \r
10844 ;THIS DEFINES BLOCK MODE BIT FOR OPENING\r
10845 BLOCKM==2               ;DEFINED IN THE LEFT HALF\r
10846 IMAGEM==4\r
10847 \r
10848 \f\r
10849 ;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME\r
10850 \r
10851         CHANLNT==4                      ;INITIAL CHANNEL LENGTH\r
10852 \r
10853 ; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS\r
10854 BUFRIN==-1      ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER\r
10855 SCRPTO==-3      ;SPECIAL HACK FOR SCRIPT CHANNELS\r
10856 PROCHN:\r
10857 \r
10858 IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR]\r
10859 [NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR]\r
10860 [RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR]\r
10861 [STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX]\r
10862 [ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]]\r
10863 \r
10864         IRP     B,C,[A]\r
10865                 B==CHANLNT-3\r
10866                 T!C,,0\r
10867                 0\r
10868                 .ISTOP\r
10869                 TERMIN\r
10870         CHANLNT==CHANLNT+2\r
10871 TERMIN\r
10872 \r
10873 \r
10874 ; EQUIVALANCES FOR CHANNELS\r
10875 \r
10876 EOFCND==LINLN\r
10877 LSTCH==CHRPOS\r
10878 WAITNS==PAGLN\r
10879 EXBUFR==LINPOS\r
10880 DISINF==BUFSTR  ;DISPLAY INFO\r
10881 INTFCN==BUFSTR  ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS\r
10882 \r
10883 \r
10884 ;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS\r
10885 \r
10886 IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR]\r
10887 A==.IRPCNT\r
10888 TERMIN\r
10889 \r
10890 EXTBFR==BYTPTR+1+<100./5>       ;LENGTH OF ADD'L BUFFER\r
10891 \r
10892 \r
10893 \r
10894 \r
10895 .GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS\r
10896 .GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR\r
10897 .GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR\r
10898 .GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS\r
10899 .GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO\r
10900 .GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,BYTDOP,TNXIN\r
10901 .GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO\r
10902 .GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS\r
10903 .GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL\r
10904 .GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1\r
10905 .GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT\r
10906 .GLOBAL TMTNXS,TNXSTR,RDEVIC\r
10907 \r
10908 \f\r
10909 .VECT.==40000\r
10910 \r
10911 ; PAIR MOVING MACRO\r
10912 \r
10913 DEFINE PMOVEM A,B\r
10914         MOVE    0,A\r
10915         MOVEM   0,B\r
10916         MOVE    0,A+1\r
10917         MOVEM   0,B+1\r
10918         TERMIN\r
10919 \r
10920 ; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN\r
10921 \r
10922 T.SPDL==0               ; SAVES P STACK BASE\r
10923 T.DIR==2                ; CONTAINS DIRECTION AND MODE\r
10924 T.NM1==4                ; NAME 1 OF FILE\r
10925 T.NM2==6                ; NAME 2 OF FILE\r
10926 T.DEV==10               ; DEVICE NAME\r
10927 T.SNM==12               ; SNAME\r
10928 T.XT==14                ; EXTRA CRUFT IF NECESSARY\r
10929 T.CHAN==16              ; CHANNEL AS GENERATED\r
10930 \r
10931 ; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES)\r
10932 \r
10933 S.DIR==0                ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY\r
10934 IFN ITS,[\r
10935 S.DEV==1                ; SIXBIT DEVICE RIGHT JUSTIFIED\r
10936 S.NM1==2                ; SIXBIT NAME1\r
10937 S.NM2==3                ; SIXBIT NAME2\r
10938 S.SNM==4                ; SIXBIT SNAME\r
10939 S.X1==5                 ; TEMPS\r
10940 S.X2==6\r
10941 S.X3==7\r
10942 ]\r
10943 \r
10944 IFE ITS,[\r
10945 S.DEV==1\r
10946 S.X1==2\r
10947 S.X2==3\r
10948 S.X3==4\r
10949 ]\r
10950 \r
10951 \r
10952 ; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES\r
10953 \r
10954 NOSTOR==400000          ; ON MEANS DONT BUILD NEW STRINGS\r
10955 MSTNET==200000          ; ON MEANS ONLY THE "NET" DEVICE CAN WIN\r
10956 SNSET==100000           ; FLAG, SNAME SUPPLIED\r
10957 DVSET==040000           ; FLAG, DEV SUPPLIED\r
10958 N2SET==020000           ; FLAG, NAME2 SET\r
10959 N1SET==010000           ; FLAG, NAME1 SET\r
10960 \r
10961 RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR\r
10962 ]\r
10963 \r
10964 \r
10965 ; TABLE OF LEGAL MODES\r
10966 \r
10967 MODES:  IRP A,,[READ,PRINT,READB,PRINTB,DISPLAY]\r
10968         SIXBIT /A/\r
10969         TERMIN\r
10970 NMODES==.-MODES\r
10971 \r
10972 ; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS\r
10973 \r
10974 IFN ITS,[\r
10975 \r
10976 DEVS:   IRP A,,[DSK,TPL,SYS,COM,TTY,USR,STY,[ST ],NET,DIS,E&S,INT,PTP,PTR\r
10977 [P  ],[DK ],[UT ],[T  ],NUL,[AI ]\r
10978 [ML ],[DM ],[AR ],ARC]B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OUSR,OSTY,OSTY,ONET,ODIS,ODIS\r
10979 OINT,OPTP,OPTP,ODSK,ODSK,OUTN,OTTY,ONUL,ODSK,ODSK,ODSK,ODSK,ODSK]\r
10980         B,,(SIXBIT /A/)\r
10981         TERMIN\r
10982 ]\r
10983 IFE ITS,[\r
10984 DEVS:   IRP A,,[DSK,TTY,INT,NET]B,,[ODSK,OTTY,OINT,ONET]\r
10985         B,,(SIXBIT /A/)\r
10986         TERMIN\r
10987 ]\r
10988 NDEVS==.-DEVS\r
10989 \r
10990 \r
10991 \f\r
10992 ;SUBROUTINE TO DO OPENING BEGINS HERE\r
10993 \r
10994 MFUNCTION NFOPEN,SUBR,[OPEN-NR]\r
10995 \r
10996         JRST    FOPEN1\r
10997 \r
10998 MFUNCTION FOPEN,SUBR,[OPEN]\r
10999 \r
11000 FOPEN1: ENTRY\r
11001         PUSHJ   P,MAKCHN        ;MAKE THE CHANNEL\r
11002         PUSHJ   P,OPNCH ;NOW OPEN IT\r
11003         JRST    FINIS\r
11004 \r
11005 ; SUBR TO JUST CREATE A CHANNEL\r
11006 \r
11007 MFUNCTION CHANNEL,SUBR\r
11008 \r
11009         ENTRY\r
11010         PUSHJ   P,MAKCHN\r
11011         MOVSI   A,TCHAN\r
11012         JRST    FINIS\r
11013 \r
11014 \r
11015 \f\r
11016 \r
11017 ; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT\r
11018 \r
11019 MAKCHN: PUSH    TP,$TPDL\r
11020         PUSH    TP,P            ; POINT AT CURRENT STACK BASE\r
11021         PUSH    TP,$TCHSTR\r
11022         PUSH    TP,CHQUOTE READ\r
11023         MOVEI   E,10            ; SLOTS OF TP NEEDED\r
11024         PUSH    TP,[0]\r
11025         SOJG    E,.-1\r
11026         MOVEI   E,0\r
11027         EXCH    E,(P)           ; GET RET ADDR IN E\r
11028 IFE ITS,        PUSH    P,[0]\r
11029 IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]]\r
11030         MOVE    B,IMQUOTE ATM\r
11031 IFN ITS,        PUSH    P,E\r
11032         PUSHJ   P,IDVAL1\r
11033         GETYP   0,A\r
11034         CAIN    0,TCHSTR\r
11035         JRST    MAK!ATM\r
11036 \r
11037         MOVE    A,$TCHSTR\r
11038 IFN ITS,        MOVE    B,CHQUOTE MDF\r
11039 IFE ITS,        MOVE    B,CHQUOTE TMDF\r
11040 MAK!ATM:\r
11041         MOVEM   A,T.!ATM(TB)\r
11042         MOVEM   B,T.!ATM+1(TB)\r
11043 IFN ITS,[\r
11044         POP     P,E\r
11045         PUSHJ   P,STRTO6        ; RESULT LEFT ON P STACK AS DESIRED\r
11046 ]\r
11047         TERMIN\r
11048         PUSH    TP,[0]          ; PUSH SLOTS\r
11049         PUSH    TP,[0]\r
11050 \r
11051         PUSH    P,[0]           ; EXT SLOTS\r
11052         PUSH    P,[0]\r
11053         PUSH    P,[0]\r
11054         PUSH    P,E             ; PUSH RETURN ADDRESS\r
11055         MOVEI   A,0\r
11056 \r
11057         JUMPGE  AB,MAKCH0       ; NO ARGS, ALREADY DONE\r
11058         GETYP   0,(AB)          ; 1ST ARG MUST BE A STRING\r
11059         CAIE    0,TCHSTR\r
11060         JRST    WTYP1\r
11061         MOVE    A,(AB)          ; GET ARG\r
11062         MOVE    B,1(AB)\r
11063         PUSHJ   P,CHMODE        ; CHECK OUT OPEN MODE\r
11064 \r
11065         PMOVEM  (AB),T.DIR(TB)  ; SAVE MODE NAME IN TEMPS\r
11066         ADD     AB,[2,,2]       ; BUMP PAST DIRECTION\r
11067         MOVEI   A,0\r
11068         JUMPGE  AB,MAKCH0       ; CHECK NAME1 BASED ON JUST MODE\r
11069 \r
11070         MOVEI   0,0             ; FLAGS PRESET\r
11071         PUSHJ   P,RGPARS        ; PARSE THE STRING(S)\r
11072         JRST    TMA\r
11073 \r
11074 ; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL\r
11075 \r
11076 MAKCH0:\r
11077 IFN ITS,[\r
11078         MOVE    C,T.SPDL+1(TB)\r
11079         HLRZS   D,S.DEV(C)      ; GET DEV\r
11080 ]\r
11081 IFE ITS,[\r
11082         MOVE    A,T.DEV(TB)\r
11083         MOVE    B,T.DEV+1(TB)\r
11084         PUSHJ   P,STRTO6\r
11085         POP     P,D\r
11086         HLRZS   D\r
11087         MOVE    C,T.SPDL+1(TB)\r
11088         MOVEM   D,S.DEV(C)\r
11089 ]\r
11090         CAIE    D,(SIXBIT /INT/); INTERNAL?\r
11091         JRST    CHNET           ; NO, MAYBE NET\r
11092         SKIPN   T.XT+1(TB)      ; WAS FCN SUPPLIED?\r
11093         JRST    TFA\r
11094 \r
11095 ; FALLS TROUGH IF SKIP\r
11096 \r
11097 \f\r
11098 \r
11099 ; NOW BUILD THE CHANNEL\r
11100 \r
11101 ARGSOK: MOVEI   A,CHANLNT       ; GET LENGTH\r
11102         PUSHJ   P,GIBLOK        ; GET A BLOCK OF STUFF\r
11103         ADD     B,[4,,4]        ; HIDE THE TTY BUFFER SLOT\r
11104         PUSH    TP,$TCHAN\r
11105         PUSH    TP,B\r
11106         HRLI    C,PROCHN        ; POINT TO PROTOTYPE\r
11107         HRRI    C,(B)           ; AND NEW ONE\r
11108         BLT     C,CHANLN-5(B)   ; CLOBBER\r
11109         MOVSI   C,TLIST         ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS\r
11110         MOVEM   C,SCRPTO-1(B)\r
11111 \r
11112 ; NOW BLT IN STUFF FROM THE STACK\r
11113 \r
11114         MOVSI   C,T.DIR(TB)     ; DIRECTION\r
11115         HRRI    C,DIRECT-1(B)\r
11116         BLT     C,SNAME(B)\r
11117         MOVEI   C,RNAME1-1(B)   ; NOW "REAL" SLOTS\r
11118         HRLI    C,T.NM1(TB)\r
11119         BLT     C,RSNAME(B)\r
11120         POPJ    P,\r
11121 \r
11122 ; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN\r
11123 \r
11124 CHNET:  CAIE    D,(SIXBIT /NET/)        ; IS IT NET\r
11125 IFN ITS,        JRST    MAKCH1\r
11126 IFE ITS,[\r
11127         JRST    ARGSOK\r
11128 ]\r
11129         MOVSI   D,TFIX          ; FOR TYPES\r
11130         MOVEI   B,T.NM1(TB)     ; MAKE SURE ALL ARE FIXED\r
11131         PUSHJ   P,CHFIX\r
11132         MOVEI   B,T.NM2(TB)\r
11133         PUSHJ   P,CHFIX\r
11134         MOVEI   B,T.SNM(TB)\r
11135         LSH     A,-1            ; SKIP DEV FLAG\r
11136         PUSHJ   P,CHFIX\r
11137         JRST    ARGSOK\r
11138 \r
11139 MAKCH1: TRNN    A,MSTNET        ; CANT HAVE SEEN A FIX\r
11140         JRST    ARGSOK\r
11141         JRST    WRONGT\r
11142 \r
11143 IFN ITS,[\r
11144 CHFIX:  TRNE    A,N1SET         ; SKIP IF NOT SPECIFIED\r
11145         JRST    CHFIX1\r
11146 ]\r
11147         SETOM   1(B)            ; SET TO -1\r
11148         SETOM   S.NM1(C)\r
11149         MOVEM   D,(B)           ; CORRECT TYPE\r
11150 IFE ITS,CHFIX:\r
11151         GETYP   0,(B)\r
11152         CAIE    0,TFIX\r
11153         JRST    PARSQ\r
11154 CHFIX1: ADDI    C,1             ; POINT TO NEXT FIELD\r
11155         LSH     A,-1            ; AND NEXT FLAG\r
11156         POPJ    P,\r
11157 PARSQ: CAIE     0,TCHSTR\r
11158         JRST    WRONGT\r
11159 IFE ITS,        POPJ    P,\r
11160 IFN ITS,[\r
11161         PUSH    P,A\r
11162         PUSH    P,C\r
11163         PUSH    TP,(B)\r
11164         PUSH    TP,1(B)\r
11165         SUBI    B,(TB)\r
11166         PUSH    P,B\r
11167         MCALL   1,PARSE\r
11168         GETYP   0,A\r
11169         CAIE    0,TFIX\r
11170         JRST    WRONGT\r
11171         POP     P,C\r
11172         ADDI    C,(TB)\r
11173         MOVEM   A,(C)\r
11174         MOVEM   B,1(C)\r
11175         POP     P,C\r
11176         POP     P,A\r
11177         POPJ    P,\r
11178 ]\r
11179 \f\r
11180 \r
11181 ; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE\r
11182 \r
11183 CHMODE: PUSHJ   P,CHMOD         ; DO IT\r
11184         MOVE    C,T.SPDL+1(TB)\r
11185         HRRZM   A,S.DIR(C)\r
11186         POPJ    P,\r
11187 \r
11188 CHMOD:  PUSHJ   P,STRTO6        ; TO SIXBIT\r
11189         POP     P,B             ; VALUE ENDSUP ON STACK, RESTORE IT\r
11190 \r
11191         CAME    B,[SIXBIT /PRINTO/]     ; KLUDGE TO MAKE PRINTO AS PRINTB\r
11192         JRST    .+3\r
11193         MOVEI   A,3             ; CODE FOR PRINTB\r
11194         POPJ    P,\r
11195 \r
11196         MOVSI   A,-NMODES       ; SCAN TO SEE IF LEGAL MODE\r
11197         CAME    B,MODES(A)\r
11198         AOBJN   A,.-1\r
11199         JUMPGE  A,WRONGD        ; ILLEGAL MODE NAME\r
11200         POPJ    P,\r
11201 \f\r
11202 IFN ITS,[\r
11203 ; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES\r
11204 \r
11205 RGPRS:  MOVEI   0,NOSTOR        ; DONT STORE STRINGS IF ENTER HERE\r
11206 \r
11207 RGPARS: HRLM    0,(P)           ; LH IS FLAGS FOR THIS PROG\r
11208         MOVSI   E,-4            ; FIELDS TO FILL\r
11209 \r
11210 RPARGL: GETYP   0,(AB)          ; GET TYPE\r
11211         CAIE    0,TCHSTR        ; STRING?\r
11212         JRST    ARGCLB          ; NO, JUST CLOBBER IT IN RAW\r
11213         JUMPGE  E,CPOPJ         ; DON'T DO ANY MORE\r
11214         PUSH    TP,(AB)         ; GET AN ARG\r
11215         PUSH    TP,1(AB)\r
11216 \r
11217 FPARS:  PUSH    TP,-1(TP)       ; ANOTHER COPY\r
11218         PUSH    TP,-1(TP)\r
11219         PUSHJ   P,FLSSP         ; NO LEADING SPACES\r
11220         MOVEI   A,0             ; WILL HOLD SIXBIT\r
11221         MOVEI   B,6             ; CHARS PER 6BIT WORD\r
11222         MOVE    C,[440600,,A]   ; BYTE POINTER INTO A\r
11223 \r
11224 FPARSL: HRRZ    0,-1(TP)        ; GET COUNT\r
11225         JUMPE   0,PARSD         ; DONE\r
11226         SOS     -1(TP)          ; COUNT\r
11227         ILDB    0,(TP)          ; CHAR TO 0\r
11228 \r
11229         CAIE    0,"\11            ; FILE NAME QUOTE?\r
11230         JRST    NOCNTQ\r
11231         HRRZ    0,-1(TP)\r
11232         JUMPE   0,PARSD\r
11233         SOS     -1(TP)\r
11234         ILDB    0,(TP)          ; USE THIS\r
11235         JRST    GOTCNQ\r
11236 \r
11237 NOCNTQ: CAIG    0,40            ; SPACE?\r
11238         JRST    NDFLD           ; YES, TERMINATE THIS FIELD\r
11239         CAIN    0,":            ; DEVICE ENDED?\r
11240         JRST    GOTDEV\r
11241         CAIN    0,";            ; SNAME ENDED\r
11242         JRST    GOTSNM\r
11243 \r
11244 GOTCNQ: PUSHJ   P,A0TO6         ; CONVERT TO 6BIT AND CHECK\r
11245 \r
11246         JUMPE   B,FPARSL        ; IGNORE IF AREADY HAVE 6\r
11247         IDPB    0,C\r
11248         SOJA    B,FPARSL\r
11249 \r
11250 ; HERE IF SPACE ENCOUNTERED\r
11251 \r
11252 NDFLD:  MOVEI   D,(E)           ; COPY GOODIE\r
11253         PUSHJ   P,FLSSP         ; FLUSH REDUNDANT SPACES\r
11254         JUMPE   0,PARSD         ; NO CHARS LEFT\r
11255 \r
11256 NFL0:   PUSH    P,A             ; SAVE SIXBIT WORD\r
11257         PUSHJ   P,6TOCHS        ; CONVERT TO STRING\r
11258         HRRZ    0,-1(TP)        ; RESTORE CHAR COUNT\r
11259 \r
11260 NFL2:   MOVEI   C,(D)           ; COPY REL PNTR\r
11261         SKIPGE  -1(P)           ; SKIP IF STRINGS TO BE STORED\r
11262         JRST    NFL3\r
11263         ASH     D,1             ; TIMES 2\r
11264         ADDI    D,T.NM1(TB)\r
11265         MOVEM   A,(D)           ; STORE\r
11266         MOVEM   B,1(D)\r
11267 NFL3:   MOVSI   A,N1SET         ; FLAG IT\r
11268         LSH     A,(C)\r
11269         IORM    A,-1(P)         ; AND CLOBBER\r
11270         MOVE    D,T.SPDL+1(TB)  ; GET P BASE\r
11271         POP     P,@SIXTBL(C)    ; AND STORE SIXBIT OF IT\r
11272 \r
11273         POP     TP,-2(TP)       ; MAKE NEW STRING POINTER\r
11274         POP     TP,-2(TP)\r
11275         JUMPE   0,.+3           ; SKIP IF NO MORE CHARS\r
11276         AOBJN   E,FPARS         ; MORE TO PARSE?\r
11277 CPOPJ:  POPJ    P,              ; RETURN, ALL DONE\r
11278 \r
11279         SUB     TP,[2,,2]       ; FLUSH OLD STRING\r
11280         ADD     E,[1,,1]\r
11281         ADD     AB,[2,,2]       ; BUMP ARG\r
11282         JUMPL   AB,RPARGL       ; AND GO ON\r
11283 CPOPJ1: AOS     A,(P)           ; PREPARE TO WIN\r
11284         HLRZS   A\r
11285         POPJ    P,\r
11286 \r
11287 \f\r
11288 \r
11289 ; HERE IF STRING HAS ENDED\r
11290 \r
11291 PARSD:  PUSH    P,A             ; SAVE 6 BIT\r
11292         MOVE    A,-3(TP)        ; CAN USE ARG STRING\r
11293         MOVE    B,-2(TP)\r
11294         MOVEI   D,(E)\r
11295         JRST    NFL2            ; AND CONTINUE\r
11296 \r
11297 ; HERE IF JUST READ DEV\r
11298 \r
11299 GOTDEV: MOVEI   D,2             ; CODE FOR DEVICE\r
11300         JRST    GOTFLD          ; GOT A FIELD\r
11301 \r
11302 ; HERE IF  JUST READ SNAME\r
11303 \r
11304 GOTSNM: MOVEI   D,3\r
11305 GOTFLD: PUSHJ   P,FLSSP\r
11306         SOJA    E,NFL0\r
11307 \r
11308 \r
11309 ; HERE FOR NON STRING ARG ENCOUNTERED\r
11310 \r
11311 ARGCLB: SKIPGE  (P)             ; IF NOT STORING, CONSIDER THIS THE END\r
11312 \r
11313         POPJ    P,\r
11314         MOVE    C,T.SPDL+1(TB)  ; GET P-BASE\r
11315         HLRZ    A,S.DEV(C)      ; GET DEVICE\r
11316         CAIE    A,(SIXBIT /INT/)        ; IS IT THE INTERNAL DEVICE\r
11317         JRST    TRYNET          ; NO, COUD BE NET\r
11318         MOVE    A,0             ; OFFNEDING TYPE TO A\r
11319         PUSHJ   P,APLQ          ; IS IT APPLICABLE\r
11320         JRST    NAPT            ; NO, LOSE\r
11321         PMOVEM  (AB),T.XT(TB)\r
11322         ADD     AB,[2,,2]       ; MUST BE LAST ARG\r
11323         JUMPL   AB,TMA\r
11324         JRST    CPOPJ1          ; ELSE SUCCESSFUL RETURN\r
11325 TRYNET: CAIE    0,TFIX          ; FOR NET DEV, ARGS MUST BE FIX\r
11326         JRST    WRONGT          ; TREAT AS WRONG TYPE\r
11327         MOVSI   A,MSTNET        ; BETTER BE NET EVENTUALLY\r
11328         IORM    A,(P)           ; STORE FLAGS\r
11329         MOVSI   A,TFIX\r
11330         MOVE    B,1(AB)         ; GET NUMBER\r
11331         MOVEI   0,(E)           ; MAKE SURE NOT DEVICE\r
11332         CAIN    0,2\r
11333         JRST    WRONGT\r
11334         PUSH    P,B             ; SAVE NUMBER\r
11335         MOVEI   D,(E)           ; SET FOR TABLE OFFSETS\r
11336         MOVEI   0,0\r
11337         ADD     TP,[4,,4]\r
11338         JRST    NFL2            ; GO CLOBBER IT AWAY\r
11339 ]\r
11340 \f\r
11341 \r
11342 ; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD\r
11343 \r
11344 FLSSP:  HRRZ    0,-1(TP)        ; GET CHR COUNNT\r
11345         JUMPE   0,CPOPJ         ; FINISHED STRING\r
11346 FLSS1:  MOVE    B,(TP)          ; GET BYTR\r
11347         ILDB    C,B             ; GETCHAR\r
11348         CAILE   C,40\r
11349         JRST    FLSS2\r
11350         MOVEM   B,(TP)          ; UPDATE BYTE POINTER\r
11351         SOJN    0,FLSS1\r
11352 \r
11353 FLSS2:  HRRM    0,-1(TP)        ; UPDATE STRING\r
11354         POPJ    P,\r
11355 \r
11356 IFN ITS,[\r
11357 ;TABLE FOR STFUFFING SIXBITS AWAY\r
11358 \r
11359 SIXTBL: S.NM1(D)\r
11360         S.NM2(D)\r
11361         S.DEV(D)\r
11362         S.SNM(D)\r
11363         S.X1(D)\r
11364 ]\r
11365 \r
11366 RDTBL:  RDEVIC(B)\r
11367         RNAME1(B)\r
11368         RNAME2(B)\r
11369         RSNAME(B)\r
11370 \r
11371 \r
11372 \f\r
11373 IFE ITS,[\r
11374 \r
11375 ; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING)\r
11376 \r
11377 RGPRS:  MOVEI   0,NOSTOR\r
11378 \r
11379 RGPARS: HRLM    0,(P)           ; SAVE FOR STORE CHECKING\r
11380         CAMGE   AB,[-7,,]       ; MULTI-STRING CASE POSSIBLE?\r
11381         JRST    TN.MLT          ; YES, GO PROCESS\r
11382 RGPRSS: GETYP   0,(AB)          ; CHECK ARG TYPE\r
11383         CAIE    0,TCHSTR\r
11384         JRST    WRONGT          ; FOR NOW ONLY STRING ARGS WIN\r
11385         PUSH    TP,(AB)\r
11386         PUSH    TP,1(AB)\r
11387         PUSHJ   P,FLSSP         ; FLUSH LEADING SPACES\r
11388         PUSHJ   P,RGPRS1\r
11389         ADD     AB,[2,,2]\r
11390 CHKLST: JUMPGE  AB,CPOPJ1\r
11391         SKIPGE  (P)             ; IF FROM OPEN, ALLOW ONE MORE\r
11392         POPJ    P,\r
11393         PMOVEM  (AB),T.XT(TB)\r
11394         ADD     AB,[2,,2]\r
11395         JUMPL   AB,TMA\r
11396 CPOPJ1: AOS     (P)\r
11397         POPJ    P,\r
11398 \r
11399 RGPRS1: PUSH    P,[0]           ; ALLOW A DEVICE SPEC\r
11400 TN.SNM: MOVE    A,(TP)\r
11401         HRRZ    0,-1(TP)\r
11402         JUMPE   0,RPDONE\r
11403         ILDB    A,A\r
11404         CAIE    A,"<            ; START "DIRECTORY" ?\r
11405         JRST    TN.N1           ; NO LOOK FOR NAME1\r
11406         SETOM   (P)             ; DEV NOT ALLOWED\r
11407         IBP     (TP)            ; SKIP CHAR\r
11408         SOS     -1(TP)\r
11409         PUSHJ   P,TN.CNT        ; COUNT CHARS TO ">"\r
11410         JUMPE   B,ILLNAM        ; RAN OUT\r
11411         CAIE    A,">            ; SKIP IF WINS\r
11412         JRST    ILLNAM\r
11413         PUSHJ   P,TN.CPS        ; COPY TO NEW STRING\r
11414         MOVEM   A,T.SNM(TB)\r
11415         MOVEM   B,T.SNM+1(TB)\r
11416 \r
11417 TN.N1:  PUSHJ   P,TN.CNT\r
11418         JUMPE   B,RPDONE\r
11419         CAIE    A,":            ; GOT A DEVICE\r
11420         JRST    TN.N11\r
11421         SKIPE   (P)\r
11422         JRST    ILLNAM\r
11423         SETOM   (P)\r
11424         PUSHJ   P,TN.CPS\r
11425         MOVEM   A,T.DEV(TB)\r
11426         MOVEM   B,T.DEV+1(TB)\r
11427         JRST    TN.SNM          ; NOW LOOK FOR SNAME\r
11428 \r
11429 TN.N11: CAIE    A,">\r
11430         CAIN    A,"<\r
11431         JRST    ILLNAM\r
11432         MOVEM   A,(P)           ; SAVE END CHAR\r
11433         PUSHJ   P,TN.CPS        ; GEN STRING\r
11434         MOVEM   A,T.NM1(TB)\r
11435         MOVEM   B,T.NM1+1(TB)\r
11436 \r
11437 TN.N2:  SKIPN   A,(P)           ; GET CHAR BACK\r
11438         JRST    RPDONE\r
11439         CAIN    A,";            ; START VERSION?\r
11440         JRST    .+3\r
11441         CAIE    A,".            ; START NAME2?\r
11442         JRST    ILLNAM          ; I GIVE UP!!!\r
11443         HRRZ    B,-1(TP)        ; GET RMAINS OF STRING\r
11444         PUSHJ   P,TN.CPS        ; AND COPY IT\r
11445         MOVEM   A,T.NM2(TB)\r
11446         MOVEM   B,T.NM2+1(TB)\r
11447 RPDONE: SUB     P,[1,,1]        ; FLUSH TEMP\r
11448         SUB     TP,[2,,2]\r
11449 CPOPJ:  POPJ    P,\r
11450 \r
11451 TN.CNT: HRRZ    0,-1(TP)        ; CHAR COUNT\r
11452         MOVE    C,(TP)          ; BPTR\r
11453         MOVEI   B,0             ; INIT COUNT TO 0\r
11454 \r
11455 TN.CN1: MOVEI   A,0             ; IN CASE RUN OUT\r
11456         SOJL    0,CPOPJ         ; RUN OUT?\r
11457         ILDB    A,C             ; TRY ONE\r
11458         CAIE    A,"\16            ; TNEX FILE QUOTE?\r
11459         JRST    TN.CN2\r
11460         SOJL    0,CPOPJ\r
11461         IBP     C               ; SKIP QUOTED CHAT\r
11462         ADDI    B,2\r
11463         JRST    TN.CN1\r
11464 \r
11465 TN.CN2: CAIE    A,"<\r
11466         CAIN    A,">\r
11467         POPJ    P,\r
11468 \r
11469         CAIE    A,".\r
11470         CAIN    A,";\r
11471         POPJ    P,\r
11472         CAIN    A,":\r
11473         POPJ    P,\r
11474         AOJA    B,TN.CN1\r
11475 \r
11476 TN.CPS: PUSH    P,B             ; # OF CHARS\r
11477         MOVEI   A,4(B)          ; ADD 4 TO B IN A\r
11478         IDIVI   A,5\r
11479         PUSHJ   P,IBLOCK        ; GET BLOCK OF WORDS FOR STRING\r
11480 \r
11481         POP     P,C             ; CHAR COUNT BACK\r
11482         HRLI    B,440700\r
11483         MOVSI   A,TCHSTR\r
11484         HRRI    A,(C)           ; CHAR STRING\r
11485         MOVE    D,B             ; COPY BYTER\r
11486 \r
11487         JUMPE   C,CPOPJ\r
11488         ILDB    0,(TP)          ; GET CHAR\r
11489         IDPB    0,D             ; AND STROE\r
11490         SOJG    C,.-2\r
11491 \r
11492         MOVNI   C,(A)           ; - LENGTH TO C\r
11493         ADDB    C,-1(TP)        ; DECREMENT WORDS COUNT\r
11494         TRNN    C,-1            ; SKIP IF EMPTY\r
11495         POPJ    P,\r
11496         IBP     (TP)\r
11497         SOS     -1(TP)          ; ELSE FLUSH TERMINATOR\r
11498         POPJ    P,\r
11499 \r
11500 ILLNAM: PUSH    TP,$TATOM\r
11501         PUSH    TP,EQUOTE ILLEGAL-TENEX-FILE-NAME\r
11502         JRST    CALER1\r
11503 \r
11504 TN.MLT: MOVEI   A,(AB)\r
11505         HRLI    A,-10\r
11506 \r
11507 TN.ML1: GETYP   0,(A)\r
11508         CAIE    0,TFIX\r
11509         CAIN    0,TCHSTR\r
11510         JRST    .+2\r
11511         JRST    RGPRSS          ; ASSUME SINGLE STRING \r
11512         ADD     A,[2,,2]\r
11513         JUMPL   A,TN.ML1\r
11514 \r
11515         MOVEI   A,T.NM1(TB)\r
11516         HRLI    A,(AB)\r
11517         BLT     A,T.SNM+1(TB)   ; BLT 'EM IN\r
11518         ADD     AB,[10,,10]     ; SKIP THESE GUYS\r
11519         JRST    CHKLST\r
11520 \r
11521 ]\r
11522 \f\r
11523 \r
11524 ; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE.  NAMES ARE ASSUMED TO ALREADY\r
11525 ; BE ON BOTH TP STACK AND P STACK\r
11526 \r
11527 OPNCH:  MOVE    C,T.SPDL+1(TB)  ; GET PDL BASE\r
11528         HRRZ    A,S.DIR(C)\r
11529         ANDI    A,1             ; JUST WANT I AND O\r
11530         HRLM    A,S.DEV(C)\r
11531 ;       .TRANS  S.DEV(C)        ; UNDO ANY TRANSLATIONS\r
11532 ;       JRST    TRLOST          ; COMPLAIN\r
11533 \r
11534         HRRZ    A,S.DEV(C)      ; GET SIXBIT DEVICE CODE\r
11535         MOVEI   E,(A)           ; COPY TO E\r
11536         ANDI    E,777700        ; WITHOUT LAST\r
11537         MOVEI   D,(E)           ; AND D\r
11538         ANDI    D,770000        ; WITH JUST LETTER\r
11539         MOVSI   B,-NDEVS        ; AOBJN COUNTER\r
11540 \r
11541 DEVLP:  HRRZ    0,DEVS(B)       ; GET ONE\r
11542         CAIN    0,(A)           ; FULL DEV?\r
11543         JRST    DISPA\r
11544         CAIN    0,(D)           ; ONE LETTER\r
11545         JRST    CH2DIG\r
11546         CAIN    0,(E)           ; 2 LTTERS\r
11547         JRST    CH1DIG\r
11548 NXTDEV: AOBJN   B,DEVLP         ; LOOP THRU\r
11549 \r
11550 IFN ITS,[\r
11551 OUSR:   HRRZ    A,S.DIR(C)      ; BLOCK OR UNIT?\r
11552         TRNE    A,2             ; SKIP IF UNIT\r
11553         JRST    ODSK\r
11554         PUSHJ   P,OPEN1         ; OPEN IT\r
11555         PUSHJ   P,FIXREA        ; AND READCHST IT\r
11556         MOVE    B,T.CHAN+1(TB)  ; RESTORE CHANNEL\r
11557         MOVE    0,[PUSHJ P,DOIOT]       ; GET AN IOINS\r
11558         MOVEM   0,IOINS(B)\r
11559         MOVE    C,T.SPDL+1(TB)\r
11560         HRRZ    A,S.DIR(C)\r
11561         TRNN    A,1\r
11562         JRST    EOFMAK\r
11563         MOVEI   0,80.\r
11564         MOVEM   0,LINLN(B)\r
11565         JRST    OPNWIN\r
11566 \r
11567 OSTY:   HLRZ    A,S.DEV(C)\r
11568         IORI    A,10            ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT)\r
11569         HRLM    A,S.DEV(C)\r
11570         JRST    OUSR\r
11571 ]\r
11572 IFE ITS,[\r
11573         PUSH    TP,$TATOM\r
11574         PUSH    TP,EQUOTE NO-SUCH-DEVICE?\r
11575         JRST    CALER1\r
11576 ]\r
11577 \r
11578 ; MAKE SURE DIGITS EXIST\r
11579 \r
11580 CH2DIG: LDB     0,[60600,,A]\r
11581         CAIG    0,'9            ; CHECK DIGITNESS\r
11582         CAIGE   0,'0\r
11583         JRST    NXTDEV          ; LOSER\r
11584 \r
11585 CH1DIG: LDB     0,[600,,A]      ; LAST CHAR\r
11586         CAIG    0,'9\r
11587         CAIGE   0,'0\r
11588         JRST    NXTDEV\r
11589 \r
11590 ; HERE TO DISPATCH IF SUCCESSFUL\r
11591 \r
11592 DISPA:  HLRZ    B,DEVS(B)\r
11593 IFN ITS,[\r
11594         HRRZ    A,S.DIR(C)      ; GET DIR OF OPEN\r
11595         CAIN    A,5             ; IS IT DISPLAY\r
11596         CAIN    B,ODIS          ; BETTER BE OPENING DISPLAY\r
11597         JRST    (B)             ; GO TO HANDLER\r
11598         JRST    WRONGD\r
11599 ]\r
11600 IFE ITS,        JRST    (B)\r
11601 \r
11602 \f\r
11603 IFN ITS,[\r
11604 \r
11605 ; DISK DEVICE OPNER COME HERE\r
11606 \r
11607 ODSK:   MOVE    A,S.SNM(C)      ; GET SNAME\r
11608         .SUSET  [.SSNAM,,A]     ; CLOBBER IT\r
11609         PUSHJ   P,OPEN0         ; DO REAL LIVE OPEN\r
11610 ]\r
11611 IFE ITS,[\r
11612 \r
11613 ; TENEX DISK FILE OPENER\r
11614 \r
11615 ODSK:   MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL\r
11616         PUSHJ   P,STSTK         ; EXPAND STRING ONTO STACK (E POINTS TO OLD P)\r
11617         MOVE    A,DIRECT-1(B)\r
11618         MOVE    B,DIRECT(B)\r
11619         PUSHJ   P,STRTO6        ; GET DIR NAME\r
11620         POP     P,C\r
11621         MOVE    D,T.SPDL+1(TB)\r
11622         HRRZ    D,S.DIR(D)\r
11623         CAMN    C,[SIXBIT /PRINTO/]\r
11624         IORI    D,100           ; TURN ON BIT TO SAY USE OLD FILE\r
11625         MOVSI   A,101           ; START SETTING UP BITS EXTRA BIT FOR MSB\r
11626         TRNE    D,1             ; SKIP IF INPUT\r
11627         TRNE    D,100           ; WITE OVER?\r
11628         TLOA    A,100000        ; FORCE NEW VERSION\r
11629         TLO     A,400000        ; FORCE OLD\r
11630         HRROI   B,1(E)          ; POIT TO STRING\r
11631         GTJFN\r
11632         TDZA    0,0             ; SAVE FACT OF NO SKIP\r
11633         MOVEI   0,1             ; INDICATE SKIPPED\r
11634         MOVE    P,E             ; RESTORE PSTACK\r
11635         JUMPE   0,GTJLOS        ; FIND OUT WHAT HAPPENED\r
11636 \r
11637         MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL\r
11638         HRRZM   A,CHANNO(B)     ; SAVE IT\r
11639         ANDI    A,-1            ; READ Y TO DO OPEN\r
11640         MOVSI   B,440000        ; USE 36. BIT BYES\r
11641         HRRI    B,200000        ; ASSUME READ\r
11642         TRNE    D,1             ; SKIP IF READ\r
11643         HRRI    B,300000        ; WRITE BIT\r
11644         HRRZ    0,FSAV(TB)              ; SEE IF REF DATE HACK\r
11645         CAIN    0,NFOPEN\r
11646         TRO     B,400           ; SET DON'T MUNG REF DATE BIT\r
11647         OPENF\r
11648         JRST    OPFLOS\r
11649         MOVEI   0,C.OPN+C.READ\r
11650         TRNE    D,1             ; SKIP FOR READ\r
11651         MOVEI   0,C.OPN+C.PRIN\r
11652         MOVE    B,T.CHAN+1(TB)\r
11653         HRRM    0,-4(B)         ; MUNG THOSE BITS\r
11654         ASH     A,1             ; POINT TO SLOT\r
11655         ADDI    A,CHNL0(TVP)    ; TO REAL SLOT\r
11656         MOVEM   B,1(A)          ; SAVE CHANNEL\r
11657         PUSHJ   P,TMTNXS        ; GET STRING FROM TENEX\r
11658         MOVE    B,CHANNO(B)     ; JFN TO A\r
11659         HRROI   A,1(E)          ; BASE OF STRING\r
11660         MOVE    C,[111111,,140001]      ; WEIRD CONTROL BITS\r
11661         JFNS                    ; GET STRING\r
11662         MOVEI   B,1(E)          ; POINT TO START OF STRING\r
11663         SUBM    P,E             ; RELATIVIZE E\r
11664         PUSHJ   P,TNXSTR        ; MAKE INTO A STRING\r
11665         SUB     P,E             ; BACK TO NORMAL\r
11666         PUSH    TP,A\r
11667         PUSH    TP,B\r
11668         PUSHJ   P,RGPRS1        ; PARSE INTO FIELDS\r
11669         MOVE    B,T.CHAN+1(TB)\r
11670         MOVEI   C,RNAME1-1(B)\r
11671         HRLI    C,T.NM1(TB)\r
11672         BLT     C,RSNAME(B)\r
11673         JRST    OPBASC\r
11674 OPFLOS: MOVEI   C,(A)           ; SAVE ERROR CODE\r
11675         MOVE    B,T.CHAN+1(TB)\r
11676         HRRZ    A,CHANNO(B)     ; JFN BACK TO A\r
11677         RLJFN                   ; TRY TO RELEASE IT\r
11678         JFCL\r
11679         MOVEI   A,(C)           ; ERROR CODE BACK TO A\r
11680 \r
11681 GTJLOS: PUSHJ   P,TGFALS        ; GET A FALSE WITH REASON\r
11682         JRST    OPNRET\r
11683 \r
11684 STSTK:  PUSH    TP,$TCHAN\r
11685         PUSH    TP,B\r
11686         MOVEI   A,4+5           ; COUNT CHARS NEEDED (NEED LAST 0 BYTE)\r
11687         MOVE    B,(TP)\r
11688         ADD     A,RDEVIC-1(B)\r
11689         ADD     A,RNAME1-1(B)\r
11690         ADD     A,RNAME2-1(B)\r
11691         ADD     A,RSNAME-1(B)\r
11692         ANDI    A,-1            ; TO 18 BITS\r
11693         IDIVI   A,5             ; TO WORDS NEEDED\r
11694         POP     P,C             ; SAVE RET ADDR\r
11695         MOVE    E,P             ; SAVE POINTER\r
11696         PUSH    P,[0]           ; ALOCATE SLOTS\r
11697         SOJG    A,.-1\r
11698         PUSH    P,C             ; RET ADDR BACK\r
11699         INTGO                   ; IN CASE OVERFLEW\r
11700         MOVE    B,(TP)          ; IN CASE GC'D\r
11701         MOVE    D,[440700,,1(E)]        ; BYTE POINTER TO IT\r
11702         MOVEI   A,RDEVIC-1(B)\r
11703         PUSHJ   P,MOVSTR        ; FLUSH IT ON\r
11704         MOVEI   A,":\r
11705         IDPB    A,D\r
11706         HRRZ    A,RSNAME-1(B)   ; ANY SNAME AT ALL?\r
11707         JUMPE   A,ST.NM1        ; NOPE, CANT HACK WITH IT\r
11708         MOVEI   A,"<\r
11709         IDPB    A,D\r
11710         MOVEI   A,RSNAME-1(B)\r
11711         PUSHJ   P,MOVSTR        ; SNAME UP\r
11712         MOVEI   A,">\r
11713         IDPB    A,D\r
11714         MOVEI   A,RNAME1-1(B)\r
11715         PUSHJ   P,MOVSTR\r
11716         MOVEI   A,".\r
11717         IDPB    A,D\r
11718 ST.NM1: MOVEI   A,RNAME2-1(B)\r
11719         PUSHJ   P,MOVSTR\r
11720         SUB     TP,[2,,2]\r
11721         POPJ    P,\r
11722 \r
11723 MOVSTR: HRRZ    0,(A)           ; CHAR COUNT\r
11724         MOVE    A,1(A)          ; BYTE POINTER\r
11725         SOJL    0,CPOPJ\r
11726         ILDB    C,A             ; GET CHAR\r
11727         IDPB    C,D             ; MUNG IT UP\r
11728         JRST    .-3\r
11729 \r
11730 ; MAKE A TENEX ERROR MESSAGE STRING\r
11731 \r
11732 TGFALS: PUSH    P,A             ; SAVE ERROR CODE\r
11733         PUSHJ   P,TMTNXS        ; STRING ON STACK\r
11734         HRROI   A,1(E)          ; POINT TO SPACE\r
11735         MOVE    B,(E)           ; ERROR CODE\r
11736         HRLI    B,400000        ; FOR ME\r
11737         MOVSI   C,-100.         ; MAX CHARS\r
11738         ERSTR                   ; GET TENEX STRING\r
11739         JRST    TGFLS1\r
11740         JRST    TGFLS1\r
11741 \r
11742         MOVEI   B,1(E)          ; A AND B BOUND STRING\r
11743         SUBM    P,E             ; RELATIVIZE E\r
11744         PUSHJ   P,TNXSTR        ; BUILD STRING\r
11745         SUB     P,E             ; P BACK TO NORMAL\r
11746 TGFLS2: SUB     P,[1,,1]        ; FLUSH ERROR CODE SLOT\r
11747         MOVE    C,A\r
11748         MOVE    D,B\r
11749         PUSHJ   P,INCONS        ; BUILD LIST\r
11750         MOVSI   A,TFALSE        ; MAKE IT FALSE\r
11751         POPJ    P,\r
11752 \r
11753 TGFLS1: MOVE    P,E             ; RESET STACK\r
11754         MOVE    A,$TCHSTR\r
11755         MOVE    B,CHQUOTE UNKNOWN PROBLEM IN I/O\r
11756         JRST    TGFLS2\r
11757 \r
11758 ]\r
11759 ; OTHER BUFFERED DEVICES JOIN HERE\r
11760 \r
11761 OPDSK1:\r
11762 IFN ITS,[\r
11763         PUSHJ   P,FIXREA        ; STORE THE "REAL" NAMES INTO THE CHANNEL\r
11764 ]\r
11765 OPBASC: MOVE    C,T.SPDL+1(TB)  ; C WAS CLOBBERED, GET IT BACK\r
11766         HRRZ    A,S.DIR(C)      ; FIND OUT IF OPEN IS ASCII OR WORD\r
11767         TRZN    A,2             ; SKIP IF BINARY\r
11768         PUSHJ   P,OPASCI        ; DO IT FOR ASCII\r
11769 \r
11770 ; NOW SET UP IO INSTRUCTION FOR CHANNEL\r
11771 \r
11772 MAKION: MOVE    B,T.CHAN+1(TB)\r
11773         MOVEI   C,GETCHR\r
11774         JUMPE   A,MAKIO1        ; JUMP IF INPUT\r
11775         MOVEI   C,PUTCHR        ; ELSE GET INPUT\r
11776         MOVEI   0,80.           ; DEFAULT LINE LNTH\r
11777         MOVEM   0,LINLN(B)\r
11778         MOVSI   0,TFIX\r
11779         MOVEM   0,LINLN-1(B)\r
11780 MAKIO1:\r
11781         HRLI    C,(PUSHJ P,)\r
11782         MOVEM   C,IOINS(B)      ; STORE IT\r
11783         JUMPN   A,OPNWIN        ; GET AN EOF FORM FOR INPUT CHANNEL\r
11784 \r
11785 ; HERE TO CONS UP <ERROR END-OF-FILE>\r
11786 \r
11787 EOFMAK: MOVSI   C,TATOM\r
11788         MOVE    D,EQUOTE END-OF-FILE\r
11789         PUSHJ   P,INCONS\r
11790         MOVEI   E,(B)\r
11791         MOVSI   C,TATOM\r
11792         MOVE    D,IMQUOTE ERROR\r
11793         PUSHJ   P,ICONS\r
11794         MOVE    D,T.CHAN+1(TB)  ; RESTORE CHANNEL\r
11795         MOVSI   0,TFORM\r
11796         MOVEM   0,EOFCND-1(D)\r
11797         MOVEM   B,EOFCND(D)\r
11798 \r
11799 OPNWIN: MOVEI   0,10.           ; SET UP RADIX\r
11800         MOVSI   A,TCHAN         ; OPEN SUCCEEDED, RET CHANNEL\r
11801         MOVE    B,T.CHAN+1(TB)\r
11802         MOVEM   0,RADX(B)\r
11803 \r
11804 OPNRET: MOVE    C,(P)           ; RET ADDR\r
11805         SUB     P,[S.X3+2,,S.X3+2]\r
11806         SUB     TP,[T.CHAN+2,,T.CHAN+2]\r
11807         JRST    (C)\r
11808 \f\r
11809 \r
11810 ; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O\r
11811 \r
11812 OPASCI: PUSH    P,A             ; CONTAINS MODE, SAVE IT\r
11813         MOVEI   A,BUFLNT        ; GET SIZE  OF BUFFER\r
11814         PUSHJ   P,IBLOCK        ; GET STORAGE\r
11815         MOVSI   0,TWORD+.VECT.  ; SET UTYPE\r
11816         MOVEM   0,BUFLNT(B)     ; AND STORE\r
11817         MOVSI   A,TCHSTR\r
11818         SKIPE   (P)             ; SKIP IF INPUT\r
11819         JRST    OPASCO\r
11820         MOVEI   D,BUFLNT(B)     ; REST BYTE POINTER\r
11821 OPASCA: HRLI    D,440700\r
11822         MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL BACK\r
11823         MOVEI   0,C.BUF\r
11824         IORM    0,-4(B)         ; TURN ON BUFFER BIT\r
11825         MOVEM   A,BUFSTR-1(B)\r
11826         MOVEM   D,BUFSTR(B)     ; CLOBBER\r
11827         POP     P,A\r
11828         POPJ    P,\r
11829 \r
11830 OPASCO: HRROI   C,777776\r
11831         MOVEM   C,(B)           ; -1 THE BUFFER (LEAVE OFF LOW BIT)\r
11832         MOVSI   C,(B)\r
11833         HRRI    C,1(B)          ; BUILD BLT POINTER\r
11834         BLT     C,BUFLNT-1(B)   ; ZAP\r
11835         MOVEI   D,(B)           ; START MAKING STRING POINTER\r
11836         HRRI    A,BUFLNT*5      ; SET UP CHAR COUNT\r
11837         JRST    OPASCA\r
11838 \f\r
11839 \r
11840 ; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.)\r
11841 \r
11842 ONUL:\r
11843 OPTP:\r
11844 OPTR:   PUSHJ   P,OPEN0         ; SET UP MODE AND OPEN\r
11845         SETZM   S.NM1(C)        ; CLOBBER UNINTERESTING FIELDS\r
11846         SETZM   S.NM2(C)\r
11847         SETZM   S.SNM(C)\r
11848         JRST    OPDSK1\r
11849 \r
11850 ; OPEN DEVICES THAT IGNORE SNAME\r
11851 \r
11852 OUTN:   PUSHJ   P,OPEN0\r
11853         SETZM   S.SNM(C)\r
11854         JRST    OPDSK1\r
11855 \r
11856 ; OPEN THE DISPLAY DEVICE\r
11857 \r
11858 ODIS:   MOVEI   B,T.DIR(TB)     ; GET CHANNEL\r
11859         PUSHJ   P,CHRWRD        ; TO ASCII\r
11860         JFCL\r
11861         MOVE    E,B             ; DIR TO E\r
11862         MOVE    B,T.CHAN+1(TB)  ; CHANNEL\r
11863         MOVE    0,[PUSHJ P,DCHAR]       ; IOINS\r
11864         CAIN    A,1\r
11865         MOVEM   0,IOINS(B)\r
11866         PUSHJ   P,DISOPN\r
11867         JRST    DISLOS          ; LOSER\r
11868 \r
11869         MOVE    D,T.CHAN+1(TB)  ; GET CHANNEL\r
11870         MOVEI   0,C.OPN+C.PRIN\r
11871         HRRM    0,-4(D)\r
11872         MOVEM   A,DISINF-1(D)   ; AND STORE\r
11873         MOVEM   B,DISINF(D)\r
11874         SETZM   CHANNO(D)       ; NO REAL CHANNEL\r
11875         MOVEI   0,DISLNL\r
11876         MOVEM   0,LINLN(D)\r
11877         MOVEI   0,DISPGL\r
11878         MOVEM   0,PAGLN(D)\r
11879         MOVEI   0,10.           ; SET RADIX\r
11880         MOVEM   0,RADX(D)\r
11881         JRST    SAVCHN          ; ADD TO CHANNEL LIST\r
11882 \f\r
11883 \r
11884 ; INTERNAL CHANNEL OPENER\r
11885 \r
11886 OINT:   HRRZ    A,S.DIR(C)      ; CHECK DIR\r
11887         CAIL    A,2             ; READ/PRINT?\r
11888         JRST    WRONGD          ; NO, LOSE\r
11889 \r
11890         MOVE    0,INTINS(A)     ; GET INS\r
11891         MOVE    D,T.CHAN+1(TB)  ; AND CHANNEL\r
11892         MOVEM   0,IOINS(D)      ; AND CLOBBER\r
11893         MOVEI   0,C.OPN+C.READ\r
11894         TRNE    A,1\r
11895         MOVEI   0,C.OPN+C.PRIN\r
11896         HRRM    0,-4(D)\r
11897         SETOM   STATUS(D)       ; MAKE SURE NOT AA TTY\r
11898         PMOVEM  T.XT(TB),INTFCN-1(D)\r
11899 \r
11900 ; HERE TO SAVE PSEUDO CHANNELS\r
11901 \r
11902 SAVCHN: HRRZ    E,CHNL0+1(TVP)  ; POINT TO CURRENT LIST\r
11903         MOVSI   C,TCHAN\r
11904         PUSHJ   P,ICONS         ; CONS IT ON\r
11905         HRRZM   B,CHNL0+1(TVP)\r
11906         JRST    OPNWIN\r
11907 \r
11908 ; INT DEVICE I/O INS\r
11909 \r
11910 INTINS: PUSHJ   P,GTINTC\r
11911         PUSHJ   P,PTINTC\r
11912 \f\r
11913 \r
11914 ; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET)\r
11915 \r
11916 IFN ITS,[\r
11917 ONET:   HRRZ    A,S.DIR(C)      ; DIRECTION CODE\r
11918         CAILE   A,1             ; ASCII ?\r
11919         IORI    A,4             ; TURN ON IMAGE BIT\r
11920         SKIPGE  S.NM1(C)        ; NAME1 I.E. LOCAL HOST GIVEN\r
11921         IORI    A,10            ; NO, WE WILL LET ITS GIVE US ONE\r
11922         SKIPGE  S.NM2(C)        ; NORMAL OR "LISTEN"\r
11923         IORI    A,20            ; TURN ON LISTEN BIT\r
11924         MOVEI   0,7             ; DEFAULT BYTE SIZE\r
11925         TRNE    A,2             ; UNLESS\r
11926         MOVEI   0,36.           ; IMAGE WHICH IS 36\r
11927         SKIPN   T.XT(TB)        ; BYTE SIZE GIVEN?\r
11928         MOVEM   0,S.X1(C)       ; NO, STORE DEFAULT\r
11929         SKIPG   D,S.X1(C)       ; BYTE SIZE REASONABLE?\r
11930         JRST    RBYTSZ          ; NO <0, COMPLAIN\r
11931         TRNE    A,2             ; SKIP TO CHECK ASCII\r
11932         JRST    ONET2           ; CHECK IMAGE\r
11933         CAIN    D,7             ; 7-BIT WINS\r
11934         JRST    ONET1\r
11935         CAIE    D,44            ; 36-BIT INDICATES BLOCK ASCII MODE\r
11936         JRST    .+3\r
11937         IORI    A,2             ; SET BLOCK FLAG\r
11938         JRST    ONET1\r
11939         IORI    A,40            ; USE 8-BIT MODE\r
11940         CAIN    D,10            ; IS IT RIGHT\r
11941         JRST    ONET1           ; YES\r
11942 ]\r
11943 \r
11944 RBYTSZ: PUSH    TP,$TATOM       ; CALL ERROR\r
11945         PUSH    TP,EQUOTE BYTE-SIZE-BAD\r
11946         JRST    CALER1\r
11947 \r
11948 IFN ITS,[\r
11949 ONET2:  CAILE   D,36.           ; IMAGE SIZE REASONABLE?\r
11950         JRST    RBYTSZ          ; NO\r
11951         CAIN    D,36.           ; NORMAL\r
11952         JRST    ONET1           ; YES, DONT SET FIELD\r
11953 \r
11954         ASH     D,9.            ; POSITION FOR FIELD\r
11955         IORI    A,40(D)         ; SET IT AND ITS BIT\r
11956 \r
11957 ONET1:  HRLM    A,S.DEV(C)      ; CLOBBER OPEN BLOCK\r
11958         MOVE    E,A             ; SAVE BLOCK MODE INFO\r
11959         PUSHJ   P,OPEN1         ; DO THE OPEN\r
11960         PUSH    P,E\r
11961 \r
11962 ; CLOBBER REAL SLOTS FOR THE OPEN\r
11963 \r
11964         MOVEI   A,3             ; GET STATE VECTOR\r
11965         PUSHJ   P,IBLOCK\r
11966         MOVSI   A,TUVEC\r
11967         MOVE    D,T.CHAN+1(TB)\r
11968         MOVEM   A,BUFRIN-1(D)\r
11969         MOVEM   B,BUFRIN(D)\r
11970         MOVSI   A,TFIX+.VECT.   ; SET U TYPE\r
11971         MOVEM   A,3(B)\r
11972         MOVE    C,T.SPDL+1(TB)\r
11973         MOVE    B,T.CHAN+1(TB)\r
11974 \r
11975         PUSHJ   P,INETST                ; GET STATE\r
11976 \r
11977         POP     P,A             ; IS THIS BLOCK MODE\r
11978         MOVEI   0,80.           ; POSSIBLE LINE LENGTH\r
11979         TRNE    A,1             ; SKIP IF INPUT\r
11980         MOVEM   0,LINLN(B)\r
11981         TRNN    A,2             ; BLOCK MODE?\r
11982         JRST    .+3\r
11983         TRNN    A,4             ; ASCII MODE?\r
11984         JRST    OPBASC  ; GO SETUP BLOCK ASCII\r
11985         MOVE    0,[PUSHJ P,DOIOT]\r
11986         MOVEM   0,IOINS(B)\r
11987 \r
11988         JRST    OPNWIN\r
11989 \r
11990 ; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL\r
11991 \r
11992 INETST: MOVE    A,S.NM1(C)\r
11993         MOVEM   A,RNAME1(B)\r
11994         MOVE    A,S.NM2(C)\r
11995         MOVEM   A,RNAME2(B)\r
11996         LDB     A,[1100,,S.SNM(C)]\r
11997         MOVEM   A,RSNAME(B)\r
11998 \r
11999         MOVE    E,BUFRIN(B)             ; GET STATE BLOCK\r
12000 INTST1: HRRE    0,S.X1(C)\r
12001         MOVEM   0,(E)\r
12002         ADDI    C,1\r
12003         AOBJN   E,INTST1\r
12004 \r
12005         POPJ    P,\r
12006 \f\r
12007 \r
12008 ; ACCEPT A CONNECTION\r
12009 \r
12010 MFUNCTION NETACC,SUBR\r
12011 \r
12012         PUSHJ   P,ARGNET        ; CHECK THAT ARG IS AN OPEN NET CHANNEL\r
12013         MOVE    A,CHANNO(B)     ; GET CHANNEL\r
12014         LSH     A,23.           ; TO AC FIELD\r
12015         IOR     A,[.NETACC]\r
12016         XCT     A\r
12017         JRST    IFALSE          ; RETURN FALSE\r
12018 NETRET: MOVE    A,(AB)\r
12019         MOVE    B,1(AB)\r
12020         JRST    FINIS\r
12021 \r
12022 ; FORCE SYSTEM NETWORK BUFFERS TO BE SENT\r
12023 \r
12024 MFUNCTION NETS,SUBR\r
12025 \r
12026         PUSHJ   P,ARGNET\r
12027         CAME    A,MODES+1\r
12028         CAMN    A,MODES+3\r
12029         SKIPA   A,CHANNO(B)     ; GET CHANNEL\r
12030         JRST    WRONGD\r
12031         LSH     A,23.\r
12032         IOR     A,[.NETS]\r
12033         XCT     A\r
12034         JRST    NETRET\r
12035 \r
12036 ; SUBR TO RETURN UPDATED NET STATE\r
12037 \r
12038 MFUNCTION NETSTATE,SUBR\r
12039 \r
12040         PUSHJ   P,ARGNET        ; IS IT A NET CHANNEL\r
12041         PUSHJ   P,INSTAT\r
12042         JRST    FINIS\r
12043 \r
12044 ; INTERNAL NETSTATE ROUTINE\r
12045 \r
12046 INSTAT: MOVE    C,P             ; GET PDL BASE\r
12047         MOVEI   0,S.X3          ; # OF SLOTS NEEDED\r
12048         PUSH    P,[0]\r
12049         SOJN    0,.-1\r
12050 \r
12051         MOVEI   D,S.DEV(C)              ; SETUP FOR .RCHST\r
12052         HRL     D,CHANNO(B)\r
12053         .RCHST  D,              ; GET THE GOODS\r
12054 \r
12055         PUSHJ   P,INETST        ; INTO VECTOR\r
12056         SUB     P,[S.X3,,S.X3]\r
12057         MOVE    B,BUFRIN(B)\r
12058         MOVSI   A,TUVEC\r
12059         POPJ    P,\r
12060 ]\r
12061 ; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE\r
12062 \r
12063 ARGNET: ENTRY   1\r
12064         GETYP   0,(AB)\r
12065         CAIE    0,TCHAN\r
12066         JRST    WTYP1\r
12067         MOVE    B,1(AB)         ; GET CHANNEL\r
12068         SKIPN   CHANNO(B)       ; OPEN?\r
12069         JRST    CHNCLS\r
12070         MOVE    A,RDEVIC-1(B)   ; GET DEV NAME\r
12071         MOVE    B,RDEVIC(B)\r
12072         PUSHJ   P,STRTO6\r
12073         POP     P,A\r
12074         CAME    A,[SIXBIT /NET   /]\r
12075         JRST    NOTNET\r
12076         MOVE    B,1(AB)\r
12077         MOVE    A,DIRECT-1(B)   ; CHECK FOR A READ SOCKET\r
12078         MOVE    B,DIRECT(B)\r
12079         PUSHJ   P,STRTO6\r
12080         MOVE    B,1(AB)         ; RESTORE CHANNEL\r
12081         POP     P,A\r
12082         POPJ    P,\r
12083 \f\r
12084 IFE ITS,[\r
12085 \r
12086 ; TENEX NETWRK OPENING CODE\r
12087 \r
12088 ONET:   MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL\r
12089         MOVSI   C,100700\r
12090         HRRI    C,1(P)\r
12091         MOVE    E,P\r
12092         PUSH    P,[ASCII /NET:/]        ; FOR STRINGS\r
12093         GETYP   0,RNAME1-1(B)   ; CHECK TYPE\r
12094         CAIE    0,TFIX          ; SKIP IF # SUPPLIED\r
12095         JRST    ONET1\r
12096         MOVE    0,RNAME1(B)     ; GET IT\r
12097         PUSHJ   P,FIXSTK\r
12098         JFCL\r
12099         JRST    ONET2\r
12100 ONET1:  CAIE    0,TCHSTR\r
12101         JRST    WRONGT\r
12102         HRRZ    0,RNAME1-1(B)\r
12103         MOVE    B,RNAME1(B)\r
12104         JUMPE   0,ONET2\r
12105         ILDB    A,B\r
12106         JSP     D,ONETCH\r
12107         SOJA    0,.-3\r
12108 ONET2:  MOVEI   A,".\r
12109         JSP     D,ONETCH\r
12110         MOVE    B,T.CHAN+1(TB)\r
12111         GETYP   0,RNAME2-1(B)\r
12112         CAIE    0,TFIX\r
12113         JRST    ONET3\r
12114         GETYP   0,RSNAME-1(B)\r
12115         CAIE    0,TFIX\r
12116         JRST    WRONGT\r
12117         MOVE    0,RSNAME(B)\r
12118         PUSHJ   P,FIXSTK\r
12119         JRST    ONET4\r
12120         MOVE    B,T.CHAN+1(TB)\r
12121         MOVEI   A,"-\r
12122         JSP     D,ONETCH\r
12123         MOVE    0,RNAME2(B)\r
12124         PUSHJ   P,FIXSTK\r
12125         JRST    WRONGT\r
12126         JRST    ONET4\r
12127 ONET3:  CAIE    0,TCHSTR\r
12128         JRST    WRONGT\r
12129         HRRZ    0,RNAME2-1(B)\r
12130         MOVE    B,RNAME2(B)\r
12131         JUMPE   0,ONET4\r
12132         ILDB    A,B\r
12133         JSP     D,ONETCH\r
12134         SOJA    0,.-3\r
12135 \r
12136 ONET4:\r
12137 ONET5:  MOVE    B,T.CHAN+1(TB)\r
12138         GETYP   0,RNAME2-1(B)\r
12139         CAIN    0,TCHSTR\r
12140         JRST    ONET6\r
12141         MOVEI   A,";\r
12142         JSP     D,ONETCH\r
12143         MOVEI   A,"T\r
12144         JSP     D,ONETCH\r
12145 ONET6:  MOVSI   A,1\r
12146         HRROI   B,1(E)          ; STRING POINTER\r
12147         GTJFN                   ; GET THE G.D JFN\r
12148         TDZA    0,0             ; REMEMBER FAILURE\r
12149         MOVEI   0,1\r
12150         MOVE    P,E             ; RESTORE P\r
12151         JUMPE   0,GTJLOS        ; CONS UP ERROR STRING\r
12152 \r
12153         MOVE    B,T.CHAN+1(TB)\r
12154         HRRZM   A,CHANNO(B)     ; SAVE THE JFN\r
12155 \r
12156         MOVE    C,T.SPDL+1(TB)\r
12157         MOVE    D,S.DIR(C)\r
12158         MOVEI   B,10\r
12159         TRNE    D,2\r
12160         MOVEI   B,36.\r
12161         SKIPE   T.XT(TB)\r
12162         MOVE    B,T.XT+1(TB)\r
12163         JUMPL   B,RBYTSZ\r
12164         CAILE   B,36.\r
12165         JRST    RBYTSZ\r
12166         ROT     B,-6\r
12167         TLO     B,3400\r
12168         HRRI    B,200000\r
12169         TRNE    D,1             ; SKIP FOR INPUT\r
12170         HRRI    B,100000\r
12171         ANDI    A,-1            ; ISOLATE JFCN\r
12172         OPENF\r
12173         JRST    OPFLOS          ; REPORT ERROR\r
12174         MOVE    B,T.CHAN+1(TB)\r
12175         ASH     A,1             ; POINT TO SLOT\r
12176         ADDI    A,CHNL0(TVP)    ; TO REAL SLOT\r
12177         MOVEM   B,1(A)          ; SAVE CHANNEL\r
12178         MOVE    A,CHANNO(B)\r
12179         CVSKT                   ; GET ABS SOCKET #\r
12180         FATAL NETWORK BITES THE BAG!\r
12181         MOVE    D,B\r
12182         MOVE    B,T.CHAN+1(TB)\r
12183         MOVEM   D,RNAME1(B)\r
12184         MOVSI   0,TFIX\r
12185         MOVEM   0,RNAME1-1(B)\r
12186 \r
12187         MOVSI   0,TFIX\r
12188         MOVEM   0,RNAME2-1(B)\r
12189         MOVEM   0,RSNAME-1(B)\r
12190         MOVE    C,T.SPDL+1(TB)\r
12191         MOVE    C,S.DIR(C)\r
12192         MOVE    0,[PUSHJ P,DONETO]\r
12193         TRNN    C,1             ; SKIP FOR OUTPUT\r
12194         MOVE    0,[PUSHJ P,DONETI]\r
12195         MOVEM   0,IOINS(B)\r
12196         MOVEI   0,80.           ; LINELENGTH\r
12197         TRNE    C,1             ; SKIP FOR INPUT\r
12198         MOVEM   0,LINLN(B)\r
12199         MOVEI   A,3             ; GET STATE UVECTOR\r
12200         PUSHJ   P,IBLOCK\r
12201         MOVSI   0,TFIX+.VECT.\r
12202         MOVEM   0,3(B)\r
12203         MOVE    C,B\r
12204         MOVE    B,T.CHAN+1(TB)\r
12205         MOVEM   C,BUFRIN(B)\r
12206         MOVSI   0,TUVEC\r
12207         MOVEM   0,BUFRIN-1(B)\r
12208         MOVE    A,CHANNO(B)     ; GET JFN\r
12209         GDSTS                   ; GET STATE\r
12210         MOVE    E,T.CHAN+1(TB)\r
12211         MOVEM   D,RNAME2(E)\r
12212         MOVEM   C,RSNAME(E)\r
12213         MOVE    C,BUFRIN(E)\r
12214         MOVEM   B,(C)           ; INITIAL STATE STORED\r
12215         MOVE    B,E\r
12216         JRST    OPNWIN\r
12217 \r
12218 ; DOIOT FOR TENEX NETWRK\r
12219 \r
12220 DONETO: PUSH    P,0\r
12221         MOVE    0,[BOUT]\r
12222         JRST    .+3\r
12223 \r
12224 DONETI: PUSH    P,0\r
12225         MOVE    0,[BIN]\r
12226         PUSH    P,0\r
12227         PUSH    TP,$TCHAN\r
12228         PUSH    TP,B\r
12229         MOVEI   0,(A)           ; POSSIBLE OUTPUT CHAR TO 0\r
12230         MOVE    A,CHANNO(B)\r
12231         MOVE    B,0\r
12232         ENABLE\r
12233         XCT     (P)\r
12234         DISABLE\r
12235         MOVEI   A,(B)           ; RET CHAR IN A\r
12236         MOVE    B,(TP)\r
12237         MOVE    0,-1(P)\r
12238         SUB     P,[2,,2]\r
12239         SUB     TP,[2,,2]\r
12240         POPJ    P,\r
12241         \r
12242 NETPRS: MOVEI   D,0\r
12243         HRRZ    0,(C)\r
12244         MOVE    C,1(C)\r
12245 \r
12246 ONETL:  ILDB    A,C\r
12247         CAIN    A,"#\r
12248         POPJ    P,\r
12249         SUBI    A,60\r
12250         ASH     D,3\r
12251         IORI    D,(A)\r
12252         SOJG    0,ONETL\r
12253         AOS     (P)\r
12254         POPJ    P,\r
12255 \r
12256 FIXSTK: CAMN    0,[-1]\r
12257         POPJ    P,\r
12258         JFFO    0,FIXS3         ; PUT OCTAL DIGITS INTO STIRNG\r
12259         MOVEI   A,"0\r
12260         POP     P,D\r
12261         AOJA    D,ONETCH\r
12262 FIXS3:  IDIVI   A,3\r
12263         MOVEI   B,12.\r
12264         SUBI    B,(A)\r
12265         HRLM    B,(P)\r
12266         IMULI   A,3\r
12267         LSH     0,(A)\r
12268         POP     P,B\r
12269 FIXS2:  MOVEI   A,0\r
12270         ROTC    0,3             ; NEXT DIGIT\r
12271         ADDI    A,60\r
12272         JSP     D,ONETCH\r
12273         SUB     B,[1,,0]\r
12274         TLNN    B,-1\r
12275         JRST    1(B)\r
12276         JRST    FIXS2\r
12277 \r
12278 ONETCH: IDPB    A,C\r
12279         TLNE    C,760000        ; SKIP IF NEW WORD\r
12280         JRST    (D)\r
12281         PUSH    P,[0]\r
12282         JRST    (D)\r
12283 \r
12284 INSTAT: MOVE    E,B\r
12285         MOVE    A,CHANNO(E)\r
12286         GDSTS\r
12287         LSH     B,-32.\r
12288         MOVEM   D,RNAME2(E)     ; UPDATE FOREIGN SOCHKET\r
12289         MOVEM   C,RSNAME(E)     ; AND HOST\r
12290         MOVE    C,BUFRIN(E)\r
12291         XCT     ITSTRN(B)       ; XLATE TO LOOK MORE LIKE ITS\r
12292         MOVEM   B,(C)           ; STORE STATE\r
12293         MOVE    B,E\r
12294         POPJ    P,\r
12295 \r
12296 ITSTRN: MOVEI   B,0\r
12297         JRST    NLOSS\r
12298         JRST    NLOSS\r
12299         MOVEI   B,1\r
12300         MOVEI   B,2\r
12301         JRST    NLOSS\r
12302         MOVEI   B,4\r
12303         PUSHJ   P,NOPND\r
12304         MOVEI   B,0\r
12305         JRST    NLOSS\r
12306         JRST    NLOSS\r
12307         PUSHJ   P,NCLSD\r
12308         MOVEI   B,0\r
12309         JRST    NLOSS\r
12310         MOVEI   B,0\r
12311 \r
12312 NLOSS:  FATAL ILLEGAL NETWORK STATE\r
12313 \r
12314 NOPND:  MOVE    B,DIRECT(E)     ; SEE IF READ OR PRINT\r
12315         ILDB    B,B             ; GET 1ST CHAR\r
12316         CAIE    B,"R            ; SKIP FOR READ\r
12317         JRST    NOPNDW\r
12318         SIBE            ; SEE IF INPUT EXISTS\r
12319         JRST    .+3\r
12320         MOVEI   B,5\r
12321         POPJ    P,\r
12322         MOVEM   B,2(C)          ; STORE BYTES IN STATE VECTOR\r
12323         MOVEI   B,11            ; RETURN DATA PRESENT STATE\r
12324         POPJ    P,\r
12325 \r
12326 NOPNDW: SOBE                    ; SEE IF OUTPUT PRESENT\r
12327         JRST    .+3\r
12328         MOVEI   B,5\r
12329         POPJ    P,\r
12330 \r
12331         MOVEI   B,6\r
12332         POPJ    P,\r
12333 \r
12334 NCLSD:  MOVE    B,DIRECT(E)\r
12335         ILDB    B,B\r
12336         CAIE    B,"R\r
12337         JRST    RET0\r
12338         SIBE\r
12339         JRST    .+2\r
12340         JRST    RET0\r
12341         MOVEI   B,10\r
12342         POPJ    P,\r
12343 \r
12344 RET0:   MOVEI   B,0\r
12345         POPJ    P,\r
12346 \r
12347 \r
12348 MFUNCTION NETSTATE,SUBR\r
12349 \r
12350         PUSHJ   P,ARGNET\r
12351         PUSHJ   P,INSTAT\r
12352         MOVE    B,BUFRIN(B)\r
12353         MOVSI   A,TUVEC\r
12354         JRST    FINIS\r
12355 \r
12356 MFUNCTION NETS,SUBR\r
12357 \r
12358         PUSHJ   P,ARGNET\r
12359         CAME    A,MODES+1       ; PRINT OR PRINTB?\r
12360         CAMN    A,MODES+3\r
12361         SKIPA   A,CHANNO(B)\r
12362         JRST    WRONGD\r
12363         MOVEI   B,21\r
12364         MTOPR\r
12365 NETRET: MOVE    B,1(AB)\r
12366         MOVSI   A,TCHAN\r
12367         JRST    FINIS\r
12368 \r
12369 MFUNCTION NETACC,SUBR\r
12370 \r
12371         PUSHJ   P,ARGNET\r
12372         MOVE    A,CHANNO(B)\r
12373         MOVEI   B,20\r
12374         MTOPR\r
12375         JRST    NETRET\r
12376 \r
12377 ]\r
12378 \f\r
12379 ; HERE TO OPEN TELETYPE DEVICES\r
12380 \r
12381 OTTY:   HRRZ    A,S.DIR(C)      ; GET DIR CODE\r
12382         TRNE    A,2             ; SKIP IF NOT READB/PRINTB\r
12383         JRST    WRONGD          ; CANT DO THAT\r
12384 \r
12385 IFN ITS,[\r
12386         MOVE    A,S.NM1(C)      ; CHECK FOR A DIR\r
12387         MOVE    0,S.NM2(C)\r
12388         CAMN    A,[SIXBIT /.FILE./]\r
12389         CAME    0,[SIXBIT /(DIR)/]\r
12390         SKIPA   E,[-15.*2,,]\r
12391         JRST    OUTN            ; DO IT THAT WAY\r
12392 \r
12393         HRRZ    A,S.DIR(C)      ; CHECK DIR\r
12394         TRNE    A,1\r
12395         JRST    TTYLP2\r
12396         HRRI    E,CHNL1(TVP)\r
12397         PUSH    P,S.DEV(C)      ; SAVE THE SIXBIT DEV NAME\r
12398         HRLZS   (P)             ; POSTITION DEVICE NAME\r
12399 \r
12400 TTYLP:  SKIPN   D,1(E)          ; CHANNEL OPEN?\r
12401         JRST    TTYLP1          ; NO, GO TO NEXT\r
12402         MOVE    A,RDEVIC-1(D)           ; GET DEV NAME\r
12403         MOVE    B,RDEVIC(D)\r
12404         PUSHJ   P,STRTO6        ; TO 6 BIT\r
12405         POP     P,A             ; GET RESULT\r
12406         CAMN    A,(P)           ; SAME?\r
12407         JRST    SAMTYQ          ; COULD BE THE SAME\r
12408 TTYLP1: ADD     E,[2,,2]\r
12409         JUMPL   E,TTYLP\r
12410         SUB     P,[1,,1]        ; THIS ONE MUST BE UNIQUE\r
12411 TTYLP2: MOVE    C,T.SPDL+1(TB)  ; POINT TO P BASE\r
12412         HRRZ    A,S.DIR(C)      ; GET DIR OF OPEN\r
12413         SKIPE   A               ; IF OUTPUT,\r
12414         IORI    A,20            ; THEN USE DISPLAY MODE\r
12415         HRLM    A,S.DEV(C)      ; STORE IN OPEN BLOCK\r
12416         PUSHJ   P,OPEN2         ; OPEN THE TTY\r
12417         HRLZ    A,S.DEV(C)      ; GET DEVICE NAME\r
12418         PUSHJ   P,6TOCHS        ; TO A STRING\r
12419         MOVE    D,T.CHAN+1(TB)  ; POINT TO CHANNEL\r
12420         MOVEM   A,RDEVIC-1(D)\r
12421         MOVEM   B,RDEVIC(D)\r
12422         MOVE    C,T.SPDL+1(TB)  ; RESTORE PDL BASE\r
12423         MOVE    B,D             ; CHANNEL TO B\r
12424         HRRZ    0,S.DIR(C)      ; AND DIR\r
12425         JUMPE   0,TTYSPC\r
12426 TTY1:   DOTCAL  TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]]\r
12427         FATAL .CALL FAILURE\r
12428         DOTCAL  TTYSET,[CHANNO(B),MODE1,MODE2,D]\r
12429         FATAL .CALL FAILURE\r
12430         MOVE    A,[PUSHJ P,GMTYO]\r
12431         MOVEM   A,IOINS(B)\r
12432         DOTCAL  RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]]\r
12433         FATAL .CALL FAILURE\r
12434         MOVEM   D,LINLN(B)\r
12435         MOVEM   A,PAGLN(B)\r
12436         JRST    OPNWIN\r
12437 \r
12438 ; MAKE AN IOT\r
12439 \r
12440 IOTMAK: HRLZ    A,CHANNO(B)     ; GET CHANNEL\r
12441         ROT     A,5\r
12442         IOR     A,[.IOT A]      ; BUILD IOT\r
12443         MOVEM   A,IOINS(B)      ; AND STORE IT\r
12444         POPJ    P,\r
12445 \f\r
12446 \r
12447 ; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY\r
12448 \r
12449 SAMTYQ: MOVE    D,1(E)          ; RESTORE CURRENT CHANNEL\r
12450         MOVE    A,DIRECT-1(D)   ; GET DIR\r
12451         MOVE    B,DIRECT(D)\r
12452         PUSHJ   P,STRTO6\r
12453         POP     P,A             ; GET SIXBIT\r
12454         MOVE    C,T.SPDL+1(TB)\r
12455         HRRZ    C,S.DIR(C)\r
12456         CAME    A,MODES(C)      ; SKIP IF DIFFERENT DIRECTION\r
12457         JRST    TTYLP1\r
12458 \r
12459 ; HERE IF A RE-OPEN ON A TTY\r
12460 \r
12461         HRRZ    0,FSAV(TB)      ; IS IT FROM A FOPEN\r
12462         CAIN    0,FOPEN\r
12463         JRST    RETOLD          ; RET OLD CHANNEL\r
12464 \r
12465         PUSH    TP,$TCHAN\r
12466         PUSH    TP,1(E)         ; PUSH OLD CHANNEL\r
12467         PUSH    TP,$TFIX\r
12468         PUSH    TP,T.CHAN+1(TB)\r
12469         MOVE    A,[PUSHJ P,CHNFIX]\r
12470         PUSHJ   P,GCHACK\r
12471         SUB     TP,[4,,4]\r
12472         \r
12473 RETOLD: MOVE    B,1(E)          ; GET CHANNEL\r
12474         AOS     CHANNO-1(B)     ; AOS REF COUNT\r
12475         MOVSI   A,TCHAN\r
12476         SUB     P,[1,,1]        ; CLEAN UP STACK\r
12477         JRST    OPNRET          ; AND LEAVE\r
12478 \r
12479 \r
12480 ; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER\r
12481 \r
12482 CHNFIX: CAIN    C,TCHAN\r
12483         CAME    D,(TP)\r
12484         POPJ    P,\r
12485         MOVE    D,-2(TP)        ; GET REPLACEMENT\r
12486         SKIPE   B\r
12487         MOVEM   D,1(B)          ; CLOBBER IT AWAY\r
12488         POPJ    P,\r
12489 ]\f\r
12490 \r
12491 IFE ITS,[\r
12492         MOVE    C,T.SPDL+1(TB)  ; POINT TO P BASE\r
12493         HRRZ    0,S.DIR(C)      ; 0/ 0 FOR READ 0/ 1 FOR PRINT\r
12494         MOVE    A,[PUSHJ P,MTYO]\r
12495         MOVE    B,T.CHAN+1(TB)\r
12496         MOVEM   A,IOINS(B)\r
12497         MOVEI   A,100           ; PRIM INPUT JFN\r
12498         JUMPN   0,TNXTY1\r
12499         MOVEI   E,C.OPN+C.READ\r
12500         HRRM    E,-4(B)\r
12501         MOVEM   B,CHNL0+2*100+1(TVP)\r
12502         JRST    TNXTY2\r
12503 TNXTY1: MOVEM   B,CHNL0+2*101+1(TVP)\r
12504         MOVEI   A,101           ; PRIM OUTPUT JFN\r
12505         MOVEI   E,C.OPN+C.PRIN\r
12506         HRRM    E,-4(B)\r
12507 TNXTY2: MOVEM   A,CHANNO(B)\r
12508         JUMPN   0,OPNWIN\r
12509 ]\r
12510 ; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES\r
12511 \r
12512 TTYSPC: MOVEI   A,EXTBFR        ; GET EXTRA BUFFER\r
12513         PUSHJ   P,IBLOCK        ; GET BLOCK\r
12514         MOVE    D,T.CHAN+1(TB)  ;RESTORE CHANNEL POINTER\r
12515 IFN ITS,[\r
12516         MOVE    A,CHANNO(D)\r
12517         LSH     A,23.\r
12518         IOR     A,[.IOT A]\r
12519         MOVEM   A,IOIN2(B)\r
12520 ]\r
12521 IFE ITS,[\r
12522         MOVE    A,[PBIN]\r
12523         MOVEM   A,IOIN2(B)\r
12524 ]\r
12525         MOVSI   A,TLIST\r
12526         MOVEM   A,EXBUFR-1(D)   ; FOR WAITING TTY BUFFERS\r
12527         SETZM   EXBUFR(D)       ; NIL LIST\r
12528         MOVEM   B,BUFRIN(D)     ;STORE IN CHANNEL\r
12529         MOVSI   A,TUVEC         ;MAKE SURE TYPE IS UNIFORM VECTOR\r
12530         MOVEM   A,BUFRIN-1(D)\r
12531 IFN ITS,        MOVEI   A,177           ;SET ERASER TO RUBOUT\r
12532 IFE ITS,        MOVEI   A,1             ; TRY ^A FOR TENEX\r
12533         MOVEM   A,ERASCH(B)\r
12534         SETZM   KILLCH(B)       ;NO KILL CHARACTER NEEDED\r
12535         MOVEI   A,33            ;BREAKCHR TO C.R.\r
12536         MOVEM   A,BRKCH(B)\r
12537         MOVEI   A,"\            ;ESCAPER TO \\r
12538         MOVEM   A,ESCAP(B)\r
12539         MOVE    A,[010700,,BYTPTR(E)]   ;RELATIVE BYTE POINTER\r
12540         MOVEM   A,BYTPTR(B)\r
12541         MOVEI   A,14            ;BARF BACK CHARACTER FF\r
12542         MOVEM   A,BRFCHR(B)\r
12543         MOVEI   A,^D\r
12544         MOVEM   A,BRFCH2(B)\r
12545 \r
12546 ; SETUP DEFAULT TTY INTERRUPT HANDLER\r
12547 \r
12548         PUSH    TP,$TATOM\r
12549         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP\r
12550         PUSH    TP,$TFIX\r
12551         PUSH    TP,[10]         ; PRIORITY OF CHAR INT\r
12552         PUSH    TP,$TCHAN\r
12553         PUSH    TP,D\r
12554         MCALL   3,EVENT         ; 1ST MAKE AN EVENT EXIST\r
12555         PUSH    TP,A\r
12556         PUSH    TP,B\r
12557         PUSH    TP,$TSUBR\r
12558         PUSH    TP,[QUITTER]    ; DEFAULT HANDLER IS QUITTER\r
12559         MCALL   2,HANDLER\r
12560 \r
12561 ; BUILD A NULL STRING\r
12562 \r
12563         MOVEI   A,0\r
12564         PUSHJ   P,IBLOCK                ; USE A BLOCK\r
12565         MOVE    D,T.CHAN+1(TB)\r
12566         MOVEI   0,C.BUF\r
12567         IORM    0,-4(D)\r
12568         HRLI    B,440700\r
12569         MOVSI   A,TCHSTR\r
12570         MOVEM   A,BUFSTR-1(D)\r
12571         MOVEM   B,BUFSTR(D)\r
12572         MOVEI   A,0\r
12573         MOVE    B,D             ; CHANNEL TO B\r
12574         JRST    MAKION\r
12575 \f\r
12576 \r
12577 ; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST\r
12578 \r
12579 OPEN2:  MOVEI   A,S.DEV(C)      ; POINT TO OPEN BLOCK\r
12580         PUSHJ   P,MOPEN         ; OPEN THE FILE\r
12581         JRST    OPNLOS\r
12582         MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL BACK\r
12583         MOVEM   A,CHANNO(B)     ; SAVE THE CHANNEL\r
12584         JRST    OPEN3\r
12585 \r
12586 ; FIX UP MODE AND FALL INTO OPEN\r
12587 \r
12588 OPEN0:  HRRZ    A,S.DIR(C)              ; GET DIR\r
12589         TRNE    A,2             ; SKIP IF NOT BLOCK\r
12590         IORI    A,4             ; TURN ON IMAGE\r
12591         IORI    A,2             ; AND BLOCK\r
12592 \r
12593         PUSH    P,A\r
12594         PUSH    TP,$TPDL\r
12595         PUSH    TP,C            ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA\r
12596         MOVE    B,T.CHAN+1(TB)\r
12597         MOVE    A,DIRECT-1(B)\r
12598         MOVE    B,DIRECT(B)     ; THIS KLUDGE THE MESS OF NDR\r
12599         PUSHJ   P,STRTO6\r
12600         MOVE    C,(TP)\r
12601         POP     P,D             ; THE SIXBIT FOR KLUDGE\r
12602         POP     P,A             ; GET BACK THE RANDOM BITS\r
12603         SUB     TP,[2,,2]\r
12604         CAME    D,[SIXBIT /PRINTO/]\r
12605         JRST    OPEN9           ; WELL NOT THIS TIME\r
12606         IORI    A,100000        ; WRITEOVER BIT\r
12607 \r
12608         HRRZ    0,FSAV(TB)\r
12609         CAIN    0,NFOPEN\r
12610         IOR     A,4             ; DON'T CHANGE REF DATE\r
12611 OPEN9:  HRLM    A,S.DEV(C)      ; AND STORE IT\r
12612 \r
12613 ; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL\r
12614 \r
12615 OPEN1:  MOVEI   A,S.DEV(C)      ; POINT TO OPEN BLOCK\r
12616         PUSHJ   P,MOPEN\r
12617         JRST    OPNLOS\r
12618         MOVE    B,T.CHAN+1(TB)  ; GET CHANNEL BACK\r
12619         MOVEM   A,CHANNO(B)     ; CLOBBER INTO CHANNEL\r
12620         MOVSI   A,(A)           ; SET UP READ CHAN STATUS\r
12621         HRRI    A,S.DEV(C)\r
12622         .RCHST  A,              ; GET THE GOODS\r
12623 \r
12624 ; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL\r
12625 \r
12626 OPEN3:  MOVE    A,S.DIR(C)\r
12627         MOVEI   0,C.OPN+C.READ\r
12628         TRNE    A,1\r
12629         MOVEI   0,C.OPN+C.PRIN\r
12630         TRNE    A,2\r
12631         TRO     0,C.BIN\r
12632         HRRM    0,-4(B)\r
12633         MOVE    A,CHANNO(B)     ; GET CHANNEL #\r
12634         ASH     A,1\r
12635         ADDI    A,CHNL0(TVP)    ; POINT TO SLOT\r
12636         MOVEM   B,1(A)          ; NOT: TYPE ALREADY SETUP\r
12637 \r
12638 ; NOW GET STATUS WORD\r
12639 \r
12640 DOSTAT: HRLZ    A,CHANNO(B)     ; NOW GET STATUS WORD\r
12641         ROT     A,5\r
12642         IOR     A,[.STATUS STATUS(B)]   ; GET INS\r
12643         XCT     A               ; AND DO IT\r
12644         POPJ    P,\r
12645 \f\r
12646 \r
12647 ; HERE IF OPEN FAILS (CHANNEL IS IN A)\r
12648 \r
12649 OPNLOS: JUMPL   A,NOCHAN        ; ALL CHANNELS ARE IN USE\r
12650         LSH     A,23.           ; DO A .STATUS\r
12651         IOR     A,[.STATUS A]\r
12652         XCT     A               ; STATUS TO A\r
12653         PUSHJ   P,GFALS         ; GET A FALSE WITH A MESSAGE\r
12654         SUB     P,[1,,1]        ; EXTRA RET ADDR FLUSHED\r
12655         JRST    OPNRET          ; AND RETURN\r
12656 \r
12657 ; ROUTINE TO CONS UP FALSE WITH REASON\r
12658 \r
12659 GFALS:  PUSH    P,[SIXBIT /   ERR/]     ; SET UP OPEN TO ERR DEV\r
12660         PUSH    P,[3]           ; SAY ITS FOR CHANNEL\r
12661         PUSH    P,A\r
12662         .OPEN   0,-2(P)         ; USE CHANNEL 0 FOR THIS\r
12663         FATAL CAN'T OPEN ERROR DEVICE\r
12664         SUB     P,[3,,3]        ; DONT WANT OPEN BLOCK NOW\r
12665         MOVEI   A,0             ; PREPARE TO BUILD STRING ON STACK\r
12666 EL1:    PUSH    P,[0]           ; WHERE IT WILL GO\r
12667         MOVSI   B,(<440700,,(P)>)       ; BYTE POINTER TO TOP OF STACK\r
12668 EL2:    .IOT    0,0             ; GET A CHAR\r
12669         JUMPL   0,EL3           ; JUMP ON -1,,3\r
12670         CAIN    0,3             ; EOF?\r
12671         JRST    EL3             ; YES, MAKE STRING\r
12672         CAIN    0,14            ; IGNORE FORM FEEDS\r
12673         JRST    EL2             ; IGNORE FF\r
12674         CAIE    0,15            ; IGNORE CR & LF\r
12675         CAIN    0,12\r
12676         JRST    EL2\r
12677         IDPB    0,B             ; STUFF IT\r
12678         TLNE    B,760000        ; SIP IF WORD FULL\r
12679         AOJA    A,EL2\r
12680         AOJA    A,EL1           ; COUNT WORD AND GO\r
12681 \r
12682 EL3:    SKIPN   (P)             ; ANY CHARS AT END?\r
12683         SUB     P,[1,,1]        ; FLUSH XTRA\r
12684         PUSH    P,A             ; PUT UP COUNT\r
12685         .CLOSE  0,              ; CLOSE THE ERR DEVICE\r
12686         PUSHJ   P,CHMAK         ; MAKE STRING\r
12687         MOVE    C,A\r
12688         MOVE    D,B             ; COPY STRING\r
12689         PUSHJ   P,INCONS        ; CONS TO NIL\r
12690         MOVSI   A,TFALSE        ; MAKEIT A FALSE\r
12691         POPJ    P,\r
12692 \f\r
12693 \r
12694 ; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL\r
12695 \r
12696 FIXREA: HRLZS   S.DEV(C)        ; KILL MODE BITS\r
12697         MOVE    D,[-4,,S.DEV]\r
12698 \r
12699 FIXRE1: MOVEI   A,(D)           ; COPY REL POINTER\r
12700         ADD     A,T.SPDL+1(TB)  ; POINT TO SLOT\r
12701         SKIPN   A,(A)           ; SKIP IF GOODIE THERE\r
12702         JRST    FIXRE2\r
12703         PUSHJ   P,6TOCHS        ; MAKE INOT A STRING\r
12704         MOVE    C,RDTBL-S.DEV(D); GET OFFSET\r
12705         ADD     C,T.CHAN+1(TB)\r
12706         MOVEM   A,-1(C)\r
12707         MOVEM   B,(C)\r
12708 FIXRE2: AOBJN   D,FIXRE1\r
12709         POPJ    P,\r
12710 \r
12711 DOOPN:  PUSH    P,A\r
12712         HRLZ    A,CHANNO(B)     ; GET CHANNEL\r
12713         ASH     A,5\r
12714         HRR     A,(P)           ; POINT\r
12715         TLO     A,(.OPEN)\r
12716         XCT     A\r
12717         SKIPA\r
12718         AOS     -1(P)\r
12719         POP     P,A\r
12720         POPJ    P,\r
12721 \f\r
12722 ;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES\r
12723 STRTO6: PUSH    TP,A\r
12724         PUSH    TP,B\r
12725         PUSH    P,E             ;SAVE USEFUL FROB\r
12726         MOVEI   E,(A)           ; CHAR COUNT TO E\r
12727         GETYP   A,A\r
12728         CAIE    A,TCHSTR                ; IS IT ONE WORD?\r
12729         JRST    WRONGT          ;NO\r
12730 CHREAD: MOVEI   A,0             ;INITIALIZE OUTPUT WORD\r
12731         MOVE    D,[440600,,A]   ;AND BYTE POINTER TO IT\r
12732 NEXCHR: SOJL    E,SIXDON\r
12733         ILDB    0,B             ; GET NEXT CHAR\r
12734         JUMPE   0,SIXDON        ;IF NULL, WE ARE FINISHED\r
12735         PUSHJ   P,A0TO6         ; CONVERT TO SIXBIT\r
12736         IDPB    0,D             ;DEPOSIT INTO SIX BIT\r
12737         TRNN    A,77            ;IS OUTPUT FULL\r
12738         JRST    NEXCHR          ; NO, GET NEXT\r
12739 SIXDON: SUB     TP,[2,,2]       ;FIX UP TP\r
12740         POP     P,E\r
12741         EXCH    A,(P)           ;LEAVE RESULT ON P-STACK\r
12742         JRST    (A)             ;NOW RETURN\r
12743 \r
12744 \r
12745 ;SUBROUTINE TO CONVERT SIXBIT TO ATOM\r
12746 \r
12747 6TOCHS: PUSH    P,E\r
12748         PUSH    P,D\r
12749         MOVEI   B,0             ;MAX NUMBER OF CHARACTERS\r
12750         PUSH    P,[0]           ;STRING WILL GO ON P SATCK\r
12751         JUMPE   A,GETATM        ; EMPTY, LEAVE\r
12752         MOVEI   E,-1(P)         ;WILL BE BYTE POINTER\r
12753         HRLI    E,10700         ;SET IT UP\r
12754         PUSH    P,[0]           ;SECOND POSSIBLE WORD\r
12755         MOVE    D,[440600,,A]   ;INPUT BYTE POINTER\r
12756 6LOOP:  ILDB    0,D             ;START CHAR GOBBLING\r
12757         ADDI    0,40            ;CHANGET TOASCII\r
12758         IDPB    0,E             ;AND STORE IT\r
12759         TLNN    D,770000        ; SKIP IF NOT DONE\r
12760         JRST    6LOOP1\r
12761         TDNN    A,MSKS(B)       ; CHECK IF JUST SPACES LEFT\r
12762         AOJA    B,GETATM        ; YES, DONE\r
12763         AOJA    B,6LOOP         ;KEEP LOOKING\r
12764 6LOOP1: PUSH    P,[6]           ;IF ARRIVE HERE, STRING IS 2 WORDS\r
12765         JRST    .+2\r
12766 GETATM: MOVEM   B,(P)           ;SET STRING LENGTH=1\r
12767         PUSHJ   P,CHMAK         ;MAKE A MUDDLE STRING\r
12768         POP     P,D\r
12769         POP     P,E\r
12770         POPJ    P,\r
12771 \r
12772 MSKS:   7777,,-1\r
12773         77,,-1\r
12774         ,,-1\r
12775         7777\r
12776         77\r
12777 \r
12778 \r
12779 ; CONVERT ONE CHAR\r
12780 \r
12781 A0TO6:  CAIL    0,141           ;IF IT IS GREATER OR EQUAL TO LOWER A\r
12782         CAILE   0,172           ;BUT LESS THAN OR EQUAL TO LOWER Z\r
12783         JRST    .+2             ;THEN\r
12784         SUBI    0,40            ;CONVERT TO UPPER CASE\r
12785         SUBI    0,40            ;NOW TO SIX BIT\r
12786         JUMPL   0,BAD6          ;CHECK FOR A WINNER\r
12787         CAILE   0,77\r
12788         JRST    BAD6\r
12789         POPJ    P,\r
12790 \f\r
12791 ; SUBR TO DELETE AND RENAME FILES\r
12792 \r
12793 MFUNCTION RENAME,SUBR\r
12794 \r
12795         ENTRY\r
12796 \r
12797         JUMPGE  AB,TFA\r
12798         PUSH    TP,$TPDL\r
12799         PUSH    TP,P            ; SAVE P-STACK BASE\r
12800         GETYP   0,(AB)          ; GET 1ST ARG TYPE\r
12801 IFN ITS,[\r
12802         CAIN    0,TCHAN         ; CHANNEL?\r
12803         JRST    CHNRNM          ; MUST BE RENAME WHILE OPEN FOR WRITING\r
12804 ]\r
12805 IFE ITS,[\r
12806         PUSH    P,[100000,,0]\r
12807         PUSH    P,[377777,,377777]\r
12808 ]\r
12809         MOVSI   E,-4            ; 4 THINGS TO PUSH\r
12810 RNMALP: MOVE    B,@RNMTBL(E)\r
12811         PUSH    P,E\r
12812         PUSHJ   P,IDVAL1\r
12813         POP     P,E\r
12814         GETYP   0,A\r
12815         CAIE    0,TCHSTR        ; SKIP IF WINS\r
12816         JRST    RNMLP1\r
12817 \r
12818 IFN ITS,        PUSHJ   P,STRTO6        ; CONVERT TO SIXBIT\r
12819 IFE ITS,        PUSH    P,B             ; PUSH BYTE POINTER\r
12820         JRST    .+2\r
12821 \r
12822 RNMLP1: PUSH    P,RNSTBL(E)     ; USE DEFAULT\r
12823         AOBJN   E,RNMALP\r
12824 \r
12825 IFN ITS,[\r
12826         PUSHJ   P,RGPRS         ; PARSE THE ARGS\r
12827         JRST    RNM1            ; COULD BE A RENAME\r
12828 \r
12829 ; HERE TO DELETE A FILE\r
12830 \r
12831 DELFIL: MOVEI   A,0             ; SETUP FDELE\r
12832         EXCH    A,(P)           ; AND GET SNAME\r
12833         .SUSET  [.SSNAM,,A]\r
12834         HLRZS   -3(P)           ; FIXUP DEVICE\r
12835         .FDELE  -3(P)           ; DO IT TO IT\r
12836         JRST    FDLST           ; ANALYSE ERROR\r
12837 \r
12838 FDLWON: MOVSI   A,TATOM\r
12839         MOVE    B,MQUOTE T\r
12840         JRST    FINIS\r
12841 ]\r
12842 IFE ITS,[\r
12843         MOVE    A,(TP)          ; GET BASE OF PDL\r
12844         MOVEI   A,1(A)          ; POINT TO CRAP\r
12845         MOVE    B,1(AB)         ; STRING POINTER\r
12846         PUSH    P,[0]\r
12847         PUSH    P,[0]\r
12848         PUSH    P,[0]\r
12849         GTJFN                   ; GET A JFN\r
12850         JRST    TDLLOS          ; LOST\r
12851         ADD     AB,[2,,2]       ; PAST ARG\r
12852         JUMPL   AB,RNM1         ; GO TRY FOR RENAME\r
12853         MOVE    P,(TP)          ; RESTORE P STACK\r
12854         MOVEI   C,(A)           ; FOR RELEASE\r
12855         DELF                    ; ATTEMPT DELETE\r
12856         JRST    DELLOS          ; LOSER\r
12857         RLJFN                   ; MAKE SURE FLUSHED\r
12858         JFCL\r
12859 \r
12860 FDLWON: MOVSI   A,TATOM\r
12861         MOVE    B,MQUOTE T\r
12862         JRST    FINIS\r
12863 \r
12864 RNMLOS: PUSH    P,A\r
12865         MOVEI   A,(B)\r
12866         RLJFN\r
12867         JFCL\r
12868 DELLO1: MOVEI   A,(C)\r
12869         RLJFN\r
12870         JFCL\r
12871         POP     P,A             ; ERR NUMBER BACK\r
12872 TDLLOS: PUSHJ   P,TGFALS        ; GET FALSE WITH REASON\r
12873         JRST    FINIS\r
12874 \r
12875 DELLOS: PUSH    P,A             ; SAVE ERROR\r
12876         JRST    DELLO1\r
12877 ]\r
12878 \r
12879 ;TABLE OF REANMAE DEFAULTS\r
12880 IFN ITS,[\r
12881 RNMTBL: IMQUOTE DEV\r
12882         IMQUOTE NM1\r
12883         IMQUOTE NM2\r
12884         IMQUOTE SNM\r
12885 \r
12886 RNSTBL: SIXBIT /DSK   _MUDS_>           /\r
12887 ]\r
12888 IFE ITS,[\r
12889 RNMTBL: IMQUOTE DEV\r
12890         IMQUOTE SNM\r
12891         IMQUOTE NM1\r
12892         IMQUOTE NM2\r
12893 \r
12894 RNSTBL: -1,,[ASCIZ /DSK/]\r
12895         0\r
12896         -1,,[ASCIZ /_MUDS_/]\r
12897         -1,,[ASCIZ /MUD/]\r
12898 ]\r
12899 ; HERE TO DO A RENAME\r
12900 \r
12901 RNM1:   JUMPGE  AB,TMA          ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING\r
12902         GETYP   0,(AB)\r
12903         MOVE    C,1(AB)         ; GET ARG\r
12904         CAIN    0,TATOM         ; IS IT "TO"\r
12905         CAME    C,MQUOTE TO\r
12906         JRST    WRONGT          ; NO, LOSE\r
12907         ADD     AB,[2,,2]       ; BUMP PAST "TO"\r
12908         JUMPGE  AB,TFA\r
12909 IFN ITS,[\r
12910         MOVEM   P,T.SPDL+1(TB)  ; SAVE NEW P-BASE\r
12911 \r
12912         MOVEI   0,4             ; FOUR DEFAULTS\r
12913         PUSH    P,-3(P)         ; DEFAULT DEVICE IS CURRENT\r
12914         SOJN    0,.-1\r
12915 \r
12916         PUSHJ   P,RGPRS         ; PARSE THE NEXT STRING\r
12917         JRST    TMA\r
12918 \r
12919         HLRZS   A,-7(P)         ; FIX AND GET DEV1\r
12920         HLRZS   B,-3(P)         ; SAME FOR DEV2\r
12921         CAIE    A,(B)           ; SAME?\r
12922         JRST    DEVDIF\r
12923 \r
12924         POP     P,A             ; GET SNAME 2\r
12925         CAME    A,(P)-3         ; SNAME 1\r
12926         JRST    DEVDIF\r
12927         .SUSET  [.SSNAM,,A]\r
12928         POP     P,-2(P)         ; MOVE NAMES DOWN\r
12929         POP     P,-2(P)\r
12930         .FDELE  -4(P)           ; TRY THE RENAME\r
12931         JRST    FDLST\r
12932         JRST    FDLWON\r
12933 \r
12934 ; HERE FOR RENAME WHILE OPEN FOR WRITING\r
12935 \r
12936 CHNRNM: ADD     AB,[2,,2]       ; NEXT ARG\r
12937         JUMPGE  AB,TFA\r
12938         MOVE    B,-1(AB)        ; GET CHANNEL\r
12939         SKIPN   CHANNO(B)       ; SKIP IF OPEN\r
12940         JRST    BADCHN\r
12941         MOVE    A,DIRECT-1(B)   ; CHECK DIRECTION\r
12942         MOVE    B,DIRECT(B)\r
12943         PUSHJ   P,STRTO6        ; TO 6 BIT\r
12944         POP     P,A\r
12945         CAME    A,[SIXBIT /PRINT/]\r
12946         CAMN    A,[SIXBIT /PRINTB/]\r
12947         JRST    CHNRN1\r
12948         CAME    A,[SIXBIT /PRINTO/]\r
12949         JRST    WRONGD\r
12950 \r
12951 ; SET UP .FDELE BLOCK\r
12952 \r
12953 CHNRN1: PUSH    P,[0]\r
12954         PUSH    P,[0]\r
12955         MOVEM   P,T.SPDL+1(TB)\r
12956         PUSH    P,[0]\r
12957         PUSH    P,[SIXBIT /_MUDL_/]\r
12958         PUSH    P,[SIXBIT />/]\r
12959         PUSH    P,[0]\r
12960 \r
12961         PUSHJ   P,RGPRS         ; PARSE THESE\r
12962         JRST    TMA\r
12963 \r
12964         SUB     P,[1,,1]        ; SNAME/DEV IGNORED\r
12965         MOVE    AB,ABSAV(TB)    ; GET ORIG ARG POINTER\r
12966         MOVE    B,1(AB)\r
12967         MOVE    A,CHANNO(B)     ; ITS CHANNEL #\r
12968         MOVEM   A,-2(P)\r
12969         .FDELE  -4(P)\r
12970         JRST    FDLST\r
12971         MOVEI   A,-4(P)         ; SET UP FOR RDCHST\r
12972         HRL     A,CHANNO(B)\r
12973         .RCHST  A,\r
12974         MOVE    A,-3(P)         ; UPDATE CHANNEL\r
12975         PUSHJ   P,6TOCHS        ; GET A STRING\r
12976         MOVE    C,1(AB)\r
12977         MOVEM   A,RNAME1-1(C)\r
12978         MOVEM   B,RNAME1(C)\r
12979         MOVE    A,-2(P)\r
12980         PUSHJ   P,6TOCHS\r
12981         MOVE    C,1(AB)\r
12982         MOVEM   A,RNAME2-1(C)\r
12983         MOVEM   B,RNAME2(C)\r
12984         MOVE    B,1(AB)\r
12985         MOVSI   A,TCHAN\b\r
12986         JRST    FINIS\r
12987 ]\r
12988 IFE ITS,[\r
12989         PUSH    P,A\r
12990         MOVE    A,(TP)          ; PBASE BACK\r
12991         PUSH    A,[400000,,0]\r
12992         MOVEI   A,(A)\r
12993         MOVE    B,1(AB)\r
12994         GTJFN\r
12995         JRST    TDLLOS\r
12996         POP     P,B\r
12997         EXCH    A,B\r
12998         MOVEI   C,(A)           ; FOR RELEASE ATTEMPT\r
12999         RNAMF\r
13000         JRST    RNMLOS\r
13001         MOVEI   A,(B)\r
13002         RLJFN                   ; FLUSH JFN\r
13003         JFCL\r
13004         MOVEI   A,(C)           ; MAKE SURR OTHER IS FLUSHED\r
13005         RLJFN\r
13006         JFCL\r
13007         JRST    FDLWON\r
13008 ]\r
13009 ; HERE FOR LOSING .FDELE\r
13010 \r
13011 FDLST:  .STATUS 0,A             ; GET STATUS\r
13012         PUSHJ   P,GFALS         ; ANALYZE IT\r
13013         JRST    FINIS\r
13014 \r
13015 ; SOME .FDELE ERRORS\r
13016 \r
13017 DEVDIF: PUSH    TP,$TATOM\r
13018         PUSH    TP,EQUOTE DEVICE-OR-SNAME-DIFFERS\r
13019         JRST    CALER1\r
13020 \r
13021 \f; HERE TO RESET A READ CHANNEL\r
13022 \r
13023 MFUNCTION FRESET,SUBR,RESET\r
13024 \r
13025         ENTRY   1\r
13026         GETYP   A,(AB)\r
13027         CAIE    A,TCHAN\r
13028         JRST    WTYP1\r
13029         MOVE    B,1(AB)         ;GET CHANNEL\r
13030         SKIPN   IOINS(B)                ; OPEN?\r
13031         JRST    REOPE1          ; NO, IGNORE CHECKS\r
13032 IFN ITS,[\r
13033         MOVE    A,STATUS(B)     ;GET STATUS\r
13034         ANDI    A,77\r
13035         JUMPE   A,REOPE1        ;IF IT CLOSED, JUST REOPEN IT, MAYBE?\r
13036         CAILE   A,2             ;SKIPS IF TTY FLAVOR\r
13037         JRST    REOPEN\r
13038 ]\r
13039 IFE ITS,[\r
13040         MOVE    A,CHANNO(B)\r
13041         CAIE    A,100           ; TTY-IN\r
13042         CAIN    A,101           ; TTY-OUT\r
13043         JRST    .+2\r
13044         JRST    REOPEN\r
13045 ]\r
13046         CAME    B,TTICHN+1(TVP)\r
13047         CAMN    B,TTOCHN+1(TVP)\r
13048         JRST    REATTY\r
13049 REATT1: MOVEI   B,DIRECT-1(B)   ;POINT TO DIRECTION\r
13050         PUSHJ   P,CHRWRD        ;CONVERT TO A WORD\r
13051         JFCL\r
13052         CAME    B,[ASCII /READ/]\r
13053         JRST    TTYOPN\r
13054         MOVE    B,1(AB)         ;RESTORE CHANNEL\r
13055         PUSHJ   P,RRESET"       ;DO REAL RESET\r
13056         JRST    TTYOPN\r
13057 \r
13058 REOPEN: PUSH    TP,(AB)         ;FIRST CLOSE IT\r
13059         PUSH    TP,(AB)+1\r
13060         MCALL   1,FCLOSE\r
13061         MOVE    B,1(AB)         ;RESTORE CHANNEL\r
13062 \r
13063 ; SET UP TEMPS FOR OPNCH\r
13064 \r
13065 REOPE1: PUSH    P,[0]           ; WILL HOLD DIR CODE\r
13066         PUSH    TP,$TPDL\r
13067         PUSH    TP,P\r
13068         IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS]\r
13069         PUSH    TP,A-1(B)\r
13070         PUSH    TP,A(B)\r
13071         TERMIN\r
13072 \r
13073         PUSH    TP,$TCHAN\r
13074         PUSH    TP,1(AB)\r
13075 \r
13076         MOVE    A,T.DIR(TB)\r
13077         MOVE    B,T.DIR+1(TB)   ; GET DIRECTION\r
13078         PUSHJ   P,CHMOD ; CHECK THE MODE\r
13079         MOVEM   A,(P)           ; AND STORE IT\r
13080 \r
13081 ; NOW SET UP OPEN BLOCK IN SIXBIT\r
13082 IFN ITS,[\r
13083         MOVSI   E,-4            ; AOBN PNTR\r
13084 FRESE2: MOVE    B,T.CHAN+1(TB)\r
13085         MOVEI   A,@RDTBL(E)     ; GET ITEM POINTER\r
13086         GETYP   0,-1(A)         ; GET ITS TYPE\r
13087         CAIE    0,TCHSTR\r
13088         JRST    FRESE1\r
13089         MOVE    B,(A)           ; GET STRING\r
13090         MOVE    A,-1(A)\r
13091         PUSHJ   P,STRTO6\r
13092 FRESE3: AOBJN   E,FRESE2\r
13093         HLRZS   -3(P)           ; FIX DEVICE SPEC\r
13094 ]\r
13095 IFE ITS,[\r
13096         MOVE    B,T.CHAN+1(TB)\r
13097         MOVE    A,RDEVIC-1(B)\r
13098         MOVE    B,RDEVIC(B)\r
13099         PUSHJ   P,STRTO6                ; RESULT ON STACK\r
13100         HLRZS   (P)\r
13101 ]\r
13102 \r
13103         PUSH    P,[0]           ; PUSH UP SOME DUMMIES\r
13104         PUSH    P,[0]\r
13105         PUSH    P,[0]\r
13106         PUSHJ   P,OPNCH         ; ATTEMPT TO DO THEOPEN\r
13107         GETYP   0,A\r
13108         CAIE    0,TCHAN\r
13109         JRST    FINIS           ; LEAVE IF FALSE OR WHATEVER\r
13110 \r
13111 DRESET: MOVE    A,(AB)\r
13112         MOVE    B,1(AB)\r
13113         SETZM   CHRPOS(B)       ;INITIALIZE THESE PARAMETERS\r
13114         SETZM   LINPOS(B)\r
13115         SETZM   ACCESS(B)\r
13116         JRST    FINIS\r
13117 \r
13118 TTYOPN: MOVE    B,1(AB)\r
13119         CAME    B,TTOCHN+1(TVP)\r
13120         CAMN    B,TTICHN+1(TVP)\r
13121         PUSHJ   P,TTYOP2\r
13122         PUSHJ   P,DOSTAT\r
13123         DOTCAL  RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]]\r
13124         FATAL .CALL FAILURE\r
13125         MOVEM   C,PAGLN(B)\r
13126         MOVEM   D,LINLN(B)\r
13127         JRST    DRESET\r
13128 \r
13129 IFN ITS,[\r
13130 FRESE1: CAIE    0,TFIX\r
13131         JRST    BADCHN\r
13132         PUSH    P,(A)\r
13133         JRST    FRESE3\r
13134 ]\r
13135 \r
13136 ; INTERFACE TO REOPEN CLOSED CHANNELS\r
13137 \r
13138 OPNCHN: PUSH    TP,$TCHAN\r
13139         PUSH    TP,B\r
13140         MCALL   1,FRESET\r
13141         POPJ    P,\r
13142 \r
13143 REATTY: PUSHJ   P,TTYOP2\r
13144         SKIPE   NOTTY\r
13145         JRST    DRESET\r
13146         MOVE    B,1(AB)\r
13147         JRST    REATT1\r
13148 \f\r
13149 ; FUNCTION TO LIST ALL CHANNELS\r
13150 \r
13151 MFUNCTION CHANLIST,SUBR\r
13152 \r
13153         ENTRY   0\r
13154 \r
13155         MOVEI   A,N.CHNS-1      ;MAX # OF REAL CHANNELS\r
13156         MOVEI   C,0\r
13157         MOVEI   B,CHNL1(TVP)    ;POINT TO FIRST REAL CHANNEL\r
13158 \r
13159 CHNLP:  SKIPN   1(B)            ;OPEN?\r
13160         JRST    NXTCHN          ;NO, SKIP\r
13161         HRRZ    E,(B)           ; ABOUT TO FLUSH?\r
13162         JUMPN   E,NXTCHN        ; YES, FORGET IT\r
13163         MOVE    D,1(B)          ; GET CHANNEL\r
13164         HRRZ    E,CHANNO-1(D)   ; GET REF COUNT\r
13165         PUSH    TP,(B)\r
13166         PUSH    TP,1(B)\r
13167         ADDI    C,1             ;COUNT WINNERS\r
13168         SOJGE   E,.-3           ; COUNT THEM\r
13169 NXTCHN: ADDI    B,2\r
13170         SOJN    A,CHNLP\r
13171 \r
13172         SKIPN   B,CHNL0(TVP)+1  ;NOW HACK LIST OF PSUEDO CHANNELS\r
13173         JRST    MAKLST\r
13174 CHNLS:  PUSH    TP,(B)\r
13175         PUSH    TP,(B)+1\r
13176         ADDI    C,1\r
13177         HRRZ    B,(B)\r
13178         JUMPN   B,CHNLS\r
13179 \r
13180 MAKLST: ACALL   C,LIST\r
13181         JRST    FINIS\r
13182 \r
13183 \f; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE\r
13184 \r
13185 \r
13186 REOPN:  PUSH    TP,$TCHAN\r
13187         PUSH    TP,B\r
13188         SKIPN   CHANNO(B)       ; ONLY REAL CHANNELS\r
13189         JRST    PSUEDO\r
13190 \r
13191 IFN ITS,[\r
13192         MOVSI   E,-4            ; SET UP POINTER FOR NAMES\r
13193 \r
13194 GETOPB: MOVE    B,(TP)          ; GET CHANNEL\r
13195         MOVEI   A,@RDTBL(E)     ; GET POINTER\r
13196         MOVE    B,(A)           ; NOW STRING\r
13197         MOVE    A,-1(A)\r
13198         PUSHJ   P,STRTO6        ; LEAVES SIXBIT ON STACK\r
13199         AOBJN   E,GETOPB\r
13200 ]\r
13201 IFE ITS,[\r
13202         MOVE    A,RDEVIC-1(B)\r
13203         MOVE    B,RDEVIC(B)\r
13204         PUSHJ   P,STRTO6        ; GET DEV NAME IN SIXBIT\r
13205 ]\r
13206         MOVE    B,(TP)          ; RESTORE CHANNEL\r
13207         MOVE    A,DIRECT-1(B)\r
13208         MOVE    B,DIRECT(B)\r
13209         PUSHJ   P,CHMOD ; CHECK FOR A VALID MODE\r
13210 \r
13211 IFN ITS,        HLRZS   E,-3(P)         ; GET DEVICE IN PROPER PLACE\r
13212 IFE ITS,        HLRZS   E,(P)\r
13213         MOVE    B,(TP)          ; RESTORE CHANNEL\r
13214         CAIN    E,(SIXBIT /DSK/)\r
13215         JRST    DISKH           ; DISK WINS IMMEIDATELY\r
13216         CAIN    E,(SIXBIT /TTY/)        ; NO NEED TO RE-OPEN THE TTY\r
13217         JRST    REOPD1\r
13218 IFN ITS,[\r
13219         ANDI    E,777700        ; COULD BE "UTn"\r
13220         MOVE    D,CHANNO(B)     ; GET CHANNEL\r
13221         ASH     D,1\r
13222         ADDI    D,CHNL0(TVP)    ; DON'T SEEM TO BE OPEN\r
13223         SETZM   1(D)\r
13224         SETZM   CHANNO(B)\r
13225         CAIN    E,(SIXBIT /UT /)\r
13226         JRST    REOPD           ; CURRENTLY, CANT RESTORE UTAPE CHANNLES\r
13227         CAIN    E,(SIXBIT /AI /)\r
13228         JRST    REOPD           ; CURRENTLY CANT RESTORE AI CHANNELS\r
13229         CAIN    E,(SIXBIT /ML /)\r
13230         JRST    REOPD           ; CURRENTLY CANT RESTORE ML CHANNELS\r
13231         CAIN    E,(SIXBIT /DM /)\r
13232         JRST    REOPD           ; CURRENTLY CANT RESTORE DM CHANNELS\r
13233 ]\r
13234         PUSH    TP,$TCHAN       ; TRY TO RESET IT \r
13235         PUSH    TP,B\r
13236         MCALL   1,FRESET\r
13237 \r
13238 IFN ITS,[\r
13239 REOPD1: AOS     -4(P)\r
13240 REOPD:  SUB     P,[4,,4]\r
13241 ]\r
13242 IFE ITS,[\r
13243 REOPD1: AOS     -1(P)\r
13244 REOPD:  SUB     P,[1,,1]\r
13245 ]\r
13246 REOPD0: SUB     TP,[2,,2]\r
13247         POPJ    P,\r
13248 \r
13249 IFN ITS,[\r
13250 DISKH:  MOVE    C,(P)           ; SNAME\r
13251         .SUSET  [.SSNAM,,C]\r
13252 ]\r
13253 IFE ITS,[\r
13254 DISKH:  MOVEM   A,(P)           ; SAVE MODE WORD\r
13255         PUSHJ   P,STSTK         ; STRING TO STACK\r
13256         MOVE    A,(E)           ; RESTORE MODE WORD\r
13257         PUSH    TP,$TPDL\r
13258         PUSH    TP,E            ; SAVE PDL BASE\r
13259         MOVE    B,-2(TP)        ; CHANNEL BACK TO B\r
13260 ]\r
13261         MOVE    C,ACCESS(B)     ; GET CHANNELS ACCESS\r
13262         TRNN    A,2             ; SKIP IF NOT ASCII CHANNEL\r
13263         JRST    DISKH1\r
13264         HRRZ    D,ACCESS-1(B)   ; IF PARTIAL WORD OUT\r
13265         IMULI   C,5             ; TO CHAR ACCESS\r
13266         JUMPE   D,DISKH1        ; NO SWEAT\r
13267         ADDI    C,(D)\r
13268         SUBI    C,5\r
13269 DISKH1: HRRZ    D,BUFSTR-1(B)   ; ANY CHARS IN MUDDLE BUFFER\r
13270         JUMPE   D,DISKH2\r
13271         PUSH    P,A\r
13272         PUSH    P,C\r
13273         MOVEI   C,BUFSTR-1(B)\r
13274         PUSHJ   P,BYTDOP        ; FIND LENGTH OF WHOLE BUFFER\r
13275         HLRZ    D,(A)           ; LENGTH + 2 TO D\r
13276         SUBI    D,2\r
13277         IMULI   D,5             ; TO CHARS\r
13278         POP     P,C\r
13279         POP     P,A\r
13280 DISKH2: SUBI    C,(D)           ; UPDATE CHAR ACCESS\r
13281         IDIVI   C,5             ; BACK TO WORD ACCESS\r
13282         IORI    A,6             ; BLOCK IMAGE\r
13283 IFN ITS,[\r
13284         TRNE    A,1\r
13285         IORI    A,100000        ; WRITE OVER BIT\r
13286         HRLM    A,-3(P)\r
13287         MOVEI   A,-3(P)\r
13288         PUSHJ   P,DOOPN\r
13289         JRST    REOPD\r
13290         MOVE    A,C             ; ACCESS TO A\r
13291         PUSHJ   P,GETFLN        ; CHECK LENGTH\r
13292         CAIGE   0,(A)           ; CHECK BOUNDS\r
13293         JRST    .+3             ; COMPLAIN\r
13294         PUSHJ   P,DOACCS        ; AND ACESS\r
13295         JRST    REOPD1          ; SUCCESS\r
13296 \r
13297         MOVE    A,CHANNO(B)     ; CLOSE THE G.D. CHANNEL\r
13298         PUSHJ   P,MCLOSE\r
13299         JRST    REOPD\r
13300 \r
13301 DOACCS: PUSH    P,A\r
13302         HRLZ    A,CHANNO(B)\r
13303         ASH     A,5\r
13304         IOR     A,[.ACCESS (P)]\r
13305         XCT     A\r
13306         POP     P,A\r
13307         POPJ    P,\r
13308 \r
13309 DOIOTO:\r
13310 DOIOTI:\r
13311 DOIOT:\r
13312         PUSH    P,0\r
13313         MOVSI   0,TCHAN\r
13314         MOVEM   0,BSTO(PVP)     ; IN CASE OF INTERRUPT\r
13315         ENABLE\r
13316         HRLZ    0,CHANNO(B)\r
13317         ASH     0,5\r
13318         IOR     0,[.IOT A]\r
13319         XCT     0\r
13320         DISABLE\r
13321         SETZM   BSTO(PVP)\r
13322         POP     P,0\r
13323         POPJ    P,\r
13324 \r
13325 GETFLN: MOVE    0,CHANNO(B)     ; GET CHANNEL\r
13326         .CALL   FILBLK          ; READ LNTH\r
13327         .VALUE\r
13328         POPJ    P,\r
13329 \r
13330 FILBLK: SETZ\r
13331         SIXBIT /FILLEN/\r
13332         0\r
13333         402000,,0       ; STUFF RESULT IN 0\r
13334 ]\r
13335 IFE ITS,[\r
13336 \r
13337         HRROI   B,1(E)          ; TENEX STRING POINTER\r
13338         MOVEI   A,1(P)          ; A POINT TO BLOCK OF INFO\r
13339         PUSH    P,[100400,,0]   ; FORCE JFN REUSE AND ONLY ACCEPT EXISTING FILE\r
13340         PUSH    P,[377777,,377777]      ; NO I/O FOR CORRECTIONS ETC.\r
13341         REPEAT  6,PUSH P,[0]            ; OTHER SLOTS\r
13342         MOVE    D,-2(TP)        ; CHANNEL BACK\r
13343         PUSH    P,CHANNO(D)     ; AND DESIRED JFN\r
13344         GTJFN                   ; GO GET IT\r
13345         JRST    RGTJL           ; COMPLAIN\r
13346         MOVE    P,(TP)          ; RESTORE P\r
13347         MOVE    A,(P)           ; MODE WORD BACK\r
13348         MOVE    B,[440000,,200000]      ; FLAG BITS\r
13349         TRNE    A,1             ; SKIP FOR INPUT\r
13350         TRC     B,300000        ; CHANGE TO WRITE\r
13351         MOVE    A,CHANNO(D)     ; GET JFN\r
13352         OPENF\r
13353         JRST    ROPFLS\r
13354         MOVE    E,C             ; LENGTH TO E\r
13355         SIZEF                   ; GET CURRENT LENGTH\r
13356         JRST    ROPFLS\r
13357         CAMGE   B,E             ; STILL A WINNER\r
13358         JRST    ROPFLS\r
13359         MOVE    A,-2(TP)        ; CHANNEL\r
13360         MOVE    A,CHANNO(A)     ; JFN\r
13361         MOVE    B,C\r
13362         SFPTR\r
13363         JRST    ROPFLS\r
13364         SUB     TP,[2,,2]       ; FLUSH PDL POINTER\r
13365         JRST    REOPD1\r
13366 \r
13367 ROPFLS: MOVE    A,-2(TP)\r
13368         MOVE    A,CHANNO(A)\r
13369         CLOSF                   ; ATTEMPT TO CLOSE\r
13370         JFCL                    ; IGNORE FAILURE\r
13371         SKIPA\r
13372 \r
13373 RGTJL:  MOVE    P,(TP)\r
13374         SUB     TP,[2,,2]\r
13375         JRST    REOPD\r
13376 \r
13377 DOACCS: PUSH    P,B\r
13378         EXCH    A,B\r
13379         MOVE    A,CHANNO(A)\r
13380         SFPTR\r
13381         JRST    ACCFAI\r
13382         POP     P,B\r
13383         POPJ    P,\r
13384 ]\r
13385 PSUEDO: AOS     (P)             ; ASSUME SUCCESS FOR NOW\r
13386         MOVEI   B,RDEVIC-1(B)   ; SEE WHAT DEVICE IS\r
13387         PUSHJ   P,CHRWRD\r
13388         JFCL\r
13389         CAME    B,[ASCII /E&S/] ; DISPLAY ?\r
13390         CAMN    B,[ASCII /DIS/]\r
13391         SKIPA   B,(TP)          ; YES, REGOBBLE CHANNEL AND CONTINUE\r
13392         JRST    REOPD0          ; NO, RETURN HAPPY\r
13393         PUSHJ   P,DISROP\r
13394         SOS     (P)             ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS\r
13395         JRST    REOPD0\r
13396 \r
13397 \f;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL\r
13398 \r
13399 MFUNCTION FCLOSE,SUBR,[CLOSE]\r
13400 \r
13401         ENTRY   1               ;ONLY ONE ARG\r
13402         GETYP   A,(AB)          ;CHECK ARGS\r
13403         CAIE    A,TCHAN         ;IS IT A CHANNEL\r
13404         JRST    WTYP1\r
13405         MOVE    B,1(AB)         ;PICK UP THE CHANNEL\r
13406         HRRZ    A,CHANNO-1(B)   ; GET REF COUNT\r
13407         SOJGE   A,CFIN5         ;  NOT READY TO REALLY CLOSE\r
13408         CAME    B,TTICHN+1(TVP) ; CHECK FOR TTY\r
13409         CAMN    B,TTOCHN+1(TVP)\r
13410         JRST    CLSTTY\r
13411         MOVE    A,[JRST CHNCLS]\r
13412         MOVEM   A,IOINS(B)      ;CLOBBER THE IO INS\r
13413         MOVE    A,RDEVIC-1(B)   ;GET THE NAME OF THE DEVICE\r
13414         MOVE    B,RDEVIC(B)\r
13415         PUSHJ   P,STRTO6\r
13416         HLRZS   A,(P)\r
13417         MOVE    B,1(AB)         ; RESTORE CHANNEL\r
13418         CAIE    A,(SIXBIT /E&S/)\r
13419         CAIN    A,(SIXBIT /DIS/)\r
13420         PUSHJ   P,DISCLS\r
13421         MOVE    B,1(AB)         ; IN CASE CLOBBERED BY DISCLS\r
13422         SKIPN   A,CHANNO(B)     ;ANY REAL CHANNEL?\r
13423         JRST    REMOV           ; NO, EITHER  CLOSED OR PSEUDO CHANNEL\r
13424 \r
13425         MOVE    A,DIRECT-1(B)   ; POINT TO DIRECTION\r
13426         MOVE    B,DIRECT(B)\r
13427         PUSHJ   P,STRTO6        ; CONVERT TO WORD\r
13428         POP     P,A\r
13429         LDB     E,[140600,,(P)] ; FIRST CHAR OD DEV NAME\r
13430         CAIE    E,'T            ; SKIP IF TTY\r
13431         JRST    CFIN4\r
13432         CAME    A,[SIXBIT /READ/]       ; SKIP IF WINNER\r
13433         JRST    CFIN1\r
13434 IFN ITS,[\r
13435         MOVE    B,1(AB)         ; IN ITS CHECK STATUS\r
13436         LDB     A,[600,,STATUS(B)]\r
13437         CAILE   A,2\r
13438         JRST    CFIN1\r
13439 ]\r
13440         PUSH    TP,$TCHSTR\r
13441         PUSH    TP,CHQUOTE CHAR\r
13442         PUSH    TP,(AB)\r
13443         PUSH    TP,1(AB)\r
13444         MCALL   2,OFF           ; TURN OFF INTERRUPT\r
13445 CFIN1:  MOVE    B,1(AB)\r
13446         MOVE    A,CHANNO(B)\r
13447 IFN ITS,[\r
13448         PUSHJ   P,MCLOSE\r
13449 ]\r
13450 IFE ITS,[\r
13451         TLZ     A,400000        ; FOR JFN RELEASE\r
13452         CLOSF                   ; CLOSE THE FILE AND RELEASE THE JFN\r
13453         JFCL\r
13454         MOVE    A,CHANNO(B)\r
13455 ]\r
13456 CFIN:   LSH     A,1\r
13457         ADDI    A,CHNL0+1(TVP)  ;POINT TO THIS CHANNELS LSOT\r
13458         SETZM   CHANNO(B)\r
13459         SETZM   (A)             ;AND CLOBBER IT\r
13460         HLLZS   BUFSTR-1(B)\r
13461         SETZM   BUFSTR(B)\r
13462         HLLZS   ACCESS-1(B)\r
13463 CFIN2:  HLLZS   -4(B)\r
13464         MOVSI   A,TCHAN         ;RETURN THE CHANNEL\r
13465         JRST    FINIS\r
13466 \r
13467 CLSTTY: PUSH    TP,$TATOM\r
13468         PUSH    TP,EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL\r
13469         JRST    CALER1\r
13470 \r
13471 \r
13472 REMOV:  MOVEI   D,CHNL0(TVP)+1  ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST\r
13473 REMOV0: SKIPN   C,D             ;FOUND ON LIST ?\r
13474         JRST    CFIN2           ;NO, JUST IGNORE THIS CLOSED CHANNEL\r
13475         HRRZ    D,(C)           ;GET POINTER TO NEXT\r
13476         CAME    B,(D)+1         ;FOUND ?\r
13477         JRST    REMOV0\r
13478         HRRZ    D,(D)           ;YES, SPLICE IT OUT\r
13479         HRRM    D,(C)\r
13480         JRST    CFIN2\r
13481 \r
13482 \r
13483 ; CLOSE UP ANY LEFTOVER BUFFERS\r
13484 \r
13485 CFIN4:  CAME    A,[SIXBIT /PRINTO/]\r
13486         CAMN    A,[SIXBIT /PRINTB/]\r
13487         JRST    .+3\r
13488         CAME    A,[SIXBIT /PRINT/]\r
13489         JRST    CFIN1\r
13490         MOVE    B,1(AB)         ; GET CHANNEL\r
13491         GETYP   0,BUFSTR-1(B)   ; IS THERE AN OUTPUT BUFFER\r
13492         SKIPN   BUFSTR(B)\r
13493         JRST    CFIN1\r
13494         CAIE    0,TCHSTR\r
13495         JRST    CFINX1\r
13496 IFE ITS,        PUSH    P,A             ; SAVE MODE\r
13497         PUSHJ   P,BFCLOS\r
13498 IFE ITS,[\r
13499         POP     P,A             ; RESTORE MODE\r
13500         MOVE    0,RDEVIC(B)\r
13501         ILDB    0,0\r
13502         CAIN    0,"D\r
13503         CAME    A,[SIXBIT /PRINT/]\r
13504         JRST    CFINX1\r
13505         MOVE    A,CHANNO(B)     ; GET JFN\r
13506         TLO     A,400000        ; BIT MEANS DONT RELEASE JFN\r
13507         CLOSF                   ; CLOSE THE FILE\r
13508         FATAL   CLOSF LOST?\r
13509         MOVE    E,B             ; SAVE CHANNEL\r
13510         MOVE    A,CHANNO(B)\r
13511         HRLI    A,11\r
13512         MOVSI   B,7700          ; MASK\r
13513         MOVSI   C,700           ; MAKE NEW SIZE 7\r
13514         CHFDB\r
13515         HRLI    A,12\r
13516         SETOM   B\r
13517         MOVE    C,ACCESS(E)     ; LENGTH IN CHARS\r
13518         CHFDB\r
13519 ]\r
13520         HLLZS   BUFSTR-1(B)\r
13521         SETZM   BUFSTR(B)\r
13522 CFINX1: HLLZS   ACCESS-1(B)\r
13523         JRST    CFIN1\r
13524 \r
13525 CFIN5:  HRRM    A,CHANNO-1(B)\r
13526         JRST    CFIN2\r
13527 \f;SUBR TO DO .ACCESS ON A READ CHANNEL\r
13528 ;FORM:  <ACCESS  CHANNEL FIX-NUMBER>\r
13529 ;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER\r
13530 ;H. BRODIE 7/26/72\r
13531 \r
13532 MFUNCTION MACCESS,SUBR,[ACCESS]\r
13533         ENTRY   2       ;ARGS: CHANNEL AND FIX-NUMBER\r
13534 \r
13535 ;CHECK ARGUMENT TYPES\r
13536         GETYP   A,(AB)\r
13537         CAIE    A,TCHAN         ;FIRST ARG SHOULD BE CHANNEL\r
13538         JRST    WTYP1\r
13539         GETYP   A,2(AB)         ;TYPE OF SECOND\r
13540         CAIE    A,TFIX          ;SHOULD BE FIX\r
13541         JRST    WTYP2\r
13542 \r
13543 ;CHECK DIRECTION OF CHANNEL\r
13544         MOVE    B,1(AB)         ;B GETS PNTR TO CHANNEL\r
13545         MOVEI   B,DIRECT-1(B)   ;GET DIRECTION OF CHANNEL\r
13546         PUSHJ   P,CHRWRD        ;GRAB THE CHAR STRNG\r
13547         JFCL\r
13548         CAME    B,[<ASCII /PRINT/>+1]\r
13549         JRST    MACCA\r
13550         PUSH    P,[2]           ;ACCESS ON PRINTB CHANNEL\r
13551         MOVE    B,1(AB)\r
13552         SKIPE   BUFSTR(B)       ;SEE IF WE MUST FLUSH PART BUFFER\r
13553         PUSHJ   P,BFCLS1\r
13554         JRST    MACC\r
13555 MACCA:  PUSH    P,[0]           ; READ RATHER THAN READB INDICATOR\r
13556         CAMN    B,[ASCIZ /READ/]\r
13557         JRST    .+4\r
13558         CAME    B,[ASCIZ /READB/]       ; READB CHANNEL?\r
13559         JRST    WRONGD\r
13560         AOS     (P)                     ; SET INDICATOR FOR BINARY MODE\r
13561 \r
13562 ;CHECK THAT THE CHANNEL IS OPEN\r
13563 MACC:   MOVE    B,1(AB)         ;GET BACK PTR TO CHANNEL\r
13564         SKIPN   CHANNO(B)       ;CLOSED CHANNELS HAVE CHANNO ZEROED OUT\r
13565         JRST    CHNCLS  ;IF CHNL CLOSED => ERROR\r
13566 \r
13567 ;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN\r
13568 ;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER\r
13569 ADEVOK: SKIPGE  C,3(AB)         ;GET CHAR POSN...ALL NEGS = -5\r
13570         MOVNI   C,-5\r
13571 ;BUT .ACCESS -1 ISN'T IMPLEMENTED ON ITS YET, SO TELL HIM\r
13572         JUMPGE  C,MACC1\r
13573         PUSH    TP,$TATOM\r
13574         PUSH    TP,EQUOTE NEGATIVE-ACCESS-NOT-ON-ITS\r
13575         JRST    CALER1\r
13576 MACC1:  SKIPN   (P)\r
13577         IDIVI   C,5\r
13578 \r
13579 ;SETUP THE .ACCESS\r
13580         MOVE    B,1(AB)         ;GET BACK PTR TO CHANNEL\r
13581         MOVE    A,CHANNO(B)     ;A GETS REAL CHANNEL NUMBER\r
13582 IFN ITS,[\r
13583         ROT     A,23.           ;SET UP IN AC FIELD\r
13584         IOR     A,[.ACCESS 0,C] ;C CONTAINS PLACE TO ACCESS TO\r
13585 \r
13586 ;DO IT TO IT!\r
13587         XCT     A\r
13588 ]\r
13589 IFE ITS,[\r
13590         MOVE    B,C\r
13591         SFPTR                   ; DO IT IN TENEX\r
13592         JRST    ACCFAI\r
13593         MOVE    B,1(AB)         ; RESTORE CHANNEL\r
13594 ]\r
13595         POP     P,E             ; CHECK FOR READB MODE\r
13596         CAIN    E,2\r
13597         JRST    DONADV          ; PRINTB CHANNEL\r
13598         SKIPE   BUFSTR(B)       ; IS THERE A READ BUFFER TO FLUSH\r
13599         JRST    .+3\r
13600         SETZM   LSTCH(B)        ; CLEAR OUT POSSIBLE EOF INDICATOR\r
13601         JRST    DONADV\r
13602 \r
13603 ;NOW FORCE GETCHR TO DO A .IOT FIRST THING\r
13604         MOVEI   C,BUFSTR-1(B)   ; FIND END OF STRING\r
13605         PUSHJ   P,BYTDOP"\r
13606         SUBI    A,2             ; LAST REAL WORD\r
13607         HRLI    A,010700\r
13608         MOVEM   A,BUFSTR(B)\r
13609         HLLZS   BUFSTR-1(B)     ; CLOBBER CHAR COUNT\r
13610         MOVEM   A,BUFSTR(B)\r
13611         SETZM   LSTCH(B)        ;CLOBBER READ'S HIDDEN CHARACTER\r
13612 \r
13613 ;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS\r
13614         JUMPLE  D,DONADV\r
13615 ADVPTR: PUSHJ   P,GETCHR\r
13616         MOVE    B,1(AB)         ;RESTORE IN CASE CLOBBERED\r
13617         SOJG    D,ADVPTR\r
13618 \r
13619 DONADV: MOVE    C,3(AB)         ;FIXUP ACCESS SLOT IN CHNL\r
13620         MOVEM   C,ACCESS(B)\r
13621         MOVE    A,$TCHAN        ;TYPE OF RESULT = "CHANNEL"\r
13622         JRST    FINIS           ;DONE...B CONTAINS CHANNEL\r
13623 \r
13624 IFE ITS,[\r
13625 ACCFAI: PUSH    TP,$TATOM\r
13626         PUSH    TP,EQUOTE ACCESS-FAILURE\r
13627         JRST    CALER1\r
13628 ]\r
13629 \r
13630 \r
13631 ;WRONG TYPE OF DEVICE ERROR\r
13632 WRDEV:  PUSH    TP,$TATOM\r
13633         PUSH    TP,EQUOTE NON-DSK-DEVICE\r
13634         JRST    CALER1\r
13635 \f\r
13636 ; BINARY READ AND PRINT ROUTINES\r
13637 \r
13638 MFUNCTION PRINTB,SUBR\r
13639 \r
13640         ENTRY   2\r
13641 \r
13642 PBFL:   PUSH    P,.             ; PUSH NON-ZERONESS\r
13643         JRST    BINI1\r
13644 \r
13645 MFUNCTION READB,SUBR\r
13646 \r
13647         ENTRY\r
13648 \r
13649         PUSH    P,[0]\r
13650         HLRZ    0,AB\r
13651         CAIG    0,-3\r
13652         CAIG    0,-7\r
13653         JRST    WNA\r
13654 \r
13655 BINI1:  GETYP   0,(AB)          ; SHOULD BE UVEC OR STORE\r
13656         CAIN    0,TUVEC\r
13657         JRST    BINI2\r
13658         CAIE    0,TSTORAGE\r
13659         JRST    WTYP1           ; ELSE LOSE\r
13660 BINI2:  MOVE    B,1(AB)         ; GET IT\r
13661         HLRE    C,B\r
13662         SUBI    B,(C)           ; POINT TO DOPE\r
13663         GETYP   A,(B)\r
13664         PUSHJ   P,SAT"          ; GET ITS ST.ALOC.TYPE\r
13665         CAIE    A,S1WORD\r
13666         JRST    WTYP1\r
13667         GETYP   0,2(AB)\r
13668         CAIE    0,TCHAN         ; BETTER BE A CHANNEL\r
13669         JRST    WTYP2\r
13670         MOVE    B,3(AB)         ; GET IT\r
13671         MOVEI   B,DIRECT-1(B)   ; GET DIRECTION OF\r
13672         PUSHJ   P,CHRWRD        ; INTO 1 WORD\r
13673         JFCL\r
13674         MOVNI   E,1\r
13675         CAMN    B,[ASCII /READB/]\r
13676         MOVEI   E,0\r
13677         CAMN    B,[<ASCII /PRINT/>+1]\r
13678         MOVE    E,PBFL\r
13679         JUMPL   E,WRONGD                ; LOSER\r
13680         CAME    E,(P)           ; CHECK WINNGE\r
13681         JRST    WRONGD\r
13682         MOVE    B,3(AB)         ; GET CHANNEL BACK\r
13683         SKIPN   A,IOINS(B)      ; OPEN?\r
13684         PUSHJ   P,OPENIT                ; LOSE\r
13685         CAMN    A,[JRST CHNCLS]\r
13686         JRST    CHNCLS          ; LOSE, CLOSED\r
13687         JUMPN   E,BUFOU1        ; JUMP FOR OUTPUT\r
13688         CAML    AB,[-5,,]       ; SKIP IF EOF GIVEN\r
13689         JRST    BINI5\r
13690         MOVE    0,4(AB)\r
13691         MOVEM   0,EOFCND-1(B)\r
13692         MOVE    0,5(AB)\r
13693         MOVEM   0,EOFCND(B)\r
13694 BINI5:  SKIPE   LSTCH(B)        ; INDICATES IF EOF HIT\r
13695         JRST    BINEOF\r
13696         MOVE    A,1(AB)         ; GET VECTOR\r
13697         PUSHJ   P,PGBIOI        ; READ IT\r
13698         HLRE    C,A             ; GET COUNT DONE\r
13699         HLRE    D,1(AB) ; AND FULL COUNT\r
13700         SUB     C,D             ; C=> TOTAL READ\r
13701         ADDM    C,ACCESS(B)\r
13702         JUMPGE  A,BINIOK        ; NOT EOF YET\r
13703         SETOM   LSTCH(B)\r
13704 BINIOK: MOVE    B,C\r
13705         MOVSI   A,TFIX          ; RETURN AMOUNT ACTUALLY READ\r
13706         JRST    FINIS\r
13707 \r
13708 BUFOU1: SKIPE   BUFSTR(B)       ; ANY BUFFERS AROUND?\r
13709         PUSHJ   P,BFCLS1        ; GET RID OF SAME\r
13710         MOVE    A,1(AB)\r
13711         PUSHJ   P,PGBIOO\r
13712         HLRE    C,1(AB)\r
13713         MOVNS   C\r
13714         addm    c,ACCESS(B)\r
13715         MOVE    A,(AB)          ; RET VECTOR ETC.\r
13716         MOVE    B,1(AB)\r
13717         JRST    FINIS\r
13718 \r
13719 \r
13720 BINEOF: PUSH    TP,EOFCND-1(B)\r
13721         PUSH    TP,EOFCND(B)\r
13722         PUSH    TP,$TCHAN\r
13723         PUSH    TP,B\r
13724         MCALL   1,FCLOSE        ; CLOSE THE LOSER\r
13725         MCALL   1,EVAL\r
13726         JRST    FINIS\r
13727 \r
13728 OPENIT: PUSH    P,E\r
13729         PUSHJ   P,OPNCHN        ;TRY TO OPEN THE LOSER\r
13730         JUMPE   B,CHNCLS        ;FAIL\r
13731         POP     P,E\r
13732         POPJ    P,\r
13733 \f; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE\r
13734 ; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF\r
13735 ; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS.\r
13736 \r
13737 R1CHAR: SKIPN   A,LSTCH(B)              ; CHAR READING ROUTINE FOR FCOPY\r
13738         PUSHJ   P,RXCT\r
13739         MOVEM   A,LSTCH(B)\r
13740         JUMPL   A,.+2                   ; IN CASE OF -1 ON STY\r
13741         TRZN    A,400000                ; EXCL HACKER\r
13742         JRST    .+4\r
13743         MOVEM   A,LSTCH(B)              ; SAVE DE-EXCLED CHAR\r
13744         MOVEI   A,"!\r
13745         JRST    .+2\r
13746         SETZM   LSTCH(B)\r
13747         PUSH    P,C\r
13748         HRRZ    C,DIRECT-1(B)\r
13749         CAIE    C,5                     ; IF DIRECTION IS 5 LONG THEN READB\r
13750         JRST    R1CH1\r
13751         AOS     C,ACCESS-1(B)\r
13752         CAMN    C,[TFIX,,1]\r
13753         AOS     ACCESS(B)               ; EVERY FIFTY INCREMENT\r
13754         CAMN    C,[TFIX,,5]\r
13755         HLLZS   ACCESS-1(B)\r
13756         JRST    .+2\r
13757 R1CH1:  AOS     ACCESS(B)\r
13758         POP     P,C\r
13759         POPJ    P,\r
13760 \r
13761 W1CHAR: CAIE    A,15            ; CHAR WRITING ROUTINE, TEST FOR CR\r
13762         JRST    .+3\r
13763         SETOM   CHRPOS(B)\r
13764         AOSA    LINPOS(B)\r
13765         CAIE    A,12                    ; TEST FOR LF\r
13766         AOS     CHRPOS(B)               ; IF NOT LF AOS CHARACTE5R POSITION\r
13767         CAIE    A,14                    ; TEST FOR FORM FEED\r
13768         JRST    .+3\r
13769         SETZM   CHRPOS(B)               ; IF FORM FEED ZERO CHARACTER POSITION\r
13770         SETZM   LINPOS(B)               ; AND LINE POSITION\r
13771         CAIE    A,11                    ; IS THIS A TAB?\r
13772         JRST    .+6\r
13773         MOVE    C,CHRPOS(B)\r
13774         ADDI    C,7\r
13775         IDIVI   C,8.\r
13776         IMULI   C,8.                    ; FIX UP CHAR POS FOR TAB\r
13777         MOVEM   C,CHRPOS(B)             ; AND SAVE\r
13778         PUSH    P,C\r
13779         HRRZ    C,DIRECT-1(B)\r
13780         CAIE    C,6                     ; SIX LONG MUST BE PRINTB\r
13781         JRST    W1CH1\r
13782         AOS     C,ACCESS-1(B)\r
13783         CAMN    C,[TFIX,,1]\r
13784         AOS     ACCESS(B)\r
13785         CAMN    C,[TFIX,,5]\r
13786         HLLZS   ACCESS-1(B)\r
13787         JRST    .+2\r
13788 W1CH1:  AOS     ACCESS(B)\r
13789         PUSHJ   P,WXCT\r
13790         POP     P,C\r
13791         POPJ    P,\r
13792 \r
13793 R1C:    SUBM    M,(P)                   ;LITTLE ENTRY FOR COMPILED STUFF\r
13794         PUSH    TP,$TCHAN               ;SAVE THE CHANNEL TO BLESS IT\r
13795         PUSH    TP,B\r
13796         MOVEI   B,DIRECT-1(B)\r
13797         PUSHJ   P,CHRWRD\r
13798         JFCL\r
13799         CAME    B,[ASCIZ /READ/]\r
13800         CAMN    B,[ASCII /READB/]\r
13801         JRST    .+2\r
13802         JRST    BADCHN\r
13803         POP     TP,B\r
13804         POP     TP,(TP)\r
13805         SKIPN   IOINS(B)                ; IS THE CHANNEL OPEN\r
13806         PUSHJ   P,OPENIT                ; NO, GO DO IT\r
13807         PUSHJ   P,GRB                   ; MAKE SURE WE HAVE A READ BUFFER\r
13808         PUSHJ   P,R1CHAR                ; AND GET HIM A CHARACTER\r
13809         JRST    MPOPJ                   ; THATS ALL FOLKS\r
13810 \r
13811 W1C:    SUBM    M,(P)\r
13812         PUSHJ   P,W1CI\r
13813         JRST    MPOPJ\r
13814 \r
13815 W1CI:   PUSH    TP,$TCHAN\r
13816         PUSH    TP,B\r
13817         PUSH    P,A                     ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR\r
13818         MOVEI   B,DIRECT-1(B)\r
13819         PUSHJ   P,CHRWRD                ; INTERNAL CALL TO W1CHAR\r
13820         JFCL\r
13821         CAME    B,[ASCII /PRINT/]\r
13822         CAMN    B,[<ASCII /PRINT/>+1]\r
13823         JRST    .+2\r
13824         JRST    BADCHN\r
13825         POP     TP,B\r
13826         POP     TP,(TP)\r
13827         SKIPN   IOINS(B)                ; MAKE SURE THAT IT IS OPEN\r
13828         PUSHJ   P,OPENIT\r
13829         PUSHJ   P,GWB\r
13830         POP     P,A                     ; GET THE CHAR TO DO\r
13831         JRST    W1CHAR\r
13832 \r
13833 ; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT\r
13834 ; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH.\r
13835 \r
13836 \r
13837 WXCT:   PUSH    P,A                     ; SAVE THE CHAR TO WRITE\r
13838         PUSH    TP,$TCHAN               ; AND SAVE THE CHANNEL TOO\r
13839         PUSH    TP,B\r
13840         XCT     IOINS(B)                ; DO THE REAL ONE\r
13841         JRST    DOSCPT                  ; AND CHECK OUT SCRIPTAGE\r
13842 \r
13843 RXCT:   PUSH    TP,$TCHAN\r
13844         PUSH    TP,B                    ; DO IT FOR READS, SAVE THE CHAN\r
13845         XCT     IOINS(B)                ; READ IT\r
13846         PUSH    P,A                     ; AND SAVE THE CHAR AROUND\r
13847         JRST    DOSCPT                  ; AND CHECK OUT SCRIPTAGE\r
13848 \r
13849 DOSCPT: MOVE    B,(TP)                  ;CHECK FOR SCRIPTAGE\r
13850         SKIPN   SCRPTO(B)               ; IF ZERO FORGET IT\r
13851         JRST    SCPTDN                  ; THATS ALL THERE IS TO IT\r
13852         PUSH    P,C                     ; SAVE AN ACCUMULATOR FOR CLEANLINESS\r
13853         GETYP   C,SCRPTO-1(B)           ; IS IT A LIST\r
13854         CAIE    C,TLIST\r
13855         JRST    BADCHN\r
13856         PUSH    TP,$TLIST\r
13857         PUSH    TP,[0]          ; SAVE A SLOT FOR THE LIST\r
13858         MOVE    C,SCRPTO(B)             ; GET THE LIST OF SCRIPT CHANNELS\r
13859 SCPT1:  GETYP   B,(C)                   ; GET THE TYPE OF THIS SCRIPT CHAN\r
13860         CAIE    B,TCHAN\r
13861         JRST    BADCHN                  ; IF IT ISN'T A CHANNEL, COMPLAIN\r
13862         HRRZ    B,(C)                   ; GET THE REST OF THE LIST IN B\r
13863         MOVEM   B,(TP)                  ; AND STORE ON STACK\r
13864         MOVE    B,1(C)                  ; GET THE CHANNEL IN B\r
13865         MOVE    A,-1(P)                 ; AND THE CHARACTER IN A\r
13866         PUSHJ   P,W1CI          ; GO TO INTERNAL W1C, IT BLESSES GOODIES\r
13867         SKIPE   C,(TP)                  ; GET THE REST OF LIST OF CHANS\r
13868         JRST    SCPT1                   ; AND CYCLE THROUGH\r
13869         SUB     TP,[2,,2]               ; CLEAN OFF THE LIST OF CHANS\r
13870         POP     P,C                     ; AND RESTORE ACCUMULATOR C\r
13871 SCPTDN: POP     P,A                     ; RESTORE THE CHARACTER\r
13872         POP     TP,B                    ; AND THE ORIGINAL CHANNEL\r
13873         POP     TP,(TP)\r
13874         POPJ    P,                      ; AND THATS ALL\r
13875 \r
13876 \r
13877 ; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT\r
13878 ; ON THE INPUT CHANNEL\r
13879 ; CALL IS <FILECOPY IN OUT> WHERE DEFAULTS ARE INCHAN AND OUTCHAN\r
13880 \r
13881         MFUNCTION       FCOPY,SUBR,[FILECOPY]\r
13882 \r
13883         ENTRY\r
13884         HLRE    0,AB\r
13885         CAMGE   0,[-4]\r
13886         JRST    WNA                     ; TAKES FROM 0 TO 2 ARGS\r
13887 \r
13888         JUMPE   0,.+4                   ; NO FIRST ARG?\r
13889         PUSH    TP,(AB)\r
13890         PUSH    TP,1(AB)                ; SAVE IN CHAN\r
13891         JRST    .+6\r
13892         MOVE    A,$TATOM\r
13893         MOVE    B,IMQUOTE INCHAN\r
13894         PUSHJ   P,IDVAL\r
13895         PUSH    TP,A\r
13896         PUSH    TP,B\r
13897         HLRE    0,AB                    ; CHECK FOR SECOND ARG\r
13898         CAML    0,[-2]                  ; WAS THERE MORE THAN ONE ARG?\r
13899         JRST    .+4\r
13900         PUSH    TP,2(AB)                ; SAVE SECOND ARG\r
13901         PUSH    TP,3(AB)\r
13902         JRST    .+6\r
13903         MOVE    A,$TATOM                ; LOOK UP OUTCHAN AS DEFAULT\r
13904         MOVE    B,IMQUOTE OUTCHAN\r
13905         PUSHJ   P,IDVAL\r
13906         PUSH    TP,A\r
13907         PUSH    TP,B                    ; AND SAVE IT\r
13908 \r
13909         MOVE    A,-3(TP)\r
13910         MOVE    B,-2(TP)                ; INPUT CHANNEL\r
13911         MOVEI   0,0                             ; INDICATE INPUT\r
13912         PUSHJ   P,CHKCHN                ; CHECK FOR GOOD CHANNEL\r
13913         MOVE    A,-1(TP)\r
13914         MOVE    B,(TP)                  ; GET OUT CHAN\r
13915         MOVEI   0,1                     ; INDICATE OUT CHAN\r
13916         PUSHJ   P,CHKCHN                ; CHECK FOR GOOD OUT CHAN\r
13917 \r
13918         PUSH    P,[0]                   ; COUNT OF CHARS OUTPUT\r
13919 \r
13920         MOVE    B,-2(TP)\r
13921         PUSHJ   P,GRB                   ; MAKE SURE WE HAVE READ BUFF\r
13922         MOVE    B,(TP)\r
13923         PUSHJ   P,GWB                   ; MAKE SURE WE HAVE WRITE BUFF\r
13924 \r
13925 FCLOOP: MOVE    B,-2(TP)\r
13926         PUSHJ   P,R1CHAR                ; GET A CHAR\r
13927         JUMPL   A,FCDON                 ; IF A NEG NUMBER WE GOT EOF\r
13928         MOVE    B,(TP)                  ; GET OUT CHAN\r
13929         PUSHJ   P,W1CHAR                ; SPIT IT OUT\r
13930         AOS     (P)                     ; INCREMENT COUNT\r
13931         JRST    FCLOOP\r
13932 \r
13933 FCDON:  SUB     TP,[2,,2]               ; POP OFF OUTCHAN\r
13934         MCALL   1,FCLOSE                ; CLOSE INCHAN\r
13935         MOVE    A,$TFIX\r
13936         POP     P,B                     ; GET CHAR COUNT TO RETURN\r
13937         JRST FINIS\r
13938 \r
13939 CHKCHN: PUSH    P,0                     ; CHECK FOR GOOD TASTING CHANNEL\r
13940         PUSH    TP,A\r
13941         PUSH    TP,B\r
13942         GETYP   C,A\r
13943         CAIE    C,TCHAN\r
13944         JRST    CHKBDC                  ; GO COMPLAIN IN RIGHT WAY\r
13945         MOVEI   B,DIRECT-1(B)\r
13946         PUSHJ   P,CHRWRD\r
13947         JRST    CHKBDC\r
13948         MOVE    C,(P)                   ; GET CHAN DIRECT\r
13949         CAMN    B,CHKT(C)\r
13950         JRST    .+4\r
13951         ADDI    C,2                     ; TEST FOR READB OR PRINTB ALSO\r
13952         CAME    B,CHKT(C)               ; TEST FOR CORRECT DIRECT\r
13953         JRST    CHKBDC\r
13954         MOVE    B,(TP)\r
13955         SKIPN   IOINS(B)                ; MAKE SURE IT IS OPEN\r
13956         PUSHJ   P,OPENIT                ; IF ZERO IOINS GO OPEN IT\r
13957         SUB     TP,[2,,2]\r
13958         POP     P,                      ; CLEAN UP STACKS\r
13959         POPJ    P,\r
13960 \r
13961 CHKT:   ASCIZ /READ/\r
13962         ASCII /PRINT/\r
13963         ASCII /READB/\r
13964         <ASCII /PRINT/>+1\r
13965 \r
13966 CHKBDC: POP     P,E\r
13967         MOVNI   D,2\r
13968         IMULI   D,1(E)\r
13969         HLRE    0,AB\r
13970         CAMLE   0,D                     ; SEE IF THIS WAS HIS ARG OF DEFAULT\r
13971         JRST    BADCHN\r
13972         JUMPE   E,WTYP1\r
13973         JRST    WTYP2\r
13974 \r
13975 \f; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB,\r
13976 ; THAT IS THEY READ INTO AND OUT OF STRINGS.  IN ADDITION BOTH ACCEPT\r
13977 ; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF\r
13978 ; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING.\r
13979 \r
13980 ; FORMAT IS <READSTRING .STRING .INCHANNEL .EOFCOND .MAXCHARS>\r
13981 ; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN\r
13982 \r
13983 ; FORMAT FOR PRINTSTRING IS <PRINTSTRING .STRING .OUTCHANNEL .MAXCHARS>\r
13984 \r
13985 ; THESE WERE CODED 9/16/73 BY NEAL D. RYAN\r
13986 \r
13987         MFUNCTION       RSTRNG,SUBR,READSTRING\r
13988 \r
13989         ENTRY\r
13990         PUSH    P,[0]           ; FLAG TO INDICATE READING\r
13991         HLRE    0,AB\r
13992         CAMG    0,[-1]\r
13993         CAMG    0,[-9]\r
13994         JRST    WNA             ; CHECK THAT IT HAS FROM 1 TO 4 ARGS\r
13995         JRST    STRIO1\r
13996 \r
13997         MFUNCTION       PSTRNG,SUBR,PRINTSTRING\r
13998 \r
13999         ENTRY\r
14000         PUSH    P,[1]           ; FLAG TO INDICATE WRITING\r
14001         HLRE    0,AB\r
14002         CAMG    0,[-1]\r
14003         CAMG    0,[-7]\r
14004         JRST    WNA             ; CHECK THAT IT HAS FROM 1 TO 3 ARGS\r
14005 \r
14006 STRIO1: PUSH    TP,[0]          ; SAVE SLOT ON STACK\r
14007         PUSH    TP,[0]\r
14008         GETYP   0,(AB)\r
14009         CAIE    0,TCHSTR                ; MAKE SURE WE GOT STRING\r
14010         JRST    WTYP1\r
14011         HRRZ    0,(AB)          ; CHECK FOR EMPTY STRING\r
14012         SKIPN   (P)\r
14013         JUMPE   0,MTSTRN\r
14014         HLRE    0,AB\r
14015         CAML    0,[-2]          ; WAS A CHANNEL GIVEN\r
14016         JRST    STRIO2\r
14017         GETYP   0,2(AB)\r
14018         CAIE    0,TCHAN\r
14019         JRST    WTYP2           ; SECOND ARG NOT CHANNEL\r
14020         MOVE    B,3(AB)\r
14021         MOVEI   B,DIRECT-1(B)\r
14022         PUSHJ   P,CHRWRD\r
14023         JFCL\r
14024         MOVNI   E,1             ; CHECKING FOR GOOD DIRECTION\r
14025         CAMN    B,[ASCII /READ/]\r
14026         MOVEI   E,0\r
14027         CAMN    B,[ASCII /PRINT/]\r
14028         MOVEI   E,1\r
14029         CAMN    B,[<ASCII /PRINT/>+1]\r
14030         MOVEI   E,1\r
14031         CAMN    B,[ASCII /READB/]\r
14032         MOVEI   E,0\r
14033         CAME    E,(P)\r
14034         JRST    WRONGD          ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE\r
14035         PUSH    TP,2(AB)\r
14036         PUSH    TP,3(AB)        ; PUSH ON CHANNEL\r
14037         JRST    STRIO3\r
14038 STRIO2: MOVE    B,IMQUOTE INCHAN\r
14039         MOVSI   A,TCHAN\r
14040         SKIPE   (P)\r
14041         MOVE    B,IMQUOTE OUTCHAN\r
14042         PUSHJ   P,IDVAL\r
14043         TLZ     A,TYPMSK#777777\r
14044         CAME    A,$TCHAN\r
14045         JRST    BADCHN          ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL\r
14046         PUSH    TP,A\r
14047         PUSH    TP,B\r
14048 STRIO3: MOVE    B,(TP)          ; GET CHANNEL\r
14049         SKIPN   E,IOINS(B)              ; MAKE SURE HE IS OPEN\r
14050         PUSHJ   P,OPENIT                ; IF NOT GO OPEN\r
14051         CAMN    E,[JRST CHNCLS]\r
14052         JRST    CHNCLS          ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED\r
14053 STRIO4: HLRE    0,AB\r
14054         CAML    0,[-4]\r
14055         JRST    STRIO5          ; NO COUNT TO WORRY ABOUT\r
14056         GETYP   0,4(AB)\r
14057         MOVE    E,4(AB)\r
14058         MOVE    C,5(AB)\r
14059         CAIE    0,TCHSTR\r
14060         CAIN    0,TFIX          ; BETTER BE A FIXED NUMBER\r
14061         JRST    .+2\r
14062         JRST    WTYP3\r
14063         HRRZ    D,(AB)          ; GET ACTUAL STRING LENGTH\r
14064         CAIN    0,TFIX\r
14065         JRST    .+7\r
14066         SKIPE   (P)     ; TEST FOR WRITING\r
14067         JRST    .-7             ; IF WRITING WE GOT TROUBLE\r
14068         PUSH    P,D             ; ACTUAL STRING LENGTH\r
14069         MOVEM   E,(TB)  ; STUFF HIS FUNNY DELIM STRING\r
14070         MOVEM   C,1(TB)\r
14071         JRST    STRIO7\r
14072         CAML    D,C             ; MAKE SURE THE STRING IS LONG ENOUGH\r
14073         JRST    .+4             ; WIN\r
14074         PUSH    TP,$TATOM       ; LOSAGE, COUNT TOO GREAT\r
14075         PUSH    TP,EQUOTE COUNT-GREATER-THAN-STRING-SIZE\r
14076         JRST    CALER1\r
14077         PUSH    P,C     ; PUSH ON MAX COUNT\r
14078         JRST    STRIO7\r
14079 STRIO5:\r
14080 STRIO6: HRRZ    C,(AB)  ; GET CHAR COUNT\r
14081         PUSH    P,C             ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN\r
14082 STRIO7: HLRE    0,AB\r
14083         CAML    0,[-6]\r
14084         JRST    .+6\r
14085         MOVE    B,(TP)          ; GET THE CHANNEL\r
14086         MOVE    0,6(AB)\r
14087         MOVEM   0,EOFCND-1(B)   ; STUFF IN SLOT IN CHAN\r
14088         MOVE    0,7(AB)\r
14089         MOVEM   0,EOFCND(B)\r
14090         PUSH    TP,(AB)         ; PUSH ON STRING\r
14091         PUSH    TP,1(AB)\r
14092         PUSH    P,[0]           ; PUSH ON CURRENT COUNT OF CHARS DONE\r
14093         MOVE    0,-2(P)         ; GET READ OR WRITE FLAG\r
14094         JUMPN   0,OUTLOP        ; GO WRITE STUFF\r
14095 \r
14096         MOVE    B,-2(TP)        ; GET CHANNEL\r
14097         PUSHJ   P,GRB           ; MAKE SURE WE HAVE BUFF\r
14098         SKIPGE  A,LSTCH(B)      ; CHECK FOR EOF ALREADY READ PREVIOUSLY\r
14099         JRST    SRDOEF          ; GO DOES HIS EOF HACKING\r
14100 INLOP:  INTGO\r
14101         MOVE    B,-2(TP)        ; GET CHANNEL\r
14102         MOVE    C,-1(P)         ; MAX COUNT\r
14103         CAMG    C,(P)           ; COMPARE WITH COUNT DONE\r
14104         JRST    STREOF          ; WE HAVE FINISHED\r
14105         PUSHJ   P,R1CHAR        ; GET A CHAR\r
14106         JUMPL   A,INEOF         ; EOF HIT\r
14107         MOVE    C,1(TB)\r
14108         HRRZ    E,(TB)          ; DO WE HAVE A STRING TO WORRY US?\r
14109         SOJL    E,INLNT         ; GO FINISH STUFFING\r
14110         ILDB    D,C\r
14111         CAME    D,A\r
14112         JRST    .-3\r
14113         JRST    INEOF\r
14114 INLNT:  IDPB    A,(TP)          ; STUFF IN STRING\r
14115         SOS     -1(TP)          ; DECREMENT STRING COUNT\r
14116         AOS     (P)             ; INCREMENT CHAR COUNT\r
14117         JRST    INLOP\r
14118 \r
14119 INEOF:  SKIPE   C,LSTCH(B)      ; IS THIS AN ! AND IS THERE A CHAR THERE\r
14120         JRST    .+3             ; YES\r
14121         MOVEM   A,LSTCH(B)      ; NO SAVE THE CHAR\r
14122         JRST    .+3\r
14123         ADDI    C,400000\r
14124         MOVEM   C,LSTCH(B)\r
14125         HRRZ    C,DIRECT-1(B)   ; GET THE TYPE OF CHAN\r
14126         CAIN    C,5             ; IS IT READB?\r
14127         JRST    .+3\r
14128         SOS     ACCESS(B)       ; FIX UP ACCESS FOR READ CHANNEL\r
14129         JRST    STREOF          ; AND THATS IT\r
14130         HRRZ    C,ACCESS-1(B)   ; FOR A READB ITS WORSE\r
14131         MOVEI   D,5\r
14132         SKIPG   C\r
14133         HRRM    D,ACCESS-1(B)   ; CHANGE A 0 TO A FIVE\r
14134         SOS     C,ACCESS-1(B)\r
14135         CAMN    C,[TFIX,,0]\r
14136         SOS     ACCESS(B)       ; AND SOS THE WORD COUNT MAYBE\r
14137         JRST    STREOF\r
14138 \r
14139 SRDOEF: SETZM   LSTCH(B)        ; IN CASE OF -1, FLUSH IT\r
14140         AOJE    A,INLOP         ; SKIP OVER -1 ON PTY'S\r
14141         SUB     TP,[6,,6]\r
14142         SUB     P,[3,,3]        ; POP JUNK OFF STACKS\r
14143         PUSH    TP,EOFCND-1(B)\r
14144         PUSH    TP,EOFCND(B)    ; WHAT WE NEED TO EVAL\r
14145         PUSH    TP,$TCHAN\r
14146         PUSH    TP,B\r
14147         MCALL   1,FCLOSE        ; CLOSE THE LOOSING CHANNEL\r
14148         MCALL   1,EVAL          ; EVAL HIS EOF JUNK\r
14149         JRST    FINIS\r
14150 \r
14151 OUTLOP: MOVE    B,-2(TP)\r
14152         PUSHJ   P,GWB           ; MAKE SURE WE HAVE BUFF\r
14153 OUTLP1: INTGO\r
14154         MOVE    B,-2(TP)\r
14155         MOVE    C,-1(P)         ; MAX COUNT TO DO\r
14156         CAMG    C,(P)           ; HAVE WE DONE ENOUGH\r
14157         JRST    STREOF\r
14158         ILDB    A,(TP)          ; GET THE CHAR\r
14159         SOS     -1(TP)  ; SUBTRACT FROM STRING LENGTH\r
14160         AOS     (P)             ; INC COUNT OF CHARS DONE\r
14161         PUSHJ   P,W1CHAR        ; GO STUFF CHAR\r
14162         JRST    OUTLP1\r
14163 \r
14164 STREOF: MOVE    A,$TFIX\r
14165         POP     P,B             ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE\r
14166         SUB     P,[2,,2]\r
14167         SUB     TP,[6,,6]\r
14168         JRST    FINIS\r
14169 \r
14170 \r
14171 GWB:    SKIPE   BUFSTR(B)\r
14172         POPJ    P,\r
14173         PUSH    TP,$TCHAN\r
14174         PUSH    TP,B            ; GET US A WRITE BUFFER ON PRINTB CHAN\r
14175         MOVEI   A,BUFLNT\r
14176         PUSHJ   P,IBLOCK\r
14177         MOVSI   A,TWORD+.VECT.\r
14178         MOVEM   A,BUFLNT(B)\r
14179         SETOM   (B)\r
14180         MOVEI   C,1(B)\r
14181         HRLI    C,(B)\r
14182         BLT     C,BUFLNT-1(B)\r
14183         MOVE    C,B\r
14184         HRLI    C,440700\r
14185         MOVE    B,(TP)\r
14186         MOVEI   0,C.BUF\r
14187         IORM    0,-4(B)\r
14188         MOVEM   C,BUFSTR(B)\r
14189         MOVE    C,[TCHSTR,,BUFLNT*5]\r
14190         MOVEM   C,BUFSTR-1(B)\r
14191         SUB     TP,[2,,2]\r
14192         POPJ    P,\r
14193 \r
14194 \r
14195 GRB:    SKIPE   BUFSTR(B)\r
14196         POPJ    P,\r
14197         PUSH    TP,$TCHAN\r
14198         PUSH    TP,B            ; GET US A READ BUFFER\r
14199         MOVEI   A,BUFLNT\r
14200         PUSHJ   P,IBLOCK\r
14201         MOVEI   C,BUFLNT(B)\r
14202         POP     TP,B\r
14203         MOVEI   0,C.BUF\r
14204         IORM    0,-4(B)\r
14205         HRLI    C,440700\r
14206         MOVEM   C,BUFSTR(B)\r
14207         MOVSI   C,TCHSTR\r
14208         MOVEM   C,BUFSTR-1(B)\r
14209         SUB     TP,[1,,1]\r
14210         POPJ    P,\r
14211 \r
14212 MTSTRN: PUSH    TP,$TATOM\r
14213         PUSH    TP,EQUOTE EMPTY-STRING\r
14214         JRST    CALER1\r
14215 \r
14216 \f; INPUT UNBUFFERING ROUTINE.  THIS DOES THE CHARACTER UNBUFFERING\r
14217 ; FOR INPUT.  THE OPEN ROUTINE SETUPS A PUSHJ P, TO\r
14218 ; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE.\r
14219 \r
14220 ; H. BRODIE 7/19/72\r
14221 \r
14222 ; CALLING SEQ:\r
14223 ;       PUSHJ   P,GETCHR\r
14224 ;               B/ AOBJN PNTR TO CHANNEL VECTOR\r
14225 ;               RETURNS NEXT CHARACTER IN AC A.\r
14226 ;       ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND\r
14227 ;       TRANSMITS ONLY ^C ON SUCCESSIVE CALLS\r
14228 \r
14229 \r
14230 GETCHR:\r
14231 ; FIRST GRAB THE BUFFER\r
14232         GETYP   A,BUFSTR-1(B)   ; GET TYPE WORD\r
14233         CAIN    A,TCHSTR        ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER)\r
14234         JRST    GTGBUF          ; IS GOOD BUFFER...SKIP ERROR RETURN\r
14235 BDCHAN: PUSH    TP,$TATOM       ; ERROR RETURN\r
14236         PUSH    TP,EQUOTE BAD-INPUT-BUFFER\r
14237         JRST    CALER1\r
14238 \r
14239 ; BUFFER WAS GOOD\r
14240 GTGBUF: HRRZ    A,BUFSTR-1(B)   ; GET LENGTH OF STRING\r
14241         SOJGE   A,GTGCHR        ; JUMP IF STILL MORE\r
14242 \r
14243 ; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS)\r
14244 ; GENERATE AN .IOT POINTER\r
14245 ;FIRST SAVE C AND D AS I WILL CLOBBER THEM\r
14246 NEWBUF: PUSH    P,C\r
14247         PUSH    P,D\r
14248 IFN ITS,[\r
14249         LDB     C,[600,,STATUS(B)]      ; GET TYPE\r
14250         CAIG    C,2             ; SKIP IF NOT TTY\r
14251 ]\r
14252 IFE ITS,[\r
14253         SKIPE   BUFRIN(B)\r
14254 ]\r
14255         JRST    GETTTY          ; GET A TTY BUFFER\r
14256 \r
14257         PUSHJ   P,PGBUFI        ; RE-FILL BUFFER\r
14258 \r
14259         JUMPGE  A,BUFGOO                ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL\r
14260         MOVEI   C,1             ; MAKE SURE LAST EOF REALLY ENDS IT\r
14261         ANDCAM  C,-1(A)\r
14262         MOVSI   C,014000        ; GET A ^C\r
14263         MOVEM   C,(A)           ;FAKE AN EOF\r
14264 \r
14265 ; RESET THE BYTE POINTER IN THE CHANNEL.\r
14266 ; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D\r
14267 BUFGOO: HRLI    D,440700        ; GENERATE VIRGIN LH\r
14268 \r
14269         MOVEM   D,BUFSTR(B)     ; STASH IN THE BUFFER BYTE PNTR SLOT\r
14270         MOVEI   A,BUFLNT*5-1\r
14271 BUFROK: POP     P,D             ;RESTORE D\r
14272         POP     P,C             ;RESTORE C\r
14273 \r
14274 \r
14275 ; HERE IF THERE ARE CHARS IN BUFFER\r
14276 GTGCHR: HRRM    A,BUFSTR-1(B)\r
14277         ILDB    A,BUFSTR(B)     ; GET A CHAR FROM BUFFER\r
14278 IFE ITS,[\r
14279         CAIN    A,32    ; TENEX EOF?\r
14280         JRST    .+3\r
14281 ]\r
14282         CAIE    A,3             ; EOF?\r
14283         POPJ    P,              ; AND RETURN\r
14284 IFN ITS,[\r
14285         LDB     A,[600,,STATUS(B)]      ; CHECK FOR TTY\r
14286         CAILE   A,2             ; SKIP IF TTY\r
14287 ]\r
14288 IFE ITS,        SKIPN   BUFRIN(B)\r
14289 \r
14290         JRST    .+3\r
14291 RETEO1: HRRI    A,3\r
14292         POPJ    P,\r
14293 \r
14294         HRRZ    A,@BUFSTR(B)    ; SEE IF RSUBR START BIT IS ON\r
14295         TRNN    A,1\r
14296         MOVSI   A,-1\r
14297         JRST    RETEO1\r
14298 \r
14299 IFN ITS,[\r
14300 PGBUFO:\r
14301 PGBUFI:\r
14302 ]\r
14303 IFE ITS,[\r
14304 PGBUFO: SKIPA   D,[SOUT]\r
14305 PGBUFI: MOVE    D,[SIN]\r
14306 ]\r
14307         SKIPGE  A,BUFSTR(B)     ; POINT TO CURRENT BUFFER POSIT\r
14308         SUBI    A,1             ; FOR 440700 AND 010700 START\r
14309         SUBI    A,BUFLNT-1      ; CALCULATE PNTR TO BEG OF BUFFER\r
14310         HRLI    A,-BUFLNT       ; IOT (AOBJN) PNTR IN A\r
14311 IFN ITS,[\r
14312 PGBIOO:\r
14313 PGBIOI: MOVE    D,A             ; COPY FOR LATER\r
14314         MOVSI   C,TUVEC         ; PREPARE TO HANDDLE INTS\r
14315         MOVEM   C,DSTO(PVP)\r
14316         MOVEM   C,ASTO(PVP)\r
14317         MOVSI   C,TCHAN\r
14318         MOVEM   C,BSTO(PVP)\r
14319 \r
14320 ; BUILD .IOT INSTR\r
14321         MOVE    C,CHANNO(B)     ; CHANNEL NUMBER IN C\r
14322         ROT     C,23.           ; MOVE INTO AC FIELD\r
14323         IOR     C,[.IOT 0,A]    ; IOR IN SKELETON .IOT\r
14324 \r
14325 ; DO THE .IOT\r
14326         ENABLE                  ; ALLOW INTS\r
14327         XCT     C               ; EXECUTE THE .IOT INSTR\r
14328         DISABLE\r
14329         SETZM   BSTO(PVP)\r
14330         SETZM   ASTO(PVP)\r
14331         SETZM   DSTO(PVP)\r
14332         POPJ    P,\r
14333 ]\r
14334 \r
14335 IFE ITS,[\r
14336 PGBIOT: PUSH    P,D\r
14337         PUSH    TP,$TCHAN\r
14338         PUSH    TP,B\r
14339         MOVEI   C,(A)           ; POINT TO BUFFER\r
14340         HRLI    C,444400\r
14341         MOVE    D,A             ; XTRA POINTER\r
14342         MOVE    A,CHANNO(B)     ; FILE JFN\r
14343         MOVE    B,C\r
14344         HLRE    C,D             ; - COUNT TO C\r
14345         XCT     (P)             ; DO IT TO IT\r
14346         MOVEI   A,1(B)\r
14347         MOVE    B,(TP)\r
14348         SUB     TP,[2,,2]\r
14349         SUB     P,[1,,1]\r
14350         JUMPGE  C,CPOPJ         ; NO EOF YET\r
14351         HRLI    A,(C)           ; LOOK LIKE AN AOBJN PNTR\r
14352         POPJ    P,\r
14353 \r
14354 PGBIOO: SKIPA   D,[SOUT]\r
14355 PGBIOI: MOVE    D,[SIN]\r
14356         JRST    PGBIOT\r
14357 DOIOTO: PUSH    P,D\r
14358         PUSH    P,C\r
14359         PUSHJ   P,PGBIOO\r
14360 DOIOTE: POP     P,C\r
14361         POP     P,D\r
14362         POPJ    P,\r
14363 DOIOTI: PUSH    P,D\r
14364         PUSH    P,C\r
14365         PUSHJ   P,PGBIOI\r
14366         JRST    DOIOTE\r
14367 ]\r
14368 \f\r
14369 ; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE\r
14370 \r
14371 PUTCHR: PUSH    P,A\r
14372         GETYP   A,BUFSTR-1(B)   ; CHECK TYPE OF ARG\r
14373         CAIE    A,TCHSTR        ; MUST BE STRING\r
14374         JRST    BDCHAN\r
14375 \r
14376         HRRZ    A,BUFSTR-1(B)   ; GET CHAR COUNT\r
14377         JUMPE   A,REBUFF        ; PREV RESET BUFF, UNDO SAME\r
14378 \r
14379 PUTCH1: POP     P,A             ; RESTORE CHAR\r
14380         CAMN    A,[-1]          ; SPECIAL HACK?\r
14381         JRST    PUTCH2          ; YES GO HANDLE\r
14382         IDPB    A,BUFSTR(B)     ; STUFF IT\r
14383 PUTCH3: SOS     A,BUFSTR-1(B)   ; COUNT DOWN STRING\r
14384         TRNE    A,-1            ; SKIP IF FULL\r
14385         POPJ    P,\r
14386 \r
14387 ; HERE TO FLUSH OUT A BUFFER\r
14388 \r
14389         PUSH    P,C\r
14390         PUSH    P,D\r
14391         PUSHJ   P,PGBUFO        ; SETUP AND DO IOT\r
14392         HRLI    D,440700        ; POINT INTO BUFFER\r
14393         MOVEM   D,BUFSTR(B)     ; STORE IT\r
14394         MOVEI   A,BUFLNT*5      ; RESET  COUNT\r
14395         HRRM    A,BUFSTR-1(B)\r
14396         POP     P,D\r
14397         POP     P,C\r
14398         POPJ    P,\r
14399 \r
14400 ;HERE TO DA ^C AND TURN ON MAGIC BIT\r
14401 \r
14402 PUTCH2: MOVEI   A,3\r
14403         IDPB    A,BUFSTR(B)     ; ZAP OUT THE ^C\r
14404         MOVEI   A,1             ; GET BIT\r
14405         IORM    A,@BUFSTR(B)    ; ON GOES THE BIT\r
14406         JRST    PUTCH3\r
14407 \r
14408 ; RESET A FUNNY BUF\r
14409 \r
14410 REBUFF: MOVEI   A,BUFLNT*5              ; 1ST COUNT\r
14411         HRRM    A,BUFSTR-1(B)\r
14412         HRRZ    A,BUFSTR(B)             ; NOW POINTER\r
14413         SUBI    A,BUFLNT\r
14414         HRLI    A,440700\r
14415         MOVEM   A,BUFSTR(B)             ; STORE BACK\r
14416         JRST    PUTCH1\r
14417 \r
14418 \r
14419 ; HERE TO FLUSH FINAL BUFFER\r
14420 \r
14421 BFCLOS: HLLZS   ACCESS-1(B)     ; CLEAR OUT KLUDGE PRINTB PART ACCESS COUNT\r
14422         MOVE    C,B             ; THIS BUFFER FLUSHER THE WORK OF NDR\r
14423         MOVEI   B,RDEVIC-1(B)   ; FIND OUT IF THIS IS NET\r
14424         PUSHJ   P,CHRWRD\r
14425         JFCL\r
14426         TRZ     B,77777         ; LEAVE ONLY HIGH 3 CHARS\r
14427         MOVEI   A,0             ; FLAG 0=NET 1=DSK\r
14428         CAME    B,[ASCIZ /NET/] ; IS THIS NET?\r
14429         AOS     A\r
14430         PUSH    P,A             ; SAVE THE RESULT OF OUR TEST\r
14431         MOVE    B,C             ; RESTORE CHANNEL IN B\r
14432         JUMPN   A,BFCLNN        ; DONT HAVE TO CHECK NET STATE\r
14433         PUSH    TP,$TCHAN\r
14434         PUSH    TP,B            ; SAVE CHANNEL\r
14435         PUSHJ   P,INSTAT        ; GET CURRENT NETWORK STATE\r
14436         MOVE    A,(B)           ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE\r
14437         POP     TP,B            ; RESTORE B\r
14438         POP     TP,\r
14439         CAIE    A,5             ; IS NET IN OPEN STATE?\r
14440         CAIN    A,6             ; OR ELSE IS IT IN RFNM WAIT STATE\r
14441         JRST    BFCLNN          ; IF SO TO THE IOT\r
14442         POP     P,              ; ELSE FLUSH CRUFT AND DONT IOT\r
14443         POPJ    P,              ; RETURN DOING NO IOT\r
14444 BFCLNN: MOVEI   C,BUFLNT*5      ; NEW BUFFER FLUSHER BY NDR\r
14445         HRRZ    D,BUFSTR-1(B)   ; SO THAT NET ALSO WORKS RIGHT\r
14446         SUBI    C,(D)           ; GET NUMBER OF CHARS\r
14447         IDIVI   C,5             ; NUMBER OF FULL WORDS AND REST\r
14448         PUSH    P,D             ; SAVE NUMBER OF ODD CHARS\r
14449         SKIPGE  A,BUFSTR(B)     ; GET CURRENT BUF POSITION\r
14450         SUBI    A,1             ; FIX FOR 440700 BYTE POINTER\r
14451         PUSH    P,(A)           ; SAVE THE ODD WORD OF BUFFER\r
14452         MOVEI   D,BUFLNT\r
14453         SUBI    D,(C)\r
14454         SKIPE   -1(P)\r
14455         SUBI    A,1\r
14456         ADDI    D,1(A)          ; FIX UP FOR POSSIBLE ODD CHARS\r
14457         PUSH    TP,$TUVEC\r
14458         PUSH    TP,D            ; PUSH THE DOPE VECTOR ONTO THE STACK\r
14459         JUMPE   C,BFCLSR        ; IN CASE THERE ARE NO FULL WORDS TO DO\r
14460         HRL     A,C\r
14461         MOVE    E,[A,,BUFLNT]\r
14462         SUBI    E,(C)   ; FIX UP FOR BACKWARDS BLT\r
14463         POP     A,@E            ; AMAZING GRACE\r
14464         TLNE    A,-1\r
14465         JRST    .-2\r
14466         HRRO    A,D             ; SET UP AOBJN POINTER\r
14467         SUBI    A,(C)\r
14468         TLC     A,-1(C)\r
14469         PUSHJ   P,PGBIOO        ; DO THE IOT OF ALL THE FULL WORDS\r
14470 BFCLSR: HRRO    A,(TP)          ; GET IOT PTR FOR REST OF JUNK\r
14471         SUBI    A,1             ; POINT TO WORD BEFORE DOPE WORDS\r
14472         POP     P,0             ; GET BACK ODD WORD\r
14473         POP     P,C             ; GET BACK ODD CHAR COUNT\r
14474         POP     P,D             ; FLAG FOR NET OR DSK\r
14475         JUMPE   C,BFCLSD        ; IF NO ODD CHARS FINISH UP\r
14476         JUMPN   D,BFCDSK        ; GO FINISH OFF DSK\r
14477         MOVEI   D,7\r
14478         IMULI   D,(C)           ; FIND NO OF BITS TO SHIFT\r
14479         LSH     0,-43(D)        ; SHIFT BITS TO RIGHT PLACE\r
14480         MOVEM   0,(A)   ; STORE IN STRING\r
14481         SUBI    C,5             ; HOW MANY CHAR POSITIONS TO SKIP\r
14482         MOVNI   C,(C)           ; MAKE C POSITIVE\r
14483         LSH     C,17\r
14484         TLC     A,(C)           ; MUNG THE AOBJN POINTER TO KLUDGE\r
14485         PUSHJ   P,PGBIOO        ; DO IOT OF ODD CHARS\r
14486 BFCLSD: HRRZ    A,(TP)  ; GET PTR TO DOPE WORD\r
14487         SUBI    A,BUFLNT\r
14488         HRLI    A,440700        ; AOBJN POINTER TO FIRST OF BUFFER\r
14489         MOVEM   A,BUFSTR(B)\r
14490         MOVEI   A,BUFLNT*5\r
14491         HRRM    A,BUFSTR-1(B)\r
14492         SUB     TP,[2,,2]\r
14493         POPJ    P,\r
14494 \r
14495 BFCDSK: MOVE    C,A             ; FOR FUNNY AOBJN PTR\r
14496         HLL     C,BUFSTR(B)     ; POINT INTO WORD AFTER LAST CHAR\r
14497         TRZ     0,1\r
14498         MOVEM   0,(A)\r
14499 IFN ITS,        MOVEI   0,3             ; CONTROL C\r
14500 IFE ITS,        MOVEI   0,32            ; CNTL Z\r
14501         IDPB    0,C\r
14502         PUSHJ   P,PGBIOO\r
14503         JRST    BFCLSD\r
14504 \r
14505 BFCLS1: HRRZ    C,DIRECT-1(B)\r
14506         MOVSI   0,(JFCL)\r
14507         CAIE    C,6\r
14508         MOVE    0,[AOS ACCESS(B)]\r
14509         PUSH    P,0\r
14510         HRRZ    C,BUFSTR-1(B)\r
14511         IDIVI   C,5\r
14512         JUMPE   D,BCLS11\r
14513         MOVEI   A,40            ; PAD WITH SPACES\r
14514         PUSHJ   P,PUTCHR\r
14515         XCT     (P)             ; AOS ACCESS IF NECESSARY\r
14516         SOJG    D,.-3           ; TO END OF WORD\r
14517 BCLS11: POP     P,0\r
14518         HLLZS   ACCESS-1(B)\r
14519         HRRZ    C,BUFSTR-1(B)\r
14520         CAIE    C,BUFLNT*5\r
14521         PUSHJ   P,BFCLOS\r
14522         POPJ    P,\r
14523 \r
14524 \f\r
14525 ; HERE TO GET A TTY BUFFER\r
14526 \r
14527 GETTTY: SKIPN   C,EXBUFR(B)     ; SKIP IF BUFFERS BACKED UP\r
14528         JRST    TTYWAI\r
14529         HRRZ    D,(C)           ; CDR THE LIST\r
14530         GETYP   A,(C)           ; CHECK TYPE\r
14531         CAIE    A,TDEFER        ; MUST BE DEFERRED\r
14532         JRST    BDCHAN\r
14533         MOVE    C,1(C)          ; GET DEFERRED GOODIE\r
14534         GETYP   A,(C)           ; BETTER BE CHSTR\r
14535         CAIE    A,TCHSTR\r
14536         JRST    BDCHAN\r
14537         MOVE    A,(C)           ; GET FULL TYPE WORD\r
14538         MOVE    C,1(C)\r
14539         MOVEM   D,EXBUFR(B)     ; STORE CDR'D LIST\r
14540         MOVEM   A,BUFSTR-1(B)   ; MAKE CURRENT BUFFER\r
14541         MOVEM   C,BUFSTR(B)\r
14542         SOJA    A,BUFROK\r
14543 \r
14544 TTYWAI: PUSHJ   P,TTYBLK        ; BLOCKED FOR TTY I/O\r
14545         JRST    GETTTY          ; SHOULD ONLY RETURN HAPPILY\r
14546 \r
14547 \f;INTERNAL DEVICE READ ROUTINE.\r
14548 \r
14549 ;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,\r
14550 ;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER,\r
14551 ;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE"\r
14552 \r
14553 ;H. BRODIE 8/31/72\r
14554 \r
14555 GTINTC: PUSH    TP,$TCHAN       ;SAVE THE CHANNEL...WE'LL CLOBBER B\r
14556         PUSH    TP,B\r
14557         PUSH    P,C     ;AND SAVE THE OTHER ACS\r
14558         PUSH    P,D\r
14559         PUSH    P,E\r
14560         PUSH    P,0\r
14561         PUSH    TP,INTFCN-1(B)\r
14562         PUSH    TP,INTFCN(B)\r
14563         MCALL   1,APPLY\r
14564         GETYP   A,A\r
14565         CAIE    A,TCHRS\r
14566         JRST    BADRET\r
14567         MOVE    A,B\r
14568 INTRET: POP     P,0             ;RESTORE THE ACS\r
14569         POP     P,E\r
14570         POP     P,D\r
14571         POP     P,C\r
14572         POP     TP,B            ;RESTORE THE CHANNEL\r
14573         SUB     TP,[1,,1]       ;FLUSH $TCHAN...WE DON'T NEED IT\r
14574         POPJ    P,\r
14575 \r
14576 \r
14577 BADRET: PUSH    TP,$TATOM\r
14578         PUSH    TP,EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT\r
14579         JRST    CALER1\r
14580 \r
14581 ;INTERNAL DEVICE PRINT ROUTINE.\r
14582 \r
14583 ;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR)\r
14584 ;TO THE CURRENT CHARACTER BEING "PRINTED".\r
14585 \r
14586 PTINTC: PUSH    TP,$TCHAN       ;SAVE THE CHANNEL...WE'LL CLOBBER B\r
14587         PUSH    TP,B\r
14588         PUSH    P,C     ;AND SAVE THE OTHER ACS\r
14589         PUSH    P,D\r
14590         PUSH    P,E\r
14591         PUSH    P,0\r
14592         PUSH    TP,INTFCN-1(B)  ;PUSH TYPE OF GIVEN OBJ\r
14593         PUSH    TP,INTFCN(B)    ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)\r
14594         PUSH    TP,$TCHRS       ;PUSH THE TYPE "CHARACTER"\r
14595         PUSH    TP,A            ;PUSH THE CHAR\r
14596         MCALL   2,APPLY         ;APPLY THE FUNCTION TO THE CHAR\r
14597         JRST    INTRET\r
14598 \r
14599 \r
14600 \f\r
14601 ; ROUTINE TO FLUSH OUT A PRINT BUFFER\r
14602 \r
14603 MFUNCTION BUFOUT,SUBR\r
14604 \r
14605         ENTRY   1\r
14606 \r
14607         GETYP   0,(AB)\r
14608         CAIE    0,TCHAN\r
14609         JRST    WTYP1\r
14610 \r
14611         MOVE    B,1(AB)\r
14612         MOVEI   B,DIRECT-1(B)\r
14613         PUSHJ   P,CHRWRD        ; GET DIR NAME\r
14614         JFCL\r
14615         CAMN    B,[ASCII /PRINT/]\r
14616         JRST    .+3\r
14617         CAME    B,[<ASCII /PRINT/>+1]\r
14618         JRST    WRONGD\r
14619         TRNE    B,1             ; SKIP IF PRINT\r
14620         PUSH    P,[JFCL]\r
14621         TRNN    B,1             ; SKIP IF PRINTB\r
14622         PUSH    P,[AOS ACCESS(B)]\r
14623         MOVE    B,1(AB)\r
14624         GETYP   0,BUFSTR-1(B)\r
14625         CAIN    0,TCHSTR\r
14626         SKIPN   C,BUFSTR(B)             ; BYTE POINTER?\r
14627         JRST    BFIN1\r
14628         HRRZ    C,BUFSTR-1(B)   ; CHARS LEFT\r
14629         IDIVI   C,5             ; MULTIPLE OF 5?\r
14630         JUMPE   D,BFIN2         ; YUP NO EXTRAS\r
14631 \r
14632         MOVEI   A,40            ; PAD WITH SPACES\r
14633         PUSHJ   P,PUTCHR        ; OUT IT GOES\r
14634         XCT     (P)             ; MAYBE BUMP ACCESS\r
14635         SOJG    D,.-3           ; FILL\r
14636 \r
14637 BFIN2:  PUSHJ   P,BFCLOS        ; WRITE OUT BUFFER\r
14638 BFIN1:  MOVSI   A,TCHAN\r
14639         JRST FINIS\r
14640 \r
14641 \r
14642 \r
14643 ; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL\r
14644 \r
14645 MFUNCTION FILLNT,SUBR,[FILE-LENGTH]\r
14646         ENTRY   1\r
14647 \r
14648         GETYP   0,(AB)\r
14649         CAIE    0,TCHAN\r
14650         JRST    WTYP1\r
14651         MOVE    B,1(AB)\r
14652         MOVEI   B,DIRECT-1(B)   ; GET CHANNEL TYPE\r
14653         PUSHJ   P,CHRWRD\r
14654         JFCL\r
14655         CAME    B,[ASCIZ /READ/]\r
14656         JRST    .+3\r
14657         PUSH    P,[5]           ; MULTIPLICATIVE FACTOR FOR READ\r
14658         JRST    .+4\r
14659         CAME    B,[ASCII /READB/]\r
14660         JRST    WRONGD\r
14661         PUSH    P,[1]           ; MULTIPLICATIVE FACTOR FOR READ\r
14662         MOVE    C,1(AB)\r
14663 IFN ITS,[\r
14664         .CALL   FILL1\r
14665         JRST    FILLOS          ; GIVE HIM A NICE FALSE\r
14666 ]\r
14667 IFE ITS,[\r
14668         MOVE    A,CHANNO(C)\r
14669         SIZEF\r
14670         JRST    FILLOS\r
14671 ]\r
14672         POP     P,C\r
14673         IMUL    B,C\r
14674         MOVE    A,$TFIX\r
14675         JRST    FINIS\r
14676 \r
14677 IFN ITS,[\r
14678 FILL1:  SETZ                    ; BLOCK FOR .CALL TO FILLEN\r
14679         SIXBIT /FILLEN/\r
14680         CHANNO  (C)\r
14681         SETZM   B\r
14682 \r
14683 FILLOS: MOVE    A,CHANNO(C)\r
14684         PUSHJ   P,GFALS\r
14685         JRST    FINIS\r
14686 ]\r
14687 IFE ITS,[\r
14688 FILLOS: PUSHJ   P,TGFALS\r
14689         JRST    FINIS\r
14690 ]\r
14691 \r
14692 \r
14693 \f;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O\r
14694 \r
14695 NOTNET:\r
14696 BADCHN: PUSH    TP,$TATOM\r
14697         PUSH    TP,EQUOTE BAD-CHANNEL\r
14698         JRST    CALER1\r
14699 \r
14700 WRONGD: PUSH    TP,$TATOM\r
14701         PUSH    TP,EQUOTE WRONG-DIRECTION-CHANNEL\r
14702         JRST    CALER1\r
14703 \r
14704 CHNCLS: PUSH    TP,$TATOM\r
14705         PUSH    TP,EQUOTE CHANNEL-CLOSED\r
14706         JRST    CALER1\r
14707 \r
14708 BAD6:   PUSH    TP,$TATOM\r
14709         PUSH    TP,EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME\r
14710         JRST    CALER1\r
14711 \r
14712 DISLOS: MOVE    C,$TCHSTR\r
14713         MOVE    D,CHQUOTE [DISPLAY NOT AVAILABLE]\r
14714         PUSHJ   P,INCONS\r
14715         MOVSI   A,TFALSE\r
14716         JRST    OPNRET\r
14717 \r
14718 NOCHAN: PUSH    TP,$TATOM\r
14719         PUSH    TP,EQUOTE ITS-CHANNELS-EXHAUSTED\r
14720         JRST    CALER1\r
14721 \r
14722 MODE1:  232020,,202020\r
14723 MODE2:  232023,,332320\r
14724 \r
14725 END\r
14726 \r
14727 \f\r
14728 TITLE GCHACK\r
14729 \r
14730 RELOCATABLE\r
14731 \r
14732 .INSRT MUDDLE >\r
14733 \r
14734 .GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT\r
14735 .GLOBAL TD.LNT,TD.GET,TD.PUT\r
14736 \r
14737 ; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING\r
14738 ; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN\r
14739 \r
14740 ; CALL --\r
14741 ;       A/  INSTRUCTION TO BE EXECUTED\r
14742 ;       PUSHJ P,GCHACK\r
14743 \r
14744 GCHACK: HRRZ    E,TYPVEC+1(TVP) ; SET UP TYPE POINTER\r
14745         HRLI    E,C             ; WILL HAVE TYPE CODE IN C\r
14746         MOVE    B,PARBOT        ; START AT PARBOT\r
14747         SETOM   1(TP)           ; FENCE POST PDL\r
14748         PUSH    P,A\r
14749         MOVEI   A,(TB)\r
14750         PUSHJ   P,FRMUNG                ; MUNG CURRENT FRAME\r
14751         POP     P,A\r
14752 \r
14753 ; FIRST HACK PAIR SPACE\r
14754 \r
14755 PHACK:  CAML    B,PARTOP                ; SKIP IF MORE PAIRS\r
14756         JRST    VHACK           ; DONE, NOW HACK VECTORS\r
14757         GETYP   C,(B)           ; TYPE OF CURRENT PAIR\r
14758         MOVE    D,1(B)          ; AND ITS DATUM\r
14759         XCT     A               ; APPLY INS\r
14760         ADDI    B,2\r
14761         JRST    PHACK\r
14762 \r
14763 ; NOW DO THE SAME THING TO VECTOR SPACE\r
14764 \r
14765 VHACK:  MOVE    B,VECTOP        ; START AT TOP, MOVE DOWN\r
14766         SUBI    B,1             ; POINT TO TOPMOST VECTOR\r
14767 VHACK2: CAMG    B,VECBOT        ; SKIP IF MORE TO DO\r
14768         JRST    REHASQ          ; SEE IF MUST REHASH\r
14769 \r
14770         HLRE    D,-1(B)         ; GET TYPE FROM D.W.\r
14771         HLRZ    C,(B)           ; AND TOTAL LENGTH\r
14772         SUBI    B,(C)-1         ; POINT TO START OF VECTOR\r
14773         PUSH    P,B\r
14774         SUBI    C,2             ; CHECK WINNAGE\r
14775         JUMPL   C,BADV          ; FATAL LOSSAGE\r
14776         PUSH    P,C             ; SAVE COUNT\r
14777         JUMPE   C,VHACK1        ; EMPTY VECTOR, FINISHED\r
14778 \r
14779 ; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL\r
14780 \r
14781         JUMPGE  D,UHACK         ; UNIFORM\r
14782         TRNE    D,377777        ; SKIP IF GENERAL\r
14783         JRST    SHACK           ; SPECIAL\r
14784 \r
14785 ; FALL THROUGH TO GENERAL\r
14786 \r
14787 GHACK1: GETYP   C,(B)           ; LOOK A T 1ST ELEMENT\r
14788         CAIE    C,TCBLK\r
14789         CAIN    C,TENTRY        ; FRAME ON STACK\r
14790         SOJA    B,EHACK\r
14791         CAIE    C,TUBIND\r
14792         CAIN    C,TBIND         ; BINDING BLOCK\r
14793         JRST    BHACK\r
14794         CAIN    C,TGATOM        ; ATOM WITH GDECL?\r
14795         JRST    GDHACK\r
14796         MOVE    D,1(B)          ; GET DATUM\r
14797         XCT     A               ; USER INS\r
14798         ADDI    B,2             ; NEXT ELEMENT\r
14799         SOS     (P)\r
14800         SOSLE   (P)             ; COUNT ELEMENTS\r
14801         SKIPGE  (B)             ; OR FENCE POST HIT\r
14802         JRST    VHACK1\r
14803         JRST    GHACK1\r
14804 \r
14805 ; HERE TO GO OVER UVECTORS\r
14806 \r
14807 UHACK:  CAMN    A,[PUSHJ P,SBSTIS]\r
14808         JRST    VHACK1          ; IF THIS SUBSTITUTE, DONT DO UVEC\r
14809         MOVEI   C,(D)           ; COPY UNIFORM TYPE\r
14810         SUBI    B,1             ; BACK OFF\r
14811 \r
14812 UHACK1: MOVE    D,1(B)          ; DATUM\r
14813         XCT     A\r
14814         SOSLE   (P)             ; COUNT DOEN\r
14815         AOJA    B,UHACK1\r
14816         JRST    VHACK1\r
14817 \r
14818 ; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES\r
14819 \r
14820 SHACK:  ANDI    D,377777        ; KILL EXTRA CRUFT\r
14821         CAIN    D,SATOM\r
14822         JRST    ATHACK\r
14823         CAIE    D,STPSTK        ; STACK OR\r
14824         CAIN    D,SPVP          ; PROCESS\r
14825         JRST    GHACK1          ; TREAT LIKE GENERAL\r
14826         CAIN    D,SASOC         ; ASSOCATION\r
14827         JRST    ASHACK\r
14828         CAIG    D,NUMSAT        ; TEMPLATE MAYBE?\r
14829         JRST    BADV            ; NO CHANCE\r
14830         ADDI    C,(B)           ; POINT TO DOPE WORDS\r
14831         SUBI    D,NUMSAT+1\r
14832         HRLI    D,(D)\r
14833         ADD     D,TD.LNT+1(TVP)\r
14834         JUMPGE  D,BADV          ; JUMP IF INVALID TEMPLATE HACKER\r
14835 \r
14836         CAMN    A,[PUSHJ P,SBSTIS]\r
14837         JRST    VHACK1\r
14838 \r
14839 TD.UPD: PUSH    P,A             ; INS TO EXECUTE\r
14840         XCT     (D)\r
14841         HLRZ    E,B             ; POSSIBLE BASIC LENGTH\r
14842         PUSH    P,[0]\r
14843         PUSH    P,E\r
14844         MOVEI   B,(B)           ; ISOLATE LENGTH\r
14845         PUSH    P,C             ; SAVE POINTER TO OBJECT\r
14846 \r
14847         PUSH    P,[0]           ; HOME FOR VALUES\r
14848         PUSH    P,[0]           ; SLOT FOR TEMP\r
14849         PUSH    P,B             ; SAVE\r
14850         SUB     D,TD.LNT+1(TVP)\r
14851         PUSH    P,D             ; SAVE FOR FINDING OTHER TABLES\r
14852         JUMPE   E,TD.UP2        ; NO REPEATING SEQ\r
14853         ADD     D,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
14854         HLRE    D,(D)           ; D ==> - LNTH OF TEMPLATE\r
14855         ADDI    D,(E)           ; D ==> -LENGTH OF REP SEQ\r
14856         MOVNS   D\r
14857         HRLM    D,-5(P)         ; SAVE IT AND BASIC\r
14858 \r
14859 TD.UP2: SKIPG   D,-1(P)         ; ANY LEFT?\r
14860         JRST    TD.UP1\r
14861 \r
14862         MOVE    E,TD.GET+1(TVP)\r
14863         ADD     E,(P)\r
14864         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
14865         MOVEM   D,-6(P)         ; SAVE ELMENT #\r
14866         SKIPN   B,-5(P)         ; SKIP IF "RESTS" EXIST\r
14867         SOJA    D,TD.UP3\r
14868 \r
14869         MOVEI   0,(B)           ; BASIC LNT TO 0\r
14870         SUBI    0,(D)           ; SEE IF PAST BASIC\r
14871         JUMPGE  0,.-3           ; JUMP IF O.K.\r
14872         MOVSS   B               ; REP LNT TO RH, BASIC TO LH\r
14873         IDIVI   0,(B)           ; A==> -WHICH REPEATER\r
14874         MOVNS   A\r
14875         ADD     A,-5(P)         ; PLUS BASIC\r
14876         ADDI    A,1             ; AND FUDGE\r
14877         MOVEM   A,-6(P)         ; SAVE FOR PUTTER\r
14878         ADDI    E,-1(A)         ; POINT\r
14879         SOJA    D,.+2\r
14880 \r
14881 TD.UP3: ADDI    E,(D)           ; POINT TO SLOT\r
14882         XCT     (E)             ; GET THIS ELEMENT INTO A AND B\r
14883         MOVEM   A,-3(P)         ; SAVE TYPE FOR LATER PUT\r
14884         MOVEM   B,-2(P)\r
14885         GETYP   C,A             ; TYPE TO C\r
14886         MOVE    D,B             ; DATUME\r
14887         MOVEI   B,-3(P)         ; POINTER TO HOME\r
14888         MOVE    A,-7(P)         ; GET INS\r
14889         XCT     A               ; AND DO IT\r
14890         MOVE    C,-4(P)         ; GET POINTER FOR UPDATE OF ELEMENT\r
14891         MOVE    E,TD.PUT+1(TVP)\r
14892         SOS     D,-1(P)         ; RESTORE COUNT\r
14893         ADD     E,(P)\r
14894         MOVE    E,(E)           ; POINTER TO VECTOR IN E\r
14895         MOVE    B,-6(P)         ; SAVED OFFSET\r
14896         ADDI    E,(B)-1         ; POINT TO SLOT\r
14897         MOVE    A,-3(P)         ; RESTORE TYPE WORD\r
14898         MOVE    B,-2(P)\r
14899         XCT     (E)             ; SMASH IT BACK\r
14900         FATAL TEMPLATE LOSSAGE\r
14901         MOVE    C,-4(P)\r
14902         JRST    TD.UP2\r
14903 \r
14904 TD.UP1: MOVE    A,-7(P)         ; RESTORE INS\r
14905         SUB     P,[10,,10]\r
14906         MOVSI   D,400000        ; RESTORE MARK/UNMARK BIT\r
14907         JRST    VHACK1\r
14908 \r
14909 ; FATAL LOSSAGE ARRIVES HERE\r
14910 \r
14911 BADV:   FATAL GC SPACE IN A BAD STATE\r
14912 \r
14913 ; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)\r
14914 \r
14915 EHACK:  MOVSI   D,-FRAMLN       ; SET UP AOBJN PNTR\r
14916 \r
14917 EHACK1: HRRZ    C,ETB(D)        ; GET 1ST TYPE\r
14918         PUSH    P,D             ; SAVE AOBJN\r
14919         MOVE    D,1(B)          ; GET ITEM\r
14920         CAME    A,[PUSHJ P,SBSTIS]      ; DONT IF SUBSTITUTE DIFFERENT\r
14921         XCT     A               ; USER GOODIE\r
14922         POP     P,D             ; RESTORE AOBJN\r
14923         ADDI    B,1             ; MOVE ON\r
14924         SOSLE   (P)             ; ALSO COUNT IN TOTAL VECTOR\r
14925         AOBJN   D,EHACK1\r
14926         AOJA    B,GHACK1                ; AND GO ON\r
14927 \r
14928 ; TABLE OF ENTRY BLOCK TYPES\r
14929 \r
14930 ETB:    TSUBR\r
14931         TTB\r
14932         TAB\r
14933         TSP\r
14934         TPDL\r
14935         TTP\r
14936         TWORD\r
14937 \r
14938 ; HERE TO GROVEL OVER BINDING BLOCKS\r
14939 \r
14940 BHACK:  MOVEI   C,TATOM         ; ALSO TREEAT AS ATOM\r
14941         MOVE    D,1(B)\r
14942         CAME    A,[PUSHJ P,SBSTIS]      ; DONT IF SUBSTITUTE DIFFERENT\r
14943         XCT     A\r
14944         PUSHJ   P,NXTGDY        ; NEXT GOODIE\r
14945         PUSHJ   P,NXTGDY        ; AND NEXT\r
14946         MOVEI   C,TSP           ; TYPE THE BACK LOCATIVE\r
14947         PUSHJ   P,NXTGD1        ; AND NEXT\r
14948         PUSH    P,B\r
14949         HLRZ    D,-2(B)         ; DECL POINTER\r
14950         MOVEI   B,0             ; MAKE SURE NO CLOBBER\r
14951         MOVEI   C,TDECL\r
14952         XCT     A               ; DO THE THING BEING DONE\r
14953         POP     P,B\r
14954         HRLM    D,-2(B)         ; FIX UP IN CASE CHANGED\r
14955         JRST    GHACK1\r
14956 \r
14957 ; HERE TO HACK ATOMS WITH GDECLS\r
14958 \r
14959 GDHACK: CAMN    A,[PUSHJ P,SBSTIS]\r
14960         JRST    VHACK1\r
14961 \r
14962         MOVEI   C,TATOM         ; TREAT LIKE ATOM\r
14963         MOVE    D,1(B)\r
14964         XCT     A\r
14965         HRRZ    D,(B)           ; GET DECL\r
14966         JUMPE   D,VHACK1\r
14967         CAIN    D,-1            ; WATCH OUT FOR MAINFEST\r
14968         JRST    VHACK1\r
14969         PUSH    P,B             ; SAVE POINTER\r
14970         MOVEI   B,0\r
14971         MOVEI   C,TLIST\r
14972         XCT     A\r
14973         POP     P,B\r
14974         HRRM    D,(B)           ; RESET\r
14975         JRST    VHACK1\r
14976 \r
14977 ; HERE TO HACK ATOMS\r
14978 \r
14979 ATHACK: ADDI    B,1             ; POINT PRIOR TO OBL SLOT\r
14980         MOVEI   C,TOBLS         ; GET TYPE\r
14981         MOVE    D,1(B)          ; AND DATUM\r
14982         CAME    A,[PUSHJ P,SBSTIS]      ; DONT IF SUBSTITUTE DIFFERENT\r
14983         XCT     A\r
14984         JRST    VHACK1\r
14985 \r
14986 ; HERE TO HACK ASSOCIATION BLOCKS\r
14987 \r
14988 ASHACK: MOVEI   D,3             ; COUNT GOODIES TO MARK\r
14989 \r
14990 ASHAK1: PUSH    P,D\r
14991         MOVE    D,1(B)\r
14992         GETYP   C,(B)\r
14993         PUSH    P,D             ; SAVE POINTER\r
14994         XCT     A\r
14995         POP     P,D             ; GET OLD BACK\r
14996         CAME    D,1(B)          ; CHANGED?\r
14997         TLO     E,400000        ; SET NON-VIRGIN FLAG\r
14998         POP     P,D\r
14999         PUSHJ   P,BMP           ; TO NEXT\r
15000         SOJG    D,ASHAK1\r
15001 \r
15002 ; HERE  TO GOT TO NEXT VECTOR\r
15003 \r
15004 VHACK1: MOVE    B,-1(P)         ; GET POINTER\r
15005         SUB     P,[2,,2]        ; FLUSH CRUFT\r
15006         SOJA    B,VHACK2        ; FIXUP POINTER AND GO ON\r
15007 \r
15008 ; ROUTINE TO GET A GOODIE\r
15009 \r
15010 NXTGDY: GETYP   C,(B)\r
15011 NXTGD1: MOVE    D,1(B)\r
15012         XCT     A               ; DO IT TO IT\r
15013 BMP:    SOS     -1(P)\r
15014         SOSG    -1(P)\r
15015         JRST    BMP1\r
15016         ADDI    B,2\r
15017         POPJ    P,\r
15018 BMP1:   SUB     P,[1,,1]\r
15019         JRST    VHACK1\r
15020 \r
15021 REHASQ: JUMPL   E,REHASH        ; HASH TABLE RAPED, FIX IT\r
15022         POPJ    P,\r
15023 \r
15024 \r
15025 MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]\r
15026 \r
15027 ;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO\r
15028 ;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT\r
15029 ;YOU ARE DOING.\r
15030 ;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE\r
15031 ;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.\r
15032 ;BOTH ITEMS MUST BE OF THE SAME TYPE OR\r
15033 ;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS\r
15034 ;  OF STORAGE, AND SUBSTITUTION CANT BE DONE IN\r
15035 ;  UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN\r
15036 ;  A FEW OTHER YUCKY PLACES.\r
15037 ;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT\r
15038 \r
15039         ENTRY 2\r
15040 \r
15041 \r
15042 SBSTI1: GETYP   A,2(AB)\r
15043         CAIE    A,TATOM\r
15044         JRST    SBSTI2\r
15045         MOVE    B,3(AB)         ; IMPURIFY HASH BUCKET MAYBE?\r
15046         PUSHJ   P,IMPURI\r
15047 \r
15048 SBSTI2: GETYP   A,2(AB)         ; GET TYPE OF SECOND ARG\r
15049         MOVE    D,A\r
15050         PUSHJ   P,NWORDT        ; AND STORAGE ALLOCATION\r
15051         MOVE    E,A\r
15052         GETYP   A,(AB)          ; GET TYPE OF FIRST ARG \r
15053         MOVE    B,A\r
15054         PUSHJ   P,NWORDT\r
15055         CAMN    B,D             ; IF TYPES SAME, DONT CHECK FOR ALLOCATION\r
15056         JRST    SBSTI3\r
15057         CAIN    E,1\r
15058         CAIE    A,1\r
15059         JRST    SBSTIL          ; LOOSE, NOT BOTH ONE WORD GOODIES\r
15060 \r
15061 SBSTI3: MOVEI   C,0\r
15062         CAIN    D,0             ; IF GOODIE IS OF TYPE ZERO\r
15063         MOVEI   C,1             ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE\r
15064         PUSH    TP,C\r
15065         SUBI    E,1\r
15066         PUSH    TP,E            ; 1=DEFERRED TYPE ITEM, 0=ELSE\r
15067         PUSH    TP,C\r
15068         PUSH    TP,D            ; TYPE OF GOODIE\r
15069         PUSH    TP,C\r
15070         PUSH    TP,[0]\r
15071         CAIN    D,TLIST\r
15072         AOS     (TP)            ; 1=TYPE LIST, 0=ELSE\r
15073         PUSH    TP,C\r
15074         PUSH    TP,2(AB)                ; TYPE-WORD\r
15075         PUSH    TP,C\r
15076         PUSH    TP,3(AB)        ; VALUE-WORD\r
15077         PUSH    TP,(AB)\r
15078         PUSH    TP,1(AB)        ; TYPE-VALUE OF THINGS TO CHANGE INTO\r
15079         MOVE    A,[PUSHJ P,SBSTIR]\r
15080         CAME    B,D             ; IF NOT SAME TYPE, USE DIFF MUNGER\r
15081         MOVE    A,[PUSHJ P,SBSTIS]\r
15082         PUSHJ   P,GCHACK        ; DO-IT\r
15083         MOVE    A,-4(TP)\r
15084         MOVE    B,-2(TP)\r
15085         JRST    FINIS           ; GIVE THE LOOSER A HANDLE ON HIS GOODIE\r
15086 \r
15087 SBSTIR: CAME    D,-2(TP)\r
15088         JRST    LSUB            ; THIS IS IT\r
15089         CAME    C,-10(TP)\r
15090         JRST    LSUB            ; IF ITEM CANT BE SAME CHECK FOR LISTAGE\r
15091         JUMPE   B,LSUB+1        ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT\r
15092         MOVE    0,(TP)\r
15093         MOVEM   0,1(B)          ; SMASH IT\r
15094         MOVE    0,-1(TP)        ; GET TYPE WORD\r
15095         SKIPE   -12(TP)         ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST\r
15096         MOVEM   0,(B)           ; ALSO SMASH THE TYPE WORD SLOT\r
15097 \r
15098 LSUB:   SKIPN   -6(TP)          ; IF WE ARE LOOKING FOR LISTS, LOOK ON\r
15099         POPJ    P,              ; ELSE THATS ALL\r
15100         CAMG    B,PARTOP\r
15101         CAMGE   B,PARBOT        ; IS IT IN LIST SPACE?\r
15102         POPJ    P,              ; WELL NO LIST SMASHING THIS TIME\r
15103         HRRZ    0,(B)           ; GET ITS LIST POINTER\r
15104         CAME    0,-2(TP)\r
15105         POPJ    P,              ; THIS ONE DIDNT MATCH\r
15106         MOVE    0,(TP)          ; GET THE NEW REST OF THE LIST\r
15107         HRRM    0,(B)           ; AND SMASH INTO THE REST OF THE LIST\r
15108         POPJ    P,\r
15109 \r
15110 SBSTIS: CAMN    D,-2(TP)\r
15111         CAME    C,-10(TP)\r
15112         POPJ    P,\r
15113         SKIPN   B               ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE\r
15114         POPJ    P,\r
15115         MOVE    0,(TP)\r
15116         MOVEM   0,1(B)          ; KLOBBER VALUE CELL\r
15117         MOVE    0,-1(TP)\r
15118         HLLM    0,(B)           ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE\r
15119         POPJ    P,\r
15120 \r
15121 SBSTIL: PUSH    TP,$TATOM       ; LOSSAGE ON DIFFERENT TYPES, ONE DOUBLE WORD\r
15122         PUSH    TP,EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER\r
15123         JRST    CALER1\r
15124 \r
15125 END\r
15126 \r
15127 \fTITLE INITIALIZATION FOR MUDDLE\r
15128 \r
15129 RELOCATABLE\r
15130 \r
15131 LAST==1 ;POSSIBLE CHECKS DONE LATER\r
15132 \r
15133 .INSRT MUDDLE >\r
15134 \r
15135 SYSQ\r
15136 \r
15137 IFE ITS,[\r
15138 FATINS==.FATAL"\r
15139 SEVEC==104000,,204\r
15140 ]\r
15141 \r
15142 IMPURE\r
15143 \r
15144 OBSIZE==151.    ;DEFAULT OBLIST SIZE\r
15145 \r
15146 .LIFG <TVBASE+TVLNT-TVLOC>\r
15147 .LOP .VALUE\r
15148 .ELDC\r
15149 \r
15150 \r
15151 .GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP\r
15152 .GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE\r
15153 .GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER\r
15154 .GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC\r
15155 .GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1\r
15156 ; INIITAL AMOUNT OF AFREE SPACE\r
15157 \r
15158 STOSTR: BLOCK   400             ; A RANDOM AMOUNT\r
15159 ISTOST: 401,,0\r
15160 \r
15161 SETUP:\r
15162 IFN ITS,        .SUSET  [.RUNAM,,%UNAM]         ; FOR AGC'S BENFIT\r
15163         MOVE    P,GCPDL         ;GET A PUSH DOWN STACK\r
15164 IFN ITS,        .SUSET  [.SMASK,,[200000]]      ; ENABLE PDL OVFL\r
15165         MOVE    TVP,[-TVLNT,,TVBASE]    ;GET INITIAL TRANSFER VECTOR\r
15166         PUSHJ   P,TTYOPE                ;OPEN THE TTY\r
15167         AOS     A,20            ; TOP OF LOW SEGG\r
15168         HRRZM   A,P.TOP\r
15169         SOSN    A               ; IF NOTHING YET\r
15170 IFN ITS,        .SUSET  [.RMEMT,,P.TOP]\r
15171 IFE ITS,        JRST    4,\r
15172         HRRE    A,P.TOP         ; CHECK TOP\r
15173         TRNE    A,377777                ; SKIP IF ALL LOW SEG\r
15174         JUMPL   A,PAGLOS        ; COMPLAIN\r
15175         MOVE    A,HITOP         ; FIND HI SEG TOP\r
15176         ADDI    A,1777\r
15177         ANDCMI  A,1777\r
15178         MOVEM   A,RHITOP        ; SAVE IT\r
15179         MOVEI   A,200\r
15180         SUBI    A,PHIBOT\r
15181         JUMPE   A,HIBOK\r
15182         MOVSI   A,(A)\r
15183         HRRI    A,200\r
15184 IFN ITS,[\r
15185         .CALL   GIVCOR\r
15186         .VALUE\r
15187 ]\r
15188 HIBOK:  MOVEI   B,[ASCIZ /MUDDLE INITIALIZATION.\r
15189 /]\r
15190         PUSHJ   P,MSGTYP        ;PRINT IT\r
15191         MOVE    A,CODTOP        ;CHECK FOR A WINNING LOAD\r
15192         CAML    A,VECBOT        ;IT BETTER BE LESS\r
15193         JRST    DEATH1          ;LOSE COMPLETELY\r
15194         MOVE    B,PARBOT        ;CHECK FOR ANY PAIRS\r
15195         CAME    B,PARTOP        ;ANY LOAD/ASSEMBLE TIME PAIRS?\r
15196         JRST    PAIRCH          ;YES CHECK THEM\r
15197         ADDI    A,2000          ;BUMP UP\r
15198         ANDCMI  A,1777\r
15199         MOVEM   A,PARBOT        ;UPDATE PARBOT AND TOP\r
15200         MOVEM   A,PARTOP\r
15201 SETTV:  MOVE    PVP,[-PVLNT*2,,GCPVP]   ;AND A PROCESS VECTOR\r
15202         MOVEI   A,(PVP)         ;SET UP A BLT\r
15203         HRLI    A,PVBASE        ;FROM PROTOTYPE\r
15204         BLT     A,PVLNT*2-1(PVP)        ;INITIALIZE\r
15205         MOVE    TP,[-ITPLNT,,TPBAS]     ;GET A STACK FOR THIS PROCCESS\r
15206         MOVEI   TB,(TP)         ;AND A BASE\r
15207         HRLI    TB,1\r
15208         SUB     TP,[1,,1]       ;POP ONCE\r
15209 \r
15210 ; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS\r
15211 \r
15212         PUSH    P,[5]           ;COUNT INITIAL OBLISTS\r
15213 \r
15214         PUSH    P,OBLNT         ;SAVE CURRENT OBLIST DEFAULT SIZE\r
15215 \r
15216 MAKEOB: SOS     A,-1(P)\r
15217         MOVE    A,OBSZ(A)\r
15218         MOVEM   A,OBLNT\r
15219         MCALL   0,MOBLIST       ;GOBBLE AN OBLIST\r
15220         PUSH    TP,$TOBLS       ;AND SAVE THEM\r
15221         PUSH    TP,B\r
15222         MOVE    A,(P)-1         ;COUNT DOWN\r
15223         MOVEM   B,@OBTBL(A)     ;STORE\r
15224         JUMPN   A,MAKEOB\r
15225 \r
15226         POP     P,OBLNT         ;RESTORE DEFAULT OBLIST SIZE\r
15227 \r
15228         MOVE    C,TVP           ;MAKE 2 COPIES OF XFER VECTOR POINTER\r
15229         MOVE    D,TVP\r
15230 \r
15231 ;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE\r
15232 ;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR\r
15233 \r
15234 ILOOP:  HLRZ    A,(C)           ;FIRST TYPE\r
15235         JUMPE   A,TVEXAU        ;USEFUL STUFF EXHAUSTED\r
15236         CAIN    A,TCHSTR        ;CHARACTER STRING?\r
15237         JRST    CHACK           ;YES, GO HACK IT\r
15238         CAIN    A,TATOM         ;ATOM?\r
15239         JRST    ATOMHK          ;YES, CHECK IT OUT\r
15240         MOVE    A,(C)           ;MOVE TO NEW HOME (MAY BE SAME)\r
15241         MOVEM   A,(D)\r
15242         MOVE    A,1(C)\r
15243         MOVEM   A,1(D)\r
15244 SETLP:  AOS     (P)             ;COUNT NUMBER OF PAIRS IN XFER VECTOR\r
15245         ADD     D,[2,,2]        ;OUT COUNTER\r
15246 SETLP1: ADD     C,[2,,2]        ;AND IN COUNTER\r
15247         JUMPL   C,ILOOP         ;JUMP IF MORE TO DO\r
15248 \f;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST\r
15249 \r
15250 TVEXAU: HLRE    B,C             ;GET -LENGTH\r
15251         SUBI    C,(B)           ;POIT TO DOPE WORD\r
15252         ANDI    C,-1            ;NO LH\r
15253         HLRZ    A,1(C)          ;INTIAL LENGTH TO A\r
15254         MOVEI   E,(C)           ;COPY OF POINTER TO DOPW WD\r
15255         SUBI    E,(D)           ;AMOUNT LEFT OVER TO E\r
15256         HRLZM   E,1(C)          ;CLOBBER INTO DOPE WORD FOR GARBAGE\r
15257         MOVSI   E,(E)           ;PREPARE TO UPDATE TVP\r
15258         ADD     TVP,E           ;NOW POINTS TO THE RIGHT AMOUNT\r
15259         HLRE    B,D             ;-AMOUNT LEFT TO B\r
15260         ADD     B,A             ;AMOUNT OF GOOD STUFF\r
15261         HRLZM   B,1(D)          ;STORE IT IN GODD DOPE WORD\r
15262         MOVSI   E,400000        ;CLOBBER TO GENERAL IN BOTH CASES\r
15263         MOVEM   E,(C)\r
15264         MOVEM   E,(D)\r
15265 \r
15266 \r
15267 ; FIX UP TYPE VECTOR\r
15268 \r
15269         MOVE    A,TYPVEC+1(TVP) ;GET POINTER\r
15270         MOVEI   0,0             ;FOR POSSIBLE NULL SLOTS\r
15271         MOVSI   B,TATOM         ;SET TYPE TO ATOM\r
15272 \r
15273 TYPLP:  HLLM    B,(A)           ;CHANGE TYPE TO ATOM\r
15274         MOVE    C,@1(A)         ;GET ATOM\r
15275         MOVEM   C,1(A)\r
15276         ADD     A,[2,,2]                ;BUMP\r
15277         JUMPL   A,TYPLP\r
15278 \f; CLOSE TTY CHANNELS\r
15279 IFN ITS,[\r
15280 \r
15281         .CLOSE  1,\r
15282         .CLOSE  2,\r
15283 ]\r
15284 \r
15285 ;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS\r
15286 \r
15287 ;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL\r
15288 \r
15289         IRP     A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]\r
15290         IRP     B,C,[A]\r
15291         PUSH    TP,$!C\r
15292         PUSH    TP,CHQUOTE B\r
15293         .ISTOP\r
15294         TERMIN\r
15295         TERMIN\r
15296 \r
15297         MCALL   2,FOPEN         ;OPEN THE OUT PUT CHANNEL\r
15298         MOVEM   B,TTOCHN+1(TVP) ;SAVE IT\r
15299 \r
15300 ;ASSIGN AS GLOBAL VALUE\r
15301 \r
15302         PUSH    TP,$TATOM\r
15303         PUSH    TP,IMQUOTE OUTCHAN\r
15304         PUSH    TP,A\r
15305         PUSH    TP,B\r
15306         MOVE    A,[PUSHJ P,MTYO]        ;MORE WINNING INS\r
15307         MOVEM   A,IOINS(B)      ;CLOBBER\r
15308         MCALL   2,SETG\r
15309 \r
15310 ;SETUP A CALL TO OPEN THE TTY CHANNEL\r
15311 \r
15312         IRP     A,,[[READ,TCHSTR],[TTY:,TCHSTR]]\r
15313         IRP     B,C,[A]\r
15314         PUSH    TP,$!C\r
15315         PUSH    TP,CHQUOTE B\r
15316         .ISTOP\r
15317         TERMIN\r
15318         TERMIN\r
15319 \r
15320         MCALL   2,FOPEN         ;OPEN INPUTCHANNEL\r
15321         MOVEM   B,TTICHN+1(TVP) ;SAVE IT\r
15322         PUSH    TP,$TATOM       ;ASSIGN AS A GLOBAL VALUE\r
15323         PUSH    TP,IMQUOTE INCHAN\r
15324         PUSH    TP,A\r
15325         PUSH    TP,B\r
15326         MOVE    C,BUFRIN(B)     ;GET AUX BUFFER PTR\r
15327         MOVE    A,[PUSHJ P,MTYI]\r
15328         MOVEM   A,IOIN2(C)      ;MORE OF A WINNER\r
15329         MOVE    A,[PUSHJ P,MTYO]\r
15330         MOVEM   A,ECHO(C)       ;ECHO INS\r
15331         MCALL   2,SETG\r
15332 \r
15333 ;GENERATE AN INITIAL PROCESS AND SWAP IT IN\r
15334 \r
15335         PUSHJ   P,ICR   ;CREATE IT\r
15336         MOVEI   0,RUNING\r
15337         MOVEM   0,PSTAT"+1(B)\r
15338         MOVE    D,B     ;SET UP TO CALL SWAP\r
15339         JSP     C,SWAP  ;AND SWAP IN\r
15340         MOVEM   PVP,MAINPR"     ;SAVE AS THE MAIN PROCESS\r
15341         PUSH    TP,[TENTRY,,TOPLEV]     ;BUILD DUMMY FRAME\r
15342         PUSH    TP,[1,,0]\r
15343         MOVEI   A,-1(TP)\r
15344         PUSH    TP,A\r
15345         PUSH    TP,SP\r
15346         PUSH    TP,P\r
15347         MOVE    C,TP    ;COPY TP\r
15348         ADD     C,[3,,3]        ;FUDGE\r
15349         PUSH    TP,C    ;TPSAV PUSHED\r
15350         PUSH    TP,[TOPLEV]\r
15351         HRRI    TB,(TP) ;SETUP TB\r
15352         HRLI    TB,2\r
15353         ADD     TB,[1,,1]\r
15354         MOVEM   TB,TBINIT+1(PVP)\r
15355         MOVSI   A,TSUBR\r
15356         MOVEM   A,RESFUN(PVP)\r
15357         MOVEI   A,LISTEN"\r
15358         MOVEM   A,RESFUN+1(PVP)\r
15359         PUSH    TP,$TATOM\r
15360         PUSH    TP,IMQUOTE THIS-PROCESS\r
15361         PUSH    TP,$TPVP\r
15362         PUSH    TP,PVP\r
15363         MCALL   2,SETG\r
15364 \r
15365 ; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE\r
15366 \r
15367         MOVEI   A,MQUOTE T\r
15368         SUBI    A,(TVP)\r
15369 TVTOFF==0\r
15370         ADDSQU  TVTOFF\r
15371 \r
15372         MOVEM   A,SQULOC-1\r
15373 \r
15374         PUSH    TP,$TATOM\r
15375         PUSH    TP,IMQUOTE TVTOFF,,MUDDLE\r
15376         PUSH    TP,$TFIX\r
15377         PUSH    TP,A\r
15378         MCALL   2,SETG\r
15379 \r
15380 ; HERE TO SETUP SQUOZE TABLE IN PURE CORE\r
15381 \r
15382         PUSHJ   P,SQSETU        ; GO TO ROUTINE\r
15383 \r
15384         MOVEI   A,400000        ; FENCE POST PURE SR VECTOR\r
15385         HRRM    A,PURVEC(TVP)\r
15386         MOVE    A,TP\r
15387         HLRE    B,A\r
15388         SUBI    A,-PDLBUF(B)    ;POINT TO DOPE WORDS\r
15389         MOVEI   B,12    ;GROWTH SPEC\r
15390         IORM    B,(A)\r
15391         MOVEI   0,ISTOST\r
15392         MOVEM   0,CODTOP\r
15393         PUSHJ   P,AAGC  ;DO IT\r
15394         AOJL    A,.-1\r
15395         MOVE    A,TPBASE+1(PVP)\r
15396         SUB     A,[640.,,640.]\r
15397         MOVEM   A,TPBASE+1(PVP)\r
15398 \r
15399 ; CREATE LIST OF ROOT AND NEW OBLIST\r
15400 \r
15401         MOVEI   A,5\r
15402         PUSH    P,A\r
15403 \r
15404 NAMOBL: PUSH    TP,$TATOM\r
15405         PUSH    TP,@OBNAM-1(A)  ; NAME\r
15406         PUSH    TP,$TATOM\r
15407         PUSH    TP,IMQUOTE OBLIST\r
15408         PUSH    TP,$TOBLS\r
15409         PUSH    TP,@OBTBL-1(A)\r
15410         MCALL   3,PUT           ; NAME IT\r
15411         SOS     A,(P)\r
15412         PUSH    TP,$TOBLS\r
15413         PUSH    TP,@OBTBL(A)\r
15414         PUSH    TP,$TATOM\r
15415         PUSH    TP,IMQUOTE OBLIST\r
15416         PUSH    TP,$TATOM\r
15417         PUSH    TP,@OBNAM(A)\r
15418         MCALL   3,PUT\r
15419         SKIPE   A,(P)\r
15420         JRST    NAMOBL\r
15421         SUB     P,[1,,1]\r
15422 \r
15423 ;Define MUDDLE version number\r
15424         MOVEI   A,5\r
15425         MOVEI   B,0             ;Initialize result\r
15426         MOVE    C,[440700,,MUDSTR+2]\r
15427 VERLP:  ILDB    D,C             ;Get next charcter digit\r
15428         CAIG    D,"9            ;Non-digit ?\r
15429         CAIGE   D,"0\r
15430         JRST    VERDEF\r
15431         SUBI    D,"0            ;Convert to number\r
15432         IMULI   B,10.\r
15433         ADD     B,D             ;Include number into result\r
15434         SOJG    A,VERLP         ;Finished ?\r
15435 VERDEF:\r
15436         PUSH    TP,$TATOM\r
15437         PUSH    TP,MQUOTE MUDDLE\r
15438         PUSH    TP,$TFIX\r
15439         PUSH    TP,B\r
15440         MCALL   2,SETG          ;Make definition\r
15441 OPIPC:\r
15442 IFN ITS,[\r
15443         PUSH    TP,$TCHSTR\r
15444         PUSH    TP,CHQUOTE IPC\r
15445         PUSH    TP,$TATOM\r
15446         PUSH    TP,MQUOTE IPC-HANDLER\r
15447         MCALL   1,GVAL\r
15448         PUSH    TP,A\r
15449         PUSH    TP,B\r
15450         PUSH    TP,$TFIX\r
15451         PUSH    TP,[1]\r
15452         MCALL   3,ON\r
15453         MCALL   0,IPCON\r
15454 ]\r
15455 \r
15456 ; Allocate inital template tables\r
15457 \r
15458         MOVEI   A,10\r
15459         PUSHJ   P,CAFRE1\r
15460         ADD     B,[10,,10]              ; REST IT OFF\r
15461         MOVEM   B,TD.LNT+1(TVP)\r
15462         MOVEI   A,10\r
15463         PUSHJ   P,CAFRE1\r
15464         MOVEI   0,TUVEC         ; SETUP UTYPE\r
15465         HRLM    0,10(B)\r
15466         MOVEM   B,TD.GET+1(TVP)\r
15467         MOVEI   A,10\r
15468         PUSHJ   P,CAFRE1\r
15469         MOVEI   0,TUVEC         ; SETUP UTYPE\r
15470         HRLM    0,10(B)\r
15471         MOVEM   B,TD.PUT+1(TVP)\r
15472 \r
15473 PTSTRT: MOVEI   A,SETUP\r
15474         ADDI    A,1\r
15475         SUB     A,PARBOT        ;FIND WHERE PAIRS SHOULD GO\r
15476         MOVEM   A,PARNEW\r
15477 IFE ITS,[\r
15478         MOVEI   A,400000\r
15479         MOVE    B,[1,,START]\r
15480         SEVEC\r
15481 ]\r
15482         PUSH    P,[14.,,14.]    ;PUSH A SMALL PRGRM ONTO P\r
15483         MOVEI   A,1(P)  ;POINT TO ITS START\r
15484         PUSH    P,[JRST AAGC]   ;GO TO AGC\r
15485         PUSH    P,[MOVE B,PSTO+1(PVP)]  ;GET SAVED P\r
15486         PUSH    P,[SUB B,-13.(P)]       ;FUDGE TO POP OFF PROGRAM\r
15487         PUSH    P,[MOVEM B,PSAV(TB)]    ;INTO FRAME\r
15488         PUSH    P,[MOVE B,TPSTO+1(PVP)] ;GET TP\r
15489         PUSH    P,[MOVEM B,TPSAV(TB)]   ;STORE IT\r
15490         PUSH    P,[MOVE B,SPSTO+1(PVP)] ;SP\r
15491         PUSH    P,[MOVEM B,SPSAV(TB)]\r
15492         PUSH    P,[MOVEI B,TOPLEV]      ;WHERE TO GO\r
15493         PUSH    P,[MOVEM B,PCSAV(TB)]\r
15494 IFN ITS,        PUSH    P,[MOVSI B,(.VALUE )]\r
15495 IFE ITS,        PUSH    P,[MOVSI B,(JRST 4,)]\r
15496         PUSH    P,[HRRI B,C]\r
15497         PUSH    P,[JRST B]      ;GO DO VALRET\r
15498         PUSH    P,[B]\r
15499         PUSH    P,A             ; PUSH START ADDR\r
15500         MOVE    B,[JRST -11.(P)]\r
15501         MOVE    0,[JUMPA START]\r
15502         MOVE    C,[ASCII \\170/\e9\]\r
15503         MOVE    D,[ASCII \B/\e1Q\]\r
15504         MOVE    E,[ASCIZ \\r
15505 \16*\r
15506 \]              ;TERMINATE\r
15507         POPJ    P,              ; GO\r
15508 \f\r
15509 ; CHECK PAIR SPACE\r
15510 \r
15511 PAIRCH: CAMG    A,B\r
15512         JRST    SETTV           ;O.K.\r
15513 \r
15514 DEATH1: MOVEI   B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP\r
15515 /]\r
15516         PUSHJ   P,MSGTYP\r
15517         .VALUE\r
15518 \r
15519 ;CHARACTER STRING HACKER\r
15520 \r
15521 CHACK:  MOVE    A,(C)           ;GET TYPE\r
15522         HLLZM   A,(D)           ;STORE IN NEW HOME\r
15523         MOVE    B,1(C)          ;GET POINTER\r
15524         HLRZ    E,B             ;-LENGHT\r
15525         HRRM    E,(D)\r
15526         PUSH    P,E+1           ; IDIVI WILL CLOBBER\r
15527         ADDI    E,4+5*2         ; ROUND AND ACCOUNT FOR DOPE WORDS\r
15528         IDIVI   E,5             ; E/ WORDS LONG\r
15529         PUSHJ   P,EBPUR         ; MAKE A PURIFIED COPY\r
15530         POP     P,E+1\r
15531         HRLI    B,440700        ;MAKE POINT BYTER\r
15532         MOVEM   B,1(D)          ;AND STORE IT\r
15533         ANDI    A,-1    ;CLEAR LH OF A\r
15534         JUMPE   A,SETLP ;JUMP IF NO REF\r
15535         MOVE    E,(P)           ;GET OFFSET\r
15536         LSH     E,1\r
15537         HRRZ    B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR\r
15538         CAIE    B,$TCHSTR       ;SKIP IF IT DOES\r
15539         JRST    CHACK1  ;NO, JUST DO CHQUOTE PART\r
15540         HRRM    E,-1(A) ;CLOBBER\r
15541         MOVEI   B,TVP\r
15542         DPB     B,[220400,,-1(A)]       ;CLOBBER INDEX FIELD\r
15543 CHACK1: ADDI    E,1\r
15544         HRRM    E,(A)           ;STORE INTO REFERENCE\r
15545         JRST    SETLP\r
15546 \r
15547 ; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT\r
15548 \r
15549 EBPUR:  PUSH    P,E\r
15550         PUSH    P,A\r
15551         ADD     E,HITOP         ; GET NEW TOP\r
15552         CAMG    E,RHITOP        ; SKIP IF TOO BIG\r
15553         JRST    EBPUR1\r
15554 \r
15555 ;  CODE TO GROW HI SEG \r
15556 \r
15557         MOVEI   A,2000\r
15558         ADDB    A,RHITOP        ; NEW TOP\r
15559 IFN ITS,[\r
15560         ASH     A,-10.          ; NUM OF BLOCKS\r
15561         SUBI    A,1             ; BLOCK TO GET\r
15562         .CALL   HIGET\r
15563         .VALUE\r
15564 ]\r
15565 \r
15566 EBPUR1: MOVEI   A,-1(E)         ; NEEDED TO TERMINATE BLT\r
15567         EXCH    E,HITOP\r
15568         HRLI    E,(B)\r
15569         MOVEI   B,(E)\r
15570         BLT     E,(A)\r
15571         POP     P,A\r
15572         POP     P,E\r
15573         POPJ    P,\r
15574 \r
15575 GIVCOR: SETZ\r
15576         SIXBIT /CORBLK/\r
15577         1000,,0\r
15578         1000,,-1\r
15579         SETZ    A\r
15580 \r
15581 HIGET:  SETZ\r
15582         SIXBIT /CORBLK/\r
15583         1000,,100000\r
15584         1000,,-1\r
15585         A\r
15586         401000,,400001\r
15587 \r
15588 \f\r
15589 ; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T\r
15590 ; ALREADY THERE\r
15591 \r
15592 ATOMHK: PUSH    TP,$TOBLS       ; SAVE OBLIST\r
15593         PUSH    TP,[0]          ; FILLED IN LATER\r
15594         PUSH    TP,$TVEC        ;SAVE TV POINTERS\r
15595         PUSH    TP,C\r
15596         PUSH    TP,$TVEC\r
15597         PUSH    TP,D\r
15598         MOVE    B,1(C)          ;GET THE ATOM\r
15599         PUSH    TP,$TATOM       ;AND SAVE\r
15600         PUSH    TP,B\r
15601         HRRZ    A,(B)           ;GET OBLIST SPEC FROM ATOM\r
15602         LSH     A,1\r
15603         ADDI    A,1(TB)         ;POINT TO ITS HOME\r
15604         PUSH    TP,$TOBLS\r
15605         PUSH    TP,(A)          ;AND SAV IT\r
15606         MOVE    A,(A)\r
15607         MOVEM   A,-10(TP)       ; CLOBBER\r
15608         HLRE    E,A\r
15609         MOVNS   E\r
15610 \r
15611         ADD     B,[3,,3]        ;POINT TO ATOM'S PNAME\r
15612         MOVEI   A,0             ;FOR HASHING\r
15613         XOR     A,(B)\r
15614         AOBJN   B,.-1\r
15615         TLZ     A,400000        ;FORCE POSITIVE RESULT\r
15616         IDIV    A,E\r
15617         HRLS    B               ;REMAINDER IN B IS BUCKET\r
15618         ADDB    B,(TP)          ;UPDATE POINTER\r
15619 \r
15620         SKIPN   C,(B)           ;GOBBLE BUCKET CONTENTS\r
15621         JRST    USEATM          ;NONE, LEAVE AND USE THIS ATOM\r
15622 OBLOO3: MOVE    E,-2(TP)        ;RE-GOBBLE ATOM\r
15623         ADD     E,[3,,3]        ;POINT TO PNAME\r
15624         SKIPN   D,1(C)          ;CHECK LIST ELEMNT\r
15625         JRST    NXTBCK          ;0, CHECK NEXT IN THIS BUCKET\r
15626         ADD     D,[3,,3]        ;POINT TO PNAME\r
15627 OBLOO2: MOVE    A,(D)           ;GET A WORD\r
15628         CAME    A,(E)           ;COMPARE\r
15629         JRST    NXTBCK          ;THEY DIFFER, TRY NEX\r
15630 OBLOOP: AOBJP   E,CHCKD         ;COULD BE A MATCH, GO CHECK\r
15631         AOBJN   D,OBLOO2        ;HAVEN'T LOST YET\r
15632 \r
15633 NXTBCK: HRRZ    C,(C)           ;CDR THE LIST\r
15634         JUMPN   C,OBLOO3        ;IF NOT NIL, KEEP TRYING\r
15635 \r
15636 ;HERE IF THIS ATOM MUST BE PUT ON OBLIST\r
15637 \r
15638 USEATM: MOVE    B,-2(TP)                ; GET ATOM\r
15639         HLRZ    0,(B)           ; SEE IF PURE OR NOT\r
15640         TRNN    0,400000        ; SKIP IF IMPURE\r
15641         JRST    PURATM\r
15642         MOVE    B,(TP)          ;POINTER TO BUCKET\r
15643         HRRZ    C,(B)           ;POINTER TO LIST IN THIS BUCKET\r
15644         PUSH    TP,$TATOM       ;GENERATE CALL TO CONS\r
15645         PUSH    TP,-3(TP)\r
15646         PUSH    TP,$TLIST\r
15647         PUSH    TP,C\r
15648         MCALL   2,CONS          ;CONS IT UP\r
15649         MOVE    C,(TP)          ;REGOBBLE BUCKET POINTER\r
15650         HRRZM   B,(C)           ;CLOBBER\r
15651         MOVE    B,-2(TP)        ;POINT TO ATOM\r
15652         MOVE    C,-10(TP)               ; GET OBLIST\r
15653         MOVEM   C,2(B)          ; INTO ATOM\r
15654         PUSHJ   P,VALMAK        ;MAKE A GLOBAL VALUE FOR THIS LOSER\r
15655 PURAT2: MOVE    C,-6(TP)        ;RESET POINTERS\r
15656         MOVE    D,-4(TP)\r
15657         SUB     TP,[12,,12]\r
15658         MOVE    B,(C)           ;MOVE THE ENTRY\r
15659         HLLZM   B,(D)           ;DON'T WANT REF POINTER STORED\r
15660         MOVE    A,1(C)          ;AND MOVE ATOM\r
15661         MOVEM   A,1(D)\r
15662         MOVE    A,(P)           ;GET CURRENT OFFSET\r
15663         LSH     A,1\r
15664         ADDI    A,1\r
15665         ANDI    B,-1            ;CHECK FOR REAL REF\r
15666         JUMPE   B,SETLP1        ;DON'T SAVE THIS ATOM ON TVP\r
15667         HRRM    A,(B)           ;CLOBBER CODE\r
15668         JRST    SETLP\r
15669 \r
15670 \r
15671 ; HERE TO MAKE A PURE ATOM\r
15672 \r
15673 PURATM: HRRZ    B,-2(TP)        ; POINT TO IT\r
15674         HLRE    E,-2(TP)        ; - LNTH\r
15675         MOVNS   E\r
15676         ADDI    E,2\r
15677         PUSHJ   P,EBPUR         ; PURE COPY\r
15678         HRRM    B,-2(TP)        ; AND STORE BACK\r
15679         HRRO    B,(TP)          ; GET BUCKET BACK\r
15680 PURAT1: HRRZ    C,(B)           ; GET CONTENTS\r
15681         JUMPE   C,HICONS        ; AT END, OK\r
15682         CAIL    C,HIBOT         ; SKIP IF IMPURE\r
15683         JRST    HICONS  ; CONS IT ON\r
15684         MOVEI   B,(C)\r
15685         JRST    PURAT1\r
15686 \r
15687 HICONS: HRLI    C,TATOM\r
15688         PUSH    P,C\r
15689         PUSH    P,-2(TP)\r
15690         PUSH    P,B\r
15691         MOVEI   B,-2(P)\r
15692         MOVEI   E,2\r
15693         PUSHJ   P,EBPUR         ; MAKE PURE LIST CELL\r
15694 \r
15695         MOVE    C,(P)\r
15696         SUB     P,[3,,3]\r
15697         HRRM    B,(C)           ; STORE IT\r
15698         MOVE    B,1(B)          ; ATOM BACK\r
15699         MOVE    C,-6(TP)        ; GET TVP SLOT\r
15700         HRRM    B,1(C)          ; AND STORE\r
15701         HLRZ    0,(B)           ; TYPE OF VAL\r
15702         MOVE    C,B\r
15703         CAIN    0,TUNBOU        ; NOT UNBOUND?\r
15704         JRST    PURAT3          ; UNBOUND, NO VAL\r
15705         MOVEI   E,2             ; COUNT AGAIN\r
15706         PUSHJ   P,EBPUR         ; VALUE CELL\r
15707         MOVE    C,-2(TP)                ; ATOM BACK\r
15708         HLLZS   (B)             ; CLEAR LH\r
15709         MOVSI   0,TLOCI\r
15710         HLLM    0,(C)\r
15711         MOVEM   B,1(C)\r
15712 PURAT3: HRRZ    A,(C)           ; GET OBLIST CODE\r
15713         MOVE    A,OBTBL2(A)\r
15714         MOVEM   A,2(C)          ; STORE OBLIST SLOT\r
15715         HLLZS   (C)\r
15716         JRST    PURAT2\r
15717 \f\r
15718 ; A POSSIBLE MATCH ARRIVES HERE\r
15719 \r
15720 CHCKD:  AOBJN   D,NXTBCK        ;SIZES DIFFER, JUMP\r
15721         MOVE    D,1(C)          ;THEY MATCH!,  GET EXISTING ATOM\r
15722         MOVEI   A,(D)           ;GET TYPE OF IT\r
15723         MOVE    B,-2(TP)        ;GET NEW ATOM\r
15724         HLRZ    0,(B)\r
15725         TRZ     A,377777        ; SAVE ONLY 400000 BIT\r
15726         TRZ     0,377777\r
15727         CAIN    0,(A)           ; SKIP IF WIN\r
15728         JRST    IM.PUR\r
15729         MOVSI   0,400000\r
15730         ANDCAM  0,(B)\r
15731         ANDCAM  0,(D)\r
15732         HLRZ    A,(D)\r
15733         CAIE    A,TUNBOU        ;UNBOUND?\r
15734         JRST    A1VAL           ;YES, CONTINUE\r
15735         MOVE    A,(B)           ;MOVE VALUE\r
15736         MOVEM   A,(D)\r
15737         MOVE    A,1(B)\r
15738         MOVEM   A,1(D)\r
15739         MOVE    B,D             ;EXISTING ATOM TO B\r
15740         MOVEI   0,(B)\r
15741         CAIL    0,HIBOT\r
15742         JRST    .+3\r
15743         PUSHJ   P,VALMAK        ;MAKE A VALUE\r
15744         JRST    .+2\r
15745         PUSHJ   P,PVALM\r
15746 \r
15747 ;NOW FIND ATOMS OCCURENCE IN XFER VECTOR\r
15748 \r
15749 OFFIND: MOVE    D,-4(TP)        ;GET CURRENT POINTER INTO TP\r
15750         MOVE    C,TVP           ;AND A COPY OF TVP\r
15751         MOVEI   A,0             ;INITIALIZE COUNTER\r
15752 ALOOP:  CAMN    B,1(C)          ;IS THIS IT?\r
15753         JRST    AFOUND\r
15754         ADD     C,[2,,2]        ;BUMP COUNTER\r
15755         CAMGE   C,D             ;HAVE WE HIT END\r
15756         AOJA    A,ALOOP         ;NO, KEEP LOOKING\r
15757 \r
15758         MOVEI   B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED\r
15759 /]\r
15760 TYPIT:  PUSHJ   P,MSGTYP\r
15761         .VALUE\r
15762 \r
15763 AFOUND: LSH     A,1             ;FOUND ATOM, GET REAL OFFSET\r
15764         ADDI    A,1\r
15765         MOVE    C,-6(TP)        ;GET TV POINTER TO NEW ATOM\r
15766         HRRZ    B,(C)           ;POINT TO REFERENCE\r
15767         SKIPE   B               ;ANY THERE?\r
15768         HRRM    A,(B)           ;YES, CLOBBER AWAY\r
15769         SUB     TP,[12,,12]\r
15770         JRST    SETLP1          ;AND GO ON\r
15771 \r
15772 A1VAL:  HLRZ    C,(B)           ;GET VALUE'S TYPE\r
15773         MOVE    B,D             ;NOW PUT EXISTING ATOM IN B\r
15774         CAIN    C,TUNBOU        ;UNBOUND?\r
15775         JRST    OFFIND          ;YES, WINNER\r
15776 \r
15777         MOVEI   B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES\r
15778 /]\r
15779         JRST    TYPIT\r
15780 \r
15781 \r
15782 IM.PUR: MOVEI   B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE\r
15783 /]\r
15784         JRST    TYPIT\r
15785 \r
15786 PAGLOS: MOVEI   B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT\r
15787 /]\r
15788         JRST    TYPIT\r
15789 \f\r
15790 ;MAKE A VALUE IN SLOT ON GLOBAL SP\r
15791 \r
15792 VALMAK: HLRZ    A,(B)           ;TYPE OF VALUE\r
15793         CAIE    A,400000+TUNBOU\r
15794         CAIN    A,TUNBOU        ;VALUE?\r
15795         POPJ    P,              ;NO, ALL DONE\r
15796         MOVE    A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP\r
15797         SUB     A,[4,,4]        ;ALLOCATE SPACE\r
15798         CAMG    A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW\r
15799         JRST    SPOVFL\r
15800         MOVEM   A,GLOBSP+1(TVP) ;STORE IT BACK\r
15801         MOVE    C,(B)           ;GET TYPE CELL\r
15802         TLZ     C,400000\r
15803         HLLZM   C,2(A)          ;INTO TYPE CELL\r
15804         MOVE    C,1(B)          ;GET VALUE\r
15805         MOVEM   C,3(A)          ;INTO VALUE SLOT\r
15806         MOVSI   C,TGATOM        ;GET TATOM,,0\r
15807         MOVEM   C,(A)\r
15808         MOVEM   B,1(A)          ;AND POINTER TO ATOM\r
15809         MOVSI   C,TLOCI         ;NOW CLOBBER THE ATOM\r
15810         MOVEM   C,(B)           ;INTO TYPE CELL\r
15811         ADD     A,[2,,2]        ;POINT TO VALUE\r
15812         MOVEM   A,1(B)\r
15813         POPJ    P,\r
15814 \r
15815 SPOVFL: MOVEI   B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW\r
15816 /]\r
15817         JRST    TYPIT\r
15818 \r
15819 \r
15820 PVALM:  HLRZ    0,(B)\r
15821         CAIE    0,400000+TUNBOU\r
15822         CAIN    0,TUNBOU\r
15823         POPJ    P,\r
15824         MOVEI   E,2\r
15825         PUSH    P,B\r
15826         PUSHJ   P,EBPUR\r
15827         POP     P,C\r
15828         MOVEM   B,1(C)\r
15829         MOVSI   0,TLOCI\r
15830         MOVEM   0,(C)\r
15831         MOVE    B,C\r
15832         POPJ    P,\r
15833 \f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER\r
15834 \r
15835 VECTGO DUMMY1\r
15836 \r
15837 IRP     A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1\r
15838 ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER\r
15839 IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR\r
15840 MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS\r
15841 CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ\r
15842 CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN\r
15843 CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG\r
15844 CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR\r
15845 OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY\r
15846 CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO\r
15847 CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT\r
15848 CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C\r
15849 CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL\r
15850 CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC\r
15851 CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1\r
15852 CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS]\r
15853         .GLOBAL A\r
15854         ADDSQU A\r
15855         MAKAT [A]TFIX,A,MUDDLE,0\r
15856 TERMIN\r
15857 \r
15858 VECRET\r
15859 \r
15860 ; ROUTINE TO SORT AND PURIFY SQUOZE TABLE\r
15861 \r
15862 SQSETU: MOVE    A,[SQUTBL-SQULOC+2,,SQUTBL]\r
15863         MOVEI   0,1\r
15864 SQ2:    MOVE    B,(A)\r
15865         CAMG    B,2(A)\r
15866         JRST    SQ1\r
15867         MOVEI   0,0\r
15868         EXCH    B,2(A)\r
15869         MOVEM   B,(A)\r
15870         MOVE    B,1(A)\r
15871         EXCH    B,3(A)\r
15872         MOVEM   B,1(A)\r
15873 SQ1:    ADD     A,[2,,2]\r
15874         JUMPL   A,SQ2\r
15875         JUMPE   0,SQSETU\r
15876         MOVEI   E,SQULOC-SQUTBL\r
15877         MOVEI   B,SQUTBL\r
15878         PUSHJ   P,EBPUR         ; TO THE PURE WORLD\r
15879         HRLI    B,SQUTBL-SQULOC\r
15880         MOVEM   B,SQUPNT"\r
15881         POPJ    P,\r
15882         \r
15883 RHITOP: 0\r
15884 \r
15885 OBSZ:   151.\r
15886         151.\r
15887         151.\r
15888         151.\r
15889         317.\r
15890 \r
15891 OBTBL2: ROOT+1\r
15892         ERROBL+1\r
15893         INTOBL+1\r
15894         MUDOBL+1\r
15895         INITIAL+1\r
15896 \r
15897 OBTBL:  INITIAL+1(TVP)\r
15898         MUDOBL+1(TVP)\r
15899         INTOBL+1(TVP)\r
15900         ERROBL+1(TVP)\r
15901         ROOT+1(TVP)\r
15902 OBNAM:  MQUOTE INITIAL\r
15903         MQUOTE MUDDLE\r
15904         MQUOTE INTERRUPTS\r
15905         MQUOTE ERRORS\r
15906         MQUOTE ROOT\r
15907 \r
15908 END SETUP\r
15909 \r
15910 \r
15911 \f\f\f\r
15912 TITLE INTERRUPT HANDLER FOR MUDDLE\r
15913 \r
15914 RELOCATABLE\r
15915 \r
15916 ;C. REEVE  APRIL 1971\r
15917 \r
15918 .INSRT MUDDLE >\r
15919 \r
15920 SYSQ\r
15921 \r
15922 IF1,[\r
15923 IFE ITS,.INSRT MUDSYS;STENEX >\r
15924 ]\r
15925 \r
15926 PDLGRO==10000   ;AMOUNT TO GROW A PDL THAT LOSES\r
15927 NINT==72.       ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE\r
15928 \r
15929 IFN ITS,[\r
15930 ;SET UP LOCATION 42 TO POINT TO TSINT\r
15931 \r
15932 RMT [\r
15933 \r
15934 ZZZ==$. ;SAVE CURRENT LOCATION\r
15935 \r
15936 LOC 42\r
15937 \r
15938         JSR     MTSINT          ;GO TO HANDLER\r
15939 \r
15940 LOC ZZZ\r
15941 ]\r
15942 ]\r
15943 \r
15944 ; GLOBALS NEEDED BY INTERRUPT HANDLER\r
15945 \r
15946 .GLOBAL ONINT   ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT\r
15947 .GLOBA GCFLG    ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING\r
15948 .GLOBAL GCFLCH  ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM\r
15949 .GLOBAL CORTOP  ; TOP OF CORE\r
15950 .GLOBA GCINT    ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT\r
15951 .GLOBAL INTNUM,INTVEC   ;TV ENTRIES CONCERNING INTERRUPTS\r
15952 .GLOBAL AGC     ;CALL THE GARBAGE COLLECTOR\r
15953 .GLOBAL VECNEW,PARNEW,GETNUM    ;GC PSEUDO ARGS\r
15954 .GLOBAL GCPDL   ;GARBAGE COLLECTORS PDL\r
15955 .GLOBAL VECTOP,VECBOT   ;DELIMIT VECTOR SPACE\r
15956 .GLOBAL PURTOP\r
15957 .GLOBAL PDLBUF  ;AMOUNT OF  PDL GROWTH\r
15958 .GLOBAL PGROW   ;POINTS TO DOPE WORD OF NEXT PDL TO GROW\r
15959 .GLOBAL TPGROW  ;POINTS TO NEXT MUDDLE PDL TO GROW\r
15960 .GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1\r
15961 .GLOBAL BUFRIN,CHNL0,SYSCHR     ;CHANNEL GLOBALS\r
15962 .GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS\r
15963 .GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS\r
15964 .GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE\r
15965 .GLOBAL MTSINT  ;BEGINNING OF INTERRUPT HANDLER\r
15966 .GLOBAL INTINT  ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS\r
15967 .GLOBAL FRMSTK,APPLY,CHUNW\r
15968 .GLOBAL IPCGOT,DIRQ     ;HANDLE BRANCHING OFF TO IPC KLUDGERY\r
15969 \r
15970 ; GLOBALS FOR GC\r
15971 .GLOBAL GCTIM,GCCAUS,GCCALL\r
15972 \r
15973 ; GLOBALS FOR MONITOR ROUTINES\r
15974 \r
15975 .GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT\r
15976 .GLOBAL PURERR,BUFRIN,INSTAT\r
15977 \r
15978 MONITOR\r
15979 \r
15980 .GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED\r
15981 .GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN\r
15982 .GLOBAL INTHLD,BNDV,SPECBE\r
15983 ;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)\r
15984 \r
15985 \r
15986 ;***** TEMP FUDGE *******\r
15987 \r
15988 QUEUES==INTVEC\r
15989 \r
15990 \f\r
15991 ; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS\r
15992 \r
15993 ; SPECIAL TABLES\r
15994 \r
15995 SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT\r
15996 PARITY]\r
15997         MQUOTE A,[A]INTRUP\r
15998         TERMIN\r
15999 SPECLN==.-SPECIN\r
16000 \r
16001 ; TABLE OF SPECIAL FINDING ROUTINES\r
16002 \r
16003 FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0]\r
16004         A\r
16005         TERMIN\r
16006 \r
16007 ; TABLE OF SPECIAL SETUP ROUTINES\r
16008 \r
16009 INTBL:  IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF\r
16010 S.RUNT,S.REAL,S.PAR]\r
16011         A\r
16012         S!A==.IRPCNT\r
16013         TERMIN\r
16014 \r
16015 IFN ITS,[\r
16016 \r
16017 ; EXTERNAL INTERRUPT TABLE\r
16018 \r
16019 EXTINT: REPEAT NINT-36.,0\r
16020         REPEAT 16.,HCHAR\r
16021         0\r
16022         0\r
16023         REPEAT 8.,HINF\r
16024         REPEAT NINT-62.,0\r
16025 EXTEND:\r
16026 \r
16027 IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.]\r
16028 [HRUNT,34.],[HPAR,28.]]\r
16029         IRP B,C,[A]\r
16030         LOC EXTINT+C\r
16031         B\r
16032         .ISTOP\r
16033         TERMIN\r
16034 TERMIN\r
16035 \r
16036 \r
16037 LOC EXTEND\r
16038 ]\r
16039 \f\r
16040 IFE ITS,[\r
16041 \r
16042 ; TABLES FOR TENEX INTERRUPT SYSTEM\r
16043 \r
16044 LEVTAB: P1              ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3\r
16045         P2\r
16046         P3\r
16047 \r
16048 CHNMSK==0                       ; WILL BE MASK WORD FOR INT SET UP\r
16049 MFORK==400000\r
16050 NNETS==10.              ; ALLOW 10 NETWRK INTERRUPTS\r
16051 NETCHN==36.-NNETS\r
16052 \r
16053 CHNTAB:                 ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS"\r
16054         BLOCK   36.-NNETS       ; THERE AR 36. TENEX INT CHANNELS\r
16055 \r
16056 REPEAT NNETS, 1,,INTNET+3*.RPCNT\r
16057 \r
16058 IRP A,,[[0,CNTLG],[1,CNTLS],[9.,TNXPDL]]\r
16059         IRP B,C,[A]\r
16060         LOC CHNTAB+B\r
16061         1,,C\r
16062         CHNMSK==CHNMSK+<1_<35.-B>>\r
16063         .ISTOP\r
16064         TERMIN\r
16065 TERMIN\r
16066 LOC CHNTAB+36.\r
16067 \r
16068 EXTINT: BLOCK NINT-NNETS\r
16069 \r
16070 REPEAT NNETS,HNET\r
16071 \r
16072 IRP A,,[[HCNTLG,36.],[HCNTLS,37.]]\r
16073         IRP B,C,[A]\r
16074         LOC EXTINT+C\r
16075         B\r
16076         .ISTOP\r
16077         TERMIN\r
16078 TERMIN\r
16079 LOC EXTINT+NINT\r
16080 ]\r
16081 \r
16082 \r
16083 ; HANDLER/HEADER PARAMETERS\r
16084 \r
16085 ; HEADER BLOCKS\r
16086 \r
16087 IHDRLN==4               ; LENGTH OF HEADER BLOCK\r
16088 \r
16089 INAME==0                ; NAME OF INTERRUPT\r
16090 ISTATE==2               ; CURRENT STATE\r
16091 IHNDLR==4               ; POINTS TO LIST OF HANDLERS\r
16092 INTPRI==6               ; CONTAINS PRIORITY OF INTERRUPT\r
16093 \r
16094 IHANDL==4               ; LENGTH OF A HANDLER BLOCK\r
16095 \r
16096 INXT==0                 ; POINTS TO NEXTIN CHAIN\r
16097 IPREV==2                ; POINTS TO PREV IN CHAIN\r
16098 INTFCN==4               ; FUNCTION ASSOCIATED WITH THIS HANDLER\r
16099 INTPRO==6               ; PROCESS TO RUN INT IN\r
16100 \r
16101 IFN ITS,[\r
16102 RMT [\r
16103 IMPURE\r
16104 TSINT:\r
16105 MTSINT: 0                       ;INTERRUPT BITS GET STORED HERE\r
16106 TSINTR: 0                       ;INTERRUPT PC WORD STORED HERE\r
16107         JRST    TSINTP          ;GO TO PURE CODE\r
16108 \r
16109 ; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE\r
16110 \r
16111 LCKINT: 0\r
16112         JRST    DOINT\r
16113 \r
16114 PURE\r
16115 ]\r
16116 ]\r
16117 IFE ITS,[\r
16118 RMT [\r
16119 ; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS\r
16120 \r
16121 LCKINT: 0\r
16122         JRST    DOINT\r
16123 ]\r
16124 ]\r
16125 \f\r
16126 \r
16127 IFN ITS,[\r
16128 \r
16129 ;THE REST OF THIS CODE IS PURE\r
16130 \r
16131 TSINTP: SOSGE   INTFLG          ; SKIP IF ENABLED\r
16132         SETOM   INTFLG          ;DONT GET LESS THAN -1\r
16133 \r
16134         MOVEM   A,TSAVA         ;SAVE TWO ACS\r
16135         MOVEM   B,TSAVB\r
16136         MOVE    A,TSINT         ;PICK UP INT BIT PATTERN\r
16137         JUMPL   A,2NDWORD       ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON\r
16138 \r
16139         TRZE    A,200000        ;IS THIS A PDL OVERFLOW?\r
16140         JRST    IPDLOV          ;YES, GO HANDLE IT FIRST\r
16141 \r
16142 IMPCH:  MOVEI   B,0\r
16143         TRNE    A,20000         ;IS IT A MEMORY PROTECTION VIOLATION?\r
16144         MOVEI   B,1             ; FLAG SAME\r
16145 \r
16146         TRNE    A,40            ;ILLEGAL OP CODE?\r
16147         MOVEI   B,2             ; ALSO FLAG\r
16148         TRNN    A,400           ; IOC?\r
16149         JRST    .+3\r
16150         SOS     TSINTR\r
16151         MOVEI   B,3\r
16152         TLNE    A,200           ; PURE?\r
16153         MOVEI   B,4\r
16154         SOJGE   B,DO.NOW                ; CANT WAIT AROUND\r
16155 \r
16156 ;DECODE THE REST OF THE INTERRUPTS USING A TABLE\r
16157 \r
16158 2NDWORD:\r
16159         JUMPL   A,GC2           ;2ND WORD?\r
16160         IORM    A,PIRQ          ;NO, INTO WORD 1\r
16161         JRST    GCQUIT          ;AND DISMISS INT\r
16162 \r
16163 GC2:    TLZ     A,400000        ;TURN OFF SIGN BIT\r
16164         IORM    A,PIRQ2\r
16165         TRNE    A,177777        ;CHECK FOR CHANNELS\r
16166         JRST    CHNACT          ;GO IF CHANNEL ACTIVITY\r
16167 ]\r
16168 GCQUIT: SKIPGE  INTFLG          ;SKIP IF INTERRUPTS ENABLED\r
16169         JRST    INTDON          ;NO, DEFER REAL HANDLING UNTIL LATER\r
16170 \r
16171         MOVE    A,TSINTR        ;PICKUP RETURN WORD\r
16172 IFE ITS,[\r
16173         TLON    A,10000         ; EXEC PC?\r
16174         SUBI    A,1             ; YES FIXUP PC\r
16175 ]\r
16176         MOVEM   A,LCKINT        ;STORE ELSEWHERE\r
16177         MOVEI   A,DOINTE        ;CAUSE DISMISS TO HANDLER\r
16178         HRRM    A,TSINTR        ;STORE IN INT RETURN\r
16179         PUSH    P,INTFLG        ;SAVE INT FLAG\r
16180         SETOM   INTFLG          ;AND DISABLE\r
16181 \r
16182 \r
16183 INTDON: MOVE    A,TSAVA         ;RESTORE ACS\r
16184         MOVE    B,TSAVB\r
16185 IFN ITS,        .DISMISS        TSINTR          ;AND DISMISS THE INTERRUPT\r
16186 IFE ITS,        DEBRK\r
16187 \r
16188 \r
16189 DO.NOW: SKIPE   GCFLG\r
16190         JRST    DLOSER          ; HANDLE FATAL GC ERRORS\r
16191         MOVSI   B,1\r
16192         SKIPGE  INTFLG          ; IF NOT ENABLED\r
16193         MOVEM   B,INTFLG        ; PRETEND IT IS\r
16194         JRST    2NDWORD\r
16195 \r
16196 IFE ITS,[\r
16197 \r
16198 ; HERE FOR TENEX PDL OVER FLOW INTERRUPT\r
16199 \r
16200 TNXPDL: SOSGE   INTFLG\r
16201         SETOM   INTFLG\r
16202         MOVEM   A,TSAVA\r
16203         MOVEM   B,TSAVB\r
16204         JRST    IPDLOV          ; GO TO COMMON HANDLER\r
16205 \r
16206 ; HERE FOR TENEX ^G AND ^S INTERRUPTS\r
16207 \r
16208 CNTLG:  MOVEM   A,TSAVA\r
16209         MOVEI   A,1\r
16210         JRST    CNTSG\r
16211 \r
16212 CNTLS:  MOVEM   A,TSAVA\r
16213         MOVEI   A,2\r
16214 \r
16215 CNTSG:  MOVEM   B,TSAVB\r
16216         IORM    A,PIRQ2         ; SAY FOR MUDDLE LEVEL\r
16217         SOSGE   INTFLG\r
16218         SETOM   INTFLG\r
16219         JRST    GCQUIT\r
16220 INTNET:\r
16221 REPEAT NNETS,[\r
16222         MOVEM   A,TSAVA\r
16223         MOVE    A,[1_<.RPCNT+NETCHN>]\r
16224         JRST    CNTSG\r
16225 ]\r
16226 ]\r
16227 \f\r
16228 ; HERE TO PROCESS INTERRUPTS\r
16229 \r
16230 DOINT:  SKIPE   INTHLD          ; GLOBAL LOCK ON INTS\r
16231         JRST    @LCKINT\r
16232         SETOM   INTHLD          ; DONT LET IT HAPPEN AGAIN\r
16233         PUSH    P,INTFLG\r
16234 DOINTE: SKIPE   ONINT           ; ANY FUDGE?\r
16235         XCT     ONINT           ; YEAH, TRY ONE\r
16236         EXCH    0,LCKINT        ; RELATIVIZE PC IF FROM RSUBR\r
16237         PUSH    P,0             ; AND SAVE\r
16238         ANDI    0,-1\r
16239         CAMG    0,PURTOP\r
16240         CAMGE   0,VECBOT\r
16241         JRST    DONREL\r
16242         SUBI    0,(M)           ; M IS BASE REG\r
16243         HLL     0,(P)           ; GET FLAGS\r
16244         TLO     0,M             ; INDEX IT OFF M\r
16245         EXCH    0,(P)           ; AND RESTORE TO STACK\r
16246 DONREL: EXCH    0,LCKINT        ; GET BACK SAVED 0\r
16247         SETZM   INTFLG          ;DISABLE\r
16248         AOS     -1(P)           ;INCR SAVED FLAG\r
16249 \r
16250 ;NOW SAVE WORKING ACS\r
16251 \r
16252         PUSHJ   P,SAVACS\r
16253         HLRZ    A,-1(P)         ; HACK FUNNYNESS FOR MPV/ILOPR\r
16254         SKIPE   A\r
16255         SETZM   -1(P)           ; REALLY DISABLED\r
16256 \r
16257 DIRQ:   MOVE    A,PIRQ          ;NOW SATRT PROCESSING\r
16258         JFFO    A,FIRQ          ;COUNT BITS AND GO\r
16259         MOVE    A,PIRQ2         ;1ST DONE, LOOK AT 2ND\r
16260         JFFO    A,FIRQ2\r
16261 \r
16262 INTDN1: SKIPN   GCHAPN          ; SKIP IF MUST DO GC INT\r
16263         JRST    .+3\r
16264         SETZM   GCHAPN\r
16265         PUSHJ   P,INTOGC        ; AND INTERRUPT\r
16266 \r
16267         PUSHJ   P,RESTAC\r
16268 \r
16269 IFN ITS,[\r
16270         .SUSET  [.SPICLR,,[0]]  ; DISABLE INTS\r
16271 ]\r
16272         POP     P,LCKINT\r
16273         POP     P,INTFLG\r
16274         SETZM   INTHLD          ; RE-ENABLE THE WORLD\r
16275 IFN ITS,[\r
16276         EXCH    0,LCKINT\r
16277         HRRI    0,@0            ; EFFECTIVIZE THE ADDRESS\r
16278         TLZ     0,37            ; KILL IND AND INDEX\r
16279         EXCH    0,LCKINT\r
16280         .DISMIS LCKINT\r
16281 ]\r
16282 IFE ITS,        JRST    @LCKINT\r
16283 FIRQ:   PUSHJ   P,GETBIT        ;SET UP THE BIT TO CLOBBER IN PIRQ\r
16284         ANDCAM  A,PIRQ          ;CLOBBER IT\r
16285         ADDI    B,36.           ;OFSET INTO TABLE\r
16286         JRST    XIRQ            ;GO EXECUTE\r
16287 \r
16288 FIRQ2:  PUSHJ   P,GETBIT        ;PREPARE TO CLOBBER BIT\r
16289         ANDCAM  A,PIRQ2         ;CLOBBER IT\r
16290         ADDI    B,71.           ;AGAIN OFFSET INTO TABLE\r
16291 XIRQ:\r
16292         CAIE    B,21            ;PDL OVERFLOW?\r
16293         JRST    FHAND           ;YES, HACK APPROPRIATELY\r
16294 \r
16295 PDL2:   SKIPN   A,PGROW\r
16296         SKIPE   A,TPGROW\r
16297         JRST    .+2\r
16298         JRST    DIRQ            ; NOTHING GROWING, FALSE ALARM\r
16299         MOVEI   B,PDLGRO_-6     ;GET GROWTH SPEC\r
16300         DPB     B,[111100,,-1(A)]       ;STORE GROWTH SPEC\r
16301 REAGC:  MOVE    C,[10.,,1]      ; INDICATOR FOR AGC\r
16302         SKIPE   PGROW           ; P IS GROWING\r
16303         ADDI    C,6\r
16304         SKIPE   TPGROW          ; TP IS GROWING\r
16305         ADDI    C,1\r
16306         PUSHJ   P,AGC           ;COLLECT GARBAGE\r
16307         SETZM   PGROW\r
16308         SETZM   TPGROW\r
16309         AOJL    A,REAGC         ; IF NO CORE, RETRY\r
16310         JRST    DIRQ\r
16311 \r
16312 SAVACS:\r
16313 IRP A,,[0,A,B,C,D,E]\r
16314         PUSH    TP,A!STO(PVP)\r
16315         SETZM   A!STO(PVP)      ;NOW ZERO TYPE\r
16316         PUSH    TP,A\r
16317         TERMIN\r
16318         POPJ    P,\r
16319 \r
16320 RESTAC:\r
16321 IRP A,,[E,D,C,B,A,0]\r
16322         POP     TP,A\r
16323         POP     TP,A!STO(PVP)\r
16324         TERMIN\r
16325         POPJ    P,\r
16326 \r
16327 ; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS\r
16328 \r
16329 INTOGC: PUSH    P,[N.CHNS-1]\r
16330         MOVE    A,TVP\r
16331         ADD     A,[CHNL1,,CHNL1]\r
16332         PUSH    TP,$TVEC\r
16333         PUSH    TP,A\r
16334 \r
16335 INTGC1: MOVE    A,(TP)          ; GET POINTER\r
16336         SKIPN   B,1(A)          ; ANY CHANNEL?\r
16337         JRST    INTGC2\r
16338         HRRE    0,(A)           ; INDICATOR\r
16339         JUMPGE  0,INTGC2\r
16340         PUSH    TP,$TCHAN\r
16341         PUSH    TP,B\r
16342         MCALL   1,FCLOSE\r
16343 \r
16344         MOVE    A,(TP)\r
16345 \r
16346 INTGC2: HLLZS   (A)\r
16347         ADD     A,[2,,2]\r
16348         MOVEM   A,(TP)\r
16349         SOSE    (P)\r
16350         JRST    INTGC1\r
16351 \r
16352         SUB     P,[1,,1]\r
16353         SUB     TP,[2,,2]\r
16354         PUSH    TP,$TCHSTR\r
16355         PUSH    TP,CHQUOTE GC\r
16356         PUSH    TP,$TFLOAT      ; PUSH  ON TIME ARGUMENT\r
16357         PUSH    TP,GCTIM\r
16358         PUSH    TP,$TFIX        ; PUSH ON THE CAUSE ARGUMENT\r
16359         PUSH    TP,GCCAUS\r
16360         PUSH    TP,$TATOM       ; PUSH ON THE CALL ARGUMENT\r
16361         MOVE    A,GCCALL\r
16362         PUSH    TP,@GCALLR(A)\r
16363         MCALL   4,INTERR\r
16364         POPJ    P,\r
16365 \r
16366 \r
16367 GCALLR: 0\r
16368         MQUOTE BLOAT\r
16369         MQUOTE GROW\r
16370         MQUOTE LIST\r
16371         MQUOTE VECTOR\r
16372         MQUOTE SET\r
16373         MQUOTE  SETG\r
16374         MQUOTE FREEZE\r
16375         MQUOTE PURE-PAGE-LOADER\r
16376         MQUOTE GC\r
16377         MQUOTE INTERRUPT-HANDLER\r
16378         MQUOTE NEWTYPE\r
16379 \r
16380 \f; OLD "ON"  SETS UP EVENT AND HANDLER\r
16381 \r
16382 MFUNCTION ON,SUBR\r
16383 \r
16384         ENTRY\r
16385 \r
16386         HLRE    0,AB            ; 0=> -2*NUM OF ARGS\r
16387         ASH     0,-1            ; TO -NUM\r
16388         CAME    0,[-5]\r
16389         JRST    .+3\r
16390         MOVEI   B,10(AB)        ; LAST MUST BE CHAN OR LOC\r
16391         PUSHJ   P,CHNORL\r
16392         ADDI    0,3\r
16393         JUMPG   0,TFA           ; AT LEAST 3\r
16394         MOVEI   A,0             ; SET UP IN CASE NO PROC\r
16395         AOJG    0,ONPROC        ; JUMP IF NONE\r
16396         GETYP   C,6(AB)         ; CHECK IT\r
16397         CAIE    C,TPVP\r
16398         JRST    TRYFIX\r
16399         MOVE    A,7(AB)         ; GET IT\r
16400 ONPROC: PUSH    P,A             ; SAVE AS A FLAG\r
16401         GETYP   A,(AB)          ; CHECK PREV EXISTANCE\r
16402         PUSH    P,0\r
16403         CAIN    A,TATOM\r
16404         JRST    .+3\r
16405         CAIE    A,TCHSTR\r
16406         JRST    WTYP1\r
16407         MOVEI   B,(AB)          ; FIND IT\r
16408         PUSHJ   P,FNDINT\r
16409         POP     P,0             ; REST NUM OF ARGS\r
16410         JUMPN   B,ON3           ; ALREADY THERE\r
16411         SKIPE   C               ; SKIP IF NOTHING TO FLUSH\r
16412         SUB     TP,[2,,2]\r
16413         PUSH    TP,(AB)         ; GET NAME\r
16414         PUSH    TP,1(AB)\r
16415         PUSH    TP,4(AB)\r
16416         PUSH    TP,5(AB)\r
16417         MOVEI   A,2             ; # OF ARGS TO EVENT\r
16418         AOJG    0,ON1           ; JUMP IF NO LAST ARG\r
16419         PUSH    TP,10(AB)\r
16420         PUSH    TP,11(AB)\r
16421         ADDI    A,1\r
16422 ON1:    ACALL   A,EVENT\r
16423 \r
16424 ON3:    PUSH    TP,A\r
16425         PUSH    TP,B\r
16426         PUSH    TP,2(AB)        ; NOW FCN\r
16427         PUSH    TP,3(AB)\r
16428         MOVEI   A,3             ; NUM OF ARGS\r
16429         SKIPN   (P)\r
16430         SOJA    A,ON2           ; NO PROC\r
16431         PUSH    TP,$TPVP\r
16432         PUSH    TP,7(AB)\r
16433 ON2:    ACALL   A,HANDLER\r
16434         JRST    FINIS\r
16435 \r
16436 \r
16437 TRYFIX: SKIPN   A,7(AB)\r
16438         CAIE    C,TFIX\r
16439         JRST    WRONGT\r
16440         JRST    ONPROC\r
16441 \f\r
16442 ; ROUTINE TO BUILD AN EVENT\r
16443 \r
16444 MFUNCTION EVENT,SUBR\r
16445 \r
16446         ENTRY\r
16447 \r
16448         HLRZ    0,AB\r
16449         CAIN    0,-2            ; IF JUST 1\r
16450         JRST    RE.EVN          ; COULD BE EVENT\r
16451         CAIL    0,-3            ; MUST BE AT LEAST 2 ARGS\r
16452         JRST    TFA\r
16453         GETYP   A,2(AB)         ; 2ND ARG MUST BE FIXED POINT PRIORITY\r
16454         CAIE    A,TFIX\r
16455         JRST    WTYP2\r
16456         GETYP   A,(AB)          ; FIRST ARG SHOULD BE CHSTR\r
16457         CAIN    A,TATOM         ; ALLOW ACTUAL ATOM\r
16458         JRST    .+3\r
16459         CAIE    A,TCHSTR\r
16460         JRST    WTYP1\r
16461         CAIL    0,-5\r
16462         JRST    GOTRGS\r
16463         CAIG    0,-7\r
16464         JRST    TMA\r
16465         MOVEI   B,4(AB)\r
16466         PUSHJ   P,CHNORL        ; CHANNEL OR LOCATIVE (PUT ON STACK)\r
16467 \r
16468 GOTRGS: MOVEI   B,(AB)          ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT\r
16469         PUSHJ   P,FNDINT        ; CALL INTERNAL HACKER\r
16470         JUMPN   B,FINIS         ; ALREADY ONE OF THIS NAME\r
16471         PUSH    P,C\r
16472         JUMPE   C,.+3           ; GET IT OFF STACK\r
16473         POP     TP,B\r
16474         POP     TP,A\r
16475         PUSHJ   P,MAKINT        ; MAKE ONE FOR ME\r
16476         MOVSI   0,TFIX\r
16477         MOVEM   0,INTPRI(B)     ; SET UP PRIORITY\r
16478         MOVE    0,3(AB)\r
16479         MOVEM   0,INTPRI+1(B)\r
16480 CH.SPC: POP     P,C             ; GET CODE BACK\r
16481         SKIPGE  C\r
16482         PUSHJ   P,DO.SPC        ; DO ANY SPECIAL HACKS\r
16483         JRST    FINIS\r
16484 \r
16485 RE.EVN: GETYP   0,(AB)\r
16486         CAIE    0,TINTH\r
16487         JRST    TFA             ; ELSE SAY NOT ENOUGH\r
16488         MOVE    B,1(AB)         ; GET IT\r
16489         SETZM   ISTATE+1(B)     ; MAKE SURE ENABLED\r
16490         SETZB   D,C\r
16491         GETYP   A,INAME(B)      ; CHECK FOR CHANNEL\r
16492         CAIN    A,TCHAN         ; SKIP IF NOT\r
16493         HRROI   C,SS.CHA        ; SET UP CHANNEL HACK\r
16494         HRLZ    E,INTPRI(B)     ; GET POSSIBLE READ/WRITE BITS\r
16495         TLNE    E,.WRMON+.RDMON ; SKIP IF NOT MONITORS\r
16496         PUSHJ   P,GETNM1\r
16497         JUMPL   C,RE.EV1\r
16498         MOVE    B,INAME+1(B)    ; CHECK FOR SPEC\r
16499         PUSHJ   P,SPEC1\r
16500         MOVE    B,1(AB)         ; RESTORE IHEADER\r
16501 RE.EV1: PUSH    TP,INAME(B)\r
16502         PUSH    TP,INAME+1(B)\r
16503         PUSH    P,C\r
16504         MOVSI   C,TATOM\r
16505         PUSH    TP,$TATOM\r
16506         SKIPN   D\r
16507         MOVE    D,MQUOTE INTERRUPT\r
16508         PUSH    TP,D\r
16509         MOVE    A,INAME(B)\r
16510         MOVE    B,INAME+1(B)    ; GET IT\r
16511         PUSHJ   P,IGET          ; LOOK FOR IT\r
16512         JUMPN   B,FINIS         ; RETURN IT\r
16513         MOVE    A,(TB)\r
16514         MOVE    B,1(TB)\r
16515         POP     TP,D\r
16516         POP     TP,C\r
16517         PUSH    TP,(AB)\r
16518         PUSH    TP,1(AB)\r
16519         PUSHJ   P,IPUT          ; REESTABLISH IT\r
16520         MOVE    A,(AB)\r
16521         MOVE    B,1(AB)\r
16522         JRST    CH.SPC\r
16523 \r
16524 \f\r
16525 ; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT\r
16526 \r
16527 MFUNCTION HANDLER,SUBR\r
16528 \r
16529         ENTRY\r
16530 \r
16531         HLRZ    0,AB\r
16532         CAIL    0,-2            ; MUST BE 2 OR MORE ARGS\r
16533         JRST    TFA\r
16534         GETYP   A,(AB)\r
16535         CAIE    A,TINTH         ; EVENT?\r
16536         JRST    WTYP1\r
16537         GETYP   A,2(AB)\r
16538         CAIN    0,-4            ; IF EXACTLY 2\r
16539         CAIE    A,THAND         ; COULD BE HANDLER\r
16540         JRST    CHEVNT\r
16541 \r
16542         MOVE    B,3(AB)         ; GET IT\r
16543         SKIPN   IPREV+1(B)      ; SKIP IF ALREADY IN USE\r
16544         JRST    HNDOK\r
16545         MOVE    D,1(AB)         ; GET EVENT\r
16546         SKIPN   D,IHNDLR+1(D)   ; GET FIRST HANDLER\r
16547         JRST    BADHND\r
16548         CAMN    D,B             ; IS THIS IT?\r
16549         JRST    HFINIS          ; YES, ALREADY "HANDLED"\r
16550         MOVE    D,INXT+1(D)     ; GO TO NEXT HANDLER\r
16551         JUMPN   D,.-3\r
16552 BADHND: PUSH    TP,$TATOM\r
16553         PUSH    TP,EQUOTE HANDLER-ALREADY-IN-USE\r
16554         JRST    CALER1\r
16555 \r
16556 CHEVNT: CAIG    0,-7            ; SKIP IF LESS THAN 4\r
16557         JRST    TMA\r
16558         PUSH    TP,$TPVP                ; SLOT FOR PROCESS\r
16559         PUSH    TP,[0]\r
16560         CAIE    0,-6            ; IF 3, LOOK FOR PROC\r
16561         JRST    NOPROC\r
16562         GETYP   0,4(AB)\r
16563         CAIE    0,TPVP\r
16564         JRST    WTYP3\r
16565         MOVE    0,5(AB)\r
16566         MOVEM   0,(TP)\r
16567 \r
16568 NOPROC: PUSHJ   P,APLQ\r
16569         JRST    NAPT\r
16570         PUSHJ   P,MHAND         ; MAKE THE HANDLER\r
16571         MOVE    0,1(TB)         ; GET PROCESS\r
16572         MOVEM   0,INTPRO+1(B)   ; AND PUT IT INTO HANDLER\r
16573         MOVSI   0,TPVP          ; SET UP TYPE\r
16574         MOVEM   0,INTPRO(B)\r
16575         MOVE    0,2(AB)         ; SET UP FUNCTION\r
16576         MOVEM   0,INTFCN(B)\r
16577         MOVE    0,3(AB)\r
16578         MOVEM   0,INTFCN+1(B)\r
16579 \r
16580 HNDOK:  MOVE    D,1(AB)         ; PICK UP EVEENT\r
16581         MOVE    E,IHNDLR+1(D)   ; GET POINTER TO HANDLERS\r
16582         MOVEM   B,IHNDLR+1(D)   ; PUT NEW ONE IN\r
16583         MOVSI   0,TINTH         ; GET INT HDR TYPE\r
16584         MOVEM   0,IPREV(B)      ; INTO BACK POINTER\r
16585         MOVEM   D,IPREV+1(B)    ; AND POINTER ITSELF\r
16586         MOVEM   E,INXT+1(B)     ; NOW NEXT POINTER\r
16587         MOVSI   0,THAND         ; NOW HANDLER TYPE\r
16588         MOVEM   0,IHNDLR(D)     ; SET TYPE IN HEADER\r
16589         MOVEM   0,INXT(B)\r
16590         JUMPE   E,HFINIS        ; JUMP IF HEADER WAS EMPTY\r
16591         MOVEM   0,IPREV(E)      ; FIX UP ITS PREV\r
16592         MOVEM   B,IPREV+1(E)\r
16593 HFINIS: MOVSI   A,THAND\r
16594         JRST    FINIS\r
16595 \r
16596 \f\r
16597 \r
16598 ; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS\r
16599 \r
16600 MFUNCTION RUNTIMER,SUBR\r
16601 \r
16602         ENTRY   1\r
16603 \r
16604         GETYP   0,(AB)\r
16605         JFCL    10,.+1\r
16606         MOVE    A,1(AB)\r
16607         CAIE    0,TFIX\r
16608         JRST    RUNT1\r
16609         IMUL    A,[245761.]\r
16610         JRST    RUNT2\r
16611 \r
16612 RUNT1:  CAIE    0,TFLOAT\r
16613         JRST    WTYP1\r
16614         FMPR    A,[245760.62]\r
16615         MULI    A,400           ; FIX IT\r
16616         TSC     A,A\r
16617         ASH     B,(A)-243\r
16618         MOVE    A,B\r
16619 RUNT2:  JUMPL   A,OUTRNG        ; NOT FOR NEG #\r
16620         JFCL    10,OUTRNG\r
16621         .SUSET  [.SRTMR,,A]\r
16622         MOVE    A,(AB)\r
16623         MOVE    B,1(AB)\r
16624         JRST    FINIS\r
16625 \r
16626 MFUNCTION REALTIMER,SUBR\r
16627 \r
16628         ENTRY   1\r
16629 \r
16630         JFCL    10,.+1\r
16631         GETYP   0,(AB)\r
16632         MOVE    A,1(AB)\r
16633         CAIE    0,TFIX\r
16634         JRST    REALT1\r
16635         IMULI   A,60.   ; TO 60THS OF SEC\r
16636         JRST    REALT2\r
16637 \r
16638 REALT1: CAIE    0,TFLOAT\r
16639         JRST    WTYP1\r
16640         FMPRI   A,(60.0)\r
16641         MULI    A,400\r
16642         TSC     A,A\r
16643         ASH     B,(A)-243\r
16644         MOVE    A,B\r
16645 \r
16646 REALT2: JUMPL   A,OUTRNG\r
16647         JFCL    10,OUTRNG\r
16648         MOVE    B,[200000,,A]\r
16649         .REALT  B,\r
16650         JFCL\r
16651         MOVE    A,(AB)\r
16652         MOVE    B,1(AB)\r
16653         JRST    FINIS\r
16654 \r
16655 ; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS\r
16656 \r
16657 MFUNCTION %ENABL,SUBR,ENABLE\r
16658 \r
16659         PUSHJ   P,GTEVNT\r
16660         SETZM   ISTATE+1(B)\r
16661         JRST    FINIS\r
16662 \r
16663 MFUNCTION %DISABL,SUBR,DISABLE\r
16664 \r
16665 \r
16666         PUSHJ   P,GTEVNT\r
16667         SETOM   ISTATE+1(B)\r
16668         JRST    FINIS\r
16669 \r
16670 GTEVNT: ENTRY   1\r
16671         GETYP   0,(AB)\r
16672         CAIE    0,TINTH\r
16673         JRST    WTYP1\r
16674         MOVE    A,(AB)\r
16675         MOVE    B,1(AB)\r
16676         POPJ    P,\r
16677 \r
16678 DO.SPC: HRRZ    C,INTBL(C)      ; POINT TO SPECIAL CODE\r
16679         HLRZ    0,AB            ; - TWO TIMES NUM ARGS\r
16680         PUSHJ   P,(C)           ; CALL ROUTINE\r
16681         JUMPE   E,CPOPJ         ; NO BITS TO ENABLE, LEAVE\r
16682 IFE ITS,[\r
16683         PUSH    TP,A\r
16684         PUSH    TP,B\r
16685         MOVE    B,1(TB)         ; CHANNEL\r
16686         MOVE    0,CHANNO(B)\r
16687         MOVEM   0,(E)           ; SAVE IN TABLE\r
16688         MOVEI   E,(E)\r
16689         SUBI    E,NETJFN-NETCHN\r
16690         MOVE    A,0             ; SETUP FOR MTOPR\r
16691         MOVEI   B,24\r
16692         MOVSI   C,(E)\r
16693         TLO     C,770000        ; DONT SETUP INR/INS\r
16694         MTOPR\r
16695         MOVEI   0,1\r
16696         MOVNS   E\r
16697         LSH     0,35.(E)\r
16698         IORM    0,MASK1\r
16699         MOVE    B,MASK1\r
16700         MOVEI   A,MFORK\r
16701         AIC\r
16702         \r
16703         POP     TP,B\r
16704         POP     TP,A\r
16705         POPJ    P,              ; ***** TEMP ******\r
16706 ]\r
16707 IFN ITS,[\r
16708         CAILE   E,35.           ; SKIP IF 1ST WORD BIT\r
16709         JRST    SETW2\r
16710         LSH     0,-1(E)\r
16711 \r
16712         IORM    0,MASK1         ; STORE IN PROTOTYPE MASK\r
16713         .SUSET  [.SMASK,,MASK1]\r
16714         POPJ    P,\r
16715 \r
16716 SETW2:  LSH     0,-36.(E)\r
16717         IORM    0,MASK2         ; SET UP PROTO MASK2\r
16718         .SUSET  [.SMSK2,,MASK2]\r
16719         POPJ    P,\r
16720 ]\r
16721 \r
16722 ; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE\r
16723 \r
16724 CHNORL: GETYP   A,(B)           ; GET TYPE\r
16725         CAIN    A,TCHAN         ; IF CHANNEL\r
16726         JRST    CHNWIN\r
16727         PUSH    P,0\r
16728         PUSHJ   P,LOCQ          ; ELSE LOOCATIVE\r
16729         JRST    WRONGT\r
16730         POP     P,0\r
16731 CHNWIN: PUSH    TP,(B)\r
16732         PUSH    TP,1(B)\r
16733         POPJ    P,\r
16734 \f\r
16735 ; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME\r
16736 \r
16737 FNDINT: PUSHJ   P,FNDNM\r
16738         JUMPE   B,CPOPJ\r
16739         PUSHJ   P,SPEC1         ; COULD BE FUNNY\r
16740 \r
16741 INTASO: PUSH    P,C             ; C<0 IF SPECIAL\r
16742         PUSH    TP,A\r
16743         PUSH    TP,B\r
16744         MOVSI   C,TATOM\r
16745         SKIPN   D               ; COULD BE CHANGED FOR MONITOR\r
16746         MOVE    D,MQUOTE INTERRUPT\r
16747         PUSH    TP,C\r
16748         PUSH    TP,D\r
16749         PUSHJ   P,IGET\r
16750         MOVE    D,(TP)\r
16751         SUB     TP,[2,,2]\r
16752         POP     P,C             ; AND RESTOR SPECIAL INDICATOR\r
16753         SKIPE   B               ; IF FOUND\r
16754         SUB     TP,[2,,2]       ; REMOVE CRUFT\r
16755 CPOPJ:  POPJ    P,              ; AND RETURN\r
16756 \r
16757 ; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK\r
16758 \r
16759 SPEC1:  MOVSI   C,-SPECLN       ; BUILD AOBJN PNTR\r
16760 SPCLOP: CAME    B,@SPECIN(C)    ; SKIP IF SPECIAL\r
16761         AOBJN   C,.-1           ; UNTIL EXHAUSTED\r
16762         JUMPGE  C,.+3\r
16763         SKIPE   E,FNDTBL(C)\r
16764         JRST    (E)\r
16765         MOVEI   0,-1(TB)        ; SEE IF OK\r
16766         CAIE    0,(TP)\r
16767         JRST    TMA\r
16768         POPJ    P,\r
16769 \r
16770 ; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR)\r
16771 \r
16772 MAKINT: JUMPN   C,GOTATM        ; ALREADY HAVE NAME, GET THING\r
16773         MOVEI   B,(AB)          ; POINT TO STRING\r
16774         PUSHJ   P,CSTAK         ; CHARS TO STAKC\r
16775         MOVE    B,INTOBL+1(TVP)\r
16776         PUSHJ   P,INSRTX\r
16777         MOVE    D,MQUOTE INTERRUPT\r
16778 GOTATM: PUSH    TP,$TINTH       ; MAKE SLOT FOR HEADER BLOCK\r
16779         PUSH    TP,[0]\r
16780         PUSH    TP,A\r
16781         PUSH    TP,B            ; SAVE ATOM\r
16782         PUSH    TP,$TATOM\r
16783         PUSH    TP,D\r
16784         MOVEI   A,IHDRLN*2\r
16785         PUSHJ   P,GIBLOK\r
16786         MOVE    A,-3(TP)                ; GET NAME AND STORE SAME\r
16787         MOVEM   A,INAME(B)\r
16788         MOVE    A,-2(TP)\r
16789         MOVEM   A,INAME+1(B)\r
16790         SETZM   ISTATE+1(B)\r
16791         MOVEM   B,-4(TP)        ; STASH HEADER\r
16792         POP     TP,D\r
16793         POP     TP,C\r
16794         EXCH    B,(TP)\r
16795         MOVSI   A,TINTH\r
16796         EXCH    A,-1(TP)        ; INTERNAL PUT CALL\r
16797         PUSHJ   P,IPUT\r
16798         POP     TP,B\r
16799         POP     TP,A\r
16800         POPJ    P,\r
16801 \r
16802 ; FIND NAME OF INTERRUPT\r
16803 \r
16804 FNDNM:  GETYP   A,(B)           ; TYPE\r
16805         CAIE    A,TCHSTR        ; IF STRING\r
16806         JRST    FNDATM          ; DONT HAVE ATOM, OTHERWISE DO\r
16807         PUSHJ   P,IILOOK\r
16808         JRST    .+2\r
16809 FNDATM: MOVE    B,1(B)\r
16810         SETZB   C,D             ; PREVENT LOSSAGE LATER\r
16811         MOVSI   A,TATOM\r
16812 \r
16813 ; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM\r
16814 \r
16815         CAMN    B,IMQUOTE ERROR\r
16816         MOVE    B,MQUOTE ERROR,ERROR,INTRUP\r
16817         POPJ    P,\r
16818 \r
16819 IILOOK: PUSHJ   P,CSTAK         ; PUT CHRS ON STACK\r
16820         MOVE    B,INTOBL+1(TVP)\r
16821         JRST    ILOOKC  ; LOOK IT UP\r
16822 \f\r
16823 ; ROUTINE TO MAKE A HANDLER BLOCK\r
16824 \r
16825 MHAND:  MOVEI   A,IHANDL*2\r
16826         JRST    GIBLOK          ; GET BLOCK\r
16827 \r
16828 ; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT\r
16829 \r
16830 GETCHN: GETYP   0,(TB)          ; GET TYPE\r
16831         CAIE    0,TCHAN         ; CHANNL IS WINNER\r
16832         JRST    WRONGT\r
16833         MOVE    A,(TB)          ; USE THE CHANNEL TO NAME THE INTERRUPT\r
16834         MOVE    B,1(TB)\r
16835         SKIPN   CHANNO(B)       ; SKIP IF WINNING CHANNEL\r
16836         JRST    CBDCHN          ; LOSER\r
16837         POPJ    P,\r
16838 \r
16839 LOCGET: GETYP   0,(TB)          ; TYPE\r
16840         CAIN    0,TCHAN         ; SKIP IF LOCATIVE\r
16841         JRST    WRONGT\r
16842         MOVE    D,B\r
16843         MOVE    A,(TB)\r
16844         MOVE    B,1(TB)         ; GET LOCATIVE\r
16845         POPJ    P,\r
16846 \r
16847 ; FINAL MONITOR SETUP ROUTINES\r
16848 \r
16849 S.RMON: SKIPA   E,[.RDMON,,]\r
16850 S.WMON: MOVSI   E,.WRMON\r
16851         PUSH    TP,A\r
16852         PUSH    TP,B\r
16853         HLRM    E,INTPRI(B)     ; SAVE BITS\r
16854         MOVEI   B,(TB)          ; POINT TO LOCATIVE\r
16855         HRRZ    A,FSAV(TB)\r
16856         CAIN    A,OFF\r
16857         MOVSI   D,(ANDCAM E,)   ; KILL INST\r
16858         CAIN    A,EVENT\r
16859         MOVSI   D,(IORM E,)\r
16860         PUSHJ   P,SMON          ; GO DO IT\r
16861         POP     TP,B\r
16862         POP     TP,A\r
16863         MOVEI   E,0\r
16864         POPJ    P,\r
16865 \f\r
16866 \r
16867 ; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS\r
16868 \r
16869 IFN ITS,[\r
16870 S.CHAR: MOVE    E,1(TB)         ; GET CHANNEL\r
16871         MOVE    E,CHANNO(E)\r
16872         ADDI    E,36.           ; GET CORRECT MASK BIT\r
16873 ONEBIT: MOVEI   0,1             ; BIT FOR INT TO RET\r
16874         POPJ    P,\r
16875 ]\r
16876 IFE ITS,[\r
16877 S.CHAR: MOVE    E,1(TB)\r
16878         MOVE    0,RDEVIC(E)\r
16879         ILDB    0,0             ; 1ST CHAR\r
16880         PUSH    P,A\r
16881         CAIE    0,"N            ; NET ?\r
16882         JRST    S.CHA1\r
16883 \r
16884         MOVEI   A,0\r
16885         HRRZ    0,CHANNO(E)\r
16886         MOVE    E,[-NNETS,,NETJFN]\r
16887         CAMN    0,(E)\r
16888         JRST    S.CHA2\r
16889         SKIPN   (E)\r
16890         MOVE    A,E             ; REMEMBER WHERE\r
16891         AOBJN   E,.-5\r
16892         TLNN    A,-1    \r
16893         FATAL   NO MORE NETWORK\r
16894         MOVE    E,A\r
16895 S.CHA1: MOVEI   E,0\r
16896 S.CHA2: POP     P,A\r
16897         POPJ    P,\r
16898 ]\r
16899 \r
16900 \r
16901 ; SPECIAL FOR CLOCK\r
16902 \r
16903 S.DOWN: SKIPA   E,[7]\r
16904 S.CLOK: MOVEI   E,13.           ; FOR NOW JUST GET BIT #\r
16905         JRST    ONEBIT\r
16906 \r
16907 S.PAR:  MOVEI   E,28.\r
16908         JRST    ONEBIT\r
16909 \r
16910 ; RUNTIME AND REALTIME INTERRUPTS\r
16911 \r
16912 S.RUNT: SKIPA   E,[34.]\r
16913 S.REAL: MOVEI   E,35.\r
16914         JRST    ONEBIT\r
16915 \r
16916 S.IOC:  SKIPA   E,[9.]          ; IO CHANNEL ERROR\r
16917 S.PURE: MOVEI   E,26.\r
16918         JRST    ONEBIT\r
16919 \r
16920 ; MPV AND ILOPR\r
16921 \r
16922 S.MPV:  SKIPA   E,[14.]         ; BIT POS\r
16923 S.ILOP: MOVEI   E,6\r
16924         JRST    ONEBIT\r
16925 \r
16926 ; HERE TO TURN ALL INFERIOR INTS\r
16927 \r
16928 S.INF:  MOVEI   E,36.+16.+2     ; START OF BITS\r
16929         MOVEI   0,37            ; 8 BITS WORTH\r
16930         POPJ    P,\r
16931 \f\r
16932 \r
16933 ; HERE TO HANDLE ITS INTERRUPTS\r
16934 \r
16935 FHAND:  SKIPN   D,EXTINT(B)     ; SKIP IF HANDLERS ARE POSSIBLE\r
16936         JRST    DIRQ\r
16937         JRST    (D)\r
16938 \r
16939 IFN ITS,[\r
16940 ; SPECIAL CHARACTER HANDLERS\r
16941 \r
16942 HCHAR:  MOVEI   D,CHNL0+1(TVP)\r
16943         ADDI    D,(B)           ; POINT TO CHANNEL SLOT\r
16944         ADDI    D,(B)\r
16945         SKIPN   D,-72.(D)       ; PICK UP CHANNEL\r
16946         JRST    IPCGOT          ;WELL, IT GOTTA BEE THE THE IPC THEN\r
16947         PUSH    TP,$TCHAN\r
16948         PUSH    TP,D\r
16949         LDB     0,[600,,STATUS(D)]      ; GET DEVICE CODE\r
16950         CAILE   0,2             ; SKIP IF A TTY\r
16951         JRST    HNET            ; MAYBE NETWORK CHANNEL\r
16952         CAMN    D,TTICHN+1(TVP)\r
16953         SKIPN   NOTTY\r
16954         JRST    HCHR11\r
16955         MOVE    B,D             ; CHAN TO B\r
16956         PUSHJ   P,TTYOP2        ; RE-GOBBLE TTY\r
16957         MOVE    D,(TP)\r
16958 HCHR11: MOVE    D,CHANNO(D)     ; GET ITS CHANNEL\r
16959         PUSH    P,D             ; AND SAVE IT\r
16960         .CALL   HOWMNY          ; GET # OF CHARS\r
16961         MOVEI   B,0             ; IF TTY GONE, NO CHARS\r
16962 RECHR:  ADDI    B,1             ; BUMP BY ONE FOR SOSG\r
16963         MOVEM   B,CHNCNT(D)     ; AND SAVE\r
16964         IORM    A,PIRQ2         ; LEAVE THE INT ON\r
16965 \r
16966 CHRLOO: MOVE    D,(P)           ; GET CHNNAEL NO.\r
16967         SOSG    CHNCNT(D)       ; GET COUNT\r
16968         JRST    CHRDON\r
16969 \r
16970         MOVE    B,(TP)\r
16971         MOVE    D,BUFRIN(B)     ; GET EXTRA BUFFER\r
16972         XCT     IOIN2(D)        ; READ CHAR\r
16973         PUSH    TP,$TCHSTR\r
16974         PUSH    TP,CHQUOTE CHAR\r
16975         PUSH    TP,$TCHRS       ; SAVE CHAR FOR CALL    \r
16976         PUSH    TP,A\r
16977         PUSH    TP,$TCHAN       ; SAVE CHANNEL\r
16978         PUSH    TP,B\r
16979         PUSHJ   P,INCHAR        ; PUT CHAR IN USERS BUFFER\r
16980         MCALL   3,INTERRUPT     ; RUN THE HANDLERS\r
16981         JRST    CHRLOO          ; AND LOOP\r
16982 \r
16983 CHRDON: .CALL   HOWMNY\r
16984         MOVEI   B,0\r
16985         MOVEI   A,1             ; SET FOR PI WORD CLOBBER\r
16986         LSH     A,(D)\r
16987         JUMPG   B,RECHR         ; ANY MORE?\r
16988         ANDCAM  A,PIRQ2\r
16989         SUB     P,[1,,1]\r
16990         SUB     TP,[2,,2]\r
16991         JRST    DIRQ\r
16992 \r
16993 \r
16994 \f\r
16995 ; HERE FOR NET CHANNEL INTERRUPT\r
16996 \r
16997 HNET:   CAIE    0,26            ; NETWORK?\r
16998         JRST    HSTYET          ; HANDLE PSEUDO TTY ETC.\r
16999         PUSH    TP,$TATOM\r
17000         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP\r
17001         PUSH    TP,$TUVEC\r
17002         PUSH    TP,BUFRIN(D)\r
17003         PUSH    TP,$TCHAN\r
17004         PUSH    TP,D\r
17005         MOVE    B,D             ; CHAN TO B\r
17006         PUSHJ   P,INSTAT        ; UPDATE THE NETWRK STATE\r
17007         MCALL   3,INTERRUPT\r
17008         SUB     TP,[2,,2]\r
17009         JRST    DIRQ\r
17010 \r
17011 HSTYET: PUSH    TP,$TATOM\r
17012         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP\r
17013         PUSH    TP,$TCHAN\r
17014         PUSH    TP,D\r
17015         MCALL   2,INTERRUPT\r
17016         SUB     TP,[2,,2]\r
17017         JRST    DIRQ\r
17018 \r
17019 ]\r
17020 CBDCHN: PUSH    TP,$TATOM\r
17021         PUSH    TP,EQUOTE BAD-CHANNEL\r
17022         JRST    CALER1\r
17023 \r
17024 IFN ITS,[\r
17025 \r
17026 HCLOCK: PUSH    TP,$TCHSTR\r
17027         PUSH    TP,CHQUOTE CLOCK\r
17028         MCALL   1,INTERRUPT\r
17029         JRST    DIRQ\r
17030 \r
17031 HRUNT:  PUSH    TP,$TATOM\r
17032         PUSH    TP,MQUOTE RUNT,RUNT,INTRUP\r
17033         MCALL   1,INTERRUPT\r
17034         JRST    DIRQ\r
17035 \r
17036 HREAL:  PUSH    TP,$TATOM\r
17037         PUSH    TP,MQUOTE REALT,REALT,INTRUP\r
17038         MCALL   1,INTERRUPT\r
17039         JRST    DIRQ\r
17040 \r
17041 HPAR:   MOVE    A,MQUOTE PARITY,PARITY,INTRUP\r
17042         JRST    HMPV1\r
17043 \r
17044 HMPV:   MOVE    A,MQUOTE MPV,MPV,INTRUP\r
17045         JRST    HMPV1\r
17046 \r
17047 HILOPR: MOVE    A,MQUOTE ILOPR,ILOPR,INTRUP\r
17048         JRST    HMPV1\r
17049 \r
17050 HPURE:  MOVE    A,MQUOTE PURE,PURE,INTRUP\r
17051 HMPV1:  PUSH    TP,$TATOM\r
17052         PUSH    TP,A\r
17053         PUSH    P,LCKINT        ; SAVE LOCN\r
17054         PUSH    TP,$TATOM\r
17055         PUSH    TP,A\r
17056         PUSH    TP,$TWORD\r
17057         PUSH    TP,LCKINT\r
17058         MCALL   2,EMERGENCY\r
17059         POP     P,A\r
17060         MOVE    C,(TP)\r
17061         SUB     TP,[2,,2]\r
17062         JUMPN   B,DIRQ\r
17063 \r
17064         PUSH    TP,$TATOM\r
17065         PUSH    TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED\r
17066         PUSH    TP,$TATOM\r
17067         PUSH    TP,C\r
17068         PUSH    TP,$TWORD\r
17069         PUSH    TP,A\r
17070         MCALL   3,ERROR\r
17071         JRST    DIRQ\r
17072 \r
17073 \f\r
17074 \r
17075 ; HERE TO HANDLE SYS DOWN INTERRUPT\r
17076 \r
17077 HDOWN:  PUSH    TP,$TATOM\r
17078         PUSH    TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP\r
17079         .DIETI  A,              ; HOW LONG?\r
17080         PUSH    TP,$TFIX\r
17081         PUSH    TP,A\r
17082         PUSH    P,A             ; FOR MESSAGE\r
17083         MCALL   2,INTERRUPT\r
17084         POP     P,A\r
17085         JUMPN   B,DIRQ\r
17086         .SUSET  [.RTTY,,B]      ; DO WE NOW HAVE A TTY AT ALL?\r
17087         JUMPL   B,DIRQ          ; DONT HANG AROUND\r
17088         PUSH    P,A\r
17089         MOVEI   B,[ASCIZ /\r
17090 Excuse me, SYSTEM going down in /]\r
17091         SKIPG   (P)             ; SKIP IF REALLY GOING DOWN\r
17092         MOVEI   B,[ASCIZ /\r
17093 Excuse me, SYSTEM has been REVIVED!\r
17094 /]\r
17095         PUSHJ   P,MSGTYP\r
17096         POP     P,B\r
17097         JUMPE   B,DIRQ\r
17098         IDIVI   B,30.           ; TO SECONDS\r
17099         IDIVI   B,60.           ; A/ SECONDS B/ MINUTES\r
17100         JUMPE   B,NOMIN\r
17101         PUSH    P,C\r
17102         PUSHJ   P,DECOUT\r
17103         MOVEI   B,[ASCIZ / minutes /]\r
17104         PUSHJ   P,MSGTYP\r
17105         POP     P,B\r
17106         JRST    .+2\r
17107 NOMIN:  MOVEI   B,(C)\r
17108         PUSHJ   P,DECOUT\r
17109         MOVEI   B,[ASCIZ / seconds.\r
17110 /]\r
17111         PUSHJ   P,MSGTYP\r
17112         JRST    DIRQ\r
17113 \r
17114 ; TWO DIGIT DEC OUT FROM B/\r
17115 \r
17116 DECOUT: IDIVI   B,10.\r
17117         JUMPE   B,DECOU1        ; NO TEN\r
17118         MOVEI   A,60(B)\r
17119         PUSHJ   P,MTYO\r
17120 DECOU1: MOVEI   A,60(C)\r
17121         JRST    MTYO\r
17122 \f\r
17123 ; HERE TO HANDLE I/O CHANNEL ERRORS\r
17124 \r
17125 HIOC:   .SUSET  [.RAPRC,,A]     ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE\r
17126         LDB     A,[330400,,A]   ; GET CHAN #\r
17127         MOVEI   C,(A)           ; COPY\r
17128         PUSH    TP,$TATOM       ; PUSH ERROR\r
17129         PUSH    TP,EQUOTE FILE-SYSTEM-ERROR\r
17130 \r
17131         PUSH    TP,$TCHAN       \r
17132         ASH     C,1             ; GET CHANNEL\r
17133         ADDI    C,CHNL0+1(TVP)  ; GET CHANNEL VECTOR\r
17134         PUSH    TP,(C)\r
17135         LSH     A,23.           ; DO A .STATUS\r
17136         IOR     A,[.STATUS A]\r
17137         XCT     A\r
17138         PUSHJ   P,GFALS         ; GEN NAMED FALSE\r
17139         PUSH    TP,A\r
17140         PUSH    TP,B\r
17141         PUSH    TP,$TATOM\r
17142         PUSH    TP,MQUOTE IOC,IOC,INTRUP\r
17143 \r
17144         PUSH    TP,A\r
17145         PUSH    TP,B\r
17146         PUSH    TP,-7(TP)\r
17147         PUSH    TP,-7(TP)\r
17148         MCALL   3,EMERGENCY\r
17149         JUMPN   B,DIRQ1         ; JUMP IF HANDLED\r
17150         MCALL   3,ERROR\r
17151         JRST    DIRQ\r
17152 \r
17153 DIRQ1:  SUB     TP,[6,,6]\r
17154         JRST    DIRQ\r
17155 \r
17156 ; HANDLE INFERIOR KNOCKING AT THE DOOR\r
17157 \r
17158 HINF:   SUBI    B,36.+16.+2     ; CONVERT TO INF #\r
17159         PUSH    TP,$TATOM\r
17160         PUSH    TP,MQUOTE INFERIOR,INFERIOR,INTRUP\r
17161         PUSH    TP,$TFIX\r
17162         PUSH    TP,B\r
17163         MCALL   2,INTERRUPT\r
17164         JRST    DIRQ\r
17165 ]\f\r
17166 IFE ITS,[\r
17167 \r
17168 ; HERE FOR TENEX INTS (FIRST CUT)\r
17169 \r
17170 HCNTLG: MOVEI   A,7\r
17171         JRST    HCNGS\r
17172 \r
17173 HCNTLS: MOVEI   A,23\r
17174 \r
17175 HCNGS:  PUSH    TP,$TATOM\r
17176         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP\r
17177         PUSH    TP,$TCHRS\r
17178         PUSH    TP,A\r
17179         PUSH    TP,$TCHAN\r
17180         PUSH    TP,TTICHN+1(TVP)\r
17181         MCALL   3,INTERRUPT\r
17182         JRST    DIRQ\r
17183 \r
17184 HNET:   MOVE    A,NETJFN-NINT+NNETS(B)\r
17185         JUMPE   A,DIRQ\r
17186         ASH     A,1\r
17187         ADDI    A,CHNL0+1(TVP)\r
17188         MOVE    B,(A)\r
17189         PUSH    TP,$TATOM\r
17190         PUSH    TP,MQUOTE CHAR,CHAR,INTRUP\r
17191         PUSH    TP,$TUVEC\r
17192         PUSH    TP,BUFRIN(B)\r
17193         PUSH    TP,$TCHAN\r
17194         PUSH    TP,B\r
17195         PUSHJ   P,INSTAT\r
17196         MCALL   3,INTERRUPT\r
17197         JRST    DIRQ\r
17198 ]\r
17199 \r
17200 \f\r
17201 MFUNCTION OFF,SUBR\r
17202         ENTRY\r
17203 \r
17204         JUMPGE  AB,TFA\r
17205         HLRZ    0,AB\r
17206         GETYP   A,(AB)          ; ARG TYPE\r
17207         MOVE    B,1(AB)         ; AND VALUE\r
17208         CAIN    A,TINTH         ; HEADER, GO HACK\r
17209         JRST    OFFHD           ; QUEEN OF HEARTS\r
17210         CAIN    A,TATOM\r
17211         JRST    .+3\r
17212         CAIE    A,TCHSTR\r
17213         JRST    TRYHAN          ; MAYBE INDIVIDUAL HANDLER\r
17214         CAIN    0,-2            ; MORE THAN 1 ARG?\r
17215         JRST    OFFAC1          ; NO, GO ON\r
17216         CAIG    0,-5            ; CANT BE MORE THAN 2\r
17217         JRST    TMA\r
17218         MOVEI   B,2(AB)         ; POINT TO 2D\r
17219         PUSHJ   P,CHNORL\r
17220 OFFAC1: MOVEI   B,(AB)\r
17221         PUSHJ   P,FNDINT\r
17222         JUMPGE  B,NOHAN1        ; NOT HANDLED\r
17223 \r
17224 OFFH1:  PUSH    P,C             ; SAVE C FOR BIT CLOBBER\r
17225         MOVSI   C,TATOM\r
17226         SKIPN   D\r
17227         MOVE    D,MQUOTE INTERRUPT\r
17228         MOVE    A,INAME(B)\r
17229         MOVE    B,INAME+1(B)\r
17230         PUSHJ   P,IREMAS\r
17231         SKIPE   B               ; IF NO ASSOC, DONT SMASH\r
17232         SETOM   ISTATE+1(B)     ; DISABLE IN CASE QUEUED\r
17233         POP     P,C             ; SPECIAL?\r
17234         JUMPGE  C,FINIS         ;  NO, DONE\r
17235 \r
17236         HRRZ    C,INTBL(C)      ; POINT TO SPECIAL CODE\r
17237         PUSHJ   P,(C)           ; GO TO SAME\r
17238         JUMPE   E,OFINIS        ; DONE\r
17239 IFN ITS,[\r
17240         CAILE   E,35.           ; SKIP IF 1ST WORD\r
17241         JRST    CLRW2           ; CLOBBER 2D WORD BIT\r
17242         LSH     0,-1(E)         ; POSITION BIT\r
17243         ANDCAM  0,MASK1         ; KILL BIT\r
17244         .SUSET  [.SMASK,,MASK1]\r
17245 ]\r
17246 IFE ITS,[\r
17247         MOVE    D,B\r
17248         SETZM   (E)\r
17249         MOVEI   E,(E)\r
17250         SUBI    E,NETJFN-NETCHN\r
17251         MOVEI   0,1\r
17252         MOVNS   E\r
17253         LSH     0,35.(E)\r
17254         ANDCAM  0,MASK1\r
17255         MOVEI   A,MFORK\r
17256         SETCM   B,MASK1\r
17257         DIC\r
17258         ANDCAM  0,PIRQ          ; JUST IN CASE\r
17259         MOVE    B,D\r
17260 ]\r
17261 OFINIS: MOVSI   A,TINTH\r
17262         JRST    FINIS\r
17263 \r
17264 IFN ITS,[\r
17265 CLRW2:  LSH     0,-36.(E)       ; POS BIT FOR 2D WORD\r
17266         ANDCAM  0,MASK2\r
17267         .SUSET  [.SMSK2,,MASK2]\r
17268         JRST    OFINIS\r
17269 ]\r
17270 \r
17271 TRYHAN: CAIE    A,THAND         ; HANDLER?\r
17272         JRST    WTYP1\r
17273         CAIE    0,-2\r
17274         JRST    TMA\r
17275         GETYP   0,IPREV(B)      ; GET TYPE OF PREV\r
17276         MOVE    A,INXT+1(B)\r
17277         MOVE    C,IPREV+1(B)\r
17278         MOVE    D,IPREV(B)\r
17279         CAIE    0,THAND\r
17280         JRST    DOHEAD          ; PREV HUST BE HDR\r
17281         MOVEM   A,INXT+1(C)\r
17282         JRST    .+2\r
17283 DOHEAD: MOVEM   A,IHNDLR+1(C)   ; INTO HDR\r
17284         JUMPE   A,OFFINI\r
17285         MOVEM   D,IPREV(A)\r
17286         MOVEM   C,IPREV+1(A)\r
17287 OFFINI: SETZM   IPREV+1(B)\r
17288         SETZM   INXT+1(B)\r
17289         MOVSI   A,THAND\r
17290         JRST    FINIS\r
17291 \r
17292 OFFHD:  CAIE    0,-2\r
17293         JRST    TMA\r
17294         PUSHJ   P,GETNMS                ; GET INFOR ABOUT INT\r
17295         JUMPE   C,OFFH1\r
17296         PUSH    TP,INAME(B)\r
17297         PUSH    TP,INAME+1(B)\r
17298         JRST    OFFH1\r
17299 \r
17300 GETNMS: GETYP   A,INAME(B)      ; CHECK FOR SPECIAL\r
17301         SETZB   C,D\r
17302         CAIN    A,TCHAN\r
17303         HRROI   C,SS.CHA\r
17304         PUSHJ   P,LOCQ          ; LOCATIVE?\r
17305         JRST    CHGTNM\r
17306 \r
17307         MOVEI   B,INAME(B)      ; POINT TO LOCATIVE\r
17308         MOVSI   D,(MOVE E,)\r
17309         PUSHJ   P,SMON          ; GET MONITOR\r
17310         MOVE    B,1(AB)\r
17311 GETNM1: HRROI   C,SS.WMO        ; ASSUME WRITE\r
17312         TLNN    E,.WRMON\r
17313         HRROI   C,SS.RMO\r
17314         MOVE    D,MQUOTE WRITE,WRITE,INTRUP\r
17315         TLNN    E,.WRMON\r
17316         MOVE    D,MQUOTE READ,READ,INTRUP\r
17317         POPJ    P,\r
17318 \r
17319 CHGTNM: JUMPL   C,CPOPJ\r
17320         MOVE    B,INAME+1(B)\r
17321         PUSHJ   P,SPEC1\r
17322         MOVE    B,1(AB)         ; RESTORE IHEADER\r
17323         POPJ    P,\r
17324 \f\r
17325 ; EMERGENCY, CANT DEFER ME!!\r
17326 \r
17327 MQUOTE INTERRUPT\r
17328 \r
17329 EMERGENCY:\r
17330         PUSH    P,.\r
17331         JRST    INTERR+1\r
17332 \r
17333 MFUNCTION INTERRUPT,SUBR\r
17334 \r
17335         PUSH    P,[0]\r
17336 \r
17337         ENTRY\r
17338 \r
17339         SETZM   INTHLD          ; RE-ENABLE THE WORLD\r
17340         JUMPGE  AB,TFA\r
17341         MOVE    B,1(AB)         ; GET HANDLER/NAME\r
17342         GETYP   A,(AB)          ; CAN BE HEADER OR NAME\r
17343         CAIN    A,TINTH         ; SKIP IF NOT HEADER\r
17344         JRST    GTHEAD\r
17345         CAIN    A,TATOM\r
17346         JRST    .+3\r
17347         CAIE    A,TCHSTR        ; SKIP IF CHAR STRING\r
17348         JRST    WTYP1\r
17349         MOVEI   B,(AB)          ; LOOK UP NAME\r
17350         PUSHJ   P,FNDNM         ; GET NAME\r
17351         JUMPE   B,IFALSE\r
17352         MOVEI   D,0\r
17353         CAMN    B,MQUOTE CHAR,CHAR,INTRUP\r
17354         PUSHJ   P,CHNGT1\r
17355         CAME    B,MQUOTE READ,READ,INTRUP\r
17356         CAMN    B,MQUOTE WRITE,WRITE,INTRUP\r
17357         PUSHJ   P,GTLOC1\r
17358         PUSHJ   P,INTASO\r
17359         JUMPE   B,IFALSE\r
17360 \r
17361 GTHEAD: SKIPE   ISTATE+1(B)     ; ENABLED?\r
17362         JRST    IFALSE          ; IGNORE COMPLETELY\r
17363         MOVE    A,INTPRI+1(B)   ; GET PRIORITY OF INTERRUPT\r
17364         CAMLE   A,CURPRI        ; SEE IF MUST QUEU\r
17365         JRST    SETPRI          ; MAY RUN NOW\r
17366         SKIPE   (P)             ; SKIP IF DEFER OK\r
17367         JRST    DEFERR\r
17368         MOVEM   A,(P)\r
17369         PUSH    TP,$TINTH       ; SAVE HEADER\r
17370         PUSH    TP,B\r
17371         MOVEI   A,1             ; SAVE OTHER ARGS\r
17372 PSHARG: ADD     AB,[2,,2]\r
17373         JUMPGE  AB,QUEU1        ; GO MAKE QUEU ENTRY\r
17374         PUSH    TP,(AB)\r
17375         PUSH    TP,1(AB)\r
17376         AOJA    A,PSHARG\r
17377 QUEU1:  PUSHJ   P,IEVECT        ; GET VECTOR\r
17378         PUSH    TP,$TVEC\r
17379         PUSH    TP,[0]          ; WILL HOLD QUEUE HEADER\r
17380         PUSH    TP,A\r
17381         PUSH    TP,B\r
17382 \r
17383         POP     P,A             ; RESTORE PRIORITY\r
17384 \r
17385         MOVE    B,QUEUES+1(TVP) ; GET INTERRUPT QUEUES\r
17386         MOVEI   D,0\r
17387         JUMPGE  B,GQUEU         ; MAKE A QUEUE HDR\r
17388 \r
17389 NXTQU:  CAMN    A,1(B)          ; GOT PRIORITY?\r
17390         JRST    ADDQU           ; YES, ADD TO THE QUEU\r
17391         CAMG    A,1(B)          ; SKIP IF SPOT NOT FOUND\r
17392         JRST    GQUEU\r
17393         MOVE    D,B\r
17394         MOVE    B,3(B)          ; GO TO NXT QUEUE\r
17395         JUMPL   B,NXTQU\r
17396 \r
17397 GQUEU:  PUSH    TP,$TVEC        ; SAVE NEXT POINTER\r
17398         PUSH    TP,D\r
17399         PUSH    TP,$TFIX\r
17400         PUSH    TP,A            ; SAVE PRIORITY\r
17401         PUSH    TP,$TVEC\r
17402         PUSH    TP,B\r
17403         PUSH    TP,$TLIST\r
17404         PUSH    TP,[0]\r
17405         PUSH    TP,$TLIST\r
17406         PUSH    TP,[0]\r
17407         MOVEI   A,4\r
17408         PUSHJ   P,IEVECT\r
17409         MOVE    D,(TP)          ; NOW SPLICE\r
17410         SUB     TP,[2,,2]\r
17411         JUMPN   D,GQUEU1\r
17412         MOVEM   B,QUEUES+1(TVP)\r
17413         JRST    .+2\r
17414 GQUEU1: MOVEM   B,3(D)\r
17415 \r
17416 ADDQU:  MOVEM   B,-2(TP)        ; SAVE QUEU HDR\r
17417         POP     TP,D\r
17418         POP     TP,C\r
17419         PUSHJ   P,INCONS        ; CONS IT\r
17420         MOVE    C,(TP)          ;GET QUEUE HEADER\r
17421         SKIPE   D,7(C)          ; IF END EXISTS\r
17422         HRRM    B,(D)           ; SPLICE\r
17423         MOVEM   B,7(C)\r
17424         SKIPN   5(C)            ; SKIP IF START EXISTS\r
17425         MOVEM   B,5(C)\r
17426 \r
17427 IFINI:  MOVSI   A,TATOM\r
17428         MOVE    B,MQUOTE T\r
17429         JRST    FINIS\r
17430 \r
17431 SETPRI: EXCH    A,CURPRI\r
17432         MOVEM   A,(P)\r
17433 \r
17434         PUSH    TP,$TAB         ; PASS AB TO HANDLERS\r
17435         PUSH    TP,AB\r
17436 \r
17437         PUSHJ   P,RUNINT        ; RUN THE HANDLERS\r
17438         POP     P,A             ; UNQUEU ANY WAITERS\r
17439         PUSHJ   P,UNQUEU\r
17440 \r
17441         JRST    IFINI\r
17442 \r
17443 ; HERE TO UNQUEUE WAITING INTERRUPTS\r
17444 \r
17445 UNQUEU: PUSH    P,A             ; SAVE NEW LEVEL\r
17446 \r
17447 UNQUE1: MOVE    A,(P)           ; TARGET LEVEL\r
17448         CAMLE   A,CURPRI        ; CHECK RUG NOT PULLED OUT\r
17449         JRST    UNDONE\r
17450         SKIPE   B,QUEUES+1(TVP)\r
17451         CAML    A,1(B)          ; RIGHT LEVEL?\r
17452         JRST    UNDONE          ; FINISHED\r
17453 \r
17454         SKIPN   C,5(B)          ; ON QUEUEU?\r
17455         JRST    UNXQ\r
17456         HRRZ    D,(C)           ; CDR THE LIST\r
17457         MOVEM   D,5(B)\r
17458         SKIPN   D               ; SKIP IF NOT LAST\r
17459         SETZM   7(B)            ; CLOBBER END POINTER\r
17460         MOVE    A,1(B)          ; GET THIS PRIORITY LEVEL\r
17461         MOVEM   A,CURPRI        ; MAKE IT THE CURRENT ONE\r
17462         MOVE    D,1(C)          ; GET SAVED VECTOR OF INF\r
17463 \r
17464         MOVE    B,1(D)          ; INT HEADER\r
17465         PUSH    TP,$TVEC\r
17466         PUSH    TP,D            ; AND ARGS\r
17467 \r
17468         PUSHJ   P,RUNINT        ; RUN THEM\r
17469         JRST    UNQUE1\r
17470 \r
17471 UNDONE: POP     P,CURPRI        ; SET CURRENT LEVEL\r
17472         MOVE    A,CURPRI\r
17473         POPJ    P,\r
17474 \r
17475 UNXQ:   MOVE    B,3(B)          ; GO  TO NEXT QUEUE\r
17476         MOVEM   B,QUEUES+1(TVP)\r
17477         JRST    UNQUE1\r
17478 \r
17479 \r
17480 \r
17481 ; SUBR TO CHANGE INTERRUPT LEVEL\r
17482 \r
17483 MFUNCTION INTLEV,SUBR,[INT-LEVEL]\r
17484         ENTRY\r
17485         JUMPGE  AB,RETLEV       ; JUST RETURN CURRENT\r
17486         GETYP   A,(AB)\r
17487         CAIE    A,TFIX\r
17488         JRST    WTYP1           ; LEVEL IS FIXED\r
17489         SKIPGE  A,1(AB)\r
17490         JRST    OUTRNG"\r
17491         CAMN    A,CURPRI        ; DIFFERENT?\r
17492         JRST    RETLEV          ; NO RETURN\r
17493         PUSH    P,CURPRI\r
17494         CAMG    A,CURPRI        ; SKIP IF NO UNQUEUE NEEDED\r
17495         PUSHJ   P,UNQUEU\r
17496         MOVEM   A,CURPRI        ; SAVE\r
17497         POP     P,A\r
17498         SKIPA   B,A\r
17499 RETLEV: MOVE    B,CURPRI\r
17500         MOVSI   A,TFIX\r
17501         JRST    FINIS\r
17502 \r
17503 RUNINT: PUSH    TP,$THAND       ; SAVE HANDLERS LIST\r
17504         PUSH    TP,IHNDLR+1(B)\r
17505 \r
17506         SKIPN   ISTATE+1(B)     ; SKIP IF DISABLED\r
17507         SKIPN   B,(TP)\r
17508         JRST    SUBTP4\r
17509 NXHND:  MOVEM   B,(TP)          ; SAVE CURRENT HDR\r
17510         MOVE    A,-2(TP)                ; SAVE ARG POINTER\r
17511         PUSHJ   P,CHSWAP        ; SEE IF MUST SWAP\r
17512         PUSH    TP,[0]\r
17513         PUSH    TP,[0]\r
17514         MOVEI   C,1             ; COUNT ARGS\r
17515         PUSH    TP,$TSP\r
17516         PUSH    TP,SP\r
17517         MOVE    D,PVP\r
17518         ADD     D,[1STEPR,,1STEPR]\r
17519         PUSH    TP,BNDV\r
17520         PUSH    TP,D\r
17521         PUSH    TP,$TPVP\r
17522         PUSH    TP,[0]\r
17523         MOVE    E,TP\r
17524         PUSH    TP,INTFCN(B)\r
17525         PUSH    TP,INTFCN+1(B)\r
17526         ADD     A,[2,,2]\r
17527         JUMPGE  A,DO.HND\r
17528         PUSH    TP,(A)\r
17529         PUSH    TP,1(A)\r
17530         AOJA    C,.-4\r
17531 DO.HND: PUSH    P,C\r
17532         PUSHJ   P,SPECBE        ; BIND 1 STEP FLAG\r
17533         POP     P,C\r
17534         ACALL   C,INTAPL\r
17535         MOVE    SP,-4(TP)\r
17536         MOVE    C,(TP)          ; RESET 1 STEP\r
17537         MOVEM   C,1STEPR+1(PVP)\r
17538         SUB     TP,[6,,6]\r
17539         PUSHJ   P,CHUNSW\r
17540         CAMN    E,PVP\r
17541         SUB     TP,[4,,4]       ; NO PROCESS CHANGE, POP JUNK\r
17542         CAMN    E,PVP\r
17543         JRST    .+4\r
17544         MOVE    D,TPSTO+1(E)\r
17545         SUB     D,[4,,4]\r
17546         MOVEM   D,TPSTO+1(E)    ; FIXUP HIS STACK\r
17547 DO.H1:  GETYP   A,A             ; CHECK FOR A DISMISS\r
17548         CAIN    A,TDISMI\r
17549         JRST    SUBTP4\r
17550         MOVE    B,(TP)          ; TRY FOR NEXT HANDLER\r
17551         SKIPE   B,INXT+1(B)\r
17552         JRST    NXHND\r
17553 SUBTP4: SUB     TP,[4,,4]\r
17554         POPJ    P,\r
17555 \r
17556 MFUNCTION INTAPL,SUBR,[RUNINT]\r
17557         JRST    APPLY\r
17558 \r
17559 \r
17560 NOHAND: JUMPE   C,NOHAN1\r
17561         PUSH    TP,$TATOM\r
17562         PUSH    TP,EQUOTE INTERNAL-INTERRUPT\r
17563 NOHAN1: PUSH    TP,(AB)\r
17564         PUSH    TP,1(AB)\r
17565         PUSH    TP,$TATOM\r
17566         PUSH    TP,EQUOTE NOT-HANDLED\r
17567         SKIPE   A,C\r
17568         MOVEI   A,1\r
17569         ADDI    A,2\r
17570         JRST    CALER\r
17571 \r
17572 DEFERR: PUSH    TP,$TATOM\r
17573         PUSH    TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT\r
17574         PUSH    TP,$TINTH\r
17575         PUSH    TP,B\r
17576         PUSH    TP,$TATOM\r
17577         PUSH    TP,MQUOTE INTERRUPT\r
17578         MCALL   3,RERR          ; FORCE REAL ERROR\r
17579         JRST    FINIS\r
17580 \r
17581 ; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION\r
17582 \r
17583 MFUNCTION DISMISS,SUBR\r
17584 \r
17585         HLRZ    0,AB\r
17586         JUMPGE  AB,TFA\r
17587         CAIGE   0,-6\r
17588         JRST    TMA\r
17589         MOVNI   D,1\r
17590         CAIE    0,-6\r
17591         JRST    DISMI3\r
17592         GETYP   0,4(AB)\r
17593         CAIE    0,TFIX\r
17594         JRST    WTYP\r
17595         SKIPGE  D,5(AB)\r
17596         JRST    OUTRNG\r
17597 \r
17598 DISMI3: MOVEI   A,(TB)\r
17599 \r
17600 DISMI0: HRRZ    B,FSAV(A)\r
17601         HRRZ    C,PCSAV(A)\r
17602         CAIE    B,INTAPL\r
17603         JRST    DISMI1\r
17604 \r
17605         MOVE    E,OTBSAV(A)\r
17606         MOVEI   0,(A)           ; SAVE FRAME\r
17607         MOVEI   A,DISMI2\r
17608         HRRM    A,PCSAV(E)      ; GET IT BACK HERE\r
17609         MOVE    A,(AB)\r
17610         MOVE    B,1(AB)\r
17611         MOVE    C,TPSAV(E)\r
17612         MOVEM   A,-7(C)\r
17613         MOVEM   B,-6(C)\r
17614         MOVEI   C,0\r
17615         CAMGE   AB,[-3,,]\r
17616         MOVEI   C,2(AB)\r
17617         MOVE    B,0             ; DEST FRAME\r
17618         JUMPL   D,.+3\r
17619         MOVE    A,PSAV(E)       ; NOW MUNG SAVED INT LEVEL\r
17620         MOVEM   D,-1(A)         ; ZAP YOUR MUNGED\r
17621         PUSHJ   P,CHUNW         ; CHECK ON UNWINDERS\r
17622         JRST    FINIS           ; FALL DOWN\r
17623 \r
17624 DISMI1: MOVEI   E,(A)\r
17625         HRRZ    A,OTBSAV(A)\r
17626         JUMPN   A,DISMI0\r
17627 \r
17628         MOVE    A,(AB)\r
17629         MOVE    B,1(AB)\r
17630 \r
17631         PUSH    TP,A\r
17632         PUSH    TP,B\r
17633         SKIPGE  A,D\r
17634         JRST    .+4\r
17635         CAMG    A,CURPRI\r
17636         PUSHJ   P,UNQUEU\r
17637         MOVEM   A,CURPRI\r
17638         CAML    AB,[-3,,]\r
17639         JRST    .+5\r
17640         PUSH    TP,2(AB)\r
17641         PUSH    TP,3(AB)\r
17642         MCALL   2,ERRET\r
17643         JRST    FINIS\r
17644 \r
17645         POP     TP,B\r
17646         POP     TP,A\r
17647         JRST    FINIS\r
17648 \r
17649 DISMI2: MOVE    C,(TP)\r
17650         MOVEM   C,1STEPR+1(PVP)\r
17651         MOVE    SP,-4(TP)\r
17652         SUB     TP,[6,,6]\r
17653         PUSHJ   P,CHUNSW        ; UNDO ANY PROCESS HACKING\r
17654         MOVE    C,TP\r
17655         CAME    E,PVP           ; SWAPED?\r
17656         MOVE    C,TPSTO+1(E)\r
17657         MOVE    D,-1(C)\r
17658         MOVE    0,(C)\r
17659         SUB     TP,[4,,4]\r
17660         SUB     C,[4,,4]        ; MAYBE FIXUP OTHER STACK\r
17661         CAME    E,PVP\r
17662         MOVEM   C,TPSTO+1(E)\r
17663         PUSH    TP,D\r
17664         PUSH    TP,0\r
17665         PUSH    TP,A\r
17666         PUSH    TP,B\r
17667         MOVE    A,-1(P)         ; SAVED PRIORITY\r
17668         CAMG    A,CURPRI\r
17669         PUSHJ   P,UNQUEU\r
17670         MOVEM   A,CURPRI\r
17671         SKIPN   -1(TP)\r
17672         JRST    .+3\r
17673         MCALL   2,ERRET\r
17674         JRST    FINIS\r
17675 \r
17676         SUB     TP,[4,,4]\r
17677         MOVSI   A,TDISMI\r
17678         MOVE    B,MQUOTE T\r
17679         JRST    DO.H1\r
17680         \r
17681 CHNGT1: HLRE    B,AB\r
17682         SUBM    AB,B\r
17683         GETYP   0,-2(B)\r
17684         CAIE    0,TCHAN\r
17685         JRST    WTYP3\r
17686         MOVE    B,-1(B)\r
17687         MOVSI   A,TCHAN\r
17688         POPJ    P,\r
17689 \r
17690 GTLOC1: GETYP   A,2(AB)\r
17691         PUSHJ   P,LOCQ\r
17692         JRST    WTYP2\r
17693         MOVE    D,B             ; RET ATOM FOR ASSOC\r
17694         MOVE    A,2(AB)\r
17695         MOVE    B,3(AB)\r
17696         POPJ    P,\r
17697 \f; MONITOR CHECKERS\r
17698 \r
17699 MONCH0: HLLZ    0,(B)           ; POTENTIAL MONITORS\r
17700 MONCH:  TLZ     0,TYPMSK        ; KILL TYPE\r
17701         IOR     C,0             ; IN NEW TYPE\r
17702         PUSH    P,0\r
17703         MOVEI   0,(B)\r
17704         CAIL    0,HIBOT\r
17705         JRST    PURERR\r
17706         POP     P,0\r
17707         TLNN    0,.WRMON        ; SKIP IF WRITE MONIT\r
17708         POPJ    P,\r
17709 \r
17710 ; MONITOR IS ON, INVOKE HANDLER\r
17711 \r
17712         PUSH    TP,A            ; SAVE OBJ\r
17713         PUSH    TP,B\r
17714         PUSH    TP,C\r
17715         PUSH    TP,D            ; SAVE DATUM\r
17716         MOVSI   C,TATOM         ; PREPARE TO FIND IT\r
17717         MOVE    D,MQUOTE WRITE,WRITE,INTRUP\r
17718         PUSHJ   P,IGET\r
17719         JUMPE   B,MONCH1        ; NOT FOUND IGNORE FOR NOW\r
17720         PUSH    TP,A            ; START SETTING UP CALL\r
17721         PUSH    TP,B\r
17722         PUSH    TP,-5(TP)\r
17723         PUSH    TP,-5(TP)\r
17724         PUSH    TP,-5(TP)\r
17725         PUSH    TP,-5(TP)\r
17726         PUSHJ   P,FRMSTK        ; PUT FRAME ON STAKC\r
17727         MCALL   4,EMERGE        ; DO IT\r
17728 MONCH1: POP     TP,D\r
17729         POP     TP,C\r
17730         POP     TP,B\r
17731         POP     TP,A\r
17732         HLLZ    0,(B)           ; UPDATE MONITORS\r
17733         TLZ     0,TYPMSK\r
17734         IOR     C,0\r
17735         POPJ    P,\r
17736 \r
17737 ; NOW FOR READ MONITORS\r
17738 \r
17739 RMONC0: HLLZ    0,(B)\r
17740 RMONCH: TLNN    0,.RDMON\r
17741         POPJ    P,\r
17742         PUSH    TP,A\r
17743         PUSH    TP,B\r
17744         MOVSI   C,TATOM\r
17745         MOVE    D,MQUOTE READ,READ,INTRUP\r
17746         PUSHJ   P,IGET\r
17747         JUMPE   B,RMONC1\r
17748         PUSH    TP,A\r
17749         PUSH    TP,B\r
17750         PUSH    TP,-3(TP)\r
17751         PUSH    TP,-3(TP)\r
17752         PUSHJ   P,FRMSTK        ; PUT FRAME ON STACK\r
17753         MCALL   3,EMERGE\r
17754 RMONC1: POP     TP,B\r
17755         POP     TP,A\r
17756         POPJ    P,\r
17757 \r
17758 ; PUT THE CURRENT FRAME ON THE STACK\r
17759 \r
17760 FRMSTK: PUSHJ   P,MAKACT\r
17761         HRLI    A,TFRAME\r
17762         PUSH    TP,A\r
17763         PUSH    TP,B\r
17764         POPJ    P,\r
17765 \r
17766 ; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE\r
17767 \r
17768 PURERR: PUSH    TP,$TATOM\r
17769         PUSH    TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE\r
17770         PUSH    TP,A\r
17771         PUSH    TP,B\r
17772         MOVEI   A,2\r
17773         JRST    CALER\r
17774 \f\r
17775 ; PROCESS SWAPPING CODE\r
17776 \r
17777 CHSWAP: MOVE    E,PVP           ; GET CURRENT\r
17778         POP     P,0\r
17779         SKIPE   D,INTPRO+1(B)   ; SKIP IF NO PROCESS GIVEN\r
17780         CAMN    D,PVP           ; SKIP IF DIFFERENT\r
17781         JRST    PSHPRO\r
17782         \r
17783         PUSHJ   P,SWAPIT        ; DO SWAP\r
17784 \r
17785 PSHPRO: PUSH    TP,$TPVP\r
17786         PUSH    TP,E\r
17787         JRST    @0\r
17788 \r
17789 CHUNSW: MOVE    E,PVP           ; RET OLD PROC\r
17790         MOVE    D,-2(TP)        ; GET SAVED PROC\r
17791         CAMN    D,PVP           ; SWAPPED?\r
17792         POPJ    P,\r
17793 \r
17794 SWAPIT: PUSH    P,0\r
17795         MOVE    0,PSTAT+1(D)    ; CHECK STATE\r
17796         CAIE    0,RESMBL\r
17797         JRST    NOTRES\r
17798         MOVEM   0,PSTAT+1(PVP)\r
17799         MOVEI   0,RUNING\r
17800         MOVEM   0,PSTAT+1(D)    ; SAVE NEW STATE\r
17801         POP     P,0\r
17802         POP     P,C\r
17803         JRST    SWAP"\r
17804 \f\r
17805 \r
17806 ;SUBROUTINE TO GET BIT FOR CLOBBERAGE\r
17807 \r
17808 GETBIT: MOVNS   B               ;NEGATE\r
17809         MOVSI   A,400000        ;GET THE BIT\r
17810         LSH     A,(B)           ;SHIFT TO POSITION\r
17811         POPJ    P,              ;AND RETURN\r
17812 \r
17813 ;HERE TO HANDLE PDL OVERFLOW.  ASK FOR A GC\r
17814 \r
17815 IPDLOV:\r
17816 IFN ITS,[\r
17817         MOVEM   A,TSINT         ;SAVE INT WORD\r
17818 ]\r
17819 \r
17820         SKIPE   GCFLG           ;IS GC RUNNING?\r
17821         JRST    GCPLOV          ;YES, COMPLAIN GROSSLY\r
17822 \r
17823         MOVEI   A,200000        ;GET BIT TO CLOBBER\r
17824         IORM    A,PIRQ          ;LEAVE A MESSAGE FOR HIGHER LEVEL\r
17825 \r
17826         EXCH    P,GCPDL         ;GET A WINNING PDL\r
17827         HRRZ    B,TSINTR        ;GET POINTER TO LOSING INSTRUCTION\r
17828         SKIPG   GCPDL           ; SKIP IF NOT P\r
17829         LDB     B,[270400,,-1(B)]       ;GET AC FIELD\r
17830         SKIPL   GCPDL           ; SKIP IF P\r
17831         MOVEI   B,P\r
17832         MOVEI   A,(B)           ;COPY IT\r
17833         LSH     A,1             ;TIMES 2\r
17834         ADDI    A,0STO(PVP)     ;POINT TO THIS ACS CURRENT TYPE\r
17835         HLRZ    A,(A)           ;GET THAT TYPE INTO A\r
17836         CAIN    B,P             ;IS IT P\r
17837         MOVEI   B,GCPDL         ;POINT TO SAVED P\r
17838 \r
17839         CAIN    B,B             ;OR IS IT B ITSELF\r
17840         MOVEI   B,TSAVB\r
17841         CAIN    B,A             ;OR A\r
17842         MOVEI   B,TSAVA\r
17843 \r
17844         CAIN    B,C             ;OR C\r
17845         MOVEI   B,1(P)          ;C WILL BE ON THE STACK\r
17846 \r
17847         PUSH    P,C\r
17848         PUSH    P,A\r
17849 \r
17850         MOVE    A,(B)           ;GET THE LOSING POINTER\r
17851         MOVEI   C,(A)           ;AND ISOLATE RH\r
17852 \r
17853         CAMG    C,VECTOP        ;CHECK IF IN GC SPACE\r
17854         CAMG    C,VECBOT\r
17855         JRST    NOGROW          ;NO, COMPLAIN\r
17856 \r
17857 ; FALL THROUGH\r
17858 \f\r
17859 \r
17860         HLRZ    C,A             ;GET -LENGTH\r
17861         SUBI    A,-1(C)         ;POINT TO A DOPE WORD\r
17862         POP     P,C             ;RESTORE TYPE INTO C\r
17863         PUSH    P,D             ; SAVE FOR GROWTH HACKER\r
17864         MOVEI   D,0\r
17865         CAIN    C,TPDL          ; POIN TD TO APPROPRIATE DOPE WORD\r
17866         MOVEI   D,PGROW\r
17867         CAIN    C,TTP\r
17868         MOVEI   D,TPGROW\r
17869         JUMPE   D,BADPDL        ; IF D STILL 0, THIS PDL IS WEIRD\r
17870         MOVEI   A,PDLBUF(A)     ; POINT TO ALLEGED REAL DOPE WORD\r
17871         SKIPN   (D)             ; SKIP IF PREVIOUSLY BLOWN\r
17872         MOVEM   A,(D)           ; CLOBBER IN\r
17873         CAME    A,(D)           ; MAKE SURE IT IS THE SAME\r
17874         JRST    PDLOSS\r
17875         POP     P,D             ; RESTORE D\r
17876 \r
17877 \r
17878 PNTRHK: MOVE    C,(B)           ;RESTORE PDL POINTER\r
17879         SUB     C,[PDLBUF,,0]   ;FUDGE THE POINTER\r
17880         MOVEM   C,(B)           ;AND STORE IT\r
17881 \r
17882         POP     P,C             ;RESTORE THE WORLD\r
17883         EXCH    P,GCPDL         ;GET BACK ORIG PDL\r
17884 IFN ITS,[\r
17885         MOVE    A,TSINT         ;RESTORE INT WORD\r
17886 \r
17887         JRST    IMPCH           ;LOOK FOR MORE INTERRUPTS\r
17888 ]\r
17889 IFE ITS,        JRST    GCQUIT\r
17890 \r
17891 TPOVFL: SETOM   INTFLG          ;SIMULATE PDL OVFL\r
17892         PUSH    P,A\r
17893         MOVEI   A,200000        ;TURN ON THE BIT\r
17894         IORM    A,PIRQ\r
17895         SUB     TP,[PDLBUF,,0]  ;HACK STACK POINTER\r
17896         HLRE    A,TP            ;FIND DOPEW\r
17897         SUBM    TP,A            ;POINT TO DOPE WORD\r
17898         MOVEI   A,1(A)          ; ZERO LH AND POINT TO DOPEWD\r
17899         SKIPN   TPGROW\r
17900         HRRZM   A,TPGROW\r
17901         CAME    A,TPGROW        ; MAKE SURE WINNAGE\r
17902         JRST    PDLOSS\r
17903         POP     P,A\r
17904         POPJ    P,\r
17905 \r
17906 \r
17907 ; GROW CORE IF PDL OVERFLOW DURING GC\r
17908 \r
17909 GCPLOV: MOVE    A,P.TOP ; GET TOP OF IMPURE\r
17910         ASH     A,-10.          ; TO BLOCKS\r
17911         EXCH    P,GCPDL         ; NEED A PDL TO CALL P.CORE\r
17912         ADDI    A,1             ; GO TO NEXT BLOCK\r
17913 GRECOR: PUSHJ   P,P.CORE        ; GET CORE\r
17914         JRST    SLPCOR          ; HANG GETTING THE CORE\r
17915         EXCH    P,GCPDL         ; BPDLS BACK\r
17916         ADD     P,[-2000,,0]\r
17917 IFE ITS,        JRST    GCQUIT\r
17918 IFN ITS,[\r
17919         MOVE    A,TSINT\r
17920         JRST    IMPCH\r
17921 \r
17922 \r
17923 SLPCOR: MOVEI   B,1\r
17924         .SLEEP  B,\r
17925         JRST    GRECOR\r
17926 \r
17927 ]\r
17928 \f\r
17929 IFN ITS,[\r
17930 \r
17931 ;HERE TO HANDLE LOW-LEVEL CHANNELS\r
17932 \r
17933 \r
17934 CHNACT: SKIPN   GCFLG           ;GET A WINNING PDL\r
17935         EXCH    P,GCPDL\r
17936         ANDI    A,177777        ;ISOLATE CHANNEL BITS\r
17937         PUSH    P,0             ;SAVE\r
17938 \r
17939 CHNA1:  MOVEI   B,0             ;BIT COUNTER\r
17940         JFFO    A,.+2           ;COUNT\r
17941         JRST    CHNA2\r
17942         SUBI    B,35.           ;NOW HAVE CHANNEL\r
17943         MOVMS   B               ;PLUS IT\r
17944         MOVEI   0,1\r
17945         LSH     0,(B)\r
17946         ANDCM   A,0\r
17947         MOVEI   0,(B)           ; COPY TO 0\r
17948         LSH     0,23.           ;POSITION FOR A .STATUS\r
17949         IOR     0,[.STATUS 0]\r
17950         XCT     0               ;DO IT\r
17951         ANDI    0,77            ;ISOLATE DEVICE\r
17952         CAILE   0,2\r
17953         JRST    CHNA1\r
17954 \r
17955 PMIN4:  MOVE    0,B             ; CHAN TO 0\r
17956         .ITYIC  0,              ; INTO 0\r
17957         JRST    .+2             ; DONE, GO ON\r
17958         JRST    PMIN4\r
17959         SETZM   GCFLCH          ; LEAVE GC MODE\r
17960         JRST    CHNA1\r
17961 \r
17962 CHNA2:  POP     P,0\r
17963         SKIPN   GCFLG\r
17964         EXCH    P,GCPDL\r
17965         JRST    GCQUIT\r
17966 \r
17967 HOWMNY: SETZ\r
17968         SIXBIT /LISTEN/\r
17969         D\r
17970         402000,,B\r
17971 ]\r
17972 \r
17973 MFUNCTION GASCII,SUBR,ASCII\r
17974         ENTRY   1\r
17975 \r
17976         GETYP   A,(AB)\r
17977         CAIE    A,TCHRS\r
17978         JRST    TRYNUM\r
17979 \r
17980         MOVE    B,1(AB)\r
17981         MOVSI   A,TFIX\r
17982         JRST    FINIS\r
17983 \r
17984 TRYNUM: CAIE    A,TFIX\r
17985         JRST    WTYP1\r
17986         SKIPGE  B,1(AB)         ;GET NUMBER\r
17987         JRST    TOOBIG\r
17988         CAILE   B,177           ;CHECK RANGE\r
17989         JRST    TOOBIG\r
17990         MOVSI   A,TCHRS\r
17991         JRST    FINIS\r
17992 \r
17993 TOOBIG: PUSH    TP,$TATOM\r
17994         PUSH    TP,EQUOTE ARGUMENT-OUT-OF-RANGE\r
17995         JRST    CALER1\r
17996 \r
17997 \f\r
17998 ;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION\r
17999 \r
18000 BADPDL: FATAL   NON PDL OVERFLOW\r
18001 \r
18002 NOGROW: FATAL   PDL OVERFLOW ON NON EXPANDABLE PDL\r
18003 \r
18004 PDLOSS: FATAL   PDL OVEFLOW BUFFER EXHAUSTED\r
18005 \r
18006 DLOSER: PUSH    P,LOSRS(B)\r
18007         MOVE    A,TSAVA\r
18008         MOVE    B,TSAVB\r
18009         POPJ    P,\r
18010 \r
18011 LOSRS:  IMPV\r
18012         ILOPR\r
18013         IOC\r
18014         IPURE\r
18015 \r
18016 \r
18017 ;MEMORY PROTECTION INTERRUPT\r
18018 \r
18019 IOC:    FATAL   IO CHANNEL ERROR IN GARBAGE COLLECTOR\r
18020 IMPV:   FATAL   MPV IN GARBAGE COLLECTOR\r
18021 \r
18022 IPURE:  FATAL   PURE WRITE IN GARBAGE COLLECTOR\r
18023 ILOPR:  FATAL   ILLEGAL OPEREATION IN GARBAGE COLLECTOR\r
18024 \r
18025 IFN ITS,[\r
18026 \r
18027 ;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS\r
18028 \r
18029 INTINT: SETZM   CHNCNT\r
18030         MOVE    A,[CHNCNT,,CHNCNT+1]\r
18031         BLT     A,CHNCNT+16.\r
18032         SETZM   INTFLG\r
18033         .SUSET  [.SPICLR,,[-1]]\r
18034         MOVE    A,MASK1         ;SET MASKS\r
18035         MOVE    B,MASK2\r
18036         .SETM2  A,              ;SET BOTH MASKS\r
18037         MOVSI   A,TVEC\r
18038         MOVEM   A,QUEUES(TVP)\r
18039         SETZM   QUEUES+1(TVP)   ;UNQUEUE ANY OLD INTERRUPTS\r
18040         SETZM   CURPRI\r
18041         POPJ    P,\r
18042 ]\r
18043 IFE ITS,[\r
18044 \r
18045 ; INITIALIZE TENEX INTERRUPT SYSTEM\r
18046 \r
18047 INTINT: CIS                     ; CLEAR THE INT WORLD\r
18048         SETZM   INTFLG          ; IN CASE RESTART\r
18049         MOVSI   A,TVEC          ; FIXUP QUEUES\r
18050         MOVEM   A,QUEUES(TVP)\r
18051         SETZM   QUEUES+1(TVP)\r
18052         SETZM   CURPRI          ; AND PRIORITY LEVEL\r
18053         MOVEI   A,MFORK         ; TURN ON MY INTERRUPTS\r
18054         MOVE    B,[LEVTAB,,CHNTAB]      ; POINT TO TABLES\r
18055         SIR                     ; TELL SYSTEM ABOUT THEM\r
18056         MOVE    B,MASK1         ; SET UP FOR INT BITS\r
18057         AIC                     ; TURN THEM ON\r
18058         MOVSI   A,7             ; CNTL G AND CHANNEL 0\r
18059         ATI                     ; ACTIVATE IT\r
18060         MOVE    A,[23,,1]       ; CNTL S AND CHANNEL 1\r
18061         ATI                     ; ACTIVATE IT\r
18062         MOVEI   A,MFORK         ; DO THE ENABLE\r
18063         EIR\r
18064         POPJ    P,\r
18065 ]\r
18066 \f\r
18067 \r
18068 ; CNTL-G HANDLER\r
18069 \r
18070 MFUNCTION QUITTER,SUBR\r
18071 \r
18072         ENTRY   2\r
18073         GETYP   A,(AB)\r
18074         CAIE    A,TCHRS\r
18075         JRST    WTYP1\r
18076         GETYP   A,2(AB)\r
18077         CAIE    A,TCHAN\r
18078         JRST    WTYP2\r
18079         MOVE    B,1(AB)\r
18080         MOVE    A,(AB)\r
18081         CAIN    B,^S            ; HANDLE CNTL-S\r
18082         JRST    RETLIS\r
18083         CAIE    B,7\r
18084         JRST    FINIS\r
18085 \r
18086         PUSHJ   P,CLEAN         ; CLEAN UP I/O CHANNELS\r
18087         PUSH    TP,$TATOM\r
18088         PUSH    TP,EQUOTE CONTROL-G?\r
18089         MCALL   1,ERROR\r
18090         JRST    FINIS\r
18091 \r
18092 RETLIS: MOVEI   D,(TB)          ; FIND A LISTEN OR ERROR TO RET TO\r
18093 \r
18094 RETLI1: HRRZ    A,OTBSAV(D)\r
18095         HRRZ    C,FSAV(A)       ; CHECK FUNCTION\r
18096         CAIE    C,LISTEN\r
18097         CAIN    C,ERROR         ; FOUND?\r
18098         JRST    FNDHIM          ; YES, GO TO SAME\r
18099         CAIN    C,ERROR%        ; FUNNY ERROR\r
18100         JRST    FNDHIM\r
18101         CAIN    C,TOPLEV        ; NO ERROR/LISTEN\r
18102         JRST    FINIS\r
18103         MOVEI   D,(A)\r
18104         JRST    RETLI1\r
18105 \r
18106 FNDHIM: PUSH    TP,$TTB\r
18107         PUSH    TP,D\r
18108         PUSHJ   P,CLEAN\r
18109         MOVE    B,(TP)          ; NEW FRAME\r
18110         SUB     TP,[2,,2]\r
18111         MOVEI   C,0\r
18112         PUSHJ   P,CHUNW         ; UNWIND?\r
18113         MOVSI   A,TATOM\r
18114         MOVE    B,MQUOTE T\r
18115         JRST    FINIS\r
18116 \r
18117 CLEAN:  MOVE    B,3(AB)         ; GET IN CHAN\r
18118         PUSHJ   P,RRESET\r
18119         MOVE    B,3(AB)         ; CHANNEL BAKC\r
18120         MOVE    C,BUFRIN(B)\r
18121         SKIPN   C,ECHO(C)       ; GET ECHO\r
18122         JRST    CLUNQ\r
18123 IFN ITS,[\r
18124         MOVEI   A,2\r
18125         CAMN    C,[PUSHJ P,MTYO]\r
18126         JRST    TYONUM\r
18127         LDB     A,[270400,,C]\r
18128 TYONUM: LSH     A,23.\r
18129         IOR     A,[.RESET]\r
18130         XCT     A\r
18131 ]\r
18132 IFE ITS,[\r
18133         MOVEI   A,101           ; OUTPUT JFN\r
18134         CFOBF\r
18135 ]\r
18136 \r
18137 CLUNQ:  SETZB   A,CURPRI\r
18138         JRST    UNQUEU\r
18139 \r
18140 \f\r
18141 IMPURE\r
18142 ONINT:  0               ; INT FUDGER\r
18143 IFN ITS,[\r
18144 ;RANDOM IMPURE CRUFT NEEDED\r
18145 CHNCNT: BLOCK   16.     ; # OF CHARS IN EACH CHANNEL\r
18146 \r
18147 TSAVA:  0\r
18148 TSAVB:  0\r
18149 PIRQ:   0                       ;HOLDS REQUEST BITS FOR 1ST WORD\r
18150 PIRQ2:  0                       ;SAME FOR WORD 2\r
18151 PCOFF:  0\r
18152 MASK1:  1200,,220540                    ;FIRST MASK\r
18153 MASK2:  0                       ;SECOND THEREOF\r
18154 CURPRI: 0               ; CURRENT PRIORITY\r
18155 ]\r
18156 IFE ITS,[\r
18157 NETJFN: BLOCK   NNETS\r
18158 MASK1:  CHNMSK\r
18159 TSINTR:\r
18160 P1:     0                       ; PC INT LEVEL 1\r
18161 P2:     0                       ; PC INT LEVEL 2\r
18162 P3:     0                       ; PC INT LEVEL 3\r
18163 CURPRI: 0\r
18164 TSAVA:  0\r
18165 TSAVB:  0\r
18166 PIRQ:   0\r
18167 PIRQ2:  0\r
18168 ]\r
18169 PURE\r
18170 \r
18171 END\r
18172 \fTITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES\r
18173 \r
18174 RELOCA\r
18175 \r
18176 .GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE\r
18177 .GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI\r
18178 .GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN\r
18179 .GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC\r
18180 .GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT\r
18181 .GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1\r
18182 .GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6\r
18183 .GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM\r
18184 .GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM\r
18185 .GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY\r
18186 .GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI\r
18187 .GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ\r
18188 .GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG\r
18189 .GLOBAL TYPIC\r
18190 .INSRT MUDDLE >\r
18191 \r
18192 MONITS==1               ; SET TO 1 IF PC DEMON WANTED\r
18193 .VECT.==1               ; BIT TO INDICATE VECTORS FOR GCHACK\r
18194 \r
18195 ;MAIN LOOP AND STARTUP\r
18196 \r
18197 START:  MOVEI   0,0                     ; SET NO HACKS\r
18198         MOVEM   0,WHOAMI                ; HACK FOR TS FOO linked to TS MUDDLE\r
18199         MOVE    PVP,MAINPR              ; MAKE SURE WE START IN THE MAIN PROCESS\r
18200         JUMPE   0,INITIZ                ; MIGHT BE RESTART\r
18201         MOVE    P,PSTO+1(PVP)           ; SET UP FOR BOOTSTRAP HACK\r
18202         MOVE    TP,TPSTO+1(PVP)\r
18203 INITIZ: SKIPN   P                       ; IF NO CURRENT P\r
18204         MOVE    P,PSTO+1(PVP)           ; PDL TO GET OFF THE GROUND\r
18205         SKIPN   TP                      ; SAME FOR TP\r
18206         MOVE    TP,TPSTO+1(PVP)         ; GET A TP TO WORK WITH\r
18207         MOVE    TVP,TVPSTO+1(PVP)       ; GET A TVP\r
18208         SETZB   R,M                     ; RESET RSUBR AC'S\r
18209         PUSHJ   P,%RUNAM\r
18210         PUSHJ   P,%RJNAM\r
18211         PUSHJ   P,TTYOPE                ;OPEN THE TTY\r
18212         MOVEI   B,MUDSTR\r
18213         SKIPE   WHOAMI          ; SKIP IF THIS IS MUDDLE\r
18214         JRST    .+3             ; ELSE NO MESSAGE\r
18215         SKIPN   NOTTY                   ; IF NO TTY, IGNORE\r
18216         PUSHJ   P,MSGTYP                ;TYPE OUT TO USER\r
18217 \r
18218         XCT     MESSAG                  ;MAYBE PRINT A MESSAGE\r
18219         PUSHJ   P,INTINT                ;INITIALIZE INTERRUPT HANDLER\r
18220         XCT     IPCINI\r
18221         PUSHJ   P,PURCLN                ; CLEAN UP PURE SHARED AREA\r
18222 RESTART:                                ;RESTART A PROCESS\r
18223 STP:    MOVEI   C,0\r
18224         MOVE    B,TBINIT+1(PVP)         ;POINT INTO STACK AT START\r
18225         PUSHJ   P,CHUNW                 ; LEAVE WHILE DOING UNWIND CHECK\r
18226         MOVEI   E,TOPLEV\r
18227         MOVEI   A,TFALSE                ; IN CASE FALLS OFF PROCESS\r
18228         MOVEI   B,0\r
18229         MOVEM   E,-1(TB)\r
18230         JRST    CONTIN\r
18231 \r
18232         MQUOTE  TOPLEVEL\r
18233 TOPLEVEL:\r
18234         MCALL   0,LISTEN\r
18235         JRST    TOPLEVEL\r
18236 \f\r
18237 \r
18238 MFUNCTION LISTEN,SUBR\r
18239 \r
18240         ENTRY\r
18241         PUSH    P,[0]           ;FLAG: DON'T PRINT ERROR MSG\r
18242         JRST    ER1\r
18243 \r
18244 ; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE\r
18245         IMQUOTE ERROR\r
18246 \r
18247 ERROR:  MOVE    B,IMQUOTE ERROR\r
18248         PUSHJ   P,IGVAL         ; GET VALUE\r
18249         GETYP   C,A\r
18250         CAIN    C,TSUBR         ; CHECK FOR NO CHANGE\r
18251         CAIE    B,RERR1         ; SKIP IF NOT CHANGED\r
18252         JRST    .+2\r
18253         JRST    RERR1           ; GO TO THE DEFAULT\r
18254         PUSH    TP,A            ; SAVE VALUE\r
18255         PUSH    TP,B\r
18256         MOVE    C,AB            ; SAVE AB\r
18257         MOVEI   D,1             ; AND COUNTER\r
18258 USER1:  PUSH    TP,(C)          ; PUSH THEM\r
18259         PUSH    TP,1(C)\r
18260         ADD     C,[2,,2]        ; BUMP\r
18261         ADDI    D,1\r
18262         JUMPL   C,USER1\r
18263         ACALL   D,APPLY         ; EVAL USERS ERROR\r
18264         JRST    FINIS\r
18265 \r
18266 \r
18267 TPSUBR==TSUBR+400000\r
18268 \r
18269 MFUNCTION ERROR%,PSUBR,ERROR\r
18270 \r
18271 RMT [EXPUNGE TPSUBR\r
18272 ]\r
18273 RERR1:  ENTRY\r
18274         PUSH    TP,$TATOM\r
18275         PUSH    TP,MQUOTE ERROR,ERROR,INTRUP\r
18276         PUSHJ   P,FRMSTK        ; PUT ERROR'S FRAME ON STACK\r
18277         MOVEI   D,2\r
18278         MOVE    C,AB\r
18279 RERR2:  JUMPGE  C,RERR22\r
18280         PUSH    TP,(C)\r
18281         PUSH    TP,1(C)\r
18282         ADD     C,[2,,2]\r
18283         AOJA    D,RERR2\r
18284 RERR22: ACALL   D,EMERGENCY\r
18285         JRST    RERR\r
18286 \r
18287 IMQUOTE ERROR\r
18288 RERR:   ENTRY\r
18289         PUSH    P,[-1]          ;PRINT ERROR FLAG\r
18290 \r
18291 ER1:    MOVE    B,IMQUOTE INCHAN\r
18292         PUSHJ   P,ILVAL         ; CHECK INPUT CHANNEL IS SOME KIND OF TTY\r
18293         GETYP   A,A\r
18294         CAIE    A,TCHAN         ; SKIP IF IT IS A CHANNEL\r
18295         JRST    ER2             ; NO, MUST REBIND\r
18296         CAMN    B,TTICHN+1(TVP)\r
18297         JRST    NOTINC\r
18298 ER2:    MOVE    B,IMQUOTE INCHAN\r
18299         MOVEI   C,TTICHN(TVP)   ; POINT TO VALU\r
18300         PUSHJ   P,PUSH6         ; PUSH THE BINDING\r
18301         MOVE    B,TTICHN+1(TVP) ; GET IN CHAN\r
18302 NOTINC: SKIPE   NOTTY\r
18303         JRST    NOECHO\r
18304         PUSH    TP,$TCHAN\r
18305         PUSH    TP,B\r
18306         PUSH    TP,$TATOM\r
18307         PUSH    TP,MQUOTE T\r
18308         MCALL   2,TTYECH        ; ECHO INPUT\r
18309 NOECHO: MOVE    B,IMQUOTE OUTCHAN\r
18310         PUSHJ   P,ILVAL         ; GET THE VALUE\r
18311         GETYP   A,A\r
18312         CAIE    A,TCHAN         ; SKIP IF OK CHANNEL\r
18313         JRST    ER3             ; NOT CHANNEL, MUST REBIND\r
18314         CAMN    B,TTOCHN+1(TVP)\r
18315         JRST    NOTOUT\r
18316 ER3:    MOVE    B,IMQUOTE OUTCHAN\r
18317         MOVEI   C,TTOCHN(TVP)\r
18318         PUSHJ   P,PUSH6         ; PUSH THE BINDINGS\r
18319 NOTOUT: MOVE    B,IMQUOTE OBLIST\r
18320         PUSHJ   P,ILVAL ; GET THE VALUE OF OBLIST\r
18321         PUSHJ   P,OBCHK         ; IS IT A WINNER ?\r
18322         SKIPA   A,$TATOM        ; NO, SKIP AND CONTINUE\r
18323         JRST    NOTOBL          ; YES, DO NOT DO REBINDING\r
18324         MOVE    B,IMQUOTE OBLIST\r
18325         PUSHJ   P,IGLOC\r
18326         GETYP   0,A\r
18327         CAIN    0,TUNBOU\r
18328         JRST    MAKOB           ; NO GLOBAL OBLIST, MAKE ONE\r
18329         MOVEI   C,(B)           ; COPY ADDRESS\r
18330         MOVE    A,(C)           ; GET THE GVAL\r
18331         MOVE    B,(C)+1\r
18332         PUSHJ   P,OBCHK         ; IS IT A WINNER ?\r
18333         JRST    MAKOB           ; NO, GO MAKE A NEW ONE\r
18334         MOVE    B,IMQUOTE OBLIST\r
18335         PUSHJ   P,PUSH6\r
18336 \r
18337 NOTOBL: PUSH    TP,[TATOM,,-1]  ;FOR BINDING\r
18338         PUSH    TP,IMQUOTE LER,[LERR ]INTRUP\r
18339         PUSHJ   P,MAKACT\r
18340         HRLI    A,TFRAME        ; CORRCT TYPE\r
18341         PUSH    TP,A\r
18342         PUSH    TP,B\r
18343         PUSH    TP,[0]\r
18344         PUSH    TP,[0]\r
18345         MOVE    A,PVP           ; GET PROCESS\r
18346         ADD     A,[PROCID,,PROCID]      ; POINT TO ID (ALSO LEVEL)\r
18347         PUSH    TP,BNDV\r
18348         PUSH    TP,A\r
18349         MOVE    A,PROCID(PVP)\r
18350         ADDI    A,1             ; BUMP ERROR LEVEL\r
18351         PUSH    TP,A\r
18352         PUSH    TP,PROCID+1(PVP)\r
18353         PUSH    P,A\r
18354 \r
18355         MOVE    B,IMQUOTE READ-TABLE\r
18356         PUSHJ   P,IGVAL\r
18357         PUSH    TP,[TATOM,,-1]\r
18358         PUSH    TP,IMQUOTE READ-TABLE\r
18359         GETYP   C,A             ; TO GVAL OF READ-TABLE ON ERROR AND\r
18360         CAIE    C,TVEC  ; TOP ERRET'S\r
18361         JRST    .+4\r
18362         PUSH    TP,A\r
18363         PUSH    TP,B\r
18364         JRST    .+3\r
18365         PUSH    TP,$TUNBOUND\r
18366         PUSH    TP,[-1]\r
18367         PUSH    TP,[0]\r
18368         PUSH    TP,[0]\r
18369 \r
18370         PUSHJ   P,SPECBIND      ;BIND THE CRETANS\r
18371         MOVE    A,-1(P)         ;RESTORE SWITHC\r
18372         JUMPE   A,NOERR         ;IF 0, DONT PRINT ERROR MESS\r
18373         PUSH    TP,$TATOM\r
18374         PUSH    TP,EQUOTE *ERROR*\r
18375         MCALL   0,TERPRI\r
18376         MCALL   1,PRINC ;PRINT THE MESSAGE\r
18377 NOERR:  MOVE    C,AB            ;GET A COPY OF AB\r
18378 \r
18379 ERRLP:  JUMPGE  C,LEVPRT        ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP\r
18380         PUSH    TP,$TAB\r
18381         PUSH    TP,C\r
18382         MOVEI   B,PRIN1\r
18383         GETYP   A,(C)           ; GET  ARGS TYPE\r
18384         CAIE    A,TATOM\r
18385         JRST    ERROK\r
18386         MOVE    A,1(C)          ; GET ATOM\r
18387         MOVE    A,2(A)\r
18388         CAIE    A,ERROBL+1\r
18389         CAMN    A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST\r
18390         MOVEI   B,PRINC         ; DONT PRINT TRAILER\r
18391 ERROK:  PUSH    P,B             ; SAVE ROUTINE POINTER\r
18392         PUSH    TP,(C)\r
18393         PUSH    TP,1(C)\r
18394         MCALL   0,TERPRI        ; CRLF\r
18395         POP     P,B             ; GET ROUTINE BACK\r
18396         .MCALL  1,(B)\r
18397         POP     TP,C\r
18398         SUB     TP,[1,,1]\r
18399         ADD     C,[2,,2]        ;BUMP SAVED AB\r
18400         JRST    ERRLP           ;AND CONTINUE\r
18401 \r
18402 \r
18403 LEVPRT: XCT     INITFL          ;LOAD MUDDLE INIT FILE IF FIRST TIME\r
18404         MCALL   0,TERPRI\r
18405         PUSH    TP,$TATOM\r
18406         PUSH    TP,EQUOTE [LISTENING-AT-LEVEL ]\r
18407         MCALL   1,PRINC         ;PRINT LEVEL\r
18408         PUSH    TP,$TFIX        ;READY TO PRINT LEVEL\r
18409         HRRZ    A,(P)           ;GET LEVEL\r
18410         SUB     P,[2,,2]        ;AND POP STACK\r
18411         PUSH    TP,A\r
18412         MCALL   1,PRIN1         ;PRINT WITHOUT SPACES ETC.\r
18413         PUSH    TP,$TATOM       ;NOW PROCESS\r
18414         PUSH    TP,EQUOTE [ PROCESS ]\r
18415         MCALL   1,PRINC         ;DONT SLASHIFY SPACES\r
18416         PUSH    TP,PROCID(PVP)  ;NOW ID\r
18417         PUSH    TP,PROCID+1(PVP)\r
18418         MCALL   1,PRIN1\r
18419         SKIPN   C,CURPRI\r
18420         JRST    MAINLP\r
18421         PUSH    TP,$TFIX\r
18422         PUSH    TP,C\r
18423         PUSH    TP,$TATOM\r
18424         PUSH    TP,EQUOTE [ INT-LEVEL ]\r
18425         MCALL   1,PRINC\r
18426         MCALL   1,PRIN1\r
18427         JRST    MAINLP          ; FALL INTO MAIN LOOP\r
18428         \r
18429 \f;ROUTINES FOR ERROR-LISTEN\r
18430 \r
18431 OBCHK:  GETYP   0,A\r
18432         CAIN    0,TOBLS\r
18433         JRST    CPOPJ1          ; WIN FOR SINGLE OBLIST\r
18434         CAIE    0,TLIST         ; IF LIST, MAKE SURE EACH IS AN OBLIST\r
18435         JRST    CPOPJ           ; ELSE, LOSE\r
18436 \r
18437         JUMPE   B,CPOPJ         ; NIL ,LOSE\r
18438         PUSH    TP,A\r
18439         PUSH    TP,B\r
18440         PUSH    P,[0]           ;FLAG FOR DEFAULT CHECKING\r
18441         MOVEI   0,1000          ; VERY BIG NUMBER FOR CIRCULARITY TEST\r
18442 \r
18443 OBCHK0: INTGO\r
18444         SOJE    0,OBLOSE        ; CIRCULARITY TEST\r
18445         HRRZ    B,(TP)          ; GET LIST POINTER\r
18446         GETYP   A,(B)\r
18447         CAIE    A,TOBLS         ; SKIP IF WINNER\r
18448         JRST    DEFCHK          ; CHECK FOR SPECIAL ATOM DEFAULT\r
18449         HRRZ    B,(B)\r
18450         MOVEM   B,(TP)\r
18451         JUMPN   B,OBCHK0\r
18452 OBWIN:  AOS     (P)-1\r
18453 OBLOSE: SUB     TP,[2,,2]\r
18454         SUB     P,[1,,1]\r
18455         POPJ    P,\r
18456 \r
18457 DEFCHK: SKIPN   (P)             ; BEEN HERE BEFORE ?\r
18458         CAIE    A,TATOM         ; OR, NOT AN ATOM ?\r
18459         JRST    OBLOSE          ; YES, LOSE\r
18460         MOVE    A,(B)+1\r
18461         CAME    A,MQUOTE DEFAULT\r
18462         JRST    OBLOSE          ; LOSE\r
18463         SETOM   (P)             ; SET FLAG\r
18464         HRRZ    B,(B)           ; CHECK FOR END OF LIST\r
18465         MOVEM   B,(TP)\r
18466         JUMPN   B,OBCHK0                ; NOT THE END, CONTINUE LOOKING\r
18467         JRST    OBLOSE          ; LOSE FOR DEFAULT AT THE END\r
18468 \r
18469 \r
18470 \r
18471 PUSH6:  PUSH    TP,[TATOM,,-1]\r
18472         PUSH    TP,B\r
18473         PUSH    TP,(C)\r
18474         PUSH    TP,1(C)\r
18475         PUSH    TP,[0]\r
18476         PUSH    TP,[0]\r
18477         POPJ    P,\r
18478 \r
18479 \r
18480 MAKOB:  PUSH    TP,INITIAL(TVP)\r
18481         PUSH    TP,INITIAL+1(TVP)\r
18482         PUSH    TP,ROOT(TVP)\r
18483         PUSH    TP,ROOT+1(TVP)\r
18484         MCALL   2,LIST\r
18485         PUSH    TP,$TATOM\r
18486         PUSH    TP,IMQUOTE OBLIST\r
18487         PUSH    TP,A\r
18488         PUSH    TP,B\r
18489         MCALL   2,SETG\r
18490         PUSH    TP,[TATOM,,-1]\r
18491         PUSH    TP,IMQUOTE OBLIST\r
18492         PUSH    TP,A\r
18493         PUSH    TP,B\r
18494         PUSH    TP,[0]\r
18495         PUSH    TP,[0]\r
18496         JRST    NOTOBL\r
18497 \f\r
18498 \r
18499 ;THIS IS IT FOLKS...THE MAIN LOOP.  READ, EVAL, PRINT\r
18500 \r
18501 MAINLP: MOVE    A,$TATOM        ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE\r
18502         MOVE    B,MQUOTE REP\r
18503         PUSHJ   P,ILVAL         ;GET ITS LVAL TO SEE IF REDEFINED\r
18504         GETYP   C,A\r
18505         CAIE    C,TUNBOUND\r
18506         JRST    REPCHK\r
18507         MOVE    A,$TATOM        ;SEE IF IT HAS GVAL SINCE NO LVAL\r
18508         MOVE    B,MQUOTE REP\r
18509         PUSHJ   P,IGVAL\r
18510         GETYP   C,A\r
18511         CAIN    C,TUNBOUN\r
18512         JRST    IREPER\r
18513 REPCHK: CAIN    C,TSUBR\r
18514         CAIE    B,REPER\r
18515         JRST    .+2\r
18516         JRST    IREPER\r
18517 REREPE: PUSH    TP,A\r
18518         PUSH    TP,B\r
18519         GETYP   A,-1(TP)\r
18520         PUSHJ   P,APLQ\r
18521         JRST    ERRREP\r
18522         MCALL   1,APPLY         ;LOOSER HAS REDEFINED SO CALL HIS\r
18523         JRST    MAINLP\r
18524 IREPER: PUSH    P,[0]           ;INDICATE FALL THROUGH\r
18525         JRST    REPERF\r
18526 \r
18527 ERRREP: PUSH    TP,[TATOM,,-1]\r
18528         PUSH    TP,MQUOTE REP\r
18529         PUSH    TP,$TSUBR\r
18530         PUSH    TP,[REPER]\r
18531         PUSH    TP,[0]\r
18532         PUSH    TP,[0]\r
18533         PUSHJ   P,SPECBIN\r
18534         PUSH    TP,$TATOM\r
18535         PUSH    TP,EQUOTE NON-APPLICABLE-REP\r
18536         PUSH    TP,-11(TP)\r
18537         PUSH    TP,-11(TP)\r
18538         MCALL   2,ERROR\r
18539         SUB     TP,[6,,6]\r
18540         PUSHJ   P,SSPECS\r
18541         JRST    REREPE\r
18542 \r
18543 \r
18544 MFUNCTION REPER,SUBR,REP\r
18545 REPER:  ENTRY   0\r
18546         PUSH    P,[1]           ;INDICATE DIRECT CALL\r
18547 REPERF: MCALL   0,TERPRI\r
18548         MCALL   0,READ\r
18549         PUSH    TP,A\r
18550         PUSH    TP,B\r
18551         MCALL   0,TERPRI\r
18552         MCALL   1,EVAL\r
18553         PUSH    TP,$TATOM\r
18554         PUSH    TP,IMQUOTE LAST-OUT\r
18555         PUSH    TP,A\r
18556         PUSH    TP,B\r
18557         MCALL   2,SET\r
18558         PUSH    TP,A\r
18559         PUSH    TP,B\r
18560         MCALL   1,PRIN1\r
18561         POP     P,C             ;FLAG FOR FALL THROUGH OR CALL\r
18562         JUMPN   C,FINIS         ;IN CASE LOOSER CALLED REP\r
18563         JRST    MAINLP\r
18564 \r
18565 \f\r
18566 ;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL\r
18567 \r
18568 MFUNCTION RETRY,SUBR\r
18569 \r
18570         ENTRY\r
18571         JUMPGE  AB,RETRY1       ; USE MOST RECENT\r
18572         CAMGE   AB,[-2,,0]\r
18573         JRST    TMA\r
18574         GETYP   A,(AB)          ; CHECK TYPE\r
18575         CAIE    A,TFRAME\r
18576         JRST    WTYP1\r
18577         MOVEI   B,(AB)          ; POINT TO ARG\r
18578         JRST    RETRY2\r
18579 RETRY1: MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
18580         PUSHJ   P,ILOC          ; LOCATIVE TO FRAME\r
18581 RETRY2: PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY\r
18582         HRRZ    0,OTBSAV(B)     ; CHECK FOR TOP\r
18583         JUMPE   0,RESTAR        ; YES RE-ENTER TOP LEVEL\r
18584         PUSH    TP,$TTB\r
18585         PUSH    TP,B            ; SAVE FRAME\r
18586         MOVE    B,OTBSAV(B)     ; GET PRVIOUS FOR UNBIND HACK\r
18587         MOVEI   C,-1(TP)\r
18588         PUSHJ   P,CHUNW         ; CHECK ANY UNWINDING\r
18589         CAME    SP,SPSAV(TB)    ; UNBINDING NEEDED?\r
18590         PUSHJ   P,SPECSTORE\r
18591         MOVE    P,PSAV(TB)      ; GET OTHER STUFF\r
18592         MOVE    AB,ABSAV(B)\r
18593         HLRE    A,AB            ; COMPUTE # OF ARGS\r
18594         MOVNI   A,-FRAMLN(A)    ; MAKE TP POINT PAST FRAME\r
18595         HRLI    A,(A)\r
18596         MOVE    C,TPSAV(TB)     ; COMPUTE TP\r
18597         ADD     C,A\r
18598         MOVE    TP,C\r
18599         MOVE    TB,B            ; FIX UP TB\r
18600         HRRZ    C,FSAV(TB)      ; GET FUNCTION\r
18601         CAMGE   C,VECTOP        ; CHECK FOR RSUBR\r
18602         CAMG    C,VECBOT\r
18603         JRST    (C)             ; GO\r
18604         GETYP   0,(C)           ; RSUBR OR ENTRY?\r
18605         CAIE    0,TATOM\r
18606         CAIN    0,TRSUBR\r
18607         JRST    RETRNT\r
18608         MOVS    R,(C)           ; SET UP R\r
18609         HRRI    R,(C)\r
18610         MOVEI   C,0\r
18611         JRST    RETRN3\r
18612 \r
18613 RETRNT: CAIE    0,TRSUBR\r
18614         JRST    RETRN1\r
18615         MOVE    R,1(C)\r
18616 RETRN4: HRRZ    C,2(C)          ; OFFSET\r
18617 RETRN3: SKIPL   M,1(R)\r
18618         JRST    RETRN5\r
18619 RETRN7: ADDI    C,(M)\r
18620         JRST    (C)\r
18621 \r
18622 RETRN5: MOVEI   D,(M)           ; TOTAL OFFSET\r
18623         MOVSS   M\r
18624         ADD     M,PURVEC+1(TVP)\r
18625         SKIPL   M,1(M)\r
18626         JRST    RETRN6\r
18627         ADDI    M,(D)\r
18628         JRST    RETRN7\r
18629 RETRN6: HLRZ    A,1(R)\r
18630         PUSH    P,D\r
18631         PUSH    P,C\r
18632         PUSHJ   P,PLOAD\r
18633         JRST    RETRER          ; LOSER\r
18634         POP     P,C\r
18635         POP     P,D\r
18636         MOVE    M,B\r
18637         JRST    RETRN7\r
18638 \r
18639 RETRN1: MOVE    B,1(C)\r
18640         PUSH    TP,$TVEC\r
18641         PUSH    TP,C\r
18642         PUSHJ   P,IGVAL\r
18643         GETYP   0,A\r
18644         MOVE    C,(TP)\r
18645         SUB     TP,[2,,2]\r
18646         CAIE    0,TRSUBR\r
18647         JRST    RETRN2\r
18648         MOVE    R,B\r
18649         JRST    RETRN3\r
18650 \r
18651 RETRN2: PUSH    TP,$TATOM\r
18652         PUSH    TP,EQUOTE CANT-RETRY-ENTRY-GONE\r
18653         JRST    CALER1\r
18654 \r
18655 RETRER: PUSH    TP,$TATOM\r
18656         PUSH    TP,EQUOTE PURE-LOAD-FAILURE\r
18657         JRST    CALER1\r
18658 \r
18659 \f\r
18660 ;FUNCTION TO DO ERROR RETURN\r
18661 \r
18662 MFUNCTION ERRET,SUBR\r
18663 \r
18664         ENTRY\r
18665         HLRE    A,AB            ; -2*# OF ARGS\r
18666         JUMPGE  A,STP           ; RESTART PROCESS\r
18667         ASH     A,-1            ; -# OF ARGS\r
18668         AOJE    A,ERRET2        ; NO FRAME SUPPLIED\r
18669         AOJL    A,TMA\r
18670         ADD     AB,[2,,2]\r
18671         PUSHJ   P,OKFRT\r
18672         JRST    WTYP2\r
18673         SUB     AB,[2,,2]\r
18674         PUSHJ   P,CHPROC        ; POINT TO FRAME SLOT\r
18675         JRST    ERRET3\r
18676 ERRET2: MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
18677         PUSHJ   P,ILVAL         ; GET ITS VALUE\r
18678 ERRET3: PUSH    TP,A\r
18679         PUSH    TP,B\r
18680         MOVEI   B,-1(TP)\r
18681         PUSHJ   P,CHFSWP        ; CHECK VALIDITY AND SWAP IF NECESSARY\r
18682         HRRZ    0,OTBSAV(B)     ; TOP LEVEL?\r
18683         JUMPE   0,TOPLOS\r
18684         PUSHJ   P,CHUNW         ; ANY UNWINDING\r
18685         JRST    CHFINIS\r
18686 \r
18687 \r
18688 ; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME\r
18689 \r
18690 MFUNCTION       FRAME,SUBR\r
18691         ENTRY\r
18692         SETZB   A,B\r
18693         JUMPGE  AB,FRM1         ; DEFAULT CASE\r
18694         CAMG    AB,[-3,,0]      ; SKIP IF OK ARGS\r
18695         JRST    TMA\r
18696         PUSHJ   P,OKFRT         ; A FRAME OR SIMILAR THING?\r
18697         JRST    WTYP1\r
18698 \r
18699 FRM1:   PUSHJ   P,CFRAME        ; GO TO INTERNAL\r
18700         JRST    FINIS\r
18701 \r
18702 CFRAME: JUMPN   A,FRM2          ; ARG SUPPLIED?\r
18703         MOVE    B,IMQUOTE LER,[LERR ]INTRUP\r
18704         PUSHJ   P,ILVAL\r
18705         JRST    FRM3\r
18706 FRM2:   PUSHJ   P,CHPROC        ; CHECK FOR PROCESS\r
18707         PUSH    TP,A\r
18708         PUSH    TP,B\r
18709         MOVEI   B,-1(TP)        ; POINT TO SLOT\r
18710         PUSHJ   P,CHFRM         ; CHECK IT\r
18711         MOVE    C,(TP)          ; GET FRAME BACK\r
18712         MOVE    B,OTBSAV(C)     ;GET PREVIOUS FRAME\r
18713         SUB     TP,[2,,2]\r
18714         TRNN    B,-1            ; SKIP IF OK\r
18715         JRST    TOPLOSE\r
18716 \r
18717 FRM3:   JUMPN   B,FRM4  ; JUMP IF WINNER\r
18718         MOVE    B,IMQUOTE THIS-PROCESS\r
18719         PUSHJ   P,ILVAL         ; GET PROCESS OF INTEREST\r
18720         GETYP   A,A             ; CHECK IT\r
18721         CAIN    A,TUNBOU\r
18722         MOVE    B,PVP           ; USE CURRENT\r
18723         MOVEI   A,PVLNT*2+1(B)  ; POINT TO DOPE WORDS\r
18724         MOVE    B,TBINIT+1(B)   ; AND BASE FRAME\r
18725 FRM4:   HLL     B,OTBSAV(B)     ;TIME\r
18726         HRLI    A,TFRAME\r
18727         POPJ    P,\r
18728 \r
18729 OKFRT:  AOS     (P)             ;ASSUME WINNAGE\r
18730         GETYP   0,(AB)\r
18731         MOVE    A,(AB)\r
18732         MOVE    B,1(AB)\r
18733         CAIE    0,TFRAME\r
18734         CAIN    0,TENV\r
18735         POPJ    P,\r
18736         CAIE    0,TPVP\r
18737         CAIN    0,TACT\r
18738         POPJ    P,\r
18739         SOS     (P)\r
18740         POPJ    P,\r
18741 \r
18742 CHPROC: GETYP   0,A             ; TYPE\r
18743         CAIE    0,TPVP\r
18744         POPJ    P,              ; OK\r
18745         MOVEI   A,PVLNT*2+1(B)\r
18746         CAMN    B,PVP           ; THIS PROCESS?\r
18747         JRST    CHPRO1\r
18748         MOVE    B,TBSTO+1(B)\r
18749         JRST    FRM4\r
18750 \r
18751 CHPRO1: MOVE    B,OTBSAV(TB)\r
18752         JRST    FRM4\r
18753 \r
18754 ; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME\r
18755 \r
18756 MFUNCTION       ARGS,SUBR\r
18757         ENTRY   1\r
18758         PUSHJ   P,OKFRT         ; CHECK FRAME TYPE\r
18759         JRST    WTYP1\r
18760         PUSHJ   P,CARGS\r
18761         JRST    FINIS\r
18762 \r
18763 CARGS:  PUSHJ   P,CHPROC\r
18764         PUSH    TP,A\r
18765         PUSH    TP,B\r
18766         MOVEI   B,-1(TP)        ; POINT TO FRAME SLOT\r
18767         PUSHJ   P,CHFRM         ; AND CHECK FOR VALIDITY\r
18768         MOVE    C,(TP)          ; FRAME BACK\r
18769         MOVSI   A,TARGS\r
18770 CARGS1: GETYP   0,FSAV(C)       ; IS THIS A FUNNY ONE\r
18771         CAIE    0,TCBLK         ; SKIP IF FUNNY\r
18772         JRST    .+3             ; NO NORMAL\r
18773         MOVE    C,OTBSAV(C)     ; ASSOCIATE WITH PREVIOUS FRAME\r
18774         JRST    CARGS1\r
18775         HLR     A,OTBSAV(C)     ; TIME IT AND\r
18776         MOVE    B,ABSAV(C)      ; GET POINTER\r
18777         SUB     TP,[2,,2]       ; FLUSH CRAP\r
18778         POPJ    P,\r
18779 \r
18780 ; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME\r
18781 \r
18782 MFUNCTION       FUNCT,SUBR      ;RETURNS FUNCTION NAME OF\r
18783         ENTRY   1       ; FRAME ARGUMENT\r
18784         PUSHJ   P,OKFRT         ; CHECK TYPE\r
18785         JRST    WTYP1\r
18786         PUSHJ   P,CFUNCT\r
18787         JRST    FINIS\r
18788 \r
18789 CFUNCT: PUSHJ   P,CHPROC\r
18790         PUSH    TP,A\r
18791         PUSH    TP,B\r
18792         MOVEI   B,-1(TP)\r
18793         PUSHJ   P,CHFRM         ; CHECK IT\r
18794         MOVE    C,(TP)          ; RESTORE FRAME\r
18795         HRRZ    A,FSAV(C)       ;FUNCTION POINTER\r
18796         CAMG    A,VECTOP        ;IS THIS AN RSUBR ?\r
18797         CAMGE   A,VECBOT\r
18798         SKIPA   B,@-1(A)        ;NO, GET SUBR'S NAME POINTER\r
18799         MOVE    B,(A)+3         ;YES, GET RSUBR'S NAME ENTRY\r
18800         MOVSI   A,TATOM\r
18801         SUB     TP,[2,,2]\r
18802         POPJ    P,\r
18803 \r
18804 BADFRAME:\r
18805         PUSH    TP,$TATOM\r
18806         PUSH    TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
18807         JRST    CALER1\r
18808 \r
18809 \r
18810 TOPLOSE:\r
18811         PUSH    TP,$TATOM\r
18812         PUSH    TP,EQUOTE TOP-LEVEL-FRAME\r
18813         JRST    CALER1\r
18814 \r
18815 \r
18816 \f\r
18817 \f\r
18818 ; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED\r
18819 \r
18820 MFUNCTION       HANG,SUBR\r
18821 \r
18822         ENTRY\r
18823 \r
18824         JUMPGE  AB,HANG1        ; NO PREDICATE\r
18825         CAMGE   AB,[-3,,]\r
18826         JRST    TMA\r
18827 REHANG: MOVE    A,[PUSHJ P,CHKPRH]\r
18828         MOVEM   A,ONINT         ; CHECK PREDICATE AFTER ANY INTERRUPT\r
18829         PUSH    TP,(AB)\r
18830         PUSH    TP,1(AB)\r
18831 HANG1:  ENABLE                  ;LET OURSELVES BE INTERRUPTED OUT\r
18832         PUSHJ   P,%HANG\r
18833         DISABLE                 ;PREVENT INTERRUPTS AT RANDOM TIMES\r
18834         SETZM   ONINT\r
18835         MOVE    A,$TATOM\r
18836         MOVE    B,MQUOTE T\r
18837         JRST    FINIS\r
18838 \r
18839 \r
18840 ; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED\r
18841 ; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE\r
18842 \r
18843 MFUNCTION       SLEEP,SUBR\r
18844 \r
18845         ENTRY\r
18846 \r
18847         JUMPGE  AB,TFA\r
18848         CAML    AB,[-3,,]\r
18849         JRST    SLEEP1\r
18850         CAMGE   AB,[-5,,]\r
18851         JRST    TMA\r
18852         PUSH    TP,2(AB)\r
18853         PUSH    TP,3(AB)\r
18854 SLEEP1: GETYP   0,(AB)\r
18855         CAIE    0,TFIX\r
18856         JRST    .+5\r
18857         MOVE    B,1(AB)\r
18858         JUMPL   B,OUTRNG        ;ARG SHOULDNT BE NEGATIVE\r
18859         IMULI   B,30.           ;CONVERT TO # OF THIRTIETHS OF A SECOND\r
18860         JRST    SLEEPR          ;GO SLEEP\r
18861         CAIE    0,TFLOAT        ;IF IT WASNT FIX MAKE SURE IT IS FLOAT\r
18862         JRST    WTYP1           ;WRONG TYPE ARG\r
18863         MOVE    B,1(AB)\r
18864         FMPR    B,[30.0]        ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND\r
18865         MULI    B,400           ;KLUDGE TO FIX IT\r
18866         TSC     B,B\r
18867         ASH     C,(B)-243\r
18868         MOVE    B,C             ;MOVE THE FIXED NUMBER INTO B\r
18869         JUMPL   B,OUTRNG        ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER\r
18870 SLEEPR: MOVE    A,B\r
18871 RESLEE: MOVE    B,[PUSHJ P,CHKPRS]\r
18872         CAMGE   AB,[-3,,]\r
18873         MOVEM   B,ONINT\r
18874         ENABLE\r
18875         PUSHJ   P,%SLEEP\r
18876         DISABLE\r
18877         SETZM   ONINT\r
18878         MOVE    A,$TATOM\r
18879         MOVE    B,MQUOTE T\r
18880         JRST    FINIS\r
18881 \r
18882 CHKPRH: PUSH    P,B\r
18883         MOVEI   B,HANGP\r
18884         JRST    .+3\r
18885 \r
18886 CHKPRS: PUSH    P,B\r
18887         MOVEI   B,SLEEPP\r
18888         HRRM    B,LCKINT\r
18889         SETZM   ONINT           ; TURN OFF FEATURE FOR NOW\r
18890         POP     P,B\r
18891         POPJ    P,\r
18892 \r
18893 HANGP:  SKIPA   B,[REHANG]\r
18894 SLEEPP: MOVEI   B,RESLEE\r
18895         PUSH    P,B\r
18896         PUSH    P,A\r
18897         DISABLE\r
18898         PUSH    TP,(TB)\r
18899         PUSH    TP,1(TB)\r
18900         MCALL   1,EVAL\r
18901         GETYP   0,A\r
18902         CAIE    0,TFALSE\r
18903         JRST    FINIS\r
18904         POP     P,A\r
18905         POPJ    P,\r
18906 \r
18907 MFUNCTION       VALRET,SUBR\r
18908 ; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS\r
18909 \r
18910         ENTRY   1\r
18911         GETYP   A,(AB)          ; GET TYPE OF ARGUMENT\r
18912         CAIE    A,TCHSTR        ; IS IT A CHR STRING?\r
18913         JRST    WTYP1           ; NO...ERROR WRONG TYPE\r
18914         PUSHJ   P,CSTACK        ; COPY THE CHR STRING TO THE STACK\r
18915                                         ; CSTACK IS IN ATOMHK\r
18916         MOVEI   B,0             ; ASCIZ TERMINATOR\r
18917         EXCH    B,(P)           ; STORE AND RETRIEVE COUNT\r
18918 \r
18919 ; CALCULATE THE BEGINNING ADDR OF THE STRING\r
18920         MOVEI   A,-1(P)         ; GET ADDR OF TOP OF STACK\r
18921         SUBI    A,-1(B)         ; GET STARTING ADDR\r
18922         PUSHJ   P,%VALRE        ; PASS UP TO MONITOR\r
18923         JRST    IFALSE          ; IF HE RETURNS, RETURN FALSE\r
18924 \r
18925 \r
18926 MFUNCTION       LOGOUT,SUBR\r
18927 \r
18928 ; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)\r
18929         ENTRY   0\r
18930         PUSHJ   P,%TOPLQ        ; SKIP IF AT TOP LEVEL\r
18931         JRST    IFALSE\r
18932         PUSHJ   P,CLOSAL\r
18933         PUSHJ   P,%LOGOUT       ; TRY TO FLUSH\r
18934         JRST    IFALSE          ; COULDN'T DO IT...RETURN FALSE\r
18935 \r
18936 ; FUNCTS TO GET UNAME AND JNAME\r
18937 \r
18938 MFUNCTION UNAME,SUBR\r
18939 \r
18940         ENTRY   0\r
18941 \r
18942         PUSHJ   P,%RUNAM\r
18943         JRST    RSUJNM\r
18944 \r
18945 MFUNCTION JNAME,SUBR\r
18946 \r
18947         ENTRY   0\r
18948 \r
18949         PUSHJ   P,%RJNAM\r
18950         JRST    RSUJNM\r
18951 \r
18952 ; FUNCTION TO SET AND READ GLOBAL SNAME\r
18953 \r
18954 MFUNCTION SNAME,SUBR\r
18955 \r
18956         ENTRY\r
18957 \r
18958         JUMPGE  AB,SNAME1\r
18959         CAMG    AB,[-3,,]\r
18960         JRST    TMA\r
18961         GETYP   A,(AB)          ; ARG MUST BE STRING\r
18962         CAIE    A,TCHSTR\r
18963         JRST    WTYP1\r
18964         PUSH    TP,$TATOM\r
18965         PUSH    TP,IMQUOTE SNM\r
18966         PUSH    TP,(AB)\r
18967         PUSH    TP,1(AB)\r
18968         MCALL   2,SETG\r
18969         JRST    FINIS\r
18970 \r
18971 SNAME1: MOVE    B,IMQUOTE SNM\r
18972         PUSHJ   P,IDVAL1\r
18973         GETYP   0,A\r
18974         CAIN    0,TCHSTR\r
18975         JRST    FINIS\r
18976         MOVE    A,$TCHSTR\r
18977         MOVE    B,CHQUOTE\r
18978         JRST    FINIS\r
18979 \r
18980 RSUJNM: PUSHJ   P,6TOCHS        ; CONVERT IT\r
18981         JRST    FINIS\r
18982 \r
18983 \r
18984 SGSNAM: MOVE    B,IMQUOTE SNM\r
18985         PUSHJ   P,IDVAL1\r
18986         GETYP   0,A\r
18987         CAIE    0,TCHSTR\r
18988         JRST    SGSN1\r
18989 \r
18990         PUSH    TP,A\r
18991         PUSH    TP,B\r
18992         PUSHJ   P,STRTO6\r
18993         POP     P,A\r
18994         SUB     TP,[2,,2]\r
18995         JRST    .+2\r
18996 \r
18997 SGSN1:  MOVEI   A,0\r
18998         PUSHJ   P,%SSNAM        ; SET SNAME IN SYSTEM\r
18999         POPJ    P,\r
19000 \r
19001 \f\r
19002 \r
19003 ;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND\r
19004 ;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.\r
19005 \r
19006 ICR:    MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP\r
19007         PUSHJ   P,IVECT         ;GOBBLE A VECTOR\r
19008         HRLI    C,PVBASE        ;SETUP A BLT POINTER\r
19009         HRRI    C,(B)           ;GET INTO ADDRESS\r
19010         BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP\r
19011         MOVSI   C,400000+SPVP+.VECT.    ;SET SPECIAL TYPE\r
19012         MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN\r
19013         PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR\r
19014         PUSH    TP,B\r
19015 \r
19016         PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR\r
19017         PUSH    TP,[PLNT]\r
19018         MCALL   1,UVECTOR\r
19019         ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER\r
19020         MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER\r
19021         MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES\r
19022         MOVEM   B,PBASE+1(C)\r
19023 \r
19024 \r
19025         MOVEI   A,TPLNT         ;PREPARE TO CREATE A TEMPORARY PDL\r
19026         PUSHJ   P,IVECT         ;GET THE TEMP PDL\r
19027         ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK\r
19028         MOVE    C,(TP)          ;RE-GOBBLE NEW PVP\r
19029         SUB     B,[1,,1]        ;FIX FOR STACK\r
19030         MOVEM   B,TPBASE+1(C)\r
19031 \r
19032 ;SETUP INITIAL BINDING\r
19033 \r
19034         PUSH    B,$TBIND\r
19035         MOVEM   B,SPBASE+1(C)   ;SAVE AS BASE OF SP\r
19036         MOVEM   B,SPSTO+1(C)    ;AND CURRENT THEREOF\r
19037         MOVEM   B,CURFCN+1(C)   ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC\r
19038         PUSH    B,IMQUOTE THIS-PROCESS\r
19039         PUSH    B,$TPVP ;GIVE IT PROCESS AS VALUE\r
19040         PUSH    B,C\r
19041         ADD     B,[2,,2]        ;FINISH FRAME\r
19042         MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER\r
19043         MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF\r
19044         MOVEM   TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR\r
19045         AOS     A,IDPROC                ;GOBBLE A UNIQUE PROCESS I.D.\r
19046         MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO\r
19047         AOS     A,PTIME         ; GET A UNIQUE BINDING ID\r
19048         MOVEM   A,BINDID+1(C)\r
19049 \r
19050         MOVSI   A,TPVP          ;CLOBBER THE TYPE\r
19051         MOVE    B,(TP)          ;AND POINTER TO PROCESS\r
19052         SUB     TP,[2,,2]\r
19053         POPJ    P,\r
19054 \r
19055 ;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A\r
19056 \r
19057 IVECT:  PUSH    TP,$TFIX\r
19058         PUSH    TP,A\r
19059         MCALL   1,VECTOR        ;GOBBLE THE VECTOR\r
19060         POPJ    P,\r
19061 \r
19062 \r
19063 ;SUBROUTINE TO SWAP A PROCESS IN\r
19064 ;CALLED WITH JSP A,SWAP AND NEW PVP IN B\r
19065 \r
19066 SWAP:                           ;FIRST STORE ALL THE ACS\r
19067 \r
19068         IRP     A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
19069         MOVEM   A,A!STO+1(PVP)\r
19070         TERMIN\r
19071 \r
19072         SETOM   1(TP)           ; FENCE POST MAIN STACK\r
19073         MOVEM   TP,TPSAV(TB)    ; CORRECT FRAME\r
19074         SETZM   PSAV(TB)        ; CLEAN UP CURRENT FRAME\r
19075         SETZM   SPSAV(TB)\r
19076         SETZM   PCSAV(TB)\r
19077 \r
19078         MOVE    E,PVP   ;RETURN OLD PROCESS IN E\r
19079         MOVE    PVP,D   ;AND MAKE NEW ONE BE D\r
19080 \r
19081 SWAPIN:\r
19082         ;NOW RESTORE NEW PROCESSES AC'S\r
19083 \r
19084         IRP     A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
19085         MOVE    A,A!STO+1(PVP)\r
19086         TERMIN\r
19087 \r
19088         JRST    (C)             ;AND RETURN\r
19089 \r
19090 \r
19091 \f\r
19092 \r
19093 ;SUBRS ASSOCIATED WITH TYPES\r
19094 \r
19095 ;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE\r
19096 ;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.\r
19097 \r
19098 SAT:    LSH     A,1             ;TIMES 2 TO REF VECTOR\r
19099         HRLS    A               ;TO BOTH HALVES TO HACK AOBJN POINTER\r
19100         ADD     A,TYPVEC+1(TVP) ;ACCESS THE VECTOR\r
19101         HRR     A,(A)           ;GET PROBABLE SAT\r
19102         JUMPL   A,.+2           ;DID WE REALLY HAVE A VALID TYPE\r
19103         MOVEI   A,0             ;NO RETURN 0\r
19104         ANDI    A,SATMSK\r
19105         POPJ    P,              ;AND RETURN\r
19106 \r
19107 ;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE\r
19108 ;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.\r
19109 ;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID\r
19110 ;TYPECODE.\r
19111 MFUNCTION TYPE,SUBR\r
19112 \r
19113         ENTRY   1\r
19114         GETYP   A,(AB)          ;TYPE INTO A\r
19115 TYPE1:  PUSHJ   P,ITYPE         ;GO TO INTERNAL\r
19116         JUMPN   B,FINIS         ;GOOD RETURN\r
19117 TYPERR: PUSH    TP,$TATOM       ;SETUP ERROR CALL\r
19118         PUSH    TP,EQUOTE TYPE-UNDEFINED\r
19119         JRST    CALER1"         ;STANDARD ERROR HACKER\r
19120 \r
19121 CITYPE: GETYP   A,A             ; GET TYPE FOR COMPILER CALL\r
19122 ITYPE:  LSH     A,1             ;TIMES 2\r
19123         HRLS    A               ;TO BOTH SIDES\r
19124         ADD     A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION\r
19125         JUMPGE  A,TYPERR        ;LOST, TYPE OUT OF BOUNDS\r
19126         MOVE    B,1(A)          ;PICKUP TYPE\r
19127         HLLZ    A,(A)\r
19128         POPJ    P,\r
19129 \r
19130 ; PREDICATE -- IS OBJECT OF TYPE SPECIFIED\r
19131 \r
19132 MFUNCTION %TYPEQ,SUBR,[TYPE?]\r
19133 \r
19134         ENTRY\r
19135 \r
19136         MOVE    D,AB            ; GET ARGS\r
19137         ADD     D,[2,,2]\r
19138         JUMPGE  D,TFA\r
19139         MOVE    A,(AB)\r
19140         HLRE    C,D\r
19141         MOVMS   C\r
19142         ASH     C,-1            ; FUDGE\r
19143         PUSHJ   P,ITYPQ         ; GO INTERNAL\r
19144         JFCL\r
19145         JRST    FINIS\r
19146 \r
19147 ITYPQ:  GETYP   A,A             ; OBJECT\r
19148         PUSHJ   P,ITYPE\r
19149 TYPEQ0: SOJL    C,CIFALS\r
19150         GETYP   0,(D)\r
19151         CAIE    0,TATOM         ; Type name must be an atom\r
19152         JRST    WRONGT\r
19153         CAMN    B,1(D)          ; Same as the OBJECT?\r
19154         JRST    CPOPJ1          ; Yes, return type name\r
19155         ADD     D,[2,,2]\r
19156         JRST    TYPEQ0          ; No, continue comparing\r
19157 \r
19158 CIFALS: MOVEI   B,0\r
19159         MOVSI   A,TFALSE\r
19160         POPJ    P,\r
19161 \r
19162 CTYPEQ: SOJE    A,CIFALS        ; TREAT NO ARGS AS FALSE\r
19163         MOVEI   D,1(A)          ; FIND BASE OF ARGS\r
19164         ASH     D,1\r
19165         HRLI    D,(D)\r
19166         SUBM    TP,D            ; D POINTS TO BASE\r
19167         MOVE    E,D             ; SAVE FOR TP RESTORE\r
19168         ADD     D,[3,,3]        ; FUDGE\r
19169         MOVEI   C,(A)           ; NUMBER OF TYPES\r
19170         MOVE    A,-2(D)\r
19171         PUSHJ   P,ITYPQ\r
19172         JFCL            ; IGNORE SKIP FOR NOW\r
19173         MOVE    TP,E            ; SET TP BACK\r
19174         JUMPL   B,CPOPJ1        ; SKIP\r
19175         POPJ    P,\r
19176 \f\r
19177 ; Entries to get type codes for types for fixing up RSUBRs and assembling\r
19178 \r
19179 MFUNCTION %TYPEC,SUBR,[TYPE-C]\r
19180 \r
19181         ENTRY\r
19182 \r
19183         JUMPGE  AB,TFA\r
19184         GETYP   0,(AB)\r
19185         CAIE    0,TATOM\r
19186         JRST    WTYP1\r
19187         MOVE    B,1(AB)\r
19188         CAMGE   AB,[-3,,0]      ; skip if only type name given\r
19189         JRST    GTPTYP\r
19190         MOVE    C,MQUOTE ANY\r
19191 \r
19192 TYPEC1: PUSHJ   P,CTYPEC        ; go to internal\r
19193         JRST    FINIS\r
19194 \r
19195 GTPTYP: CAMGE   AB,[-5,,0]\r
19196         JRST    TMA\r
19197         GETYP   0,2(AB)\r
19198         CAIE    0,TATOM\r
19199         JRST    WTYP2\r
19200         MOVE    C,3(AB)\r
19201         JRST    TYPEC1\r
19202 \r
19203 CTYPEC: PUSH    P,C             ; save primtype checker\r
19204         PUSHJ   P,TYPLOO        ; search type vector\r
19205         POP     P,B\r
19206         CAMN    B,MQUOTE ANY\r
19207         JRST    CTPEC1\r
19208         PUSH    P,D\r
19209         HRRZ    A,(A)\r
19210         ANDI    A,SATMSK\r
19211         PUSH    P,A\r
19212         PUSHJ   P,TYPLOO\r
19213         HRRZ    0,(A)\r
19214         ANDI    0,SATMSK\r
19215         CAME    0,(P)\r
19216         JRST    TYPDIF\r
19217         MOVE    D,-1(P)\r
19218         SUB     P,[2,,2]\r
19219 CTPEC1: MOVEI   B,(D)\r
19220         MOVSI   A,TTYPEC\r
19221         POPJ    P,\r
19222 \r
19223 MFUNCTION %TYPEW,SUBR,[TYPE-W]\r
19224 \r
19225         ENTRY\r
19226 \r
19227         JUMPGE  AB,TFA\r
19228         GETYP   0,(AB)\r
19229         CAIE    0,TATOM\r
19230         JRST    WTYP1\r
19231         MOVEI   D,0\r
19232         MOVE    C,MQUOTE ANY\r
19233         MOVE    B,1(AB)\r
19234         CAMGE   AB,[-3,,0]\r
19235         JRST    CTYPW1\r
19236 \r
19237 CTYPW3: PUSHJ   P,CTYPEW\r
19238         JRST    FINIS\r
19239 \r
19240 CTYPW1: GETYP   0,2(AB)\r
19241         CAIE    0,TATOM\r
19242         JRST    WTYP2\r
19243         CAMGE   AB,[-5,,0]      ; JUMP IF RH IS GIVEN\r
19244         JRST    CTYPW2\r
19245         MOVE    C,3(AB)\r
19246         JRST    CTYPW3\r
19247 \r
19248 CTYPW2: CAMGE   AB,[-7,,0]\r
19249         JRST    TMA\r
19250         GETYP   0,4(AB)\r
19251         CAIE    0,TFIX\r
19252         JRST    WRONGT\r
19253         MOVE    D,5(AB)\r
19254         JRST    CTYPW3\r
19255 \r
19256 CTYPEW: PUSH    P,D\r
19257         PUSHJ   P,CTYPEC        ; GET CODE IN B\r
19258         POP     P,B\r
19259         HRLI    B,(D)\r
19260         MOVSI   A,TTYPEW\r
19261         POPJ    P,\r
19262 \f       \r
19263 ;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS\r
19264 \r
19265 STBL:   REPEAT NUMSAT,MQUOTE INTERNAL-TYPE\r
19266 \r
19267 LOC STBL\r
19268 \r
19269 IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]\r
19270 [ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]\r
19271 [PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]\r
19272 [LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]\r
19273 IRP B,C,[A]\r
19274 LOC STBL+S!B\r
19275 MQUOTE C\r
19276 \r
19277 .ISTOP\r
19278 \r
19279 TERMIN\r
19280 TERMIN\r
19281 \r
19282 LOC STBL+NUMSAT+1\r
19283 \r
19284 \r
19285 MFUNCTION TYPEPRIM,SUBR\r
19286 \r
19287         ENTRY   1\r
19288         GETYP   A,(AB)\r
19289         CAIE    A,TATOM\r
19290         JRST    NOTATOM\r
19291         MOVE    B,1(AB)\r
19292         PUSHJ   P,CTYPEP\r
19293         JRST    FINIS\r
19294 \r
19295 CTYPEP: PUSHJ   P,TYPLOO        ; CONVERT ATOM TO CODE\r
19296         HRRZ    A,(A)           ; SAT TO A\r
19297         ANDI    A,SATMSK\r
19298         JRST    PTYP1\r
19299 \r
19300 MFUNCTION PRIMTYPE,SUBR\r
19301 \r
19302         ENTRY   1\r
19303 \r
19304         MOVE    A,(AB)          ;GET TYPE\r
19305         PUSHJ   P,CPTYPE\r
19306         JRST    FINIS\r
19307 \r
19308 CPTYPE: GETYP   A,A\r
19309         PUSHJ   P,SAT           ;GET SAT\r
19310 PTYP1:  JUMPE   A,TYPERR\r
19311         MOVE    B,MQUOTE TEMPLATE\r
19312         CAIG    A,NUMSAT        ; IF BIG SAT, THEN TEMPLATE\r
19313         MOVE    B,@STBL(A)\r
19314         MOVSI   A,TATOM\r
19315         POPJ    P,\r
19316 \f\r
19317 \r
19318 ; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT\r
19319 \r
19320 MFUNCTION RSUBR,SUBR\r
19321         ENTRY   1\r
19322 \r
19323         GETYP   A,(AB)\r
19324         CAIE    A,TVEC          ; MUST BE VECTOR\r
19325         JRST    WTYP1\r
19326         MOVE    B,1(AB)         ; GET IT\r
19327         GETYP   A,(B)           ; CHECK 1ST ELEMENTS TYPE\r
19328         CAIN    A,TPCODE        ; PURE CODE\r
19329         JRST    .+3\r
19330         CAIE    A,TCODE\r
19331         JRST    NRSUBR\r
19332         HLRM    B,(B)           ; CLOBEER SPECIAL COUNT FIELD\r
19333         MOVSI   A,TRSUBR\r
19334         JRST    FINIS\r
19335 \r
19336 NRSUBR: PUSH    TP,$TATOM\r
19337         PUSH    TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE\r
19338         JRST    CALER1\r
19339 \r
19340 ; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR\r
19341 \r
19342 MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]\r
19343 \r
19344         ENTRY   2\r
19345 \r
19346         GETYP   0,(AB)          ; TYPE OF ARG\r
19347         CAIE    0,TVEC          ; BETTER BE VECTOR\r
19348         JRST    WTYP1\r
19349         GETYP   0,2(AB)\r
19350         CAIE    0,TFIX\r
19351         JRST    WTYP2\r
19352         MOVE    B,1(AB)         ; GET VECTOR\r
19353         CAML    B,[-3,,0]\r
19354         JRST    BENTRY\r
19355         GETYP   0,(B)           ; FIRST ELEMENT\r
19356         CAIE    0,TRSUBR\r
19357         JRST    MENTR1\r
19358 MENTR2: GETYP   0,2(B)\r
19359         CAIE    0,TATOM\r
19360         JRST    BENTRY\r
19361         MOVE    C,3(AB)\r
19362         HRRM    C,2(B)          ; OFFSET INTO VECTOR\r
19363         HLRM    B,(B)\r
19364         MOVSI   A,TENTER\r
19365         JRST    FINIS\r
19366 \r
19367 MENTR1: CAIE    0,TATOM\r
19368         JRST    BENTRY\r
19369         MOVE    B,1(B)          ; GET ATOM\r
19370         PUSHJ   P,IGVAL         ; GET VAL\r
19371         GETYP   0,A\r
19372         CAIE    0,TRSUBR\r
19373         JRST    BENTRY\r
19374         MOVE    B,1(AB)         ; RESTORE B\r
19375         JRST    MENTR2\r
19376 \r
19377 BENTRY: PUSH    TP,$TATOM\r
19378         PUSH    TP,EQUOTE BAD-VECTOR\r
19379         JRST    CALER1\r
19380         \r
19381 ; SUBR TO GET ENTRIES OFFSET\r
19382 \r
19383 MFUNCTION LENTRY,SUBR,[ENTRY-LOC]\r
19384 \r
19385         ENTRY   1\r
19386 \r
19387         GETYP   0,(AB)\r
19388         CAIE    0,TENTER\r
19389         JRST    WTYP1\r
19390         MOVE    B,1(AB)\r
19391         HRRZ    B,2(B)\r
19392         MOVSI   A,TFIX\r
19393         JRST    FINIS\r
19394 \r
19395 ; RETURN FALSE\r
19396 \r
19397 RTFALS: MOVSI   A,TFALSE\r
19398         MOVEI   B,0\r
19399         POPJ    P,\r
19400 \r
19401 ;SUBROUTINE CALL FOR RSUBRs\r
19402 RCALL:  SUBM    M,(P)           ;CALCULATE PC's OFFSET IN THE RSUBR\r
19403         PUSHJ   P,@0            ;GO TO THE PROPER SUBROUTINE\r
19404         SUBM    M,(P)           ;RECONSTITUTE THE RSUBR's PC\r
19405         POPJ    P,\r
19406 \r
19407 \r
19408 ; ERRORS IN COMPILED CODE MAY END UP HERE\r
19409 \r
19410 COMPERR:\r
19411         PUSH    TP,$TATOM\r
19412         PUSH    TP,EQUOTE ERROR-IN-COMPILED-CODE\r
19413         JRST    CALER1\r
19414 \f\r
19415 \r
19416 ;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME\r
19417 ;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND\r
19418 ;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND\r
19419 \r
19420 MFUNCTION CHTYPE,SUBR\r
19421 \r
19422         ENTRY   2\r
19423         GETYP   A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM\r
19424         CAIE    A,TATOM \r
19425         JRST    NOTATOM\r
19426         MOVE    B,3(AB)         ;AND TYPE NAME\r
19427         PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE\r
19428 TFOUND: HRRZ    B,(A)           ;GOBBLE THE SAT\r
19429         TRNE    B,CHBIT         ; SKIP IF CHTYPABLE\r
19430         JRST    CANTCH\r
19431         TRNE    B,TMPLBT        ; TEMPLAT\r
19432         HRLI    B,-1\r
19433         AND     B,[-1,,SATMSK]\r
19434         GETYP   A,(AB)          ;NOW GET TYPE TO HACK\r
19435         PUSHJ   P,SAT           ;FIND OUT ITS SAT\r
19436         JUMPE   A,TYPERR        ;COMPLAIN\r
19437         CAILE   A,NUMSAT\r
19438         JRST    CHTMPL          ; JUMP IF TEMPLATE DATA\r
19439         CAIE    A,(B)           ;DO THEY AGREE?\r
19440         JRST    TYPDIF          ;NO, COMPLAIN\r
19441 CHTMP1: MOVSI   A,(D)           ;GET NEW TYPE\r
19442         HRR     A,(AB)          ; FOR DEFERRED GOODIES\r
19443         JUMPL   B,CHMATC        ; CHECK IT\r
19444         MOVE    B,1(AB)         ;AND VALUE\r
19445         JRST    FINIS\r
19446 \r
19447 CHTMPL: MOVE    E,1(AB)         ; GET ARG\r
19448         HLRZ    A,(E)\r
19449         ANDI    A,SATMSK\r
19450         MOVE    0,3(AB)         ; SEE IF TO "TEMPLATE"\r
19451         CAME    0,MQUOTE TEMPLATE\r
19452         CAIN    A,(B)\r
19453         JRST    CHTMP1\r
19454         JRST    TYPDIF\r
19455 \r
19456 CHMATC: PUSH    TP,A\r
19457         PUSH    TP,1(AB)        ; SAVE GOODIE\r
19458         MOVSI   A,TATOM\r
19459         MOVE    B,3(AB)\r
19460         MOVSI   C,TATOM\r
19461         MOVE    D,MQUOTE DECL\r
19462         PUSHJ   P,IGET          ; FIND THE DECL\r
19463         MOVE    C,(AB)\r
19464         MOVE    D,1(AB)         ; NOW GGO TO MATCH\r
19465         PUSHJ   P,TMATCH\r
19466         JRST    TMPLVIO\r
19467         POP     TP,B\r
19468         POP     TP,A\r
19469         JRST    FINIS\r
19470 \r
19471 TYPLOO: PUSHJ   P,TYPFND\r
19472         JRST    .+2\r
19473         POPJ    P,\r
19474         PUSH    TP,$TATOM       ;LOST, GENERATE ERROR\r
19475         PUSH    TP,EQUOTE BAD-TYPE-NAME\r
19476         JRST    CALER1\r
19477 \r
19478 TYPFND: MOVE    A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR\r
19479         MOVEI   D,0             ;INITIALIZE TYPE COUNTER\r
19480 TLOOK:  CAMN    B,1(A)          ;CHECK THIS ONE\r
19481         JRST    CPOPJ1\r
19482         ADDI    D,1             ;BUMP COUNTER\r
19483         AOBJP   A,.+2           ;COUTN DOWN ON VECTOR\r
19484         AOBJN   A,TLOOK\r
19485         POPJ    P,\r
19486 CPOPJ1: AOS     (P)\r
19487         POPJ    P,\r
19488 \r
19489 TYPDIF: PUSH    TP,$TATOM       ;MAKE ERROR MESSAGE\r
19490         PUSH    TP,EQUOTE STORAGE-TYPES-DIFFER\r
19491         JRST    CALER1\r
19492 \r
19493 \r
19494 TMPLVI: PUSH    TP,$TATOM\r
19495         PUSH    TP,EQUOTE DECL-VIOLATION\r
19496         JRST    CALER1\r
19497 \f\r
19498 \r
19499 ; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE\r
19500 \r
19501 MFUNCTION NEWTYPE,SUBR\r
19502 \r
19503         ENTRY\r
19504 \r
19505         HLRZ    0,AB            ; CHEC # OF ARGS\r
19506         CAILE   0,-4            ; AT LEAST 2\r
19507         JRST    TFA\r
19508         CAIGE   0,-6\r
19509         JRST    TMA             ; NOT MORE THAN 3\r
19510         GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)\r
19511         GETYP   C,2(AB)         ; SAME WITH SECOND\r
19512         CAIN    A,TATOM         ; CHECK\r
19513         CAIE    C,TATOM\r
19514         JRST    NOTATOM\r
19515 \r
19516         MOVE    B,3(AB)         ; GET PRIM TYPE NAME\r
19517         PUSHJ   P,TYPLOO        ; LOOK IT UP\r
19518         HRRZ    A,(A)           ; GOBBLE SAT\r
19519         HRLI    A,TATOM         ; MAKE NEW TYPE\r
19520         PUSH    P,A             ; AND SAVE\r
19521         MOVE    B,1(AB)         ; SEE IF PREV EXISTED\r
19522         PUSHJ   P,TYPFND\r
19523         JRST    NEWTOK          ; DID NOT EXIST BEFORE\r
19524         MOVEI   B,2(A)          ; FOR POSSIBLE TMPLAT BIT\r
19525         HRRZ    A,(A)           ; GET SAT\r
19526         HRRZ    0,(P)           ; AND PROPOSED\r
19527         ANDI    0,SATMSK\r
19528         ANDI    A,SATMSK\r
19529         CAIN    0,(A)           ; SKIP IF LOSER\r
19530         JRST    NEWTFN          ; O.K.\r
19531 \r
19532         PUSH    TP,$TATOM\r
19533         PUSH    TP,EQUOTE TYPE-ALREADY-EXISTS\r
19534         JRST    CALER1\r
19535 \r
19536 NEWTOK: POP     P,A\r
19537         MOVE    B,1(AB)         ; NEWTYPE NAME\r
19538         PUSHJ   P,INSNT         ; MUNG IN NEW TYPE\r
19539 \r
19540 NEWTFN: CAML    AB,[-5,,]       ; SKIP IF TEMPLAT SUPPLIED\r
19541         JRST    NEWTF1\r
19542         MOVEI   0,TMPLBT        ; GET THE BIT\r
19543         IORM    0,-2(B)         ; INTO WORD\r
19544         MOVE    A,(AB)          ; GET TYPE NAME\r
19545         MOVE    B,1(AB)\r
19546         MOVSI   C,TATOM\r
19547         MOVE    D,MQUOTE DECL\r
19548         PUSH    TP,4(AB)        ; GET TEMLAT\r
19549         PUSH    TP,5(AB)\r
19550         PUSHJ   P,IPUT\r
19551 NEWTF1: MOVE    A,(AB)\r
19552         MOVE    B,1(AB)         ; RETURN NAME\r
19553         JRST    FINIS\r
19554 \r
19555 ; SET  UP GROWTH FIELDS\r
19556 \r
19557 IGROWT: SKIPA   A,[111100,,(C)]\r
19558 IGROWB: MOVE    A,[001100,,(C)]\r
19559         HLRE    B,C\r
19560         SUB     C,B             ; POINT TO DOPE WORD\r
19561         MOVE    B,TYPIC ; INDICATED GROW BLOCK\r
19562         DPB     B,A\r
19563         POPJ    P,\r
19564 \r
19565 INSNT:  PUSH    TP,A\r
19566         PUSH    TP,B            ; SAVE NAME OF NEWTYPE\r
19567         MOVE    C,TYPBOT+1(TVP) ; CHECK GROWTH NEED\r
19568         CAMGE   C,TYPVEC+1(TVP)\r
19569         JRST    ADDIT           ; STILL ROOM\r
19570 GAGN:   PUSHJ   P,IGROWB        ; SETUP BOTTOM GROWTH\r
19571         SKIPE   C,EVATYP+1(TVP)\r
19572         PUSHJ   P,IGROWT        ; SET UP TOP GROWTH\r
19573         SKIPE   C,APLTYP+1(TVP)\r
19574         PUSHJ   P,IGROWT\r
19575         MOVE    C,[11.,,5]      ; SET UP INDICATOR FOR AGC\r
19576         PUSHJ   P,AGC           ; GROW THE WORLD\r
19577         AOJL    A,GAGN          ; BAD AGC LOSSAGE\r
19578         MOVE    0,[-101,,-100]\r
19579         ADDM    0,TYPBOT+1(TVP) ; FIX UP POINTER\r
19580 \r
19581 ADDIT:  MOVE    C,TYPVEC+1(TVP)\r
19582         SUB     C,[2,,2]        ; ALLOCATE ROOM\r
19583         MOVEM   C,TYPVEC+1(TVP)\r
19584         HLRE    B,C             ; PREPARE TO BLT\r
19585         SUBM    C,B             ; C POINTS DOPE WORD END\r
19586         HRLI    C,2(C)          ; GET BLT AC READY\r
19587         BLT     C,-3(B)\r
19588         POP     TP,-1(B)        ; CLOBBER IT IN\r
19589         POP     TP,-2(B)\r
19590         POPJ    P,\r
19591 \r
19592 \f\r
19593 ; Interface to interpreter for setting up tables associated with\r
19594 ;       template data structures.\r
19595 ;       A/      <\b-name of type>\b-\r
19596 ;       B/      <\b-length ins>\b-\r
19597 ;       C/      <\b-uvector of length code or 0>\r
19598 ;       D/      <\b-uvector of GETTERs>\b-\r
19599 ;       E/      <\b-uvector of PUTTERs>\b-\r
19600 \r
19601 CTMPLT: SUBM    M,(P)           ; could possibly gc during this stuff\r
19602         SKIPE   C               ; for now dont handle vector of length ins\r
19603         FATAL   TEMPLATE DATA WITH COMPUTED LENGTH\r
19604         PUSH    TP,$TATOM       ; save name of type\r
19605         PUSH    TP,A\r
19606         PUSH    P,B             ; save length instr\r
19607         HLRE    A,TD.LNT+1(TVP) ; check for template slots left?\r
19608         HRRZ    B,TD.LNT+1(TVP)\r
19609         SUB     B,A             ; point to dope words\r
19610         HLRZ    B,1(B)          ; get real length\r
19611         ADDM    B,A             ; any room?\r
19612         JUMPG   A,GOODRM        ; jump if ok\r
19613 \r
19614         PUSH    TP,$TUVEC       ; save getters and putters\r
19615         PUSH    TP,D\r
19616         PUSH    TP,$TUVEC\r
19617         PUSH    TP,E\r
19618         MOVEI   A,6(B)          ; grow it 10 by copying\r
19619         PUSH    P,A             ; save new length\r
19620         PUSHJ   P,CAFRE1        ; get frozen uvector\r
19621         ADD     B,[10,,10]      ; rest it down some\r
19622         HRL     C,TD.LNT+1(TVP) ; prepare to BLT in\r
19623         MOVEM   B,TD.LNT+1(TVP) ; and save as new length vector\r
19624         HRRI    C,(B)           ; destination\r
19625         ADD     B,(P)           ; final destination address\r
19626         BLT     C,-13(B)\r
19627         MOVE    A,(P)           ; length for new getters\r
19628         PUSHJ   P,CAFRE1\r
19629         MOVE    C,TD.GET+1(TVP) ; get old for copy\r
19630         MOVEM   B,TD.GET+1(TVP)\r
19631         HRRI    C,(B)\r
19632         ADD     B,(P)\r
19633         BLT     C,-13(B)        ; zap those guys in\r
19634         MOVE    A,(P)           ; finally putters\r
19635         PUSHJ   P,CAFRE1\r
19636         MOVE    C,TD.PUT+1(TVP)\r
19637         MOVEM   B,TD.PUT+1(TVP)\r
19638         HRRI    C,(B)           ; BLT pointer\r
19639         ADD     B,(P)\r
19640         BLT     C,-13(B)\r
19641         SUB     P,[1,,1]        ; flush stack craft\r
19642         MOVE    E,(TP)\r
19643         MOVE    D,-2(TP)\r
19644         SUB     TP,[4,,4]\r
19645 \r
19646 GOODRM: MOVE    B,TD.LNT+1(TVP) ; move down to fit new guy\r
19647         SUB     B,[1,,1]        ; will always win due to prev checks\r
19648         MOVEM   B,TD.LNT+1(TVP)\r
19649         HRLI    B,1(B)\r
19650         HLRE    A,TD.LNT+1(TVP)\r
19651         MOVNS   A\r
19652         ADDI    A,-1(B)         ; A/ final destination\r
19653         BLT     B,-1(A)\r
19654         POP     P,(A)           ; new length ins munged in\r
19655         HLRE    A,TD.LNT+1(TVP)\r
19656         MOVNS   A               ; A/ offset for other guys\r
19657         PUSH    P,A             ; save it\r
19658         ADD     A,TD.GET+1(TVP) ; point for storing uvs of ins\r
19659         MOVEM   D,-1(A)\r
19660         MOVE    A,(P)\r
19661         ADD     A,TD.PUT+1(TVP)\r
19662         MOVEM   E,-1(A)         ; store putter also\r
19663         POP     P,A             ; compute primtype\r
19664         ADDI    A,NUMSAT\r
19665         HRLI    A,TATOM\r
19666         MOVE    B,(TP)          ; ready to mung type vector\r
19667         SUB     TP,[2,,2]\r
19668         PUSHJ   P,INSNT         ; insert into vector\r
19669         JRST    MPOPJ\r
19670 \f\r
19671 \r
19672 ; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES\r
19673 \r
19674 MFUNCTION EVALTYPE,SUBR\r
19675 \r
19676         ENTRY   2\r
19677 \r
19678         PUSHJ   P,CHKARG        ; VERIFY WINNAGE IN ARGS\r
19679         MOVEI   A,EVATYP        ; POINT TO TABLE\r
19680         MOVEI   E,EVTYPE        ; POINT TO PURE VERSION\r
19681 TBLCAL: PUSHJ   P,TBLSET        ; SETUP TABLE ENTRY\r
19682         JRST    FINIS\r
19683 \r
19684 MFUNCTION APPLYTYPE,SUBR\r
19685 \r
19686         ENTRY   2\r
19687 \r
19688         PUSHJ   P,CHKARG\r
19689         MOVEI   A,APLTYP        ; POINT TO APPLY TABLE\r
19690         MOVEI   E,APTYPE        ; PURE TABLE\r
19691         JRST    TBLCAL\r
19692 \r
19693 \r
19694 MFUNCTION PRINTTYPE,SUBR\r
19695 \r
19696         ENTRY   2\r
19697 \r
19698         PUSHJ   P,CHKARG\r
19699         MOVEI   A,PRNTYP        ; POINT TO APPLY TABLE\r
19700         MOVEI   E,PRTYPE        ; PURE TABLE\r
19701         JRST    TBLCAL\r
19702 \r
19703 ; CHECK ARGS AND SETUP FOR TABLE HACKER\r
19704 \r
19705 CHKARG: GETYP   A,(AB)          ; 1ST MUST BE TYPE NAME\r
19706         CAIE    A,TATOM\r
19707         JRST    WTYP1\r
19708         MOVE    B,1(AB)         ; GET ATOM\r
19709         PUSHJ   P,TYPLOO        ; VERIFY THAT IT IS A TYPE\r
19710         PUSH    P,D             ; SAVE TYPE NO.\r
19711         HRRZ    A,(A)           ; GET SAT\r
19712         ANDI    A,SATMSK\r
19713         PUSH    P,A\r
19714         GETYP   A,2(AB)         ; GET 2D TYPE\r
19715         CAIE    A,TATOM         ; EITHER TYPE OR APPLICABLE\r
19716         JRST    TRYAPL          ; TRY APPLICABLE\r
19717         MOVE    B,3(AB)         ; VERIFY IT IS A TYPE\r
19718         PUSHJ   P,TYPLOO\r
19719         HRRZ    A,(A)           ; GET SAT\r
19720         ANDI    A,SATMSK\r
19721         POP     P,C             ; RESTORE SAVED SAT\r
19722         CAIE    A,(C)           ; SKIP IF A WINNER\r
19723         JRST    TYPDIF          ; REPORT ERROR\r
19724         POP     P,C             ; GET SAVED TYPE\r
19725         MOVEI   B,0             ; TELL THAT WE ARE A TYPE\r
19726         POPJ    P,\r
19727 \r
19728 TRYAPL: PUSHJ   P,APLQ          ; IS THIS APPLICABLE\r
19729         JRST    NAPT\r
19730         SUB     P,[1,,1]\r
19731         MOVE    B,2(AB)         ; RETURN SAME\r
19732         MOVE    D,3(AB)\r
19733         POP     P,C\r
19734         POPJ    P,\r
19735 \r
19736 \f\r
19737 ; HERE TO PUT ENTRY IN APPROPRIATE TABLE\r
19738 \r
19739 TBLSET: HRLI    A,(A)           ; FOR TVP HACKING\r
19740         ADD     A,TVP           ; POINT TO TVP SLOT\r
19741         PUSH    TP,B\r
19742         PUSH    TP,D            ; SAVE VALUE \r
19743         PUSH    TP,$TVEC\r
19744         PUSH    TP,A\r
19745         PUSH    P,C             ; SAVE TYPE BEING HACKED\r
19746         PUSH    P,E\r
19747         SKIPE   B,1(A)          ; SKIP IF VECTOR DOESN'T EXIST YET\r
19748         JRST    TBL.OK\r
19749         HLRE    A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH\r
19750         MOVNS   A\r
19751         ASH     A,-1\r
19752         PUSHJ   P,IVECT         ; GET VECTOR\r
19753         MOVE    C,(TP)          ; POINT TO RETURN POINT\r
19754         MOVEM   B,1(C)          ; SAVE VECTOR\r
19755 \r
19756 TBL.OK: POP     P,E\r
19757         POP     P,C             ; RESTORE TYPE\r
19758         SUB     TP,[2,,2]\r
19759         POP     TP,D\r
19760         POP     TP,A\r
19761         JUMPN A,TBLOK1  ; JUMP IF FUNCTION ETC. SUPPLIED\r
19762         CAILE   D,NUMPRI        ; SKIP IF ORIGINAL TYPE\r
19763         MOVNI   E,(D)           ; CAUSE E TO ENDUP 0\r
19764         ADDI    E,(D)           ; POINT TO PURE SLOT\r
19765 TBLOK1: ADDI    C,(C)           ; POINT TO VECTOR SLOT\r
19766         ADDI    C,(B)\r
19767         JUMPN   A,OK.SET        ; OK TO CLOBBER\r
19768         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT\r
19769         ADDI    B,(D)           ; POINT TO TARGET TYPE'S SLOT\r
19770         SKIPN   A,(B)           ; SKIP IF WINNER\r
19771         SKIPE   1(B)            ; SKIP IF LOSER\r
19772         SKIPA   D,1(B)          ; SETUP D\r
19773         JRST    CH.PTB          ; CHECK PURE TABLE\r
19774 \r
19775 OK.SET: MOVEM   A,(C)           ; STORE\r
19776         MOVEM   D,1(C)\r
19777         MOVE    A,(AB)          ; RET TYPE\r
19778         MOVE    B,1(AB)\r
19779         JRST    FINIS\r
19780 \r
19781 CH.PTB: MOVEI   A,0\r
19782         MOVE    D,[SETZ NAPT]\r
19783         JUMPE   E,OK.SET\r
19784         MOVE    D,(E)\r
19785         JRST    OK.SET\r
19786 \r
19787 CALLTY: MOVE    A,TYPVEC(TVP)\r
19788         MOVE    B,TYPVEC+1(TVP)\r
19789         POPJ    P,\r
19790 \r
19791 MFUNCTION ALLTYPES,SUBR\r
19792 \r
19793         ENTRY   0\r
19794 \r
19795         MOVE    A,TYPVEC(TVP)\r
19796         MOVE    B,TYPVEC+1(TVP)\r
19797         JRST    FINIS\r
19798 \r
19799 ;\f\r
19800 \r
19801 ;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR\r
19802 \r
19803 MFUNCTION UTYPE,SUBR\r
19804 \r
19805         ENTRY   1\r
19806 \r
19807         GETYP   A,(AB)          ;GET U VECTOR\r
19808         PUSHJ   P,SAT\r
19809         CAIE    A,SNWORD\r
19810         JRST    WTYP1\r
19811         MOVE    B,1(AB)         ; GET UVECTOR\r
19812         PUSHJ   P,CUTYPE\r
19813         JRST    FINIS\r
19814 \r
19815 CUTYPE: HLRE    A,B             ;GET -LENGTH\r
19816         HRRZS   B\r
19817         SUB     B,A             ;POINT TO TYPE WORD\r
19818         GETYP   A,(B)\r
19819         JRST    ITYPE           ; GET NAME OF TYPE\r
19820 \r
19821 ; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR\r
19822 \r
19823 MFUNCTION CHUTYPE,SUBR\r
19824 \r
19825         ENTRY   2\r
19826 \r
19827         GETYP   A,2(AB)         ;GET 2D TYPE\r
19828         CAIE    A,TATOM\r
19829         JRST    NOTATO\r
19830         GETYP   A,(AB)          ; CALL WITH UVECTOR?\r
19831         PUSHJ   P,SAT\r
19832         CAIE    A,SNWORD\r
19833         JRST    WTYP1\r
19834         MOVE    A,1(AB)         ; GET UV POINTER\r
19835         MOVE    B,3(AB)         ;GET ATOM\r
19836         PUSHJ   P,CCHUTY\r
19837         MOVE    A,(AB)          ; RETURN UVECTOR\r
19838         MOVE    B,1(AB)\r
19839         JRST    FINIS\r
19840 \r
19841 CCHUTY: PUSH    TP,$TUVEC\r
19842         PUSH    TP,A\r
19843         PUSHJ   P,TYPLOO        ;LOOK IT UP\r
19844         HRRZ    B,(A)           ;GET SAT\r
19845         TRNE    B,CHBIT\r
19846         JRST    CANTCH\r
19847         ANDI    B,SATMSK\r
19848         HLRE    C,(TP)          ;-LENGTH\r
19849         HRRZ    E,(TP)\r
19850         SUB     E,C             ;POINT TO TYPE\r
19851         GETYP   A,(E)           ;GET TYPE\r
19852         JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING\r
19853         PUSHJ   P,SAT           ;GET SAT\r
19854         JUMPE   A,TYPERR\r
19855         CAIE    A,(B)           ;COMPARE\r
19856         JRST    TYPDIF\r
19857 WIN0:   HRLM    D,(E)           ;CLOBBER NEW ONE\r
19858         POP     TP,B\r
19859         POP     TP,A\r
19860         POPJ    P,\r
19861 \r
19862 CANTCH: PUSH    TP,$TATOM\r
19863         PUSH    TP,EQUOTE CANT-CHTYPE-INTO\r
19864         PUSH    TP,2(AB)\r
19865         PUSH    TP,3(AB)\r
19866         MOVEI   A,2\r
19867         JRST    CALER\r
19868 \r
19869 NOTATOM:\r
19870         PUSH    TP,$TATOM\r
19871         PUSH    TP,EQUOTE NON-ATOMIC-ARGUMENT\r
19872         PUSH    TP,(AB)\r
19873         PUSH    TP,1(AB)\r
19874         MOVEI   A,2\r
19875         JRST    CALER\r
19876 \r
19877 \r
19878 \f\r
19879 ; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY\r
19880 \r
19881 MFUNCTION QUIT,SUBR\r
19882 \r
19883         ENTRY   0\r
19884 \r
19885 \r
19886         PUSHJ   P,CLOSAL        ; DO THE CLOSES\r
19887         PUSHJ   P,%KILLM\r
19888         JRST    IFALSE          ; JUST IN CASE\r
19889 \r
19890 CLOSAL: MOVE    B,TVP           ; POINT TO XFER VECCTOR\r
19891         ADD     B,[CHNL0+2,,CHNL0+2]    ; POINT TO 1ST (NOT INCLUDING TTY I/O)\r
19892         PUSH    TP,$TVEC\r
19893         PUSH    TP,B\r
19894         PUSH    P,[N.CHNS-1]    ; MAX NO. OF CHANS\r
19895 \r
19896 CLOSA1: MOVE    B,(TP)\r
19897         ADD     B,[2,,2]\r
19898         MOVEM   B,(TP)\r
19899         SKIPN   C,-1(B)         ; THIS ONE OPEN?\r
19900         JRST    CLOSA4          ; NO\r
19901         CAME    C,TTICHN+1(TVP)\r
19902         CAMN    C,TTOCHN+1(TVP)\r
19903         JRST    CLOSA4\r
19904         PUSH    TP,-2(B)        ; PUSH IT\r
19905         PUSH    TP,-1(B)\r
19906         MCALL   1,FCLOSE                ; CLOSE IT\r
19907 CLOSA4: SOSLE   (P)             ; COUNT DOWN\r
19908         JRST    CLOSA1\r
19909 \r
19910 \r
19911         SUB     TP,[2,,2]\r
19912         SUB     P,[1,,1]\r
19913 \r
19914 CLOSA3: SKIPN   B,CHNL0+1(TVP)\r
19915         POPJ    P,\r
19916         PUSH    TP,(B)\r
19917         HLLZS   (TP)\r
19918         PUSH    TP,1(B)\r
19919         HRRZ    B,(B)\r
19920         MOVEM   B,CHNL0+1(TVP)\r
19921         MCALL   1,FCLOSE\r
19922         JRST    CLOSA3\r
19923 \f\r
19924 ; LITTLE ROUTINES USED ALL OVER THE PLACE\r
19925 \r
19926 CRLF:   MOVEI   A,15\r
19927         PUSHJ   P,MTYO\r
19928         MOVEI   A,12\r
19929         JRST    MTYO\r
19930 MSGTYP: HRLI    B,440700        ;MAKE BYTE POINTER\r
19931 MSGTY1: ILDB    A,B             ;GET NEXT CHARACTER\r
19932         JUMPE   A,CPOPJ         ;NULL ENDS STRING\r
19933         CAIE    A,177           ; DONT PRINT RUBOUTS\r
19934         PUSHJ   P,MTYO"\r
19935         JRST    MSGTY1          ;AND GET NEXT CHARACTER\r
19936 CPOPJ:  POPJ    P,\r
19937 \r
19938 IMPURE\r
19939 \r
19940 WHOAMI: 0               ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK\r
19941 \r
19942 \r
19943 ;GARBAGE COLLECTORS PDLS\r
19944 \r
19945 \r
19946 GCPDL:  -GCPLNT,,GCPDL\r
19947 \r
19948         BLOCK   GCPLNT\r
19949 \r
19950 \r
19951 PURE\r
19952 \r
19953 MUDSTR: ASCII /MUDDLE \7f\7f\7f/\r
19954 STRNG:  -1\r
19955         -1\r
19956         -1\r
19957         ASCIZ / IN OPERATION./\r
19958 \r
19959 ;MARKED PDLS FOR GC PROCESS\r
19960 \r
19961 VECTGO\r
19962 ; DUMMY FRAME FOR INITIALIZER CALLS\r
19963 \r
19964         TENTRY,,LISTEN\r
19965         0\r
19966         .-3\r
19967         0\r
19968         0\r
19969         -ITPLNT,,TPBAS-1\r
19970         0\r
19971 \r
19972 TPBAS:  BLOCK   ITPLNT+PDLBUF\r
19973         GENERAL\r
19974         ITPLNT+2+PDLBUF+7,,0\r
19975 \r
19976 \r
19977 VECRET\r
19978 \r
19979 \r
19980 \r
19981 \r
19982 $TMATO: TATOM,,-1\r
19983 \r
19984 \r
19985 PATCH:\r
19986 PAT:    BLOCK   100\r
19987 PATEND: 0\r
19988 \r
19989 END\r
19990 \f\r
19991 TITLE PURE-PAGE LOADER\r
19992 \r
19993 RELOCATABLE\r
19994 \r
19995 MAPCH==0                        ; channel for MAPing\r
19996 ELN==3                          ; Length of table entry\r
19997 \r
19998 .GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN\r
19999 .GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF\r
20000 \r
20001 .INSRT MUDDLE >\r
20002 \r
20003 SYSQ\r
20004 \r
20005 IFE ITS,[\r
20006 IF1, .INSRT STENEX >\r
20007 ]\r
20008 \r
20009 IFN ITS,[\r
20010 PURDIR==SIXBIT /MUD50/          ; directory containing pure pages\r
20011 OPURDI==SIXBIT /MHILIB/\r
20012 OFIXDI==SIXBIT /MHILIB/\r
20013 FIXDIR==SIXBIT /MUD50/\r
20014 ARC==1                          ; flag saying fixups on archive\r
20015 ]\r
20016 IFN ITS,[\r
20017 PGMSK==1777\r
20018 PGSHFT==10.\r
20019 ]\r
20020 IFE ITS,[\r
20021 PGMSK==777\r
20022 PGSHFT==9.\r
20023 ]\r
20024 \r
20025 ; This routine taskes a slot offset in register A and\r
20026 ; maps in the associated file.  It clobbers all ACs\r
20027 ; It skip returns if it wins.\r
20028 \r
20029 PLOAD:  PUSH    P,A             ; save slot offset\r
20030         ADD     A,PURVEC+1(TVP) ; point into pure vector\r
20031         MOVE    B,(A)           ; get sixbit of name\r
20032 IFN ITS,[\r
20033         MOVE    C,MUDSTR+2      ; get version number\r
20034         PUSHJ   P,CSIXBT        ; vers # to six bit\r
20035         HRRI    C,(SIXBIT /SAV/)\r
20036         MOVSS   C\r
20037         .SUSET  [.RSNAM,,0]     ; GET CURRENT SNAME TO 0\r
20038         .SUSET  [.SSNAM,,[PURDIR]]      ; get sname for it\r
20039         MOVE    A,[SIXBIT /  &DSK/]     ; build open block\r
20040         .OPEN   MAPCH,A         ; try to open file\r
20041         JRST    FIXITU          ; no current version, fix one up\r
20042         PUSH    P,0             ; for compat wit tenex and save old sname\r
20043         DOTCAL  FILLEN,[[1000,,MAPCH],[2000,,A]]\r
20044         JRST    MAPLOS\r
20045         ADDI    A,PGMSK         ; in case not even # of pages\r
20046         ASH     A,-PGSHFT       ; to pages\r
20047         PUSH    P,A             ; save the length\r
20048 ]\r
20049 IFE ITS,[\r
20050         MOVE    E,P             ; save pdl base\r
20051         PUSH    P,[0]           ; slots for building strings\r
20052         PUSH    P,[0]\r
20053         MOVE    A,[440700,,1(E)]\r
20054         MOVE    C,[440600,,B]\r
20055         MOVEI   D,6\r
20056         ILDB    0,C\r
20057         JUMPE   0,.+4           ; violate cardinal ".+ rule"\r
20058         ADDI    0,40            ; to ASCII\r
20059         IDPB    0,A\r
20060         SOJG    D,.-4\r
20061 \r
20062         PUSH    P,[ASCII /  SAV/]\r
20063         MOVE    C,MUDSTR+2      ; get ascii of vers no.\r
20064         IORI    C,1             ; hair to change r.o. to space\r
20065         MOVE    0,C\r
20066         ADDI    C,1\r
20067         ANDCM   C,0             ; C has 1st 1\r
20068         JFFO    C,.+3\r
20069         MOVEI   0,0             ; use zer name\r
20070         JRST    ZER...\r
20071         MOVEI   C,(D)\r
20072         IDIVI   C,7\r
20073         AND     0,MSKS(C)       ; get rid of r.o.s\r
20074 ZER...: PUSH    P,0\r
20075         MOVEI   B,-1(P)         ; point to it\r
20076         HRLI    B,260700\r
20077         HRROI   D,1(E)          ; point to name\r
20078         MOVEI   A,1(P)\r
20079 \r
20080         PUSH    P,[100000,,]\r
20081         PUSH    P,[377777,,377777]\r
20082         PUSH    P,[-1,,[ASCIZ /DSK/]]\r
20083         PUSH    P,[-1,,[ASCIZ /MUDLIB/]]\r
20084         PUSH    P,D\r
20085         PUSH    P,B\r
20086         PUSH    P,[0]\r
20087         PUSH    P,[0]\r
20088         PUSH    P,[0]\r
20089         MOVEI   B,0\r
20090         MOVE    D,4(E)          ; save final version string\r
20091         GTJFN\r
20092         JRST    FIXITU\r
20093 \r
20094         MOVE    B,[440000,,240000]\r
20095         OPENF\r
20096         JRST    FIXITU\r
20097         MOVE    P,E             ; flush crap\r
20098         PUSH    P,A\r
20099         SIZEF                   ; get length\r
20100         JRST    MAPLOS\r
20101         PUSH    P,C             ; save # of pages\r
20102         MOVEI   A,(C)\r
20103 ]\r
20104         PUSHJ   P,ALOPAG        ; get the necessary pages\r
20105         JRST    MAPLS1\r
20106         PUSH    P,B             ; save page number\r
20107 IFN ITS,[\r
20108         MOVN    A,-1(P)         ; get neg count\r
20109         MOVSI   A,(A)           ; build aobjn pointer\r
20110         HRR     A,(P)           ; get page to start\r
20111         MOVE    B,A             ; save for later\r
20112         HLLZ    0,A             ; page pointer for file\r
20113         DOTCAL  CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0]\r
20114         JRST    MAPLS3          ; total wipe out\r
20115         .CLOSE  MAPCH,          ; no need to have file open anymore\r
20116 ]\r
20117 IFE ITS,[\r
20118         MOVE    D,-1(P)         ; # of pages to D\r
20119         HRLI    B,400000        ; specify this fork\r
20120         HRROI   E,(B)           ; build page aobjn for later\r
20121         TLC     E,-1(D)         ; sexy way of doing lh\r
20122         HRLZ    A,-2(P)         ; JFN to lh of A\r
20123         MOVSI   C,120000        ; bits for read/execute\r
20124 \r
20125         PMAP\r
20126         ADDI    A,1\r
20127         ADDI    B,1\r
20128         SOJG    D,.-3           ; map 'em all\r
20129         MOVE    A,-2(P)\r
20130         CLOSF                   ; try to close file\r
20131         JFCL                    ; ignore failure\r
20132         MOVE    B,E\r
20133 ]\r
20134 \r
20135 ; now try to smash slot in PURVEC\r
20136 \r
20137 PLOAD1: MOVE    A,PURVEC+1(TVP) ; get pointer to it\r
20138         ASH     B,PGSHFT        ; convert to aobjn pointer to words\r
20139         MOVE    C,-3(P)         ; get slot offset\r
20140         ADDI    C,(A)           ; point to slot\r
20141         MOVEM   B,1(C)          ; clobber it in\r
20142         ANDI    B,-1            ; isolate address of page\r
20143         HRRZ    D,PURVEC(TVP)   ; get offset into vector for start of chain\r
20144         TRNE    D,400000        ; skip if not end marker\r
20145         JRST    SCHAIN\r
20146         HRLI    D,A             ; set up indexed pointer\r
20147         ADDI    D,1\r
20148         HRRZ    0,@D            ; get its address\r
20149         JUMPE   0,SCHAIN        ; no chain exists, start one\r
20150         CAILE   0,(B)           ; skip if new one should be first\r
20151         AOJA    D,INLOOP        ; jump into the loop\r
20152 \r
20153         SUBI    D,1             ; undo ADDI\r
20154 FCLOB:  MOVE    E,-3(P)         ; get offset for this guy\r
20155         HRRM    D,2(C)          ; link up\r
20156         HRRM    E,PURVEC(TVP)   ; store him away\r
20157         JRST    PLOADD\r
20158 \r
20159 SCHAIN: MOVEI   D,400000        ; get end of chain indicator\r
20160         JRST    FCLOB           ; and clobber it in\r
20161 \r
20162 INLOOP: MOVE    E,D             ; save in case of later link up\r
20163         HRR     D,@D            ; point to next table entry\r
20164         TRNE    D,400000        ; 400000 is the end of chain bit\r
20165         JRST    SLFOUN          ; found a slot, leave loop\r
20166         ADDI    D,1             ; point to address of progs\r
20167         HRRZ    0,@D            ; get address of block\r
20168         CAILE   0,(B)           ; skip if still haven't fit it in\r
20169         AOJA    D,INLOOP        ; back to loop start and point to chain link\r
20170         SUBI    D,1             ; point back to start of slot\r
20171 \r
20172 SLFOUN: MOVE    0,-3(P)         ; get offset into vector of this guy\r
20173         HRRM    0,@E            ; make previous point to us\r
20174         HRRM    D,2(C)          ; link it in\r
20175 \r
20176 \r
20177 PLOADD: AOS     -4(P)           ; skip return\r
20178 \r
20179 MAPLS3: SUB     P,[1,,1]        ; flush stack crap\r
20180 MAPLS1: SUB     P,[1,,1]\r
20181 MAPLOS:\r
20182 IFN ITS,[\r
20183         MOVE    0,(P)\r
20184         .SUSET  [.SSNAM,,0]     ; restore SNAME\r
20185 ]\r
20186         SUB     P,[2,,2]\r
20187         POPJ    P,\r
20188 \r
20189 ; Here if no current version exists\r
20190 \r
20191 FIXITU: PUSH    TP,$TFIX\r
20192         PUSH    TP,0            ; maybe save sname\r
20193 \r
20194 IFN ITS,[\r
20195         PUSH    P,C             ; save final name\r
20196         MOVE    C,[SIXBIT /FIXUP/]      ; name of fixup file\r
20197 IFN <PURDIR-OFIXDI>,.SUSET [.SSNAM,,[OFIXDI]]\r
20198 IFN ARC,        HRRI    A,(SIXBIT /ARC/)\r
20199         .OPEN   MAPCH,A\r
20200 IFE ARC,        JRST MAPLOS\r
20201 IFN ARC,        PUSHJ P,ARCLOS\r
20202         MOVE    0,[-2,,A]       ; prepare to read version and length\r
20203         PUSH    P,B             ; save program name\r
20204         .IOT    MAPCH,0\r
20205         SKIPGE  0\r
20206         FATAL BAD FIXUP FILE\r
20207         PUSH    P,B             ; save version number of fixup file\r
20208         MOVEI   A,-2(A)         ; length -2 (for vers and length)\r
20209         PUSHJ   P,IBLOCK        ; get a UVECTOR for the fixups\r
20210         PUSH    TP,$TUVEC       ; and save\r
20211         PUSH    TP,B\r
20212         MOVE    A,B\r
20213         MOVSI   0,TUVEC\r
20214         MOVEM   0,ASTO(PVP)     ; prepare for moby iot (interruptable)\r
20215         ENABLE\r
20216         .IOT    MAPCH,A         ; get fixups\r
20217         DISABLE\r
20218         .CLOSE  MAPCH,\r
20219         SETZM   ASTO(PVP)\r
20220         POP     P,A             ; restore version number\r
20221         IDIVI   A,100.          ; get 100s digit in a rest in B\r
20222         ADDI    A,20            ; convert to sixbit\r
20223         IDIVI   B,10.           ; B tens digit C 1s digit\r
20224         ADDI    B,20\r
20225         ADDI    C,20\r
20226         MOVE    0,[220600,,D]\r
20227         MOVSI   D,(SIXBIT /SAV/)\r
20228         CAIE    A,20\r
20229         IDPB    A,0\r
20230         CAIE    B,20\r
20231         IDPB    B,0\r
20232         IDPB    C,0\r
20233         MOVE    B,[SIXBIT /  &DSK/]\r
20234         MOVE    C,(P)           ; program name\r
20235 IFN <OPURDI-OFIXDI>,.SUSET [.SSNAM,,[OPURDI]]\r
20236         .OPEN   MAPCH,B         ; try for this one\r
20237         JRST    MAPLS1\r
20238         DOTCAL  FILLEN,[[1000,,MAPCH],[2000,,A]]\r
20239         JRST    MAPLS1\r
20240         ADDI    A,PGMSK         ; in case not exact pages\r
20241         ASH     A,-PGSHFT       ; to pages\r
20242         PUSH    P,A             ; save\r
20243         PUSHJ   P,ALOPAG        ; find some pages\r
20244         JRST    MAPLS4\r
20245         MOVN    A,(P)           ; build aobjn pointer\r
20246         MOVSI   A,(A)\r
20247         HRRI    A,(B)\r
20248         MOVE    B,A\r
20249         HLLZ    0,B\r
20250         DOTCAL  CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0]\r
20251         JRST    MAPLS4\r
20252         SUB     P,[1,,1]\r
20253         .CLOSE  MAPCH,\r
20254 ]\r
20255 IFE ITS,[\r
20256         PUSH    TP,$TPDL        ; save stack pointer\r
20257         PUSH    TP,E\r
20258         PUSH    P,D             ; save vers string\r
20259         HRROI   A,[ASCIZ /FIXUP/]\r
20260         MOVEM   A,10.(E)        ; into name slot\r
20261         MOVEI   A,5(E)          ; point to arg block\r
20262         SETZB   B,C\r
20263         GTJFN\r
20264         JRST    MAPLS4\r
20265         MOVEI   C,(A)           ; save JFN in case OPNEF loses\r
20266         MOVE    B,[440000,,200000]\r
20267         OPENF\r
20268         JRST    MAPLS4\r
20269         BIN                     ; length of fixups to B\r
20270         PUSH    P,A             ; save JFN\r
20271         MOVEI   A,-2(B)         ; length of uvextor to get\r
20272         PUSHJ   P,IBLOCK\r
20273         PUSH    TP,$TUVEC\r
20274         PUSH    TP,B            ; sav it\r
20275         POP     P,A             ; restore JFN\r
20276         BIN                     ; read in vers #\r
20277         MOVE    D,B             ; save vers #\r
20278         MOVE    B,(TP)\r
20279         HLRE    C,B\r
20280         HRLI    B,444400\r
20281         SIN                     ; read in entire fixups\r
20282         CLOSF                   ; and close file of same\r
20283         JFCL                    ; ignore cailure to close\r
20284         HRROI   C,1(E)          ; point to name\r
20285         MOVEM   C,9.(E)\r
20286         MOVEI   C,3(E)\r
20287         HRLI    C,260700\r
20288         MOVEM   C,10.(E)\r
20289         MOVE    0,[ASCII /     /]\r
20290         MOVEM   0,4(E)          ; all spaces\r
20291         MOVEI   A,(D)\r
20292         IDIVI   A,100.          ; to ascii\r
20293         ADDI    A,60\r
20294         IDIVI   B,10.\r
20295         ADDI    B,60\r
20296         ADDI    C,60\r
20297         MOVE    0,[440700,,4(E)]\r
20298         CAIE    A,60\r
20299         IDPB    A,0\r
20300         CAIE    B,60\r
20301         IDPB    B,0\r
20302         IDPB    C,0\r
20303         SETZB   C,B\r
20304         MOVEI   A,5(E)          ; ready for 'nother GTJFN\r
20305         GTJFN\r
20306         JRST    MAPLS5\r
20307         MOVEI   C,(A)           ; save JFN in case OPENF loses\r
20308         MOVE    B,[440000,,240000]\r
20309         OPENF\r
20310         JRST    MAPLS5\r
20311         SIZEF\r
20312         JRST    MAPLS5\r
20313         PUSH    P,A\r
20314         PUSH    P,C\r
20315         MOVEI   A,(C)\r
20316         PUSHJ   P,ALOPAG        ; get the pages\r
20317         JRST    MAPLS5\r
20318         MOVEI   D,(B)           ; save pointer\r
20319         MOVN    A,(P)           ; build page aobjn pntr\r
20320         HRLI    D,(A)\r
20321         EXCH    D,(P)           ; get length\r
20322         HRLI    B,400000\r
20323 \r
20324         HRLZ    A,-1(P)         ; JFN for PMAP\r
20325         MOVSI   C,120400        ; bits for read/execute/copy-on-write\r
20326 \r
20327         PMAP\r
20328         ADDI    A,1\r
20329         ADDI    B,1\r
20330         SOJG    D,.-3\r
20331 \r
20332         HLRZS   A\r
20333         CLOSF\r
20334         JFCL\r
20335         POP     P,B             ; restore page #\r
20336         SUB     P,[1,,1]\r
20337 ]\r
20338 ; now to do fixups\r
20339 \r
20340         MOVE    A,(TP)          ; pointer to them\r
20341         ASH     B,PGSHFT        ; aobjn to program\r
20342 \r
20343 FIX1:   SKIPL   E,(A)           ; read one hopefully squoze\r
20344         FATAL   ATTEMPT TO TYPE FIX PURE\r
20345         TLZ     E,740000\r
20346         PUSHJ   P,SQUTOA        ; look it up\r
20347         FATAL   BAD FIXUPS\r
20348 \r
20349         AOBJP   A,FIX2\r
20350         HLRZ    D,(A)           ; get old value\r
20351         SUBM    E,D             ; D is diff between old and new\r
20352         HRLM    E,(A)           ; fixup the fixups\r
20353         MOVEI   0,0             ; flag for which half\r
20354 FIX4:   JUMPE   0,FIXRH         ; jump if getting rh\r
20355         MOVEI   0,0             ; next time will get rh\r
20356         AOBJP   A,FIX2          ; done?\r
20357         HLRZ    C,(A)           ; get lh\r
20358         JUMPE   C,FIX3          ; 0 terminates\r
20359 FIX5:   ADDI    C,(B)           ; access the code\r
20360         ADDM    D,-1(C)         ; and fix it up\r
20361         JRST    FIX4\r
20362 \r
20363 FIXRH:  MOVEI   0,1             ; change flag\r
20364         HRRZ    C,(A)           ; get it and\r
20365         JUMPN   C,FIX5\r
20366 \r
20367 FIX3:   AOBJN   A,FIX1          ; do next one\r
20368 \r
20369 FIX2:\r
20370 IFN ITS,[\r
20371 IFN <PURDIR-OPURDI>     .SUSET  [.SSNAM,,[PURDIR]]\r
20372         .OPEN   MAPCH,[SIXBIT /  'DSK_PURE_>/]\r
20373         JRST    MAPLS1\r
20374         MOVE    E,B             ; save pointer\r
20375         ASH     E,-PGSHFT       ; to page AOBJN\r
20376         .IOT    MAPCH,B         ; write out the goodie\r
20377         SETZB   0,A\r
20378         MOVEI   B,MAPCH\r
20379         MOVE    C,(P)\r
20380         MOVE    D,-1(P)\r
20381         .FDELE  0               ; attempt to rename to right thing\r
20382         JRST    MAPLS1\r
20383         .CLOSE  MAPCH,\r
20384         MOVE    B,[SIXBIT /  &DSK/]\r
20385         .OPEN   MAPCH,B\r
20386         FATAL   WHERE DID THE FILE GO?\r
20387         HLLZ    0,E             ; pointer to file pages\r
20388         PUSH    P,E             ; SAVE FOR END\r
20389         DOTCAL  CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0]\r
20390         FATAL   LOSSAGE LOSSAGE PAGES LOST\r
20391         .CLOSE  MAPCH,\r
20392 \r
20393         SKIPGE  MUDSTR+2        ; skip if not experimental\r
20394         JRST    NOFIXO\r
20395         PUSHJ   P,GENVN         ; get version number as a number\r
20396         MOVE    E,(TP)\r
20397 IFN <PURDIR-FIXDIR>,.SUSET [.SSNAM,,[FIXDIR]]\r
20398 IFE ARC,        .OPEN   MAPCH,[SIXBIT /  'DSK_FIXU_>/]\r
20399 IFN ARC,        .OPEN   MAPCH,[SIXBIT /  'ARC_FIXU_>/]\r
20400 IFE ARC,        FATAL   CANT WRITE FIXUPS\r
20401 IFN ARC,        PUSHJ   P,ARCFAT\r
20402         HLRE    A,E             ; get length\r
20403         MOVNS   A\r
20404         ADDI    A,2             ; account for these 2 words\r
20405         MOVE    0,[-2,,A]       ; write version and length\r
20406         .IOT    MAPCH,0\r
20407         .IOT    MAPCH,E         ; out go the fixups\r
20408         SETZB   0,A\r
20409         MOVEI   B,MAPCH\r
20410         MOVE    C,-1(P)\r
20411         MOVE    D,[SIXBIT /FIXUP/]\r
20412         .FDELE  0\r
20413         FATAL   FIXUP WRITE OUT FAILED\r
20414         .CLOSE  MAPCH,\r
20415 NOFIXO:\r
20416 ]\r
20417 IFE ITS,[\r
20418         MOVE    E,-2(TP)        ; restore P-stack base\r
20419         MOVEI   0,600000        ; fixup args to GTJFN\r
20420         HRLM    0,5(E)\r
20421         MOVE    D,B             ; save page number\r
20422         POP     P,4(E)          ; current version name in\r
20423         MOVEI   A,5(E)          ; pointer ro arg block\r
20424         MOVEI   B,0\r
20425         GTJFN\r
20426         FATAL MAP FIXUP LOSSAGE\r
20427         MOVE    B,[440000,,100000]\r
20428         OPENF\r
20429         FATAL MAP FIXUP LOSSAGE\r
20430         MOVEI   B,(D)           ; ready to write it out\r
20431         HRLI    B,444400\r
20432         HLRE    C,D\r
20433         SOUT                    ; zap it out\r
20434         TLO     A,400000        ; dont recycle the JFN\r
20435         CLOSF\r
20436         JFCL\r
20437         ANDI    A,-1            ; kill sign bit\r
20438         MOVE    B,[440000,,240000]\r
20439         OPENF\r
20440         FATAL MAP FIXUP LOSSAGE\r
20441         MOVE    B,D\r
20442         ASH     B,-PGSHFT       ; aobjn to pages\r
20443         PUSH    P,B\r
20444         HLRE    D,B             ; -count\r
20445         HRLI    B,400000\r
20446         MOVSI   A,(A)\r
20447         MOVSI   C,120000\r
20448 \r
20449         PMAP\r
20450         ADDI    A,1\r
20451         ADDI    B,1\r
20452         AOJL    D,.-3\r
20453 \r
20454         HLRZS   A\r
20455         CLOSF\r
20456         JFCL\r
20457 \r
20458         HRROI   0,[ASCIZ /FIXUP/]       ; now write out new fixup file\r
20459         MOVEM   0,10.(E)\r
20460         MOVEI   A,5(E)\r
20461         MOVEI   B,0\r
20462 \r
20463         SKIPGE  MUDSTR+2\r
20464         JRST    NOFIXO          ; exp vers, dont write out\r
20465 \r
20466         PUSHJ   P,GENVN\r
20467         MOVEI   D,(B)           ; save vers in D\r
20468         GTJFN\r
20469         FATAL MAP FIXUP LOSSAGE\r
20470         MOVE    B,[440000,,100000]\r
20471         OPENF\r
20472         FATAL MAP FIXUP LOSSAGE\r
20473         HLRE    B,(TP)          ; length of fixup vector\r
20474         MOVNS   B\r
20475         ADDI    B,2             ; for length and version words\r
20476         BOUT\r
20477         MOVE    B,D             ; and vers #\r
20478         BOUT\r
20479         MOVSI   B,444400        ; byte pointer to fixups\r
20480         HRR     B,(TP)\r
20481         HLRE    C,(TP)\r
20482         SOUT\r
20483         CLOSF\r
20484         JFCL\r
20485 NOFIXO: MOVE    A,(P)           ; save aobjn to pages\r
20486         MOVE    P,-2(TP)\r
20487         SUB     TP,[2,,2]\r
20488         PUSH    P,A\r
20489 ]\r
20490         HRRZ    A,(P)           ; get page #\r
20491         HLRE    C,(P)           ; and # of same\r
20492         MOVE    B,(P)           ; set B up for return\r
20493         MOVNS   C\r
20494 IFN ITS,[\r
20495         SUB     P,[2,,2]\r
20496         MOVE    0,-2(TP)                ; saved sname\r
20497         MOVEM   0,(P)\r
20498 ]\r
20499         PUSH    P,C\r
20500         PUSH    P,A\r
20501         SUB     TP,[4,,4]\r
20502         JRST    PLOAD1\r
20503 \r
20504 IFN ITS,[\r
20505 MAPLS4: .CLOSE  MAPCH,\r
20506         SUB     P,[1,,1]\r
20507         JRST    MAPLS1\r
20508 ]\r
20509 IFE ITS,[\r
20510 MAPLS4: SKIPA   A,[4,,4]\r
20511 MAPLS5: MOVE    A,[6,,6]\r
20512         MOVE    P,E\r
20513         SUB     TP,A\r
20514         SKIPE   A,C\r
20515         CLOSF\r
20516         JFCL\r
20517         JRST    MAPLOS\r
20518 ]\r
20519 \r
20520 IFN ITS,[\r
20521 IFN ARC,[\r
20522 ARCLOS: PUSHJ   P,CKLOCK\r
20523         JRST    MAPLS1\r
20524 \r
20525 ARCRTR: SOS     (P)\r
20526         SOS     (P)\r
20527         POPJ    P,\r
20528 \r
20529 ARCFAT: PUSHJ   P,CKLOCK\r
20530         FATAL   CANT WRITE FIXUP FILE\r
20531         JRST    ARCRTR\r
20532 \r
20533 CKLOCK: PUSH    P,0\r
20534         .STATUS MAPCH,0\r
20535         LDB     0,[220600,,0]\r
20536         CAIN    0,23            ; file locked?\r
20537         JRST    WAIT            ; wait and retry\r
20538         POP     P,0\r
20539         POPJ    P,\r
20540 \r
20541 WAIT:   MOVEI   0,1\r
20542         .SLEEP  0,\r
20543         POP     P,0\r
20544         AOS     (P)\r
20545         POPJ    P,\r
20546 ]\r
20547 ]\r
20548 \r
20549 ; Here to try to get a free page block for new thing\r
20550 ;       A/      # of pages to get\r
20551 \r
20552 ALOPAG: PUSHJ   P,GETPAG        ; try to get enough pages\r
20553         POPJ    P,\r
20554         AOS     (P)             ; won skip return\r
20555         MOVEI   0,(B)           ; update PURBOT/PURTOP to reflect current state\r
20556         ASH     0,PGSHFT\r
20557         MOVEM   0,PURBOT\r
20558         POPJ    P,\r
20559 \r
20560 GETPAG: MOVE    C,P.TOP         ; top of GC space\r
20561         ASH     C,-PGSHFT       ; to page number\r
20562         MOVE    B,PURBOT        ; current bottom of pure space\r
20563         ASH     B,-PGSHFT       ; also to pages\r
20564         SUBM    B,C             ; pages available ==> C\r
20565         CAIGE   C,(A)           ; skip if have enough already\r
20566         JRST    GETPG1          ; no, try to shuffle around\r
20567         SUBI    B,(A)           ; B/  first new page\r
20568         AOS     (P)\r
20569         POPJ    P,              ; return with new free page in B\r
20570 \r
20571 ; Here if shuffle must occur or gc must be done to make room\r
20572 \r
20573 GETPG1: MOVEI   0,0\r
20574         SKIPE   NOSHUF          ; if can't shuffle, then ask gc\r
20575         JRST    ASKAGC\r
20576         MOVE    0,PURTOP        ; get top of mapped pure area\r
20577         SUB     0,P.TOP         ; total free words to 0\r
20578         ASH     0,-PGSHFT       ; to pages\r
20579         CAIGE   0,(A)           ; skip if winnage possible\r
20580         JRST    ASKAGC          ; please AGC give me some room!!\r
20581         SUBM    A,C             ; C/ amount we must flush to make room\r
20582 \r
20583 ; Here to find pages for flush using LRU algorithm\r
20584 \r
20585 GL1:    MOVE    B,PURVEC+1(TVP) ; get pointer to pure sr vector\r
20586         MOVEI   0,-1            ; get very large age\r
20587 \r
20588 GL2:    SKIPN   1(B)            ; skip if not already flushed\r
20589         JRST    GL3\r
20590         HLRZ    D,2(B)          ; get this ones age\r
20591         CAMLE   D,0             ; skip if this is a candidate\r
20592         JRST    GL3\r
20593         MOVE    E,B             ; point to table entry with E\r
20594         MOVEI   0,(D)           ; and use as current best\r
20595 GL3:    ADD     B,[ELN,,ELN]    ; look at next\r
20596         JUMPL   B,GL2\r
20597 \r
20598         HLRE    B,1(E)          ; get length of flushee\r
20599         ASH     B,-PGSHFT       ; to negative # of pages\r
20600         ADD     C,B             ; update amount needed\r
20601         SETZM   1(E)            ; indicate it will be gone\r
20602         JUMPG   C,GL1           ; jump if more to get\r
20603 \r
20604 ; Now compact pure space\r
20605 \r
20606         PUSH    P,A             ; need all acs\r
20607         SETZB   E,A\r
20608         HRRZ    D,PURVEC(TVP)   ; point to first in core addr order\r
20609         HRRZ    C,PURTOP        ; get destination page\r
20610         ASH     C,-PGSHFT       ; to page number\r
20611 \r
20612 CL1:    ADD     D,PURVEC+1(TVP) ; to real pointer\r
20613         SKIPE   1(D)            ; skip if this one is a flushee\r
20614         JRST    CL2\r
20615 \r
20616         HRRZ    D,2(D)          ; point to next one in chain\r
20617         JUMPN   E,CL3           ; jump if not first one\r
20618         HRRM    D,PURVEC(TVP)   ; and use its next as first\r
20619         JRST    CL4\r
20620 \r
20621 CL3:    HRRM    D,2(E)          ; link up\r
20622         JRST    CL4\r
20623 \r
20624 ; Found a stayer, move it if necessary\r
20625 \r
20626 CL2:    MOVEI   E,(D)           ; another pointer to slot\r
20627         HLRE    B,1(D)          ; - length of block\r
20628         HRRZ    D,1(D)          ; pointer to block\r
20629         SUB     D,B             ; point to top of block\r
20630         ASH     D,-PGSHFT               ; to page number\r
20631         CAIN    D,(C)           ; if not moving, jump\r
20632         JRST    CL6\r
20633 \r
20634         ASH     B,-PGSHFT       ; to pages\r
20635 IFN ITS,[\r
20636 CL5:    SUBI    C,1             ; move to pointer and from pointer\r
20637         SUBI    D,1\r
20638         DOTCAL  CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D]\r
20639         FATAL   PURE SHUFFLE LOSSAGE\r
20640         AOJL    B,CL5           ; count down\r
20641 ]\r
20642 IFE ITS,[\r
20643         PUSH    P,B             ; save # of pages\r
20644         MOVEI   A,-1(D)         ; copy from pointer\r
20645         HRLI    A,400000        ; get this fork code\r
20646         RMAP                    ; get a JFN (hopefully)\r
20647         EXCH    D,(P)           ; D # of pages (save from)\r
20648         ADDM    D,(P)           ; update from\r
20649         MOVEI   B,-1(C)         ; to pointer in B\r
20650         HRLI    B,400000\r
20651         MOVSI   C,120000        ; read/execute modes\r
20652 \r
20653         PMAP                    ; move a page\r
20654         SUBI    A,1\r
20655         SUBI    B,1\r
20656         AOJL    D,.-3           ; move them all\r
20657 \r
20658         MOVEI   C,1(B)\r
20659         POP     P,D\r
20660         ADDI    D,1\r
20661 ]\r
20662 ; Update the table address for this loser\r
20663 \r
20664         SUBM    C,D             ; compute offset (in pages)\r
20665         ASH     D,PGSHFT        ; to words\r
20666         ADDM    D,1(E)          ; update it\r
20667 CL7:    HRRZ    D,2(E)          ; chain on\r
20668 CL4:    TRNN    D,400000        ; skip if end of chain\r
20669         JRST    CL1\r
20670 \r
20671         ASH     C,PGSHFT        ; to words\r
20672         MOVEM   C,PURBOT        ; reset pur bottom\r
20673         POP     P,A\r
20674         JRST    GETPAG\r
20675 \r
20676 CL6:    HRRZ    C,1(E)          ; get new top of world\r
20677         ASH     C,-PGSHFT       ; to page #\r
20678         JRST    CL7\r
20679 \r
20680 ; SUBR to create an entry in the vector for one of these guys\r
20681 \r
20682 MFUNCTION PCODE,SUBR\r
20683 \r
20684         ENTRY   2\r
20685 \r
20686         GETYP   0,(AB)          ; check 1st arg is string\r
20687         CAIE    0,TCHSTR\r
20688         JRST    WTYP1\r
20689         GETYP   0,2(AB)         ; second must be fix\r
20690         CAIE    0,TFIX\r
20691         JRST    WTYP2\r
20692 \r
20693         MOVE    A,(AB)          ; convert name of program to sixbit\r
20694         MOVE    B,1(AB)\r
20695         PUSHJ   P,STRTO6\r
20696 PCODE4: MOVE    C,(P)           ; get name in sixbit\r
20697 \r
20698 ; Now look for either this one or an empty slot\r
20699 \r
20700         MOVEI   E,0\r
20701         MOVE    B,PURVEC+1(TVP)\r
20702 \r
20703 PCODE2: CAMN    C,(B)           ; skip if this is not it\r
20704         JRST    PCODE1          ; found it, drop out of loop\r
20705         JUMPN   E,.+3           ; dont record another empty if have one\r
20706         SKIPN   (B)             ; skip if slot filled\r
20707         MOVE    E,B             ; remember pointer\r
20708         ADD     B,[ELN,,ELN]\r
20709         JUMPL   B,PCODE2        ; jump if more to look at\r
20710 \r
20711         JUMPE   E,PCODE3        ; if E=0, error no room\r
20712         MOVEM   C,(E)           ; else stash away name and zero rest\r
20713         SETZM   1(E)\r
20714         SETZM   2(E)\r
20715         JRST    .+2\r
20716 \r
20717 PCODE1: MOVE    E,B             ; build <slot #>,,<offset>\r
20718         MOVEI   0,0             ; flag whether new slot\r
20719         SKIPE   1(E)            ; skip if mapped already\r
20720         MOVEI   0,1\r
20721         MOVE    B,3(AB)\r
20722         HLRE    D,E\r
20723         HLRE    E,PURVEC+1(TVP)\r
20724         SUB     D,E\r
20725         HRLI    B,(D)\r
20726         MOVSI   A,TPCODE\r
20727         SKIPN   NOSHUF          ; skip if not shuffling\r
20728         JRST    FINIS\r
20729         JUMPN   0,FINIS         ; jump if winner\r
20730         PUSH    TP,A\r
20731         PUSH    TP,B\r
20732         HLRZ    A,B\r
20733         PUSHJ   P,PLOAD\r
20734         JRST    PCOERR\r
20735         POP     TP,B\r
20736         POP     TP,A\r
20737         JRST    FINIS\r
20738 \r
20739 PCOERR: PUSH    TP,$TATOM\r
20740         PUSH    TP,EQUOTE PURE-LOAD-FAILURE\r
20741         JRST    CALER1\r
20742 \r
20743 \r
20744 PCODE3: HLRE    A,PURVEC+1(TVP) ; get current length\r
20745         MOVNS   A\r
20746         ADDI    A,10*ELN        ; add 10(8) more entry slots\r
20747         PUSHJ   P,IBLOCK\r
20748         EXCH    B,PURVEC+1(TVP) ; store new one and get old\r
20749         HLRE    A,B             ; -old length to A\r
20750         MOVSI   B,(B)           ; start making BLT pointer\r
20751         HRR     B,PURVEC+1(TVP)\r
20752         SUBM    B,A             ; final dest to A\r
20753         BLT     B,-1(A)\r
20754         JRST    PCODE4\r
20755 \r
20756 ; Here if must try to GC for some more core\r
20757 \r
20758 ASKAGC: SKIPE   GCFLG           ; if already in GC, lose\r
20759         POPJ    P,\r
20760         SUBM    A,0             ; amount required to 0\r
20761         ASH     0,PGSHFT        ; TO WORDS\r
20762         MOVEM   0,GCDOWN        ; pass as funny arg to AGC\r
20763         EXCH    A,C             ; save A from gc's destruction\r
20764 IFN ITS,        .IOPUSH MAPCH,          ; gc uses same channel\r
20765         PUSH    P,C\r
20766         MOVE    C,[8,,9.]       ; SET UP INDICATORS FOR GC\r
20767         PUSHJ   P,AGC\r
20768         POP     P,C\r
20769 IFN ITS,        .IOPOP  MAPCH,\r
20770         EXCH    C,A\r
20771         JUMPGE  C,GETPAG\r
20772         PUSH    TP,$TATOM\r
20773         PUSH    TP,EQUOTE NO-MORE-PAGES\r
20774         AOJA    TB,CALER1\r
20775 \r
20776 ; Here to clean up pure space by flushing all shared stuff\r
20777 \r
20778 PURCLN: SKIPE   NOSHUF\r
20779         POPJ    P,\r
20780         MOVEI   B,400000\r
20781         HRRM    B,PURVEC(TVP)   ; flush chain pointer\r
20782         MOVE    B,PURVEC+1(TVP) ; get pointer to table\r
20783         SETZM   1(B)            ; zero pointer entry\r
20784         SETZM   2(B)            ; zero link and age slots\r
20785         ADD     B,[ELN,,ELN]    ; go to next slot\r
20786         JUMPL   B,.-3           ; do til exhausted\r
20787         MOVE    B,PURBOT        ; now return pages\r
20788         SUB     B,PURTOP        ; compute page AOBJN pointer\r
20789         JUMPE   B,CPOPJ         ; no pure pages?\r
20790         MOVSI   B,(B)\r
20791         HRR     B,PURBOT\r
20792         ASH     B,-PGSHFT\r
20793 IFN ITS,[\r
20794         DOTCAL  CORBLK,[[1000,,0],[1000,,-1],B]\r
20795         FATAL   SYSTEM WONT TAKE CORE BACK?\r
20796 ]\r
20797 IFE ITS,[\r
20798         HLRE    D,B             ; - # of pges to flush\r
20799         HRLI    B,400000        ; specify hacking hom fork\r
20800         MOVNI   A,1\r
20801 \r
20802         PMAP\r
20803         ADDI    B,1\r
20804         AOJL    D,.-2\r
20805 ]\r
20806         MOVE    B,PURTOP        ; now fix up pointers\r
20807         MOVEM   B,PURBOT        ;   to indicate no pure\r
20808 CPOPJ:  POPJ    P,\r
20809 \r
20810 ; Here to move the entire pure space.\r
20811 ;       A/      # and direction of pages to move (+ ==> up)\r
20812 \r
20813 MOVPUR: SKIPE   NOSHUF\r
20814         FATAL   CANT MOVE PURE SPACE AROUND\r
20815         IFE ITS [ASH A,1]\r
20816         SKIPN   B,A             ; zero movement, ignore call\r
20817         POPJ    P,\r
20818 \r
20819         ASH     B,PGSHFT        ; convert to words for pointer update\r
20820         MOVE    C,PURVEC+1(TVP) ; loop through updating non-zero entries\r
20821         SKIPE   1(C)\r
20822         ADDM    B,1(C)\r
20823         ADD     C,[ELN,,ELN]\r
20824         JUMPL   C,.-3\r
20825 \r
20826         MOVE    C,PURTOP        ; found pages at top and bottom of pure\r
20827         ASH     C,-PGSHFT\r
20828         MOVE    D,PURBOT\r
20829         ASH     D,-PGSHFT\r
20830         ADDM    B,PURTOP        ; update to new boundaries\r
20831         ADDM    B,PURBOT\r
20832         CAIN    C,(D)           ; differ?\r
20833         POPJ    P,\r
20834         JUMPG   A,PUP           ; if moving up, go do separate CORBLKs\r
20835 \r
20836 IFN ITS,[\r
20837         SUBM    D,C             ; -size of area to C (in pages)\r
20838         MOVEI   E,(D)           ; build pointer to bottom of destination\r
20839         ADD     E,A\r
20840         HRLI    E,(C)\r
20841         HRLI    D,(C)\r
20842         DOTCAL  CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D]\r
20843         FATAL   CANT MOVE PURE\r
20844         POPJ    P,\r
20845 \r
20846 PUP:    SUBM    C,D             ; pages to move to D\r
20847         ADDI    A,(C)           ; point to new top\r
20848 \r
20849 PUPL:   SUBI    C,1\r
20850         SUBI    A,1\r
20851         DOTCAL  CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C]\r
20852         FATAL   CANT MOVE PURE\r
20853         SOJG    D,PUPL\r
20854         POPJ    P,\r
20855 ]\r
20856 IFE ITS,[\r
20857         SUBM    D,C             ; pages to move to D\r
20858         MOVSI   E,(C)           ; build aobjn pointer\r
20859         HRRI    E,(D)           ; point to lowest\r
20860         ADD     D,A             ; D==> new lowest page\r
20861 PURCL1: MOVSI   A,400000        ; specify here\r
20862         HRRI    A,(E)           ; get a page\r
20863         RMAP                    ; get a real handle on it\r
20864         MOVE    B,D             ; where to go\r
20865         HRLI    B,400000\r
20866         MOVSI   C,120000\r
20867         PMAP\r
20868         ADDI    D,1\r
20869         AOBJN   E,PURCL1\r
20870         POPJ    P,\r
20871 \r
20872 PUP:    SUB     D,C             ; - count to D\r
20873         MOVSI   E,(D)           ; start building AOBJN\r
20874         HRRI    E,(C)           ; aobjn to top\r
20875         ADD     C,A             ; C==> new top\r
20876         MOVE    D,C\r
20877 \r
20878 PUPL:   MOVSI   A,400000\r
20879         HRRI    A,(E)\r
20880         RMAP                    ; get real handle\r
20881         MOVE    B,D\r
20882         HRLI    B,400000\r
20883         MOVSI   C,120000\r
20884         PMAP\r
20885         SUBI    E,2\r
20886         SUBI    D,1\r
20887         AOBJN   E,PUPL\r
20888 \r
20889         POPJ    P,\r
20890 ]\r
20891 IFN ITS,[\r
20892 CSIXBT: MOVEI   0,5\r
20893         PUSH    P,[440700,,C]\r
20894         PUSH    P,[440600,,D]\r
20895         MOVEI   D,0\r
20896 CSXB2:  ILDB    E,-1(P)\r
20897         CAIN    E,177\r
20898         JRST    CSXB1\r
20899         SUBI    E,40\r
20900         IDPB    E,(P)\r
20901         SOJG    0,CSXB2\r
20902 CSXB1:  SUB     P,[2,,2]\r
20903         MOVE    C,D\r
20904         POPJ    P,\r
20905 ]\r
20906 GENVN:  MOVE    C,[440700,,MUDSTR+2]\r
20907         MOVEI   D,5\r
20908         MOVEI   B,0\r
20909 VNGEN:  ILDB    0,C\r
20910         CAIN    0,177\r
20911         POPJ    P,\r
20912         IMULI   B,10.\r
20913         SUBI    0,60\r
20914         ADD     B,0\r
20915         SOJG    D,VNGEN\r
20916         POPJ    P,\r
20917 \r
20918 IFE ITS,[\r
20919 MSKS:   774000,,0\r
20920         777760,,0\r
20921         777777,,700000\r
20922         777777,,777400\r
20923         777777,,777776\r
20924 ]\r
20925 END\r
20926 \f\r
20927 TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE\r
20928 \r
20929 RELOCATABLE\r
20930 \r
20931 .INSRT MUDDLE >\r
20932 \r
20933 .GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY\r
20934 .GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW\r
20935 \r
20936 ; PSTACK OFFSETS\r
20937 \r
20938 INCNT==0        ; INNER LOOP COUNT\r
20939 LISTNO==-1      ; ARG NUMBER BEING HACKED\r
20940 ARGCNT==-2      ; FINAL ARG COUNTER\r
20941 NARGS==-3       ; NUMBER OF STRUCTURES\r
20942 NTHRST==-4      ; 0=> MAP REST, OTHERWISE MAP FIRST\r
20943 \r
20944 ; MAP THE "CAR" OF EACH LIST\r
20945 \r
20946 MFUNCTION MAPF,SUBR\r
20947 \r
20948         PUSH    P,.             ; PUSH NON-ZERO\r
20949         JRST    MAP1\r
20950 \r
20951 ; MAP THE "CDR" OF EACH LIST\r
20952 \r
20953 MFUNCTION MAPR,SUBR\r
20954 \r
20955         PUSH    P,[0]\r
20956 \r
20957 MAP1:   ENTRY\r
20958         HLRE    C,AB            ; HOW MANY ARGS\r
20959         ASH     C,-1            ; TO # OF PAIRS\r
20960         ADDI    C,3             ; AT LEAST 3\r
20961         JUMPG   C,TFA           ; NOT ENOUGH\r
20962         GETYP   A,(AB)          ; TYPE OF CONSTRUCTOR\r
20963         CAIN    A,TFALSE        ; ANY CONSING NEEDE?\r
20964         JRST    MAP2            ; NO, SKIP CHECK\r
20965         PUSHJ   P,APLQ          ; CHECK IF APPLICABLE\r
20966         JRST    NAPT            ; NO, ERROR\r
20967 MAP2:   MOVNS   C               ; POS NO. OF ARGS (-3)\r
20968         ADDI    C,1             ; C/ NOW # OF LISTS...\r
20969         PUSH    P,C             ; SAVE IT\r
20970         PUSH    TP,[TATOM,,-1]  ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET\r
20971         PUSH    TP,MQUOTE LMAP,[LMAP ]INTRUP\r
20972         PUSHJ   P,FRMSTK        ; **GFP**\r
20973         PUSH    TP,[0]          ; **GFP**\r
20974         PUSH    TP,[0]          ; **GFP**\r
20975         PUSHJ   P,SPECBIND      ; **GFP**\r
20976         MOVE    C,(P)           ; RESTORE COUNT OF ARGS\r
20977         MOVE    A,AB            ; COPY ARG POINTER\r
20978         MOVSI   0,TAB           ; CLOBBER A'S TYPE\r
20979         MOVEM   0,ASTO(PVP)\r
20980 \r
20981 ARGLP:  INTGO                   ; STACK MAY OVERFLOW\r
20982         PUSH    TP,4(A)         ; SKIP FCNS\r
20983         PUSH    TP,5(A)\r
20984         ADD     A,[2,,2]\r
20985         SOJG    C,ARGLP         ; ALL UP ON STACK\r
20986 \r
20987 ; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR\r
20988 \r
20989         PUSH    TP,(AB)         ; CONSTRUCTOR\r
20990         PUSH    TP,1(AB)\r
20991         SETZM   ASTO(PVP)\r
20992         PUSH    P,[-1]          ; FUNNY TEMPS\r
20993         PUSH    P,[0]\r
20994         PUSH    P,[0]\r
20995 \r
20996 ; OUTER LOOP CDRING  EACH STRUCTURE\r
20997 \r
20998 OUTRLP: SETZM   LISTNO(P)       ; START AT 0TH LIST\r
20999         MOVE    0,NARGS(P)      ; TOTAL # OF STRUCS\r
21000         MOVEM   0,INCNT(P)      ; AS COUNTER IN INNER LOOP\r
21001         PUSH    TP,2(AB)        ; PUSH THE APPLIER\r
21002         PUSH    TP,3(AB)\r
21003 \r
21004 ; INNER LOOP, CONS UP EACH APPLICATION\r
21005 \r
21006 INRLP:  INTGO\r
21007         MOVEI   E,2             ; READY TO BUMP LISTNO\r
21008         ADDB    E,LISTNO(P)     ; CURRENT STORED AND IN C\r
21009         ADDI    E,(TB)4         ; POINT TO A STRUCTURE\r
21010         MOVE    A,(E)           ; PICK IT UP\r
21011         MOVE    B,1(E)          ; AND VAL\r
21012         PUSHJ   P,TYPSEG        ; SETUP TO REST IT ETC.\r
21013         SKIPL   ARGCNT(P)       ; DONT INCR THE 1ST TIME\r
21014         XCT     INCR1(C)        ; INCREMENT THE LOSER\r
21015         MOVE    0,DSTO(PVP)     ; UPDATE THE LIST\r
21016         MOVEM   0,(E)\r
21017         MOVEM   D,1(E)          ; CLOBBER AWAY\r
21018         PUSH    TP,DSTO(PVP)    ; FOR REST CASE\r
21019         PUSH    TP,D\r
21020         PUSHJ   P,NXTLM         ; SKIP IF GOT ONE, ELSE DONT\r
21021         JRST    DONEIT          ; FINISHED\r
21022         SETZM   DSTO(PVP)\r
21023         SKIPN   NTHRST(P)       ; SKIP IF MAP REST\r
21024         JRST    INRLP1\r
21025         MOVEM   A,-1(TP)        ; IUSE AS ARG\r
21026         MOVEM   B,(TP)\r
21027 INRLP1: SOSE    INCNT(P)        ; COUNT ARGS\r
21028         JRST    INRLP           ; MORE, GO DO THEM\r
21029 \r
21030 \r
21031 ; ALL ARGS PUSHED, APPLY USER FCN\r
21032 \r
21033         SKIPGE  ARGCNT(P)       ; UN NEGATE ARGCNT\r
21034         SETZM   ARGCNT(P)\r
21035         MOVE    A,NARGS(P)      ; GET # OF ARGS\r
21036         ADDI    A,1\r
21037         ACALL   A,MAPPLY        ; APPLY THE BAG BITER\r
21038 \r
21039         GETYP   0,(AB)          ; GET TYPE OF CONSTRUCTOR\r
21040         CAIN    0,TFALSE        ; SKIP IF ONE IS THERE\r
21041         JRST    OUTRL1\r
21042         PUSH    TP,A\r
21043         PUSH    TP,B\r
21044         AOS     ARGCNT(P)\r
21045         JRST    OUTRLP\r
21046 \r
21047 OUTRL1: MOVEM   A,-1(TP)        ; SAVE PARTIAL VALUE\r
21048         MOVEM   B,(TP)\r
21049         JRST    OUTRLP\r
21050 \r
21051 ; HERE IF ALL FINISHED\r
21052 \r
21053 DONEIT: HRLS    C,LISTNO(P)     ; HOW MANY DONE\r
21054         SUB     TP,[2,,2]       ; FLUSH SAVED VAL\r
21055         SUB     TP,C            ; FLUSH TUPLE OF CRUFT\r
21056 DONEI1: SKIPGE  ARGCNT(P)\r
21057         SETZM   ARGCNT(P)       ; IN CASE STILL NEGATIVE\r
21058         SETZM   DSTO(PVP)       ; UNSCREW\r
21059         GETYP   0,(AB)          ; ANY CONSTRUCTOR\r
21060         CAIN    0,TFALSE\r
21061         JRST    MFINIS          ; NO, LEAVE\r
21062         AOS     D,ARGCNT(P)     ; IF NO ARGS\r
21063         ACALL   D,APPLY         ; APPLY IT\r
21064 \r
21065         JRST    FINIS\r
21066 \r
21067 ; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE ()\r
21068 \r
21069 MFINIS: POP     TP,B\r
21070         POP     TP,A\r
21071         JRST    FINIS\r
21072 \r
21073 ; **GFP** FROM HERE TO THE END\r
21074 \r
21075 MFUNCTION MAPLEAVE,SUBR\r
21076 \r
21077         ENTRY\r
21078 \r
21079         CAMGE   AB,[-3,,0]\r
21080         JRST    TMA\r
21081         MOVE    B,MQUOTE LMAP,[LMAP ]INTRUP \r
21082         PUSHJ   P,ILVAL\r
21083         GETYP   0,A\r
21084         CAIE    0,TFRAME        ; MAKE SURE WINNER\r
21085         JRST    NOTM\r
21086         PUSH    TP,A\r
21087         PUSH    TP,B\r
21088         MOVEI   B,-1(TP)        ; POINT TO FRAME POINTER\r
21089         PUSHJ   P,CHFSWP\r
21090         PUSHJ   P,CHUNW\r
21091         JUMPL   C,MAPL1         ; RET VAL SUPPLIED\r
21092         MOVSI   A,TATOM\r
21093         MOVE    B,MQUOTE T\r
21094         JRST    FINIS\r
21095 \r
21096 MAPL1:  MOVE    A,(C)\r
21097         MOVE    B,1(C)\r
21098         JRST    FINIS\r
21099 \r
21100 MFUNCTION MAPSTOP,SUBR\r
21101 \r
21102         ENTRY\r
21103 \r
21104         PUSH    P,[1]\r
21105         JRST    MAPREC\r
21106 \r
21107 MFUNCTION MAPRET,SUBR\r
21108 \r
21109         ENTRY\r
21110 \r
21111         PUSH    P,[0]\r
21112 MAPREC: MOVE    B,MQUOTE LMAP,[LMAP ]INTRUP\r
21113         PUSHJ   P,ILVAL         ; GET VALUE\r
21114         GETYP   0,A             ; FRAME?\r
21115         CAIE    0,TFRAME\r
21116         JRST    NOTM\r
21117         PUSH    TP,A\r
21118         PUSH    TP,B\r
21119         MOVEI   B,-1(TP)\r
21120         POP     P,0             ; RET/STOP SWITCH\r
21121         JUMPN   0,MAPRC1        ; JUMP IF STOP\r
21122         PUSHJ   P,CHFSWP        ; CHECK IT OUT (AND MAYBE SWAP)\r
21123         PUSH    P,[NLOCR]\r
21124         JRST    MAPRC2\r
21125 MAPRC1: PUSHJ   P,CHFSWP\r
21126         PUSH    P,[NLOCR1]\r
21127 MAPRC2: HRRZ    E,SPSAV(B)      ; UNBIND BEFORE RETURN\r
21128         PUSH    TP,$TAB\r
21129         PUSH    TP,C\r
21130         ADDI    E,1             ; FUDGE FOR UNBINDER\r
21131         PUSHJ   P,SSPEC1        ; UNBINDER\r
21132         HLRE    D,(TP)          ; FIND NUMBER\r
21133         JUMPE   D,MAPRE1        ; SKIP IF NONE TO MOVE\r
21134         MOVNS   E,D             ; AND PLUS IT\r
21135         HRLI    E,(E)           ; COMPUTE NEW TP\r
21136         ADD     E,TPSAV(B)      ; NEW TP\r
21137         HRRZ    C,TPSAV(B)      ; GET OLD TOP\r
21138         MOVEM   E,TPSAV(B)\r
21139         HRL     C,(TP)          ; AND NEW BOT\r
21140         ADDI    C,1\r
21141         BLT     C,(E)           ; BRING IT ALL DOWN\r
21142 MAPRE1: ASH     D,-1            ; NO OF ARGS\r
21143         HRRI    TB,(B)          ; PREPARE TO FINIS\r
21144         MOVSI   A,TFIX\r
21145         MOVEI   B,(D)\r
21146         POP     P,0             ; GET PC TO GO TO\r
21147         MOVEM   0,PCSAV(TB)\r
21148         JRST    CONTIN          ; BACK TO MAPPER\r
21149 \r
21150 NLOCR1: TDZA    A,A             ; ZER SW\r
21151 NLOCR:  MOVEI   A,1\r
21152         GETYP   0,(AB)          ; CHECK IF BUILDING\r
21153         CAIN    0,TFALSE\r
21154         JRST    FLUSHM          ; REMOVE GOODIES\r
21155         ADDM    B,ARGCNT(P)     ; BUMP ARG COUNTER\r
21156 NLOCR2: JUMPE   A,DONEI1\r
21157         JRST    OUTRLP\r
21158 \r
21159 FLUSHM: ASH     B,1             ; FLUSH GOODIES DROPPED\r
21160         HRLI    B,(B)\r
21161         SUB     TP,B\r
21162         JRST    NLOCR2\r
21163 \r
21164 NOTM:   PUSH    TP,$TATOM\r
21165         PUSH    TP,EQUOTE NOT-IN-MAP-FUNCTION\r
21166         JRST    CALER1\r
21167 \r
21168 END\r
21169 \f; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING\r
21170 ; OF MUDDLE.  IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND\r
21171 ; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE.\r
21172 \r
21173 ; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE.\r
21174 ; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS.  THE INTGO MACRO\r
21175 ; PERFORMS THE APPROPRIATE CHECK\r
21176 \r
21177 ; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST\r
21178 ; BE ABSOLUTELY PURE.  BETWEEN ANY TWO INSTRUCTIONS OF\r
21179 ; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH\r
21180 ; A COMPACTING GARBAGE COLLECTION MAY OCCUR.\r
21181 ; NOTE:  A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN\r
21182 ; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S\r
21183 ; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS.\r
21184 \r
21185 ; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY\r
21186 ; MQUOTE <PNAME> -- FOR NORMAL ATOMS\r
21187 ; EQUOTE <PNAME> -- FOR ERROR COMMENT ATOMS\r
21188 \r
21189 ; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:\r
21190 \r
21191 ;       MCALL N,<PNAME> ;SEE MCALL MACRO\r
21192 ;       ACALL AC,<PNAME> ; SEE ACALL MACRO\r
21193 \r
21194 ; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL \r
21195 ; NAME WILL BE USED\r
21196 \r
21197 ; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED\r
21198 ; BY THE MACROS SHOULLD BE USED.\r
21199 ; THESE ARE .MCALL AND .ACALL -- EXAMPLE:\r
21200 ;       .ACALL A,@(B)\r
21201 \r
21202 \r
21203 \r
21204 \r
21205 \r
21206 \f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)\r
21207 \r
21208 ;     20:       SPECIAL CODE FOR UUO AND INTERUPTS\r
21209 \r
21210 ;CODBOT:        WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE\r
21211 \r
21212 ;               --IMPURE CODE--\r
21213 \r
21214 ;CODTOP:        WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE\r
21215 \r
21216 ;PARBOT:        WORD CONTAINING LOCATION OFBOTTOMMOST LIST\r
21217 \r
21218 ;               --PAIRSS--\r
21219 \r
21220 ;PARTOP:        WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD\r
21221 \r
21222 ;VECBOT:        WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS\r
21223 \r
21224 ;               --VECTORS--\r
21225 \r
21226 ;VECTOP:        WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR\r
21227 ;               THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR\r
21228 \r
21229 ;               --GC MARK PDL (SOMETIMES NOT THERE)--\r
21230 \r
21231 ;CORTOP:        TOP OF LOW-SEGMENT/IMPURE CORE\r
21232 \r
21233 ;600000:        START OF PURE CODE (SHARED ALSO)\r
21234 \r
21235 ;               --PURE CODE--\r
21236 \r
21237 ;\r
21238 \r
21239 \r
21240 \f; BASIC DATA TYPES PRE-DEFINED IN MUDDLE\r
21241 \r
21242 ; PRIMITIVE DATA TYPES\r
21243 ; IF T IS A DATA TYPE THEN $T=[T,,0]\r
21244 \r
21245 ; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER\r
21246 \r
21247 \r
21248 ;TLOSE          ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)\r
21249 ;TFIX           ;FIXED POINT\r
21250 ;TFLOAT         ;FLOATING POINT\r
21251 ;TCHRS          ;WORD OF UP TO 5 ASCII CHARACTERS\r
21252 ;TENTRY         ; MARKS BEGINNING OF A FRAME ON TP STACK\r
21253 ;TSUBR          ;BUILT IN FUNCTION WITH EVALUATED ARGS\r
21254 ;TFSUBR         ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS\r
21255 ;TUNBOU         ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM\r
21256 ;TBIND          ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK\r
21257 ;TILLEG         ;POINTER  PREVIOUSLY HERE NOW ILLEGAL\r
21258 ;TTIME          ;UNIQUE NUMBER (SEE FLOAD)\r
21259 ;TLIST          ;POINTER TO LIST ELEMENT\r
21260 ;TFORM          ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION\r
21261 ;TSEG           ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED \r
21262 ;               ;AS A SEGMENT\r
21263 ;TEXPR          ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION\r
21264 ;TFUNAR         ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS\r
21265 ;TLOCL          ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC)\r
21266 ;TFALSE         ;NOT TRUTH\r
21267 ;TDEFER         ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST)\r
21268 ;TUVEC          ;AOBJN POINTER TO UNIFORM VECTOR\r
21269 ;TOBLS          ;AOBJN TO UVEC OF LISTS OF ATOMS.  USED AS SYMBOL TABLE\r
21270 ;TVEC           ;VECTOR  (AOBJN POINTER TO GENERALIZED VECTOR)\r
21271 ;TCHAN          ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL\r
21272 ;TLOCV          ;LOCATIVE TO GENERAL VECTOR  (SEE AT,IN AND SETLOC)\r
21273 ;TTVP           ;POINTER TO TRANSFER VECTOR\r
21274 ;TBVL           ;BEGINS A VECTOR BINDING ON THE TP STACK\r
21275 ;TTAG           ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG\r
21276 ;TPVP           ;POINTER TO PROCESS VECTOR\r
21277 ;TLOCI          ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER)\r
21278 ;TTP            ;POINTER TO MAIN MARKED STACK\r
21279 ;TSP            ;POINTER TO CURRENT BINDINGS ON STACK\r
21280 ;TLOCS          ;LOCATIVE TO STACK (NOT CURRENTLY USED)\r
21281 ;TPP            ;POINTER TO PLANNER  PDL (NOT CURRENTLY USED)\r
21282 ;TPLD           ;POINTER TO P-STACK (UNMARKED)\r
21283 ;TARGS          ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE)\r
21284 ;TAB            ;SAVED AB (NOT GIVEN TO USER)\r
21285 ;TTB            ;SAVED TB (NOT GIVEN TO USER)\r
21286 ;TFRAME         ;USER POINTER TO STACK FRAME\r
21287 ;TCHSTR         ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED)\r
21288 ;TATOM          ;POINTER TO ATOM\r
21289 ;TLOCD          ;USER LOCATIVE TO ATOM VALUE\r
21290 ;TBYTE          :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED)\r
21291 ;TENV           ;USER POINTER TO FRAME USED AS AN ENVIRONMENT\r
21292 ;TACT           ;USER POINTER TO FRAME FOR A NAMED ACTIVATION\r
21293 ;TASOC          ;ASSOCIATION TRIPLE\r
21294 ;TLOCU          ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC)\r
21295 ;TLOCS          ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC)\r
21296 ;TLOCA          ;LOCATIVE TO ELEMENT IN ARG BLOCK\r
21297 ;TENTS          ;NOT USED\r
21298 ;TBS            ; ""\r
21299 ;TPLDS          ; ""\r
21300 ;TPC            ; ""\r
21301 ;TINFO          ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS\r
21302 ;TNBS           ;NOT USED\r
21303 ;TBVLS          ;NOT USED\r
21304 ;TCSUBR         ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL)\r
21305 ;TWORD          ;36-BIT WORD\r
21306 ;TRSUBR         ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER)\r
21307 ;TCODE          ;UNIFORM VECTOR OF INSTRUCTIONS\r
21308 ;TCLIST         ;NOT USED\r
21309 ;TBITS          ;GENERAL BYTE POINTER\r
21310 ;TSTORA         ;POINTER TO NON GC IMPURE STUFF\r
21311 ;TPICTU         ;E&S CODE IN NON GC SPACE\r
21312 ;TSKIP          ;ENVIRONMENT SPLICE\r
21313 ;TLINK          ;LEXICAL LINK \r
21314 ;TINTH          ;INTERRUPT HEADER\r
21315 ;THAND          ;INTERRUPT HANDLER\r
21316 ;TLOCN          ;LOCATIVE TO ASSOCIATION\r
21317 ;TDECL          ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS\r
21318 ;TDISMI         ;TYPE MEANING DONT RUN REST OF HANDLERS\r
21319 ;TDCLI          ; INTERNAL TYPE FOR SAVED FUNCTION BODY\r
21320 ;TMENT          ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART\r
21321 ;TENTER         ; NON-MAIN ENTRY TO AN RSUBR\r
21322 ;TSPLICE        ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN\r
21323 ;TPCODE         ; PURE CODE POINTER IN FUNNY FORMAT\r
21324 ;TTYPEW         : TYPE WORD\r
21325 ;TTYPEC         ; TYPE CODE\r
21326 ;TGATOM         ; ATOM WITH GVALUE\r
21327 ;TREADA         ; READ ACTIVATION HACK\r
21328 ;TUNWIN         ; INTERNAL FOR UNWIND SPEC ON STACK\r
21329 ;TUBIND         ; BINDING OF UNSPECIAL ATOM\r
21330 ;TMACRO         ; EVAL MACRO\r
21331 \f\r
21332 ; STORGE ALLOCATION TYPES.  ALLOCATED BY AN "IRP" LATER IN THIS FILE\r
21333 \r
21334 \r
21335 ;S1WORD         ;UNMARKED STUFF OF NO INTEREST TO AGC\r
21336 ;S2WORD         ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.)\r
21337 ;S2DEFR         ;DEFERRED LIST VALUES\r
21338 ;SNWORD         ;POINTERS TO UNIFORM VECTORS\r
21339 ;S2NWOR         ;POINTERS TO GENERAL VECTORS\r
21340 ;STPSTK         ;STACK POINTERS\r
21341 ;SPSTK          ;UNMARKED STACK POINTERS\r
21342 ;SARGS          ;POINTERS TO ARG BLOCKS (USER)\r
21343 ;SABASE         ;POINTER TO ARG BLOCK (INTERNAL)\r
21344 ;STBASE         ;POINTER TO FRAME (INTERNAL)\r
21345 ;SFRAME         ;POINTER TO FRAME (USER)\r
21346 ;SBYTE          ;GENERAL BYTE POINTER\r
21347 ;SATOM          ;POINTER TO ATOM\r
21348 ;SLOCID         ;POINTER TO VALUE CELL OF ATOM\r
21349 ;SPVP           ;PROCESS VECTORS\r
21350 ;SCHSTR         ;ASCII BYTE POINTER\r
21351 ;SASOC          ;POINTER TO ASSOCIATION BLOCK\r
21352 ;SINFO          ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO\r
21353 ;SSTORE         ;NON GC STORGAGE POINTER\r
21354 ;SLOCA          ;ARG BLOCK LOCATIVE\r
21355 ;SLOCD          ;USER VALUE CELL LOCATIVE\r
21356 ;SLOCS          ;LOCATIVE TO STRING\r
21357 ;SLOCU          ;LOCATIVE TO UVECTOR\r
21358 ;SLOCV          ;LOCATIVE TO GENERAL VECTOR\r
21359 ;SLOCL          ;LOCATIVE TO LIST ELEENT\r
21360 ;SLOCN          ;LOCATIVE TO ASSOCIATION\r
21361 ;SGATOM         ;REALLY ATOM BUT SPECIAL GC HACK\r
21362 \r
21363 ;NOTE:  TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO\r
21364 ;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE.  IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED.\r
21365 ;\r
21366 ;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT\r
21367 ; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED\r
21368 \r
21369 \f; SOME MUDDLE DATA FORMATS\r
21370 \r
21371 ; FORMAT OF LIST ELEMENT\r
21372 \r
21373 ;       WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR\r
21374 ;                BITS 1-17 TYPE OF FIRST ELEMENT OF LIST\r
21375 ;                BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)\r
21376 ;\r
21377 ;       WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED\r
21378 ;\r
21379 ;       IF DATUM REQUIRES 54 BITS TO SPECIFY,  TYPE WILL BE "TDEFER" AND\r
21380 ;       VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR\r
21381 \r
21382 \r
21383 \r
21384 ;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)\r
21385 ;POINTED INTO BY AOBJN POINTER\r
21386 ;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS\r
21387 \r
21388 \r
21389 ;       TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)\r
21390 ;       OBJ<1>  OBJECT OF SPECIFIED TYPE\r
21391 ;       TYPE<2>\r
21392 ;       OBJ<2>\r
21393 ;       .\r
21394 ;       .\r
21395 ;       .\r
21396 ;       TYPE<N>\r
21397 ;       OBJ<N>\r
21398 ;       VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE\r
21399 ;       VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN\r
21400 \r
21401 \r
21402 \f;SPECIAL VECTORS IN THE INITIAL SYSTEM\r
21403 \r
21404 ;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES\r
21405 ;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER\r
21406 ;FOUND IN THE TYPE FIELD OF ANY GOODIE.  TABLES APLTYP AND EVLTYP ALSO EXIST\r
21407 ;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY.\r
21408 \r
21409 ;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A\r
21410 \r
21411 ;TYPE TO NAME OF TYPE TRANSLATION TABLE\r
21412 \r
21413 ;       TATOM,,<STORAGE ALLOCATION TYPE>+CHBIT+TMPLBT\r
21414 \r
21415 ;       ATOMIC NAME\r
21416 \r
21417 ; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE\r
21418 ; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS\r
21419 \r
21420 ;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT\r
21421 \r
21422 ;       <TUNBOU OR TLOCI>,,<0 OR BINDID>        ; TLOCI MEANS VAL EXISTS.\r
21423                                                 ;  0 MEANS GLOBAL\r
21424 ;                                               ; BINDID SPECS ENV IN\r
21425                                                 ; WHICH LOCAL VAL EXISTS\r
21426 ;       <LOCATIVE TO VALUE OR 0>\r
21427 ;       <POINTER TO OBLIST OR 0>\r
21428 ;       <ASCII /PNAME/>\r
21429 ;       <400000+SATOM,,0>\r
21430 ;       <LNTH>,,0       (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)\r
21431 \r
21432 ;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE\r
21433 ;WILL BE POINTED TO BY THE TRANSFER VECTOR\r
21434 ;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP\r
21435 ;THE FORMAT OF THIS VECTOR IS:\r
21436 \r
21437 ;       TYPE,,0\r
21438 ;       VALUE\r
21439 ;       .\r
21440 ;       .\r
21441 ;       .\r
21442 ;       TV DOPE WORDS\r
21443 \r
21444 \r
21445 ;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR\r
21446 ;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP\r
21447 ;THE FORMAT OF A PROCESS VECTOR IS:\r
21448 \r
21449 ;       TFIX,,0\r
21450 ;       PROCID  ;UNIQUE ID OF THIS PROCESS\r
21451 \r
21452 ;       20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS\r
21453 ;       CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS\r
21454 ;       OF THE FORM AC!STO(PVP)\r
21455 \r
21456 ;       OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER\r
21457 ;       .\r
21458 ;       .\r
21459 ;       .\r
21460 ;       PV DOPE WORDS\r
21461 \r
21462 \r
21463 \r
21464 \r
21465 ;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS\r
21466 \r
21467 \fIF1 [\r
21468 PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS\r
21469 /\r
21470 ]\r
21471 \r
21472 IF2 [PRINTC /MUDDLE\r
21473 /\r
21474 ]\r
21475 ;AC ASSIGNMNETS\r
21476 \r
21477 P"=17   ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)\r
21478 R"=16   ;REFERENCE BASE FOR RSUBRS\r
21479 M"=15   ;CODE BASE FOR RSUBRS\r
21480 SP"=14  ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP)\r
21481 TP"=13  ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS \r
21482         ;AND MARKED TEMPORARIES)\r
21483 TB"=12  ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER \r
21484 AB"=11  ;ARGUMENT PDL BASE (MARKED)\r
21485         ;AB IS AN AOBJN POINTER TO THE ARGUMENTS\r
21486 TVP"=7  ;TRANSFER VECTOR POINTER\r
21487 PVP"=6  ;PROCESS VECTOR POINTER\r
21488 \r
21489 ;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE\r
21490 \r
21491 A"=1    ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS\r
21492 B"=2\r
21493 C"=3\r
21494 D"=4\r
21495 E"=5\r
21496 \r
21497 NIL"=0  ;END OF LIST MARKER\r
21498 \r
21499 ;MACRO TO DEFINE MAIN IF NOT DEFINED\r
21500 \r
21501 IF1 [\r
21502 DEFINE SYSQ\r
21503         ITS==1\r
21504         IFE <<<.AFNM1>_-24.>-<SIXBIT /    T./>>,ITS==0\r
21505         IFN ITS,[PRINTC /ITS VERSION\r
21506 /]\r
21507         IFE ITS,[PRINTC /TENEX VERSION\r
21508 /]\r
21509  \r
21510         TERMIN\r
21511 \r
21512 DEFINE DEFMAI ARG,\D\r
21513         D==.TYPE ARG\r
21514         IFE <D-17>,ARG==0\r
21515         EXPUNGE D\r
21516         TERMIN\r
21517 ]\r
21518 \r
21519 DEFMAI MAIN\r
21520 DEFMAI READER\r
21521 \r
21522 IF2,EXPUNGE DEFMAI\r
21523 \r
21524 \f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS\r
21525 \r
21526 \r
21527 IFN MAIN,NUMPRI==-1\r
21528 \r
21529 IF1 [\r
21530 NUMPRI==-1      ;NUMBER OF PRIMITIVE TYPES\r
21531 \r
21532 DEFINE TYPMAK  SAT,LIST\r
21533 IRP A,,[LIST]\r
21534 NUMPRI==NUMPRI+1\r
21535 IRP B,,[A]\r
21536 T!B==NUMPRI\r
21537 .GLOBAL $!T!B\r
21538 IFN MAIN,[$!T!B=[T!B,,0]\r
21539 ]\r
21540 .ISTOP\r
21541 TERMIN\r
21542 IFN MAIN,[\r
21543 RMT [ADDTYP SAT,A\r
21544 ]]\r
21545 TERMIN\r
21546 TERMIN\r
21547 \r
21548 ;MACRO TO ADD STUFF TO TYPE VECTOR\r
21549 \r
21550 IFN MAIN,[\r
21551 DEFINE ADDTYP SAT,TYPE,NAME,CHF,\CH\r
21552         IFSE [CHF],CH==0\r
21553         IFSN [CHF],CH==CHBIT\r
21554         IFSE [NAME]IN,CH==CHBIT\r
21555         IFSN [CHF]-1,[\r
21556         TATOM,,CH+SAT\r
21557         IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL\r
21558                 IFSN [NAME]IN,MQUOTE [NAME]\r
21559                 ]\r
21560         IFSE [NAME],MQUOTE TYPE\r
21561         ]\r
21562         IFSE [CHF]-1,[\r
21563         TATOM,,CH+SAT\r
21564         IMQUOTE [NAME]\r
21565         ]\r
21566         TERMIN\r
21567 ]\r
21568 ]\r
21569 IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST\r
21570         RMT [EXPUN [LIST]\r
21571 ]\r
21572         TERMIN\r
21573 ]\r
21574 ]\r
21575 \r
21576 ;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD\r
21577 \r
21578 \r
21579 NUMSAT==0\r
21580 GENERAL==400000,,0      ;FLAG FOR BEING A GENERAL VECTOR\r
21581 \r
21582 IF1 [\r
21583 DEFINE PRMACR HACKER\r
21584 \r
21585 IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS\r
21586 ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE\r
21587 LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCT]\r
21588 \r
21589 HACKER A\r
21590 \r
21591 TERMIN\r
21592 TERMIN\r
21593 \r
21594 \r
21595 \r
21596 DEFINE DEFINR B\r
21597         NUMSAT==NUMSAT+1\r
21598         S!B==NUMSAT\r
21599         TERMIN\r
21600 ]\r
21601 \r
21602 PRMACR DEFINR\r
21603 \r
21604 STMPLT==NUMSAT+1\r
21605 \r
21606 ;MACRO FOR SAVING STUFF TO DO LATER\r
21607 \r
21608 .GSSET 4\r
21609 \r
21610 DEFINE HERE G00002,G00003\r
21611 G00002!G00003!TERMIN\r
21612 \r
21613 IF1 [\r
21614 DEFINE RMT A\r
21615 HERE [DEFINE HERE G00002,G00003\r
21616 G00002!][A!G00003!TERMIN]\r
21617 TERMIN\r
21618 ]\r
21619 \r
21620 \r
21621 RMT [EXPUNGE GENERAL,NUMSTA\r
21622 ]\r
21623 \r
21624 DEFINE XPUNGR A\r
21625         EXPUNGE S!A\r
21626         TERMIN\r
21627 \r
21628 IFE MAIN,[\r
21629 RMT [PRMACR XPUNGR\r
21630 ]\r
21631 ]\r
21632 \r
21633 C.BUF==1\r
21634 C.PRIN==2\r
21635 C.BIN==4\r
21636 C.OPN==10\r
21637 C.READ==40\r
21638 \r
21639 ; FLAG INDICATING VECTOR FOR GCHACK\r
21640 \r
21641 .VECT.==40000\r
21642 \r
21643 ; DEFINE SYMBLOS FOR VARIOUS OBLISTS\r
21644 \r
21645 SYSTEM==0       ;MAIN SYSTEM OBLIST\r
21646 ERRORS==1       ;ERROR COMMENT OBLIST\r
21647 INTRUP==2       ;INERRUPT OBLIST\r
21648 MUDDLE==3       ;MUDDLE GLOBAL SYMBOLS (ADDRESSES)\r
21649 \r
21650 RMT [EXPUNGE SYSTEM,ERRORS,INTRUP\r
21651 ]\r
21652 ; DEFINE SYMBOLS FOR PROCESS STATES\r
21653 \r
21654 RUNABL==1\r
21655 RESMBL==2\r
21656 RUNING==3\r
21657 DEAD==4\r
21658 BLOCKED==5\r
21659 \r
21660 IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED\r
21661 ]\r
21662 ]\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)\r
21663 \r
21664 IFN MAIN,[RMT [SAVE==.\r
21665         LOC TYPVLC\r
21666         ]\r
21667         ]\r
21668 \r
21669 \r
21670 TYPMAK S1WORD,[[LOSE],FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],[SUBR,,1],[FSUBR,,1]]\r
21671 TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME]\r
21672 TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE]]\r
21673 TYPMAK SLOCL,[LOCL]\r
21674 TYPMAK S2WORD,[FALSE]\r
21675 TYPMAK S2DEFRD,[[DEFER,IN]]\r
21676 TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST,-1]]\r
21677 TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL,1]]\r
21678 TYPMAK SLOCV,[LOCV]\r
21679 TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]]\r
21680 TYPMAK SPVP,[[PVP,PROCESS]]\r
21681 TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]]\r
21682 TYPMAK S2WORD,[[MACRO]]\r
21683 TYPMAK SPSTK,[[PDL,IN]]\r
21684 TYPMAK SARGS,[[ARGS,TUPLE]]\r
21685 TYPMAK SABASE,[[AB,IN]]\r
21686 TYPMAK STBASE,[[TB,IN]]\r
21687 TYPMAK SFRAME,[FRAME]\r
21688 TYPMAK SCHSTR,[[CHSTR,STRING]]\r
21689 TYPMAK SATOM,[ATOM]\r
21690 TYPMAK SLOCID,[LOCD]\r
21691 TYPMAK SBYTE,[BYTE]\r
21692 TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1]]\r
21693 TYPMAK SASOC,[ASOC]\r
21694 TYPMAK SLOCU,[LOCU]\r
21695 TYPMAK SLOCS,[LOCS]\r
21696 TYPMAK SLOCA,[LOCA]\r
21697 TYPMAK S1WORD,[[CBLK,IN]]\r
21698 TYPMAK STMPLT,[[TMPLT,TEMPLATE]]\r
21699 TYPMAK SLOCT,[LOCT]\r
21700         ;THE FOLLOWING TYPES (THROUGH CSUBR) CAN PROBABLY BE RECYCLED\r
21701 TYPMAK S1WORD,[[PC,IN]]\r
21702 TYPMAK SINFO,[[INFO,IN]]\r
21703 TYPMAK SATOM,[[BNDS,IN]]\r
21704 TYPMAK S2NWORD,[[BVLS,IN]]\r
21705 TYPMAK S1WORD,[[CSUBR,,1]]\r
21706 \r
21707 TYPMAK S1WORD,[[WORD]]\r
21708 TYPMAK S2NWORD,[[RSUBR,,1]]\r
21709 TYPMAK SNWORD,[CODE]\r
21710         ;TYPE CLIST CAN PROBABLY BE RECYCLED\r
21711 TYPMAK S2WORD,[[CLIST,IN]]\r
21712 TYPMAK S1WORD,[[BITS]]\r
21713 TYPMAK SSTORE,[STORAGE,PICTURE]\r
21714 TYPMAK STPSTK,[[SKIP,IN]]\r
21715 TYPMAK SATOM,[[LINK,,1]]\r
21716 TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]]\r
21717 TYPMAK SLOCN,[[LOCN,LOCAS]]\r
21718 TYPMAK S2WORD,[DECL]\r
21719 TYPMAK SATOM,[DISMISS]\r
21720 TYPMAK S2WORD,[[DCLI,IN]]\r
21721 TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1]]\r
21722 TYPMAK S2WORD,[SPLICE]\r
21723 TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]]\r
21724 TYPMAK SGATOM,[[GATOM,IN]]\r
21725 TYPMAK SFRAME,[[READA,,1]]\r
21726 TYPMAK STBASE,[[UNWIN,IN]]\r
21727 TYPMAK S1WORD,[[UBIND,IN]]\r
21728 IFN MAIN,[RMT [LOC SAVE\r
21729         ]\r
21730         ]\r
21731 IF2,EXPUNGE TYPMAK,DOTYPS\r
21732 \f\r
21733 RMT [EQUALS XP EXPUNGE\r
21734 IF2,XP STMPLT\r
21735 ]\r
21736 IF1 [\r
21737 \r
21738 DEFINE EXPUN LIST\r
21739         IRP A,,[LIST]\r
21740         IRP B,,[A]\r
21741         EXPUNGE T!B\r
21742         .ISTOP\r
21743         TERMIN\r
21744         TERMIN\r
21745         TERMIN\r
21746 ]\r
21747 \r
21748 \r
21749 TYPMSK==17777\r
21750 MONMSK==TYPMSK#777777\r
21751 SATMSK==777\r
21752 CHBIT==1000\r
21753 TMPLBT==2000\r
21754 \r
21755 IF1 [\r
21756 DEFINE GETYP AC,ADR\r
21757         LDB AC,[221500,,ADR]\r
21758         TERMIN\r
21759 \r
21760 DEFINE GETYPF AC,ADR\r
21761         LDB AC,[003700,,ADR]\r
21762         TERMIN\r
21763 \r
21764 DEFINE MONITO\r
21765         .WRMON==200000\r
21766         .RDMON==100000\r
21767         .EXMON== 40000\r
21768         .GLOBAL .MONWR,.MONRD,.MONEX\r
21769         RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON\r
21770 ]\r
21771         TERMIN\r
21772 ]\r
21773 \r
21774 IFN MAIN,MONITO\r
21775 \r
21776 IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT\r
21777 ]\r
21778 ]\r
21779 \f;MUDDLE WIDE GLOBALS\r
21780 \r
21781 ;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL\r
21782 \r
21783 IF1 [\r
21784 IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R]\r
21785 .GLOBAL A!STO\r
21786 TERMIN\r
21787 \r
21788 .GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG\r
21789 \r
21790 ;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE\r
21791 \r
21792 .GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC\r
21793 .GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT\r
21794 .GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1\r
21795 ]\r
21796 \r
21797 \r
21798 ;STORAGE ALLOCATIN SPECIFICATION GLOBALS\r
21799 \r
21800 NSUBRS==600.            ; ESTIMATE OF # OF SUBRS IN WOLD\r
21801 TPLNT"==2000    ;TEMP PDL LENGTHH\r
21802 GSPLNT==2000    ;INITIAL GLOBAL SP\r
21803 GCPLNT"==100.   ;GARBAGE COLLECTOR'S PDL LENGTH\r
21804 PVLNT"==100     ;LENGTH OF INITIAL PROCESS VECTOR\r
21805 TVLNT"==6000    ;MAX TRANSFER VECTOR\r
21806 ITPLNT"==100    ;TP FOR GC\r
21807 PLNT"==1000     ;PDL FOR USER PROCESS\r
21808 \r
21809 ;LOCATIONS OF VARIOUS STORAGE AREAS\r
21810 \r
21811 PARBASE"==32000 ;START OF PAIR SPACE\r
21812 VECBASE"==44000 ;START OF VECTOR SPACE\r
21813 IFN MAIN,[PARLOC"==PARBASE\r
21814 VECLOC"==VECBASE\r
21815 ]\r
21816 \f\r
21817 ;INITIAL MACROS\r
21818 \r
21819 ;SYMBLOS ASSOCIATED WITH STACK FRAMES\r
21820 ;TB POINTS TO CURRENT FRAME,  THE SYMBOLS BELOW ARE OFFSETS ON TB\r
21821 \r
21822 FRAMLN==7       ;LENGTH OF A FRAME\r
21823 FSAV==-7        ;POINT TO CALLED FUNCTION\r
21824 OTBSAV==-6      ;POINT TO PREVIOUS FRAME AND CONTAINS TIME\r
21825 ABSAV==-5       ;ARGUMENT POINTER\r
21826 SPSAV==-4       ;BINDING POINTER\r
21827 PSAV==-3        ;SAVED P-STACK\r
21828 TPSAV==-2       ;TOP OF STACK POINTER\r
21829 PCSAV==-1       ;PCWORD\r
21830 \r
21831 RMT [EXPUNGE FRAMLN\r
21832 ]\r
21833 IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV \r
21834 ]\r
21835 ]\r
21836 \r
21837 ;CALL MACRO\r
21838 ; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS\r
21839 \r
21840 .GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS\r
21841 \r
21842 ; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS\r
21843 \r
21844 IF1 [\r
21845 DEFINE MCALL N,F\r
21846         .GLOBAL F\r
21847         IFGE <17-N>,.MCALL N,F\r
21848         IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS\r
21849 /\r
21850         .MCALL F\r
21851         ]\r
21852         TERMIN\r
21853 \r
21854 ; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N\r
21855 \r
21856 DEFINE ACALL N,F\r
21857         .GLOBAL F\r
21858         .ACALL N,F\r
21859         TERMIN\r
21860 \r
21861 ; STANDARD SUBROUTINE RETURN\r
21862 \r
21863 ;       JRST FINIS\r
21864 \r
21865 ; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED\r
21866 ; VALUE SHOULD BE IN A AND B\r
21867 \r
21868 ;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS\r
21869 \r
21870 DEFINE ENTRY N\r
21871         IFSN N,,[\r
21872                 HLRZ A,AB\r
21873                 CAIE A,-2*N\r
21874                 JSP  E,GETWNA]\r
21875 TERMIN\r
21876 \f\r
21877 \r
21878 ; MACROS ASSOCIATED WIT INTERRUPT PROCESSING\r
21879 ;INTERRUPT IF THERE IS A WAITING INTERRUPT\r
21880 \r
21881 DEFINE INTGO\r
21882         SKIPGE INTFLG\r
21883         JSR LCKINT\r
21884 TERMIN\r
21885 \r
21886 ;TO BECOME INTERRUPTABLE\r
21887 \r
21888 DEFINE ENABLE\r
21889         AOSN INTFLG\r
21890         JSR LCKINT\r
21891 TERMIN\r
21892 \r
21893 ;TO BECOME UNITERRUPTABLE\r
21894 \r
21895 DEFINE DISABLE\r
21896         SETZM INTFLG\r
21897 TERMIN\r
21898 ]\r
21899 \fIF1 [\r
21900 ;MACRO TO BUILD TYPE DISPATCH TABLES EASILY\r
21901 \r
21902 DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH\r
21903 \r
21904 NAME:\r
21905         REPEAT LNTH+1,DEFAULT\r
21906         IRP A,,[LIST]\r
21907                 IRP TYPE,LOCN,[A]\r
21908                 LOC NAME+TYPE\r
21909                 LOCN\r
21910                 .ISTOP\r
21911                 TERMIN\r
21912         TERMIN\r
21913         LOC NAME+LNTH+1\r
21914 TERMIN\r
21915 \r
21916 ; DISPATCH FOR NUMPRI GOODIES\r
21917 \r
21918 DEFINE DISTBL NAME,DEFAULT,LIST\r
21919         TBLDIS NAME,DEFAULT,[LIST]NUMPRI\r
21920         TERMIN\r
21921 \r
21922 DEFINE DISTBS NAME,DEFAULT,LIST\r
21923         TBLDIS NAME,DEFAULT,[LIST]NUMSAT\r
21924         TERMIN\r
21925 \r
21926 ]\r
21927 \f\r
21928 \r
21929 VECFLG==0\r
21930 PARFLG==0\r
21931 \r
21932 ;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE\r
21933 \r
21934 ;CHAR STRING MAKER, RETURNS POINTER AND TYPE\r
21935 \r
21936 IF1 [\r
21937 DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST\r
21938                 TYPE==TCHSTR\r
21939                 VECTGO WHERE\r
21940                 LNT==.LENGTH \NAME!\\r
21941                 ASCII \NAME!\\r
21942                 LAST==$."\r
21943                 TCHRS,,0\r
21944                 $."-WHERE+1,,0\r
21945                 VAL==LNT,,WHERE\r
21946                 VECRET\r
21947 \r
21948 TERMIN\r
21949 ;MACRO TO DEFINE ATOMS\r
21950 \r
21951 DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST\r
21952         FIRST==.\r
21953         TYAT,,OBLIS\r
21954         VALU\r
21955         0\r
21956         ASCII \NAME!\\r
21957         400000+SATOM,,0\r
21958         .-FIRST+1,,0\r
21959         TVENT==FIRST-.+2,,FIRST\r
21960         IFSN [LOCN],LOCN==TVENT\r
21961         ADDTV TATOM,TVENT,REFER\r
21962         TERMIN\r
21963 \r
21964 \r
21965 \r
21966 \f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE\r
21967 ;GENERAL SWITCHER\r
21968 \r
21969 DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW\r
21970 \r
21971         IFE F1,[SAVE==.\r
21972                 LOC NEWLOC\r
21973                 SAVEF2==F2\r
21974                 IFN F2,OTHLOC==SAVE\r
21975                 F2==0\r
21976                 DEFINE RETNAM\r
21977                         F1==F1-1\r
21978                         IFE F1,[NEWLOC==.\r
21979                         F2==SAVEF2\r
21980                         LOC TOPWRD\r
21981                         NEWLOC\r
21982                         LOC SAVE\r
21983                         ]\r
21984                         TERMIN\r
21985                 ]\r
21986 \r
21987         IFN F1,[F1==F1+1\r
21988                 ]\r
21989 \r
21990         IFSN LOCN,,LOCN==.\r
21991         IFE F1,F1==1\r
21992 \r
21993 TERMIN\r
21994 \r
21995 \r
21996 DEFINE VECTGO LOCN\r
21997         LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP\r
21998         TERMIN\r
21999 \r
22000 DEFINE PARGO LOCN\r
22001         LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP\r
22002         TERMIN\r
22003 \r
22004 DEFINE ADDSQU NAME,\SAVE\r
22005         SAVE==.\r
22006         LOC SQULOC\r
22007         SQUOZE 0,NAME\r
22008         NAME\r
22009         SQULOC==.\r
22010         LOC SAVE\r
22011         TERMIN\r
22012 \r
22013 DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE\r
22014         SAVE==.\r
22015         LOC TVLOC\r
22016         TVOFF==.-TVBASE+1\r
22017         TYPE,,REFER\r
22018         GOODIE\r
22019         TVLOC==.\r
22020         LOC SAVE\r
22021         TERMIN\r
22022 \r
22023 ;MACRO TO ADD TO PROCESS VECTOR\r
22024 \r
22025 DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE\r
22026         SAVE==.\r
22027         LOC PVLOC\r
22028         PVOFF==.-PVBASE\r
22029         IFSN OFFS,,OFFS==PVOFF\r
22030         TYPE,,0\r
22031         GOODIE\r
22032         PVLOC==.\r
22033         LOC SAVE\r
22034         TERMIN\r
22035 \r
22036 \r
22037 \r
22038 \r
22039 \f\r
22040 ;MACRO TO DEFINE A FUNCTION ATOM\r
22041 \r
22042 DEFINE MFUNCTION NAME,TYPE,PNAME\r
22043         (TVP)\r
22044 NAME":\r
22045         VECTGO DUMMY1\r
22046         ADDSQU NAME\r
22047         IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1>\r
22048         IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1>\r
22049         VECRET\r
22050         TERMIN\r
22051 \r
22052 ; VERSION OF MQUOTE WITH IMPURE BIT ON\r
22053 \r
22054 DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN\r
22055         (TVP)\r
22056 \r
22057         LOCN==.-1\r
22058         VECTGO DUMMY1\r
22059         IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN\r
22060 \r
22061         IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN\r
22062         VECRET\r
22063         TERMIN\r
22064 \r
22065 ;MACRO TO DEFINE QUOTED GOODIE\r
22066 \r
22067 DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN\r
22068         (TVP)\r
22069 \r
22070         LOCN==.-1\r
22071         VECTGO DUMMY1\r
22072         IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN\r
22073         IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN\r
22074         VECRET\r
22075         TERMIN\r
22076 \r
22077 \r
22078 \r
22079 \r
22080 DEFINE CHQUOTE NAME,\LOCN,TYP,VAL\r
22081         (TVP)\r
22082         LOCN==.-1\r
22083         MACHAR [NAME]TYP,VAL\r
22084         ADDTV TYP,VAL,LOCN\r
22085 \r
22086         TERMIN\r
22087 \r
22088 \r
22089 ; SPECIAL ERROR MQUOTE\r
22090 \r
22091 DEFINE EQUOTE ARG,PNAME\r
22092         MQUOTE ARG,[PNAME]ERRORS TERMIN\r
22093 \r
22094 \r
22095 ; MACRO DO .CALL UUOS\r
22096 \r
22097 DEFINE DOTCAL NM,LIST,\LOCN\r
22098         .CALL LOCN\r
22099         RMT [LOCN==.\r
22100                 SETZ\r
22101                 SIXBIT /NM/\r
22102                 IRP Q,R,[LIST]\r
22103                         IFSN [R][][Q\r
22104                         ]\r
22105 \r
22106                         IFSE [R][][<SETZ>\<Q>\r
22107                         ]\r
22108                 TERMIN\r
22109                 ]\r
22110 TERMIN\r
22111 \r
22112 ; MACRO TO HANDLE FATAL ERRORS\r
22113 \r
22114 DEFINE FATAL MSG/\r
22115         FATINS  [ASCIZ /:\e FATAL ERROR MSG \e\r
22116 /]\r
22117         TERMIN\r
22118 ]\r
22119 \f\r
22120 CHRWD==5\r
22121 \r
22122 IFN READER,[\r
22123 NCHARS==177\r
22124 ;CHARACTER TABLE GENERATING MACROS\r
22125 \r
22126 DEFINE SETSYM WRDL,BYTL,COD\r
22127         WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>\r
22128         WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>\r
22129         TERMIN\r
22130 \r
22131 DEFINE INIWRD N,INIT\r
22132         WRD!N==INIT\r
22133         TERMIN\r
22134 \r
22135 DEFINE OUTWRD N\r
22136         WRD!N\r
22137         TERMIN\r
22138 \r
22139 ;MACRO TO KILL THESE SYMBOLS LATER\r
22140 \r
22141 DEFINE KILLWD N\r
22142         EXPUNGE WRD!N\r
22143         TERMIN\r
22144 DEFINE SETMSK N\r
22145         MSK!N==<177_<<4-N>*7+1>>#<-1>\r
22146         TERMIN\r
22147 \r
22148 ;MACRO TO KILL MASKS LATER\r
22149 \r
22150 DEFINE KILMSK N\r
22151         EXPUNGE MSK!N\r
22152         TERMIN\r
22153 \r
22154 NWRDS==<NCHARS+CHRWD-1>/CHRWD\r
22155 \r
22156 REPEAT CHRWD,SETMSK \.RPCNT\r
22157 \r
22158 REPEAT NWRDS,INIWRD \.RPCNT,004020100402\r
22159 \r
22160 DEFINE OUTTBL\r
22161         REPEAT NWRDS,OUTWRD \.RPCNT\r
22162         TERMIN\r
22163 \r
22164 \r
22165 ;MACRO TO GENERATE THE DUMMIES EASLILIER\r
22166 \r
22167 DEFINE INITCH \DUM1,DUM2,DUM3\r
22168 \r
22169 \r
22170 DEFINE SETCOD  COD,LIST\r
22171         IRP CHAR,,[LIST]\r
22172         DUM1==CHAR/5\r
22173         DUM2==CHAR-DUM1*5\r
22174         SETSYM \DUM1,\DUM2,COD\r
22175         TERMIN\r
22176         TERMIN\r
22177 \r
22178 DEFINE SETCHR COD,LIST\r
22179         IRPC CHAR,,[LIST]\r
22180         DUM3=="CHAR\r
22181         DUM1==DUM3/5\r
22182         DUM2==DUM3-DUM1*5\r
22183         SETSYM \DUM1,\DUM2,COD\r
22184         TERMIN\r
22185         TERMIN\r
22186 \r
22187 DEFINE INCRCO OCOD,LIST\r
22188         IRP CHAR,,[LIST]\r
22189         DUM1==CHAR/5\r
22190         DUM2==CHAR-DUM1*5\r
22191         SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>\r
22192         TERMIN\r
22193         TERMIN\r
22194 \r
22195 DEFINE INCRCH OCOD,LIST\r
22196         IRPC CHAR,,[LIST]\r
22197         DUM3=="CHAR\r
22198         DUM1==DUM3/5\r
22199         DUM2==DUM3-DUM1*5\r
22200         SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>\r
22201         TERMIN\r
22202         TERMIN\r
22203         RMT [EXPUNGE DUM1,DUM2,DUM3\r
22204         REPEAT NWRDS,KILLWD \.RPCNT\r
22205         REPEAT CHRWD,KILMSK \.RPCNT\r
22206 ]\r
22207 \r
22208 TERMIN\r
22209 \r
22210 INITCH\r
22211 ]\r
22212 \f\r
22213 ;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)\r
22214 \r
22215 EQUALS E.END END\r
22216 \r
22217 DEFINE END ARG\r
22218         EQUALS END E.END\r
22219         CONSTANTS\r
22220 \r
22221         IMPURE\r
22222         VARIABLES\r
22223         PURE\r
22224         HERE\r
22225         .LNKOT\r
22226         IF2 GEXPUN\r
22227         CONSTANTS\r
22228         IMPURE\r
22229         VARIABLES\r
22230         CODEND==.\r
22231         LOC CODTOP\r
22232         CODEND\r
22233         LOC CODEND\r
22234         PURE\r
22235         CODEND==.\r
22236         LOC HITOP\r
22237         CODEND\r
22238         LOC CODEND\r
22239         IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED\r
22240         IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT\r
22241         END ARG\r
22242         TERMIN\r
22243 \r
22244 \r
22245 ;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY\r
22246 \r
22247 IF1 [\r
22248 DEFINE NUMGEN SYM,\REST,N\r
22249         NN==NN-1\r
22250         N==<SYM_-30.>&77\r
22251         REST==<SYM_6>\r
22252         IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>\r
22253         IFN NN,NUMGEN REST\r
22254         EXPUNGE N,REST\r
22255         TERMIN\r
22256 \r
22257 DEFINE VERSIO N\r
22258         PRINTC /VERSION = N\r
22259 /\r
22260         TERMIN\r
22261 ]\r
22262 \r
22263 TOTAL==0\r
22264 NN==7\r
22265 \r
22266 NUMGEN .FNAM2\r
22267 \r
22268 IF1 [\r
22269 RADIX 10.\r
22270 \r
22271 VERSIO \TOTAL\r
22272 \r
22273 RADIX 8\r
22274 PROGVN==TOTAL\r
22275 \r
22276 \r
22277 DEFINE VATOM SYM,\LOCN,TV,A,B\r
22278         VECTGO\r
22279         LOCN==.\r
22280         TFIX,,MUDDLE\r
22281         PROGVN\r
22282         0\r
22283         A==<<<<SYM_-30.>&77>+40>_29.>\r
22284         B==<<SYM_-24.>&77>\r
22285         IFN B,A==A+<<B+40>_22.>\r
22286         B==<<SYM_-18.>&77>\r
22287         IFN B,A==A+<<B+40>_15.>\r
22288         B==<<SYM_-12.>&77>\r
22289         IFN B,A==A+<<B+40>_8.>\r
22290         B==<<SYM_-6.>&77>\r
22291         IFN B,A==A+<<B+40>_1.>\r
22292         A\r
22293         IFN <SYM&77>,<<SYM&77>+40>_29.\r
22294         400000+SATOM,,\r
22295         .-LOCN+1,,0\r
22296         TV==LOCN-.+2,,LOCN\r
22297         ADDTV TATOM,TV,0\r
22298         VECRET\r
22299         TERMIN\r
22300 \r
22301 ;VATOM .FNAM1                   ;"HACK REMOVED FOR EFFICIENCY"\r
22302 \r
22303 \r
22304 ;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"\r
22305 \r
22306 DEFINE GEXPUN \SYM\r
22307         NN==7\r
22308         TOTAL==0\r
22309         NUMGEN \<SIXBIT /SYM!/>\r
22310         RADIX 10.\r
22311         .GSSET 0\r
22312         REPEAT TOTAL,XXP\r
22313         RADIX 8\r
22314 TERMIN\r
22315 \r
22316 DEFINE XXP \A\r
22317         EXPUNGE A\r
22318         TERMIN\r
22319 \r
22320 \r
22321 DEFINE ..LOC NEW,OLD\r
22322         .LIFS .LPUR"+.LIMPU"\r
22323         OLD!"==$."\r
22324         LOC NEW!"\r
22325         .ELDC\r
22326         .LIFS -.LPUR"\r
22327         LOC $."\r
22328         .ELDC\r
22329         .LIFS -.LIMPU\r
22330         LOC $."\r
22331         .ELDC\r
22332         TERMIN\r
22333 \r
22334 \r
22335 ; PURE - MACRO TO SWITCH LOADING TO PURE CORE.\r
22336 \r
22337 DEFINE PURE\r
22338         IFE PURITY-1, ..LOC .LPUR,.LIMPU\r
22339         PURITY==0\r
22340         TERMIN\r
22341 \r
22342 ; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE.\r
22343 \r
22344 DEFINE IMPURE\r
22345         IFE PURITY, ..LOC .LIMPU,.LPUR\r
22346         PURITY==1\r
22347         TERMIN\r
22348 ]\r
22349 PURITY==0\r
22350 \f\f\r
22351 TITLE MUDEX -- TENEX  DEPENDANT MUDDLE CODE\r
22352 \r
22353 RELOCATABLE\r
22354 \r
22355 .INSRT MUDDLE >\r
22356 .INSRT STENEX >\r
22357 \r
22358 MFORK==400000\r
22359 \r
22360 MONITS==1\r
22361 \r
22362 .GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,MSGTYP,TTYOP2\r
22363 .GLOBAL %UNAM,%JNAM,%RUNAM,%RJNAM,%GCJOB,%SHWND,%SHFNT,%GETIP,%INFMP\r
22364 .GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI\r
22365 .GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT\r
22366 .GLOBAL GCRSET\r
22367 \r
22368 GCHN==0\r
22369 WRTP==1000,,100000\r
22370 GCHI==1000,,GCHN\r
22371 CRJB==1000,,400001\r
22372 FME==1000,,-1\r
22373 FLS==1000,,\r
22374 \r
22375 CTIME:  JOBTM                           ; get run time in milli secs\r
22376         MOVE    B,A\r
22377         JSP     A,BFLOAT                ; Convert to floating\r
22378         FDVRI   B,(1000.0)              ; Change to units of seconds\r
22379         MOVSI   A,TFLOAT\r
22380         POPJ    P,\r
22381 \r
22382 ; SET THE SNAME GLOBALLY\r
22383 \r
22384 %SSNAM: POPJ    P,\r
22385 \r
22386 ; READ THE GLOBAL SNAME\r
22387 \r
22388 %RSNAM: POPJ    P,\r
22389 \r
22390 ; KILL THE CURRENT JOB\r
22391 \r
22392 %KILLM: HALTF\r
22393         POPJ    P,\r
22394 \r
22395 ; PASS STRING TO SUPERIOR (MONITOR?)\r
22396 \r
22397 %VALRE: HALTF\r
22398         POPJ    P,\r
22399 \r
22400 ; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL")\r
22401 \r
22402 %LOGOU: LGOUT\r
22403         POPJ    P,\r
22404 \r
22405 ; GO TO SLEEP A WHILE\r
22406 \r
22407 %SLEEP: IMULI   A,33.           ; TO MILLI SECS\r
22408         DISMS\r
22409         POPJ    P,\r
22410 \r
22411 ; HANG FOR EVER\r
22412 \r
22413 %HANG:  WAIT\r
22414 \r
22415 ; READ JNAME\r
22416 \r
22417 %RJNAM: POPJ    P,\r
22418 \r
22419 ; READ UNAME\r
22420 \r
22421 %RUNAM: POPJ    P,\r
22422 \r
22423 ; HERE TO SEE IF WE ARE A TOP LEVEL JOB\r
22424 \r
22425 %TOPLQ: GJINF\r
22426         SKIPGE  D\r
22427         AOS     (P)\r
22428         POPJ    P,\r
22429 \r
22430 ; GET AN INFERIOR FOR THE GARBAGE COLLECTOR\r
22431 \r
22432 %GCJOB: PUSH    P,A\r
22433         MOVEI   A,200000        ; GET BITS FOR FORK\r
22434         CFORK                   ; MAKE AN IFERIOR FORK\r
22435         FATAL CANT GET GC FORK\r
22436         MOVEM   A,GCFRK         ; SAVE HANDLE\r
22437         POP     P,A             ; RESTORE PAGE\r
22438         PUSHJ   P,%GETIP        ; GET IT THERE\r
22439         PUSHJ   P,%SHWND\r
22440         JRST    %SHFNT          ; AND FRONTIER\r
22441 \r
22442 ; HERE TO GET A PAGE FOR THE INFERIOR\r
22443 \r
22444 %GETIP: POPJ    P,\r
22445 \r
22446 ; HERE TO SHARE WINDOW\r
22447 \r
22448 %SHWND: TDZA    0,0             ; FLAG SAYING WINDOW\r
22449 \r
22450 ; HERE TO SHARE FRONTIER\r
22451 \r
22452 %SHFNT: MOVEI   0,1\r
22453         PUSH    P,A\r
22454         PUSH    P,B\r
22455         PUSH    P,C\r
22456         MOVEI   B,2*FRNP        ; FRONTIER (REMEMBER TENEX PAGE SIZE)\r
22457         SKIPN   0\r
22458         MOVEI   B,2*WNDP        ; NO,WINDOW\r
22459         HRLI    B,MFORK\r
22460         ASH     A,1             ; TIMES 2\r
22461         HRL     A,GCFRK\r
22462         MOVSI   C,140000        ; READ AND WRITE ACCESS\r
22463 \r
22464         PMAP\r
22465         ADDI    A,1\r
22466         ADDI    B,1\r
22467         PMAP\r
22468         ASH     B,9.            ; POINT TO PAGE\r
22469         MOVES   (B)             ; CLOBBER TOP\r
22470         MOVES   -1(B)           ; AND UNDER\r
22471         POP     P,C\r
22472         POP     P,B\r
22473         POP     P,A\r
22474         POPJ    P,\r
22475 \r
22476 ; HERE TO MAP INFERIOR BACK AND KILL SAME\r
22477 \r
22478 %INFMP: PUSH    P,C\r
22479         PUSH    P,D\r
22480         PUSH    P,E\r
22481         ASH     A,1\r
22482         ASH     B,1\r
22483         MOVE    D,A             ; POINT TO PAGES\r
22484         MOVE    E,B             ; FOR COPYING\r
22485         PUSH    P,A             ; SAVE FOR TOUCHING\r
22486         MOVS    A,GCFRK\r
22487         MOVSI   B,MFORK\r
22488         MOVSI   C,120400        ; READ AND WRITE COPY\r
22489 \r
22490 LP1:    HRRI    A,(E)\r
22491         HRRI    B,(D)\r
22492         PMAP\r
22493         ADDI    E,1\r
22494         AOBJN   D,LP1\r
22495 \r
22496 ; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE)\r
22497 \r
22498         POP     P,E             ; RESTORE MY FIRST PAGE #\r
22499         MOVEI   A,(E)           ; COPY FOR LOOP\r
22500         ASH     A,9.            ; TO WORD ADDR\r
22501         MOVES   (A)             ; WRITE IT\r
22502         AOBJN   E,.-3           ; FOR ALL PAGES\r
22503 \r
22504         MOVE    A,GCFRK\r
22505         KFORK\r
22506         POP     P,E\r
22507         POP     P,D\r
22508         POP     P,C\r
22509         POPJ    P,\r
22510 \r
22511 ; HACK TO PRINT MESSAGE OF INTEREST TO USER\r
22512 \r
22513 MESOUT: MOVSI   A,(JFCL)\r
22514         MOVEM   A,MESSAG        ; DO ONLY ONCE\r
22515         MOVEI   A,400000\r
22516         MOVE    B,[1,,ILLUUO]\r
22517         MOVE    C,[40,,UUOH]\r
22518         SCVEC\r
22519         SETZ    SP,             ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME\r
22520         PUSHJ   P,GCRSET\r
22521         PUSHJ   P,PGINT         ; INITIALIZE PAGE MAP\r
22522         RESET\r
22523         PUSHJ   P,TTYOP2\r
22524         SKIPE   NOTTY           ; HAVE A TTY?\r
22525         JRST    RESNM           ; NO, SKIP THIS STUFF\r
22526 \r
22527         MOVEI   A,MESBLK\r
22528         MOVEI   B,0\r
22529         GTJFN\r
22530         JRST    RESNM\r
22531         MOVE    B,[70000,,200000]\r
22532         OPENF\r
22533         JRST    RESNM\r
22534 \r
22535 MSLP:   BIN\r
22536         MOVE    D,B             ; SAVE BYTE\r
22537         GTSTS\r
22538         TLNE    B,1000\r
22539         JRST    RESNM\r
22540         EXCH    D,A\r
22541         CAIN    A,14\r
22542         PBOUT\r
22543         MOVE    A,D\r
22544         JRST    MSLP\r
22545 \r
22546 RESNM2: CLOSF\r
22547         JFCL\r
22548 \r
22549 RESNM:\r
22550 RESNM1: POPJ    P,\r
22551 \r
22552 MESBLK: 100000,,\r
22553         377777,,377777\r
22554         -1,,[ASCIZ /DSK/]\r
22555         -1,,[ASCIZ /VEZZA/]\r
22556         -1,,[ASCIZ /MUDDLE/]\r
22557         -1,,[ASCIZ /MESSAG/]\r
22558         0\r
22559         0\r
22560         0\r
22561 \r
22562 MUDINT: MOVSI   0,(JFCL)        ; CLOBBER MUDDLE INIT SWITCH\r
22563         MOVEM   0,INITFL\r
22564 \r
22565         GJINF                   ; GET INFO NEEDED\r
22566         PUSHJ   P,TMTNXS        ; MAKE A TEMP STRING FOR TENEX INFO (POINTER LEFT IN E)\r
22567         HRROI   A,1(E)          ; TNX STRING POINTER\r
22568         DIRST\r
22569         FATAL   ATTACHED DIR DOES NOT EXIST\r
22570         MOVEI   B,1(E)          ; NOW HAVE BOUNDS OF STRING\r
22571         SUBM    P,E             ; RELATIVIZE E\r
22572         PUSHJ   P,TNXSTR        ; MAKE THE STRING\r
22573         SUB     P,E\r
22574         PUSH    TP,$TATOM\r
22575         PUSH    TP,IMQUOTE SNM\r
22576         PUSH    TP,A\r
22577         PUSH    TP,B\r
22578         MCALL   2,SETG\r
22579         PUSH    TP,$TCHSTR\r
22580         PUSH    TP,CHQUOTE READ\r
22581         PUSH    TP,$TCHSTR\r
22582         PUSH    TP,CHQUOTE MUDDLE.INIT\r
22583         MCALL   2,FOPEN\r
22584         GETYP   A,A\r
22585         CAIE    A,TCHAN\r
22586         POPJ    P,\r
22587         PUSH    TP,$TCHAN\r
22588         PUSH    TP,B\r
22589         MOVEI   B,INITSTR       ; TELL USER WHAT'S HAPPENING\r
22590         SKIPE   WHOAMI\r
22591         JRST    .+3\r
22592         SKIPN   NOTTY\r
22593         PUSHJ   P,MSGTYP\r
22594         MCALL   1,MLOAD\r
22595         POPJ    P,\r
22596 \r
22597 TMTNXS: POP     P,D             ; SAVE RET ADDR\r
22598         MOVE    E,P             ; BUILD A STRING SPACE ON PSTACK\r
22599         MOVEI   0,20.           ; USE 20 WORDS (=100 CHARS)\r
22600         PUSH    P,[0]\r
22601         SOJG    0,.-1\r
22602 \r
22603         JRST    (D)\r
22604 \r
22605 \r
22606 TNXSTR: SUBI    B,(P)\r
22607         PUSH    P,B\r
22608         ADDI    B,-1(P)\r
22609         SUBI    B,(A)           ; WORDS TO B\r
22610         IMULI   B,5             ; TO CHARS\r
22611         LDB     0,[360600,,A]   ; GET BYTE POSITION\r
22612         IDIVI   0,7             ; TO  A REAL BYTE POSITION\r
22613         MOVNS   0\r
22614         ADDI    0,5\r
22615         SUBM    0,B             ; FINAL LENGTH IN BYTES TO B\r
22616         PUSH    P,B             ; SAVE IT\r
22617         MOVEI   A,4(B)          ; TO WORDS\r
22618         IDIVI   A,5\r
22619         PUSHJ   P,IBLOCK        ; GET STRING\r
22620         POP     P,A\r
22621         POP     P,C\r
22622         ADDI    C,(P)\r
22623         MOVE    D,B             ; COPY POINTER\r
22624         MOVE    0,(C)           ; GET A WORD\r
22625         MOVEM   0,(D)\r
22626         ADDI    C,1\r
22627         AOBJN   D,.-3\r
22628 \r
22629         HRLI    A,TCHSTR\r
22630         HRLI    B,440700        ; MAKE INTO BYTER\r
22631         POPJ    P,\r
22632 \r
22633 IPCINI: JFCL\r
22634 IFN MONITS,[\r
22635 \r
22636 DEMS:   SETZ\r
22637         SIXBIT /DEMSIG/\r
22638         SETZ    [SIXBIT /MUDSTA/]\r
22639 ]\r
22640 INITSTR:        ASCIZ /MUDDLE INIT/\r
22641 \r
22642 IMPURE\r
22643 \r
22644 GCFRK:  0\r
22645 \r
22646 IFN MONITS,[\r
22647 MESSDM: 30,,(SIXBIT /IPC/)\r
22648         .+1\r
22649         SIXBIT /MUDDLESTATIS/\r
22650         1\r
22651         1\r
22652 ]\r
22653 \r
22654 MESSAG: PUSHJ   P,MESOUT        ; MESSAGE SWITCH\r
22655 \r
22656 INITFL: PUSHJ   P,MUDINT        ; MUDDLE INIT SWITCH\r
22657 \r
22658 PURE\r
22659 \r
22660 END\r
22661 \f\r
22662 TITLE SQUOZE TABLE HANDLER FOR MUDDLE\r
22663 \r
22664 RELOCATABLE\r
22665 \r
22666 .INSRT MUDDLE >\r
22667 \r
22668 .GLOBAL SQUPNT,ATOSQ,SQUTOA\r
22669 \r
22670 ; POINTER TO TABLE FILLED IN BY INITM\r
22671 \r
22672 SQUPNT: 0\r
22673 \r
22674 ; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E\r
22675 \r
22676 ATOSQ:  PUSH    P,B\r
22677         PUSH    P,A\r
22678         MOVE    A,SQUPNT                ; GET TABLE POINTER\r
22679         MOVE    B,[2,,2]\r
22680         CAMN    E,1(A)\r
22681         JRST    ATOSQ1\r
22682         ADD     A,B\r
22683         JUMPL   A,.-3\r
22684 POPABJ: POP     P,B\r
22685         POP     P,A\r
22686         POPJ    P,\r
22687 \r
22688 ATOSQ1: MOVE    E,(A)\r
22689         AOS     -2(P)\r
22690         JRST    POPABJ\r
22691 \r
22692 ; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E\r
22693 \r
22694 SQUTOA: PUSH    P,A\r
22695         PUSH    P,B\r
22696         PUSH    P,C\r
22697 \r
22698         MOVE    A,SQUPNT                ; POINTER TO TABLE\r
22699         HLRE    B,SQUPNT\r
22700         MOVNS   B\r
22701         HRLI    B,(B)           ; B IS CURRENT OFFSET\r
22702 \r
22703 UP:     ASH     B,-1            ; HALVE TABLE\r
22704         AND     B,[-2,,-2]      ; FORCE DIVIS BY 2\r
22705         MOVE    C,A             ; COPY POINTER\r
22706         JUMPLE  B,LSTHLV        ; CANT GET SMALLER\r
22707         ADD     C,B\r
22708         CAMLE   E,(C)           ; SKIP IF EITHER FOUND OR IN TOP\r
22709         MOVE    A,C             ; POINT TO SECOND HALF\r
22710         CAMN    E,(C)           ; SKIP IF NOT FOUND\r
22711         JRST    WON\r
22712         CAML    E,(C)           ; SKIP IF IN TOP HALF\r
22713         JRST    UP\r
22714         HLLZS   C               ; FIX UP OINTER\r
22715         SUB     A,C\r
22716         JRST    UP\r
22717 \r
22718 WON:    MOVE    E,1(C)          ; RET VAL IN E\r
22719         AOS     -3(P)           ; SKIP RET\r
22720 WON1:   POP     P,C\r
22721         POP     P,B\r
22722         POP     P,A\r
22723         POPJ    P,\r
22724 \r
22725 LSTHLV: CAMN    E,(C)           ; LINEAR SERCH REST\r
22726         JRST    WON\r
22727         ADD     C,[2,,2]\r
22728         JUMPL   C,.-3\r
22729         JRST    WON1            ; ALL GONE, LOSE\r
22730 \r
22731 END\r
22732 \f\r
22733 TITLE MODIFIED AFREE FOR MUDDLE\r
22734 \r
22735 RELOCATABLE\r
22736 \r
22737 .INSRT MUDDLE >\r
22738 \r
22739 .GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1\r
22740 .GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP\r
22741 .GLOBAL FLIST,STORIC\r
22742 MFUNCTION FREEZE,SUBR\r
22743 \r
22744         ENTRY   1\r
22745 \r
22746         GETYP   A,(AB)          ; get type of it\r
22747         PUSH    TP,(AB)         ; save a copy\r
22748         PUSH    TP,1(AB)\r
22749         PUSH    P,[0]           ; flag for tupel freeze\r
22750         PUSHJ   P,SAT           ; to SAT\r
22751         MOVEI   B,0             ; final type\r
22752         CAIN    A,SNWORD        ; check valid types\r
22753         MOVSI   B,TUVEC         ; use UVECTOR\r
22754         CAIN    A,S2NWOR\r
22755         MOVSI   B,TVEC\r
22756         CAIN    A,SARGS\r
22757         MOVSI   B,TVEC\r
22758         CAIN    A,SCHSTR\r
22759         MOVSI   B,TCHSTR\r
22760         JUMPE   B,WTYP1\r
22761         PUSH    P,B             ; save final type\r
22762         CAME    B,$TCHSTR       ; special chars hack\r
22763         JRST    OK.FR\r
22764         HRR     B,(AB)          ; fixup count\r
22765         MOVEM   B,(P)\r
22766 \r
22767         MOVEI   C,(TB)          ; point to it\r
22768         PUSHJ   P,BYTDOP        ; A==> points to dope word\r
22769         HRRO    B,1(TB)\r
22770         SUBI    A,1(B)          ; A==> length of block\r
22771         TLC     B,-1(A)\r
22772         MOVEM   B,1(TB)         ; and save\r
22773         MOVSI   0,TUVEC\r
22774         MOVEM   0,(TB)\r
22775 \r
22776 OK.FR:  HLRE    A,1(TB)         ; get length\r
22777         MOVNS   A\r
22778         PUSH    P,A\r
22779         ADDI    A,2\r
22780         PUSHJ   P,CAFREE        ; get storage\r
22781         HRLZ    B,1(TB)         ; set up to BLT\r
22782         HRRI    B,(A)\r
22783         POP     P,C\r
22784         ADDI    C,(A)           ; compute end\r
22785         BLT     B,(C)\r
22786         MOVEI   B,(A)\r
22787         HLL     B,1(AB)\r
22788         POP     P,A\r
22789         JRST    FINIS\r
22790 \r
22791                 \r
22792 CAFRE:  PUSH    P,A\r
22793         HRRZ    E,STOLST+1(TVP)\r
22794         SETZB   C,D\r
22795         PUSHJ   P,ICONS         ; get list element\r
22796         PUSH    TP,$TLIST       ; and save\r
22797         PUSH    TP,B\r
22798         MOVE    A,(P)           ; restore length\r
22799         ADDI    A,2             ; 2 more for dope words\r
22800         PUSHJ   P,CAFREE        ; get the core and dope words\r
22801         POP     P,B             ; restore count\r
22802         MOVNS   B               ; build AOBJN pointer\r
22803         MOVSI   B,(B)\r
22804         HRRI    B,(A)\r
22805         MOVE    C,(TP)\r
22806         MOVEM   B,1(C)          ; save on list\r
22807         MOVSI   0,TSTORA        ; and type\r
22808         HLLM    0,(C)\r
22809         HRRZM   C,STOLST+1(TVP) ; and save as new list\r
22810         SUB     TP,[2,,2]\r
22811         POPJ    P,\r
22812         \r
22813 CAFRE1: PUSH    P,A\r
22814         ADDI    A,2\r
22815         PUSHJ   P,CAFREE\r
22816         HRROI   B,(A)           ; pointer to B\r
22817         POP     P,A             ; length back\r
22818         TLC     B,-1(A)\r
22819         POPJ    P,\r
22820 \r
22821 CAFREE: IRP     AC,,[B,C,D,E]\r
22822         PUSH    P,AC\r
22823         TERMIN\r
22824         SKIPG   A               ; make sure arg is a winner\r
22825         FATAL BAD CALL TO CAFREE\r
22826         MOVSI   A,(A)           ; count to left half for search\r
22827         MOVEI   B,FLIST         ; get first pointer\r
22828         HRRZ    C,(B)           ; c points to next block\r
22829 CLOOP:  CAMG    A,(C)           ; skip if not big enough\r
22830         JRST    CONLIS          ; found one\r
22831         MOVEI   D,(B)           ; save in case fall out\r
22832         MOVEI   B,(C)           ; point to new previous\r
22833         HRRZ    C,(C)           ; next block\r
22834         JUMPN   C,CLOOP         ; go on through loop\r
22835         HLRZ    E,A             ; count to E\r
22836         CAMGE   E,STORIC        ; skip if a area or more\r
22837         MOVE    E,STORIC        ; else use a whole area\r
22838         MOVE    C,PARBOT        ; foun out if any funny space\r
22839         SUB     C,CODTOP        ; amount around to C\r
22840         CAMLE   C,E             ; skip if must GC\r
22841         JRST    CHAVIT          ; already have it\r
22842         SUBI    E,-1(C)         ; get needed from agc\r
22843         MOVEM   E,PARNEW        ; funny arg to AGC\r
22844         PUSH    P,A\r
22845         MOVE    C,[7,,6]        ; SET UP AGC INDICATORS\r
22846         PUSHJ   P,AGC           ; collect that garbage\r
22847         SETZM   PARNEW          ; dont do it again\r
22848         AOJL    A,GCLOS         ; couldn't get core\r
22849         POP     P,A\r
22850 \r
22851 ; Make sure pointers still good after GC\r
22852 \r
22853         MOVEI   D,FLIST\r
22854         HRRZ    B,(D)\r
22855 \r
22856         HRRZ    E,(B)           ; next pointer\r
22857         JUMPE   E,.+4           ; end of list ok\r
22858         MOVEI   D,(B)\r
22859         MOVEI   B,(E)\r
22860         JRST    .-4             ; look at next\r
22861 \r
22862 CHAVIT: MOVE    E,PARBOT        ; find amount obtained\r
22863         SUBI    E,1             ; dont use a real pair\r
22864         MOVEI   C,(E)           ; for reset of CODTOP\r
22865         SUB     E,CODTOP\r
22866         EXCH    C,CODTOP        ; store it back\r
22867         CAIE    B,(C)           ; did we simply grow the last block?\r
22868         JRST    CSPLIC          ; no, splice it in\r
22869         HLRZ    C,(B)           ; length of old guy\r
22870         ADDI    C,(E)           ; total length\r
22871         ADDI    B,(E)           ; point to new last dope word\r
22872         HRLZM   C,(B)           ; clobber final length in\r
22873         HRRM    B,(D)           ; and splice into free list\r
22874         MOVEI   C,(B)           ; reset acs for reentry into loop\r
22875         MOVEI   B,(D)\r
22876         JRST    CLOOP\r
22877 \r
22878 ; Here to splice new core onto end of list.\r
22879 \r
22880 CSPLIC: MOVE    C,CODTOP        ; point to end of new block\r
22881         HRLZM   E,(C)           ; store length of new block in dope words\r
22882         HRRM    C,(D)           ; D is old previous, link it up\r
22883         MOVEI   B,(D)           ; and reset B for reentry into loop\r
22884         JRST    CLOOP\r
22885 \r
22886 ; here if an appropriate block is on the list\r
22887 \r
22888 CONLIS: HLRZS   A               ; count back to a rh\r
22889         HLRZ    D,(C)           ; length of proposed block to D\r
22890         CAIN    A,(D)           ; skip if they are different\r
22891         JRST    CEASY           ; just splice it out\r
22892         MOVEI   B,(C)           ; point to block to be chopped up\r
22893         SUBI    B,-1(D)         ; point to beginning of same\r
22894         SUBI    D,(A)           ; amount of block to be left to D\r
22895         HRLM    D,(C)           ; and fix up dope words\r
22896         ADDI    B,-1(A)         ; point to end of same\r
22897         HRLZM   A,(B)\r
22898         HRRM    B,(B)           ; for GC benefit\r
22899 \r
22900 CFREET: CAIE    A,1             ; if more than 1\r
22901         SETZM   -1(B)           ; make tasteful dope worda\r
22902         SUBI    B,-1(A)\r
22903         MOVEI   A,(B)\r
22904         IRP     AC,,[E,D,C,B]\r
22905         POP     P,AC\r
22906         TERMIN\r
22907         POPJ    P,\r
22908 \r
22909 CEASY:  MOVEI   D,(C)           ; point to block to return\r
22910         HRRZ    C,(C)           ; point to next of same\r
22911         HRRM    C,(B)           ; smash its previous\r
22912         MOVEI   B,(D)           ; point to block with B\r
22913         HRRM    B,(B)           ; for GC benefit\r
22914         JRST    CFREET\r
22915 \r
22916 GCLOS:  PUSH    TP,$TATOM\r
22917         PUSH    TP,EQUOTE NO-MORE-STORAGE\r
22918         JRST    CALER1\r
22919 \r
22920 CAFRET: HRROI   B,(B)           ; prepare to search list\r
22921         TLC     B,-1(A)         ; by making an AOBJN pointer\r
22922         HRRZ    C,STOLST+1(TVP) ; start of list\r
22923         MOVEI   D,STOLST+1(TVP)\r
22924 \r
22925 CAFRTL: JUMPE   C,CPOPJ         ; not founc\r
22926         CAME    B,1(C)          ; this it?\r
22927         JRST    CAFRT1\r
22928         HRRZ    C,(C)           ; yes splice it out\r
22929         HRRM    C,(D)           ; smash it\r
22930 CPOPJ:  POPJ    P,              ; dont do anything now\r
22931 \r
22932 CAFRT1: MOVEI   D,(C)\r
22933         HRRZ    C,(C)\r
22934         JRST    CAFRTL\r
22935 \r
22936 ; Here from GC to collect all unused blocks into free list\r
22937 \r
22938 STOGC:  SETZB   C,E             ; zero current length and pointer\r
22939         MOVE    A,CODTOP        ; get high end of free space\r
22940 \r
22941 STOGCL: CAIG    A,STOSTR        ; end?\r
22942         JRST    STOGCE          ; yes, cleanup and leave\r
22943 \r
22944         HLRZ    0,(A)           ; get length\r
22945         ANDI    0,377777\r
22946         SKIPGE  (A)             ; skip if a not used block\r
22947         JRST    STOGC1          ; jump if marked\r
22948 \r
22949         JUMPE   C,STOGC3        ; jump if no block under construction\r
22950         ADD     C,0             ; else add this length to current\r
22951         JRST    STOGC4\r
22952 \r
22953 STOGC3: MOVEI   B,(A)           ; save pointer\r
22954         MOVE    C,0             ; init length\r
22955 \r
22956 STOGC4: SUB     A,0             ; point to next block\r
22957         JRST    STOGCL\r
22958 \r
22959 STOGC1: ANDCAM  D,(A)           ; kill mark bit\r
22960         JUMPE   C,STOGC4        ; if no block under cons, dont fix\r
22961         HRLM    C,(B)           ; store total block length\r
22962         HRRM    E,(B)           ; next pointer hooked in\r
22963         MOVEI   E,(B)           ; new next pointer\r
22964         MOVEI   C,0\r
22965         JRST    STOGC4\r
22966 \r
22967 STOGCE: JUMPE   C,STGCE1        ; jump if no current block\r
22968         HRLM    C,(B)           ; smash in count\r
22969         HRRM    E,(B)           ; smash in next pointer\r
22970         MOVEI   E,(B)           ; and setup E\r
22971 \r
22972 STGCE1: HRRZM   E,FLIST+1       ; final link up\r
22973         POPJ    P,\r
22974 \r
22975 IMPURE\r
22976 \r
22977 FLIST:  .+1\r
22978         ISTOST\r
22979 \r
22980 PURE\r
22981 \r
22982 END\r
22983 \f\r
22984 TITLE FLOATB--CONVERT FLOATING NUMBER TO ASCII STRING\r
22985 \r
22986 RELOCA\r
22987 \r
22988 .GLOBAL FLOATB\r
22989 \r
22990 ACNUM==1\r
22991 \r
22992 IRP A,,[A,B,C,D,E,F,G,H,I,J]\r
22993 A==ACNUM\r
22994 ACNUM==ACNUM+1\r
22995 TERMIN\r
22996 \r
22997 P==17\r
22998 \r
22999 TEM1==I\r
23000 \r
23001 EXPUNGE ACNUM\r
23002 \r
23003 FLOATB: PUSH    P,B\r
23004         PUSH    P,C\r
23005         PUSH    P,D\r
23006         PUSH    P,F\r
23007         PUSH    P,G\r
23008         PUSH    P,H\r
23009         PUSH    P,I\r
23010         PUSH    P,0\r
23011         PUSH    P,J\r
23012         MOVSI   0,440700        ; BUILD BYTEPNTR\r
23013         HLRZ    J,A             ; POINT TO BUFFER\r
23014         HRRI    0,1(J)\r
23015         MOVE    A,(A)           ; GET NUMBER\r
23016         MOVE    D,A\r
23017         SETZM   (J)             ; Clear counter\r
23018         PUSHJ   P,NFLOT\r
23019         POP     P,J\r
23020         POP     P,0\r
23021         POP     P,I\r
23022         POP     P,H\r
23023         POP     P,G\r
23024         POP     P,F\r
23025         POP     P,D\r
23026         POP     P,C\r
23027         POP     P,B\r
23028         POPJ    P,\r
23029 \r
23030 ; at this point we enter code abstracted from DDT.\r
23031 NFLOT:  JUMPG   A,TFL1\r
23032         JUMPE   A,FP1A\r
23033         MOVNS   A\r
23034         PUSH    P,A\r
23035         MOVEI   A,"-\r
23036         PUSHJ   P,CHRO\r
23037         POP     P,A\r
23038         TLZE    A,400000\r
23039         JRST    FP1A\r
23040 \r
23041 TFL1:   MOVEI   B,0\r
23042 TFLX:   CAMGE   A,FT01\r
23043         JRST    FP4\r
23044         CAML    A,FT8\r
23045         AOJA    B,FP4\r
23046 FP1A:\r
23047 FP3:    SETZB   C,TEM1          ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION\r
23048         MULI    A,400\r
23049         ASHC    B,-243(A)\r
23050         MOVE    A,B\r
23051         PUSHJ   P,FP7\r
23052         PUSH    P,A\r
23053         MOVEI   A,".\r
23054         PUSHJ   P,CHRO\r
23055         POP     P,A\r
23056         MOVNI   A,10\r
23057         ADD     A,TEM1\r
23058         MOVE    E,C\r
23059 FP3A:   MOVE    D,E\r
23060         MULI    D,12\r
23061         PUSHJ   P,FP7B\r
23062         SKIPE   E\r
23063         AOJL    A,FP3A\r
23064         POPJ    P,              ; ONE return from OFLT here\r
23065 \r
23066 FP4:    MOVNI   C,6\r
23067         MOVEI   F,0\r
23068 FP4A:   ADDI    F,1(F)\r
23069         XCT     FCP(B)\r
23070         SOSA    F\r
23071         FMPR    A,@FCP+1(B)\r
23072         AOJN    C,FP4A\r
23073         PUSH    P,EXPSGN(B)\r
23074         PUSHJ   P,FP3\r
23075         PUSH    P,A\r
23076         MOVEI   A,"E\r
23077         PUSHJ   P,CHRO\r
23078         POP     P,A\r
23079         POP     P,D\r
23080         PUSHJ   P,FDIGIT\r
23081         MOVE    A,F\r
23082 \r
23083 FP7:    SKIPE   A       ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT\r
23084         AOS     TEM1\r
23085         IDIVI   A,12\r
23086         HRLM    B,(P)\r
23087         JUMPE   A,FP7A1\r
23088         PUSHJ   P,FP7\r
23089 \r
23090 FP7A1:  HLRZ    D,(P)\r
23091 FP7B:   ADDI    D,"0\r
23092 \r
23093 ; type digit\r
23094 FDIGIT: PUSH    P,A\r
23095         MOVE    A,D\r
23096         PUSHJ   P,CHRO\r
23097         POP     P,A\r
23098         POPJ    P,\r
23099 \r
23100 CHRO:   AOS     (J)     ; COUNT CHAR\r
23101         IDPB    A,0     ; STUFF CHAR\r
23102         POPJ    P,\r
23103 \r
23104 ; constants\r
23105         1.0^32.\r
23106         1.0^16.\r
23107 FT8:    1.0^8\r
23108         1.0^4\r
23109         1.0^2\r
23110         1.0^1\r
23111 FT:     1.0^0\r
23112         1.0^-32.\r
23113         1.0^-16.\r
23114         1.0^-8\r
23115         1.0^-4\r
23116         1.0^-2\r
23117 FT01:   1.0^-1\r
23118 FT0=FT01+1\r
23119 \r
23120 ; instructions\r
23121 FCP:    CAMLE   A, FT0(C)\r
23122         CAMGE   A, FT(C)\r
23123         0, FT0(C)\r
23124 \r
23125 EXPSGN: "-\r
23126         "+\r
23127 \r
23128 \r
23129 EXPUNGE A,B,C,D,E,F,G,H,I,J,TEM1,P\r
23130 \r
23131 END\r
23132 \fTITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM\r
23133 \r
23134 RELOCATABLE\r
23135 \r
23136 .INSRT MUDDLE >\r
23137 \r
23138 .GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP\r
23139 .GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP\r
23140 .GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0\r
23141 .GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM\r
23142 .GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST\r
23143 .GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK\r
23144 .GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY\r
23145 .GLOBAL TMPLNT,ISTRCM\r
23146 \r
23147 ; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE\r
23148 \r
23149 PRMTYP:\r
23150 \r
23151 REPEAT NUMSAT,[0]                       ;INITIALIZE TABLE TO ZEROES\r
23152 \r
23153 IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]\r
23154 \r
23155 LOC PRMTYP+S!A\r
23156 P!A==.IRPCN+1\r
23157 P!A\r
23158 \r
23159 TERMIN\r
23160 \r
23161 PTMPLT==PBYTE+1\r
23162 \r
23163 ; FUDGE FOR STRUCTURE LOCATIVES\r
23164 \r
23165 IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]\r
23166 [LOCT,TMPLT]]\r
23167         IRP B,C,[A]\r
23168         LOC PRMTYP+S!B\r
23169         P!B==P!C,,0\r
23170         P!B\r
23171         .ISTOP\r
23172         TERMIN\r
23173 TERMIN\r
23174 \r
23175 LOC PRMTYP+SSTORE       ;SPECIAL HACK FOR AFREE STORAGE\r
23176 PNWORD\r
23177 \r
23178 LOC PRMTYP+NUMSAT+1\r
23179 \r
23180 PNUM==PTMPLT+1\r
23181 \r
23182 ; MACRO TO BUILD PRIMITIVE DISPATCH TABLES\r
23183 \r
23184 DEFINE PRDISP NAME,DEFAULT,LIST\r
23185         TBLDIS NAME,DEFAULT,[LIST]PNUM\r
23186         TERMIN\r
23187 \r
23188 \r
23189 ; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL\r
23190 \r
23191 PTYPE:  GETYP   A,(B)   ;CALLE D WITH B POINTING TO PAIR\r
23192         CAIN    A,TILLEG        ;LOSE IF ILLEGAL\r
23193         JRST    ILLCHOS\r
23194 \r
23195         PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE\r
23196         CAIE    A,SLOCA\r
23197         CAIN    A,SARGS         ;SPECIAL HAIR FOR ARGS\r
23198         PUSHJ   P,CHARGS\r
23199         CAIN    A,SFRAME\r
23200         PUSHJ   P,CHFRM\r
23201         CAIN    A,SLOCID\r
23202         PUSHJ   P,CHLOCI\r
23203 PTYP1:  MOVEI   0,(A)           ; ALSO RETURN PRIMTYPE\r
23204         CAILE   A,NUMSAT        ; SKIP IF NOT TEMPLATE\r
23205         SKIPA   A,[PTMPLT]\r
23206         MOVE    A,PRMTYP(A)     ;GET PRIM TYPE,\r
23207         POPJ    P,\r
23208 \r
23209 ; COMPILERS CALL TO ABOVE (LESS CHECKING)\r
23210 \r
23211 CPTYPE: PUSHJ   P,SAT\r
23212         MOVEI   0,(A)\r
23213         CAILE   A,NUMSAT\r
23214         SKIPA   A,[PTMPLT]\r
23215         MOVE    A,PRMTYP(A)\r
23216         POPJ    P,\r
23217 \r
23218 \r
23219 MFUNCTION SUBSTRUC,SUBR\r
23220 \r
23221         ENTRY\r
23222         JUMPGE  AB,TFA  ;need at least one arg\r
23223         CAMGE   AB,[-10,,0]     ;NO MORE THEN 4\r
23224         JRST    TMA\r
23225         MOVE    B,AB\r
23226         PUSHJ   P,PTYPE ;get primtype in A\r
23227         PUSH    P,A\r
23228         JRST    @TYTBL(A)\r
23229 \r
23230 RESSUB: CAMLE   AB,[-2,,0]      ;if only one arg skip rest\r
23231         JRST    @COPYTB(A)\r
23232         HLRZ    B,(AB)2 ;GET TYPE\r
23233         CAIE    B,TFIX  ;IF FIX OK\r
23234         JRST    WRONGT\r
23235         MOVE    B,(AB)1 ;ptr to object of resting\r
23236         MOVE    C,(AB)3 ;# of times to rest\r
23237         MOVEI   E,(A)\r
23238         MOVE    A,(AB)\r
23239         PUSHJ   P,@MRSTBL(E)\r
23240         PUSH    TP,A    ;type\r
23241         PUSH    TP,B    ;put rested sturc on stack\r
23242         JRST    ALOCOK\r
23243 \r
23244 PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB]\r
23245 [PNWORD,RESSUB],[PCHSTR,RESSUB]]\r
23246 \r
23247 PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST]\r
23248 [PNWORD,UREST],[PCHSTR,SREST]]\r
23249 \r
23250 PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC]\r
23251 [PNWORD,CPYUVC],[PCHSTR,CPYSTR]]\r
23252 \r
23253 PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC]\r
23254 [PNWORD,ALUVEC],[PCHSTR,ALSTR]]\r
23255 \r
23256 ALOCFX: MOVE    B,(TP)  ;missing 3rd arg aloc for "rest" of struc\r
23257         MOVE    C,-1(TP)\r
23258         MOVE    A,(P)\r
23259         PUSH    P,[377777,,-1]\r
23260         PUSHJ   P,@LENTBL(A) ;get length of rested struc\r
23261         SUB     P,[1,,1]\r
23262         POP     P,C\r
23263         MOVE    A,B     ;# of elements needed\r
23264         JRST    @ALOCTB(C)\r
23265 \r
23266 ALOCOK: CAML    AB,[-4,,0]  ;exactly 3 args\r
23267         JRST    ALOCFX\r
23268         HLRZ    C,(AB)4\r
23269         CAIE    C,TFIX  ;OK IF TYPE FIX\r
23270         JRST    WRONGT\r
23271         POP     P,C     ;C HAS PRIMTYYPE\r
23272         MOVE    A,(AB)5 ;# of elements needed\r
23273         JRST    @ALOCTB(C)      ;DO ALLOCATION\r
23274 \r
23275 \r
23276 CPYVEC: HLRE    A,(AB)1 ;USE WHEN ONLY ONE ARG\r
23277         MOVNS   A\r
23278         ASH     A,-1    ;# OF ELEMENTS FOR ALLOCATION\r
23279         PUSH    TP,(AB)\r
23280         PUSH    TP,(AB)1\r
23281 \r
23282 ALVEC:  PUSH    P,A     \r
23283         ASH     A,1\r
23284         HRLI    A,(A)\r
23285         ADD     A,(TP)\r
23286         CAIL    A,-1    ;CHK FOR OUT OF RANGE\r
23287         JRST    OUTRNG\r
23288         CAMGE   AB,[-6,,]       ; SKIP IF WE GET VECTOR\r
23289         JRST    ALVEC2          ; USER SUPPLIED VECTOR\r
23290         MOVE    A,(P)\r
23291         PUSHJ   P,IBLOK1\r
23292 ALVEC1: MOVE    A,(P)   ;# OF WORDS TO ALLOCATE\r
23293         MOVE    C,B             ; SAVE VECTOR POINTER\r
23294         ASH     A,1     ;TIMES 2\r
23295         HRLI    A,(A)\r
23296         ADD     A,B     ;PTING TO FIRST DOPE WORD -ALLOCATED \r
23297         CAIL    A,-1\r
23298         JRST    OUTRNG\r
23299         SUBI    A,1     ;ptr to last element of the block\r
23300         HRL     B,(TP)  ;bleft-ptr to source ,  b right -ptr to allocated space\r
23301         BLT     B,(A)\r
23302         MOVE    B,C\r
23303         POP     P,A\r
23304         SUB     TP,[2,,2]\r
23305         MOVSI   A,TVEC\r
23306         JRST    FINIS\r
23307 \r
23308 ALVEC2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
23309         CAIE    0,TVEC\r
23310         JRST    WTYP\r
23311         HLRE    A,7(AB)         ; CHECK SIZE\r
23312         MOVNS   A\r
23313         ASH     A,-1            ; # OF ELEMENTS\r
23314         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
23315         JRST    OUTRNG\r
23316         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
23317         JRST    ALVEC1\r
23318 \r
23319 CPYUVC: HLRE    A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION\r
23320         MOVNS   A\r
23321         PUSH    TP,(AB)\r
23322         PUSH    TP,1(AB)\r
23323 \r
23324 ALUVEC: PUSH    P,A\r
23325         HRLI    A,(A)\r
23326         ADD     A,(TP)  ;PTING TO DOPE WORD OF ORIG VEC\r
23327         CAIL    A,-1\r
23328         JRST    OUTRNG\r
23329         CAMGE   AB,[-6,,]       ; SKIP IF WE SUPPLY UVECTOR\r
23330         JRST    ALUVE2\r
23331         MOVE    A,(P)\r
23332         PUSHJ   P,IBLOCK\r
23333 ALUVE1: MOVE    A,(P)   ;# of owrds to allocate\r
23334         HRLI    A,(A)\r
23335         ADD     A,B     ;LOCATION O FIRST ALLOCATED DOPE WORD\r
23336         HLR     D,(AB)1 ;# OF ELEMENTS IN UVECTOR\r
23337         MOVNS   D\r
23338         ADD     D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE\r
23339         GETYP   E,(D)   ;GET UTYPE\r
23340         CAML    AB,[-6,,]       ; SKIP IF USER SUPPLIED OUTPUT UVECTOR\r
23341         HRLM    E,(A)   ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC\r
23342         CAMGE   AB,[-6,,]\r
23343         CAIN    0,(E)           ; 0 HAS USER UVEC UTYPE\r
23344         JRST    .+2\r
23345         JRST    WRNGUT\r
23346         CAIL    A,-1\r
23347         JRST    OUTRNG\r
23348         MOVE    C,B             ; SAVE POINTER TO FINAL GUY\r
23349         HRL     C,(TP)  ;Bleft- ptr to source, Bright-ptr to allocated space\r
23350         BLT     C,-1(A)\r
23351         POP     P,A\r
23352         MOVSI   A,TUVEC\r
23353         JRST    FINIS\r
23354 \r
23355 ALUVE2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
23356         CAIE    0,TUVEC\r
23357         JRST    WTYP\r
23358         HLRE    A,7(AB)         ; CHECK SIZE\r
23359         MOVNS   A\r
23360         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
23361         JRST    OUTRNG\r
23362         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
23363         HLRE    A,B\r
23364         SUBM    B,A\r
23365         GETYP   0,(A)           ; GET UTYPE OF USER UVECTOR\r
23366         JRST    ALUVE1\r
23367 \r
23368 CPYSTR: HRR     A,(AB)  ;#OF CHAR TO COPY\r
23369         PUSH    TP,(AB) ;ALSTR EXPECTS STRING IN TP\r
23370         PUSH    TP,1(AB)\r
23371 \r
23372 ALSTR:  PUSH    P,A\r
23373         HRRZ    0,-1(TP)        ;0 IS LENGTH OFF VECTOR\r
23374         CAIGE   0,(A)\r
23375         JRST    OUTRNG\r
23376         CAMGE   AB,[-6,,]       ; SKIP IF WE SUPPLY STRING\r
23377         JRST    ALSTR2\r
23378         ADDI    A,4\r
23379         IDIVI   A,5\r
23380         PUSHJ   P,IBLOCK ;ALLOCATE SPACE\r
23381         HRLI    B,440700\r
23382         MOVE    A,(P)           ; # OF CHARS TO A\r
23383 ALSTR1: PUSH    P,B     ;BYTE PTR TO ALOC SPACE\r
23384         POP     TP,C ;PTR TO ORIGINAL STR\r
23385         POP     TP,D ;USELESS\r
23386 COPYST: ILDB    D,C ;GET NEW CHAR\r
23387         IDPB    D,B ;DEPOSIT CHAR\r
23388         SOJG    A,COPYST        ;FINISH TRANSFER?\r
23389 \r
23390 CLOSTR: POP     P,B ;BYTE PTR TO COPY\r
23391         POP     P,A ;# FO ELEMENTS\r
23392         HRLI    A,TCHSTR\r
23393         JRST    FINIS\r
23394 \r
23395 ALSTR2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
23396         CAIE    0,TCHSTR\r
23397         JRST    WTYP\r
23398         HRRZ    A,6(AB)\r
23399         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
23400         JRST    OUTRNG\r
23401         EXCH    A,(P)\r
23402         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
23403         JRST    ALSTR1\r
23404 \r
23405 CPYLST: SKIPN   1(AB)\r
23406         JRST    ZEROLT\r
23407         PUSHJ   P,CELL2\r
23408         POP     P,C\r
23409         HRLI    C,TLIST ;TP JUNK FOR GAR. COLLECTOR\r
23410         PUSH    TP,C    ;TYPE\r
23411         PUSH    TP,B    ;VALUE -PTR TO NEW LIST\r
23412         PUSH    TP,C    ;TYPE\r
23413         MOVE    C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST\r
23414 REPLST: MOVE    D,(C)\r
23415         MOVE    E,1(C)  ;GET LIST ELEMENT INTO ALOC SPACE\r
23416         HLLM    D,(B)\r
23417         MOVEM   E,1(B)  ;PUT INTO ALLOCATED SPACE\r
23418         HRRZ    C,(C)   ;UPDATE PTR\r
23419         JUMPE   C,CLOSWL        ;END OF LIST?\r
23420         PUSH    TP,B\r
23421         PUSHJ   P,CELL2\r
23422         POP     TP,D\r
23423         HRRM    B,(D)   ;LINK ALLOCATED LIST CELLS\r
23424         JRST    REPLST\r
23425 \r
23426 CLOSWL: POP     TP,B    ;USELESS\r
23427         POP     TP,B    ;PTR TO NEW LIST\r
23428         POP     TP,A    ;TYPE\r
23429         JRST    FINIS\r
23430 \r
23431 \r
23432 \r
23433 ALLIST: CAMGE   AB,[-6,,]       ; SKIP IF WE BUILD THE LIST\r
23434         JRST    CPYLS2\r
23435         JUMPE   A,ZEROLT\r
23436         PUSH    P,A\r
23437         PUSHJ   P,CELL\r
23438         POP     P,A     ;# OF ELEMENTS\r
23439         PUSH    P,B     ;ptr to allocated list\r
23440         POP     TP,C    ;ptr to orig list\r
23441         JRST    ENTCOP\r
23442 \r
23443 COPYL:  ADDI    B,2\r
23444         HRRM    B,-2(B) ;LINK ALOCATED LIST CELLS\r
23445 ENTCOP: JUMPE   C,OUTRNG\r
23446         MOVE    D,(C)   \r
23447         MOVE    E,1(C)  ;get list element into D+E\r
23448         HLLM    D,(B)\r
23449         MOVEM   E,1(B)  ;put into allocated space\r
23450         HRRZ    C,(C)   ;update ptrs\r
23451         SOJG    A,COPYL ;finish transfer?\r
23452 \r
23453 CLOSEL: POP     P,B     ;PTR TO NEW LIST\r
23454         POP     TP,A    ;type\r
23455         JRST    FINIS\r
23456 \r
23457 ZEROLT: SUB     TP,[1,,1]       ;IF RESTED ALL OF LIST\r
23458         SUB     TP,[1,,1]\r
23459         MOVSI   A,TLIST\r
23460         MOVEI   B,0\r
23461         JRST    FINIS\r
23462 \r
23463 CPYLS2: GETYP   0,6(AB)\r
23464         CAIE    0,TLIST\r
23465         JRST    WTYP\r
23466         MOVE    B,7(AB)         ; GET DEST LIST\r
23467         MOVE    C,(TP)\r
23468 \r
23469         JUMPE   A,CPYLS3\r
23470 CPYLS4: JUMPE   B,OUTRNG\r
23471         JUMPE   C,OUTRNG\r
23472         MOVE    D,1(C)\r
23473         MOVEM   D,1(B)\r
23474         GETYP   0,(C)\r
23475         HRLM    0,(B)\r
23476         HRRZ    B,(B)\r
23477         HRRZ    C,(C)\r
23478         SOJG    A,CPYLS4\r
23479 \r
23480 CPYLS3: MOVE    B,7(AB)\r
23481         MOVSI   A,TLIST\r
23482         JRST    FINIS\r
23483 \r
23484 \r
23485 ; PROCESS TYPE ILLEGAL\r
23486 \r
23487 ILLCHO: HRRZ    B,1(B)  ;GET CLOBBERED TYPE\r
23488         CAIN    B,TARGS ;WAS IT ARGS?\r
23489         JRST    ILLAR1\r
23490         CAIN    B,TFRAME                ;A FRAME?\r
23491         JRST    ILFRAM\r
23492         CAIN    B,TLOCD         ;A LOCATIVE TO AN ID\r
23493         JRST    ILLOC1\r
23494 \r
23495         LSH     B,1             ;NONE OF ABOVE LOOK IN TABLE\r
23496         ADDI    B,TYPVEC+1(TVP)\r
23497         PUSH    TP,$TATOM\r
23498         PUSH    TP,EQUOTE ILLEGAL\r
23499         PUSH    TP,$TATOM\r
23500         PUSH    TP,(B)          ;PUSH ATOMIC NAME\r
23501         MOVEI   A,2\r
23502         JRST    CALER           ;GO TO ERROR REPORTER\r
23503 \r
23504 ; CHECK AN ARGS POINTER\r
23505 \r
23506 CHARGS: PUSHJ   P,ICHARG                ; INTERNAL CHECK\r
23507         JUMPN   B,CPOPJ\r
23508 \r
23509 ILLAR1: PUSH    TP,$TATOM\r
23510         PUSH    TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK\r
23511         JRST    CALER1\r
23512 \r
23513 ICHARG: PUSH    P,A             ;SAVE SOME ACS\r
23514         PUSH    P,B\r
23515         PUSH    P,C\r
23516         SKIPN   C,1(B)  ;GET POINTER\r
23517         JRST    ILLARG          ; ZERO POINTER IS ILLEGAL\r
23518         HLRE    A,C             ;FIND ASSOCIATED FRAME\r
23519         SUBI    C,(A)           ;C POINTS TO FRAME OR FRAME POINTER\r
23520         GETYP   A,(C)           ;GET TYPE OF NEXT GOODIE\r
23521         CAIN    A,TCBLK\r
23522         JRST    CHARG1\r
23523         CAIE    A,TENTRY        ;MUST BE EITHER ENTRY OR TINFO\r
23524         CAIN    A,TINFO\r
23525         JRST    CHARG1          ;WINNER\r
23526         JRST    ILLARG\r
23527 \r
23528 CHARG1: CAIN    A,TINFO         ;POINTER TO FRAME?\r
23529         ADD     C,1(C)          ;YES, GET IT\r
23530         CAIE    A,TINFO         ;POINTS TO ENTRT?\r
23531         MOVEI   C,FRAMLN(C)     ;YES POINT TO END OF FRAME\r
23532         HLRZ    C,OTBSAV(C)     ;GET TIME FROM FRAME\r
23533         HRRZ    B,(B)           ;AND ARGS TIME\r
23534         CAIE    B,(C)           ;SAME?\r
23535 ILLARG: SETZM   -1(P)           ; RETURN ZEROED B\r
23536 POPBCJ: POP     P,C\r
23537         POP     P,B\r
23538         POP     P,A\r
23539         POPJ    P,              ;GO GET PRIM TYPE\r
23540 \f\r
23541 \r
23542 \r
23543 ; CHECK A FRAME POINTER\r
23544 \r
23545 CHFRM:  PUSHJ   P,CHFRAM\r
23546         JUMPN   B,CPOPJ\r
23547 \r
23548 ILFRAM: PUSH    TP,$TATOM\r
23549         PUSH    TP,EQUOTE ILLEGAL-FRAME\r
23550         JRST    CALER1\r
23551 \r
23552 CHFRAM: PUSH    P,A             ;SAVE SOME REGISTERS\r
23553         PUSH    P,B\r
23554         PUSH    P,C\r
23555         HRRZ    A,(B)           ; GE PVP POINTER\r
23556         HLRZ    C,(A)           ; GET LNTH\r
23557         SUBI    A,-1(C)         ; POINT TO TOP\r
23558         CAIN    A,(PVP)         ; SKIP  IF NOT THIS PROCESS\r
23559         MOVEM   TP,TPSTO+1(A)   ; MAKE CURRENT BE STORED\r
23560         HRRZ    A,TPSTO+1(A)    ; GET TP FOR THIS PROC\r
23561         HRRZ    C,1(B)          ;GET POINTER PART\r
23562         CAILE   C,1(A)          ;STILL WITHIN STACK\r
23563         JRST    BDFR\r
23564         HLRZ    A,FSAV(C)       ;CHECK STILL AN ENTRY BLOCK\r
23565         CAIN    A,TCBLK\r
23566         JRST    .+3\r
23567         CAIE    A,TENTRY\r
23568         JRST    BDFR\r
23569         HLRZ    A,1(B)          ;GET TIME FROM POINTER\r
23570         HLRZ    C,OTBSAV(C)     ;AND FROM FRAME\r
23571         CAIE    A,(C)           ;SAME?\r
23572 BDFR:   SETZM   -1(P)           ; RETURN 0 IN B\r
23573         JRST    POPBCJ          ;YES, WIN\r
23574 \r
23575 ; CHECK A LOCATIVE TO AN IDENTIFIER\r
23576 \r
23577 CHLOCI: PUSHJ   P,ICHLOC\r
23578         JUMPN   B,CPOPJ\r
23579 \r
23580 ILLOC1: PUSH    TP,$TATOM\r
23581         PUSH    TP,EQUOTE ILLEGAL-LOCATIVE\r
23582         JRST    CALER1\r
23583 \r
23584 ICHLOC: PUSH    P,A\r
23585         PUSH    P,B\r
23586         PUSH    P,C\r
23587 \r
23588         HRRZ    A,(B)           ;GET TIME FROM POINTER\r
23589         JUMPE   A,POPBCJ        ;ZERO, GLOBAL VARIABLE NO TIME\r
23590         HRRZ    C,1(B)          ;POINT TO STACK\r
23591         CAMLE   C,VECTOP\r
23592         JRST    ILLOC           ;NO\r
23593         HRRZ    C,2(C)          ; SHOULD BE DECL,,TIME\r
23594         CAIE    A,(C)\r
23595 ILLOC:  SETZM   -1(P)           ; RET 0 IN B\r
23596         JRST    POPBCJ\r
23597 \r
23598 \r
23599         \r
23600 \f\r
23601 ; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED\r
23602 \r
23603 MFUNCTION %STRUC,SUBR,[STRUCTURED?]\r
23604 \r
23605         ENTRY   1\r
23606 \r
23607         GETYP   A,(AB)          ; GET TYPE\r
23608         PUSHJ   P,ISTRUC        ; INTERNAL\r
23609         JRST    IFALSE\r
23610         JRST    ITRUTH\r
23611 \r
23612 \r
23613 ; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE\r
23614 \r
23615 MFUNCTION %LEGAL,SUBR,[LEGAL?]\r
23616 \r
23617         ENTRY   1\r
23618 \r
23619         MOVEI   B,(AB)          ; POINT TO ARG\r
23620         PUSHJ   P,ILEGQ\r
23621         JRST    IFALSE\r
23622         JRST    ITRUTH\r
23623 \r
23624 ILEGQ:  GETYP   A,(B)\r
23625         CAIN    A,TILLEG\r
23626         POPJ    P,\r
23627         PUSHJ   P,SAT           ; GET STORG TYPE\r
23628         CAIN    A,SFRAME        ; FRAME?\r
23629         PUSHJ   P,CHFRAM\r
23630         CAIN    A,SARGS ; ARG TUPLE\r
23631         PUSHJ   P,ICHARG\r
23632         CAIN    A,SLOCID        ; ID LOCATIVE\r
23633         PUSHJ   P,ICHLOC\r
23634         JUMPE   B,CPOPJ\r
23635         JRST    CPOPJ1\r
23636 \r
23637 \r
23638 ; COMPILERS CALL\r
23639 \r
23640 CILEGQ: PUSH    TP,A\r
23641         PUSH    TP,B\r
23642         MOVEI   B,-1(TP)\r
23643         PUSHJ   P,ILEGQ\r
23644         TDZA    0,0\r
23645         MOVEI   0,1\r
23646         SUB     TP,[2,,2]\r
23647         JUMPE   0,NO\r
23648 \r
23649 YES:    MOVSI   A,TATOM\r
23650         MOVE    B,MQUOTE T\r
23651         JRST    CPOPJ1\r
23652 \r
23653 NOM:    SUBM    M,(P)\r
23654 NO:     MOVSI   A,TFALSE\r
23655         MOVEI   B,0\r
23656         POPJ    P,\r
23657 \r
23658 YESM:   SUBM    M,(P)\r
23659         JRST    YES\r
23660 \f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS\r
23661 \r
23662 MFUNCTION BITS,SUBR\r
23663         ENTRY\r
23664         JUMPGE  AB,TFA          ;AT LEAST ONE ARG ?\r
23665         GETYP   A,(AB)\r
23666         CAIE    A,TFIX\r
23667         JRST    WTYP1\r
23668         SKIPLE  C,(AB)+1        ;GET FIRST AND CHECK TO SEE IF POSITIVE\r
23669         CAILE   C,44            ;CHECK IF FIELD NOT GREATER THAN WORD SIZE\r
23670         JRST    OUTRNG\r
23671         MOVEI   B,0\r
23672         CAML    AB,[-2,,0]      ;ONLY ONE ARG ?\r
23673         JRST    ONEF            ;YES\r
23674         CAMGE   AB,[-4,,0]      ;MORE THAN TWO ARGS ?\r
23675         JRST    TMA             ;YES, LOSE\r
23676         GETYP   A,(AB)+2\r
23677         CAIE    A,TFIX\r
23678         JRST    WTYP2\r
23679         SKIPGE  B,(AB)+3        ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE\r
23680         JRST    OUTRNG\r
23681         ADD     C,(AB)+3        ;CALCULATE LEFTMOST EXTENT OF THE FIELD\r
23682         CAILE   C,44            ;SHOULD BE LESS THAN WORD SIZE\r
23683         JRST    OUTRNG\r
23684         LSH     B,6\r
23685 ONEF:   ADD     B,(AB)+1\r
23686         LSH     B,30            ;FORM BYTE POINTER'S LEFT HALF\r
23687         MOVSI   A,TBITS\r
23688         JRST    FINIS\r
23689 \r
23690 \r
23691 \r
23692 MFUNCTION GETBITS,SUBR\r
23693         ENTRY 2\r
23694         GETYP   A,(AB)\r
23695         PUSHJ   P,SAT\r
23696         CAIN    A,SSTORE\r
23697         JRST    .+3\r
23698         CAIE    A,S1WORD\r
23699         JRST    WTYP1\r
23700         GETYP   A,(AB)+2\r
23701         CAIE    A,TBITS\r
23702         JRST    WTYP2\r
23703         MOVEI   A,(AB)+1        ;GET ADDRESS OF THE WORD\r
23704         HLL     A,(AB)+3        ;GET LEFT HALF OF BYTE POINTER\r
23705         LDB     B,A\r
23706         MOVSI   A,TWORD         ; ALWAYS RETURN WORD\b\b\b\b____\r
23707         JRST    FINIS\r
23708 \r
23709 \r
23710 MFUNCTION PUTBITS,SUBR\r
23711         ENTRY\r
23712         CAML    AB,[-2,,0]      ;AT LEAST TWO ARGS ?\r
23713         JRST    TFA             ;NO, LOSE\r
23714         GETYP   A,(AB)\r
23715         PUSHJ   P,SAT\r
23716         CAIE    A,S1WORD\r
23717         JRST    WTYP1\r
23718         GETYP   A,(AB)+2\r
23719         CAIE    A,TBITS\r
23720         JRST    WTYP2\r
23721         MOVEI   B,0             ;EMPTY THIRD ARG DEFAULT\r
23722         CAML    AB,[-4,,0]      ;ONLY TWO ARGS ?\r
23723         JRST    TWOF\r
23724         CAMGE   AB,[-6,,0]      ;MORE THAN THREE ARGS ?\r
23725         JRST    TMA             ;YES, LOSE\r
23726         GETYP   A,(AB)+4\r
23727         PUSHJ   P,SAT\r
23728         CAIE    A,S1WORD\r
23729         JRST    WTYP3\r
23730         MOVE    B,(AB)+5\r
23731 TWOF:   MOVEI   A,(AB)+1        ;ADDRESS OF THE TARGET WORD\r
23732         HLL     A,(AB)+3        ;GET THE LEFT HALF OF THE BYTE POINTER\r
23733         DPB     B,A\r
23734         MOVE    B,(AB)+1\r
23735         MOVE    A,(AB)          ;SAME TYPE AS FIRST ARG'S\r
23736         JRST    FINIS\r
23737 \f\r
23738 \r
23739 ; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS\r
23740 \r
23741 MFUNCTION       LNTHQ,SUBR,[LENGTH?]\r
23742 \r
23743         ENTRY 2\r
23744         GETYP   A,(AB)2\r
23745         CAIE    A,TFIX\r
23746         JRST    WTYP2\r
23747         PUSH    P,(AB)3\r
23748         JRST    LNTHER\r
23749 \r
23750 \r
23751 MFUNCTION LENGTH,SUBR\r
23752 \r
23753         ENTRY   1\r
23754         PUSH    P,[377777777777]\r
23755 LNTHER: MOVE    B,AB            ;POINT TO ARGS\r
23756         PUSHJ   P,PTYPE         ;GET ITS PRIM TYPE\r
23757         MOVE    B,1(AB)\r
23758         MOVE    C,(AB)\r
23759         PUSHJ   P,@LENTBL(A)    ; CALL RIGTH ONE\r
23760         JRST    LFINIS          ;OTHERWISE USE 0\r
23761 \r
23762 PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]\r
23763 [PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]]\r
23764 \r
23765 LNLST:  SKIPN   C,B             ; EMPTY?\r
23766         JRST    LNLST2          ; YUP, LEAVE\r
23767         MOVEI   B,1             ; INIT COUNTER\r
23768         MOVSI   A,TLIST         ;WILL BECOME INTERRUPTABLE\r
23769         HLLM    A,CSTO(PVP)     ;AND C WILL BE A LIST POINTER\r
23770 LNLST1: INTGO           ;IN CASE CIRCULAR LIST\r
23771         CAMLE   B,(P)-1\r
23772         JRST    LNLST2\r
23773         HRRZ    C,(C)           ;STEP\r
23774         JUMPE   C,.+2           ;DONE, RETRUN LENGTH\r
23775         AOJA    B,LNLST1        ;COUNT AND GO\r
23776 LNLST2: SETZM   CSTO(PVP)\r
23777         POPJ    P,\r
23778 \r
23779 LFINIS: POP     P,C\r
23780         CAMLE   B,C\r
23781         JRST    IFALSE\r
23782         MOVSI   A,TFIX          ;LENGTH IS AN INTEGER\r
23783         JRST    FINIS\r
23784 \r
23785 LNVEC:  ASH     B,-1            ;GENERAL VECTOR DIVIDE BY 2\r
23786 LNUVEC: HLRES   B               ;GET LENGTH\r
23787         MOVMS   B               ;MAKE POS\r
23788         POPJ    P,\r
23789 \r
23790 LNCHAR: HRRZ    B,C             ; GET COUNT\r
23791         POPJ    P,\r
23792 \r
23793 LNTMPL: GETYP   A,(B)           ; GET REAL SAT\r
23794         SUBI    A,NUMSAT+1\r
23795         HRLS    A               ; READY TO HIT TABLE\r
23796         ADD     A,TD.LNT+1(TVP)\r
23797         JUMPGE  A,BADTPL\r
23798         MOVE    C,B             ; DATUM TO C\r
23799         XCT     (A)             ; GET LENGTH\r
23800         HLRZS   C               ; REST COUNTER\r
23801         SUBI    B,(C)           ; FLUSH IT OFF\r
23802         MOVEI   B,(B)           ; IN CASE FUNNY STUFF\r
23803         MOVSI   A,TFIX\r
23804         POPJ    P,\r
23805 \r
23806 ; COMPILERS ENTRIES\r
23807 \r
23808 CILNT:  SUBM    M,(P)\r
23809         PUSH    P,[377777,,-1]\r
23810         MOVE    C,A\r
23811         GETYP   A,A\r
23812         PUSHJ   P,CPTYPE        ; GET PRIMTYPE\r
23813         JUMPE   A,COMPERR\r
23814         PUSHJ   P,@LENTBL(A)    ; DISPATCH\r
23815         MOVSI   A,TFIX\r
23816         SUB     P,[1,,1]\r
23817 MPOPJ:  SUBM    M,(P)\r
23818         POPJ    P,\r
23819 \r
23820 CILNQ:  SUBM    M,(P)\r
23821         PUSH    P,C\r
23822         MOVE    C,A\r
23823         GETYP   A,A\r
23824         PUSHJ   P,CPTYPE\r
23825         JUMPE   A,COMPERR\r
23826         PUSHJ   P,@LENTBL(A)\r
23827         POP     P,C\r
23828         SUBM    M,(P)\r
23829         MOVSI   A,TFIX\r
23830         CAMG    B,C\r
23831         JRST    CPOPJ1\r
23832         MOVSI   A,TFALSE\r
23833         MOVEI   B,0\r
23834         POPJ    P,\r
23835 \f\r
23836 \r
23837 \r
23838 IDNT1:  MOVE    A,(AB)          ;RETURN THE FIRST ARG\r
23839         MOVE    B,1(AB)\r
23840         JRST    FINIS\r
23841 \r
23842 MFUNCTION QUOTE,FSUBR\r
23843 \r
23844         ENTRY   1\r
23845 \r
23846         GETYP   A,(AB)\r
23847         CAIE    A,TLIST         ;ARG MUST BE A LIST\r
23848         JRST    WTYP1\r
23849         SKIPN   B,1(AB)         ;SHOULD HAVE A BODY\r
23850         JRST    TFA\r
23851 \r
23852         HLLZ    A,(B)           ; GET IT\r
23853         MOVE    B,1(B)\r
23854         JSP     E,CHKAB\r
23855         JRST    FINIS\r
23856 \r
23857 MFUNCTION       NEQ,SUBR,[N==?]\r
23858         \r
23859         MOVEI   D,1\r
23860         JRST    EQR\r
23861 \r
23862 MFUNCTION EQ,SUBR,[==?]\r
23863 \r
23864         MOVEI   D,0\r
23865 EQR:    ENTRY   2\r
23866 \r
23867         GETYP   A,(AB)          ;GET 1ST TYPE\r
23868         GETYP   C,2(AB)         ;AND 2D TYPE\r
23869         MOVE    B,1(AB)\r
23870         CAIN    A,(C)           ;CHECK IT\r
23871         CAME    B,3(AB)\r
23872         JRST    @TABLE2(D)\r
23873         JRST    @TABLE1(D)\r
23874 \r
23875 ITRUTH: MOVSI   A,TATOM         ;RETURN TRUTH\r
23876         MOVE    B,MQUOTE T\r
23877         JRST    FINIS\r
23878 \r
23879 IFALSE: MOVSI   A,TFALSE                ;RETURN FALSE\r
23880         MOVEI   B,0\r
23881         JRST    FINIS\r
23882 \r
23883 TABLE1: ITRUTH\r
23884 TABLE2: IFALSE\r
23885         ITRUTH\r
23886 \r
23887 \f\r
23888 \r
23889 \r
23890 MFUNCTION EMPTY,SUBR,EMPTY?\r
23891 \r
23892         ENTRY   1\r
23893 \r
23894         MOVE    B,AB\r
23895         PUSHJ   P,PTYPE         ;GET PRIMITIVE TYPE\r
23896 \r
23897         MOVEI   A,(A)\r
23898         JUMPE   A,WTYP1\r
23899         SKIPN   B,1(AB)         ;GET THE ARG\r
23900         JRST    ITRUTH\r
23901 \r
23902         CAIN    A,PTMPLT        ; TEMPLATE?\r
23903         JRST    EMPTPL\r
23904         CAIE    A,P2WORD                ;A LIST?\r
23905         JRST    EMPT1           ;NO VECTOR OR CHSTR\r
23906         JUMPE   B,ITRUTH                ;0 POINTER MEANS EMPTY LIST\r
23907         JRST    IFALSE\r
23908 \r
23909 \r
23910 EMPT1:  CAIE    A,PCHSTR                ;CHAR STRING?\r
23911         JRST    EMPT2           ;NO, VECTOR\r
23912         HRRZ    B,(AB)          ; GET COUNT\r
23913         JUMPE   B,ITRUTH        ;0 STRING WINS\r
23914         JRST    IFALSE\r
23915 \r
23916 EMPT2:  JUMPGE  B,ITRUTH\r
23917         JRST    IFALSE\r
23918 \r
23919 EMPTPL: PUSHJ   P,LNTMPL        ; GET LENGTH\r
23920         JUMPE   B,ITRUTH\r
23921         JRST    IFALSE\r
23922 \r
23923 ; COMPILER'S ENTRY TO EMPTY\r
23924 \r
23925 CEMPTY: PUSH    P,A\r
23926         GETYP   A,A\r
23927         PUSHJ   P,CPTYPE\r
23928         POP     P,0\r
23929         JUMPE   A,COMPERR\r
23930         JUMPE   B,YES           ; ALWAYS EMPTY\r
23931         CAIN    A,PTMPLT\r
23932         JRST    CEMPTP\r
23933         CAIN    A,P2WORD\r
23934         JRST    NO\r
23935         CAIN    A,PCHSTR\r
23936         JRST    .+3\r
23937         JUMPGE  B,YES\r
23938         JRST    NO\r
23939         TRNE    0,-1            ; STRING, SKIP ON ZERO LENGTH FIELD\r
23940         JRST    NO\r
23941         JRST    YES\r
23942 \r
23943 CEMPTP: PUSHJ   P,LNTMPL\r
23944         JUMPE   B,YES\r
23945         JRST    NO\r
23946 \r
23947 MFUNCTION       NEQUAL,SUBR,[N=?]\r
23948         PUSH    P,[1]\r
23949         JRST    EQUALR\r
23950 \r
23951 MFUNCTION EQUAL,SUBR,[=?]\r
23952         PUSH    P,[0]\r
23953 EQUALR: ENTRY   2\r
23954 \r
23955         MOVE    C,AB            ;SET UP TO CALL INTERNAL\r
23956         MOVE    D,AB\r
23957         ADD     D,[2,,2]        ;C POINTS TO FIRS, D TO SECOND\r
23958         PUSHJ   P,IEQUAL        ;CALL INTERNAL\r
23959         JRST    EQFALS          ;NO SKIP MEANS LOSE\r
23960         JRST    EQTRUE\r
23961 EQFALS: POP     P,C\r
23962         JRST    @TABLE2(C)\r
23963 EQTRUE: POP     P,C\r
23964         JRST    @TABLE1(C)\r
23965 \r
23966 \f\r
23967 ; COMPILER'S ENTRY TO =? AND N=?\r
23968 \r
23969 CINEQU: PUSH    P,[0]\r
23970         JRST    .+2\r
23971 \r
23972 CIEQUA: PUSH    P,[1]\r
23973         PUSH    TP,A\r
23974         PUSH    TP,B\r
23975         PUSH    TP,C\r
23976         PUSH    TP,D\r
23977         MOVEI   C,-3(TP)\r
23978         MOVEI   D,-1(TP)\r
23979         SUBM    M,-1(P)         ; MAY BECOME INTERRUPTABLE\r
23980         PUSHJ   P,IEQUAL\r
23981         JRST    NOE\r
23982         POP     P,C\r
23983         SUB     TP,[4,,4]       ; FLUSH TEMPS\r
23984         JRST    @CTAB1(C)\r
23985 \r
23986 NOE:    POP     P,C\r
23987         SUB     TP,[4,,4]\r
23988         JRST    @CTAB2(C)\r
23989 \r
23990 CTAB1:  NOM\r
23991 CTAB2:  YESM\r
23992         NOM\r
23993         \r
23994 ; INTERNAL EQUAL SUBROUTINE\r
23995 \r
23996 IEQUAL: MOVE    B,C             ;NOW CHECK THE ARGS\r
23997         PUSHJ   P,PTYPE\r
23998         MOVE    B,D\r
23999         PUSHJ   P,PTYPE\r
24000         GETYP   0,(C)           ;NOW CHECK FOR EQ\r
24001         GETYP   B,(D)\r
24002         MOVE    E,1(C)\r
24003         CAIN    0,(B)           ;DONT SKIP IF POSSIBLE WINNER\r
24004         CAME    E,1(D)          ;DEFINITE WINNER, SKIP\r
24005         JRST    IEQ1\r
24006 CPOPJ1: AOS     (P)             ;EQ, SKIP RETURN\r
24007         POPJ    P,\r
24008 \r
24009 \r
24010 IEQ1:   CAIE    0,(B)           ;SKIP IF POSSIBLE MATCH\r
24011 CPOPJ:  POPJ    P,              ;NOT POSSIBLE WINNERS\r
24012         JRST    @EQTBL(A)       ;DISPATCH\r
24013 \r
24014 PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]\r
24015 [PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]]\r
24016 \r
24017 \r
24018 EQLIST: PUSHJ   P,PUSHCD        ;PUT ARGS ON STACK\r
24019 \r
24020 EQLST1: INTGO                   ;IN CASE OF CIRCULAR\r
24021         HRRZ    C,-2(TP)        ;GET FIRST\r
24022         HRRZ    D,(TP)          ;AND 2D\r
24023         CAIN    C,(D)           ;EQUAL?\r
24024         JRST    EQLST2          ;YES, LEAVE\r
24025         JUMPE   C,EQLST3        ;NIL LOSES\r
24026         JUMPE   D,EQLST3\r
24027         GETYP   0,(C)           ;CHECK DEFERMENT\r
24028         CAIN    0,TDEFER\r
24029         HRRZ    C,1(C)          ;PICK UP POINTED TO CROCK\r
24030         GETYP   0,(D)\r
24031         CAIN    0,TDEFER\r
24032         HRRZ    D,1(D)          ;POINT TO REAL GOODIE\r
24033         PUSHJ   P,IEQUAL        ;CHECK THE CARS\r
24034         JRST    EQLST3          ;LOSE\r
24035         HRRZ    C,@-2(TP)       ;CDR THE LISTS\r
24036         HRRZ    D,@(TP\r
24037         HRRZM   C,-2(TP)        ;AND STORE\r
24038         HRRZM   D,(TP)\r
24039         JRST    EQLST1\r
24040 \r
24041 EQLST2: AOS     (P)             ;SKIP RETRUN\r
24042 EQLST3: SUB     TP,[4,,4]       ;REMOVE CRUFT\r
24043         POPJ    P,\r
24044 \f\r
24045 ; HERE FOR HACKING TEMPLATE STRUCTURES\r
24046 \r
24047 EQTMPL: PUSHJ   P,PUSHCD        ; SAVE GOODIES\r
24048         PUSHJ   P,PUSHCD\r
24049         MOVE    C,1(C)          ; CHECK REAL SATS\r
24050         GETYP   C,(C)\r
24051         MOVE    D,1(D)\r
24052         GETYP   0,(D)\r
24053         CAIE    0,(C)           ; SKIP IF WINNERS\r
24054         JRST    EQTMP4\r
24055         PUSH    P,0             ; SAVE MAGIC OFFSET\r
24056         MOVE    B,-2(TP)\r
24057         PUSHJ   P,TM.LN1        ; RET LENGTH IN B\r
24058         MOVEI   B,-1(B)         ; FLUSH FUNNY\r
24059         HLRZ    C,-2(TP)\r
24060         SUBI    B,(C)\r
24061         PUSH    P,B\r
24062         MOVE    C,(TP)          ; POINTER TO OTHER GUY\r
24063         ADD     A,TD.LNT+1(TVP)\r
24064         XCT     (A)             ; OTHER LENGTH TO B\r
24065         HLRZ    0,B             ; REST OFFSETTER\r
24066         PUSH    P,0\r
24067         MOVEI   B,-1(B)\r
24068         HLRZ    C,(TP)\r
24069         SUBI    B,(C)\r
24070         CAME    B,-1(P)\r
24071         JRST    EQTMP1\r
24072 \r
24073 EQTMP2: AOS     C,(P)\r
24074         SOSGE   -1(P)\r
24075         JRST    EQTMP3          ; WIN!!\r
24076 \r
24077         MOVE    B,-6(TP)        ; POINTER\r
24078         MOVE    0,-2(P)         ; GET MAGIC OFFSET\r
24079         PUSHJ   P,TM.TOE        ; GET OFFSET TO TEMPLATE\r
24080         ADD     A,TD.GET+1(TVP)\r
24081         MOVE    A,(A)\r
24082         ADDI    E,(A)\r
24083         XCT     (E)             ; VAL TO A AND B\r
24084         MOVEM   A,-3(TP)\r
24085         MOVEM   B,-2(TP)\r
24086         MOVE    C,(P)\r
24087         MOVE    B,-4(TP)        ; OTHER GUY\r
24088         MOVE    0,-2(P)\r
24089         PUSHJ   P,TM.TOE\r
24090         ADD     A,TD.GET+1(TVP)\r
24091         MOVE    A,(A)\r
24092         ADDI    E,(A)\r
24093         XCT     (E)             ; GET OTHER VALUE\r
24094         MOVEM   A,-1(TP)\r
24095         MOVEM   B,(TP)\r
24096         MOVEI   C,-3(TP)\r
24097         MOVEI   D,-1(TP)\r
24098         PUSHJ   P,IEQUAL        ; RECURSE\r
24099         JRST    EQTMP1          ; LOSER\r
24100         JRST    EQTMP2          ; WINNER\r
24101 \r
24102 EQTMP3: AOS     -3(P)           ; WIN RETURN\r
24103 EQTMP1: SUB     P,[3,,3]        ; FLUSH JUNK\r
24104 EQTMP4: SUB     TP,[10,,10]\r
24105         POPJ    P,\r
24106 \r
24107 \r
24108 \r
24109 EQVEC:  HLRE    A,1(C)          ;GET LENGTHS\r
24110         HLRZ    B,1(D)\r
24111         CAIE    B,(A)           ;SKIP IF EQUAL LENGTHS\r
24112         POPJ    P,              ;LOSE\r
24113         JUMPGE  A,CPOPJ1        ;SKIP RETRUN WIN\r
24114         PUSHJ   P,PUSHCD        ;SAVE ARGS\r
24115 \r
24116 EQVEC1: INTGO                   ;IN CASE LONG VECTOR\r
24117         MOVE    C,(TP)\r
24118         MOVE    D,-2(TP)        ;ARGS TO C AND D\r
24119         PUSHJ   P,IEQUAL\r
24120         JRST    EQLST3\r
24121         MOVE    C,[2,,2]        ;GET BUMPER\r
24122         ADDM    C,(TP)\r
24123         ADDB    C,-2(TP)        ;BUMP BOTH POINTERS\r
24124         JUMPL   C,EQVEC1\r
24125         JRST    EQLST2\r
24126 \r
24127 EQUVEC: HLRE    A,1(C)          ;GET LENGTHS\r
24128         HLRZ    B,1(D)\r
24129         CAIE    B,(A)           ;SKIP IF EQUAL\r
24130         POPJ    P,\r
24131 \r
24132         HRRZ    B,1(C)          ;START COMPUTING DOPE WORD LOCN\r
24133         SUB     B,A             ;B POINTS TO DOPE WORD\r
24134         GETYP   0,(B)           ;GET UNIFORM TYPE\r
24135         HRRZ    B,1(D)          ;NOW FIND OTHER DOPE WORD\r
24136         SUB     B,A\r
24137         HLRZ    B,(B)           ;OTHER UNIFORM TYPE\r
24138         CAIE    0,(B)           ;TYPES THE SAME?\r
24139         POPJ    P,              ;NO, LOSE\r
24140 \r
24141         JUMPGE  A,CPOPJ1        ;IF ZERO LENGTH ALREADY WON\r
24142 \r
24143         HRLZI   B,(B)           ;TYPE TO LH\r
24144         PUSH    P,B             ;AND SAVED\r
24145         PUSHJ   P,PUSHCD        ;SAVE ARGS\r
24146 \r
24147 EQUV1:  MOVEI   C,1(TP)         ;POINT TO WHERE WILL GO\r
24148         PUSH    TP,(P)\r
24149         MOVE    A,-3(TP)        ;PUSH ONE OF THE VECTORS\r
24150         PUSH    TP,(A)          ; PUSH ELEMENT\r
24151         MOVEI   D,1(TP)         ;POINT TO 2D ARG\r
24152         PUSH    TP,(P)\r
24153         MOVE    A,-3(TP)        ;AND PUSH ITS POINTER\r
24154         PUSH    TP,(A)\r
24155         PUSHJ   P,IEQUAL\r
24156         JRST    UNEQUV\r
24157 \r
24158         SUB     TP,[4,,4]       ;POP TP\r
24159         MOVE    A,[1,,1]\r
24160         ADDM    A,(TP)          ;BUMP POINTERS\r
24161         ADDB    A,-2(TP)\r
24162         JUMPL   A,EQUV1         ;JUMP IF STILL MORE STUFF\r
24163         SUB     P,[1,,1]        ;POP OFF TYPE\r
24164         JRST    EQLST2\r
24165 \r
24166 UNEQUV: SUB     P,[1,,1]\r
24167         SUB     TP,[10,,10]\r
24168         POPJ    P,\r
24169 \f\r
24170 \r
24171 \r
24172 EQCHST: HRRZ    B,(C)           ; GET LENGTHS\r
24173         HRRZ    A,(D)\r
24174         CAIE    A,(B)           ;SAME\r
24175         JRST    EQCHS3          ;NO, LOSE\r
24176         MOVE    C,1(C)\r
24177         MOVE    D,1(D)\r
24178         JUMPE   A,EQCHS4        ;BOTH 0 LENGTH, WINS\r
24179 \r
24180 EQCHS2:\r
24181         ILDB    0,C             ;GET NEXT CHARS\r
24182         ILDB    E,D\r
24183         CAIE    0,(E)           ; SKIP IF STILL WINNING\r
24184         JRST    EQCHS3          ; NOT =\r
24185         SOJG    A,EQCHS2\r
24186 \r
24187 EQCHS4: AOS     (P)\r
24188 EQCHS3: POPJ    P,\r
24189 \r
24190 PUSHCD: PUSH    TP,(C)\r
24191         PUSH    TP,1(C)\r
24192         PUSH    TP,(D)\r
24193         PUSH    TP,1(D)\r
24194         POPJ    P,\r
24195 \r
24196 \f\r
24197 ; REST/NTH/AT/PUT/GET\r
24198 \r
24199 ; ARG CHECKER\r
24200 \r
24201 ARGS1:  MOVE    E,[JRST WTYP2]  ; ERROR CONDITION FOR 2D ARG NOT FIXED\r
24202 ARGS2:  HLRE    0,AB            ; CHECK NO. OF ARGS\r
24203         ASH     0,-1            ; TO - NO. OF ARGS\r
24204         AOJG    0,TFA           ; 0--TOO FEW\r
24205         AOJL    0,TMA           ; MORE THAT 2-- TOO MANY\r
24206         MOVEI   C,1             ; DEFAULT ARG2\r
24207         JUMPN   0,ARGS4         ; GET STRUCTURED ARG\r
24208 ARGS3:  GETYP   A,2(AB)\r
24209         CAIE    A,TFIX          ; SHOULD BE FIXED NUMBER\r
24210         XCT     E               ; DO ERROR THING\r
24211         SKIPGE  C,3(AB)         ; BETTER BE NON-NEGATIVE\r
24212         JRST    OUTRNG\r
24213 ARGS4:  MOVEI   B,(AB)          ; POINT TO STRUCTURED POINTER\r
24214         PUSHJ   P,PTYPE         ; GET PRIM TYPE\r
24215         MOVEI   E,(A)           ; DISPATCH CODE TO E\r
24216         MOVE    A,(AB)          ; GET ARG 1\r
24217         MOVE    B,1(AB)\r
24218         POPJ    P,\r
24219 \r
24220 ; REST \r
24221 \r
24222 MFUNCTION REST,SUBR\r
24223 \r
24224         ENTRY\r
24225         PUSHJ   P,ARGS1         ; GET AND CHECK ARGS\r
24226         PUSHJ   P,@RESTBL(E)    ; DO IT BASED ON TYPE\r
24227         MOVE    C,A             ; THE FOLLOWING IS TO MAKE STORAGE WORK\r
24228         GETYP   A,(AB)\r
24229         PUSHJ   P,SAT\r
24230         CAIN    A,SSTORE        ; SKIP IF NOT STORAGE\r
24231         MOVSI   C,TSTORA        ; USE ITS PRIMTYPE\r
24232         MOVE    A,C\r
24233         JRST    FINIS\r
24234 \r
24235 PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]\r
24236 [PCHSTR,SREST],[PTMPLT,TMPRST]]\r
24237 \r
24238 ; AT\r
24239 \r
24240 MFUNCTION AT,SUBR\r
24241 \r
24242         ENTRY\r
24243         PUSHJ   P,ARGS1\r
24244         SOJL    C,OUTRNG\r
24245         PUSHJ   P,@ATTBL(E)\r
24246         JRST    FINIS\r
24247 \r
24248 PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
24249 [PCHSTR,STAT],[PTMPLT,TAT]]\r
24250 \r
24251 \f\r
24252 ; NTH\r
24253 \r
24254 MFUNCTION NTH,SUBR\r
24255 \r
24256         ENTRY\r
24257 \r
24258         PUSHJ   P,ARGS1\r
24259         SOJL    C,OUTRNG\r
24260         PUSHJ   P,@NTHTBL(E)\r
24261         JRST    FINIS\r
24262 \r
24263 PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]\r
24264 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
24265 \r
24266 ; GET\r
24267 \r
24268 MFUNCTION GET,SUBR\r
24269 \r
24270         ENTRY\r
24271         MOVE    E,IIGETP        ; MAKE ARG CHECKER FAIL INTO GETPROP\r
24272         PUSHJ   P,ARGS5         ; CHECK ARGS\r
24273         SOJL    C,OUTRNG\r
24274         SKIPN   E,IGETBL(E)     ; GET DISPATCH ADR\r
24275         JRST    IGETP           ; REALLY PUTPROP\r
24276         JUMPE   0,TMA\r
24277         PUSHJ   P,(E)           ; DISPATCH\r
24278         JRST    FINIS\r
24279 \r
24280 PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]\r
24281 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
24282 \r
24283 ; GETL\r
24284 \r
24285 MFUNCTION GETL,SUBR\r
24286 \r
24287         ENTRY\r
24288         MOVE    E,IIGETL        ; ERROR HACK\r
24289         PUSHJ   P,ARGS5\r
24290         SOJL    C,OUTRNG        ; LOSER\r
24291         SKIPN   E,IGTLTB(E)\r
24292         JRST    IGETLO          ; REALLY GETPL\r
24293         JUMPE   0,TMA\r
24294         PUSHJ   P,(E)           ; DISPATCH\r
24295         JRST    FINIS\r
24296 \r
24297 IIGETL: JRST    IGETLO\r
24298 \r
24299 PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
24300 [PCHSTR,STAT]]\r
24301 \r
24302 \r
24303 ; ARG CHECKER FOR PUT/GET/GETL\r
24304 \r
24305 ARGS5:  HLRE    0,AB            ; -# OF ARGS\r
24306         ASH     0,-1\r
24307         ADDI    0,2             ; 0 OR -1 WIN\r
24308         JUMPG   0,TFA\r
24309         AOJL    0,TMA           ; MORE THAN 3\r
24310         JRST    ARGS3           ; GET ARGS\r
24311 \f\r
24312 ; PUT\r
24313 \r
24314 MFUNCTION PUT,SUBR\r
24315 \r
24316         ENTRY\r
24317         MOVE    E,IIPUTP\r
24318         PUSHJ   P,ARGS5         ; GET ARGS\r
24319         SKIPN   E,IPUTBL(E)\r
24320         JRST    IPUTP\r
24321         CAML    AB,[-5,,]       ; SKIP IF GOOD ARRGS\r
24322         JRST    TFA\r
24323         SOJL    C,OUTRNG\r
24324         PUSH    TP,4(AB)\r
24325         PUSH    TP,5(AB)\r
24326         PUSHJ   P,(E)\r
24327         MOVE    A,(AB)          ; RET STRUCTURE\r
24328         MOVE    B,1(AB)\r
24329         JRST    FINIS\r
24330 \r
24331 PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]\r
24332 [PCHSTR,SPUT],[PTMPLT,TMPPUT]]\r
24333 \r
24334 ; IN\r
24335 \r
24336 MFUNCTION IN,SUBR\r
24337 \r
24338         ENTRY   1\r
24339 \r
24340         MOVEI   B,(AB)          ; POINT TO ARG\r
24341         PUSHJ   P,PTYPE\r
24342         MOVS    E,A             ; REAL DISPATCH TO E\r
24343         MOVE    B,1(AB)\r
24344         MOVE    A,(AB)\r
24345         GETYP   C,A             ; IN CASE NEEDED\r
24346         PUSHJ   P,@INTBL(E)\r
24347         JRST    FINIS\r
24348 \r
24349 PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]\r
24350 [PCHSTR,SIN],[PTMPLT,TIN]]\r
24351 \r
24352 OTHIN:  CAIE    C,TLOCN         ; ASSOCIATION LOCATIVE\r
24353         JRST    OTHIN1          ; MAYBE LOCD\r
24354         HLLZ    0,VAL(B)\r
24355         PUSHJ   P,RMONCH\r
24356         MOVE    A,VAL(B)\r
24357         MOVE    B,VAL+1(B)\r
24358         POPJ    P,\r
24359 \r
24360 OTHIN1: CAIE    C,TLOCD\r
24361         JRST    WTYP1\r
24362         JRST    VIN\r
24363 \r
24364 \f\r
24365 ; SETLOC\r
24366 \r
24367 MFUNCTION SETLOC,SUBR\r
24368 \r
24369         ENTRY   2\r
24370 \r
24371         MOVEI   B,(AB)          ; POINT TO ARG\r
24372         PUSHJ   P,PTYPE         ; DO TYPE\r
24373         MOVS    E,A             ; REAL TYPE\r
24374         MOVE    B,1(AB)\r
24375         MOVE    C,2(AB)         ; PASS ARG\r
24376         MOVE    D,3(AB)\r
24377         MOVE    A,(AB)          ; IN CASE\r
24378         GETYP   0,A\r
24379         PUSHJ   P,@SETTBL(E)\r
24380         MOVE    A,2(AB)\r
24381         MOVE    B,3(AB)\r
24382         JRST    FINIS\r
24383 \r
24384 PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]\r
24385 [PCHSTR,SSTUF],[PTMPLT,TSTUF]]\r
24386 \r
24387 OTHSET: CAIE    0,TLOCN         ; ASSOC?\r
24388         JRST    OTHSE1\r
24389         HLLZ    0,VAL(B)        ; GET MONITORS\r
24390         PUSHJ   P,MONCH\r
24391         MOVEM   C,VAL(B)\r
24392         MOVEM   D,VAL+1(B)\r
24393         POPJ    P,\r
24394 \r
24395 OTHSE1: CAIE    0,TLOCD\r
24396         JRST    WTYP1\r
24397         JRST    VSTUF\r
24398 \r
24399 ; LREST  -- REST A LIST IN B BY AMOUNT IN C\r
24400 \r
24401 LREST:  MOVSI   A,TLIST\r
24402         JUMPE   C,CPOPJ\r
24403         MOVEM   A,BSTO(PVP)\r
24404 \r
24405 LREST2: INTGO                   ;CHECK INTERRUPTS\r
24406         JUMPE   B,OUTRNG        ; CANT CDR NIL\r
24407         HRRZ    B,(B)           ;CDR THE LIST\r
24408         SOJG    C,LREST2        ;COUNT DOWN\r
24409         SETZM   BSTO(PVP)       ;RESET BSTO\r
24410         POPJ    P,\r
24411 \r
24412 \f\r
24413 ; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK\r
24414 \r
24415 VREST:  SKIPA   A,$TVEC         ; FINAL TYPE\r
24416 AREST:  HRLI    A,TARGS\r
24417         ASH     C,1             ; TIMES 2\r
24418         JRST    UREST1\r
24419 \r
24420 ; UREST  -- REST A UVECTOR\r
24421 \r
24422 STORST: SKIPA   A,$TSTORA\r
24423 UREST:  MOVSI   A,TUVEC\r
24424 UREST1: JUMPE   C,CPOPJ\r
24425         HRLI    C,(C)\r
24426         JUMPL   C,OUTRNG\r
24427         ADD     B,C             ; REST IT\r
24428         CAILE   B,-1            ; OUT OF RANGE ?\r
24429         JRST    OUTRNG\r
24430         POPJ    P,\r
24431 \r
24432 \r
24433 ; SREST -- REST A STRING\r
24434 \r
24435 SREST:  JUMPE   C,SREST1\r
24436         PUSH    P,A             ; SAVE TYPE WORD\r
24437         PUSH    P,C             ; SAVE AMOUNT\r
24438         MOVEI   D,(A)           ; GET LENGTH\r
24439         CAILE   C,(D)           ; SKIP IF OK\r
24440         JRST    OUTRNG\r
24441         LDB     D,[366000,,B]   ;POSITION FIELD OF BYTE POINTER\r
24442         LDB     A,[300600,,B]   ;SIZE FIELD\r
24443         PUSH    P,A             ;SAVE SIZE\r
24444         IDIVI   D,(A)           ;COMPUT BYTES IN 1ST WORD\r
24445         MOVEI   0,36.           ;NOW COMPUTE BYTES PER WORD\r
24446         IDIVI   0,(A)           ;BYTES PER WORD IN 0\r
24447         MOVE    E,0             ;COPY OF BYTES PER WORD TO E\r
24448         SUBI    0,(D)           ;0 # OF UNSUED BYTES IN 1ST WORD\r
24449         ADDB    C,0             ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY\r
24450         IDIVI   C,(E)           ;C/ REL WORD D/ CHAR IN LAST\r
24451         ADDI    C,(B)           ;POINTO WORD WITH C\r
24452         POP     P,A             ;RESTORE BITS PER BYTE\r
24453         IMULI   A,(D)           ;A/ BITS USED IN LAST WORD\r
24454         MOVEI   0,36.\r
24455         SUBI    0,(A)           ;0 HAS NEW POSITION FIELD\r
24456         DPB     0,[360600,,B]   ;INTO BYTE POINTER\r
24457         HRRI    B,(C)           ;POINT TO RIGHT WORD\r
24458         POP     P,C             ; RESTORE AMOUNT\r
24459         POP     P,A\r
24460         SUBI    A,(C)           ; NEW LENGTH\r
24461 SREST1: HRLI    A,TCHSTR\r
24462         POPJ    P,\r
24463 \r
24464 ; TMPRST -- REST A TEMPLATE DATA STRUCTURE\r
24465 \r
24466 TMPRST: PUSHJ   P,TM.TOE        ; CHECK ALL BOUNDS ETC.\r
24467         MOVSI   D,(D)\r
24468         HLL     C,D\r
24469         MOVE    B,C             ; RET IN B\r
24470         MOVSI   A,TTMPLT\r
24471         POPJ    P,\r
24472 \r
24473 ; LAT  --  GET A LOCATIVE TO A LIST\r
24474 \r
24475 LAT:    PUSHJ   P,LREST         ; GET POINTER\r
24476         JUMPE   B,OUTRNG        ; YOU LOSE!\r
24477         MOVSI   A,TLOCL         ; NEW TYPE\r
24478         POPJ    P,\r
24479 \r
24480 \f\r
24481 ; UAT  --  GET A LOCATIVE TO A UVECTOR\r
24482 \r
24483 UAT:    PUSHJ   P,UREST \r
24484         MOVSI   A,TLOCU\r
24485         JRST    POPJL\r
24486 \r
24487 ; VAT  --  GET A LOCATIVE TO A VECTOR\r
24488 \r
24489 VAT:    PUSHJ   P,VREST         ; REST IT AND TYPE IT\r
24490         MOVSI   A,TLOCV\r
24491         JRST    POPJL\r
24492 \r
24493 ; AAT  --  GET A LOCATIVE TO AN ARGS BLOCK\r
24494 \r
24495 AAT:    PUSHJ   P,AREST\r
24496         HRLI    A,TLOCA\r
24497 POPJL:  JUMPGE  B,OUTRNG        ; LOST\r
24498         POPJ    P,\r
24499 \r
24500 ; STAT  --  LOCATIVE TO A STRING\r
24501 \r
24502 STAT:   PUSHJ   P,SREST\r
24503         TRNN    A,-1            ; SKIP IF ANY LEFT\r
24504         JRST    OUTRNG\r
24505         HRLI    A,TLOCS         ; LOCATIVE\r
24506         POPJ    P,\r
24507 \r
24508 ; TAT -- LOCATIVE TO A TEMPLATE\r
24509 \r
24510 TAT:    PUSHJ   P,TMPRST\r
24511         PUSH    TP,A\r
24512         PUSH    TP,B\r
24513         GETYP   A,(B)           ; GET REAL SAT\r
24514         SUBI    A,NUMSAT+1\r
24515         HRLS    A               ; READY TO HIT TABLE\r
24516         ADD     A,TD.LNT+1(TVP)\r
24517         JUMPGE  A,BADTPL\r
24518         MOVE    C,B             ; DATUM TO C\r
24519         XCT     (A)             ; GET LENGTH\r
24520         HLRZS   C               ; REST COUNTER\r
24521         SUBI    B,(C)           ; FLUSH IT OFF\r
24522         JUMPE   B,OUTRNG\r
24523         MOVE    B,(TP)\r
24524         SUB     TP,[2,,2]\r
24525         MOVSI   A,TLOCT\r
24526         POPJ    P,\r
24527         \r
24528 \r
24529 ; LNTH  --  NTH OF LIST\r
24530 \r
24531 LNTH:   PUSHJ   P,LAT\r
24532 LNTH1:  PUSHJ   P,RMONC0        ; CHECK READ MONITORS\r
24533         HLLZ    A,(B)           ; GET GOODIE\r
24534         MOVE    B,1(B)\r
24535         JSP     E,CHKAB         ; HACK DEFER\r
24536         POPJ    P,\r
24537 \r
24538 ; VNTH  --  NTH A VECTOR, ANTH  --  NTH AN ARGS BLOCK\r
24539 \r
24540 ANTH:   PUSHJ   P,AAT\r
24541         JRST    .+2\r
24542 \r
24543 VNTH:   PUSHJ   P,VAT\r
24544 AIN:\r
24545 VIN:    PUSHJ   P,RMONC0\r
24546         MOVE    A,(B)\r
24547         MOVE    B,1(B)\r
24548         POPJ    P,\r
24549 \r
24550 ; UNTH  --  NTH OF UVECTOR\r
24551 \r
24552 UNTH:   PUSHJ   P,UAT\r
24553 UIN:    HLRE    C,B             ; FIND DW\r
24554         SUBM    B,C\r
24555         HLLZ    0,(C)           ; GET MONITORS\r
24556         MOVE    D,0\r
24557         TLZ     D,TYPMSK#<-1>\r
24558         PUSH    P,D\r
24559         PUSHJ   P,RMONCH        ; CHECK EM\r
24560         POP     P,A\r
24561         MOVE    B,(B)           ; AND VALUE\r
24562         POPJ    P,\r
24563 \r
24564 \f\r
24565 ; SNTH  --  NTH A STRING\r
24566 \r
24567 SNTH:   PUSHJ   P,STAT\r
24568 SIN:    PUSH    TP,A\r
24569         PUSH    TP,B            ; SAVE POINT BYTER\r
24570         MOVEI   C,-1(TP)        ; FIND DOPE WORD\r
24571         PUSHJ   P,BYTDOP\r
24572         HLLZ    0,-1(A)         ; GET \r
24573         POP     TP,B\r
24574         POP     TP,A\r
24575         PUSHJ   P,RMONCH\r
24576         ILDB    B,B             ; GET CHAR\r
24577         MOVSI   A,TCHRS\r
24578         POPJ    P,\r
24579 \r
24580 ; TIN -- IN OF A TEMPLATE\r
24581 \r
24582 TIN:    MOVEI   C,0\r
24583 \r
24584 ; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE\r
24585 \r
24586 TMPLNT: ADDI    C,1\r
24587         PUSHJ   P,TM.TOE        ; GET POINTER TO INS IN E\r
24588         ADD     A,TD.GET+1(TVP) ; POINT TO GETTER\r
24589         MOVE    A,(A)           ; GET VECTOR OF INS\r
24590         ADDI    E,-1(A)         ; POINT TO INS\r
24591         SUBI    D,1\r
24592         XCT     (E)             ; DO IT\r
24593         POPJ    P,              ; RETURN\r
24594 \r
24595 ; LPUT  --  PUT ON A LIST\r
24596 \r
24597 LPUT:   PUSHJ   P,LAT           ; POSITION\r
24598         POP     TP,D\r
24599         POP     TP,C\r
24600 \r
24601 ; LSTUF -- HERE TO STUFF A LIST ELEMENT\r
24602 \r
24603 LSTUF:  PUSHJ   P,MONCH0        ; CHECK OUT MONITOR BITS\r
24604         GETYP   A,C             ; ISOLATE TYPE\r
24605         PUSHJ   P,NWORDT        ; NEED TO DEFER?\r
24606         SOJN    A,DEFSTU\r
24607         HLLM    C,(B)   \r
24608         MOVEM   D,1(B)          ; AND VAL\r
24609         POPJ    P,\r
24610 \r
24611 DEFSTU: PUSH    TP,$TLIST\r
24612         PUSH    TP,B\r
24613         PUSH    TP,C\r
24614         PUSH    TP,D\r
24615         PUSHJ   P,CELL2         ; GET WORDS\r
24616         POP     TP,1(B)\r
24617         POP     TP,(B)\r
24618         MOVE    E,(TP)\r
24619         SUB     TP,[2,,2]\r
24620         MOVEM   B,1(E)\r
24621         HLLZ    0,(E)           ; GET OLD MONITORS\r
24622         TLZ     0,TYPMSK        ; KILL TYPES\r
24623         TLO     0,TDEFER        ; MAKE DEFERRED\r
24624         HLLM    0,(E)\r
24625         POPJ    P,\r
24626 \r
24627 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK\r
24628 \r
24629 APUT:   PUSHJ   P,AAT\r
24630         JRST    .+2\r
24631 \r
24632 VPUT:   PUSHJ   P,VAT           ; TREAT LIKE VECTOR\r
24633         POP     TP,D            ; GET GOODIE BACK\r
24634         POP     TP,C\r
24635 \r
24636 ; AVSTUF --  CLOBBER ARGS AND VECTORS\r
24637 \r
24638 ASTUF:\r
24639 VSTUF:  PUSHJ   P,MONCH0\r
24640         MOVEM   C,(B)\r
24641         MOVEM   D,1(B)\r
24642         POPJ    P,\r
24643 \r
24644 \f\r
24645 \r
24646 \r
24647 ; UPUT  --  CLOBBER A UVECTOR\r
24648 \r
24649 UPUT:   PUSHJ   P,UAT           ; GET IT RESTED\r
24650         POP     TP,D\r
24651         POP     TP,C\r
24652 \r
24653 ; USTUF -- HERE TO CLOBBER A UVECTOR\r
24654 \r
24655 USTUF:  HLRE    E,B\r
24656         SUBM    B,E             ; C POINTS TO DOPE\r
24657         GETYP   A,(E)           ; GET UTYPE\r
24658         GETYP   0,C\r
24659         CAIE    0,(A)           ; CHECK SAMENESS\r
24660         JRST    WRNGUT\r
24661         HLLZ    0,(E)           ; MONITOR BITS IN DOPE WORD\r
24662         MOVSI   A,TUVEC\r
24663         PUSHJ   P,MONCH\r
24664         MOVEM   D,(B)           ; SMASH\r
24665         POPJ    P,\r
24666 \r
24667 ; SPUT -- HERE TO PUT A STRING\r
24668 \r
24669 SPUT:   PUSHJ   P,STAT          ; REST IT\r
24670         POP     TP,D\r
24671         POP     TP,C\r
24672 \r
24673 ; SSTUF -- STUFF A STRING\r
24674 \r
24675 SSTUF:  GETYP   0,C             ; BETTER BE CHAR\r
24676         CAIE    0,TCHRS\r
24677         JRST    WTYP3\r
24678         PUSH    TP,A\r
24679         PUSH    TP,B\r
24680         MOVEI   C,-1(TP)        ; FIND D.W.\r
24681         PUSHJ   P,BYTDOP\r
24682         HLLZ    0,(A)-1         ; GET MONITORS\r
24683         POP     TP,B\r
24684         POP     TP,A\r
24685         MOVSI   C,TCHRS\r
24686         PUSHJ   P,MONCH\r
24687         IDPB    D,B             ; STASH\r
24688         POPJ    P,\r
24689 \r
24690 ; TSTUF -- SETLOC A TEMPLATE\r
24691 \r
24692 TSTUF:  PUSH    TP,C\r
24693         PUSH    TP,D\r
24694         MOVEI   C,0\r
24695 \r
24696 ; PUTTMP -- TEMPLATE PUTTER\r
24697 \r
24698 TMPPUT: ADDI    C,1\r
24699         PUSHJ   P,TM.TOE        ; GET E POINTING TO SLOT #\r
24700         ADD     A,TD.PUT+1(TVP) ; POINT TO INS\r
24701         MOVE    A,(A)           ; GET VECTOR OF INS\r
24702         ADDI    E,-1(A)\r
24703         POP     TP,B            ; NEW VAL TO A AND B\r
24704         POP     TP,A\r
24705         SUBI    D,1\r
24706         XCT     (E)             ; DO IT\r
24707         JRST    BADPUT\r
24708         POPJ    P,\r
24709 \r
24710 TM.LN1: SUBI    0,NUMSAT+1\r
24711         HRRZ    A,0             ; RET FIXED OFFSET\r
24712         HRLS    0\r
24713         ADD     0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST\r
24714         JUMPGE  0,BADTPL\r
24715         PUSH    P,C\r
24716         MOVE    C,B\r
24717         HRRZS   0               ; POINT TO TABLE ENTRY\r
24718         PUSH    P,A\r
24719         XCT     @0              ; DO IT\r
24720         POP     P,A\r
24721         POP     P,C\r
24722         POPJ    P,\r
24723 \r
24724 TM.TBL: MOVEI   E,(D)           ; TENTATIVE WINNER IN E\r
24725         TLNN    B,-1            ; SKIP IF REST HAIR EXISTS\r
24726         POPJ    P,              ; NO, WIN\r
24727 \r
24728         PUSH    P,A             ; SAVE OFFSET\r
24729         HRLS    A               ; A IS REL OFFSET TO INS TABLE\r
24730         ADD     A,TD.GET+1(TVP) ; GET ONEOF THE TABLES\r
24731         MOVE    A,(A)           ; TABLE POINTER TO A\r
24732         MOVSI   0,-1(D)         ; START SEEING IF PAST TEMP SPEC\r
24733         ADD     0,A\r
24734         JUMPL   0,CPOPJA        ; JUMP IF E STILL VALID\r
24735         HLRZ    E,B             ; BASIC LENGTH TO E\r
24736         HLRE    0,A             ; LENGTH OF TEMPLATE TO 0\r
24737         ADDI    0,(E)           ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE\r
24738         MOVNS   0\r
24739         SUBM    D,E             ; E ==> # PAST BASIC WANTED\r
24740         EXCH    0,E\r
24741         IDIVI   0,(E)           ; A ==> REL REST GUY WANTED\r
24742         HLRZ    E,B\r
24743         ADDI    E,1(A)\r
24744 CPOPJA: POP     P,A\r
24745         POPJ    P,\r
24746 \r
24747 ; TM.TOE -- GET RIGHT TEMPLATE # IN E\r
24748 ; C/ OBJECT #, B/ OBJECT POINTER\r
24749 \r
24750 TM.TOE: GETYP   0,(B)           ; GET REAL SAT\r
24751         MOVEI   D,(C)           ; OBJ # TO D\r
24752         HLRZ    C,B             ; REST COUNT\r
24753         ADDI    D,(C)           ; FUDGE FOR REST COUNTER\r
24754         MOVE    C,B             ; POINTER TO C\r
24755         PUSHJ   P,TM.LN1        ; GET LENGTH IN B (WATCH LH!)\r
24756         CAILE   D,(B)           ; CHECK RANGE\r
24757         JRST    OUTRNG          ; LOSER, QUIT\r
24758         JRST    TM.TBL          ; GO COMPUTE TABLE OFFSET\r
24759                 \r
24760 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B\r
24761 ; FIXES (P)\r
24762 \r
24763 CPTYEE: MOVE    E,A\r
24764         GETYP   A,A\r
24765         PUSHJ   P,CPTYPE\r
24766         JUMPE   A,COMPERR\r
24767         SUBM    M,-1(P)\r
24768         EXCH    E,A\r
24769         POPJ    P,\r
24770 \r
24771 ; COMPILER CALLS TO MANY OF THESE GUYS\r
24772 \r
24773 CIREST: PUSHJ   P,CPTYEE        ; TYPE OF DISP TO E\r
24774         JUMPL   C,OUTRNG\r
24775         CAIN    0,SSTORE\r
24776         JRST    CIRST1\r
24777         PUSHJ   P,@RESTBL(E)\r
24778         JRST    MPOPJ\r
24779 \r
24780 CIRST1: PUSHJ   P,STORST\r
24781         JRST    MPOPJ\r
24782 \r
24783 CINTH:  PUSHJ   P,CPTYEE\r
24784         SOJL    C,OUTRNG        ; CHECK BOUNDS\r
24785         PUSHJ   P,@NTHTBL(E)\r
24786         JRST    MPOPJ\r
24787 \r
24788 CIAT:   PUSHJ   P,CPTYEE\r
24789         SOJL    C,OUTRNG\r
24790         PUSHJ   P,@ATTBL(E)\r
24791         JRST    MPOPJ\r
24792 \r
24793 CSETLO: PUSHJ   P,CTYLOC\r
24794         MOVSS   E               ; REAL DISPATCH\r
24795         GETYP   0,A             ; INCASE LOCAS OR LOCD\r
24796         PUSH    TP,C\r
24797         PUSH    TP,D\r
24798         PUSHJ   P,@SETTBL(E)\r
24799         POP     TP,B\r
24800         POP     TP,A\r
24801         JRST    MPOPJ\r
24802 \r
24803 CIN:    PUSHJ   P,CTYLOC\r
24804         MOVSS   E               ; REAL DISPATCH\r
24805         GETYP   C,A\r
24806         PUSHJ   P,@INTBL(E)\r
24807         JRST    MPOPJ\r
24808 \r
24809 CTYLOC: MOVE    E,A\r
24810         GETYP   A,A\r
24811         PUSHJ   P,CPTYPE\r
24812         SUBM    M,-1(P)\r
24813         EXCH    A,E\r
24814         POPJ    P,\r
24815 \r
24816 ; COMPILER'S PUT,GET AND GETL\r
24817 \r
24818 CIGET:  PUSH    P,[0]\r
24819         JRST    .+2\r
24820 \r
24821 CIGETL: PUSH    P,[1]\r
24822         MOVE    E,A\r
24823         GETYP   A,A\r
24824         PUSHJ   P,CPTYPE\r
24825         EXCH    A,E\r
24826         JUMPE   E,CIGET1        ; REAL GET, NOT NTH\r
24827         GETYP   0,C             ; INDIC FIX?\r
24828         CAIE    0,TFIX\r
24829         JRST    CIGET1\r
24830         POP     P,E             ; GET FLAG\r
24831         AOS     (P)             ; ALWAYS SKIP\r
24832         MOVE    C,D             ; # TO AN AC\r
24833         JRST    @.+1(E)\r
24834                 CINTH\r
24835                 CIAT\r
24836 \r
24837 CIGET1: POP     P,E             ; GET FLAG\r
24838         JRST    @GETTR(E)       ; DO A REAL GET\r
24839 \r
24840 GETTR:          CIGTPR\r
24841                 CIGETP\r
24842 \r
24843 CIPUT:  SUBM    M,(P)\r
24844         MOVE    E,A\r
24845         GETYP   A,A\r
24846         PUSHJ   P,CPTYPE\r
24847         EXCH    A,E\r
24848         PUSH    TP,-1(TP)               ; PAIN AND SUFFERING\r
24849         PUSH    TP,-1(TP)\r
24850         MOVEM   A,-3(TP)\r
24851         MOVEM   B,-2(TP)\r
24852         JUMPE   E,CIPUT1\r
24853         GETYP   0,C\r
24854         CAIE    0,TFIX          ; YES DO STRUCT\r
24855         JRST    CIPUT1\r
24856         MOVE    C,D\r
24857         SOJL    C,OUTRNG        ; CHECK BOUNDS\r
24858         PUSHJ   P,@IPUTBL(E)\r
24859 PMPOPJ: POP     TP,B\r
24860         POP     TP,A\r
24861         JRST    MPOPJ\r
24862 \r
24863 CIPUT1: PUSHJ   P,IPUT\r
24864         JRST    PMPOPJ\r
24865 \f\r
24866 ; SMON -- SET MONITOR BITS\r
24867 ;       B/ <POINTER TO LOCATIVE>\r
24868 ;       D/ <IORM> OR <ANDCAM>\r
24869 ;       E/ BITS\r
24870 \r
24871 SMON:   GETYP   A,(B)\r
24872         PUSHJ   P,PTYPE         ; TO PRIM TYPE\r
24873         HLRZS   A\r
24874         SKIPE   A,SMONTB(A)     ; DISPATCH?\r
24875         JRST    (A)\r
24876 \r
24877 ; COULD STILL BE LOCN OR LOCD\r
24878 \r
24879         GETYP   A,(B)           ; TYPE BACK\r
24880         CAIE    A,TLOCN\r
24881         JRST    SMON2           ; COULD BE LOCD\r
24882         MOVE    C,1(B)          ; POINT\r
24883         HRRI    D,VAL(C)        ; MAKE INST POINT\r
24884         JRST    SMON3\r
24885 \r
24886 SMON2:  CAIE    A,TLOCD\r
24887         JRST    WRONGT\r
24888 \r
24889 \r
24890 ; SET LIST/TUPLE/ID LOCATIVE\r
24891 \r
24892 SMON4:  HRR     D,1(B)          ; POINT TO TYPE WORD\r
24893 SMON3:  XCT     D\r
24894         POPJ    P,\r
24895 \r
24896 ; SET UVEC LOC\r
24897 \r
24898 SMON5:  HRRZ    C,1(B)          ; POINT TO TOP OF UV\r
24899         HLRE    0,1(B)\r
24900         SUB     C,0             ; POINT TO DOPE\r
24901         HRRI    D,(C)           ; POINT IN INST\r
24902         JRST    SMON3\r
24903 \r
24904 ; SET CHSTR LOC\r
24905 \r
24906 SMON6:  MOVEI   C,(B)           ; FOR BYTDOP\r
24907         PUSHJ   P,BYTDOP        ; POINT TO DOPE\r
24908         HRRI    D,(A)-1\r
24909         JRST    SMON3\r
24910 \r
24911 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]\r
24912 [PNWORD,SMON5],[PCHSTR,SMON6]]\r
24913 \r
24914 \f\r
24915 ; COMPILER'S MONAD?\r
24916 \r
24917 CIMON:  PUSH    P,A\r
24918         GETYP   A,A\r
24919         PUSHJ   P,CPTYPE\r
24920         JUMPE   A,CIMON1\r
24921         POP     P,A\r
24922         JRST    CEMPTY\r
24923 \r
24924 CIMON1: POP     P,A\r
24925         JRST    YES\r
24926 \r
24927 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE\r
24928 \r
24929 MFUNCTION MONAD,SUBR,MONAD?\r
24930 \r
24931         ENTRY   1\r
24932 \r
24933         MOVE    B,AB            ; CHECK PRIM TYPE\r
24934         PUSHJ   P,PTYPE\r
24935         JUMPE   A,ITRUTH                ;RETURN ARGUMENT\r
24936         SKIPE   B,1(AB)\r
24937         JRST    @MONTBL(A)      ;DISPATCH ON PTYPE\r
24938         JRST    ITRUTH\r
24939 \r
24940 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]\r
24941 [PCHSTR,CHMON],[PTMPLT,TMPMON]]\r
24942 \r
24943 MON1:   JUMPGE  B,ITRUTH                ;EMPTY VECTOR\r
24944         JRST    IFALSE\r
24945 \r
24946 CHMON:  HRRZ    B,(AB)\r
24947         JUMPE   B,ITRUTH\r
24948         JRST    IFALSE\r
24949 \r
24950 TMPMON: PUSHJ   P,LNTMPL\r
24951         JUMPE   B,ITRUTH\r
24952         JRST    IFALSE\r
24953 \r
24954 CISTRU: GETYP   A,A             ; COMPILER CALL\r
24955         PUSHJ   P,ISTRUC\r
24956         JRST    NO\r
24957         JRST    YES\r
24958 \r
24959 ISTRUC: PUSHJ   P,SAT           ; STORAGE TYPE\r
24960         SKIPE   A,PRMTYP(A)\r
24961         AOS     (P)             ; SKIP IF WINS\r
24962         POPJ    P,\r
24963 \r
24964 ; SUBR TO CHECK FOR LOCATIVE\r
24965 \r
24966 MFUNCTION %LOCA,SUBR,[LOCATIVE?]\r
24967 \r
24968         ENTRY   1\r
24969         GETYP   A,(AB)  \r
24970         PUSHJ   P,LOCQQ\r
24971         JRST    IFALSE\r
24972         JRST    ITRUTH\r
24973 \r
24974 ; SKIPS IF TYPE IN A IS A LOCATIVE\r
24975 \r
24976 LOCQ:   GETYP   A,(B)           ; GET TYPE\r
24977 LOCQQ:  PUSH    P,A             ; SAVE FOR LOCN/LOCD\r
24978         PUSHJ   P,SAT\r
24979         MOVE    A,PRMTYP(A)\r
24980         JUMPE   A,LOCQ1\r
24981         SUB     P,[1,,1]\r
24982         TRNN    A,-1\r
24983 LOCQ2:  AOS     (P)\r
24984         POPJ    P,\r
24985 \r
24986 LOCQ1:  POP     P,A             ; RESTORE TYPE\r
24987         CAIE    A,TLOCN\r
24988         CAIN    A,TLOCD\r
24989         JRST    LOCQ2\r
24990         POPJ    P,\r
24991 \r
24992 \f\r
24993 ; MUDDLE SORT ROUTINE\r
24994 \r
24995 ; P-STACK OFFSETS MUDDLE SORT ROUTINE\r
24996 \r
24997 ; P-STACK OFFSETS FOR THIS PROGRAM\r
24998 \r
24999 XCHNG==0                ; FLAG SAYING AN EXCHANGE HAS HAPPENED\r
25000 PLACE==-1               ; WHERE WE ARE NOW\r
25001 UTYP==-2                ; TYPE OF UNIFORM VECTOR\r
25002 DELT==-3                ; DIST BETWEEN COMPARERS\r
25003 \r
25004 MFUNCTION SORT,SUBR\r
25005 \r
25006         ENTRY\r
25007 \r
25008         HLRZ    0,AB            ; CHECK FOR ENOUGH ARGS\r
25009         CAILE   0,-4\r
25010         JRST    TFA\r
25011         GETYP   A,(AB)          ; 1ST MUST EITHER BE FALSE OR APPLICABLE\r
25012         CAIN    A,TFALSE\r
25013         JRST    SORT1           ; FALSE, OK\r
25014         PUSHJ   P,APLQ          ; IS IT APPLICABLE\r
25015         JRST    NAPT            ; NO, LOSER\r
25016 \r
25017 SORT1:  MOVE    B,AB\r
25018         ADD     B,[2,,2]        ; BUMP TO POINT TO MAIN ARRAY\r
25019         SETZB   D,E             ; 0 # OF STUCS AND LNTH\r
25020 \r
25021 SORT2:  GETYP   A,(B)           ; GET ITS TYPE\r
25022         PUSHJ   P,PTYPE         ; IS IT STRUCTURED?\r
25023         MOVEI   C,1             ; CHECK TYPE OF STRUC\r
25024         CAIN    A,PNWORD        ; UVEC?\r
25025         MOVEI   C,0             ; YUP\r
25026         CAIE    A,PARGS\r
25027         CAIN    A,P2NWORD       ; VECTOR\r
25028         MOVNI   C,1\r
25029         JUMPG   C,WTYP\r
25030         PUSH    TP,(B)          ; PUSH IT\r
25031         PUSH    TP,1(B)\r
25032         ADD     B,[2,,2]        ; GO ON\r
25033         MOVEI   A,1             ; DEFAULT REC SIZE\r
25034         PUSHJ   P,NXFIX         ; SIZE OF RECORD?\r
25035         HLRZ    0,-2(TP)        ; -LNTH OF STUC\r
25036         HRRZ    A,(TP)          ; LENGTH OF REC\r
25037         IDIVI   0,(A)           ; DIV TO GET - # OF RECS\r
25038         SKIPN   D               ; PREV LENGTH EXIST?\r
25039         MOVE    D,0             ; NO USE THIS\r
25040         CAME    0,D\r
25041         JRST    SLOSE0\r
25042         MOVEI   A,0             ; DEF REC SIZE\r
25043         PUSHJ   P,NXFIX         ; AND OFFSET OF KEY\r
25044         SUBI    E,1\r
25045         JUMPL   B,SORT2         ; GO ON\r
25046         HRRM    E,4(TB)         ; SAVE THAT IN APPROPRIATE PLACE\r
25047 \r
25048         MOVE    0,3(TB)\r
25049         CAMG    0,5(TB)         ; CHECK FOR BAD OFFSET\r
25050         JRST    SLOSE3\r
25051 \r
25052 ; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS\r
25053 \r
25054         HLRE    B,1(TB)         ; COMP LENGTH\r
25055         MOVNS   B\r
25056         HRRZ    C,2(TB)         ; GET VEC/UVEC FLAG\r
25057         MOVEI   D,(B)\r
25058         ASH     B,(C)           ; FUDGE\r
25059         JUMPE   C,.+3           ; SKIP FOR UVEC\r
25060         MOVE    0,[1,,1]        ; ELSE FUDGE KEY OFFSET\r
25061         ADDM    0,5(TB)\r
25062         HRRZ    0,3(TB)         ; GET REC LENGTH\r
25063         IDIV    D,0             ; # OF RECS\r
25064         JUMPN   E,SLOSE4\r
25065         CAIG    D,1             ; MORE THAN 1?\r
25066         JRST    SORTD           ; NO, DONE ALREADY\r
25067         GETYP   0,(AB)          ; TYPE OF COMPARER\r
25068         CAIE    0,TFALSE        ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING\r
25069         JRST    SORT3           ; USER SUPPLIED COMPARER, LET HIM WORRY\r
25070 \r
25071 ; NOW CHECK OUT ELEMENT TYPES\r
25072 \r
25073         JUMPN   C,SORT5         ; JUMP IF GENERAL\r
25074         MOVEI   D,1(B)          ; FIND END OF VECTOR\r
25075         ADD     D,1(TB)         ; D POINTS TO END\r
25076         PUSHJ   P,TYPCH1        ; GET TYPE AND CHECK IT\r
25077         JRST    SORT6\r
25078 \r
25079 SORT5:  MOVE    D,1(TB)         ; POINT TO VEC\r
25080         ADD     D,5(TB)         ; INTO REC TO KEY\r
25081         PUSHJ   P,TYPCH1\r
25082 \r
25083 SAMELP: GETYP   C,-1(D)         ; GET TYPE\r
25084         CAIE    0,(C)           ; COMPARE TYPE\r
25085         JRST    SLOSE2\r
25086         ADD     D,3(TB)         ; TO NEXT RECORD\r
25087         JUMPL   D,SAMELP\r
25088 \r
25089 SORT6:  CAIE    A,S1WORD        ; 1 WORDS?\r
25090         JRST    SORT7\r
25091         MOVEI   E,INTSRT\r
25092         MOVSI   A,400000        ; SET UP MASK\r
25093 SORT9:  PUSHJ   P,ISORT\r
25094         MOVE    A,2(AB)\r
25095         MOVE    B,3(AB)\r
25096         JRST    FINIS\r
25097 \r
25098 SORT7:  CAIE    A,SATOM         ; ATOMS?\r
25099         JRST    SORT8\r
25100         MOVE    E,[-3,,ATMSRT]  ; SET UP FOR ATOMS\r
25101         MOVE    A,[430140,,3(D)]        ; BIT POINTER FOR ATOMS\r
25102         JRST    SORT9\r
25103 \r
25104 SORT8:  MOVE    E,[1,,STRSRT]   ; MUST BE STRING SORT\r
25105         MOVE    A,[430140,,(D)] ; BYTE POINTER FOR STRINGER\r
25106         JRST    SORT9\r
25107 \r
25108 ; TABLES FOR RADIX SORT CHECKERS\r
25109 \r
25110 INTSRT==0\r
25111 ATMSRT==1\r
25112 STRSRT==2\r
25113 \r
25114 TST1:   PUSHJ   P,I.TST1\r
25115         PUSHJ   P,A.TST1\r
25116         PUSHJ   P,S.TST1\r
25117 \r
25118 TST2:   PUSHJ   P,I.TST2\r
25119         PUSHJ   P,A.TST2\r
25120         PUSHJ   P,S.TST2\r
25121 \r
25122 NXBIT:  ROT     A,-1\r
25123         PUSHJ   P,A.NXBI\r
25124         PUSHJ   P,S.NXBI\r
25125 \r
25126 PREBIT: ROT     A,1\r
25127         PUSHJ   P,A.PREB\r
25128         PUSHJ   P,S.PREB\r
25129 \r
25130 ENDTST: SKIPGE  A\r
25131         TLOE    A,40\r
25132         TLOE    A,40\r
25133 \r
25134 ; INTEGER SORT SPECIFIC ROUTINES\r
25135 \r
25136 I.TST1: JUMPL   A,I.TST3\r
25137 I.TST4: TDNE    A,(D)\r
25138         AOS     (P)\r
25139         POPJ    P,\r
25140 \r
25141 I.TST2: JUMPL   A,I.TST4\r
25142 I.TST3: TDNN    A,(D)\r
25143         AOS     (P)\r
25144         POPJ    P,\r
25145 \r
25146 ; ATOM SORT SPECIFIC ROUTINES\r
25147 \r
25148 A.TST1: MOVE    D,(D)           ; GET AN ATOM\r
25149         CAMG    E,D             ; SKIP IF NOT EXHAUSTED\r
25150         POPJ    P,\r
25151         TLZ     A,40            ; TELL A BIT HAS HAPPENED\r
25152         LDB     D,A             ; GET THE BIT\r
25153         SKIPE   D\r
25154         AOS     (P)             ; SKIP IF ON\r
25155         POPJ    P,\r
25156 \r
25157 A.TST2: PUSHJ   P,A.TST1        ; USE OTHER ROUTINE\r
25158         AOS     (P)\r
25159         POPJ    P,\r
25160 \r
25161 A.NXBI: TLNN    A,770000        ; CHECK FOR WORD CHANGE\r
25162         SUB     E,[1,,0]        ; FIX WORD CHECKER\r
25163         IBP     A\r
25164         POPJ    P,\r
25165 \r
25166 A.PREB: ADD     A,[10000,,]     ; AH FOR A DECR BYTE POINTER\r
25167         SKIPG   A\r
25168         CAMG    A,[437777,,-1]  ; SKIP IF BACKED OVER WORD\r
25169         POPJ    P,\r
25170         TLZ     A,770000        ; CLOBBER POSIT FIELD\r
25171         SUBI    A,1             ; DECR WORD POS FIELD\r
25172         ADD     E,[1,,0]        ; AND FIX WORD HACKER\r
25173         POPJ    P,\r
25174 \r
25175 ; STRING SPECIFIC SORT ROUTINES\r
25176 \r
25177 S.TST1: HRLZ    0,-1(D)         ; LENGTH OF STRING\r
25178         IMULI   0,7             ; IN BITS\r
25179         HRRI    0,-1            ; MAKE SURE BIGGER RH\r
25180         CAMG    0,E             ; SKIP IF MORE BITS LEFT\r
25181         POPJ    P,              ; DON TSKIP\r
25182         TLZ     A,40            ; BIT FOUND\r
25183         HLRZ    0,(D)           ; CHECK FOR SIMPLE CASE\r
25184         HRRZ    D,(D)           ; POINT TO STRING\r
25185         CAIN    0,440700        ; SKIP IF HAIRY\r
25186         JRST    S.TST3\r
25187 \r
25188         PUSH    P,A             ; SAVE BYTER\r
25189         MOVEI   A,440700        ; COMPUTE BITS NOT USED 1ST WORD\r
25190         SUBI    A,@0\r
25191         HLRZ    0,(P)           ; GET BIT POINTER\r
25192         SUBI    0,(A)           ; UPDATE POS FIELD\r
25193         JUMPGE  0,.+2           ; NO NEED FOR NEXT WORD\r
25194         ADD     0,[1,,440000]\r
25195         MOVSS   0\r
25196         HRRZ    A,(P)   ; REBUILD BYTE POINTER\r
25197         ADDI    0,(A)\r
25198         LDB     0,0             ; GET THE DAMN BYTE\r
25199         POP     P,A\r
25200         JRST    .+2\r
25201 \r
25202 S.TST3: LDB     0,A             ; GET BYTE FOR EASY CASE\r
25203         SKIPE   0\r
25204         AOS     (P)\r
25205         POPJ    P,\r
25206 \r
25207 S.TST2: PUSHJ   P,S.TST1\r
25208         AOS     (P)\r
25209         POPJ    P,\r
25210 \r
25211 S.NXBI: IBP     A               ; BUMP BYTER\r
25212         TLNN    A,770000        ; SKIP IF NOT END BIT\r
25213         IBP     A               ; SKIP END BIT (NOT USED IN ASCII STRINGS)\r
25214         ADD     E,[1,,0]        ; COUNT BIT\r
25215         POPJ    P,\r
25216 \r
25217 S.PREB: SUB     E,[1,,0]        ; DECR CHAR COUNT\r
25218         ADD     A,[10000,,0]    ; PLEASE GIVE ME A DECRBYTEPNTR\r
25219         SKIPG   A\r
25220         CAMG    A,[437777,,-1]\r
25221         POPJ    P,\r
25222         TLC     A,450000        ; POINT TO LAST USED BIT IN WORD\r
25223         SUBI    A,1\r
25224         POPJ    P,\r
25225 \r
25226 ; SIMPLE RADIX EXCHANGE\r
25227 \r
25228 ISORT:  MOVE    B,1(TB)         ; START OF VECTOR\r
25229         HLRE    D,B             ; COMPUTE POINTER TO END OF IT\r
25230         SUBM    B,D             ; FIND END\r
25231         MOVEI   C,(D)\r
25232 \r
25233 ISORT1: PUSH    TP,(TB)\r
25234         PUSH    TP,C\r
25235         MOVE    0,C             ; SEE IF HAVE MET AT MIDDLE\r
25236         SUB     0,3(TB)\r
25237         ANDI    0,-1\r
25238         CAIGE   0,(B)\r
25239         JRST    ISORT7          ; HAVE MET, LEAVE\r
25240         PUSH    TP,(TB)         ; SAVE OTHER POINTER\r
25241         PUSH    TP,B\r
25242 \r
25243         INTGO\r
25244         MOVE    B,(TP)          ; IN CASE MOVED\r
25245         MOVE    C,-2(TP)\r
25246 \r
25247 ISORT3: HRRZ    D,5(TB)         ; OFFSET TO KEY\r
25248         ADDI    D,(B)           ; POINT TO KEY\r
25249         XCT     TST1(E)         ; CHECK FOR LOSER\r
25250         JRST    ISORT4\r
25251         SUB     C,3(TB)         ; IS THERE ONE TO EXCHANGE WITH\r
25252         HRRZ    D,5(TB)\r
25253         ADDI    D,(C)\r
25254         XCT     TST2(E)         ; SKIP IF A POSSIBLE EXCHANGE\r
25255         JRST    ISORT2          ; NO EXCH, KEEP LOOKING\r
25256 \r
25257         PUSHJ   P,EXCHM         ; DO THE EXCHANGE\r
25258 \r
25259 ISORT4: ADD     B,3(TB)         ; HAVE EXCHANGED, MOVE ON\r
25260 ISORT2: CAME    B,C             ; MET?\r
25261         JRST    ISORT3          ; MORE TO CHECK\r
25262         XCT     NXBIT(E)        ; NEXT BIT\r
25263         MOVE    B,(TP)          ; RESTORE TOP POINTER\r
25264         SUB     TP,[2,,2]       ; FLUSH IT\r
25265         XCT     ENDTST(E)\r
25266         JRST    ISORT6\r
25267         PUSHJ   P,ISORT1        ; SORT SUB AREA\r
25268         MOVE    C,(TP)          ; AND OTHER SUB AREA\r
25269         PUSHJ   P,ISORT1\r
25270 ISORT6: XCT     PREBIT(E)\r
25271 ISORT7: MOVE    B,(TP)\r
25272         SUB     TP,[2,,2]\r
25273         POPJ    P,\r
25274 \r
25275 ; SCHELL SORT FOR USER SUPPLIED COMPARER\r
25276 \r
25277 SORT3:  ADDI    D,1\r
25278         ASH     D,-1            ; COMPUTE INITIAL D\r
25279         PUSH    P,D             ; AND SAVE IT\r
25280         PUSH    P,[0]           ; MAY HOLD UTYPE OF VECTOR\r
25281         HRRZ    0,(TB)          ; 0 NON ZERO MEANS GEN VECT\r
25282         JUMPN   0,SSORT1        ; DONT COMPUTE UTYPE\r
25283         HLRE    C,1(TB)\r
25284         HRRZ    D,1(TB)         ; FIND TYPE\r
25285         SUBI    D,(C)\r
25286         GETYP   D,(D)\r
25287         MOVSM   D,(P)           ; AND SAVE\r
25288 SSORT1: PUSH    P,[0]           ; CURRENT PLACE IN VECTOR\r
25289         PUSH    P,[0]           ; EXCHANGE FLAG\r
25290         PUSH    TP,[0]\r
25291         PUSH    TP,[0]\r
25292 \r
25293 ; OUTER LOOP STARTS HERE\r
25294 \r
25295 OUTRLP: SETZM   XCHNG(P)        ; NO EXHCANGE YET\r
25296         SETZM   PLACE(P)\r
25297 \r
25298 INRLP:  PUSH    TP,(AB)         ; PUSH USER COMPARE FCN\r
25299         PUSH    TP,1(AB)\r
25300         MOVE    C,PLACE(P)      ; GET CURRENT PLACE\r
25301         ADD     C,1(TB)         ; ADD POINTER TO VEC IN\r
25302         ADD     C,5(TB)         ; OFFSET TO KEY\r
25303         PUSHJ   P,GETELM\r
25304         MOVE    D,3(TB)\r
25305         IMUL    D,DELT(P)       ; TIMES WORDS PER REC\r
25306         ADD     C,D\r
25307         PUSHJ   P,GETELM\r
25308         MCALL   3,APPLY         ; APPLY IT\r
25309         GETYP   0,A             ; TYPE OF RETURN\r
25310         CAIN    0,TFALSE        ; SKIP IF MUST CHANGE\r
25311         JRST    INRLP1\r
25312 \r
25313         MOVE    C,1(TB)         ; POINT TO START\r
25314         ADD     C,PLACE(P)\r
25315         MOVE    B,3(TB)\r
25316         IMUL    B,DELT(P)\r
25317         ADD     B,C\r
25318         PUSHJ   P,EXCHM         ; EXCHANGE THEM\r
25319         SETOM   XCHNG(P)        ; SAY AN EXCHANGE TOOK PLACE\r
25320 \r
25321 INRLP1: MOVE    C,3(TB)         ; GET OFFSET\r
25322         ADDB    C,PLACE(P)\r
25323         MOVE    D,3(TB)\r
25324         IMUL    D,DELT(P)\r
25325         ADD     C,D             ; CHECK FOR OVERFLOW\r
25326         ADD     C,1(TB)\r
25327         JUMPL   C,INRLP\r
25328         SKIPE   XCHNG(P)        ; ANY EXCHANGES?\r
25329         JRST    OUTRLP          ; YES, RESET PLACE AND GO\r
25330         SOSG    D,DELT(P)       ; SKIP IF DIST WAS 1\r
25331         JRST    SORTD\r
25332         ADDI    D,2             ; COMPUTE NEW DIST\r
25333         ASH     D,-1\r
25334         MOVEM   D,DELT(P)\r
25335         JRST    OUTRLP\r
25336 \r
25337 SORTD:  MOVE    A,2(AB)         ; DONE, RET 1ST STRUC\r
25338         MOVE    B,3(AB)\r
25339         JRST    FINIS\r
25340 \r
25341 ; ROUTINE TO GET NEXT ARG IF ITS FIX\r
25342 \r
25343 NXFIX:  JUMPGE  B,NXFIX1        ; NONE LEFT, USE DEFAULT\r
25344         GETYP   0,(B)           ; TYPE\r
25345         CAIE    0,TFIX          ; FIXED?\r
25346         JRST    NXFIX1          ; NO, USE DEFAULT\r
25347         MOVE    A,1(B)          ; GET THE NUMBER\r
25348         ADD     B,[2,,2]        ; BUMP TO NEXT ARG\r
25349 NXFIX1: HRLI    C,TFIX\r
25350         TRNE    C,-1            ; SKIP IF UV\r
25351         ASH     A,1             ; FUDGE FOR VEC/UVEC\r
25352         HRLI    A,(A)\r
25353         PUSH    TP,C\r
25354         PUSH    TP,A\r
25355         POPJ    P,\r
25356 \r
25357 GETELM: SKIPN   A,UTYP-1(P)     ; SKIP IF UVECT\r
25358         MOVE    A,-1(C)         ; GGET GEN TYPE\r
25359         PUSH    TP,A\r
25360         PUSH    TP,(C)\r
25361         POPJ    P,\r
25362 \r
25363 TYPCH1: GETYP   A,-1(D)         ; GET TYPE\r
25364         MOVEI   0,(A)           ; SAVE IN 0\r
25365         PUSHJ   P,SAT           ; AND SAT\r
25366         CAIE    A,SCHSTR        ; STRING\r
25367         CAIN    A,SATOM\r
25368         POPJ    P,\r
25369         CAIN    A,S1WORD        ; 1-WORD GOODIE\r
25370         POPJ    P,\r
25371         JRST    SLOSE1\r
25372 \r
25373 ; HERE TO DO EXCHANGE\r
25374 \r
25375 EXCHM:  PUSH    P,E\r
25376         PUSH    P,A             ; SAVE VITAL ACS\r
25377         PUSH    P,B\r
25378         PUSH    P,C\r
25379         SUB     B,1(TB)         ; COMPUTE RECORD #\r
25380         HLRZS   B               ; TO RH\r
25381         HRRZ    0,3(TB)         ; GET REC LENGTH\r
25382         IDIV    B,0             ; DIV BY REC LENGTH\r
25383         MOVE    C,(P)\r
25384         SUB     C,1(TB)         ; SAME FOR C\r
25385         HLRZS   C\r
25386         IDIV    C,0             ; NOW HAVE OTHER RECORD\r
25387 \r
25388         HRRE    D,4(TB)         ; - # OF STUCS\r
25389         MOVSI   D,(D)           ; MAKE AN AOBJN POINTER\r
25390         HRRI    D,(TB)          ; TO TEMPPS\r
25391 \r
25392 RECLP:  HRRZ    0,3(D)          ; GET REC LENGTH\r
25393         MOVN    E,3(D)          ; NOW AOBJN TO REC\r
25394         MOVSI   E,(E)\r
25395         HRR     E,1(D)\r
25396         MOVEI   A,(C)           ; COMP START OF REC\r
25397         IMUL    A,0             ; TIMES REC LENGTH\r
25398         ADDI    E,(A)\r
25399         MOVEI   A,(B)\r
25400         IMUL    A,0\r
25401         ADD     A,1(D)          ; POINT TO OTHER RECORD\r
25402 \r
25403 EXCHLP: EXCH    0,(A)\r
25404         EXCH    0,(E)\r
25405         EXCH    0,(A)\r
25406         ADDI    A,1\r
25407         AOBJN   E,EXCHLP\r
25408 \r
25409         ADD     D,[1,,6]        ; TO NEXT STRUC\r
25410         JUMPL   D,RECLP         ; IF MORE\r
25411 \r
25412         POP     P,C\r
25413         POP     P,B\r
25414         POP     P,A\r
25415         POP     P,E\r
25416         POPJ    P,\r
25417 \f\r
25418 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS\r
25419 \r
25420 MFUNCTION MEMBER,SUBR\r
25421 \r
25422         MOVE    E,[PUSHJ P,EQLTST]      ;TEST ROUTINE IN E\r
25423         JRST    MEMB\r
25424 \r
25425 MFUNCTION MEMQ,SUBR\r
25426 \r
25427         MOVE    E,[PUSHJ P,EQTST]       ;EQ TESTER\r
25428 \r
25429 MEMB:   ENTRY   2\r
25430         MOVE    B,AB            ;POINT TO FIRST ARG\r
25431         PUSHJ   P,PTYPE         ;CHECK PRIM TYPE\r
25432         ADD     B,[2,,2]        ;POINT TO 2ND ARG\r
25433         PUSHJ   P,PTYPE\r
25434         JUMPE   A,WTYP2         ;2ND WRONG TYPE\r
25435         PUSH    TP,(AB)\r
25436         PUSH    TP,1(AB)\r
25437         MOVE    C,2(AB)         ; FOR TUPLE CASE\r
25438         SKIPE   B,3(AB)         ;GOBBLE LIST VECTOR ETC. POINTER\r
25439         PUSHJ   P,@MEMTBL(A)    ;DISPATCH\r
25440         JRST    IFALSE          ;OR REPORT LOSSAGE\r
25441         JRST    FINIS\r
25442 \r
25443 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]\r
25444 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]]\r
25445 \r
25446 \r
25447 \r
25448 MEMLST: MOVSI   0,TLIST         ;SET B'S TYPE TO LIST\r
25449         MOVEM   0,BSTO(PVP)\r
25450         JUMPE   B,MEMLS6        ; EMPTY LIST LOSE IMMEDIATE\r
25451 \r
25452 MEMLS1: INTGO                   ;CHECK INTERRUPTS\r
25453         MOVEI   C,(B)           ;COPY POINTER\r
25454         GETYP   D,(C)           ;GET TYPE\r
25455         MOVSI   A,(D)           ;COPY\r
25456         CAIE    D,TDEFER                ;DEFERRED?\r
25457         JRST    MEMLS2\r
25458         MOVE    C,1(C)          ;GET DEFERRED DATUM\r
25459         GETYPF  A,(C)           ;GET FULL TYPE WORD\r
25460 MEMLS2: MOVE    C,1(C)          ;GET DATUM\r
25461         XCT     E               ;DO THE COMPARISON\r
25462         JRST    MEMLS3          ;NO MATCH\r
25463         MOVSI   A,TLIST\r
25464 MEMLS5: AOS     (P)\r
25465 MEMLS6: SETZM   BSTO(PVP)               ;RESET B'S TYPE\r
25466         POPJ    P,\r
25467 \r
25468 MEMLS3: HRRZ    B,(B)           ;STEP THROGH\r
25469         JUMPN   B,MEMLS1        ;STILL MORE TO DO\r
25470 MEMLS4: MOVSI   A,TFALSE        ;RETURN FALSE\r
25471         JRST    MEMLS6          ;RETURN 0\r
25472 \r
25473 MEMTUP: HRRZ    A,C\r
25474         TLOA    A,TARGS\r
25475 MEMVEC: MOVSI   A,TVEC          ;CLOBBER B'S TYPE TO VECTOR\r
25476         JUMPGE  B,MEMLS4        ;EMPTY VECTOR\r
25477         MOVEM   A,BSTO(PVP)\r
25478 \r
25479 MEMV1:  INTGO                   ;CHECK FOR INTS\r
25480         GETYPF  A,(B)           ;GET FULL TYPE\r
25481         MOVE    C,1(B)          ;AND DATA\r
25482         XCT     E               ;DO COMPARISON INS\r
25483         JRST    MEMV2           ;NOT EQUAL\r
25484         MOVE    A,BSTO(PVP)\r
25485         JRST    MEMLS5          ;RETURN WITH POINTER\r
25486 \f\r
25487 MEMV2:  ADD     B,[2,,2]        ;INCREMENT AND GO\r
25488         JUMPL   B,MEMV1         ;STILL WINNING\r
25489 MEMV3:  MOVEI   B,0\r
25490         JRST    MEMLS4          ;AND RETURN FALSE\r
25491 \r
25492 MUVEC:  JUMPGE  B,MEMLS4\r
25493         GETYP   A,-1(TP)        ;GET TYPE OF GODIE\r
25494         HLRE    C,B             ;LOOK FOR UNIFORM TYPE\r
25495         SUBM    B,C             ;DOPE POINTER TO C\r
25496         GETYP   C,(C)           ;GET THE TYPE\r
25497         CAIE    A,(C)           ;ARE THEY THE SAME?\r
25498         JRST    MEMLS4          ;NO, LOSE\r
25499         MOVSI   A,TUVEC\r
25500         CAIN    0,SSTORE\r
25501         MOVSI   A,TSTORA\r
25502         PUSH    P,A\r
25503         MOVEM   A,BSTO(PVP)\r
25504         MOVSI   A,(C)           ;TYPE TO LH\r
25505         PUSH    P,A             ; SAVE FOR EACH TEST\r
25506 \r
25507 MUVEC1: INTGO                   ;CHECK OUT INTS\r
25508         MOVE    C,(B)           ;GET DATUM\r
25509         MOVE    A,(P)           ; GET TYPE\r
25510         XCT     E               ;COMPARE\r
25511         AOBJN   B,MUVEC1        ;LOOP TO WINNAGE\r
25512         SUB     P,[1,,1]\r
25513         POP     P,A\r
25514         JUMPGE  B,MEMV3         ;LOSE RETURN\r
25515 \r
25516 MUVEC2: JRST    MEMLS5\r
25517 \r
25518 \r
25519 MEMCH:  GETYP   A,-1(TP)                ;IS ARG A SINGLE CHAR\r
25520         CAIE    A,TCHRS         ;SKIP IF POSSIBLE WINNER\r
25521         JRST    MEMSTR\r
25522         MOVEI   0,(C)\r
25523         MOVE    D,(TP)          ; AND CHAR\r
25524 \r
25525 MEMCH1: SOJL    0,MEMV3\r
25526         MOVE    E,B\r
25527         ILDB    A,B\r
25528         CAIE    A,(D)           ;CHECK IT\r
25529         SOJA    C,MEMCH1\r
25530 \r
25531 MEMCH2: MOVE    B,E\r
25532         MOVE    A,C\r
25533         JRST    MEMLS5\r
25534 \r
25535 MEMSTR: CAME    E,[PUSHJ P,EQLTST]\r
25536         JRST    MEMV3\r
25537         HLRZ    A,C\r
25538         CAIE    A, TCHSTR       ; A SHOULD HAVE TCHSTR IN RIGHT HALF\r
25539         JRST    MEMV3\r
25540         MOVEI   0,(C)           ; GET # OF CHAR INTO 0\r
25541         ILDB    D,(TP)\r
25542         PUSH    P,D             ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK\r
25543 \r
25544 MEMST1: SOJL    0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR\r
25545         MOVE    E,B\r
25546         ILDB    A,B\r
25547         CAME    A,(P)\r
25548         SOJA    C,MEMST1        ; MATCH FAILS TRY NEXT\r
25549 \r
25550         PUSH    P,B\r
25551         PUSH    P,E\r
25552         PUSH    P,C\r
25553         PUSH    P,0\r
25554         MOVE    E,(TP)          ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP\r
25555         HRRZ    C,-1(TP)        ; LENGTH OF 1ARG\r
25556 MEMST2: SOJE    C,MEMWN         ; WON -RAN OUT OF 1ARG FIRST-\r
25557         SOJL    MEMLSR          ; LOST -RAN OUT OF 2ARG-\r
25558         ILDB    A,B\r
25559         ILDB    D,E\r
25560         CAIN    A,(D)           ; SKP IF POSSIBLY LOST -BACK TO MEMST1-\r
25561         JRST    MEMST2\r
25562 \r
25563         POP     P,0\r
25564         POP     P,C\r
25565         POP     P,E\r
25566         POP     P,B\r
25567         SOJA    C,MEMST1\r
25568 \r
25569 MEMWN:  MOVE    B,-2(P)         ; SETS UP ARGS LIKE MEMCH2 - HAVE WON\r
25570         MOVE    A,-1(P)\r
25571         SUB     P,[5,,5]\r
25572         JRST    MEMLS5\r
25573 \r
25574 MEMLSR: SUB     P,[5,,5]\r
25575         JRST    MEMV3\r
25576 \r
25577 MEMLS:  SUB     P,[1,,1]\r
25578         JRST    MEMV3\r
25579 \r
25580 ; MEMBERSHIP FOR TEMPLATE HACKER\r
25581 \r
25582 MEMTMP: GETYP   0,(B)           ; GET REAL SAT\r
25583         PUSH    P,E\r
25584         PUSH    P,0\r
25585         PUSH    TP,A\r
25586         PUSH    TP,B            ; SAVE GOOEIE\r
25587         PUSHJ   P,TM.LN1        ; GET LENGTH\r
25588         MOVEI   B,(B)\r
25589         HLRZ    A,(TP)          ; FUDGE FOR REST\r
25590         SUBI    B,(A)\r
25591         PUSH    P,B             ; SAVE LENGTH\r
25592         PUSH    P,[-1]\r
25593         POP     TP,B\r
25594         POP     TP,A\r
25595         MOVEM   A,BSTO+1(PVP)\r
25596 \r
25597 MEMTM1: SETZM   BSTO(PVP)\r
25598         AOS     C,(P)\r
25599         SOSGE   -1(P)\r
25600         JRST    MEMTM2\r
25601         MOVE    0,-2(P)\r
25602         PUSHJ   P,TMPLNT        ; GET ITEM\r
25603         EXCH    C,B             ; VALUE TO C, POINTER BACK TO B\r
25604         MOVE    E,-3(P)\r
25605         MOVSI   0,TTMPLT\r
25606         MOVEM   0,BSTO(PVP)\r
25607         XCT     E\r
25608         JRST    MEMTM1\r
25609 \r
25610         HRL     B,(P)           ; DO APPROPRIATE REST\r
25611         AOS     -4(P)\r
25612 MEMTM2: SUB     P,[4,,4]\r
25613         MOVSI   A,TTMPLT\r
25614         SETZM   BSTO(PVP)\r
25615         POPJ    P,\r
25616 \r
25617 EQTST:  GETYP   A,A\r
25618         GETYP   0,-1(TP)\r
25619         CAMN    C,(TP)          ;CHECK VALUE\r
25620         CAIE    0,(A)           ;AND TYPE\r
25621         POPJ    P,\r
25622         JRST    CPOPJ1\r
25623 \r
25624 EQLTST: PUSH    TP,BSTO(PVP)\r
25625         PUSH    TP,B\r
25626         PUSH    TP,A\r
25627         PUSH    TP,C\r
25628         SETZM   BSTO(PVP)\r
25629         PUSH    P,E             ;SAVE INS\r
25630         MOVEI   C,-5(TP)        ;SET UP CALL TO IEQUAL\r
25631         MOVEI   D,-1(TP)\r
25632         AOS     -1(P)           ;ASSUME SKIP\r
25633         PUSHJ   P,IEQUAL        ;GO INO EQUAL\r
25634         SOS     -1(P)           ;UNDO SKIP\r
25635         SUB     TP,[2,,2]       ;AND POOP OF CRAP\r
25636         POP     TP,B\r
25637         POP     TP,BSTO(PVP)\r
25638         POP     P,E\r
25639         POPJ    P,\r
25640 \r
25641 ; COMPILER MEMQ AND MEMBER\r
25642 \r
25643 CIMEMB: SKIPA   E,[PUSHJ P,EQLTST]\r
25644 \r
25645 CIMEMQ: MOVE    E,[PUSHJ P,EQTST]\r
25646         SUBM    M,(P)\r
25647         PUSH    TP,A\r
25648         PUSH    TP,B\r
25649         GETYP   A,C\r
25650         PUSHJ   P,CPTYPE\r
25651         JUMPE   A,COMPERR\r
25652         MOVE    B,D             ; STRUCT TO B\r
25653         PUSHJ   P,@MEMTBL(A)\r
25654         TDZA    0,0             ; FLAG NO SKIP\r
25655         MOVEI   0,1             ; FLAG SKIP\r
25656         SUB     TP,[2,,2]\r
25657         JUMPE   0,NOM\r
25658         SOS     (P)             ; SKIP RETURN\r
25659         JRST    MPOPJ\r
25660 \f\r
25661 \r
25662 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR\r
25663 \r
25664 MFUNCTION TOP,SUBR\r
25665 \r
25666         ENTRY   1\r
25667 \r
25668         MOVE    B,AB            ;CHECK ARG\r
25669         PUSHJ   P,PTYPE\r
25670         MOVEI   E,(A)\r
25671         MOVE    A,(AB)\r
25672         MOVE    B,1(AB)\r
25673         PUSHJ   P,@TOPTBL(E)    ;DISPATCH\r
25674         JRST    FINIS\r
25675 \r
25676 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]\r
25677 [PTMPLT,BCKTOP]]\r
25678 \r
25679 BCKTOP: MOVEI   B,(B)           ; FIX UP POINTER\r
25680         MOVSI   A,TTMPLT\r
25681         POPJ    P,\r
25682 \r
25683 UVTOP:  SKIPA   A,$TUVEC\r
25684 VTOP:   MOVSI   A,TVEC\r
25685         CAIN    0,SSTORE\r
25686         MOVSI   A,TSTORA\r
25687         HLRE    C,B             ;AND -LENGTH\r
25688         HRRZS   B\r
25689         SUB     B,C             ;POINT TO DOPE WORD\r
25690         HLRZ    D,1(B)          ;TOTAL LENGTH\r
25691         SUBI    B,-2(D)         ;POINT TO TOP\r
25692         MOVNI   D,-2(D)         ;-LENGTH\r
25693         HRLI    B,(D)           ;B NOW POINTS TO TOP\r
25694         POPJ    P,\r
25695 \r
25696 CHTOP:  PUSH    TP,A\r
25697         PUSH    TP,B\r
25698         LDB     0,[360600,,(TP)]        ; POSITION FIELD\r
25699         LDB     E,[300600,,(TP)]        ; AND SIZE FILED\r
25700         IDIVI   0,(E)           ; 0/ BYTES IN 1ST WORD\r
25701         MOVEI   C,36.           ; BITS PER WORD\r
25702         IDIVI   C,(E)           ; BYTES PER WORD\r
25703         PUSH    P,C\r
25704         SUBM    C,0             ; UNUSED BYTES I 1ST WORD\r
25705         ADD     0,-1(TP)        ; LENGTH OF WORD BOUNDARIED STRING\r
25706         MOVEI   C,-1(TP)        ; GET DOPE WORD\r
25707         PUSHJ   P,BYTDOP\r
25708         HLRZ    C,(A)           ; GET LENGTH\r
25709         SUBI    A,-1(C)         ;  START +1\r
25710         MOVEI   B,(A)           ; SETUP BYTER\r
25711         HRLI    B,440000\r
25712         SUB     A,(TP)          ; WORDS DIFFERENT\r
25713         IMUL    A,(P)           ; CHARS EXTRA\r
25714         SUBM    0,A             ; FINAL TOTAL TO A\r
25715         HRLI    A,TCHSTR\r
25716         POP     P,C\r
25717         DPB     E,[300600,,B]\r
25718         SUB     TP,[2,,2]\r
25719         POPJ    P,\r
25720 \f\r
25721 \r
25722 \r
25723 ATOP:\r
25724 \r
25725 GETATO: HLRE    C,B             ;GET -LENGTH\r
25726         HRROS   B\r
25727         SUB     B,C             ;POINT PAST\r
25728         GETYP   0,(B)           ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)\r
25729         CAIN    0,TENTRY                ;IF ENTRY\r
25730         JRST    EASYTP          ;WANT UNEVALUATED ARGS\r
25731         HRRE    C,(B)           ;ELSE-- GET NO. OF ARGS (*-2)\r
25732         SUBI    B,(C)           ;GO TO TOP\r
25733         TLCA    B,-1(C)         ;STORE NUMBER IN TOP POINTER\r
25734 EASYTP: MOVE    B,FRAMLN+ABSAV(B)       ;GET ARG POINTER\r
25735         HRLI    A,TARGS\r
25736         POPJ    P,\r
25737 \r
25738 ; COMPILERS ENTRY TO TOP\r
25739 \r
25740 CITOP:  PUSHJ   P,CPTYEE\r
25741         CAIN    E,P2WORD        ; LIST?\r
25742         JRST    COMPERR\r
25743         PUSHJ   P,@TOPTBL(E)\r
25744         JRST    MPOPJ\r
25745 \r
25746 ; FUNCTION TO CLOBBER THE CDR OF A LIST\r
25747 \r
25748 MFUNCTION PUTREST,SUBR,[PUTREST]\r
25749         ENTRY   2\r
25750 \r
25751         MOVE    B,AB            ;COPY ARG POINTER\r
25752         PUSHJ   P,PTYPE         ;CHECK IT\r
25753         CAIE    A,P2WORD        ;LIST?\r
25754         JRST    WTYP1           ;NO, LOSE\r
25755         ADD     B,[2,,2]        ;AND NEXT ONE\r
25756         PUSHJ   P,PTYPE\r
25757         CAIE    A,P2WORD\r
25758         JRST    WTYP2           ;NOT LIST, LOSE\r
25759         HRRZ    B,1(AB)         ;GET FIRST\r
25760         MOVE    D,3(AB)         ;AND 2D LIST\r
25761         CAIL    B,HIBOT\r
25762         JRST    PURERR\r
25763         HRRM    D,(B)           ;CLOBBER\r
25764         MOVE    A,(AB)          ;RETURN CALLED TYPE\r
25765         JRST    FINIS\r
25766 \r
25767 \f\r
25768 \r
25769 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING\r
25770 \r
25771 MFUNCTION BACK,SUBR\r
25772 \r
25773         ENTRY\r
25774 \r
25775         MOVEI   C,1             ;ASSUME BACKING UP ONE\r
25776         JUMPGE  AB,TFA          ;NO ARGS IS TOO FEW\r
25777         CAML    AB,[-2,,0]      ;SKIP IF MORE THAN 2 ARGS\r
25778         JRST    BACK1           ;ONLY ONE ARG\r
25779         GETYP   A,2(AB)         ;GET TYPE\r
25780         CAIE    A,TFIX          ;MUST BE FIXED\r
25781         JRST    WTYP2\r
25782         SKIPGE  C,3(AB)         ;GET NUMBER\r
25783         JRST    OUTRNG\r
25784         CAMGE   AB,[-4,,0]      ;SKIP IF WINNING NUMBER OF ARGS\r
25785         JRST    TMA\r
25786 BACK1:  MOVE    B,AB            ;SET UP TO FIND TYPE\r
25787         PUSHJ   P,PTYPE         ;GET PRIM TYPE\r
25788         MOVEI   E,(A)\r
25789         MOVE    A,(AB)\r
25790         MOVE    B,1(AB)         ;GET DATUM\r
25791         PUSHJ   P,@BCKTBL(E)\r
25792         JRST    FINIS\r
25793 \r
25794 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]\r
25795 [PTMPLT,BCKTMP]]\r
25796 \r
25797 BACKV:  LSH     C,1             ;GENERAL, DOUBLE AMOUNT\r
25798         SKIPA   A,$TVEC\r
25799 BACKU:  MOVSI   A,TUVEC\r
25800         CAIN    0,SSTORE\r
25801         MOVSI   A,TSTORA\r
25802         HRLI    C,(C)           ;TO BOTH HALVES\r
25803         SUB     B,C             ;BACK UP VECTOR POINTER\r
25804         HLRE    C,B             ;FIND OUT IF OVERFLOW\r
25805         SUBM    B,C             ;DOPE POINTER TO C\r
25806         HLRZ    D,1(C)          ;GET LENGTH\r
25807         SUBI    C,-2(D)         ;POINT TO TOP\r
25808         ANDI    C,-1\r
25809         CAILE   C,(B)           ;SKIP IF A WINNER\r
25810         JRST    OUTRNG          ;COMPLAIN\r
25811 BACKUV: POPJ    P,\r
25812 \r
25813 BCKTMP: MOVSI   C,(C)\r
25814         SUB     B,C             ; FIX UP POINTER\r
25815         JUMPL   B,OUTRNG\r
25816         MOVSI   A,TTMPLT\r
25817         POPJ    P,\r
25818 \r
25819 BACKC:  PUSH    TP,A\r
25820         PUSH    TP,B\r
25821         ADDI    A,(C)           ; NEW LENGTH\r
25822         HRLI    A,TCHSTR\r
25823         PUSH    P,A             ; SAVE COUNT\r
25824         LDB     E,[300600,,B]   ;BYTE SIZE\r
25825         MOVEI   0,36.           ;BITS PER WORD\r
25826         IDIVI   0,(E)           ;DIVIDE TO FIND BYTES/WORD\r
25827         IDIV    C,0             ;C/ WORDS BACK, D/BYTES BACK\r
25828         SUBI    B,(C)           ;BACK WORDS UP\r
25829         JUMPE   D,CHBOUN        ;CHECK BOUNDS\r
25830 \r
25831         IMULI   0,(E)           ;0/ BITS OCCUPIED BY FULL WORD\r
25832         LDB     A,[360600,,B]   ;GET POSITION FILED\r
25833 BACKC2: ADDI    A,(E)           ;BUMP\r
25834         CAIGE   A,36.\r
25835         JRST    BACKC1          ;O.K.\r
25836         SUB     A,0\r
25837         SUBI    B,1             ;DECREMENT POINTER PART\r
25838 BACKC1: SOJG    D,BACKC2        ;DO FOR ALL BYTES\r
25839 \f\r
25840 \r
25841 \r
25842         DPB     A,[360600,,B]   ;FIX UP POINT BYTER\r
25843 CHBOUN: MOVEI   C,-1(TP)\r
25844         PUSHJ   P,BYTDOP                ; FIND DOPE WORD\r
25845         HLRZ    C,(A)\r
25846         SUBI    A,-1(C)         ; POINT TO TOP\r
25847         MOVE    C,B             ; COPY BYTER\r
25848         IBP     C\r
25849         CAILE   A,(C)           ; SKIP IF OK\r
25850         JRST    OUTRNG\r
25851         POP     P,A             ; RESTORE COUNT\r
25852         SUB     TP,[2,,2]\r
25853         POPJ    P,\r
25854 \r
25855 \r
25856 BACKA:  LSH     C,1             ;NUMBER TIMES 2\r
25857         HRLI    C,(C)           ;TO BOTH HALVES\r
25858         SUB     B,C             ;FIX POINTER\r
25859         MOVE    E,B             ;AND SAVE\r
25860         PUSHJ   P,GETATO                ;LOOK A T TOP\r
25861         CAMLE   B,E             ;COMPARE\r
25862         JRST    OUTRNG\r
25863         MOVE    B,E\r
25864         POPJ    P,\r
25865 \r
25866 ; COMPILER'S BACK\r
25867 \r
25868 CIBACK: PUSHJ   P,CPTYEE\r
25869         JUMPL   C,OUTRNG\r
25870         CAIN    E,P2WORD\r
25871         JRST    COMPERR\r
25872         PUSHJ   P,@BCKTBL(E)\r
25873         JRST    MPOPJ\r
25874 \f\r
25875 MFUNCTION STRCOMP,SUBR\r
25876 \r
25877         ENTRY   2\r
25878 \r
25879         MOVE    A,(AB)\r
25880         MOVE    B,1(AB)\r
25881         MOVE    C,2(AB)\r
25882         MOVE    D,3(AB)\r
25883         PUSHJ   P,ISTRCM\r
25884         JRST    FINIS\r
25885 \r
25886 ISTRCM: GETYP   0,A\r
25887         CAIE    0,TCHSTR\r
25888         JRST    ATMCMP          ; MAYBE ATOMS\r
25889 \r
25890         GETYP   0,C\r
25891         CAIE    0,TCHSTR\r
25892         JRST    WTYP2\r
25893 \r
25894         MOVEI   A,(A)           ; ISOLATR LENGHTS\r
25895         MOVEI   C,(C)\r
25896 \r
25897 STRCO2: SOJL    A,CHOTHE        ; ONE STRING EXHAUSTED, CHECK OTHER\r
25898         SOJL    C,1BIG          ; 1ST IS BIGGER\r
25899         ILDB    0,B\r
25900         ILDB    E,D\r
25901         CAIN    0,(E)           ; SKIP IF DIFFERENT\r
25902         JRST    STRCO2\r
25903         CAIL    0,(E)           ; SKIP IF 2D BIGGER THAN 1ST\r
25904         JRST    1BIG\r
25905 2BIG:   MOVNI   B,1\r
25906         JRST    RETFIX\r
25907 \r
25908 CHOTHE: JUMPN   C,2BIG          ; 2 IS BIGGER\r
25909 SM.CMP: TDZA    B,B             ; RETURN 0\r
25910 1BIG:   MOVEI   B,1\r
25911 RETFIX: MOVSI   A,TFIX\r
25912         POPJ    P,\r
25913 \r
25914 ATMCMP: CAIE    0,TATOM         ; COULD BE ATOM\r
25915         JRST    WTYP1           ; NO, QUIT\r
25916         GETYP   0,C\r
25917         CAIE    0,TATOM\r
25918         JRST    WTYP2\r
25919 \r
25920         CAMN    B,D             ; SAME ATOM?\r
25921         JRST    SM.CMP\r
25922         ADD     B,[3,,3]        ; SKIP VAL CELL ETC.\r
25923         ADD     D,[3,,3]\r
25924 \r
25925 ATMCM1: MOVE    0,(B)           ; GET A  WORD OF CHARS\r
25926         CAME    0,(D)           ; SAME?\r
25927         JRST    ATMCM3          ; NO, GET DIF\r
25928         AOBJP   B,ATMCM2\r
25929         AOBJN   D,ATMCM1        ; MORE TO COMPARE\r
25930         JRST    1BIG            ; 1ST IS BIGGER\r
25931 \r
25932 \r
25933 ATMCM2: AOBJP   D,SM.CMP        ; EQUAL\r
25934         JRST    2BIG\r
25935 \r
25936 ATMCM3: LSH     0,-1            ; AVOID SIGN LOSSAGE\r
25937         MOVE    C,(D)\r
25938         LSH     C,-1\r
25939         CAMG    0,C\r
25940         JRST    2BIG\r
25941         JRST    1BIG\r
25942 \r
25943 \f;ERROR COMMENTS FOR SOME PRIMITIVES\r
25944 \r
25945 OUTRNG: PUSH    TP,$TATOM\r
25946         PUSH    TP,EQUOTE OUT-OF-BOUNDS\r
25947         JRST    CALER1\r
25948 \r
25949 WRNGUT: PUSH    TP,$TATOM\r
25950         PUSH    TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS\r
25951         JRST    CALER1\r
25952 \r
25953 SLOSE0: PUSH    TP,$TATOM\r
25954         PUSH    TP,EQUOTE VECTOR-LENGTHS-DIFFER\r
25955         JRST    CALER1\r
25956 \r
25957 SLOSE1: PUSH    TP,$TATOM\r
25958         PUSH    TP,EQUOTE KEYS-WRONG-TYPE\r
25959         JRST    CALER1\r
25960 \r
25961 SLOSE2: PUSH    TP,$TATOM\r
25962         PUSH    TP,EQUOTE KEY-TYPES-DIFFER\r
25963         JRST    CALER1\r
25964 \r
25965 SLOSE3: PUSH    TP,$TATOM\r
25966         PUSH    TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD\r
25967         JRST    CALER1\r
25968 \r
25969 SLOSE4: PUSH    TP,$TATOM\r
25970         PUSH    TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS\r
25971         JRST    CALER1\r
25972 \r
25973 IIGETP: JRST    IGETP           ;FUDGE FOR MIDAS/STINK LOSSAGE\r
25974 IIPUTP: JRST    IPUTP\r
25975 \r
25976 \f;SUPER USEFUL ERROR MESSAGES   (USED BY WHOLE WORLD)\r
25977 \r
25978 WNA:    PUSH    TP,$TATOM\r
25979         PUSH    TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS\r
25980         JRST    CALER1\r
25981 \r
25982 TFA:    PUSH    TP,$TATOM\r
25983         PUSH    TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED\r
25984         JRST    CALER1\r
25985 \r
25986 TMA:    PUSH    TP,$TATOM\r
25987         PUSH    TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED\r
25988         JRST    CALER1\r
25989 \r
25990 WRONGT: \r
25991 WTYP:   PUSH    TP,$TATOM\r
25992         PUSH    TP,EQUOTE ARG-WRONG-TYPE\r
25993         JRST    CALER1\r
25994 \r
25995 IWTYP1:\r
25996 WTYP1:  PUSH    TP,$TATOM\r
25997         PUSH    TP,EQUOTE FIRST-ARG-WRONG-TYPE\r
25998         JRST    CALER1\r
25999 \r
26000 IWTYP2:\r
26001 WTYP2:  PUSH    TP,$TATOM\r
26002         PUSH    TP,EQUOTE SECOND-ARG-WRONG-TYPE\r
26003         JRST    CALER1\r
26004 \r
26005 BADTPL: PUSH    TP,$TATOM\r
26006         PUSH    TP,EQUOTE BAD-TEMPLATE-DATA\r
26007         JRST    CALER1\r
26008 \r
26009 BADPUT: PUSH    TP,$TATOM\r
26010         PUSH    TP,EQUOTE TEMPLATE-TYPE-VIOLATION\r
26011         JRST    CALER1\r
26012 \r
26013 WTYP3:  PUSH    TP,$TATOM\r
26014         PUSH    TP,EQUOTE THIRD-ARG-WRONG-TYPE\r
26015         JRST    CALER1\r
26016 \r
26017 CALER1: MOVEI   A,1\r
26018 CALER:  HRRZ    C,FSAV(TB)\r
26019         PUSH    TP,$TATOM\r
26020         CAMGE   C,VECTOP\r
26021         CAMGE   C,VECBOT\r
26022         SKIPA   C,@-1(C)        ; SUBRS AND FSUBRS\r
26023         MOVE    C,3(C)          ; FOR RSUBRS\r
26024         PUSH    TP,C\r
26025         ADDI    A,1\r
26026         ACALL   A,ERROR\r
26027         JRST    FINIS\r
26028   \r
26029 \r
26030 GETWNA: HLRZ    B,(E)-2         ;GET LOSING COMPARE INSTRUCTION\r
26031         CAIE    B,(CAIE A,)     ;AS EXPECTED ?\r
26032         JRST    WNA             ;NO,\r
26033         HRRE    B,(E)-2         ;GET DESIRED NUMBER OF ARGS\r
26034         HLRE    A,AB            ;GET ACTUAL NUMBER OF ARGS\r
26035         CAMG    B,A\r
26036         JRST    TFA\r
26037         JRST    TMA\r
26038 \r
26039 END\r
26040 \fTITLE  PRINTER ROUTINE FOR MUDDLE\r
26041 \r
26042 RELOCATABLE\r
26043 \r
26044 .INSRT DSK:MUDDLE >\r
26045 \r
26046 .GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL\r
26047 .GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT\r
26048 .GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID\r
26049 .GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT\r
26050 .GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1\r
26051 .GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR\r
26052 .GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH\r
26053 \r
26054 BUFLNT==100             ; BUFFER LENGTH IN WORDS\r
26055 \r
26056 FLAGS==0        ;REGISTER USED TO STORE FLAGS\r
26057 CARRET==15      ;CARRIAGE RETURN CHARACTER\r
26058 ESCHAR=="\      ;ESCAPE CHARACTER\r
26059 SPACE==40       ;SPACE CHARACTER\r
26060 ATMBIT==200000  ;BIT SWITCH FOR ATOM-NAME PRINT\r
26061 NOQBIT==020000  ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)\r
26062 SEGBIT==010000  ;SWITCH TO INDICATE PRINTING A SEGMENT\r
26063 SPCBIT==004000  ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)\r
26064 FLTBIT==002000  ;SWITCH TO INDICATE "FLATSIZE" CALL\r
26065 HSHBIT==001000  ;SWITCH TO INDICATE "PHASH" CALL\r
26066 TERBIT==000400  ;SWITCH TO INDICATE "TERPRI" CALL\r
26067 UNPRSE==000200  ;SWITCH TO INDICATE "UNPARSE" CALL\r
26068 ASCBIT==000100  ;SWITCH TO INDICATE USING A "PRINT" CHANNEL\r
26069 BINBIT==000040  ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL\r
26070 PJBIT==400000\r
26071 C.BUF==1\r
26072 C.PRIN==2\r
26073 C.BIN==4\r
26074 C.OPN==10\r
26075 C.READ==40\r
26076 \r
26077 \r
26078 \fMFUNCTION      FLATSIZE,SUBR\r
26079         DEFINE FLTMAX\r
26080                 4(B) TERMIN\r
26081         DEFINE FLTSIZ\r
26082                 2(B)TERMIN\r
26083 ;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND\r
26084 ;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE\r
26085 ;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX\r
26086         ENTRY\r
26087         CAMG    AB,[-2,,0]      ;CHECK NUMBER OF ARGS\r
26088         CAMG    AB,[-6,,0]\r
26089         JRST    WNA\r
26090         PUSH    P,3(AB)\r
26091 \r
26092         GETYP   A,2(AB)\r
26093         CAIE    A,TFIX\r
26094         JRST    WTYP2           ;SECOND ARG NOT FIX THEN LOSE\r
26095 \r
26096         CAMG    AB,[-4,,0]      ;SEE IF THERE IS A RADIX ARGUMENT\r
26097         JRST    .+3             ; RADIX SUPPLIED\r
26098         PUSHJ   P,GTRADX        ; GET THE RADIX FROM OUTCHAN\r
26099         JRST    FLTGO\r
26100         GETYP   A,4(AB)         ;CHECK TO SEE THAT RADIX IS FIX\r
26101         CAIE    A,TFIX\r
26102         JRST    WTYP            ;ERROR THIRD ARGUMENT WRONG TYPE\r
26103         MOVE    C,5(AB)\r
26104         PUSHJ   P,GETARG        ; GET ARGS INTO A AND B\r
26105 FLTGO:  POP     P,D             ; RESTORE FLATSIZE MAXIMUM\r
26106         PUSHJ   P,CIFLTZ\r
26107         JFCL\r
26108         JRST    FINIS\r
26109 \r
26110 \r
26111 \r
26112 MFUNCTION UNPARSE,SUBR\r
26113         DEFINE UPB\r
26114                 0(B) TERMIN\r
26115 \r
26116         ENTRY\r
26117 \r
26118         JUMPGE  AB,TFA\r
26119         MOVE    E,TP            ;SAVE TP POINTER\r
26120 \r
26121 \r
26122 \r
26123 ;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE\r
26124 ;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED\r
26125         CAMG    AB,[-2,,0]      ;SKIP IF RADIX SUPPLIED\r
26126         JRST    .+3\r
26127         PUSHJ   P,GTRADX        ;GET THE RADIX FROM OUTCHAN\r
26128         JRST    UNPRGO\r
26129         CAMGE   AB,[-5,,0]      ;CHECK FOR TOO MANY\r
26130         JRST    TMA\r
26131         GETYP   0,2(AB)\r
26132         CAIE    0,TFIX          ;SEE IF RADIX IS FIXED\r
26133         JRST    WTYP2\r
26134         MOVE    C,3(AB)         ;GET RADIX\r
26135         PUSHJ   P,GETARG        ;GET ARGS INTO A AND B\r
26136 UNPRGO: PUSHJ   P,CIUPRS\r
26137         JRST    FINIS\r
26138         JRST    FINIS\r
26139 \r
26140 \r
26141 GTRADX: MOVE    B,IMQUOTE OUTCHAN\r
26142         PUSH    P,0             ;SAVE FLAGS\r
26143         PUSHJ   P,IDVAL         ;GET VALUE FOR OUTCHAN\r
26144         POP     P,0\r
26145         GETYP   A,A             ;CHECK TYPE OF CHANNEL\r
26146         CAIE    A,TCHAN\r
26147         JRST    FUNCH1-1        ;IT IS A TP-POINTER\r
26148         MOVE    C,RADX(B)       ;GET RADIX FROM OUTCHAN\r
26149         JRST    FUNCH1\r
26150         MOVE    C,(B)+6         ;GET RADIX FROM STACK\r
26151 \r
26152 FUNCH1: CAIG    C,1             ;CHECK FOR STRANGE RADIX\r
26153         MOVEI   C,10.           ;DEFAULT IF THIS IS THE CASE\r
26154 GETARG: MOVE    A,(AB)\r
26155         MOVE    B,1(AB)\r
26156         POPJ    P,\r
26157 \r
26158 \r
26159 MFUNCTION       PRINT,SUBR\r
26160         ENTRY   \r
26161         PUSHJ   P,AGET          ; GET ARGS\r
26162         PUSHJ   P,CIPRIN\r
26163         JRST    FINIS\r
26164 \r
26165 MFUNCTION       PRINC,SUBR\r
26166         ENTRY   \r
26167         PUSHJ   P,AGET          ; GET ARGS\r
26168         PUSHJ   P,CIPRNC\r
26169         JRST    FINIS\r
26170 \r
26171 MFUNCTION       PRIN1,SUBR\r
26172         ENTRY   \r
26173         PUSHJ   P,AGET\r
26174         PUSHJ   P,CIPRN1\r
26175         JRST    FINIS\r
26176         JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF\r
26177 \r
26178 \r
26179 MFUNCTION       TERPRI,SUBR\r
26180         ENTRY\r
26181         PUSHJ   P,AGET1\r
26182         PUSHJ   P,CITERP\r
26183         JRST    FINIS\r
26184 \r
26185 \f\r
26186 CITERP: SUBM    M,(P)\r
26187         MOVSI   0,TERBIT+SPCBIT ; SET UP FLAGS\r
26188         PUSHJ   P,TESTR ; TEST FOR GOOD CHANNEL\r
26189         MOVEI   A,CARRET        ; MOVE IN CARRIAGE-RETURN\r
26190         PUSHJ   P,PITYO         ; PRINT IT OUT\r
26191         MOVEI   A,12            ; LINE-FEED\r
26192         PUSHJ   P,PITYO\r
26193         MOVSI   A,TFALSE        ; RETURN A FALSE\r
26194         MOVEI   B,0\r
26195         JRST    MPOPJ           ; RETURN\r
26196 \r
26197 \r
26198 TESTR:  GETYP   E,A\r
26199         CAIN    E,TCHAN         ; CHANNEL?\r
26200         JRST    TESTR1          ; OK?\r
26201         CAIE    E,TTP\r
26202         JRST    BADCHN\r
26203         HLRZS   0\r
26204         IOR     0,A             ; RESTORE FLAGS\r
26205         HRLZS   0\r
26206         POPJ    P,\r
26207 TESTR1: HRRZ    E,-4(B)         ; GET IN FLAGS FROM CHANNEL\r
26208         TRC     E,C.PRIN+C.OPN  ; CHECK TO SEE THAT CHANNEL IS GOOD\r
26209         TRNE    E,C.PRIN+C.OPN\r
26210         JRST    BADCHN          ; ITS A LOSER\r
26211         TRNE    E,C.BIN\r
26212         JRST    PSHNDL          ; DON'T HANDLE BINARY\r
26213         TLO     ASCBIT          ; ITS ASCII\r
26214         POPJ    P,              ; ITS A WINNER\r
26215         \r
26216 PSHNDL: PUSH    TP,C            ; SAVE ARGS\r
26217         PUSH    TP,D\r
26218         PUSH    TP,A            ; PUSH CHANNEL ONTO STACK\r
26219         PUSH    TP,B\r
26220         PUSHJ   P,BPRINT        ; CHECK BUFFER\r
26221         POP     TP,B\r
26222         POP     TP,A\r
26223         POP     TP,D\r
26224         POP     TP,C\r
26225         POPJ    P,\r
26226 \r
26227 \r
26228 \f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B\r
26229 \r
26230 CIUPRS: SUBM    M,(P)           ; MODIFY M-POINTER\r
26231         MOVE    E,TP            ; SAVE TP-POINTER\r
26232         PUSH    TP,[0]          ; SLOT FOR FIRST STRING COPY\r
26233         PUSH    TP,[0]\r
26234         PUSH    TP,[0]          ; AND SECOND STRING\r
26235         PUSH    TP,[0]\r
26236         PUSH    TP,A            ; SAVE OBJECTS\r
26237         PUSH    TP,B\r
26238         PUSH    TP,$TTP         ; SAVE TP POINTER\r
26239         PUSH    TP,E\r
26240         PUSH    P,C\r
26241         MOVE    D,[377777,,-1]  ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE\r
26242         PUSHJ   P,CIFLTZ        ; FIND LENGTH OF STRING\r
26243         FATAL UNPARSE BLEW IT\r
26244         PUSH    TP,$TFIX        ; MOVE IN ARGUMENT FOR ISTRING\r
26245         PUSH    TP,B\r
26246         MCALL   1,ISTRING\r
26247         POP     TP,E            ; RESTORE TP-POINTER\r
26248         SUB     TP,[1,,1]       ;GET RID OF TYPE WORD\r
26249         MOVEM   A,1(E)          ; SAVE RESULTS\r
26250         MOVEM   A,3(E)\r
26251         MOVEM   B,2(E)\r
26252         MOVEM   B,4(E)\r
26253         POP     TP,B            ; RESTORE THE WORLD\r
26254         POP     TP,A\r
26255         POP     P,C\r
26256         MOVSI   0,FLTBIT+UNPRSE ; SET UP FLAGS\r
26257         PUSHJ   P,CUSET\r
26258         JRST    MPOPJ           ; RETURN\r
26259 \r
26260 \r
26261 \r
26262 ; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,\r
26263 ; A,B THE TYPE-OBJECT PAIR\r
26264 \r
26265 CIFLTZ: SUBM    M,(P)\r
26266         MOVE    E,TP            ; SAVE POINTER\r
26267         PUSH    TP,$TFIX        ; PUSH ON FLATSIZE COUNT\r
26268         PUSH    TP,[0]\r
26269         PUSH    TP,$TFIX        ; PUSH ON FLATSIZE MAXIMUM\r
26270         PUSH    TP,D\r
26271         MOVSI   0,FLTBIT        ; MOVE ON FLATSIZE FLAG\r
26272         PUSHJ   P,CUSET         ; CONTINUE\r
26273         JRST    MPOPJ\r
26274         SOS     (P)             ; SKIP RETURN\r
26275         JRST    MPOPJ           ; RETURN\r
26276 \r
26277 ; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING\r
26278 ; NEEDED TO GET A RESULT.\r
26279 \r
26280 CUSET:  PUSH    TP,$TFIX        ; PUSH ON RADIX\r
26281         PUSH    TP,C\r
26282         PUSH    TP,$TPDL\r
26283         PUSH    TP,P            ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE\r
26284         PUSH    TP,A            ; SAVE OBJECTS\r
26285         PUSH    TP,B\r
26286         MOVSI   C,TTP           ; CONSTRUCT TP-POINTER\r
26287         HLR     C,FLAGS         ; SAVE FLAGS IN TP-POINTER\r
26288         MOVE    D,E\r
26289         PUSH    TP,C            ; PUSH ON CHANNEL\r
26290         PUSH    TP,D\r
26291         PUSHJ   P,IPRINT        ; GO TO INTERNAL PRINTER\r
26292         POP     TP,B            ; GET IN TP POINTER\r
26293         MOVE    TP,B            ; RESTORE POINTER\r
26294         TLNN    FLAGS,UNPRSE    ; SEE IF UNPARSE CALL\r
26295         JRST    FLTGEN          ; ITS A FLATSIZE\r
26296         MOVE    A,UPB+3         ; RETURN STRING\r
26297         MOVE    B,UPB+4\r
26298         POPJ    P,              ; DONE\r
26299 FLTGEN: MOVE    A,FLTSIZ-1      ; GET IN COUNT\r
26300         MOVE    B,FLTSIZ\r
26301         AOS     (P)\r
26302         POPJ    P,              ; EXIT\r
26303 \r
26304 \f\r
26305 ; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME\r
26306 ; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL\r
26307 \r
26308 CIPRIN: SUBM    M,(P)\r
26309         MOVSI   0,SPCBIT        ; SET UP FLAGS\r
26310         PUSHJ   P,TPRT          ; PRINT INITIALIZATION\r
26311         PUSHJ   P,IPRINT\r
26312         JRST    TPRTE           ; EXIT\r
26313 \r
26314 CIPRN1: SUBM    M,(P)\r
26315         MOVEI   FLAGS,0         ; SET UP FLAGS\r
26316         PUSHJ   P,TPR1          ; INITIALIZATION\r
26317         PUSHJ   P,IPRINT        ; PRINT IT OUT\r
26318         JRST    TPR1E           ; EXIT\r
26319 \r
26320 CIPRNC: SUBM    M,(P)\r
26321         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS\r
26322         PUSHJ   P,TPR1          ; INITIALIZATION\r
26323         PUSHJ   P,IPRINT\r
26324         JRST    TPR1E           ; EXIT\r
26325 \f\r
26326 ; INITIALIZATION FOR PRINT ROUTINES\r
26327 \r
26328 TPRT:   PUSHJ   P,TESTR         ; SEE IF CHANNEL IS OK\r
26329         PUSH    TP,C            ; SAVE ARGUMENTS\r
26330         PUSH    TP,D\r
26331         PUSH    TP,A            ; SAVE CHANNEL\r
26332         PUSH    TP,B\r
26333         MOVEI   A,CARRET        ; PRINT CARRIAGE RETURN\r
26334         PUSHJ   P,PITYO\r
26335         MOVEI   A,12            ; AND LF\r
26336         PUSHJ   P,PITYO\r
26337         MOVE    A,-3(TP)        ; MOVE IN ARGS\r
26338         MOVE    B,-2(TP)\r
26339         POPJ    P,\r
26340 \r
26341 ; EXIT FOR PRINT ROUTINES\r
26342 \r
26343 TPRTE:  POP     TP,B            ; RESTORE CHANNEL\r
26344         MOVEI   A,SPACE         ; PRINT TRAILING SPACE\r
26345         PUSHJ   P,PITYO\r
26346         SUB     TP,[1,,1]       ; GET RID OF CHANNEL TYPE-WORD\r
26347         POP     TP,B            ; RETURN WHAT WAS PASSED\r
26348         POP     TP,A\r
26349         JRST    MPOPJ           ; EXIT\r
26350 \r
26351 ; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES\r
26352 \r
26353 TPR1:   PUSHJ   P,TESTR         ; SEE IF CHANNEL IS OK\r
26354         PUSH    TP,C            ; SAVE ARGS\r
26355         PUSH    TP,D\r
26356         PUSH    TP,A            ; SAVE CHANNEL\r
26357         PUSH    TP,B\r
26358         MOVE    A,-3(TP)                ; GET ARGS\r
26359         MOVE    B,-2(TP)\r
26360         POPJ    P,\r
26361 \r
26362 ; EXIT FOR PRIN1 AND PRINC ROUTINES\r
26363 \r
26364 TPR1E:  SUB     TP,[2,,2]       ; REMOVE CHANNEL\r
26365         POP     TP,B            ; RETURN ARGUMENTS THAT WERE GIVEN\r
26366         POP     TP,A\r
26367         JRST    MPOPJ           ; EXIT\r
26368 \r
26369 \r
26370 \f\r
26371 CPATM:  SUBM    M,(P)\r
26372         MOVSI   C,TATOM         ; GET TYPE FOR BINARY\r
26373         MOVE    0,$SPCBIT       ; SET UP FLAGS\r
26374         PUSHJ   P,TPRT          ; PRINT INITIALIZATION\r
26375         PUSHJ   P,CPATOM        ; PRINT IT OUT\r
26376         JRST    TPRTE           ; EXIT\r
26377 \r
26378 CP1ATM: SUBM    M,(P)\r
26379         MOVE    C,$TATOM\r
26380         MOVEI   FLAGS,0         ; SET UP FLAGS\r
26381         PUSHJ   P,TPR1          ; INITIALIZATION\r
26382         PUSHJ   P,CPATOM        ; PRINT IT OUT\r
26383         JRST    TPR1E           ; EXIT\r
26384 \r
26385 CPCATM: SUBM    M,(P)\r
26386         MOVE    C,$TATOM\r
26387         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS\r
26388         PUSHJ   P,TPR1          ; INITIALIZATION\r
26389         PUSHJ   P,CPATOM        ; PRINT IT OUT\r
26390         JRST    TPR1E           ; EXIT\r
26391 \r
26392 \r
26393 ; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE \r
26394 ; CHARACTER IS IN C.\r
26395 CPCH:   SUBM    M,(P)\r
26396         MOVSI   FLAGS,NOQBIT\r
26397         MOVE    C,$TCHRS\r
26398         PUSHJ   P,TESTR         ; SEE IF CHANNEL IS GOOD\r
26399         PUSH    P,D\r
26400         MOVE    A,D             ; MOVE IN CHARACTER FOR PITYO\r
26401         PUSHJ   P,PITYO\r
26402         MOVE    A,$TCHRST       ; RETURN THE CHARACTER\r
26403         POP     P,B\r
26404         JRST    MPOPJ\r
26405 \r
26406 \r
26407 \r
26408 \r
26409 CPSTR:  SUBM    M,(P)\r
26410         HRLI    C,TCHSTR\r
26411         MOVSI   0,SPCBIT        ; SET UP FLAGS\r
26412         PUSHJ   P,TPRT          ; PRINT INITIALIZATION\r
26413         PUSHJ   P,CPCHST        ; PRINT IT OUT\r
26414         JRST    TPRTE           ; EXIT\r
26415 \r
26416 CP1STR: SUBM    M,(P)\r
26417         HRLI    C,TCHSTR\r
26418         MOVEI   FLAGS,0         ; SET UP FLAGS\r
26419         PUSHJ   P,TPR1          ; INITIALIZATION\r
26420         PUSHJ   P,CPCHST        ; PRINT IT OUT\r
26421         JRST    TPR1E           ; EXIT\r
26422 \r
26423 CPCSTR: SUBM    M,(P)\r
26424         HRLI    C,TCHSTR\r
26425         MOVSI   FLAGS,NOQBIT    ; SET UP FLAGS\r
26426         PUSHJ   P,TPR1          ; INITIALIZATION\r
26427         PUSHJ   P,CPCHST        ; PRINT IT OUT\r
26428         JRST    TPR1E           ; EXIT\r
26429 \r
26430 \r
26431 CPATOM: PUSH    TP,A            ; COPY ARGS FOR INTERNAL SAKE\r
26432         PUSH    TP,B\r
26433         PUSH    P,0             ; ATOM CALLER ROUTINE\r
26434         PUSH    P,C\r
26435         JRST    PATOM\r
26436 \r
26437 CPCHST: PUSH    TP,A            ; COPY ARGS FOR INTERNAL SAKE\r
26438         PUSH    TP,B\r
26439         PUSH    P,0             ; STRING CALLER ROUTINE\r
26440         PUSH    P,C\r
26441         JRST    PCHSTR\r
26442 \r
26443 \r
26444 \f\r
26445 AGET:   MOVEI   FLAGS,0\r
26446         SKIPL   E,AB            ; COPY ARG POINTER\r
26447         JRST    TFA             ;NO ARGS IS AN ERROR\r
26448         ADD     E,[2,,2]        ;POINT AT POSSIBLE CHANNEL\r
26449         JRST    COMPT\r
26450 AGET1:  MOVE    E,AB            ; GET COPY OF AB\r
26451         MOVSI   FLAGS,TERBIT\r
26452 \r
26453 COMPT:  PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR ONE CHANNEL\r
26454         PUSH    TP,[0]\r
26455         JUMPGE  E,DEFCHN        ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING\r
26456         CAMG    E,[-2,,0]       ;IF MORE ARGS THEN ERROR\r
26457         JRST    TMA\r
26458         MOVE    A,(E)           ;GET CHANNEL\r
26459         MOVE    B,(E)+1\r
26460         JRST    NEWCHN\r
26461 \r
26462 DEFCHN: MOVE    B,IMQUOTE OUTCHAN\r
26463         MOVSI   A,TATOM\r
26464         PUSH    P,FLAGS         ;SAVE FLAGS\r
26465         PUSHJ   P,IDVAL         ;GET VALUE OF OUTCHAN\r
26466         POP     P,0\r
26467 \r
26468 NEWCHN: TLNE    FLAGS,TERBIT    ; SEE IF TERPRI\r
26469         POPJ    P,\r
26470         MOVE    C,(AB)  ; GET ARGS\r
26471         MOVE    D,1(AB)\r
26472         POPJ    P,\r
26473 \r
26474 ; HERE IF USING A PRINTB CHANNEL\r
26475 \r
26476 BPRINT: TLO     FLAGS,BINBIT\r
26477         SKIPE   BUFSTR(B)       ; ANY OUTPUT BUFFER?\r
26478         POPJ    P,\r
26479 \r
26480 ; HERE TO GENERATE A STRING BUFFER\r
26481 \r
26482         PUSH    P,FLAGS\r
26483         MOVEI   A,BUFLNT        ; GET BUFFER LENGTH\r
26484         PUSHJ   P,IBLOCK        ; MAKE A BUFFER\r
26485         MOVSI   0,TWORD+.VECT.  ; CLOBBER U TYPE\r
26486         MOVEM   0,BUFLNT(B)\r
26487         SETOM   (B))            ; -1 THE BUFFER\r
26488         MOVEI   C,1(B)\r
26489         HRLI    C,(B)\r
26490         BLT     C,BUFLNT-1(B)\r
26491         HRLI    B,440700\r
26492         MOVE    C,(TP)\r
26493         MOVEM   B,BUFSTR(C)     ; STOR BYTE POINTER\r
26494         MOVE    0,[TCHSTR,,BUFLNT*5]\r
26495         MOVEM   0,BUFSTR-1(C)\r
26496         POP     P,FLAGS\r
26497 \r
26498         MOVE    B,(TP)\r
26499         POPJ    P,\r
26500 \f\r
26501 \r
26502 IPRINT: PUSH    P,C             ; SAVE C\r
26503         PUSH    P,FLAGS ;SAVE PREVIOUS FLAGS\r
26504         PUSH    TP,A    ;SAVE ARGUMENT ON TP-STACK\r
26505         PUSH    TP,B\r
26506         \r
26507         INTGO           ;ALLOW INTERRUPTS HERE\r
26508  \r
26509         GETYP   A,-1(TP)        ;GET THE TYPE CODE OF THE ITEM\r
26510         SKIPE   C,PRNTYP+1(TVP) ; USER TYPE TABLE?\r
26511         JRST    PRDISP\r
26512 NORMAL: CAIG    A,NUMPRI        ;PRIMITIVE?\r
26513         JRST    @PRTYPE(A)      ;YES-DISPATCH\r
26514         JRST    PUNK    ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT\r
26515 \r
26516 ; HERE FOR USER PRINT DISPATCH\r
26517 \r
26518 PRDISP: ADDI    C,(A)           ; POINT TO SLOT\r
26519         ADDI    C,(A)\r
26520         SKIPE   (C)             ; SKIP EITHER A LOSER OR JRST DISP\r
26521         JRST    PRDIS1          ; APPLY EVALUATOR\r
26522         SKIPN   C,1(C)          ; GET ADDR OR GO TO PURE DISP\r
26523         JRST    NORMAL\r
26524         JRST    (C)\r
26525 \r
26526 PRDIS1: PUSH    P,C             ; SAVE C\r
26527         PUSH    TP,[TATOM,,-1]  ; PUSH ON OUTCHAN FOR SPECBIND\r
26528         PUSH    TP,IMQUOTE OUTCHAN\r
26529         PUSH    TP,-5(TP)\r
26530         PUSH    TP,-5(TP)\r
26531         PUSH    TP,[0]\r
26532         PUSH    TP,[0]\r
26533         PUSHJ   P,SPECBIND\r
26534         POP     P,C             ; RESTORE C\r
26535         PUSH    TP,(C)          ; PUSH ARGS FOR APPLY\r
26536         PUSH    TP,1(C)\r
26537         PUSH    TP,-9(TP)\r
26538         PUSH    TP,-9(TP)\r
26539         MCALL   2,APPLY         ; APPLY HACKER TO OBJECT\r
26540         MOVEI   E,-8(TP)\r
26541         PUSHJ   P,SSPEC1        ;UNBIND OUTCHAN\r
26542         SUB     TP,[6,,6]       ; POP OFF STACK\r
26543         JRST    PNEXT\r
26544 \r
26545 ; PRINT DISPATCH TABLE\r
26546 \r
26547 DISTBL  PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]\r
26548 [TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]\r
26549 [TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]\r
26550 [TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]\r
26551 [TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]]\r
26552 \r
26553 PUNK:   MOVE    C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS\r
26554         GETYP   B,-1(TP)        ; GET THE TYPE CODE INTO REG B\r
26555         LSH     B,1             ; MULTIPLY BY TWO\r
26556         HRL     B,B             ; DUPLICATE IT IN THE LEFT HALF\r
26557         ADD     C,B             ; INCREMENT THE AOBJN-POINTER\r
26558         JUMPGE  C,PRERR         ; IF POSITIVE, INDEX > VECTOR SIZE\r
26559 \r
26560         MOVE    B,-2(TP)                ; MOVE IN CHANNEL\r
26561         PUSHJ   P,RETIF1        ; START NEW LINE IF NO ROOM\r
26562         MOVEI   A,"#            ; INDICATE TYPE-NAME FOLLOWS\r
26563         PUSHJ   P,PITYO\r
26564         MOVE    A,(C)           ; GET TYPE-ATOM\r
26565         MOVE    B,1(C)\r
26566         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT\r
26567         PUSH    TP,-3(TP)\r
26568         PUSHJ   P,IPRINT        ; PRINT ATOM-NAME\r
26569         SUB     TP,[2,,2]       ; POP STACK \r
26570         MOVE    B,-2(TP)                ; MOVE IN CHANNEL\r
26571         PUSHJ   P,SPACEQ        ;  MAYBE SPACE\r
26572         MOVE    B,(B)           ; RESET THE REAL ARGUMENT POINTER\r
26573         HRRZ    A,(C)           ; GET THE STORAGE-TYPE\r
26574         ANDI    A,SATMSK\r
26575         CAIG    A,NUMSAT        ; SKIP IF TEMPLATE\r
26576         JRST    @UKTBL(A)       ; USE DISPATCH TABLE ON STORAGE TYPE\r
26577         JRST    TMPRNT          ; PRINT TEMPLATED DATA STRUCTURE\r
26578 \r
26579 DISTBS  UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]\r
26580 [SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]\r
26581 [SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]\r
26582 [SLOCT,LOCP]]\r
26583 \r
26584         ; SELECK AN ILLEGAL\r
26585 \r
26586 ILLCH:  MOVEI   B,-1(TP)\r
26587         JRST    ILLCHO\r
26588 \r
26589 \f; PRINT INTERRUPT HANDLER\r
26590 \r
26591 PHAND:  MOVE    B,-2(TP)        ; MOVE CHANNEL INTO B\r
26592         PUSHJ   P,RETIF1\r
26593         MOVEI   A,"#\r
26594         PUSHJ   P,PITYO         ; SAY "FUNNY TYPE"\r
26595         MOVSI   A,TATOM\r
26596         MOVE    B,MQUOTE HANDLER\r
26597         PUSH    TP,-3(TP)       ; PUSH CHANNEL ON FOR IPRINT\r
26598         PUSH    TP,-3(TP)\r
26599         PUSHJ   P,IPRINT                ; PRINT THE TYPE NAME\r
26600         SUB     TP,[2,,2]               ; POP CHANNEL OFF STACK\r
26601         MOVE    B,-2(TP)        ; GET CHANNEL\r
26602         PUSHJ   P,SPACEQ                ; SPACE MAYBE\r
26603         SKIPN   B,(TP)          ; GET ARG BACK\r
26604         JRST    PNEXT\r
26605         MOVE    A,INTFCN(B)     ; PRINT FUNCTION FOR NOW\r
26606         MOVE    B,INTFCN+1(B)\r
26607         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT\r
26608         PUSH    TP,-3(TP)\r
26609         PUSHJ   P,IPRINT        ; PRINT THE INT FUNCTION\r
26610         SUB     TP,[2,,2]       ; POP CHANNEL OFF\r
26611         JRST    PNEXT\r
26612 \r
26613 ; PRINT INT HEADER\r
26614 \r
26615 PINTH:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26616         PUSHJ   P,RETIF1\r
26617         MOVEI   A,"#\r
26618         PUSHJ   P,PITYO\r
26619         MOVSI   A,TATOM         ; AND NAME\r
26620         MOVE    B,MQUOTE IHEADER\r
26621         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26622         PUSH    TP,-3(TP)\r
26623         PUSHJ   P,IPRINT\r
26624         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
26625         PUSHJ   P,SPACEQ        ; MAYBE SPACE\r
26626         SKIPN   B,-2(TP)                ; INT HEADER BACK\r
26627         JRST    PNEXT\r
26628         MOVE    A,INAME(B)      ; GET NAME\r
26629         MOVE    B,INAME+1(B)\r
26630         PUSHJ   P,IPRINT\r
26631         SUB     TP,[2,,2]       ; CLEAN OFF STACK\r
26632         JRST    PNEXT\r
26633 \r
26634 \r
26635 ; PRINT ASSOCIATION BLOCK\r
26636 \r
26637 ASSPNT: MOVEI   A,"(            ; MAKE IT BE (ITEN INDIC VAL)\r
26638         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26639         PUSHJ   P,PRETIF                ; MAKE ROOM AND PRINT\r
26640         SKIPA   C,[-3,,0]       ; # OF FIELDS\r
26641 ASSLP:  PUSHJ   P,SPACEQ\r
26642         MOVE    D,(TP)          ; RESTORE GOODIE\r
26643         ADD     D,ASSOFF(C)     ; POINT TO FIELD\r
26644         MOVE    A,(D)           ; GET IT\r
26645         MOVE    B,1(D)\r
26646         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26647         PUSH    TP,-3(TP)\r
26648         PUSHJ   P,IPRINT        ; AND PRINT IT\r
26649         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
26650         AOBJN   C,ASSLP\r
26651 \r
26652         MOVEI   A,")\r
26653         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26654         PUSHJ   P,PRETIF        ; CLOSE IT\r
26655         JRST    PNEXT\r
26656 \r
26657 ASSOFF: ITEM\r
26658         INDIC\r
26659         VAL\r
26660 \f; PRINT TYPE-C AND TYPE-W\r
26661 \r
26662 PTYPEW: HRRZ    A,(TP)  ; POSSIBLE RH\r
26663         HLRZ    B,(TP)\r
26664         MOVE    C,MQUOTE TYPE-W\r
26665         JRST    PTYPEX\r
26666 \r
26667 PTYPEC: HRRZ    B,(TP)\r
26668         MOVEI   A,0\r
26669         MOVE    C,MQUOTE TYPE-C\r
26670 \r
26671 PTYPEX: PUSH    P,B\r
26672         PUSH    P,A\r
26673         PUSH    TP,$TATOM\r
26674         PUSH    TP,C\r
26675         MOVEI   A,2\r
26676         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
26677         PUSHJ   P,RETIF         ; ROOM TO START?\r
26678         MOVEI   A,"%\r
26679         PUSHJ   P,PITYO\r
26680         MOVEI   A,"<\r
26681         PUSHJ   P,PITYO\r
26682         POP     TP,B            ; GET NAME\r
26683         POP     TP,A\r
26684         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26685         PUSH    TP,-3(TP)\r
26686         PUSHJ   P,IPRINT        ; AND PRINT IT AS 1ST ELEMENT\r
26687         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
26688         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26689         PUSHJ   P,SPACEQ        ; MAYBE SPACE\r
26690         MOVE    A,-1(P)         ; TYPE CODE\r
26691         ASH     A,1\r
26692         HRLI    A,(A)           ; MAKE SURE WINS\r
26693         ADD     A,TYPVEC+1(TVP)\r
26694         JUMPL   A,PTYPX1        ; JUMP FOR A WINNER\r
26695         PUSH    TP,$TATOM\r
26696         PUSH    TP,EQUOTE BAD-TYPE-CODE\r
26697         JRST    CALER1\r
26698 \r
26699 PTYPX1: MOVE    B,1(A)          ; GET TYPE NAME\r
26700         HRRZ    A,(A)           ; AND SAT\r
26701         ANDI    A,SATMSK\r
26702         MOVEM   A,-1(P)         ; AND SAVE IT\r
26703         MOVSI   A,TATOM\r
26704         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26705         PUSH    TP,-3(TP)\r
26706         PUSHJ   P,IPRINT        ; OUT IT GOES\r
26707         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
26708         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26709         PUSHJ   P,SPACEQ        ; MAYBE SPACE\r
26710         MOVE    A,-1(P)         ; GET SAT BACK\r
26711         MOVE    B,@STBL(A)\r
26712         MOVSI   A,TATOM         ; AND PRINT IT\r
26713         PUSH    TP,-3(TP)               ; GET CHANNEL FOR IPRINT\r
26714         PUSH    TP,-3(TP)\r
26715         PUSHJ   P,IPRINT\r
26716         SUB     TP,[2,,2]       ; POP OFF STACK\r
26717         SKIPN   B,(P)           ; ANY EXTRA CRAP?\r
26718         JRST    PTYPX2\r
26719 \r
26720         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26721         PUSHJ   P,SPACEQ\r
26722         MOVE    B,(P)\r
26723         MOVSI   A,TFIX\r
26724         PUSH    TP,-3(TP)       ; PUSH CHANNELS FOR IPRINT\r
26725         PUSH    TP,-3(TP)\r
26726         PUSHJ   P,IPRINT        ; PRINT EXTRA\r
26727         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
26728 \r
26729 PTYPX2: MOVEI   A,">\r
26730         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26731         PUSHJ   P,PRETIF\r
26732         SUB     P,[2,,2]        ; FLUSH CRUFT\r
26733         JRST    PNEXT\r
26734 \r
26735 \f; PRINT PURE CODE POINTER\r
26736 \r
26737 PPCODE: MOVEI   A,2\r
26738         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26739         PUSHJ   P,RETIF\r
26740         MOVEI   A,"%\r
26741         PUSHJ   P,PITYO\r
26742         MOVEI   A,"<\r
26743         PUSHJ   P,PITYO\r
26744         MOVSI   A,TATOM         ; PRINT SUBR CALL\r
26745         MOVE    B,MQUOTE PCODE\r
26746         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26747         PUSH    TP,-3(TP)\r
26748         PUSHJ   P,IPRINT\r
26749         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
26750         PUSHJ   P,SPACEQ        ; MAYBE SPACE?\r
26751         HLRZ    A,-2(TP)                ; OFFSET TO VECTOR\r
26752         ADD     A,PURVEC+1(TVP) ; SLOT TO A\r
26753         MOVE    A,(A)           ; SIXBIT NAME\r
26754         PUSH    P,FLAGS\r
26755         PUSHJ   P,6TOCHS        ; TO A STRING\r
26756         POP     P,FLAGS\r
26757         PUSHJ   P,IPRINT\r
26758         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
26759         PUSHJ   P,SPACEQ\r
26760         HRRZ    B,-2(TP)        ; GET OFFSET\r
26761         MOVSI   A,TFIX\r
26762         PUSHJ   P,IPRINT\r
26763         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
26764         MOVEI   A,">\r
26765         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26766         PUSHJ   P,PRETIF        ; CLOSE THE FORM\r
26767         JRST    PNEXT\r
26768 \r
26769 \r
26770 \f; PRINT SUB-ENTRY TO RSUBR\r
26771 \r
26772 PENTRY: MOVE    B,(TP)          ; GET BLOCK\r
26773         GETYP   A,(B)           ; TYPE OF 1ST ELEMENT\r
26774         CAIE    A,TRSUBR        ; RSUBR, OK\r
26775         JRST    PENT1\r
26776         MOVSI   A,TATOM         ; UNLINK\r
26777         HLLM    A,(B)\r
26778         MOVE    A,1(B)\r
26779         MOVE    A,3(A)\r
26780         MOVEM   A,1(B)\r
26781 PENT2:  MOVEI   A,2             ; CHECK ROOM\r
26782         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26783         PUSHJ   P,RETIF\r
26784         MOVEI   A,"%            ; SETUP READ TIME MACRO\r
26785         PUSHJ   P,PITYO\r
26786         MOVEI   A,"<\r
26787         PUSHJ   P,PITYO\r
26788         MOVSI   A,TATOM\r
26789         MOVE    B,MQUOTE RSUBR-ENTRY\r
26790         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26791         PUSH    TP,-3(TP)\r
26792         PUSHJ   P,IPRINT\r
26793         MOVE    B,-4(TP)\r
26794         PUSHJ   P,SPACEQ        ; MAYBE SPACE\r
26795         MOVEI   A,"'            ; QUOTE TO AVOID EVALING IT\r
26796         PUSHJ   P,PRETIF\r
26797         MOVSI   A,TVEC\r
26798         MOVE    B,-2(TP)\r
26799         PUSHJ   P,IPRINT\r
26800         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
26801         PUSHJ   P,SPACEQ\r
26802         MOVE    B,-2(TP)\r
26803         HRRZ    B,2(B)\r
26804         MOVSI   A,TFIX\r
26805         PUSHJ   P,IPRINT\r
26806         MOVEI   A,">\r
26807         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
26808         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26809         PUSHJ   P,PRETIF\r
26810         JRST    PNEXT\r
26811 \r
26812 PENT1:  CAIN    A,TATOM\r
26813         JRST    PENT2\r
26814         PUSH    TP,$TATOM\r
26815         PUSH    TP,EQUOTE BAD-ENTRY-BLOCK\r
26816         JRST    CALER1\r
26817 \r
26818 \f; HERE TO PRINT TEMPLATED DATA STRUCTURE\r
26819 \r
26820 TMPRNT: PUSH    P,FLAGS         ; SAVE FLAGS\r
26821         MOVE    A,(TP)          ; GET POINTER\r
26822         GETYP   A,(A)           ; GET SAT\r
26823         PUSH    P,A             ; AND SAVE IT\r
26824         MOVEI   A,"{            ; OPEN SQUIGGLE\r
26825         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26826         PUSHJ   P,PRETIF        ; PRINT WITH CHECKING\r
26827         HLRZ    A,(TP)          ; GET AMOUNT RESTED OFF\r
26828         SUBI    A,1\r
26829         PUSH    P,A             ; AND SAVE IT\r
26830         MOVE    A,-1(P)         ; GET SAT\r
26831         SUBI    A,NUMSAT+1      ; FIXIT UP\r
26832         HRLI    A,(A)\r
26833         ADD     A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE\r
26834         JUMPGE  A,BADTPL        ; COMPLAIN\r
26835         HRRZS   C,(TP)          ; GET LENGTH\r
26836         XCT     (A)             ;  INTO B\r
26837         SUB     B,(P)           ; FUDGE FOR RESTS\r
26838         MOVEI   B,-1(B)         ; FUDGE IT\r
26839         PUSH    P,B             ; AND SAVE IT\r
26840 \r
26841 TMPRN1: AOS     C,-1(P)         ; GET ELEMENT OF INTEREST\r
26842         SOSGE   (P)             ; CHECK FOR ANY LEFT\r
26843         JRST    TMPRN2          ; ALL DONE\r
26844 \r
26845         MOVE    B,(TP)          ; POINTER\r
26846         HRRZ    0,-2(P)         ; SAT\r
26847         PUSHJ   P,TMPLNT        ; GET THE ITEM\r
26848         MOVE    FLAGS,-3(P)     ; RESTORE FLAGS\r
26849         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
26850         PUSH    TP,-3(TP)\r
26851         PUSHJ   P,IPRINT        ; PRINT THIS ELEMENT\r
26852         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
26853         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
26854         SKIPE   (P)             ; IF NOT LAST ONE THEN\r
26855         PUSHJ   P,SPACEQ        ;   SEPARATE WITH A SPACE\r
26856         JRST    TMPRN1\r
26857 \r
26858 TMPRN2: SUB     P,[4,,4]\r
26859         MOVE    B,-2(TP)\r
26860         MOVEI   A,"}            ; CLOSE THIS GUY\r
26861         PUSHJ   P,PRETIF\r
26862         JRST    PNEXT\r
26863 \r
26864 \r
26865 \f; RSUBR PRINTING ROUTINES.  ON PRINTB CHANNELS, WRITES OUT\r
26866 ; COMPACT BINARY.  ON PRINT CHANNELS ALL IS ASCII\r
26867 \r
26868 PRSUBR: MOVE    A,(TP)          ; GET RSUBR IN QUESTION\r
26869         GETYP   A,(A)           ; CHECK FOR PURE RSUBR\r
26870         CAIN    A,TPCODE\r
26871         JRST    PRSBRP          ; PRINT IT SPECIAL WAY\r
26872 \r
26873         TLNN    FLAGS,BINBIT    ; SKIP IF BINARY OUTPUT\r
26874         JRST    ARSUBR\r
26875 \r
26876         PUSH    P,FLAGS\r
26877         MOVSI   A,TRSUBR        ; FIND FIXUPS\r
26878         MOVE    B,(TP)\r
26879         HLRE    D,1(B)          ; -LENGTH OF CODE VEC\r
26880         PUSH    P,D             ; SAVE SAME\r
26881         MOVSI   C,TATOM\r
26882         MOVE    D,MQUOTE RSUBR\r
26883         PUSHJ   P,IGET          ; GO GET THEM\r
26884         JUMPE   B,RCANT         ; NO FIXUPS, BINARY LOSES\r
26885         PUSH    TP,A            ; SAVE FIXUP LIST\r
26886         PUSH    TP,B\r
26887 \r
26888         MOVNI   A,1             ; USE ^C AS MARKER FOR RSUBR\r
26889         MOVE    FLAGS,-1(P)     ; RESTORE FLAGS\r
26890         MOVE    B,-4(TP)        ; GET CHANNEL FOR PITYO\r
26891                 PUSHJ   P,PITYO         ; OUT IT GOES\r
26892 \r
26893 PRSBR1:         MOVE    B,-4(TP)\r
26894         PUSHJ   P,BFCLS1        ; FLUSH OUT CURRENT BUFFER\r
26895 \r
26896         MOVE    B,-4(TP)                ; CHANNEL BACK\r
26897         MOVN    E,(P)           ; LENGTH OF CODE\r
26898         PUSH    P,E\r
26899         HRROI   A,(P)           ; POINT TO SAME\r
26900         PUSHJ   P,DOIOTO        ; OUT GOES COUNT\r
26901         MOVSI   C,TCODE\r
26902         MOVEM   C,ASTO(PVP)     ; FOR IOT INTERRUPTS\r
26903         MOVE    A,-2(TP)        ; GET POINTER TO CODE\r
26904         MOVE    A,1(A)\r
26905         PUSHJ   P,DOIOTO        ; IOT IT OUT\r
26906         POP     P,E\r
26907         ADDI    E,1             ; UPDATE ACCESS\r
26908         ADDM    E,ACCESS(B)\r
26909         SETZM   ASTO(PVP)       ; UNSCREW A\r
26910 \r
26911 ; NOW PRINT OUT NORMAL RSUBR VECTOR\r
26912 \r
26913         MOVE    FLAGS,-1(P)     ; RESTORE FLAGS\r
26914         SUB     P,[1,,1]\r
26915         MOVE    B,-2(TP)        ; GET RSUBR VECTOR\r
26916         PUSHJ   P,PRBODY        ; PRINT ITS BODY\r
26917 \r
26918 ; HERE TO PRINT BINARY FIXUPS\r
26919 \r
26920         MOVEI   E,0             ; 1ST COMPUTE LENGTH OF FIXUPS\r
26921         SKIPN   A,(TP)  ; LIST TO A\r
26922         JRST    PRSBR5          ; EMPTY, DONE\r
26923         JUMPL   A,UFIXES        ; JUMP IF FIXUPS IN UVECTOR FORM\r
26924         ADDI    E,1             ; FOR VERS\r
26925 \r
26926 PRSBR6: HRRZ    A,(A)           ; NEXT?\r
26927         JUMPE   A,PRSBR5\r
26928         GETYP   B,(A)\r
26929         CAIE    B,TDEFER        ; POSSIBLE STRING\r
26930         JRST    PRSBR7          ; COULD BE ATOM\r
26931         MOVE    B,1(A)          ; POSSIBLE STRINGER\r
26932         GETYP   C,(B)\r
26933         CAIE    C,TCHSTR        ; YES!!!\r
26934         JRST    BADFXU          ; LOSING FIXUPS\r
26935         HRRZ    C,(B)           ; # OF CHARS TO C\r
26936         ADDI    C,5+5           ; ROUND AND ADD FOR COUNT\r
26937         IDIVI   C,5             ; TO WORDS\r
26938         ADDI    E,(C)\r
26939         JRST    FIXLST          ; COUNT FOR USE LIST ETC.\r
26940 \r
26941 PRSBR7: GETYP   B,(A)           ; GET TYPE\r
26942         CAIE    B,TATOM\r
26943         JRST    BADFXU\r
26944         ADDI    E,1\r
26945 \r
26946 FIXLST: HRRZ    A,(A)           ; REST IT TO OLD VAL\r
26947         JUMPE   A,BADFXU\r
26948         GETYP   B,(A)           ; FIX?\r
26949         CAIE    B,TFIX\r
26950         JRST    BADFXU\r
26951         MOVEI   D,1\r
26952         HRRZ    A,(A)           ; TO USE LIST\r
26953         JUMPE   A,BADFXU\r
26954         GETYP   B,(A)\r
26955         CAIE    B,TLIST\r
26956         JRST    BADFXU          ; LOSER\r
26957         MOVE    C,1(A)          ; GET LIST\r
26958 \r
26959 PRSBR8: JUMPE   C,PRSBR9\r
26960         GETYP   B,(C)           ; TYPE OK?\r
26961         CAIE    B,TFIX\r
26962         JRST    BADFXU\r
26963         HRRZ    C,(C)\r
26964         AOJA    D,PRSBR8        ; LOOP\r
26965 \r
26966 PRSBR9: ADDI    D,2             ; ROUND UP\r
26967         ASH     D,-1            ; DIV BY 2 FOR TWO GOODIES PER HWORD\r
26968         ADDI    E,(D)\r
26969         JRST    PRSBR6\r
26970 \r
26971 PRSBR5: PUSH    P,E             ; SAVE LENGTH OF FIXUPS\r
26972         PUSH    TP,$TUVEC       ; SLOT FOR BUFFER POINTER\r
26973         PUSH    TP,[0]\r
26974 \r
26975 PFIXU1: MOVE    B,-6(TP)                ; START LOOPING THROUGH CHANNELS\r
26976         PUSHJ   P,BFCLS1        ; FLUSH BUFFER\r
26977         MOVE    B,-6(TP)                ; CHANNEL BACK\r
26978         MOVEI   C,BUFSTR-1(B)   ; SETUP BUFFER\r
26979         PUSHJ   P,BYTDOP        ; FIND D.W.\r
26980         SUBI    A,BUFLNT+1\r
26981         HRLI    A,-BUFLNT\r
26982         MOVEM   A,(TP)\r
26983         MOVE    E,(P)           ; LENGTH OF FIXUPS\r
26984         SETZB   C,D             ; FOR EOUT\r
26985         PUSHJ   P,EOUT\r
26986         MOVE    C,-2(TP)        ; FIXUP LIST\r
26987         MOVE    E,1(C)          ; HAVE VERS\r
26988         PUSHJ   P,EOUT          ; OUT IT GOES\r
26989 \r
26990 PFIXU2: HRRZ    C,(C)           ; FIRST THING\r
26991         JUMPE   C,PFIXU3        ; DONE?\r
26992         GETYP   A,(C)           ; STRING OR ATOM\r
26993         CAIN    A,TATOM         ; MUST BE STRING\r
26994         JRST    PFIXU4\r
26995         MOVE    A,1(C)          ; POINT TO POINTER\r
26996         HRRZ    D,(A)           ; LENGTH\r
26997         IDIVI   D,5\r
26998         PUSH    P,E             ; SAVE REMAINDER\r
26999         MOVEI   E,1(D)\r
27000         MOVNI   D,(D)\r
27001         MOVSI   D,(D)\r
27002         PUSH    P,D\r
27003         PUSHJ   P,EOUT\r
27004         MOVEI   D,0\r
27005 PFXU1A: MOVE    A,1(C)          ; RESTORE POINTER\r
27006         HRRZ    A,1(A)          ; BYTE POINTER\r
27007         ADD     A,(P)\r
27008         MOVE    E,(A)\r
27009         PUSHJ   P,EOUT\r
27010         MOVE    A,[1,,1]\r
27011         ADDB    A,(P)\r
27012         JUMPL   A,PFXU1A\r
27013         MOVE    D,-1(P)         ; LAST WORD\r
27014         MOVE    A,1(C)\r
27015         HRRZ    A,1(A)\r
27016         ADD     A,(P)\r
27017         SKIPE   E,D\r
27018         MOVE    E,(A)           ; LAST WORD OF CHARS\r
27019         IOR     E,PADS(D)\r
27020         PUSHJ   P,EOUT          ; OUT\r
27021         SUB     P,[1,,1]\r
27022         JRST    PFIXU5\r
27023 \r
27024 PADS:   ASCII /#####/\r
27025         ASCII /####/\r
27026         ASCII /\ 2###/\r
27027         ASCII /\ 2##/\r
27028         ASCII /\ 2\ 2#/\r
27029 \r
27030 PFIXU4: HRRZ    E,(C)           ; GET CURRENT VAL\r
27031         MOVE    E,1(E)\r
27032         PUSHJ   P,ATOSQ         ; GET SQUOZE\r
27033         JRST    BADFXU\r
27034         TLO     E,400000        ; USE TO DIFFERENTIATE BETWEEN STRING\r
27035         PUSHJ   P,EOUT\r
27036 \r
27037 ; HERE TO WRITE OUT LISTS\r
27038 \r
27039 PFIXU5: HRRZ    C,(C)           ; POINT TO CURRENT VALUE\r
27040         HRLZ    E,1(C)\r
27041         HRRZ    C,(C)           ; POINT TO USES LIST\r
27042         HRRZ    D,1(C)          ; GET IT\r
27043 \r
27044 PFIXU6: TLCE    D,400000        ; SKIP FOR RH\r
27045         HRLZ    E,1(D)          ; SETUP LH\r
27046         JUMPG   D,.+3\r
27047         HRR     E,1(D)\r
27048         PUSHJ   P,EOUT          ; WRITE IT OUT\r
27049         HRR     D,(D)\r
27050         TRNE    D,-1            ; SKIP IF DONE\r
27051         JRST    PFIXU6\r
27052 \r
27053         TRNE    E,-1            ; SKIP IF ZERO BYTE EXISTS\r
27054         MOVEI   E,0\r
27055         PUSHJ   P,EOUT\r
27056         JRST    PFIXU2          ; DO NEXT\r
27057 \r
27058 PFIXU3: HLRE    C,(TP)          ; -AMNT LEFT IN BUFFER\r
27059         MOVN    D,C             ; PLUS SAME\r
27060         ADDI    C,BUFLNT        ; WORDS USED TO C\r
27061         JUMPE   C,PFIXU7        ; NONE USED, LEAVE\r
27062         MOVSS   C               ; START SETTING UP BTB\r
27063         MOVN    A,C             ; ALSO FINAL IOT POINTER\r
27064         HRR     C,(TP)          ; PDL POINTER PART OF BTB\r
27065         SUBI    C,1\r
27066         HRLI    D,C             ; CONTINUE SETTING UP BTB\r
27067         POP     C,@D            ; MOVE 'EM DOWN\r
27068         TLNE    C,-1\r
27069         JRST    .-2\r
27070         HRRI    A,@D            ; OUTPUT POINTER\r
27071         ADDI    A,1\r
27072         MOVSI   B,TUVEC\r
27073         MOVEM   B,ASTO(PVP)\r
27074         MOVE    B,-6(TP)\r
27075         PUSHJ   P,DOIOTO        ; WRITE IT OUT\r
27076         SETZM   ASTO(PVP)\r
27077 \r
27078 PFIXU7:         SUB     TP,[4,,4]\r
27079         SUB     P,[2,,2]\r
27080         JRST    PNEXT\r
27081 \r
27082 ; ROUTINE TO OUTPUT CONTENTS OF E\r
27083 \r
27084 EOUT:   MOVE    B,-6(TP)        ; CHANNEL\r
27085         AOS     ACCESS(B)\r
27086         MOVE    A,(TP)          ; BUFFER POINTER\r
27087         MOVEM   E,(A)\r
27088         AOBJP   A,.+3           ; COUNT AND GO\r
27089         MOVEM   A,(TP)\r
27090         POPJ    P,\r
27091 \r
27092         SUBI    A,BUFLNT        ; SET UP IOT POINTER\r
27093         HRLI    A,-BUFLNT\r
27094         MOVEM   A,(TP)          ; RESET SAVED POINTER\r
27095         MOVSI   0,TUVEC\r
27096         MOVEM   0,ASTO(PVP)\r
27097         MOVSI   0,TLIST\r
27098         MOVEM   0,DSTO(PVP)\r
27099         MOVEM   0,CSTO(PVP)\r
27100         PUSHJ   P,DOIOTO        ; OUT IT GOES\r
27101         SETZM   ASTO(PVP)\r
27102         SETZM   CSTO(PVP)\r
27103         SETZM   DSTO(PVP)\r
27104         POPJ    P,\r
27105 \r
27106 ; HERE IF UVECOR FORM OF FIXUPS\r
27107 \r
27108 UFIXES: PUSH    TP,$TUVEC\r
27109         PUSH    TP,A            ; SAVE IT\r
27110 \r
27111 UFIX1:          MOVE    B,-6(TP)                ; GET SAME\r
27112         PUSHJ   P,BFCLS1        ; FLUSH OUT BUFFER\r
27113         HLRE    C,(TP)  ; GET LENGTH\r
27114         MOVMS   C\r
27115         PUSH    P,C\r
27116         HRROI   A,(P)           ; READY TO ZAP IT OUT\r
27117         PUSHJ   P,DOIOTO        ; ZAP!\r
27118         SUB     P,[1,,1]\r
27119         HLRE    C,(TP)          ; LENGTH BACK\r
27120         MOVMS   C\r
27121         ADDI    C,1\r
27122         ADDM    C,ACCESS(B)     ; UPDATE ACCESS\r
27123         MOVE    A,(TP)          ; NOW THE UVECTOR\r
27124         MOVSI   C,TUVEC\r
27125         MOVEM   C,ASTO(PVP)\r
27126         PUSHJ   P,DOIOTO        ; GO\r
27127         SETZM   ASTO(PVP)\r
27128         SUB     P,[1,,1]\r
27129         SUB     TP,[4,,4]\r
27130         JRST    PNEXT\r
27131 \r
27132 RCANT:  PUSH    TP,$TATOM\r
27133         PUSH    TP,EQUOTE RSUBR-LACKS-FIXUPS\r
27134         JRST    CALER1\r
27135 \r
27136 \r
27137 BADFXU: PUSH    TP,$TATOM\r
27138         PUSH    TP,EQUOTE BAD-FIXUPS\r
27139         JRST    CALER1\r
27140 \r
27141 PRBODY: TDZA    C,C             ; FLAG SAYING FLUSH CODE\r
27142 PRBOD1: MOVEI   C,1             ; PRINT CODE ALSO\r
27143         PUSH    P,FLAGS\r
27144         PUSH    TP,$TRSUBR\r
27145         PUSH    TP,B\r
27146         PUSH    P,C\r
27147         MOVEI   A,"[            ; START VECTOR TEXT\r
27148         MOVE    B,-6(TP)        ; GET CHANNEL FOR PITYO\r
27149         PUSHJ   P,PITYO\r
27150         POP     P,C\r
27151         MOVE    B,(TP)          ; RSUBR BACK\r
27152         JUMPN   C,PRSON         ; GO START PRINTING\r
27153         MOVEI   A,"0            ; PLACE SAVER FOR CODE VEC\r
27154         MOVE    B,-6(TP)        ; GET CHANNEL FOR PITYO\r
27155         PUSHJ   P,PITYO\r
27156 \r
27157 PRSBR2: MOVE    B,[2,,2]        ; BUMP VECTOR\r
27158         ADDB    B,(TP)\r
27159         JUMPGE  B,PRSBR3        ; NO SPACE IF LAST\r
27160         MOVE    B,-6(TP)        ; GET CHANNEL FOR SPACEQ\r
27161         PUSHJ   P,SPACEQ\r
27162         SKIPA   B,(TP)          ; GET BACK POINTER\r
27163 PRSON:  JUMPGE  B,PRSBR3\r
27164         GETYP   0,(B)           ; SEE IF RSUBR POINTED TO\r
27165         CAIN    0,TENTER\r
27166         JRST    .+3             ; JUMP IF RSUBR ENTRY\r
27167         CAIE    0,TRSUBR        ; YES!\r
27168         JRST    PRSB10          ; COULD BE SUBR/FSUBR\r
27169         MOVE    C,1(B)          ; GET RSUBR\r
27170         PUSH    P,0             ; SAVE TYPE FOUND\r
27171         GETYP   0,2(C)          ; SEE IF ATOM\r
27172         CAIE    0,TATOM\r
27173         JRST    PRSBR4\r
27174         MOVE    B,3(C)          ; GET ATOM NAME\r
27175         PUSHJ   P,IGVAL         ; GO LOOK\r
27176         MOVE    C,(TP)          ; ORIG RSUBR BACK\r
27177         GETYP   A,A\r
27178         POP     P,0             ; DESIRED TYPE\r
27179         CAIE    0,(A)           ; SAME TYPE\r
27180         JRST    PRSBR4\r
27181         MOVE    D,1(C)\r
27182         MOVE    0,3(D)          ; NAME OF RSUBR IN QUESTION\r
27183         CAME    0,3(B)          ; WIN?\r
27184         JRST    PRSBR4\r
27185         MOVEM   0,1(C)\r
27186         MOVSI   A,TATOM\r
27187         MOVEM   A,(C)           ; UNLINK\r
27188 \r
27189 PRSBR4: MOVE    FLAGS,(P)       ; RESTORE FLAGS\r
27190         MOVE    B,(TP)\r
27191         MOVE    A,(B)\r
27192         MOVE    B,1(B)          ; PRINT IT\r
27193         PUSH    TP,-7(TP)       ; PUSH CHANNEL FOR IPRINT\r
27194         PUSH    TP,-7(TP)\r
27195         PUSHJ   P,IPRINT\r
27196         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
27197         JRST    PRSBR2\r
27198 \r
27199 PRSB10: CAIE    0,TSUBR         ; SUBR?\r
27200         CAIN    0,TFSUBR\r
27201         JRST    .+2\r
27202         JRST    PRSBR4\r
27203         MOVE    C,1(B)          ; GET LOCN OF SUBR OR FSUBR\r
27204         MOVE    C,@-1(C)        ; NAME OF IT\r
27205         MOVEM   C,1(B)          ; SMASH\r
27206         MOVSI   C,TATOM         ; AND TYPE\r
27207         MOVEM   C,(B)\r
27208         JRST    PRSBR4\r
27209 \r
27210 PRSBR3: MOVEI   A,"]\r
27211         MOVE    B,-6(TP)\r
27212         PUSHJ   P,PRETIF        ; CLOSE IT UP\r
27213         SUB     TP,[2,,2]       ; FLUSH CRAP\r
27214         POP     P,FLAGS\r
27215         POPJ    P,\r
27216 \r
27217 \r
27218 \f; HERE TO PRINT PURE RSUBRS\r
27219 \r
27220 PRSBRP: MOVEI   A,2             ; WILL "%<" FIT?\r
27221         MOVE    B,-2(TP)        ; GET CHANNEL FOR RETIF\r
27222         PUSHJ   P,RETIF\r
27223         MOVEI   A,"%\r
27224         PUSHJ   P,PITYO\r
27225         MOVEI   A,"<\r
27226         PUSHJ   P,PITYO\r
27227         MOVSI   A,TATOM\r
27228         MOVE    B,MQUOTE RSUBR\r
27229         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
27230         PUSH    TP,-3(TP)\r
27231         PUSHJ   P,IPRINT        ; PRINT IT OUT\r
27232         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
27233         MOVE    B,-2(TP)\r
27234         PUSHJ   P,SPACEQ        ; MAYBE SPACE\r
27235         MOVEI   A,"'            ; QUOTE THE VECCTOR\r
27236         PUSHJ   P,PRETIF\r
27237         MOVE    B,(TP)          ; GET RSUBR BODY BACK\r
27238         PUSH    TP,$TFIX                ; STUFF THE STACK\r
27239         PUSH    TP,[0]\r
27240         PUSHJ   P,PRBOD1        ; PRINT AND UNLINK\r
27241         SUB     TP,[2,,2]       ; GET JUNK OFF STACK\r
27242         MOVE    B,-2(TP)        ; GET CHANNEL FOR RETIF\r
27243         MOVEI   A,">\r
27244         PUSHJ   P,PRETIF\r
27245         JRST    PNEXT\r
27246 \r
27247 ; HERE TO PRINT ASCII RSUBRS\r
27248 \r
27249 ARSUBR: PUSH    P,FLAGS         ; SAVE FROM GET\r
27250         MOVSI   A,TRSUBR\r
27251         MOVE    B,(TP)\r
27252         MOVSI   C,TATOM\r
27253         MOVE    D,MQUOTE RSUBR\r
27254         PUSHJ   P,IGET          ; TRY TO GET FIXUPS\r
27255         POP     P,FLAGS\r
27256         JUMPE   B,PUNK          ; NO FIXUPS LOSE\r
27257         GETYP   A,A\r
27258         CAIE    A,TLIST         ; ARE FIXUPS A LIST?\r
27259         JRST    PUNK            ; NO, AGAIN LOSE\r
27260         PUSH    TP,$TLIST\r
27261         PUSH    TP,B            ; SAVE FIXUPS\r
27262         MOVEI   A,17.\r
27263 \r
27264         MOVE    B,-4(TP)\r
27265         PUSHJ   P,RETIF\r
27266         PUSH    P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]\r
27267 \r
27268 AL1:    ILDB    A,(P)           ; GET CHAR\r
27269         JUMPE   A,.+3\r
27270         PUSHJ   P,PITYO\r
27271         JRST    AL1\r
27272 \r
27273         SUB     P,[1,,1]\r
27274         PUSHJ   P,SPACEQ\r
27275 \r
27276         MOVEI   A,"'\r
27277         PUSHJ   P,PRETIF        ; QUOTE TO AVOID ADDITIONAL EVAL\r
27278         MOVE    B,-2(TP)        ; PRINT ACTUAL KLUDGE\r
27279         PUSHJ   P,PRBOD1\r
27280         MOVE    B,-4(TP)        ; GET CHANNEL FOR SPACEQ\r
27281         PUSHJ   P,SPACEQ\r
27282         MOVEI   A,"'            ; DONT EVAL FIXUPS EITHER\r
27283         PUSHJ   P,PRETIF\r
27284         POP     TP,B\r
27285         POP     TP,A\r
27286         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
27287         PUSH    TP,-3(TP)\r
27288         PUSHJ   P,IPRINT\r
27289         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
27290         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27291         MOVEI   A,">\r
27292         PUSHJ   P,PRETIF\r
27293         JRST    PNEXT\r
27294 \r
27295 \f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)\r
27296 \r
27297 LOCP:   PUSH    TP,-1(TP)\r
27298         PUSH    TP,-1(TP)\r
27299         PUSH    P,0\r
27300         MCALL   1,IN            ; GET ITS CONTENTS FROM "IN"\r
27301         POP     P,0\r
27302         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
27303         PUSH    TP,-3(TP)\r
27304         PUSHJ   P,IPRINT        ; PRINT IT\r
27305         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
27306         JRST    PNEXT\r
27307 \f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT\r
27308 ;B CONTAINS CHANNEL\r
27309 ;PRINTER ITYO USED FOR FLATSIZE FAKE OUT\r
27310 PITYO:  TLNN    FLAGS,FLTBIT\r
27311         JRST    ITYO\r
27312 PITYO1: PUSH    TP,[TTP,,0]     ; PUSH ON TP POINTER\r
27313         PUSH    TP,B\r
27314         TLNE    FLAGS,UNPRSE    ;SKIPS UNPRSE NOT SET\r
27315         JRST    ITYO+2\r
27316         AOS     FLTSIZ  ;FLATSIZE DOESN'T PRINT\r
27317                         ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT\r
27318         SOSGE   FLTMAX  ;UNLESS THE MAXIMUM IS EXCEEDED\r
27319         JRST    .+4\r
27320         POP     TP,B            ; GET CHANNEL BACK\r
27321         SUB     TP,[1,,1]\r
27322         POPJ    P,\r
27323         MOVEI   E,(B)           ; GET POINTER FOR UNBINDING\r
27324         PUSHJ   P,SSPEC1\r
27325         MOVE    P,UPB+8         ; RESTORE P\r
27326         POP     TP,B            ; GET BACK TP POINTER\r
27327         PUSH    P,0             ; SAVE FLAGS\r
27328         MOVE    TP,B            ; RESTORE TP\r
27329 PITYO3: MOVEI   C,(TB)\r
27330         CAILE   C,1(TP)\r
27331         JRST    PITYO2\r
27332         POP     P,0             ; RESTORE FLAGS\r
27333         MOVSI   A,TFALSE        ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE\r
27334         MOVEI   B,0\r
27335         POPJ    P,\r
27336 \r
27337 PITYO2: HRR     TB,OTBSAV(TB)   ; RESTORE TB\r
27338         JRST    PITYO3\r
27339 \r
27340 \r
27341 \f;THE REAL THING\r
27342 ;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG\r
27343 ;CHARACTER STRINGS\r
27344 ; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)\r
27345 ITYO:   PUSH    TP,$TCHAN\r
27346         PUSH    TP,B\r
27347         PUSH    P,FLAGS         ;SAVE STUFF\r
27348         PUSH    P,C\r
27349 ITYOCH: PUSH    P,A             ;SAVE OUTPUT CHARACTER\r
27350 \r
27351 \r
27352 ITYO1:  TLNE    FLAGS,UNPRSE    ;SKIPS UNPRSE NOT SET\r
27353         JRST    UNPROUT         ;IF FROM UNPRSE, STASH IN STRING\r
27354         CAIE    A,^L            ;SKIP IF THIS IS A FORM-FEED\r
27355         JRST    NOTFF\r
27356         SETZM   LINPOS(B)       ;ZERO THE LINE NUMBER\r
27357         JRST    ITYXT\r
27358 \r
27359 NOTFF:  CAIE    A,15            ;SKIP IF IT IS A CR\r
27360         JRST    NOTCR\r
27361         SETZM   CHRPOS(B)       ;ZERO THE CHARACTER POSITION\r
27362         PUSHJ   P,WXCT          ;OUTPUT THE C-R\r
27363         PUSHJ   P,AOSACC        ; BUMP COUNT\r
27364         AOS     C,LINPOS(B)     ;ADD ONE TO THE LINE NUMBER\r
27365         CAMG    C,PAGLN(B)      ;SKIP IF THIS TAKES US PAST PAGE END\r
27366         JRST    ITYXT1\r
27367 \r
27368         SETZM   LINPOS(B)       ;ZERO THE LINE POSITION\r
27369 ;       PUSHJ   P,WXCT          ; REMOVED FOR NOW\r
27370 ;       PUSHJ   P,AOSACC\r
27371 ;       MOVEI   A,^L            ; DITTO\r
27372         JRST    ITYXT1\r
27373 \r
27374 NOTCR:  CAIN    A,^I            ;SKIP IF NOT TAB\r
27375         JRST    TABCNT\r
27376         CAIE    A,10            ; BACK SPACE\r
27377         JRST    .+3\r
27378         SOS     CHRPOS(B)       ; BACK UP ONE\r
27379         JRST    ITYXT\r
27380         CAIE    A,^J            ;SKIP IF LINE FEED\r
27381         AOS     CHRPOS(B)       ;ADD TO CHARACTER NUMBER\r
27382 \r
27383 ITYXT:  PUSHJ   P,AOSACC        ; BUMP ACCESS\r
27384 ITYXTA: PUSHJ   P,WXCT          ;OUTPUT THE CHARACTER\r
27385 ITYXT1: POP     P,A             ;RESTORE THE ORIGINAL CHARACTER\r
27386 \r
27387 ITYRET: POP     P,C             ;RESTORE REGS & RETURN\r
27388         POP     P,FLAGS\r
27389         POP     TP,B            ; GET CHANNEL BACK\r
27390         SUB     TP,[1,,1]\r
27391         POPJ    P,\r
27392 \r
27393 TABCNT: PUSH    P,D\r
27394         MOVE    C,CHRPOS(B)\r
27395         ADDI    C,8.            ;INCREMENT COUNT BY EIGHT (MOD EIGHT)\r
27396         IDIVI   C,8.\r
27397         IMULI   C,8.\r
27398         MOVEM   C,CHRPOS(B)     ;REPLACE COUNT\r
27399         POP     P,D\r
27400         JRST    ITYXT\r
27401 \r
27402 UNPROUT: POP    P,A     ;GET BACK THE ORIG CHAR\r
27403         IDPB    A,UPB+2         ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO\r
27404         SOS     UPB+1\r
27405         JRST    ITYRET  ;RETURN\r
27406 \r
27407 AOSACC: TLNN    FLAGS,BINBIT\r
27408         JRST    NRMACC\r
27409         AOS     C,ACCESS-1(B)   ; COUNT CHARS IN WORD\r
27410         CAMN    C,[TFIX,,1]\r
27411         AOS     ACCESS(B)\r
27412         CAMN    C,[TFIX,,5]\r
27413         HLLZS   ACCESS-1(B)\r
27414         POPJ    P,\r
27415 \r
27416 NRMACC: AOS     ACCESS(B)\r
27417         POPJ    P,\r
27418 \r
27419 SPACEQ: MOVEI   A,40\r
27420         TLNE    FLAGS,FLTBIT+BINBIT\r
27421         JRST    PITYO           ; JUST OUTPUT THE SPACE\r
27422         PUSH    P,[1]           ; PRINT SPACE IF NOT END OF LINE\r
27423         MOVEI   A,1\r
27424         JRST    RETIF2\r
27425 \r
27426 RETIF1: MOVEI   A,1\r
27427 \r
27428 RETIF:  PUSH    P,[0]\r
27429         TLNE    FLAGS,FLTBIT+BINBIT\r
27430         JRST    SPOPJ           ; IF WE ARE IN FLATSIZE THEN ESCAPE\r
27431 RETIF2: PUSH    P,FLAGS\r
27432 RETCH:  PUSH    P,A\r
27433 \r
27434 RETCH1: ADD     A,CHRPOS(B)     ;ADD THE CHARACTER POSITION\r
27435         SKIPN   CHRPOS(B)       ; IF JUST RESET, DONT DO IT AGAIN\r
27436         JRST    RETXT\r
27437         CAMG    A,LINLN(B)      ;SKIP IF GREATER THAN LINE LENGTH\r
27438         JRST    RETXT1\r
27439 \r
27440         MOVEI   A,^M    ;FORCE A CARRIAGE RETURN\r
27441         SETZM   CHRPOS(B)\r
27442         PUSHJ   P,WXCT\r
27443         PUSHJ   P,AOSACC        ; BUMP CHAR COUNT\r
27444         MOVEI   A,^J    ;AND FORCE A LINE FEED\r
27445         PUSHJ   P,WXCT\r
27446         PUSHJ   P,AOSACC        ; BUMP CHAR COUNT\r
27447         AOS     A,LINPOS(B)\r
27448         CAMG    A,PAGLN(B)      ;AT THE END OF THE PAGE ?\r
27449         JRST    RETXT\r
27450 ;       MOVEI   A,^L    ;IF SO FORCE A FORM FEED\r
27451 ;       PUSHJ   P,WXCT\r
27452 ;       PUSHJ   P,AOSACC        ; BUMP CHAR COUNT\r
27453         SETZM   LINPOS(B)\r
27454 \r
27455 RETXT:  POP     P,A\r
27456 \r
27457         POP     P,FLAGS\r
27458 SPOPJ:  SUB     P,[1,,1]\r
27459         POPJ    P,      ;RETURN\r
27460 \r
27461 PRETIF: PUSH    P,A     ;SAVE CHAR\r
27462         PUSHJ   P,RETIF1\r
27463         POP     P,A\r
27464         JRST    PITYO\r
27465 \r
27466 RETIF3: TLNE    FLAGS,FLTBIT    ; NOTHING ON FLATSIZE\r
27467         POPJ    P,\r
27468         PUSH    P,[0]\r
27469         PUSH    P,FLAGS\r
27470         HRRI    FLAGS,2         ; PRETEND ONLY 1 CHANNEL\r
27471         PUSH    P,A\r
27472         JRST    RETCH1\r
27473 \r
27474 RETXT1: SKIPN   -2(P)           ; SKIP IF SPACE HACK\r
27475         JRST    RETXT\r
27476         MOVEI   A,40\r
27477         PUSHJ   P,WXCT\r
27478         AOS     CHRPOS(B)\r
27479         PUSH    P,C\r
27480         PUSHJ   P,AOSACC\r
27481         POP     P,C\r
27482         JRST    RETXT\r
27483 \r
27484 \f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.\r
27485 ;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE\r
27486 ;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.\r
27487 PRERR:  MOVEI   A,21.   ;CHECK FOR 21. SPACES LEFT ON PRINT LINE\r
27488         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27489         PUSHJ   P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH\r
27490         MOVEI   A,"*    ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL\r
27491         PUSHJ   P,PITYO ;TYPE IT\r
27492 \r
27493         MOVE    E,[000300,,-2(TP)]      ;GET POINTER INDEXED OFF TP SO THAT\r
27494                                 ;TYPE CODE MAY BE OBTAINED FOR PRINTING.\r
27495         MOVEI   D,6     ;# OF OCTAL DIGITS IN HALF WORD\r
27496 OCTLP1: ILDB    A,E     ;GET NEXT 3-BIT BYTE OF TYPE CODE\r
27497         IORI    A,60    ;OR-IN 60 FOR ASCII DIGIT\r
27498         PUSHJ   P,PITYO ;PRINT IT\r
27499         SOJG    D,OCTLP1        ;REPEAT FOR SIX CHARACTERS\r
27500 \r
27501 PRE01:  MOVEI   A,"*    ;DELIMIT TYPE CODE FROM VALUE FIELD\r
27502         PUSHJ   P,PITYO\r
27503 \r
27504         HRLZI   E,(410300,,(TP))        ;BYTE POINTER TO SECOND WORD\r
27505                                 ;INDEXED OFF TP\r
27506         MOVEI   D,12.   ;# OF OCTAL DIGITS IN A WORD\r
27507 OCTLP2: LDB     A,E     ;GET 3 BITS\r
27508         IORI    A,60    ;CONVERT TO ASCII\r
27509         PUSHJ   P,PITYO ;PRINT IT\r
27510         IBP     E       ;INCREMENT POINTER TO NEXT BYTE\r
27511         SOJG    D,OCTLP2        ;REPEAT FOR 12. CHARS\r
27512 \r
27513         MOVEI   A,"*    ;DELIMIT END OF ERROR TYPEOUT\r
27514         PUSHJ   P,PITYO ;REPRINT IT\r
27515 \r
27516         JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
27517 \r
27518 POCTAL: MOVEI   A,14.   ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT\r
27519         MOVE    B,-2(TP)                ; GET CHANNEL INTO B\r
27520         PUSHJ   P,RETIF\r
27521         JRST    PRE01   ;PRINT VALUE AS "*XXXXXXXXXXXX*"\r
27522 \r
27523 \f;PRINT BINARY INTEGERS IN DECIMAL.\r
27524 ;\r
27525 PFIX:   MOVM    E,(TP)          ; GET # (MAFNITUDE)\r
27526         JUMPL   E,POCTAL        ; IF ABS VAL IS NEG, MUST BE SETZ\r
27527         PUSH    P,FLAGS\r
27528 \r
27529 PFIX1:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27530 PFIX2:  MOVE    D,UPB+6         ; IF UNPARSE, THIS IS RADIX\r
27531         TLNE    FLAGS,UNPRSE+FLTBIT     ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE\r
27532         JRST    PFIXU\r
27533         MOVE    D,RADX(B)       ; GET OUTPUT RADIX\r
27534 PFIXU:  CAIG    D,1             ; DONT ALLOW FUNNY RADIX\r
27535         MOVEI   D,10.           ; IF IN DOUBT USE 10.\r
27536         PUSH    P,D\r
27537         MOVEI   A,1             ; START A COUNTER\r
27538         SKIPGE  B,(TP)          ; CHECK SIGN\r
27539         MOVEI   A,2             ; NEG, NEED CHAR FOR SIGN\r
27540 \r
27541         IDIV    B,D             ; START COUNTING\r
27542         JUMPE   B,.+2\r
27543         AOJA    A,.-2\r
27544 \r
27545         MOVE    B,-2(TP)        ; CHANNEL TO B\r
27546         TLNN    FLAGS,FLTBIT+BINBIT\r
27547         PUSHJ   P,RETIF3        ; CHECK FOR C.R.\r
27548         MOVE    B,-2(TP)                ; RESTORE CHANNEL\r
27549         MOVEI   A,"-            ; GET SIGN\r
27550         SKIPGE  (TP)            ; SKIP IF NOT NEEDED\r
27551         PUSHJ   P,PITYO\r
27552         MOVM    C,(TP)  ; GET MAGNITUDE OF #\r
27553         MOVE    B,-2(TP)        ; RESTORE CHANNEL\r
27554         POP     P,E             ; RESTORE RADIX\r
27555         PUSHJ   P,FIXTYO        ; WRITE OUT THE #\r
27556         MOVE    FLAGS,-1(P)\r
27557         SUB     P,[1,,1]        ; FLUSH P STUFF\r
27558         JRST    PNEXT\r
27559 \r
27560 FIXTYO: IDIV    C,E\r
27561         HRLM    D,(P)           ; SAVE REMAINDER\r
27562         SKIPE   C\r
27563         PUSHJ   P,FIXTYO\r
27564         HLRZ    A,(P)           ; START GETTING #'S BACK\r
27565         ADDI    A,60\r
27566         MOVE    B,-2(TP)                ; CHANNEL BACK\r
27567         JRST    PITYO\r
27568 \r
27569 \f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.\r
27570 ;\r
27571 PFLOAT: SKIPN   A,(TP)  ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO)\r
27572         JRST    PFLT0   ; HACK THAT ZERO\r
27573         MOVM    E,A             ; CHECK FOR NORMALIZED\r
27574         TLNN    E,400           ; NORMALIZED\r
27575         JRST    PUNK\r
27576         MOVEI   E,FLOATB        ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE\r
27577         MOVE    D,[6,,6]        ;# WORDS TO GET FROM STACK\r
27578 \r
27579 PNUMB:  HRLI    A,1(P)  ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK\r
27580         HRR     A,TP    ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM\r
27581         HLRZ    B,A     ;SAVE RETURN AREA ADDRESS IN REG B\r
27582         ADD     P,D     ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP\r
27583         JUMPGE  P,PDLERR        ;PLUS OR ZERO STACK POINTER IS OVERFLOW\r
27584 PDLWIN: PUSHJ   P,(E)   ;CALL ROUTINE WHOSE ADDRESS IS IN REG E\r
27585 \r
27586         MOVE    C,(B)   ;GET COUNT 0F # CHARS RETURNED\r
27587         MOVE    A,C     ;MAKE SURE THAT # WILL FIT ON PRINT LINE\r
27588 PFLT1:  PUSH    P,B             ; SAVE B\r
27589         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27590         PUSHJ   P,RETIF ;START NEW LINE IF IT WON'T\r
27591         POP     P,B             ; RESTORE B\r
27592 \r
27593         HRLI    B,000700        ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE\r
27594 PNUM01: ILDB    A,B     ;GET NEXT BYTE\r
27595         PUSH    P,B     ;SAVE B\r
27596         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27597         PUSHJ   P,PITYO ;PRINT IT\r
27598 \r
27599                                         P,B             ; RESTORE B\r
27600         SOJG    C,PNUM01        ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO\r
27601 \r
27602         SUB     P,D     ;SUBTRACT # WORDS USED ON STACK FOR RETURN\r
27603         JRST    PNEXT   ;STORE REGS & POP UP ONE LEVEL TO CALLER\r
27604 \r
27605 \r
27606 PFLT0:  MOVEI   A,9.    ; WIDTH OF 0.0000000\r
27607         MOVEI   C,9.    ; SEE ABOVE\r
27608         MOVEI   D,0     ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING\r
27609         MOVEI   B,[ASCII /0.0000000/]\r
27610         SOJA    B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE\r
27611 \r
27612 \r
27613 \r
27614 \r
27615 PDLERR: SUB     P,D             ;REST STACK POINTER\r
27616 REPEAT 6,PUSH   P,[0]\r
27617         JRST PDLWIN\r
27618 \f;PRINT SHORT (ONE WORD) CHARACTER STRINGS\r
27619 ;\r
27620 PCHRS:  MOVEI   A,3     ;MAX # CHARS PLUS 2 (LESS ESCAPES)\r
27621         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27622         TLNE    FLAGS,NOQBIT    ;SKIP IF QUOTES WILL BE USED\r
27623         MOVEI   A,1     ;ELSE, JUST ONE CHARACTER POSSIBLE\r
27624         PUSHJ   P,RETIF ;NEW LINE IF INSUFFICIENT SPACE\r
27625         TLNE    FLAGS,NOQBIT    ;DON'T QUOTE IF IN PRINC MODE\r
27626         JRST    PCASIS\r
27627         MOVEI   A,"!    ;TYPE A EXCL\r
27628         PUSHJ   P,PITYO\r
27629         MOVEI   A,""            ;AND A DOUBLE QUOTE\r
27630         PUSHJ   P,PITYO\r
27631 \r
27632 PCASIS: MOVE    A,(TP)          ;GET NEXT BYTE FROM WORD\r
27633         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
27634         JRST    PCPRNT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
27635         CAIE    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER\r
27636         JRST    PCPRNT  ;ESCAPE THE ESCAPE CHARACTER\r
27637 \r
27638 ESCPRT: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER\r
27639         PUSHJ   P,PITYO \r
27640 \r
27641 PCPRNT: MOVE    A,(TP)          ;GET THE CHARACTER AGAIN\r
27642         PUSHJ   P,PITYO ;PRINT IT\r
27643         JRST    PNEXT\r
27644 \r
27645 \r
27646 \f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)\r
27647 ;\r
27648 PDEFER: MOVE    A,(B)   ;GET FIRST WORD OF ITEM\r
27649         MOVE    B,1(B)  ;GET SECOND\r
27650         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
27651         PUSH    TP,-3(TP)\r
27652         PUSHJ   P,IPRINT        ;PRINT IT\r
27653         SUB     TP,[2,,2]       ; POP OFF CHANNEL\r
27654         JRST    PNEXT   ;GO EXIT\r
27655 \r
27656 \r
27657 ; Print an ATOM.  TRAILERS are added if the atom is not in the current\r
27658 ; lexical path.  Also escaping of charactets is performed to allow READ\r
27659 ; to win.\r
27660 \r
27661 PATOM:  PUSH    P,[440700,,D]   ; PUSH BYE POINTER TO FINAL STRING\r
27662         SETZB   D,E             ; SET CHARCOUNT AD DESTINATION TO 0\r
27663         HLLZS   -1(TP)          ; RH OF TATOM,, WILL COUNT ATOMS IN PATH\r
27664 \r
27665 PATOM0: PUSH    TP,$TPDL        ; SAVE CURRENT STAKC FOR \ LOGIC\r
27666         PUSH    TP,P\r
27667         LDB     A,[301400,,(P)] ; GET BYTE PTR POSITION\r
27668         DPB     A,[301400,,E]   ; SAVE IN E\r
27669         MOVE    C,-2(TP)        ; GET ATOM POINTER\r
27670         ADD     C,[3,,3]        ; POINT TO PNAME\r
27671         HLRE    A,C             ; -# WORDS TO A\r
27672         PUSH    P,A             ; PUSH THAT FOR "AOSE"\r
27673         MOVEI   A,177           ; PUT RUBOUT WHERE \ MIGHT GO\r
27674         JSP     B,DOIDPB\r
27675         HRLI    C,440700        ; BUILD BYET POINTER\r
27676 \r
27677 PATOM1: ILDB    A,C             ; GET A CHAR\r
27678         JUMPE   A,PATDON        ; END OF PNAME?\r
27679         TLNN    C,760000        ; SKIP IF NOT WORD BOUNDARY\r
27680         AOS     (P)             ; COUNT WORD\r
27681         JRST    PENTCH          ; ENTER THE CHAR INTO OUTPUT\r
27682 \r
27683 PATDON: LDB     A,[220600,,E]   ; GET "STATE"\r
27684         LDB     A,STABYT+6      ; SIMULATE "END" CHARACTER\r
27685         DPB     A,[220600,,E]   ; AND STORE\r
27686         MOVE    B,E             ; SETUP BYTE POINTER TO 1ST CHAR\r
27687         TLZ     B,77\r
27688         HRR     B,(TP)  ; POINT\r
27689         SUB     TP,[2,,2]       ; FLUSH SAVED PDL\r
27690         MOVE    C,-1(P)         ; GET BYE POINTER\r
27691         SUB     P,[2,,2]        ; FLUSH\r
27692         PUSH    P,D\r
27693         MOVEI   A,0\r
27694         IDPB    A,B\r
27695         AOS     -1(TP)          ; COUNT ATOMS\r
27696         TLNE    FLAGS,NOQBIT    ; SKIP IF NOT "PRINC"\r
27697         JRST    NOLEX4          ; NEEDS NO LEXICAL TRAILERS\r
27698         MOVEI   A,"\            ; GET QUOTER\r
27699         TLNN    E,2             ; SKIP IF NEEDED\r
27700         JRST    PATDO1\r
27701         SOS     -1(TP)          ; DONT COUNT BECAUSE OF SLASH\r
27702         DPB     A,B             ; CLOBBER\r
27703 PATDO1: MOVEI   E,(E)           ; CLEAR LH(E)\r
27704         PUSH    P,C             ; SAVE BYTER\r
27705         PUSH    P,E             ; ALSO CHAR COUNT\r
27706 \r
27707         MOVE    B,IMQUOTE OBLIST\r
27708         PUSH    P,FLAGS\r
27709         PUSHJ   P,IDVAL         ; GET LOCAL/GLOBAL VALUE\r
27710         POP     P,FLAGS         ; AND RESTORES FLAGS\r
27711         MOVE    C,(TP)          ; GET ATOM BACK\r
27712         SKIPN   C,2(C)          ; GET ITS OBLIST\r
27713         AOJA    A,NOOBL1        ; NONE, USE FALSE\r
27714         JUMPL   C,.+3           ; JUMP IF REAL OBLIST\r
27715         ADDI    C,(TVP)         ; ELSE MUST BE OFFSET\r
27716         MOVE    C,(C)\r
27717         CAME    A,$TLIST        ; SKIP IF  A LIST\r
27718         CAMN    A,$TOBLS        ; SKIP IF UNREASONABLE VALUE\r
27719         JRST    CHOBL           ; WINS, NOW LOCATE IT\r
27720 \r
27721 CHROOT: CAME    C,ROOT+1(TVP)   ; IS THIS ROOT?\r
27722         JRST    FNDOBL          ; MUST FIND THE PATH NAME\r
27723         POP     P,E             ; RESTORE CHAR COUNT\r
27724         MOVE    D,(P)           ; AND PARTIAL WORD\r
27725         EXCH    D,-1(P)         ; STORE BYTE POINTER AND GET PARTIAL WORD\r
27726         MOVEI   A,"!            ; PUT OUT MAGIC\r
27727         JSP     B,DOIDPB        ; INTO BUFFER\r
27728         MOVEI   A,"-    \r
27729         JSP     B,DOIDPB\r
27730         MOVEI   A,40\r
27731         JSP     B,DOIDPB\r
27732 \r
27733 NOLEX0: SUB     P,[2,,2]        ; REMOVE COUNTER AND BYTE POINTER\r
27734         PUSH    P,D             ; PUSH NEXT WORD IF ANY\r
27735         JRST    NOLEX4\r
27736 \r
27737 NOLEX:  MOVE    E,(P)           ; GET COUNT\r
27738         SUB     P,[2,,2]\r
27739 NOLEX4: MOVEI   E,(E)           ; CLOBBER LH(E)\r
27740         MOVE    A,E             ; COUNT TO A\r
27741         SKIPN   (P)             ; FLUSH 0 WORD\r
27742         SUB     P,[1,,1]\r
27743         HRRZ    C,-1(TP)        ; GET # OF ATOMS\r
27744         SUBI    A,(C)           ; FIX COUNT\r
27745         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27746         PUSHJ   P,RETIF         ; MAY NEED C.R.\r
27747         MOVEI   C,-1(E)         ; COMPUTE WORDS-1\r
27748         IDIVI   C,5             ; WORDS-1 TO C\r
27749         HRLI    C,(C)\r
27750         MOVE    D,P     \r
27751         SUB     D,C             ; POINTS TO 1ST WORD OF CHARS\r
27752         MOVSI   C,440700+D      ; BYTEPOINTER TO STRING\r
27753         PUSH    TP,$TPDL                ; SAVE FROM GC\r
27754         PUSH    TP,D\r
27755 \r
27756 PATOUT: ILDB    A,C             ; READ A CHAR\r
27757         SKIPE   A               ; IGNORE NULS\r
27758         PUSHJ   P,PITYO         ; PRINT IT\r
27759         MOVE    D,(TP)          ; RESTORE POINTER\r
27760         SOJG    E,PATOUT\r
27761 \r
27762 NOLEXD: SUB     TP,[2,,2]       ; FLUSH TP JUNK\r
27763         MOVE    P,D             ; RESTORE P\r
27764         SUB     P,[1,,1]\r
27765         JRST    PNEXT\r
27766 \r
27767 \r
27768 PENTCH: TLNE    FLAGS,NOQBIT    ; "PRINC"?\r
27769         JRST    PENTC1          ; YES, AVOID SLASHING\r
27770         IDIVI   A,CHRWD ; GET CHARS TYPE\r
27771         LDB     B,BYTPNT(B)\r
27772         CAIL    B,6             ; SKIP IF NOT SPECIAL\r
27773         JRST    PENTC2          ; SLASH IMMEDIATE\r
27774         LDB     A,[220600,,E]   ; GET "STATE"\r
27775         LDB     A,STABYT-1(B)   ; GET NEW STATE\r
27776         DPB     A,[220600,,E]   ; AND SAVE IT\r
27777 PENTC3: LDB     A,C             ; RESTORE CHARACTER\r
27778 PENTC1: JSP     B,DOIDPB\r
27779         SKIPGE  (P)             ; SKIP IF DONE\r
27780         JRST    PATOM1          ; CONTINUE\r
27781         JRST    PATDON\r
27782 \r
27783 PENTC2: MOVEI   A,"\            ; GET CHAR QUOTER\r
27784         JSP     B,DOIDPB        ; NEEDED, DO IT\r
27785         MOVEI   A,4             ; PATCH FOR ATOMS ALREADY BACKSLASHED\r
27786         JRST    PENTC3-1\r
27787 \r
27788 ; ROUTINE TO PUT ONE CHAR ON STACK BUFFER\r
27789 \r
27790 DOIDPB: IDPB    A,-1(P)         ; DEPOSIT\r
27791         TRNN    D,377           ; SKIP IF D FULL\r
27792         AOJA    E,(B)\r
27793         PUSH    P,(P)           ; MOVE TOP OF STACK UP\r
27794         MOVEM   D,-2(P)         ; SAVE WORDS\r
27795         MOVE    D,[440700,,D]\r
27796         MOVEM   D,-1(P)\r
27797         MOVEI   D,0\r
27798         AOJA    E,(B)\r
27799 \r
27800 ; CHECK FOR UNIQUENESS LOOKING INTO PATH\r
27801 \r
27802 CHOBL:  CAME    A,$TOBLS        ; SINGLE OBLIST?\r
27803         JRST    LSTOBL          ; NO, AL LIST THEREOF\r
27804         CAME    B,C             ; THE RIGTH ONE?\r
27805         JRST    CHROOT          ; NO, CHECK ROOT\r
27806         JRST    NOLEX           ; WINNER, NO TRAILERS!\r
27807 \r
27808 LSTOBL: PUSH    TP,A            ; SCAN A LIST OF OBLISTS\r
27809         PUSH    TP,B\r
27810         PUSH    TP,A\r
27811         PUSH    TP,B\r
27812         PUSH    TP,$TOBLS\r
27813         PUSH    TP,C\r
27814 \r
27815 NXTOB2: INTGO                   ; LIST LOOP, PREVENT LOSSAGE\r
27816         SKIPN   C,-2(TP)                ; SKIP IF NOT DONE\r
27817         JRST    CHROO1          ; EMPTY, CHECK ROOT\r
27818         MOVE    B,1(C)          ; GET ONE\r
27819         CAME    B,(TP)          ; WINNER?\r
27820         JRST    NXTOBL          ; NO KEEP LOOKING\r
27821         CAMN    C,-4(TP)        ; SKIP IF NOT FIRST ON  LIST\r
27822         JRST    NOLEX1\r
27823         MOVE    A,-6(TP)        ; GET ATOM BACK\r
27824         MOVEI   D,0\r
27825         ADD     A,[3,,3]        ; POINT TO PNAME\r
27826         PUSH    P,0             ; SAVE FROM RLOOKU\r
27827         PUSH    P,(A)\r
27828         ADDI    D,5\r
27829         AOBJN   A,.-2           ; PUSH THE PNAME\r
27830         PUSH    P,D             ; AND CHAR COUNT\r
27831         MOVSI   A,TLIST         ; TELL RLOOKU WE WIN\r
27832         MOVE    B,-4(TP)        ; GET BACK OBLIST LIST\r
27833         SUB     TP,[6,,6]       ; FLUSH CRAP\r
27834         PUSHJ   P,RLOOKU        ; FIND IT\r
27835         POP     P,0\r
27836         CAMN    B,(TP)          ; SKIP IF NON UNIQUE\r
27837         JRST    NOLEX           ; UNIQUE , NO TRAILER!!\r
27838         JRST    CHROO2          ; CHECK ROOT\r
27839 \r
27840 NXTOBL: HRRZ    B,@-2(TP)       ; STEP THE LIST\r
27841         MOVEM   B,-2(TP)\r
27842         JRST    NXTOB2\r
27843 \r
27844 \r
27845 FNDOBL: MOVE    C,(TP)          ; GET ATOM\r
27846         MOVSI   A,TOBLS\r
27847         MOVE    B,2(C)\r
27848         JUMPL   B,.+3\r
27849         ADDI    B,(TVP)\r
27850         MOVE    B,(B)\r
27851         MOVSI   C,TATOM\r
27852         MOVE    D,IMQUOTE OBLIST\r
27853         PUSH    P,0\r
27854         PUSHJ   P,IGET\r
27855         POP     P,0\r
27856 NOOBL1: POP     P,E             ; RESTORE CHAR COUNT\r
27857         MOVE    D,(P)           ; GET PARTIAL WORD\r
27858         EXCH    D,-1(P)         ; AND BYTE POINTER\r
27859         CAME    A,$TATOM        ; IF NOT ATOM, USE FALSE\r
27860         JRST    NOOBL\r
27861         MOVEM   B,(TP)          ; STORE IN ATOM SLOT\r
27862         MOVEI   A,"!\r
27863         JSP     B,DOIDPB        ; WRITE IT OUT\r
27864         MOVEI   A,"-\r
27865         JSP     B,DOIDPB\r
27866         SUB     P,[1,,1]\r
27867         JRST    PATOM0          ; AND LOOP\r
27868 \r
27869 NOOBL:  MOVE    C,[440700,,[ASCIZ /!-#FALSE ()/]]\r
27870         ILDB    A,C\r
27871         JUMPE   A,NOLEX0\r
27872         JSP     B,DOIDPB\r
27873         JRST    .-3\r
27874 \r
27875 \r
27876 NOLEX1: SUB     TP,[6,,6]       ; FLUSH STUFF\r
27877         JRST    NOLEX\r
27878 \r
27879 CHROO1: SUB     TP,[6,,6]\r
27880 CHROO2: MOVE    C,(TP)          ; GET ATOM\r
27881         SKIPGE  C,2(C)          ; AND ITS OBLIST\r
27882         JRST    CHROOT\r
27883         ADDI    C,(TVP)\r
27884         MOVE    C,(C)\r
27885         JRST    CHROOT\r
27886 \r
27887 \r
27888 \f; STATE TABLES FOR \ OF FIRST CHAR\r
27889 \r
27890 RADIX 16.\r
27891 \r
27892 STATS:  431244000\r
27893         434444400\r
27894         222224200\r
27895         434564200\r
27896         444444400\r
27897         454564200\r
27898         487444200\r
27899         484444400\r
27900         484444200\r
27901 \r
27902 RADIX 8.\r
27903 \r
27904 STABYT: 400400,,STATS(A)\r
27905         340400,,STATS(A)\r
27906         300400,,STATS(A)\r
27907         240400,,STATS(A)\r
27908         200400,,STATS(A)\r
27909         140400,,STATS(A)\r
27910         100400,,STATS(A)\r
27911 \r
27912 \f;PRINT LONG CHARACTER STRINGS.\r
27913 ;\r
27914 PCHSTR: MOVE    B,(TP)\r
27915         TLZ     FLAGS,ATMBIT    ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING\r
27916         PUSH    P,-1(TP)        ; PUSH CHAR COUNT\r
27917         MOVE    D,[AOS E]       ;GET INSTRUCTION TO COUNT CHARACTERS\r
27918         SETZM   E       ;ZERO COUNT\r
27919         PUSHJ   P,PCHRST        ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING\r
27920         MOVE    A,E     ;PUT COUNT RETURNED IN REG A\r
27921         TLNN    FLAGS,NOQBIT    ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)\r
27922         ADDI    A,2     ;PLUS TWO FOR QUOTES\r
27923         PUSH    P,B             ; SAVE B\r
27924         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27925         PUSHJ   P,RETIF ;START NEW LINE IF NO SPACE\r
27926         POP     P,B             ; RESTORE B\r
27927         TLNE    FLAGS,NOQBIT    ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)\r
27928         JRST    PCHS01  ;OTHERWISE, DON'T QUOTE\r
27929         MOVEI   A,""    ;PRINT A DOUBLE QUOTE\r
27930         PUSH    P,B             ; SAVE B\r
27931         MOVE B,-2(TP)\r
27932         PUSHJ   P,PITYO\r
27933         POP     P,B             ; RESTORE B\r
27934 \r
27935 PCHS01: MOVE    D,[PUSHJ P,PITYO]       ;OUTPUT INSTRUCTION\r
27936         MOVEM   B,(TP)  ;RESET BYTE POINTER\r
27937         POP     P,-1(TP)        ; RESET CHAR COUNT\r
27938         PUSHJ   P,PCHRST        ;TYPE STRING\r
27939 \r
27940         TLNE    FLAGS,NOQBIT    ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE\r
27941         JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
27942         MOVEI   A,""    ;PRINT A DOUBLE QUOTE\r
27943         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27944         PUSH    P,B             ; SAVE B\r
27945         MOVE    B,-2(TP)        ; GET CHANNEL\r
27946         PUSHJ   P,PITYO\r
27947         POP     P,B             ;RESTORE B\r
27948         JRST    PNEXT\r
27949 \r
27950 \r
27951 ;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.\r
27952 ;\r
27953 ;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.\r
27954 ;\r
27955 PCHRST: PUSH    P,A     ;SAVE REGS\r
27956         PUSH    P,B\r
27957         PUSH    P,C\r
27958         PUSH    P,D\r
27959 \r
27960 PCHR02: INTGO                   ; IN CASE VERY LONG STRING\r
27961         HRRZ    C,-1(TP)        ;GET COUNT\r
27962         SOJL    C,PCSOUT        ; DONE?\r
27963         HRRM    C,-1(TP)\r
27964         ILDB    A,(TP)          ; GET CHAR\r
27965 \r
27966         TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
27967         JRST    PCSPRT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
27968         CAIN    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER\r
27969         JRST    ESCPRN  ;ESCAPE THE ESCAPE CHARACTER\r
27970         CAIN    A,""    ;SKIP IF NOT A DOUBLE QUOTE\r
27971         JRST    ESCPRN  ;OTHERWISE, ESCAPE THE """\r
27972         IDIVI   A,CHRWD ;CODE HERE FINDS CHARACTER TYPE\r
27973         LDB     B,BYTPNT(B)     ; "\r
27974         CAIGE   B,6     ;SKIP IF NOT A NUMBER/LETTER\r
27975         JRST    PCSPRT  ;OTHERWISE, PRINT IT\r
27976         TLNN    FLAGS,ATMBIT    ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)\r
27977         JRST    PCSPRT  ;OTHERWISE, NO OTHER CHARS TO ESCAPE\r
27978 \r
27979 ESCPRN: MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER\r
27980         PUSH    P,B             ; SAVE B\r
27981         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27982         XCT     (P)-1   \r
27983         POP     P,B             ; RESTORE B\r
27984 \r
27985 PCSPRT: LDB     A,(TP)  ;GET THE CHARACTER AGAIN\r
27986         PUSH    P,B             ; SAVE B\r
27987         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
27988         XCT     (P)-1   ;PRINT IT\r
27989         POP     P,B             ; RESTORE B\r
27990         JRST    PCHR02  ;LOOP THROUGH STRING\r
27991 \r
27992 PCSOUT: POP     P,D\r
27993         POP     P,C     ;RESTORE REGS & RETURN\r
27994         POP     P,B\r
27995         POP     P,A\r
27996         POPJ    P,\r
27997 \r
27998 \r
27999 \f;PRINT AN ARGUMENT LIST\r
28000 ;CHECK FOR TIME ERRORS\r
28001 \r
28002 PARGS:  MOVEI   B,-1(TP)        ;POINT TO ARGS POINTER\r
28003         PUSHJ   P,CHARGS        ;AND CHECK THEM\r
28004         JRST    PVEC            ; CHEAT TEMPORARILY\r
28005 \r
28006 \r
28007 \r
28008 ;PRINT A FRAME\r
28009 PFRAME: MOVEI   B,-1(TP)        ;POINT TO FRAME POINTER\r
28010         PUSHJ   P,CHFRM\r
28011         HRRZ    B,(TP)          ;POINT TO FRAME ITSELF\r
28012         HRRZ    B,FSAV(B)       ;GET POINTER TO SUBROUTINE\r
28013         CAMGE   B,VECTOP\r
28014         CAMGE   B,VECBOT\r
28015         SKIPA   B,@-1(B)        ; SUBRS AND FSUBRS\r
28016         MOVE    B,3(B)          ; FOR RSUBRS\r
28017         MOVSI   A,TATOM\r
28018         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28019         PUSH    TP,-3(TP)\r
28020         PUSHJ   P,IPRINT        ;PRINT FUNCTION NAME\r
28021         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28022         JRST    PNEXT\r
28023 \r
28024 PPVP:   MOVE    B,(TP)          ; PROCESS TO B\r
28025         MOVSI   A,TFIX\r
28026         JUMPE   B,.+3\r
28027         MOVE    A,PROCID(B)\r
28028         MOVE    B,PROCID+1(B)   ;GET ID\r
28029         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28030         PUSH    TP,-3(TP)\r
28031         PUSHJ   P,IPRINT\r
28032         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28033         JRST    PNEXT\r
28034 \r
28035 ; HERE TO PRINT LOCATIVES\r
28036 \r
28037 LOCPT1: HRRZ    A,-1(TP)\r
28038         JUMPN   A,PUNK\r
28039 LOCPT:  MOVEI   B,-1(TP)        ; VALIDITY CHECK\r
28040         PUSHJ   P,CHLOCI\r
28041         HRRZ    A,-1(TP)\r
28042         JUMPE   A,GLOCPT\r
28043         MOVE    B,(TP)\r
28044         MOVE    A,(B)\r
28045         MOVE    B,1(B)\r
28046         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28047         PUSH    TP,-3(TP)\r
28048         PUSHJ   P,IPRINT\r
28049         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28050         JRST    PNEXT\r
28051 \r
28052 GLOCPT: MOVEI   A,2\r
28053         MOVE    B,-2(TP)                ; GET CHANNEL\r
28054         PUSHJ   P,RETIF\r
28055         MOVEI   A,"%\r
28056         PUSHJ   P,PITYO\r
28057         MOVEI   A,"<\r
28058         PUSHJ   P,PITYO\r
28059         MOVSI   A,TATOM\r
28060         MOVE    B,MQUOTE GLOC\r
28061         PUSH    TP,-3(TP)\r
28062         PUSH    TP,-3(TP)\r
28063         PUSHJ   P,IPRINT\r
28064         SUB     TP,[2,,2]\r
28065         PUSHJ   P,SPACEQ\r
28066         MOVE    B,(TP)\r
28067         MOVSI   A,TATOM\r
28068         MOVE    B,-1(B)\r
28069         PUSH    TP,-3(TP)\r
28070         PUSH    TP,-3(TP)\r
28071         PUSHJ   P,IPRINT\r
28072         SUB     TP,[2,,2]\r
28073         PUSHJ   P,SPACEQ\r
28074         MOVSI   A,TATOM\r
28075         MOVE    B,MQUOTE T\r
28076         PUSH    TP,-3(TP)\r
28077         PUSH    TP,-3(TP)\r
28078         PUSHJ   P,IPRINT\r
28079         SUB     TP,[2,,2]\r
28080         MOVEI   A,">\r
28081         PUSHJ   P,PRETIF\r
28082         JRST    PNEXT\r
28083 \r
28084 \f;PRINT UNIFORM VECTORS.\r
28085 ;\r
28086 PUVEC:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28087         MOVEI   A,2             ; ROOM FOR ! AND SQ BRACK?\r
28088         PUSHJ   P,RETIF\r
28089         MOVEI   A,"!    ;TYPE AN ! AND OPEN SQUARE BRACKET\r
28090         PUSHJ   P,PITYO\r
28091         MOVEI   A,"[\r
28092         PUSHJ   P,PITYO\r
28093 \r
28094         MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR\r
28095         TLNN    C,777777        ;SKIP ONLY IF COUNT IS NOT ZERO\r
28096         JRST    NULVEC  ;ELSE, VECTOR IS EMPTY\r
28097 \r
28098         HLRE    A,C     ;GET NEG COUNT\r
28099         MOVEI   D,(C)   ;COPY POINTER\r
28100         SUB     D,A     ;POINT TO DOPE WORD\r
28101         HLLZ    A,(D)   ;GET TYPE\r
28102         PUSH    P,A     ;AND SAVE IT\r
28103 \r
28104 PUVE02: MOVE    A,(P)   ;PUT TYPE CODE IN REG A\r
28105         MOVE    B,(C)   ;PUT DATUM INTO REG B\r
28106         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28107         PUSH    TP,-3(TP)\r
28108         PUSHJ   P,IPRINT        ;TYPE IT\r
28109         SUB     TP,[2,,2]       ; POP CHANNEL OF STACK\r
28110         MOVE    C,(TP)  ;GET AOBJN POINTER\r
28111         AOBJP   C,NULVE1        ;JUMP IF COUNT IS ZERO\r
28112         MOVEM   C,(TP)  ;PUT POINTER BACK ONTO STACK\r
28113 \r
28114         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28115         PUSHJ   P,SPACEQ\r
28116         JRST    PUVE02  ;LOOP THROUGH VECTOR\r
28117 \r
28118 NULVE1: SUB     P,[1,,1]        ;REMOVE STACK CRAP\r
28119 NULVEC: MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28120         MOVEI   A,"!    ;TYPE CLOSE BRACKET\r
28121         PUSHJ   P,PRETIF\r
28122         MOVEI   A,"]\r
28123         PUSHJ   P,PRETIF\r
28124         JRST    PNEXT\r
28125 \r
28126 \f;PRINT A GENERALIZED VECTOR\r
28127 ;\r
28128 PVEC:   MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28129         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR [\r
28130         MOVEI   A,"[    ;PRINT A LEFT-BRACKET\r
28131         PUSHJ   P,PITYO\r
28132 \r
28133         MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR\r
28134         TLNN    C,777777        ;SKIP IF POINTER-COUNT IS NON-ZERO\r
28135         JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR\r
28136 PVCR01: MOVE    A,(C)   ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A\r
28137         MOVE    B,1(C)  ;SECOND WORD OF LIST INTO REG B\r
28138         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28139         PUSH    TP,-3(TP)\r
28140         PUSHJ   P,IPRINT        ;PRINT THAT ELEMENT\r
28141         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28142 \r
28143         MOVE    C,(TP)  ;GET AOBJN POINTER FROM TP-STACK\r
28144         AOBJP   C,PVCEND        ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)\r
28145         AOBJN   C,.+2   ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO\r
28146         JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR\r
28147         MOVEM   C,(TP)  ;PUT INCREMENTED POINTER BACK ON TP-STACK\r
28148 \r
28149         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28150         PUSHJ   P,SPACEQ\r
28151         JRST    PVCR01  ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR\r
28152 \r
28153 PVCEND: MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28154         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR ]\r
28155         MOVEI   A,"]    ;PRINT A RIGHT-BRACKET\r
28156         PUSHJ   P,PITYO\r
28157         JRST    PNEXT\r
28158 \r
28159 \f;PRINT A LIST.\r
28160 ;\r
28161 PLIST:  MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28162         PUSHJ   P,RETIF1        ;NEW LINE IF NO SPACE LEFT FOR "("\r
28163         MOVEI   A,"(    ;TYPE AN OPEN PAREN\r
28164         PUSHJ   P,PITYO\r
28165         PUSHJ   P,LSTPRT        ;PRINT THE INSIDES\r
28166         MOVE    B,-2(TP)                ; RESTORE CHANNEL TO B\r
28167         PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN\r
28168         MOVEI   A,")    ;TYPE A CLOSE PAREN\r
28169         PUSHJ   P,PITYO\r
28170         JRST    PNEXT\r
28171 \r
28172 PSEG:   TLOA    FLAGS,SEGBIT    ;PRINT A SEGMENT (& SKIP)\r
28173 \r
28174 PFORM:  TLZ     FLAGS,SEGBIT    ;PRINT AN ELEMENT\r
28175 \r
28176 PLMNT3: MOVE    C,(TP)\r
28177         JUMPE   C,PLMNT1        ;IF THE CALL IS EMPTY GO AWAY\r
28178         MOVE    B,1(C)\r
28179         MOVEI   D,0\r
28180         CAMN    B,MQUOTE LVAL\r
28181         MOVEI   D,".\r
28182         CAMN    B,MQUOTE GVAL\r
28183         MOVEI   D,",\r
28184         CAMN    B,MQUOTE QUOTE\r
28185         MOVEI   D,"'\r
28186         JUMPE   D,PLMNT1                ;NEITHER, LEAVE\r
28187 \r
28188 ;ITS A SPECIAL HACK\r
28189         HRRZ    C,(C)\r
28190         JUMPE   C,PLMNT1        ;NIL BODY?\r
28191 \r
28192 ;ITS VALUE OF AN ATOM\r
28193         HLLZ    A,(C)\r
28194         MOVE    B,1(C)\r
28195         HRRZ    C,(C)\r
28196         JUMPN   C,PLMNT1        ;IF TERE ARE EXTRA ARGS GO AWAY\r
28197 \r
28198         PUSH    P,D             ;PUSH THE CHAR\r
28199         PUSH    TP,A\r
28200         PUSH    TP,B\r
28201         TLNN    FLAGS,SEGBIT    ;SKIP (CONTINUE) IF THIS IS A SEGMENT\r
28202         JRST    PLMNT4  ;ELSE DON'T PRINT THE "."\r
28203 \r
28204 ;ITS A SEGMENT CALL\r
28205         MOVE    B,-4(TP)        ; GET CHANNEL INTO B\r
28206         MOVEI   A,2             ; ROOM FOR ! AND . OR ,\r
28207         PUSHJ   P,RETIF\r
28208         MOVEI   A,"!\r
28209         PUSHJ   P,PITYO\r
28210 \r
28211 PLMNT4: MOVE    B,-4(TP)                ; GET CHANNEL INTO B\r
28212         PUSHJ   P,RETIF1\r
28213         POP     P,A             ;RESTORE CHAR\r
28214         PUSHJ   P,PITYO\r
28215         POP     TP,B\r
28216         POP     TP,A\r
28217         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28218         PUSH    TP,-3(TP)\r
28219         PUSHJ   P,IPRINT\r
28220         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28221         JRST    PNEXT\r
28222 \r
28223 \r
28224 PLMNT1: TLNN    FLAGS,SEGBIT    ;SKIP IF THIS IS A SEGMENT\r
28225         JRST    PLMNT5  ;ELSE DON'T TYPE THE "!"\r
28226 \r
28227 ;ITS A SEGMENT CALL\r
28228         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28229         MOVEI   A,2             ; ROOM FOR ! AND <\r
28230         PUSHJ   P,RETIF\r
28231         MOVEI   A,"!\r
28232         PUSHJ   P,PITYO\r
28233 \r
28234 PLMNT5: MOVE    B,-2(TP)        ; GET CHANNEL FOR B\r
28235         PUSHJ   P,RETIF1        \r
28236         MOVEI   A,"<\r
28237         PUSHJ   P,PITYO\r
28238         PUSHJ   P,LSTPRT\r
28239         MOVEI   A,"!\r
28240         MOVE    B,-2(TP)                ; GET CHANNEL INTO B\r
28241         TLNE    FLAGS,SEGBIT    ;SKIP IF NOT SEGEMNT\r
28242         PUSHJ   P,PRETIF\r
28243         MOVEI   A,">\r
28244         PUSHJ   P,PRETIF\r
28245         JRST    PNEXT\r
28246 \r
28247 \r
28248 \f\r
28249 LSTPRT: SKIPN   C,(TP)\r
28250         POPJ    P,\r
28251         HLLZ    A,(C)   ;GET NEXT ELEMENT\r
28252         MOVE    B,1(C)\r
28253         HRRZ    C,(C)   ;CHOP THE LIST\r
28254         JUMPN   C,PLIST1\r
28255         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28256         PUSH    TP,-3(TP)\r
28257         PUSHJ   P,IPRINT        ;PRINT THE LAST ELEMENT\r
28258         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28259         POPJ    P,\r
28260 \r
28261 PLIST1: MOVEM   C,(TP)\r
28262         PUSH    TP,-3(TP)       ; GET CHANNEL FOR IPRINT\r
28263         PUSH    TP,-3(TP)\r
28264         PUSHJ   P, IPRINT       ;PRINT THE NEXT ELEMENT\r
28265         SUB     TP,[2,,2]       ; POP CHANNEL OFF STACK\r
28266         MOVE    B,-2(TP)        ; GET CHANNEL INTO B\r
28267         PUSHJ   P,SPACEQ\r
28268         JRST    LSTPRT  ;REPEAT\r
28269 \r
28270 PNEXT:  POP     P,FLAGS ;RESTORE PREVIOUS FLAG BITS\r
28271         SUB     TP,[2,,2]       ;REMOVE INPUT ELEMENT FROM TP-STACK\r
28272         POP     P,C     ;RESTORE REG C\r
28273         POPJ    P,\r
28274 \r
28275 OPENIT: PUSH    P,E\r
28276         PUSH    P,FLAGS\r
28277         PUSHJ   P,OPNCHN\r
28278         POP     P,FLAGS\r
28279         POP     P,E\r
28280         JUMPGE  B,FNFFL ;ERROR IF IT CANNOT BE OPENED\r
28281         POPJ    P,\r
28282 \r
28283 \r
28284 END\r
28285 \f\r
28286 TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE\r
28287 \r
28288 RELOCATABLE\r
28289 \r
28290 .INSRT MUDDLE >\r
28291 \r
28292 ; COMPONENTS IN AN ASSOCIATION BLOCK\r
28293 \r
28294 ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES\r
28295 VAL==2          ;VALUE\r
28296 INDIC==4        ;INDICATOR\r
28297 NODPNT==6               ;IF NON ZERO POINTS TO CHAIN\r
28298 PNTRS==7        ;POINTERS NEXT (RH) AND PREV (LH)\r
28299 \r
28300 ASOLNT==8       ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK\r
28301 \r
28302 .GLOBAL ASOVEC  ;POINTER TO HASH VECTOR IN TV\r
28303 .GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE\r
28304 .GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET\r
28305 .GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ\r
28306 \r
28307 MFUNCTION GETP,SUBR,[GETPROP]\r
28308 \r
28309         ENTRY\r
28310 \r
28311 IGETP:  PUSHJ   P,GETLI\r
28312         JRST    FINIS           ; NO SKIP, LOSE\r
28313         MOVSI   A,TLOCN\r
28314         HLLZ    0,VAL(B)\r
28315         PUSHJ   P,RMONCH        ; CHECK MONITOR\r
28316         MOVE    A,VAL(B)        ;ELSE RETURN VALUE\r
28317         MOVE    B,VAL+1(B)\r
28318 CFINIS: JRST    FINIS\r
28319 \r
28320 ; FUNCTION TO RETURN LOCATIVE TO ASSOC\r
28321 \r
28322 MFUNCTION GETPL,SUBR\r
28323 \r
28324         ENTRY\r
28325 \r
28326 IGETLO: PUSHJ   P,GETLI\r
28327         JRST    FINIS\r
28328         MOVSI   A,TLOCN\r
28329         JRST    FINIS\r
28330 \r
28331 GETLI:  PUSHJ   P,2OR3          ; GET ARGS\r
28332         PUSHJ   P,IGETL         ;SEE IF ASSOCIATION EXISTS\r
28333         SKIPE   B\r
28334         AOS     (P)             ; WIN RETURN\r
28335         CAMGE   AB,[-4,,0]      ; ANY ERROR THING\r
28336         JUMPE   B,CHFIN         ;IF 0, NONE EXISTS\r
28337         POPJ    P,\r
28338 \r
28339 CHFIN:  PUSH    TP,4(AB)\r
28340         PUSH    TP,5(AB)\r
28341         MCALL   1,EVAL\r
28342         POPJ    P,\r
28343 \r
28344 ; COMPILER CALLS TO SOME OF THESE\r
28345 \r
28346 CIGETP: SUBM    M,(P)           ; FIX RET ADDR\r
28347         PUSHJ   P,IGETL         ; GO TO INTERNAL\r
28348         JUMPE   B,MPOPJ\r
28349         MOVSI   A,TLOCN\r
28350 MPOPJ1: SOS     (P)             ; WINNER (SOS BECAUSE OF SUBM M,(P))\r
28351 MPOPJ:  SUBM    M,(P)\r
28352         POPJ    P,\r
28353 \r
28354 CIGTPR: SUBM    M,(P)\r
28355         PUSHJ   P,IGETL\r
28356         JUMPE   B,MPOPJ\r
28357         MOVE    A,VAL(B)        ; GET VAL TYPE\r
28358         MOVE    B,VAL+1(B)\r
28359         JRST    MPOPJ1\r
28360 \r
28361 CIPUTP: SUBM    M,(P)\r
28362         PUSH    TP,-1(TP)       ; SAVE VAL\r
28363         PUSH    TP,-1(TP)\r
28364         PUSHJ   P,IPUT          ; DO IT\r
28365         POP     TP,B\r
28366         POP     TP,A\r
28367         JRST    MPOPJ\r
28368 \r
28369 CIREMA: SUBM    M,(P)\r
28370         PUSHJ   P,IREMAS                ; FLUSH IT\r
28371         JRST    MPOPJ\r
28372 \r
28373 ; CHECK PUT/GET PUTPROP AND GETPROP ARGS\r
28374 \r
28375 2OR3:   HLRE    0,AB\r
28376         ASH     0,-1            ; TO -# OF ARGS\r
28377         ADDI    0,2             ; AT LEAST 2\r
28378         JUMPG   0,TFA           ; 1 OR LESS, LOSE\r
28379         AOJL    0,TMA           ; 4 OR MORE, LOSE\r
28380         MOVE    A,(AB)          ; GET ARGS INTO ACS\r
28381         MOVE    B,1(AB)\r
28382         MOVE    C,2(AB)\r
28383         MOVE    D,3(AB)\r
28384         POPJ    P,\r
28385 \r
28386 ; INTERNAL GET\r
28387 \r
28388 IGET:   PUSHJ   P,IGETL         ; GET LOCATIVE\r
28389         JUMPE   B,CPOPJ\r
28390         MOVE    A,VAL(B)\r
28391         MOVE    B,VAL+1(B)\r
28392         POPJ    P,\r
28393 \r
28394 ; FUNCTION TO MAKE AN ASSOCIATION\r
28395 \r
28396 MFUNCTION PUTP,SUBR,[PUTPROP]\r
28397 \r
28398         ENTRY\r
28399 \r
28400 IPUTP:  PUSHJ   P,2OR3          ; GET ARGS\r
28401         JUMPN   0,REMAS         ; REMOVE AN ASSOCIATION\r
28402         PUSH    TP,4(AB)        ; SAVE NEW VAL\r
28403         PUSH    TP,5(AB)\r
28404         PUSHJ   P,IPUT          ; DO IT\r
28405         MOVE    A,(AB)          ; RETURN NEW VAL\r
28406         MOVE    B,1(AB)\r
28407         JRST    FINIS\r
28408 \r
28409 REMAS:  PUSHJ   P,IREMAS\r
28410         JRST    FINIS\r
28411 \r
28412 IPUT:   SKIPN   DUMNOD+1(TVP)   ; NEW DUMMY NEDDED?\r
28413         PUSHJ   P,DUMMAK        ; YES, GO MAKE ONE\r
28414 IPUT1:  PUSHJ   P,IGETI         ;SEE IF THIS ONE EXISTS\r
28415 \r
28416         JUMPE   B,NEWASO        ;JUMP IF NEED NEW ASSOCIATION BLOCK\r
28417 CLOBV:  MOVE    C,-5(TP)        ; RET NEW VAL\r
28418         MOVE    D,-4(TP)\r
28419         SUB     TP,[6,,6]\r
28420         HLLZ    0,VAL(B)\r
28421         MOVSI   A,TLOCN\r
28422         PUSHJ   P,MONCH         ; MONITOR CHECK\r
28423         MOVEM   C,VAL(B)        ;STORE IT\r
28424         MOVEM   D,VAL+1(B)\r
28425 CPOPJ:  POPJ    P,\r
28426 \r
28427 ; HERE TO CREATE A NEW ASSOCIATION\r
28428 \r
28429 NEWASO: MOVE    B,DUMNOD+1(TVP) ; GET BALNK ASSOCIATION\r
28430         SETZM   DUMNOD+1(TVP)   ; CAUSE NEW ONE NEXT TIME\r
28431 \r
28432 \r
28433 ;NOW SPLICE IN CHAIN\r
28434 \r
28435         JUMPE   D,PUT1  ;NO OTHERS EXISTED IN THIS BUCKET\r
28436         HRLZM   C,PNTRS(B)              ;CLOBBER PREV POINTER\r
28437         HRRM    B,PNTRS(C)              ;AND NEXT POINTER\r
28438         JRST    .+2\r
28439 \r
28440 PUT1:   HRRZM   B,(C)   ;STORE INTO VECTOR\r
28441         HRRZ    C,NODES+1(TVP)\r
28442         HRLM    C,NODPNT(B)\r
28443         MOVE    D,NODPNT(C)\r
28444         HRRZM   B,NODPNT(C)\r
28445         HRRM    D,NODPNT(B)\r
28446         HRLM    B,NODPNT(D)\r
28447         MOVEI   C,-3(TP)        ;COPY ARG POINTER\r
28448         MOVSI   A,-4            ;AND COPY POINTER\r
28449 \r
28450 PUT2:   MOVE    D,(C)   ;START COPYING\r
28451         MOVEM   D,@CLOBTB(A)\r
28452         ADDI    C,1\r
28453         AOBJN   A,PUT2  ;NOTE *** DEPENDS ON ORDER IN VECTOR ***\r
28454 \r
28455         JRST    CLOBV\r
28456 \r
28457 ;HERE TO REMOVE AN ASSOCIATION\r
28458 \r
28459 IREMAS: PUSHJ   P,IGETL         ;LOOK IT UP\r
28460         JUMPE   B,CPOPJ         ;NEVER EXISTED, IGNORE\r
28461         HRRZ    A,PNTRS(B)      ;NEXT POINTER\r
28462         HLRZ    E,PNTRS(B)              ;PREV POINTER\r
28463         SKIPE   A               ;DOES A NEXT EXIST?\r
28464         HRLM    E,PNTRS(A)      ;YES CLOBBER ITS PREV POINTER\r
28465         SKIPN   D               ;SKIP IF NOT FIRST IN BUCKET\r
28466         MOVEM   A,(C)           ;FIRST STORE NEW ONE\r
28467         SKIPE   D               ;OTHERWISE\r
28468         HRRM    A,PNTRS(E)      ;PATCH NEXT POINTER IN PREVIOUS\r
28469         HRRZ    A,NODPNT(B)     ;SEE IF MUST UNSPLICE NODE\r
28470         HLRZ    E,NODPNT(B)\r
28471         SKIPE   A\r
28472         HRLM    E,NODPNT(A)     ;SPLICE\r
28473         JUMPE   E,PUT4          ;FLUSH IF NO PREV POINTER\r
28474         HRRZ    C,NODPNT(E)     ;GET PREV'S NEXT POINTER\r
28475         CAIE    C,(B)           ;DOES IT POINT TO THIS NODE\r
28476         .VALUE  [ASCIZ /:\eFATAL PUT LOSSAGE/]\r
28477         HRRM    A,NODPNT(E)     ;YES, SPLICE\r
28478 PUT4:   MOVE    A,VAL(B)                ;RETURN VALUE\r
28479         SETZM   PNTRS(B)\r
28480         MOVE    B,VAL+1(B)\r
28481         POPJ    P,\r
28482 \r
28483 \r
28484 ;INTERNAL GET FUNCTION CALLED BY PUT AND GET\r
28485 ; A AND B ARE THE ITEM\r
28486 ;C AND D ARE THE INDICATOR\r
28487 \r
28488 IGETL:  PUSHJ   P,IGETI\r
28489         SUB     TP,[4,,4]       ; FLUSH CRUFT LEFT BY IGETI\r
28490         POPJ    P,\r
28491 \r
28492 IGETI:  PUSHJ   P,LHCLR\r
28493         EXCH    A,C\r
28494         PUSHJ   P,LHCLR\r
28495         EXCH    C,A\r
28496         PUSH    TP,A\r
28497         PUSH    TP,B\r
28498         PUSH    TP,C            ;SAVE C AND D\r
28499         PUSH    TP,D\r
28500         XOR     A,B             ; BUILD HASH\r
28501         XOR     A,C\r
28502         XOR     A,D\r
28503         TLZ     A,400000        ; FORCE POS A\r
28504         HLRZ    B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR\r
28505         MOVNS   B\r
28506         IDIVI   A,(B)           ;RELATIVE BUCKET NOW IN B\r
28507         HRLI    B,(B)           ;IN CASE GC OCCURS\r
28508         ADD     B,ASOVEC+1(TVP) ;POINT TO BUCKET\r
28509         MOVEI   D,0             ;SET FIRST SWITCH\r
28510         SKIPN   A,(B)   ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY)\r
28511         JRST    GFALSE\r
28512 \r
28513         MOVSI   0,TASOC         ;FOR INTGOS, MAKE A TASOC\r
28514         HLLZM   0,ASTO(PVP)\r
28515 \r
28516 IGET1:  GETYPF  0,ITEM(A)       ;GET ITEMS TYPE\r
28517 \r
28518         MOVE    E,ITEM+1(A)\r
28519         CAMN    0,-3(TP)                ;COMPARE TYPES\r
28520         CAME    E,-2(TP)        ;AND VALUES\r
28521         JRST    NXTASO          ;LOSER\r
28522         GETYPF  0,INDIC(A)      ;MOW TRY INDICATORS\r
28523         MOVE    E,INDIC+1(A)\r
28524         CAMN    0,-1(TP)\r
28525         CAME    E,(TP)\r
28526         JRST    NXTASO\r
28527 \r
28528         SKIPN   D               ;IF 1ST THEN\r
28529         MOVE    C,B             ;RETURN POINTER IN C\r
28530         MOVE    B,A             ;FOUND, RETURN ASSOCIATION\r
28531         MOVSI   A,TASOC\r
28532 IGRET:  SETZM   ASTO(PVP)\r
28533         POPJ    P,\r
28534 \r
28535 NXTASO: MOVEI   D,1             ;SET SWITCH\r
28536         MOVE    C,A             ;CYCLE\r
28537         HRRZ    A,PNTRS(A)      ;STEP\r
28538         JUMPN   A,IGET1\r
28539 \r
28540         MOVSI   A,TFALSE\r
28541         MOVEI   B,0\r
28542         JRST    IGRET\r
28543 \r
28544 GFALSE: MOVE    C,B     ;PRESERVE VECTOR POINTER\r
28545         MOVSI   A,TFALSE\r
28546         SETZB   B,D\r
28547         JRST    IGRET\r
28548 \r
28549 ; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE\r
28550 \r
28551 REPEAT 0,[\r
28552 MFUNCTION PUTN,SUBR\r
28553 \r
28554         ENTRY\r
28555 \r
28556         CAML    AB,[-4,,0]      ;WAS THIS A REMOVAL\r
28557         JRST    PUT\r
28558 \r
28559         PUSHJ   P,IPUT          ;DO THE PUT\r
28560         SKIPE   NODPNT(C)       ;NODE CHAIN EXISTS?\r
28561         JRST    FINIS\r
28562 \r
28563         PUSH    TP,$TASOC               ;NO, START TO BUILD\r
28564         PUSH    TP,C\r
28565         SKIPN   DUMNOD+1(TVP)   ; FIX UP DUMMY?\r
28566         PUSHJ   P,DUMMAK\r
28567 CHPT:   MOVE    C,$TCHSTR\r
28568         MOVE    D,CHQUOTE NODE\r
28569         PUSHJ   P,IGETL\r
28570         JUMPE   B,MAKNOD        ;NOT FOUND, LOSE\r
28571 NODSPL: MOVE    C,(TP)          ;HERE TO SPLICE IN NEW NODE\r
28572         MOVE    D,VAL+1(B)      ;GET POINTER TO NODE STRING\r
28573         HRRM    D,NODPNT(C)     ;CLOBBER\r
28574         HRLM    B,NODPNT(C)\r
28575         SKIPE   D               ;SPLICE ONLY IF THERE IS SOMETHING THERE\r
28576         HRLM    C,NODPNT(D)\r
28577         MOVEM   C,VAL+1(B)      ;COMPLETE NODE CHAIN\r
28578         MOVE    A,2(AB)         ;RETURN VALUE\r
28579         MOVE    B,3(AB)\r
28580         JRST    FINIS\r
28581 \r
28582 MAKNOD: PUSHJ   P,NEWASO        ;GENERATE THE NEW ASSOCIATION\r
28583         MOVE    A,@CHPT         ;GET UNIQUE STRING\r
28584         MOVEM   A,INDIC(C)              ;CLOBBER IN INDIC\r
28585         MOVE    A,@CHPT+1\r
28586         MOVEM   A,INDIC+1(C)\r
28587         MOVE    B,C             ;POINTER TO B\r
28588         HRRZ    C,NODES+1(TVP)          ;GET POINTER TO CHAIN OF NODES\r
28589         HRRZ    D,VAL+1(C)      ;SKIP DUMMY NODE\r
28590         HRRM    B,VAL+1(C)      ;CLOBBER INTO CHAIN\r
28591         HRRM    D,NODPNT(B)\r
28592         SKIPE   D               ;SPLICE IF ONLY SOMETHING THERE\r
28593         HRLM    B,NODPNT(D)\r
28594         HRLM    C,NODPNT(B)\r
28595         MOVSI   A,TASOC         ;SET TYPE OF VAL TO ASSOCIATION\r
28596         MOVEM   A,VAL(B)\r
28597         SETZM   VAL+1(B)\r
28598         JRST    NODSPL  ;GO SPLICE ITEM ONTO NODE\r
28599 ]\r
28600 \r
28601 DUMMAK: PUSH    TP,A\r
28602         PUSH    TP,B\r
28603         PUSH    TP,C\r
28604         PUSH    TP,D\r
28605         MOVEI   A,ASOLNT\r
28606         PUSHJ   P,IBLOCK\r
28607         MOVSI   A,400000+SASOC+.VECT.\r
28608         MOVEM   A,ASOLNT(B)     ;SET SPECIAL TYPE\r
28609         MOVEM   B,DUMNOD+1(TVP)\r
28610         POP     TP,D\r
28611         POP     TP,C\r
28612         POP     TP,B\r
28613         POP     TP,A\r
28614         POPJ    P,\r
28615 \r
28616 CLOBTB: ITEM(B)\r
28617         ITEM+1(B)\r
28618         INDIC(B)\r
28619         INDIC+1(B)\r
28620         VAL(B)\r
28621         VAL+1(B)\r
28622 \r
28623 MFUNCTION ASSOCIATIONS,SUBR\r
28624 \r
28625         ENTRY   0\r
28626         MOVE    B,NODES+1(TVP)\r
28627 ASSOC1: MOVSI   A,TASOC         ; SET TYPE\r
28628         HRRZ    B,NODPNT(B)     ; POINT TO 1ST REAL NODE\r
28629         JUMPE   B,IFALSE\r
28630         JRST    FINIS\r
28631 \r
28632 ; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE\r
28633 \r
28634 MFUNCTION NEXT,SUBR\r
28635 \r
28636         ENTRY   1\r
28637 \r
28638         GETYP   0,(AB)          ; BETTER BE ASSOC\r
28639         CAIE    0,TASOC\r
28640         JRST    WTYP1           ; LOSE\r
28641         MOVE    B,1(AB)         ; GET ARG\r
28642         JRST    ASSOC1\r
28643 \r
28644 ; GET ITEM/INDICATOR/VALUE CELLS\r
28645 \r
28646 MFUNCTION %ITEM,SUBR,ITEM\r
28647 \r
28648         MOVEI   B,ITEM          ; OFFSET\r
28649         JRST    GETIT\r
28650 \r
28651 MFUNCTION INDICATOR,SUBR\r
28652 \r
28653         MOVEI   B,INDIC\r
28654         JRST    GETIT\r
28655 \r
28656 MFUNCTION AVALUE,SUBR\r
28657 \r
28658         MOVEI   B,VAL\r
28659 GETIT:  ENTRY   1\r
28660         GETYP   0,(AB)          ; BETTER BE ASSOC\r
28661         CAIE    0,TASOC\r
28662         JRST    WTYP1\r
28663         ADD     B,1(AB)         ; GET ARG\r
28664         MOVE    A,(B)\r
28665         MOVE    B,1(B)\r
28666         JRST    FINIS\r
28667 \r
28668 LHCLR:  PUSH    P,A\r
28669         GETYP   A,A\r
28670         PUSHJ   P,NWORDT        ; DEFERRED ?\r
28671         SOJE    A,LHCLR2\r
28672         POP     P,A\r
28673 LHCLR1: TLZ     A,TYPMSK#<-1>\r
28674         POPJ    P,\r
28675 LHCLR2: POP     P,A\r
28676         HLLZS   A\r
28677         JRST    LHCLR1\r
28678 \r
28679 END\r
28680 \f\r
28681 TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE\r
28682 \r
28683 RELOCATABLE\r
28684 \r
28685 .INSRT MUDDLE >\r
28686 \r
28687 SYSQ\r
28688 \r
28689 IF1,[\r
28690 IFE ITS,.INSRT MUDSYS;STENEX >\r
28691 ]\r
28692 \r
28693 .GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB\r
28694 .GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,NOTTY,TTYOP2,IBLOCK\r
28695 .GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS\r
28696 .GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS\r
28697 .GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN\r
28698 .GLOBAL RDEVIC\r
28699 TTYOUT==1\r
28700 TTYIN==2\r
28701 \r
28702 ; FLAGS CONCERNING TTY CHANNEL STATE\r
28703 \r
28704 N.ECHO==1                       ; NO INPUT ECHO\r
28705 N.CNTL==2                       ; NO RUBOUT ^L ^D ECHO\r
28706 N.IMED==4                       ; ALL CHARS WAKE UP\r
28707 N.IME1==10                      ; SOON WILL BE N.IMED\r
28708 \r
28709 \r
28710 ; OPEN BLOCK MODE BITS\r
28711 OUT==1\r
28712 IMAGEM==4\r
28713 ASCIIM==0\r
28714 UNIT==0\r
28715 \r
28716 \r
28717 ; READC IS CALLED BY PUSHJ P,READC\r
28718 ; B POINTS TO A TTY FLAVOR CHANNEL\r
28719 ; ONE CHARACTER IS RETURNED IN  A\r
28720 ; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS\r
28721 \r
28722 ; HERE TO ASK SYSTEM FOR SOME CHARACTERS\r
28723 \r
28724 INCHAR: IRP     A,,[0,C,D,E]    ;SAVE ACS\r
28725         PUSH    P,A\r
28726         TERMIN\r
28727         MOVE    E,BUFRIN(B)             ; GET AUX BUFFER\r
28728         MOVE    D,BYTPTR(E)\r
28729         HLRE    0,E             ;FIND END OF BUFFER\r
28730         SUBM    E,0\r
28731         ANDI    0,-1            ;ISOLATE RH\r
28732         MOVE    C,SYSCHR(E)     ; GET FLAGS\r
28733 \r
28734 INCHR1: TRNE    C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE\r
28735         JRST    DONE\r
28736         TLZE    D,40            ; SKIP IF NOT ESCAPED\r
28737         JRST    INCHR2          ; ESCAPED\r
28738         CAMN    A,ESCAP(E)      ; IF ESCAPE\r
28739         TLO     D,40            ; REMEMBER\r
28740         CAMN    A,BRFCH2(E)\r
28741         JRST    BRF\r
28742         CAMN    A,BRFCHR(E)             ;BUFFER PRINT CHAR\r
28743         JRST    CLEARQ          ;MAYBE CLEAR SCREEN\r
28744         CAMN    A,BRKCH(E)      ;IS THIS A BREAK?\r
28745         JRST    DONE            ;YES, DONE\r
28746         CAMN    A,ERASCH(E)     ;ARE IS IT ERASE?\r
28747         JRST    ERASE           ;YES, GO PROCESS\r
28748         CAMN    A,KILLCH(E)     ;OR KILL\r
28749         JRST    KILL\r
28750 \r
28751 INCHR2: PUSHJ   P,PUTCHR        ;PUT ACHAR IN BUFFER\r
28752 INCHR3: MOVEM   D,BYTPTR(E)\r
28753         JRST    DONE1\r
28754 \r
28755 DONE:   SKIPL   A               ; IF JUST BUFFER FORCE, SKIP\r
28756         PUSHJ   P,PUTCHR        ; STORE CHAR\r
28757         MOVEI   A,N.IMED        ; TURN OFF IMEDIACY\r
28758         ANDCAM  A,SYSCHR(E)\r
28759         MOVEM   D,BYTPTR(E)\r
28760         PUSH    TP,$TCHAN       ; SAVE CHANNEL\r
28761         PUSH    TP,B\r
28762         MOVE    A,CHRCNT(E)     ; GET # OF CHARS\r
28763         SETZM   CHRCNT(E)\r
28764         PUSH    P,A\r
28765         ADDI    A,4             ; ROUND UP\r
28766         IDIVI   A,5             ; AND DOWN\r
28767         PUSHJ   P,IBLOCK        ; GET CORE\r
28768         HLRE    A,B             ; FIND D.W.\r
28769         SUBM    B,A\r
28770         MOVSI   0,TCHRS+.VECT.  ; GET TYPE\r
28771         MOVEM   0,(A)           ; AND STORE\r
28772         MOVEI   D,(B)           ; COPY PNTR\r
28773         POP     P,C             ; CHAR COUNT\r
28774         HRLI    D,440700\r
28775         HRLI    C,TCHSTR\r
28776         PUSH    TP,C\r
28777         PUSH    TP,D\r
28778         PUSHJ   P,INCONS        ; CONS IT ON\r
28779         MOVE    C,-2(TP)        ; GET CHAN BACK\r
28780         MOVEI   D,EXBUFR(C)     ; POINT TO BUFFER LIST\r
28781         HRRZ    0,(D)           ; LAST?\r
28782         JUMPE   0,.+3\r
28783         MOVE    D,0\r
28784         JRST    .-3             ; GO UNTIL END\r
28785         HRRM    B,(D)           ; SPLICE\r
28786 \r
28787 ; HERE TO BLT IN BUFFER\r
28788 \r
28789         MOVE    D,BUFRIN(C)     ; POINT TO COMPLETED BUFFER\r
28790         HRRZ    C,(TP)          ; START OF NEW STRING\r
28791         HRLI    C,BYTPTR+1(D)   ; 1ST WORD OF CHARS\r
28792         MOVE    E,[010700,,BYTPTR(E)]\r
28793         EXCH    E,BYTPTR(D)     ; END OF STRING\r
28794         MOVEI   E,-BYTPTR(E)\r
28795         ADD     E,(TP)          ; ADD TO START\r
28796         BLT     C,-1(E)\r
28797         MOVE    B,-2(TP)        ; CHANNEL BACK\r
28798         SUB     TP,[4,,4]       ; FLUSH JUNK\r
28799         PUSHJ   P,TTYUNB        ; UNBLOCK THIS TTY\r
28800 DONE1:  IRP     A,,[E,D,C,0]\r
28801         POP     P,A\r
28802         TERMIN\r
28803         POPJ    P,\r
28804 \r
28805 \r
28806 ERASE:  SKIPN   CHRCNT(E)       ;ANYTHING IN BUFFER?\r
28807         JRST    BARFCR  ;NO, MAYBE TYPE CR\r
28808 \r
28809         SOS     CHRCNT(E)       ;DELETE FROM COUNT\r
28810         LDB     A,D             ;RE-GOBBLE LAST CHAR\r
28811 IFN ITS,[\r
28812         LDB     C,[600,,STATUS(B)]      ; CHECK FOR IMLAC\r
28813         CAIE    C,2             ; SKIP IF IT IS\r
28814 ]\r
28815         JRST    TYPCHR\r
28816         SKIPN   ECHO(E)         ; SKIP IF ECHOABLE\r
28817         JRST    NECHO\r
28818         PUSHJ   P,CHRTYP        ; FOUND OUT IMALC BEHAVIOR\r
28819         SKIPGE  C,FIXIM2(C)\r
28820         JRST    (C)\r
28821 NOTFUN: PUSHJ   P,DELCHR\r
28822         SOJG    C,.-1\r
28823 \r
28824 NECHO:  ADD     D,[70000,,0]    ;DECREMENT BYTE POINTER\r
28825         JUMPGE  D,INCHR3        ;AND GO ON, UNLESS BYTE POINTER LOST\r
28826         SUB     D,[430000,,1]   ;FIX UP BYTE POINTER\r
28827         JRST    INCHR3\r
28828 \r
28829 LFKILL: PUSHJ   P,LNSTRV\r
28830         JRST    NECHO\r
28831 \r
28832 BSKILL: PUSHJ   P,GETPOS        ; CURRENT POSITION TO A\r
28833         PUSHJ   P,SETPOS        ; POSITION IMLAC CURSOR\r
28834         MOVEI   A,20            ; ^P\r
28835         XCT     ECHO(E)\r
28836         MOVEI   A,"L            ; L , DELETE TO END OF LINE\r
28837         XCT     ECHO(E)\r
28838         JRST    NECHO\r
28839 \r
28840 TBKILL: PUSHJ   P,GETPOS\r
28841         ANDI    A,7\r
28842         SUBI    A,10            ; A -NUMBER OF DELS TO DO\r
28843         PUSH    P,A\r
28844         PUSHJ   P,DELCHR\r
28845         AOSE    (P)\r
28846         JRST    .-2\r
28847 \r
28848         SUB     P,[1,,1]\r
28849         JRST    NECHO\r
28850 TYPCHR:\r
28851 IFE ITS,[\r
28852         PUSH    P,A             ; USE TENEX SLASH RUBOUT\r
28853         MOVEI   A,"\\r
28854         SKIPE   C,ECHO(E)\r
28855         XCT     C\r
28856         POP     P,A\r
28857 ]\r
28858         SKIPE   C,ECHO(E)\r
28859         XCT     C\r
28860         JRST    NECHO\r
28861 \r
28862 ; ROUTINE TO DEL CHAR ON IMLAC\r
28863 \r
28864 DELCHR: MOVEI   A,20\r
28865         XCT     ECHO(E)\r
28866         MOVEI   A,"X\r
28867         XCT     ECHO(E)\r
28868         POPJ    P,\r
28869 \r
28870 ; HERE FOR SPECIAL IMLAC HACKS\r
28871 \r
28872 FOURQ:  PUSH    P,CNOTFU\r
28873 FOURQ2: MOVEI   C,2             ; FOR ^Z AND ^_\r
28874         CAMN    B,TTICHN+1(TVP) ; SKIP IF NOT CONSOLE TTY\r
28875         MOVEI   C,4\r
28876 CNOTFU: POPJ    P,NOTFUN\r
28877 \r
28878 CNECHO: JRST    NECHO\r
28879 \r
28880 LNSTRV: MOVEI   A,20            ; ^P\r
28881         XCT     ECHO(E)\r
28882         MOVEI   A,"U\r
28883         XCT     ECHO(E)\r
28884         POPJ    P,\r
28885 \r
28886 ; HERE IF KILLING A C.R., RE-POSITION CURSOR\r
28887 \r
28888 CRKILL: PUSHJ   P,GETPOS        ; COMPUTE LINE POS\r
28889         PUSHJ   P,SETPOS\r
28890         JRST    NECHO\r
28891 \r
28892 SETPOS: PUSH    P,A             ; SAVE POS\r
28893         MOVEI   A,20\r
28894         XCT     ECHO(E)\r
28895         MOVEI   A,"H\r
28896         XCT     ECHO(E)\r
28897         POP     P,A\r
28898         XCT     ECHO(E)         ; HORIZ POSIT AT END OF LINE\r
28899         POPJ    P,0\r
28900 \r
28901 GETPOS: PUSH    P,0\r
28902         MOVEI   0,10            ; MINIMUM CURSOR POS\r
28903         PUSH    P,[010700,,BYTPTR(E)]   ; POINT TO BUFFER\r
28904         PUSH    P,CHRCNT(E)     ; NUMBER THEREOF\r
28905 \r
28906 GETPO1: SOSGE   (P)             ; COUNT DOWN\r
28907         JRST    GETPO2\r
28908         ILDB    A,-1(P)         ; CHAR FROM BUFFER\r
28909         CAIN    A,15            ; SKIP IF NOT CR\r
28910         MOVEI   0,10            ; C.R., RESET COUNT\r
28911         PUSHJ   P,CHRTYP        ; GET TYPE\r
28912         XCT     FIXIM3(C)       ; GET FIXED COUNT\r
28913         ADD     0,C\r
28914         JRST    GETPO1\r
28915 \r
28916 GETPO2: MOVE    A,0             ; RET COUNT\r
28917         MOVE    0,-2(P)         ; RESTORE AC 0\r
28918         SUB     P,[3,,3]\r
28919         POPJ    P,\r
28920 \r
28921 CHRTYP: MOVEI   C,0             ; NUMBER OF FLUSHEES\r
28922         CAILE   A,37            ; SKIP IF CONTROL CHAR\r
28923         POPJ    P,\r
28924         PUSH    TP,$TCHAN\r
28925         PUSH    TP,B            ; SAVE CHAN\r
28926         IDIVI   A,12.           ; FIND SPECIAL HACKS\r
28927         MOVE    A,FIXIML(A)     ; GET CONT WORD\r
28928         IMULI   B,3\r
28929         ROTC    A,3(B)          ; GET CODE IN B\r
28930         ANDI    B,7\r
28931         MOVEI   C,(B)\r
28932         MOVE    B,(TP)          ; RESTORE CHAN\r
28933         SUB     TP,[2,,2]\r
28934         POPJ    P,\r
28935 \r
28936 FIXIM2: 1\r
28937         2\r
28938         SETZ    FOURQ\r
28939         SETZ    CRKILL\r
28940         SETZ    LFKILL\r
28941         SETZ    BSKILL\r
28942         SETZ    TBKILL\r
28943 \r
28944 FIXIM3: MOVEI   C,1\r
28945         MOVEI   C,2\r
28946         PUSHJ   P,FOURQ2\r
28947         MOVEI   C,0\r
28948         MOVEI   C,0\r
28949         MOVNI   C,1\r
28950         PUSHJ   P,CNTTAB\r
28951 \r
28952 CNTTAB: ANDCMI  0,7     ; GET COUNT INCUDING TAB HACK\r
28953         ADDI    0,10\r
28954         MOVEI   C,0\r
28955         POPJ    P,\r
28956         \r
28957 FIXIML: 111111,,115641  ; CNTL @ABCDE,,FGHIJK\r
28958         131111,,111111  ; LMNOPQ,,RSTUVW\r
28959         112011,,120000  ; XYZ LBRAK \ RBRAK,,^  _\r
28960 \r
28961 ; HERE TO KILL THE WHOLE BUFFER\r
28962 \r
28963 KILL:   CLEARM  CHRCNT(E)       ;NONE LEFT NOW\r
28964         MOVE    D,[010700,,BYTPTR(E)]   ;RESET POINTER\r
28965 \r
28966 BARFCR:\r
28967 IFN ITS,[\r
28968         MOVE    A,ERASCH(E)     ;GET THE ERASE CHAR\r
28969         CAIN    A,177           ;IS IT RUBOUT?\r
28970 ]\r
28971         PUSHJ   P,CRLF1         ; PRINT CR-LF\r
28972         JRST    INCHR3\r
28973 \r
28974 CLEARQ:\r
28975 IFN ITS,[\r
28976         MOVE    A,STATUS(B)     ;CHECK CONSOLE KIND\r
28977         ANDI    A,77\r
28978         CAIN    A,2             ;DATAPOINT?\r
28979         PUSHJ   P,CLR           ;YES, CLEAR SCREEN\r
28980 ]\r
28981 \r
28982 BRF:    MOVE    C,[010700,,BYTPTR(E)]   ;POINT TO START OF BUFFER\r
28983         SKIPN   ECHO(E)         ;ANY ECHO INS?\r
28984         JRST    NECHO\r
28985 \r
28986         PUSHJ   P,CRLF2\r
28987         PUSH    P,CHRCNT(E)\r
28988 \r
28989         SOSGE   (P)\r
28990         JRST    DECHO\r
28991         ILDB    A,C                     ;GOBBLE CHAR\r
28992         XCT     ECHO(E)         ;ECHO IT\r
28993         JRST    .-4             ;DO FOR ENTIRE BUFFER\r
28994 \r
28995 DECHO:  SUB     P,[1,,1]\r
28996         JRST    INCHR3\r
28997 \r
28998 CLR:    SKIPN   C,ECHO(E)       ;ONLY IF INS EXISTS\r
28999         POPJ    P,\r
29000         MOVEI   A,20            ;ERASE SCREEN\r
29001         XCT     C\r
29002         MOVEI   A,103\r
29003         XCT     C\r
29004         POPJ    P,\r
29005 \r
29006 PUTCHR: AOS     CHRCNT(E)       ;COUNT THIS CHARACTER\r
29007         IBP     D               ;BUMP BYTE POINTER\r
29008         CAIG    0,@D            ;DONT SKIP IF BUFFER FULL\r
29009         PUSHJ   P,BUFULL                ;GROW BUFFER\r
29010 IFE ITS,[\r
29011         CAIN    A,37            ; CHANGE EOL TO CRLF\r
29012         MOVEI   A,15\r
29013 ]\r
29014         DPB     A,D             ;CLOBBER BYTE POINTER IN\r
29015         MOVE    C,SYSCHR(E)     ; FLAGS\r
29016         TRNN    C,N.IMED+N.CNTL\r
29017         CAIE    A,15            ; IF CR INPUT, FOLLOW WITH LF\r
29018         POPJ    P,\r
29019         MOVEI   A,12            ; GET LF\r
29020         JRST    PUTCHR\r
29021 \r
29022 ; BUFFER FULL, GROW THE BUFFER\r
29023 \r
29024 BUFULL: PUSH    TP,$TCHAN       ;SAVE B\r
29025         PUSH    TP,B\r
29026         PUSH    P,A             ; SAVE CURRENT CHAR\r
29027         HLRE    A,BUFRIN(B)\r
29028         MOVNS   A\r
29029         ADDI    A,100           ; MAKE ONE LONGER\r
29030         PUSHJ   P,IBLOCK        ; GET IT\r
29031         MOVE    A,(TP)          ;RESTORE CHANNEL POINTER\r
29032         SUB     TP,[2,,2]       ;AND REMOVE CRUFT\r
29033         MOVE    E,BUFRIN(A)     ;GET AUX BUFFER POINTER\r
29034         MOVEM   B,BUFRIN(A)\r
29035         HLRE    0,E             ;RECOMPUTE 0\r
29036         MOVSI   E,(E)\r
29037         HRRI    E,(B)           ; POINT TO DEST\r
29038         SUB     B,0\r
29039         BLT     E,(B)\r
29040         MOVEI   0,100-2(B)\r
29041         MOVE    B,A\r
29042         POP     P,A\r
29043         POPJ    P,\r
29044 \r
29045 ; ROUTINE TO CRLF ON ANY TTY\r
29046 \r
29047 CRLF1:  SKIPN   ECHO(E)\r
29048         POPJ    P,              ; NO ECHO INS\r
29049 CRLF2:  MOVEI   A,15\r
29050         XCT     ECHO(E)\r
29051         MOVEI   A,12\r
29052         XCT     ECHO(E)\r
29053         POPJ    P,\r
29054 \r
29055 ; SUBROUTINE TO FLUSH BUFFER\r
29056 \r
29057 RRESET: SETZM   LSTCH(B)        ; CLOBBER RE-USE CHAR\r
29058         MOVE    E,BUFRIN(B)             ;GET AUX BUFFER\r
29059         SETZM   CHRCNT(E)\r
29060         MOVEI   D,N.IMED+N.IME1\r
29061         ANDCAM  D,SYSCHR(E)\r
29062         MOVE    D,[010700,,BYTPTR(E)]   ;RESET BYTE POINTER\r
29063         MOVEM   D,BYTPTR(E)\r
29064         MOVE    D,CHANNO(B)     ;GOBBLE CHANNEL\r
29065         SETZM   CHNCNT(D)       ; FLUSH COUNTERS\r
29066 IFN ITS,[\r
29067         LSH     D,23.           ;POSITION\r
29068         IOR     D,[.RESET 0]\r
29069         XCT     D               ;RESET ITS CHANNEL\r
29070 ]\r
29071 IFE ITS,[\r
29072         MOVEI   A,100           ; TTY IN JFN\r
29073         CFIBF\r
29074 ]\r
29075         SETZM   EXBUFR(B)       ; CLOBBER STAKED BUFFS\r
29076         MOVEI   C,BUFSTR-1(B)   ; FIND D.W.\r
29077         PUSHJ   P,BYTDOP\r
29078         SUBI    A,2\r
29079         HRLI    A,010700\r
29080         MOVEM   A,BUFSTR(B)\r
29081         HLLZS   BUFSTR-1(B)\r
29082         POPJ    P,\r
29083 \r
29084 ; SUBROUTINE TO ESTABLISH ECHO IOINS\r
29085 \r
29086 MFUNCTION ECHOPAIR,SUBR\r
29087 \r
29088         ENTRY   2\r
29089 \r
29090         GETYP   A,(AB)          ;CHECK ARG TYPES\r
29091         GETYP   C,2(AB)\r
29092         CAIN    A,TCHAN         ;IS A CHANNEL\r
29093         CAIE    C,TCHAN         ;IS C ALSO\r
29094         JRST    WRONGT          ;NO, ONE OF THEM LOSES\r
29095 \r
29096         MOVE    A,1(AB)         ;GET CHANNEL\r
29097         PUSHJ   P,TCHANC        ; VERIFY TTY IN\r
29098         MOVE    D,3(AB)         ;GET OTHER CHANNEL\r
29099         MOVEI   B,DIRECT-1(D)   ;AND ITS DIRECTION\r
29100         PUSHJ   P,CHRWRD\r
29101         JFCL\r
29102         CAME    B,[ASCII /PRINT/]\r
29103         JRST    WRONGD\r
29104 \r
29105         MOVE    B,BUFRIN(A)     ;GET A'S AUX BUFFER\r
29106         HRLZ    C,CHANNO(D)     ; GET CHANNEL\r
29107         LSH     C,5\r
29108         IOR     C,[.IOT A]      ; BUILD AN IOT\r
29109         MOVEM   C,ECHO(B)               ;CLOBBER\r
29110 CHANRT: MOVE    A,(AB)\r
29111         MOVE    B,1(AB)         ;RETURN 1ST ARG\r
29112         JRST    FINIS\r
29113 \r
29114 TCHANC: MOVEI   B,DIRECT-1(A)   ;GET DIRECTION\r
29115         PUSHJ   P,CHRWRD        ; CONVERT\r
29116         JFCL\r
29117         CAME    B,[ASCII /READ/]\r
29118         JRST    WRONGD\r
29119         LDB     C,[600,,STATUS(A)]      ;GET A CODE\r
29120         CAILE   C,2             ;MAKE SURE A TTY FLAVOR DEVICE\r
29121         JRST    WRONGC\r
29122         POPJ    P,\r
29123 IFE ITS,[\r
29124 TTYOPEN:\r
29125 TTYOP2: MOVEI   A,-1            ; TENEX JFN FOR TERMINAL\r
29126         MOVEI   2,145100        ; MAGIC BITS (SEE TENEX MANUAL)\r
29127         SFMOD                   ; ZAP\r
29128         RFMOD                   ; LETS FIND SCREEN SIZE\r
29129         LDB     A,[220700,,B]   ; GET PAGE WIDTH\r
29130         LDB     B,[310700,,B]   ; AND LENGTH\r
29131         MOVE    C,TTOCHN+1(TVP)\r
29132         MOVEM   A,LINLN(C)\r
29133         MOVEM   B,PAGLN(C)\r
29134         MOVEI   A,-1            ; NOW HACK CNTL CHAR STUFF\r
29135         RFCOC                   ; GET CURRENT\r
29136         AND     B,[036377,,-1]  ; CHANGE FOR ^@, ^A AND ^D (FOR NOW)\r
29137         SFCOC                   ; AND RESUSE IT\r
29138 \r
29139         POPJ    P,\r
29140 ]\r
29141 \r
29142 IFN ITS,[\r
29143 TTYOP2: .SUSET  [.RTTY,,C]\r
29144         SETZM   NOTTY\r
29145         JUMPL   C,TTYNO         ; DONT HAVE TTY\r
29146 \r
29147 TTYOPEN:\r
29148         SKIPE   NOTTY\r
29149         POPJ    P,\r
29150         .OPEN   TTYIN,[SIXBIT /   TTY/]\r
29151         JRST    TTYNO\r
29152         .OPEN   TTYOUT,[21,,(SIXBIT /TTY/)]     ;AND OUTPUT\r
29153         FATAL CANT OPEN TTY\r
29154         DOTCAL  TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]]\r
29155         FATAL .CALL FAILURE\r
29156         DOTCAL  TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B]\r
29157         FATAL .CALL FAILURE\r
29158         \r
29159 SETCHN: MOVE    B,TTICHN+1(TVP) ;GET CHANNEL\r
29160         MOVEI   C,TTYIN         ;GET ITS CHAN #\r
29161         MOVEM   C,CHANNO(B)\r
29162         .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS\r
29163 \r
29164         MOVE    B,TTOCHN+1(TVP) ;GET OUT CHAN\r
29165         MOVEI   C,TTYOUT\r
29166         MOVEM   C,CHANNO(B)\r
29167         .STATUS TTYOUT,STATUS(B)\r
29168         SETZM   IMAGFL          ;RESET IMAGE MODE FLAG\r
29169         HLLZS   IOINS-1(B)\r
29170         DOTCAL  RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]]\r
29171         FATAL   .CALL RSSIZE LOSSAGE\r
29172         MOVEM   C,PAGLN(B)\r
29173         MOVEM   D,LINLN(B)\r
29174         POPJ    P,\r
29175 \r
29176 ; HERE IF TTY WONT OPEN\r
29177 \r
29178 TTYNO:  SETOM   NOTTY\r
29179         POPJ    P,\r
29180 ]\r
29181 \r
29182 MTYI:   SKIPE   NOTTY           ; SKIP IF HAVE TTY\r
29183         FATAL TRIED TO USE NON-EXISTANT TTY\r
29184 IFN ITS,        .IOT    TTYIN,A\r
29185 IFE ITS,        PBIN\r
29186         POPJ    P,\r
29187 \r
29188 MTYO:   SKIPE   NOTTY\r
29189         POPJ    P,              ; IGNORE, DONT HAVE TTY\r
29190         SKIPE   IMAGFL          ;SKIP RE-OPENING IF ALREADY IN ASCII\r
29191         PUSHJ   P,MTYO1 ;WAS IN IMAGE...RE-OPEN\r
29192         CAIE    A,177           ;DONT OUTPUT A DELETE\r
29193 IFN ITS,        .IOT    TTYOUT,A\r
29194 IFE ITS,        PBOUT\r
29195         POPJ    P,\r
29196 \r
29197 MTYO1:  MOVE    B,TTOCHN+1(TVP)\r
29198         PUSH    P,0\r
29199         PUSHJ   P,REASCI\r
29200         POP     P,0\r
29201         POPJ    P,\r
29202 \r
29203 ; HERE FOR TYO TO ANY TTY FLAVOR DEVICE\r
29204 \r
29205 GMTYO:  PUSH    P,0\r
29206         HRRZ    0,IOINS-1(B)    ; GET FLAG\r
29207         SKIPE   0\r
29208         PUSHJ   P,REASCI        ; RE-OPEN TTY\r
29209         HRLZ    0,CHANNO(B)\r
29210         ASH     0,5\r
29211         IOR     0,[.IOT A]\r
29212         CAIE    A,177           ; DONE OUTPUT A DELETE\r
29213         XCT     0\r
29214         POP     P,0\r
29215         POPJ    P,\r
29216 \r
29217 REASCI: PUSH    P,A\r
29218         PUSH    P,C\r
29219         PUSHJ   P,DEVTOC\r
29220         HRLI    C,21            ; ASCII GRAPHIC BIT\r
29221         MOVE    A,CHANNO(B)     ; GET CHANNEL\r
29222         ASH     A,23.           ; TO AC FIELD\r
29223         IOR     A,[.OPEN 0,C]\r
29224         XCT     A\r
29225         FATAL TTY OPEN LOSSAGE\r
29226         POP     P,C\r
29227         POP     P,A\r
29228         HLLZS   IOINS-1(B)\r
29229         CAMN    B,TTOCHN+1(TVP)\r
29230         SETZM   IMAGFL\r
29231         POPJ    P,\r
29232 \r
29233 \r
29234 \r
29235 WRONGC: PUSH    TP,$TATOM\r
29236         PUSH    TP,EQUOTE NOT-A-TTY-TYPE-CHANNEL\r
29237         JRST    CALER1\r
29238 \r
29239 \r
29240 \r
29241 ; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING\r
29242 \r
29243 TTYBLK: PUSH    TP,$TCHAN\r
29244         PUSH    TP,B\r
29245         PUSH    P,0\r
29246         PUSH    P,E             ; SAVE SOME ACS\r
29247 IFN ITS,[\r
29248         MOVE    A,CHANNO(B)     ; GET CHANNEL NUMBER\r
29249         SOSG    CHNCNT(A)       ; ANY PENDING CHARS\r
29250         JRST    TTYBL1\r
29251         SETZM   CHNCNT(A)\r
29252         MOVEI   0,1\r
29253         LSH     0,(A)\r
29254         .SUSET  [.SIFPI,,0]     ; SLAM AN INT ON\r
29255 ]\r
29256 TTYBL1: MOVE    C,BUFRIN(B)\r
29257         MOVE    A,SYSCHR(C)     ; GET FLAGS\r
29258         TRZ     A,N.IMED\r
29259         TRZE    A,N.IME1        ; IF WILL BE\r
29260         TRO     A,N.IMED        ; THE MAKE IT\r
29261         MOVEM   A,SYSCHR(C)\r
29262 IFN ITS,[\r
29263         MOVE    A,[.CALL TTYIOT]; NON-BUSY WAIT\r
29264         SKIPE   NOTTY\r
29265         MOVE    A,[.SLEEP A,]\r
29266 ]\r
29267 IFE ITS,[\r
29268         MOVE    A,[PUSHJ P,TNXIN]\r
29269 ]\r
29270         MOVEM   A,WAITNS(B)\r
29271         PUSH    TP,$TCHSTR\r
29272         PUSH    TP,CHQUOTE BLOCKED\r
29273         PUSH    TP,$TPVP\r
29274         PUSH    TP,PVP\r
29275         MCALL   2,INTERRUPT\r
29276         MOVSI   A,TCHAN\r
29277         MOVEM   A,BSTO(PVP)\r
29278         MOVE    B,(TP)\r
29279         ENABLE\r
29280 REBLK:  MOVEI   A,-1            ; IN CASE SLEEPING\r
29281         XCT     WAITNS(B)       ; NOW WAIT\r
29282         JFCL\r
29283 IFE ITS,        JRST    .-3\r
29284 IFN ITS,        JRST    CHRSNR  ; SNARF CHAR\r
29285 REBLK1: DISABLE                 ; FALL THROUG=> UNBLOCKED\r
29286         SETZM   BSTO(PVP)\r
29287         POP     P,E\r
29288         POP     P,0\r
29289         MOVE    B,(TP)\r
29290         SUB     TP,[2,,2]\r
29291         POPJ    P,\r
29292 \r
29293 CHRSNR: SKIPE   NOTTY           ; TTY?\r
29294         JRST    REBLK           ; NO, JUST RESET AND BLOCK\r
29295         .SUSET  [.SIFPI,,[1_<TTYIN>]]\r
29296         JRST    REBLK           ; AND GO BACK\r
29297 \r
29298 TTYIOT: SETZ\r
29299         SIXBIT /IOT/\r
29300         1000,,TTYIN\r
29301         0\r
29302         405000,,20000\r
29303 \r
29304 ; HERE TO UNBLOCK TTY\r
29305 \r
29306 TTYUNB: MOVE    A,WAITNS(B)     ; GET INS\r
29307         CAMN    A,[JRST REBLK1]\r
29308         JRST    TTYUN1\r
29309         MOVE    A,[JRST REBLK1] ; LEAVE THE SLEEP\r
29310         MOVEM   A,WAITNS(B)\r
29311         PUSH    TP,$TCHAN\r
29312         PUSH    TP,B\r
29313         PUSH    TP,$TCHSTR\r
29314         PUSH    TP,CHQUOTE UNBLOCKED\r
29315         PUSH    TP,$TCHAN\r
29316         PUSH    TP,B\r
29317         MCALL   2,INTERRUPT\r
29318         MOVE    B,(TP)          ; RESTORE CHANNEL\r
29319         SUB     TP,[2,,2]\r
29320 TTYUN1: POPJ    P,\r
29321 \r
29322 IFE ITS,[\r
29323 ; TENEX BASIC TTY I/O ROUTINE\r
29324 \r
29325 TNXIN:  PUSHJ   P,MTYI\r
29326         PUSHJ   P,INCHAR\r
29327         POPJ    P,\r
29328 ]\r
29329 MFUNCTION TTYECHO,SUBR\r
29330 \r
29331         ENTRY   2\r
29332 \r
29333         GETYP   0,(AB)\r
29334         CAIE    0,TCHAN\r
29335         JRST    WTYP1\r
29336         MOVE    A,1(AB)         ; GET CHANNEL\r
29337         PUSHJ   P,TCHANC        ; MAKE SURE IT IS TTY INPUT\r
29338         MOVE    E,BUFRIN(A)     ; EXTRA INFO BUFFER\r
29339 IFN ITS,[\r
29340         DOTCAL  TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]]\r
29341         FATAL .CALL FAILURE\r
29342 ]\r
29343 IFE ITS,[\r
29344         MOVEI   A,100           ; TTY JFN\r
29345         RFMOD                   ; MODE IN B\r
29346         TRZ     B,6000          ; TURN OFF ECHO \r
29347 ]\r
29348         GETYP   D,2(AB)         ; ARG 2\r
29349         CAIE    D,TFALSE        ; SKIP IF WANT ECHO OFF\r
29350         JRST    ECHOON\r
29351 \r
29352 IFN ITS,[\r
29353         ANDCM   B,[606060,,606060]\r
29354         ANDCM   C,[606060,,606060]\r
29355 \r
29356         DOTCAL  TTYSET,[CHANNO(A),B,C,0]\r
29357         FATAL .CALL FAILURE\r
29358 ]\r
29359 IFE ITS,[\r
29360         SFMOD\r
29361 ]\r
29362 \r
29363         MOVEI   B,N.ECHO+N.CNTL ; SET FLAGS\r
29364         IORM    B,SYSCHR(E)\r
29365 \r
29366         JRST    CHANRT\r
29367 \r
29368 ECHOON:\r
29369 IFN ITS,[\r
29370         IOR     B,[202020,,202020]\r
29371         IOR     C,[202020,,202020]\r
29372         DOTCAL  TTYSET,[CHANNO(A),B,C,0]\r
29373         FATAL .CALL FAILURE\r
29374 ]\r
29375 IFE ITS,[\r
29376         TRO     B,4000\r
29377         SFMOD\r
29378 ]\r
29379         MOVEI   A,N.ECHO+N.CNTL\r
29380         ANDCAM  A,SYSCHR(E)\r
29381         JRST    CHANRT\r
29382 \r
29383 \r
29384 \r
29385 ; USER SUBR FOR INSTANT CHARACTER SNARFING\r
29386 \r
29387 MFUNCTION UTYI,SUBR,TYI\r
29388 \r
29389         ENTRY\r
29390         CAMGE   AB,[-3,,]\r
29391         JRST    TMA\r
29392         MOVE    A,(AB)\r
29393         MOVE    B,1(AB)\r
29394         JUMPL   AB,.+3\r
29395         MOVE    B,IMQUOTE INCHAN\r
29396         PUSHJ   P,IDVAL         ; USE INCHAN\r
29397         GETYP   0,A             ; GET TYPE\r
29398         CAIE    0,TCHAN\r
29399         JRST    WTYP1\r
29400         LDB     0,[600,,STATUS(B)]\r
29401         CAILE   0,2\r
29402         JRST    WTYP1\r
29403         SKIPN   A,LSTCH(B)      ; ANY READ AHEAD CHAR\r
29404         JRST    UTYI1           ; NO, SKIP\r
29405         SETZM   LSTCH(B)\r
29406         TLZN    A,400000        ; ! HACK?\r
29407         JRST    UTYI2           ; NO, OK\r
29408         MOVEM   A,LSTCH(B)      ; YES SAVE\r
29409         MOVEI   A,"!            ; RET AN !\r
29410         JRST    UTYI2\r
29411 \r
29412 UTYI1:  MOVE    0,IOINS(B)\r
29413         CAME    0,[PUSHJ P,GETCHR]\r
29414         JRST    WTYP1\r
29415         PUSH    TP,$TCHAN\r
29416         PUSH    TP,B\r
29417         MOVE    C,BUFRIN(B)\r
29418         MOVEI   D,N.IME1+N.IMED \r
29419         IORM    D,SYSCHR(C)     ; CLOBBER IT IN\r
29420         DOTCAL  TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]]\r
29421         FATAL .CALL FAILURE\r
29422         PUSH    P,A\r
29423         PUSH    P,0\r
29424         PUSH    P,D             ; SAVE THEM\r
29425         IOR     D,[030303,,030303]\r
29426         IOR     A,[030303,,030303]\r
29427         DOTCAL  TTYSET,[CHANNO(B),A,D,0]\r
29428         FATAL .CALL FAILURE\r
29429         MOVNI   A,1\r
29430         SKIPE   CHRCNT(C)       ; ALREADY SOME?\r
29431         PUSHJ   P,INCHAR\r
29432         MOVE    C,BUFRIN(B)     ; GET BUFFER BACK\r
29433         MOVEI   D,N.IME1\r
29434         IORM    D,SYSCHR(C)\r
29435         PUSHJ   P,GETCHR\r
29436         MOVE    B,1(TB)\r
29437         MOVE    C,BUFRIN(B)\r
29438         MOVEI   D,N.IME1+N.IMED\r
29439         ANDCAM  D,SYSCHR(C)\r
29440         POP     P,D\r
29441         POP     P,0\r
29442         POP     P,C\r
29443         DOTCAL  TTYSET,[CHANNO(B),C,D,0]\r
29444         FATAL .CALL FAILURE\r
29445 UTYI2:  MOVEI   B,(A)\r
29446         MOVSI   A,TCHRS\r
29447         JRST    FINIS\r
29448 \r
29449 MFUNCTION       IMAGE,SUBR\r
29450         ENTRY\r
29451         JUMPGE  AB,TFA          ; 1 OR 2 ARGS NEEDED\r
29452         GETYP   A,(AB)          ;GET THE TYPE OF THE ARG\r
29453         CAIE    A,TFIX          ;CHECK IT FOR CORRECT TYPE\r
29454         JRST    WTYP1           ;WAS WRONG...ERROR EXIT\r
29455         HLRZ    0,AB\r
29456         CAIL    0,-2\r
29457         JRST    USEOTC\r
29458         CAIE    0,-4\r
29459         JRST    TMA\r
29460         GETYP   0,2(AB)\r
29461         CAIE    0,TCHAN\r
29462         JRST    WTYP2\r
29463         MOVE    B,3(AB)         ; GET CHANNEL\r
29464 IMAGE1: LDB     0,[600,,STATUS(B)]\r
29465         CAILE   0,2             ; MUST BE TTY\r
29466         JRST    IMAGFO\r
29467         MOVE    0,IOINS(B)\r
29468         CAMN    0,[PUSHJ P,MTYO]\r
29469         JRST    .+3\r
29470         CAME    0,[PUSHJ P,GMTYO]\r
29471         JRST    WRONGD\r
29472         HRRZ    0,IOINS-1(B)\r
29473         JUMPE   0,OPNIMG\r
29474 IMGIOT: MOVE    A,1(AB)         ;GET VALUE\r
29475         HRLZ    0,CHANNO(B)\r
29476         ASH     0,5\r
29477         IOR     0,[.IOT A]\r
29478         XCT     0\r
29479 IMGEXT: MOVE    A,(AB)          ;RETURN THE ORIGINAL ARG\r
29480         MOVE    B,1(AB)\r
29481         JRST    FINIS           ;EXIT\r
29482 \r
29483 \r
29484 IMAGFO: PUSH    TP,$TCHAN       ;IMAGE OUTPUT FOR NON TTY\r
29485         PUSH    TP,B\r
29486         MOVEI   B,DIRECT-1(B)\r
29487         PUSHJ   P,CHRWRD\r
29488         JFCL\r
29489         CAME    B,[ASCII /PRINT/]\r
29490         CAMN    B,[<ASCII /PRINT/>+1]\r
29491         JRST    .+2\r
29492         JRST    BADCHN          ; CHANNEL COULDNT BE BLESSED\r
29493         MOVE    B,(TP)\r
29494         PUSHJ   P,GWB           ; MAKE SURE CHANNEL HAS BUFFER\r
29495         MOVE    A,1(AB)         ; GET THE CHARACTER TO DO\r
29496         PUSHJ   P,W1CHAR\r
29497         MOVE    A,(AB)\r
29498         MOVE    B,1(AB)         ;RETURN THE FIX\r
29499         JRST    FINIS\r
29500 \r
29501 \r
29502 USEOTC: MOVSI   A,TATOM\r
29503         MOVE    B,IMQUOTE OUTCHAN\r
29504         PUSHJ   P,IDVAL\r
29505         GETYP   0,A\r
29506         CAIE    0,TCHAN\r
29507         MOVE    B,TTICHN+1(TVP)\r
29508         JRST    IMAGE1\r
29509 \r
29510 OPNIMG: HLLOS   IOINS-1(B)\r
29511         CAMN    B,TTOCHN+1(TVP)\r
29512         SETOM   IMAGFL\r
29513         PUSHJ   P,DEVTOC\r
29514         HRLI    C,41            ; SUPER IMAGE BIT\r
29515         MOVE    A,CHANNO(B)\r
29516         ASH     A,23.\r
29517         IOR     A,[.OPEN 0,C]\r
29518         XCT     A\r
29519         FATAL TTY OPEN LOSSAGE\r
29520         JRST    IMGIOT\r
29521 \r
29522 DEVTOC: PUSH    P,D\r
29523         PUSH    P,E\r
29524         PUSH    P,0\r
29525         PUSH    P,A\r
29526         MOVE    D,RDEVIC(B)\r
29527         MOVE    E,[220600,,C]\r
29528         MOVEI   A,3\r
29529         MOVEI   C,0\r
29530         ILDB    0,D\r
29531         SUBI    0,40\r
29532         IDPB    0,E\r
29533         SOJG    A,.-3\r
29534         POP     P,A\r
29535         POP     P,0\r
29536         POP     P,E\r
29537         POP     P,D\r
29538         POPJ    P,\r
29539 \r
29540 IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)\r
29541         0\r
29542         0\r
29543 \r
29544 \r
29545 \r
29546 IMPURE\r
29547 IMAGFL: 0\r
29548 PURE\r
29549 \r
29550 \r
29551 END\r
29552 \f\r
29553 TITLE READER FOR MUDDLE\r
29554 \r
29555 ;C. REEVE DEC. 1970\r
29556 \r
29557 RELOCA\r
29558 \r
29559 READER==1       ;TELL MUDDLE > TO USE SOME SPECIAL HACKS\r
29560 FRMSIN==1       ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST\r
29561 \r
29562 .INSRT MUDDLE >\r
29563 \r
29564 .GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB\r
29565 .GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW\r
29566 .GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP\r
29567 .GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB\r
29568 .GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2\r
29569 .GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS\r
29570 \r
29571 BUFLNT==100\r
29572 \r
29573 FF=0    ;FALG REGISTER DURING NUMBER CONVERSION\r
29574 \r
29575 ;FLAGS USED (RIGHT HALF)\r
29576 \r
29577 NOTNUM==1       ;NOT A NUMBER\r
29578 NFIRST==2       ;NOT FIRST CHARACTER BEING READ\r
29579 DECFRC==4       ;FORCE DECIMAL CONVERSION\r
29580 NEGF==10        ;NEGATE THIS THING\r
29581 NUMWIN==20      ;DIGIT(S) SEEN\r
29582 INSTRN==40      ;IN QUOTED CHARACTER STRING\r
29583 FLONUM==100     ;NUMBER IS FLOOATING POINT\r
29584 DOTSEN==200     ;. SEEN IN IMPUT STREAM\r
29585 EFLG==400       ;E SEEN FOR EXPONENT\r
29586 IFN FRMSIN,[\r
29587         FRSDOT==1000                    ;. CAME FIRST\r
29588         USEAGN==2000                    ;SPECIAL DOT HACK\r
29589 ]\r
29590 OCTWIN==4000\r
29591 OCTSTR==10000\r
29592 \r
29593 ;TEMPORARY OFFSETS\r
29594 \r
29595 VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR\r
29596 ONUM==1 ;CURRENT NUMBER IN OCTAL\r
29597 DNUM==3 ;CURRENT NUMBER IN DECIMAL\r
29598 FNUM==5 ;CURRENTLY UNUSED\r
29599 CNUM==7 ;IN CURRENT RADIX\r
29600 NDIGS==11       ;NUMBER OF DIGITS\r
29601 ENUM==13 ;EXPONENT\r
29602 \r
29603 \r
29604 \f; TEXT FILE LOADING PROGRAM\r
29605 \r
29606 MFUNCTION MLOAD,SUBR,[LOAD]\r
29607 \r
29608         ENTRY\r
29609 \r
29610         HLRZ    A,AB            ;GET NO. OF ARGS\r
29611         CAIE    A,-4            ;IS IT 2\r
29612         JRST    TRY2            ;NO, TRY ANOTHER\r
29613         GETYP   A,2(AB)         ;GET TYPE\r
29614         CAIE    A,TOBLS         ;IS IT OBLIST\r
29615         CAIN    A,TLIST         ; OR LIST THEREOF?\r
29616         JRST    CHECK1\r
29617         JRST    WTYP2\r
29618 \r
29619 TRY2:   CAIE    A,-2            ;IS ONE SUPPLIED\r
29620         JRST    WNA\r
29621 \r
29622 CHECK1: GETYP   A,(AB)          ;GET TYPE\r
29623         CAIE    A,TCHAN         ;IS IT A CHANNEL\r
29624         JRST    WTYP1\r
29625 \r
29626 LOAD1:  HLRZ    A,TB            ;GET CURRENT TIME\r
29627         PUSH    TP,$TTIME       ;AND SAVE IT\r
29628         PUSH    TP,A\r
29629 \r
29630         MOVEI   C,CLSNGO        ; LOCATION OF FUNNY CLOSER\r
29631         PUSHJ   P,IUNWIN        ; SET UP AS UNWINDER\r
29632 \r
29633 LOAD2:  PUSH    TP,(AB)         ;USE SUPPLIED CHANNEL\r
29634         PUSH    TP,1(AB)\r
29635         PUSH    TP,(TB)         ;USE TIME AS EOF ARG\r
29636         PUSH    TP,1(TB)\r
29637         CAML    AB,[-2,,0]      ;CHECK FOR 2ND ARG\r
29638         JRST    LOAD3           ;NONE\r
29639         PUSH    TP,2(AB)        ;PUSH ON 2ND ARG\r
29640         PUSH    TP,3(AB)\r
29641         MCALL   3,READ\r
29642         JRST    CHKRET          ;CHECK FOR EOF RET\r
29643 \r
29644 LOAD3:  MCALL   2,READ\r
29645 CHKRET: CAMN    A,(TB)          ;IS TYPE EOF HACK\r
29646         CAME    B,1(TB)         ;AND IS VALUE\r
29647         JRST    EVALIT          ;NO, GO EVAL RESULT\r
29648         PUSH    TP,(AB)\r
29649         PUSH    TP,1(AB)\r
29650         MCALL   1,FCLOSE\r
29651         MOVE    A,$TCHSTR\r
29652         MOVE    B,CHQUOTE DONE\r
29653         JRST    FINIS\r
29654 \r
29655 CLSNGO: PUSH    TP,$TCHAN\r
29656         PUSH    TP,1(AB)\r
29657         MCALL   1,FCLOSE\r
29658         JRST    UNWIN2          ; CONTINUE UNWINDING\r
29659 \r
29660 EVALIT: PUSH    TP,A\r
29661         PUSH    TP,B\r
29662         MCALL   1,EVAL\r
29663         JRST    LOAD2\r
29664 \r
29665 \r
29666 \r
29667 ; OTHER FILE LOADING PROGRAM\r
29668 \r
29669 \r
29670 \f\r
29671 MFUNCTION FLOAD,SUBR\r
29672 \r
29673         ENTRY\r
29674 \r
29675         MOVEI   C,1             ;INITIALIZE OPEN'S ARG COUNT\r
29676         PUSH    TP,$TAB ;SLOT FOR SAVED AB\r
29677         PUSH    TP,[0]  ;EMPTY FOR NOW\r
29678         PUSH    TP,$TCHSTR      ;PUT IN FIRST ARG\r
29679         PUSH    TP,CHQUOTE READ\r
29680         MOVE    A,AB            ;COPY OF ARGUMENT POINTER\r
29681 \r
29682 FARGS:  JUMPGE  A,CALOPN        ;DONE? IF SO CALL OPEN\r
29683         GETYP   B,(A)           ;NO, CHECK TYPE OF THIS ARG\r
29684         CAIE    B,TOBLS         ;OBLIST?\r
29685         CAIN    B,TLIST         ; OR LIST THEREOF\r
29686         JRST    OBLSV           ;YES, GO SAVE IT\r
29687 \r
29688         PUSH    TP,(A)          ;SAVE THESE ARGS\r
29689         PUSH    TP,1(A)\r
29690         ADD     A,[2,,2]        ;BUMP A\r
29691         AOJA    C,FARGS         ;COUNT AND GO\r
29692 \r
29693 OBLSV:  MOVEM   A,1(TB) ;SAVE THE AB\r
29694 \r
29695 CALOPN: ACALL   C,FOPEN         ;OPEN THE FILE\r
29696 \r
29697         JUMPGE  B,FNFFL ;FILE MUST NO EXIST\r
29698         EXCH    A,(TB)  ;PLACE CHANNEL ON STACK\r
29699         EXCH    B,1(TB)         ;OBTAINING POSSIBLE OBLIST\r
29700         JUMPN   B,2ARGS         ;OBLIST SUOPPLIED?\r
29701 \r
29702         MCALL   1,MLOAD         ;NO, JUST CALL\r
29703         JRST    FINIS\r
29704 \r
29705 \r
29706 2ARGS:  PUSH    TP,(B)          ;PUSH THE OBLIST\r
29707         PUSH    TP,1(B)\r
29708         MCALL   2,MLOAD\r
29709         JRST    FINIS\r
29710 \r
29711 \r
29712 FNFFL:  PUSH    TP,$TATOM\r
29713         PUSH    TP,EQUOTE FILE-SYSTEM-ERROR\r
29714         JUMPE   B,CALER1\r
29715         PUSH    TP,A\r
29716         PUSH    TP,B\r
29717         MOVEI   A,2\r
29718         JRST    CALER\r
29719 \r
29720 \fMFUNCTION READ,SUBR\r
29721 \r
29722         ENTRY\r
29723 \r
29724         PUSH    P,[IREAD1]      ;WHERE TO GO AFTER BINDING\r
29725 READ0:  PUSH    TP,$TTP         ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)\r
29726         PUSH    TP,[0]\r
29727         PUSH    TP,$TFIX        ;SLOT FOR RADIX\r
29728         PUSH    TP,[0]\r
29729         PUSH    TP,$TCHAN       ;AND SLOT FOR CHANNEL\r
29730         PUSH    TP,[0]\r
29731         PUSH    TP,[0]          ; USER DISP SLOT\r
29732         PUSH    TP,[0]\r
29733         PUSH    TP,$TSPLICE\r
29734         PUSH    TP,[0]          ;SEGMENT FOR SPLICING MACROS\r
29735         JUMPGE  AB,READ1        ;NO ARGS, NO BINDING\r
29736         GETYP   C,(AB)          ;ISOLATE TYPE\r
29737         CAIN    C,TUNBOU\r
29738         JRST    WTYP1\r
29739         PUSH    TP,[TATOM,,-1]  ;PUSH THE ATOMS\r
29740         PUSH    TP,IMQUOTE INCHAN\r
29741         PUSH    TP,(AB)         ;PUSH ARGS\r
29742         PUSH    TP,1(AB)\r
29743         PUSH    TP,[0]          ;DUMMY\r
29744         PUSH    TP,[0]\r
29745         MOVE    B,1(AB)         ;GET CHANNEL POINTER\r
29746         ADD     AB,[2,,2]       ;AND ARG POINTER\r
29747         JUMPGE  AB,BINDEM               ;MORE?\r
29748         PUSH    TP,[TVEC,,-1]\r
29749         ADD     B,[EOFCND-1,,EOFCND-1]\r
29750         PUSH    TP,B\r
29751         PUSH    TP,(AB)\r
29752         PUSH    TP,1(AB)\r
29753         ADD     AB,[2,,2]\r
29754         JUMPGE  AB,BINDEM               ;IF ANY MORE ARGS GO PROCESS AND BIND THEM\r
29755         GETYP   C,(AB)          ;ISOLATE TYPE\r
29756         CAIE    C,TLIST\r
29757         CAIN    C,TOBLS\r
29758         SKIPA\r
29759         JRST    WTYP3\r
29760         PUSH    TP,[TATOM,,-1]  ;PUSH THE ATOMS\r
29761         PUSH    TP,IMQUOTE OBLIST\r
29762         PUSH    TP,(AB)         ;PUSH ARGS\r
29763         PUSH    TP,1(AB)\r
29764         PUSH    TP,[0]          ;DUMMY\r
29765         PUSH    TP,[0]\r
29766         ADD     AB,[2,,2]       ;AND ARG POINTER\r
29767         JUMPGE  AB,BINDEM       ; ALL DONE, BIND ATOMS\r
29768         GETYP   0,(AB)          ; GET TYPE OF TABLE\r
29769         CAIE    0,TVEC          ; SKIP IF BAD TYPE\r
29770         JRST    WTYP            ; ELSE COMPLAIN\r
29771         PUSH    TP,[TATOM,,-1]\r
29772         PUSH    TP,IMQUOTE READ-TABLE\r
29773         PUSH    TP,(AB)\r
29774         PUSH    TP,1(AB)\r
29775         PUSH    TP,[0]\r
29776         PUSH    TP,[0]\r
29777         ADD     AB,[2,,2]       ; BUMP TO NEXT ARG\r
29778         JUMPL   AB,TMA          ;MORE ?, ERROR\r
29779 BINDEM: PUSHJ   P,SPECBIND\r
29780         JRST    READ1\r
29781 \r
29782 MFUNCTION RREADC,SUBR,READCHR\r
29783 \r
29784         ENTRY\r
29785         PUSH    P,[IREADC]\r
29786         JRST    READC0          ;GO BIND VARIABLES\r
29787 \r
29788 MFUNCTION NXTRDC,SUBR,NEXTCHR\r
29789 \r
29790         ENTRY\r
29791 \r
29792         PUSH    P,[INXTRD]\r
29793 READC0: CAMGE   AB,[-5,,]\r
29794         JRST    TMA\r
29795         PUSH    TP,(AB)\r
29796         PUSH    TP,1(AB)\r
29797         JUMPL   AB,READC1\r
29798         MOVE    B,IMQUOTE INCHAN\r
29799         PUSHJ   P,IDVAL\r
29800         GETYP   A,A\r
29801         CAIE    A,TCHAN\r
29802         JRST    BADCHN\r
29803         MOVEM   A,-1(TP)\r
29804         MOVEM   B,(TP)\r
29805 READC1: PUSHJ   P,@(P)\r
29806         JRST    .+2\r
29807         JRST    FINIS\r
29808 \r
29809         PUSH    TP,-1(TP)\r
29810         PUSH    TP,-1(TP)\r
29811         MCALL   1,FCLOSE\r
29812         MOVE    A,EOFCND-1(B)\r
29813         MOVE    B,EOFCND(B)\r
29814         CAML    AB,[-3,,]\r
29815         JRST    .+3\r
29816         MOVE    A,2(AB)\r
29817         MOVE    B,3(AB)\r
29818         PUSH    TP,A\r
29819         PUSH    TP,B\r
29820         MCALL   1,EVAL\r
29821         JRST    FINIS\r
29822 \r
29823 \r
29824 MFUNCTION PARSE,SUBR\r
29825 \r
29826         ENTRY\r
29827 \r
29828         PUSHJ   P,GAPRS         ;GET ARGS FOR PARSES\r
29829         PUSHJ   P,GPT           ;GET THE PARSE TABLE\r
29830         PUSHJ   P,NXTCH         ; GET A CHAR TO TEST FOR ! ALT\r
29831         SKIPN   11.(TB)         ; EOF HIT, COMPLAIN TO LOOSER\r
29832         JRST    NOPRS\r
29833         MOVEI   A,33            ; CHANGE IT TO AN ALT, SNEAKY HUH?\r
29834         CAIN    B,MANYT         ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT\r
29835         MOVEM   A,5(TB)\r
29836         PUSHJ   P,IREAD1        ;GO DO THE READING\r
29837         JRST    .+2\r
29838         JRST    LPSRET          ;PROPER EXIT\r
29839 NOPRS:  PUSH    TP,$TATOM\r
29840         PUSH    TP,EQUOTE CAN'T-PARSE\r
29841         JRST    CALER1\r
29842 \r
29843 MFUNCTION LPARSE,SUBR\r
29844 \r
29845         ENTRY\r
29846 \r
29847         PUSHJ   P,GAPRS         ;GET THE ARGS TO THE PARSE\r
29848         JRST    LPRS1\r
29849 \r
29850 GAPRS:  PUSH    TP,$TTP\r
29851         PUSH    TP,[0]\r
29852         PUSH    TP,$TFIX\r
29853         PUSH    TP,[10.]\r
29854         PUSH    TP,$TFIX\r
29855         PUSH    TP,[0]          ; LETTER SAVE\r
29856         PUSH    TP,[0]\r
29857         PUSH    TP,[0]          ; PARSE TABLE MAYBE?\r
29858         PUSH    TP,$TSPLICE\r
29859         PUSH    TP,[0]          ;SEGMENT FOR SPLICING MACROS\r
29860         PUSH    TP,[0]          ;SLOT FOR LOCATIVE TO STRING\r
29861         PUSH    TP,[0]\r
29862         JUMPGE  AB,USPSTR\r
29863         PUSH    TP,[TATOM,,-1]\r
29864         PUSH    TP,IMQUOTE PARSE-STRING\r
29865         PUSH    TP,(AB)\r
29866         PUSH    TP,1(AB)        ; BIND OLD PARSE-STRING\r
29867         PUSH    TP,[0]\r
29868         PUSH    TP,[0]\r
29869         PUSHJ   P,SPECBIND\r
29870         ADD     AB,[2,,2]\r
29871         JUMPGE  AB,USPSTR\r
29872         GETYP   0,(AB)\r
29873         CAIE    0,TFIX\r
29874         JRST    WTYP2\r
29875         MOVE    0,1(AB)\r
29876         MOVEM   0,3(TB)\r
29877         ADD     AB,[2,,2]\r
29878         JUMPGE  AB,USPSTR\r
29879         GETYP   0,(AB)\r
29880         CAIE    0,TLIST\r
29881         CAIN    0,TOBLS\r
29882         SKIPA\r
29883         JRST    WTYP3\r
29884         PUSH    TP,[TATOM,,-1]\r
29885         PUSH    TP,IMQUOTE OBLIST\r
29886         PUSH    TP,(AB)\r
29887         PUSH    TP,1(AB)        ; HE WANTS HIS OWN OBLIST\r
29888         PUSH    TP,[0]\r
29889         PUSH    TP,[0]\r
29890         PUSHJ   P,SPECBIND\r
29891         ADD     AB,[2,,2]\r
29892         JUMPGE  AB,USPSTR\r
29893         GETYP   0,(AB)\r
29894         CAIE    0,TVEC\r
29895         JRST    WTYP\r
29896         PUSH    TP,[TATOM,,-1]\r
29897         PUSH    TP,IMQUOTE PARSE-TABLE\r
29898         PUSH    TP,(AB)\r
29899         PUSH    TP,1(AB)\r
29900         PUSH    TP,[0]\r
29901         PUSH    TP,[0]\r
29902         PUSHJ   P,SPECBIND\r
29903         ADD     AB,[2,,2]\r
29904         JUMPGE  AB,USPSTR\r
29905         GETYP   0,(AB)\r
29906         CAIE    0,TCHRS\r
29907         JRST    WTYP\r
29908         MOVE    0,1(AB)\r
29909         MOVEM   0,5(TB)         ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS\r
29910         ADD     AB,[2,,2]\r
29911         JUMPL   AB,TMA\r
29912 USPSTR: MOVE    B,IMQUOTE PARSE-STRING\r
29913         PUSHJ   P,ILOC          ; GET A LOCATIVE TO THE STRING, WHEREVER\r
29914         GETYP   0,A\r
29915         CAIN    0,TUNBOUND      ; NONEXISTANT\r
29916         JRST    BDPSTR\r
29917         GETYP   0,(B)           ; IT IS POINTING TO A STRING\r
29918         CAIE    0,TCHSTR\r
29919         JRST    BDPSTR\r
29920         MOVEM   A,10.(TB)\r
29921         MOVEM   B,11.(TB)\r
29922         POPJ    P,\r
29923 \r
29924 LPRS1:  PUSHJ   P,GPT           ; GET THE VALUE OF PARSE-TABLE IN SLOT\r
29925         PUSH    TP,$TLIST\r
29926         PUSH    TP,[0]          ; HERE WE ARE MAKE PLACE TO SAVE GOODIES\r
29927         PUSH    TP,$TLIST\r
29928         PUSH    TP,[0]\r
29929 LPRS2:  PUSHJ   P,IREAD1\r
29930         JRST    LPRSDN          ; IF WE ARE DONE, WE ARE THROUGH\r
29931         MOVE    C,A\r
29932         MOVE    D,B\r
29933         PUSHJ   P,INCONS\r
29934         SKIPN   -2(TP)\r
29935         MOVEM   B,-2(TP)        ; SAVE THE BEGINNING ON FIRST\r
29936         SKIPE   C,(TP)\r
29937         HRRM    B,(C)           ; PUTREST INTO IT\r
29938         MOVEM   B,(TP)\r
29939         JRST    LPRS2\r
29940 LPRSDN: MOVSI   A,TLIST\r
29941         MOVE    B,-2(TP)\r
29942 LPSRET: SKIPLE C,5(TB)          ; EXIT FOR PARSE AND LPARSE\r
29943         CAIN    C,400033        ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE\r
29944         JRST    FINIS           ; IF SO NO NEED TO BACK STRING ONE\r
29945         SKIPN   C,11.(TB)\r
29946         JRST    FINIS           ; IF ATE WHOLE STRING, DONT GIVE BACK ANY\r
29947 BUPRS:  MOVEI   D,1\r
29948         ADDM    D,(C)           ; AOS THE COUNT OF STRING LENGTH\r
29949         SKIPG   D,1(C)          ; SEXIER THAN CLR'S CODE FOR DECREMENTING\r
29950         SUB     D,[430000,,1]   ; A BYTE POINTER\r
29951         ADD     D,[70000,,0]\r
29952         MOVEM   D,1(C)\r
29953         HRRZ    E,2(TB)\r
29954         JUMPE   E,FINIS         ; SEE IF WE NEED TO BACK UP TWO\r
29955         HLLZS   2(TB)           ; CLEAR OUT DOUBLE CHR LOOKY FLAG\r
29956         JRST    BUPRS           ; AND BACK UP PARSE STRING A LITTLE MORE\r
29957 \r
29958 \f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS\r
29959 \r
29960 \r
29961 GRT:    MOVE    B,IMQUOTE READ-TABLE\r
29962         SKIPA                   ; HERE TO GET TABLE FOR READ\r
29963 GPT:    MOVE    B,IMQUOTE PARSE-TABLE\r
29964         MOVSI   A,TATOM         ; TO FILL SLOT WITH PARSE TABLE\r
29965         PUSHJ   P,ILVAL\r
29966         GETYP   0,A\r
29967         CAIN    0,TUNBOUND\r
29968         POPJ    P,\r
29969         CAIE    0,TVEC\r
29970         JRST    BADPTB\r
29971         MOVEM   A,6(TB)\r
29972         MOVEM   B,7(TB)\r
29973         POPJ    P,\r
29974 \r
29975 READ1:  PUSHJ   P,GRT\r
29976         MOVE    B,IMQUOTE INCHAN\r
29977         MOVSI   A,TATOM\r
29978         PUSHJ   P,IDVAL         ;NOW GOBBLE THE REAL CHANNEL\r
29979         TLZ     A,TYPMSK#777777\r
29980         HLLZS   A               ; INCASE OF FUNNY BUG\r
29981         CAME    A,$TCHAN        ;IS IT A CHANNEL\r
29982         JRST    BADCHN\r
29983         MOVEM   A,4(TB)         ; STORE CHANNEL\r
29984         MOVEM   B,5(TB)\r
29985         HRRZ    A,-4(B)\r
29986         TRC     A,C.OPN+C.READ\r
29987         TRNE    A,C.OPN+C.READ\r
29988         JRST    WRONGD\r
29989         HLLOS   4(TB)\r
29990         TRNE    A,C.BIN         ; SKIP IF NOT BIN\r
29991         JRST    BREAD           ; CHECK FOR BUFFER\r
29992         HLLZS   4(TB)\r
29993 GETIOA: MOVE    B,5(TB)\r
29994 GETIO:  MOVE    A,IOINS(B)      ;GOBBLE THE I/O INSTRUCTION\r
29995         JUMPE   A,OPNFIL        ;GO REALLY OPEN THE CROCK\r
29996         MOVE    A,RADX(B)       ;GET RADIX\r
29997         MOVEM   A,3(TB)\r
29998         MOVEM   B,5(TB) ;SAVE CHANNEL\r
29999 REREAD: MOVE    D,LSTCH(B)      ;ANY CHARS AROUND?\r
30000         MOVEI   0,33\r
30001         CAIN    D,400033        ;FLUSH THE TERMINATOR HACK\r
30002         MOVEM   0,LSTCH(B)      ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND\r
30003 \r
30004         PUSHJ   P,@(P)          ;CALL INTERNAL READER\r
30005         JRST    BADTRM          ;LOST\r
30006 RFINIS: SUB     P,[1,,1]        ;POP OFF LOSER\r
30007         PUSH    TP,A\r
30008         PUSH    TP,B\r
30009         JUMPE   C,FLSCOM                ; FLUSH TOP LEVEL COMMENT\r
30010         PUSH    TP,C\r
30011         PUSH    TP,D\r
30012         MOVE    A,4(TB)\r
30013         MOVE    B,5(TB)         ; GET CHANNEL\r
30014         MOVSI   C,TATOM\r
30015         MOVE    D,MQUOTE COMMENT\r
30016         PUSHJ   P,IPUT\r
30017 RFINI1: POP     TP,B\r
30018         POP     TP,A\r
30019         JRST    FINIS\r
30020 \r
30021 FLSCOM: MOVE    A,4(TB)\r
30022         MOVE    B,5(TB)\r
30023         MOVSI   C,TATOM\r
30024         MOVE    D,MQUOTE COMMENT\r
30025         PUSHJ   P,IREMAS\r
30026         JRST    RFINI1\r
30027 \r
30028 BADTRM: MOVE    C,5(TB)         ; GET CHANNEL\r
30029         JUMPGE  B,CHLSTC        ;NO, MUST BE UNMATCHED PARENS\r
30030         SETZM   LSTCH(C)        ; DONT REUSE EOF CHR\r
30031         PUSH    TP,4(TB)                ;CLOSE THE CHANNEL\r
30032         PUSH    TP,5(TB)\r
30033         MCALL   1,FCLOSE\r
30034         PUSH    TP,EOFCND-1(B)\r
30035         PUSH    TP,EOFCND(B)\r
30036         MCALL   1,EVAL          ;AND EVAL IT\r
30037         SETZB   C,D\r
30038         GETYP   0,A             ; CHECK FOR FUNNY ACT\r
30039         CAIE    0,TREADA\r
30040         JRST    RFINIS          ; AND RETURN\r
30041 \r
30042         PUSHJ   P,CHUNW         ; UNWIND TO POINT\r
30043         MOVSI   A,TREADA        ; SEND MESSAGE BACK\r
30044         JRST    CONTIN\r
30045 \r
30046 ;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL\r
30047 \r
30048 OPNFIL: PUSHJ   P,OPNCHN        ;GO DO THE OPEN\r
30049         JUMPGE  B,FNFFL         ;LOSE IC B IS 0\r
30050         JRST    GETIO\r
30051 \r
30052 \r
30053 CHLSTC: MOVE    B,5(TB)         ;GET CHANNEL BACK\r
30054         JRST    REREAD\r
30055 \r
30056 \r
30057 BREAD:  MOVE    B,5(TB)         ; GET CHANNEL\r
30058         SKIPE   BUFSTR(B)\r
30059         JRST    GETIO\r
30060         MOVEI   A,BUFLNT                ; GET A BUFFER\r
30061         PUSHJ   P,IBLOCK\r
30062         MOVEI   C,BUFLNT(B)     ; POINT TO END\r
30063         HRLI    C,440700\r
30064         MOVE    B,5(TB)         ; CHANNEL BACK\r
30065         MOVEI   0,C.BUF\r
30066         IORM    0,-4(B)\r
30067         MOVEM   C,BUFSTR(B)\r
30068         MOVSI   C,TCHSTR+.VECT.\r
30069         MOVEM   C,BUFSTR-1(B)\r
30070         JRST    GETIO\r
30071 \f;MAIN ENTRY TO READER\r
30072 \r
30073 NIREAD: PUSHJ   P,LSTCHR\r
30074 NIREA1: PUSH    P,[-1]          ; DONT GOBBLE COMMENTS\r
30075         JRST    IREAD2\r
30076 \r
30077 IREAD:\r
30078         PUSHJ   P,LSTCHR        ;DON'T REREAD LAST CHARACTER\r
30079 IREAD1: PUSH    P,[0]           ; FLAG SAYING SNARF COMMENTS\r
30080 IREAD2: INTGO\r
30081 BDLP:   SKIPE   C,9.(TB)        ;HAVE WE GOT A SPLICING MACRO LEFT\r
30082         JRST    SPLMAC          ;IF SO GIVE HIM SOME OF IT\r
30083         PUSHJ   P,NXTCH         ;GOBBLE CHAR IN A AND TYPE IN D\r
30084         MOVMS   B               ; FOR SPECIAL NEG HACK OF MACRO TABLES\r
30085         CAIG    B,ENTYPE\r
30086         JUMPN   B,@DTBL-1(B)    ;ERROR ON ZERO TYPE OR FUNNY TYPE\r
30087         JRST    BADCHR\r
30088 \r
30089 \r
30090 SPLMAC: HRRZ    D,(C)           ;GET THE REST OF THE SEGMENT\r
30091         MOVEM   D,9.(TB)        ;AND PUT BACK IN PLACE\r
30092         GETYP   D,(C)           ;SEE IF DEFERMENT NEEDED\r
30093         CAIN    D,TDEFER\r
30094         MOVE    C,1(C)          ;IF SO, DO DEFEREMENT\r
30095         MOVE    A,(C)\r
30096         MOVE    B,1(C)          ;GET THE GOODIE\r
30097         AOS     -1(P)           ;ALWAYS A SKIP RETURN\r
30098         POP     P,(P)           ;DONT WORRY ABOUT COMMENT SEARCHAGE\r
30099         SETZB   C,D             ;MAKE SURE HE DOESNT THINK WE GOT COMMENT\r
30100         POPJ    P,              ;GIVE HIM WHAT HE DESERVES\r
30101 \r
30102 DTBL:   NUMLET                  ;HERE IF NUMBER OR LETTER\r
30103         NUMLET                  ;NUMBER\r
30104 NUMCOD==.-DTBL\r
30105         NUMLET                  ;+-\r
30106 PLUMIN==.-DTBL\r
30107         NUMLET                  ;.\r
30108 DOTTYP==.-DTBL\r
30109         NUMLET                  ;E\r
30110 NONSPC==.-DTBL  ;NUMBER OF NON-SPECIAL CHARACTERS\r
30111         SPACE                   ;SPACING CHAR CR,LF,SP,TAB ETC.\r
30112 SPATYP==.-DTBL  ;TYPE FOR SPACE CHARS\r
30113 \r
30114 \r
30115 ;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS\r
30116 \r
30117         LPAREN                  ;( - BEGIN LIST\r
30118         RPAREN                  ;) - END CURRENT LEVEL OF INPUT\r
30119         LBRACK                  ;[ -BEGIN ARRAY\r
30120 LBRTYP==.-DTBL\r
30121         RBRACK                  ;] - END OF ARRAY\r
30122         QUOTIT                  ;' - QUOTE THE FOLLOWING GOODIE\r
30123 QUOTYP==.-DTBL\r
30124 \r
30125         MACCAL                  ;% - INVOKE A READ TIME MACRO\r
30126 MACTYP==.-DTBL\r
30127         CSTRING                 ;" - CHARACTER STRING\r
30128 CSTYP==.-DTBL\r
30129         NUMLET                  ;\ - ESCAPE,BEGIN ATOM\r
30130 \r
30131 ESCTYP==.-DTBL  ;TYPE OF ESCAPE CHARACTER\r
30132 \r
30133         SPECTY                  ;# - SPECIAL TYPE TO BE READ\r
30134 SPCTYP==.-DTBL\r
30135         OPNANG                  ;< - BEGIN ELEMENT CALL\r
30136 \r
30137 SLMNT==.-DTBL   ;TYPE OF START OF SEGMENT\r
30138 \r
30139         CLSANG                  ;> - END ELEMENT CALL\r
30140 \r
30141 \r
30142         EOFCHR                  ;^C - END OF FILE\r
30143 \r
30144         COMNT                   ;; - BEGIN COMMENT\r
30145 COMTYP==.-DTBL  ;TYPE OF START OF COMMENT\r
30146 \r
30147         GLOVAL                  ;, - GET GLOBAL VALUE\r
30148 GLMNT==.-DTBL\r
30149         ILLSQG                  ;{ - START TEMPLATE STRUCTURE\r
30150 TMPTYP==.-DTBL\r
30151         CLSBRA                  ;} - END TEMPLATE STRUCTURE\r
30152 \r
30153 NTYPES==.-DTBL\r
30154 \f\r
30155 \r
30156 \r
30157 ; EXTENDED TABLE FOR ! HACKS\r
30158 \r
30159         NUMLET                  ; !! FAKE OUT\r
30160         SEGDOT                  ;!. - CALL TO LVAL (SEG)\r
30161 DOTEXT==.-DTBL\r
30162         UVECIN                  ;![ - INPUT UNIFORM VECTOR ]\r
30163 LBREXT==.-DTBL\r
30164         QUOSEG                  ;!' - SEG CALL TO QUOTE\r
30165 QUOEXT==.-DTBL\r
30166         SINCHR                  ;!" - INPUT ONE CHARACTER\r
30167 CSEXT==.-DTBL\r
30168         SEGIN                   ;!< - SEG CALL\r
30169 SLMEXT==.-DTBL\r
30170         GLOSEG                  ;!, - SEG CALL TO GVAL\r
30171 GLMEXT==.-DTBL\r
30172         LOSPATH                 ;!- - PATH NAME SEPARATOR\r
30173 PATHTY==.-DTBL\r
30174         TERM                    ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES\r
30175 MANYT==.-DTBL\r
30176         USRDS1                  ; DISPATCH FOR USER TABLE (NO !)\r
30177 USTYP1==.-DTBL\r
30178         USRDS2                  ;   "       "   "     "   (WITH !)\r
30179 USTYP2==.-DTBL\r
30180 ENTYPE==.-DTBL\r
30181 \r
30182 \r
30183 \r
30184 SPACE:  PUSHJ   P,LSTCHR                ;DONT REREAD SPACER\r
30185         JRST    BDLP\r
30186 \r
30187 USRDS1: SKIPA   B,A             ; GET CHAR IN B \r
30188 USRDS2: MOVEI   B,200(A)        ; ! CHAR, DISP 200 FURTHER\r
30189         ASH     B,1\r
30190         ADD     B,7(TB)         ; POINT TO TABLE ENTRY\r
30191         GETYP   0,(B)\r
30192         CAIN    0,TLIST\r
30193         MOVE    B,1(B)          ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK\r
30194         SKIPL   C,5(TB)         ; GET CHANNEL POINTER (IF ANY)\r
30195         JRST    USRDS3\r
30196         ADD     C,[EOFCND-1,,EOFCND-1]\r
30197         PUSH    TP,$TBVL\r
30198         HRRM    SP,(TP)         ; BUILD A TBVL\r
30199         MOVE    SP,TP\r
30200         PUSH    TP,C\r
30201         PUSH    TP,(C)\r
30202         PUSH    TP,1(C)\r
30203         MOVEI   D,PVLNT*2+1(PVP)\r
30204         HRLI    D,TREADA\r
30205         MOVEM   D,(C)\r
30206         MOVEI   D,(TB)\r
30207         HLL     D,OTBSAV(TB)\r
30208         MOVEM   D,1(C)\r
30209 USRDS3: PUSH    TP,(B)          ; APPLIER\r
30210         PUSH    TP,1(B)\r
30211         PUSH    TP,$TCHRS       ; APPLY TO CHARACTER\r
30212         PUSH    TP,A\r
30213         PUSHJ   P,LSTCHR        ; FLUSH CHAR\r
30214         MCALL   2,APPLY         ; GO TO USER GOODIE\r
30215         HRRZ    SP,(SP)         ; UNBIND MANUALLY\r
30216         MOVEI   D,(TP)\r
30217         SUBI    D,(SP)\r
30218         MOVSI   D,(D)\r
30219         HLL     SP,TP\r
30220         SUB     SP,D\r
30221         SUB     TP,[4,,4]       ; FLUSH TP CRAP\r
30222         GETYP   0,A             ; CHECK FOR DISMISS?\r
30223         CAIN    0,TSPLICE\r
30224         JRST    GOTSPL          ; RETURN OF SEGMENT INDICATES SPLICAGE\r
30225         CAIN    0,TREADA        ; FUNNY?\r
30226         JRST    DOEOF\r
30227         CAIE    0,TDISMI\r
30228         JRST    RET             ; NO, RETURN FROM IREAD\r
30229         JRST    BDLP            ; YES, IGNORE RETURN\r
30230 \r
30231 GOTSPL: MOVEM   B,9.(TB)        ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM\r
30232         JRST    BDLP            ; GO BACK AND READ FROM OUR SPLICE, OK?\r
30233 \r
30234 \f\r
30235 ;HERE ON NUMBER OR LETTER, START ATOM\r
30236 \r
30237 NUMLET: PUSHJ   P,GOBBLE        ;READ IN THE ATOM AND PUT PNTR ON ARG PDL\r
30238         JRST    RET             ;NO SKIP RETURN I.E. NON NIL\r
30239 \r
30240 ;HERE TO START BUILDING A CHARACTER STRING GOODIE\r
30241 \r
30242 CSTRING:        PUSHJ   P,GOBBL1        ;READ IN STRING\r
30243         JRST    RET\r
30244 \r
30245 ;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION\r
30246 \r
30247 MACCAL: PUSHJ   P,NXTCH1        ;READ ONE MORE CHARACTER\r
30248         CAIE    B,MACTYP        ;IS IT ANOTHER MACRO CHAR\r
30249 \r
30250         JRST    MACAL2          ;NO, CALL MACRO AND USE VALUE\r
30251         PUSHJ   P,LSTCHR        ;DONT REREAD %\r
30252         PUSHJ   P,MACAL1        ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE\r
30253         JRST    IREAD2\r
30254 \r
30255 MACAL2: PUSH    P,CRET\r
30256 MACAL1: PUSHJ   P,IREAD1        ;READ FUNCTION NAME\r
30257         JRST    RETERR\r
30258         PUSH    TP,C\r
30259         PUSH    TP,D            ; SAVE COMMENT IF ANY\r
30260         PUSH    TP,A            ;SAVE THE RESULT\r
30261         PUSH    TP,B            ;AND USE IT AS AN ARGUMENT\r
30262         MCALL   1,EVAL\r
30263         POP     TP,D\r
30264         POP     TP,C            ; RESTORE COMMENT IF ANY...\r
30265 CRET:   POPJ    P,RET12\r
30266 \r
30267 ;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT\r
30268 \r
30269 SPECTY: PUSHJ   P,NIREAD        ; READ THE TYPES NAME (SHOULD BE AN ATOM)\r
30270         JRST    RETERR\r
30271         PUSH    TP,A\r
30272         PUSH    TP,B\r
30273         PUSHJ   P,NXTCH         ; GET NEXT CHAR\r
30274         CAIN    B,TMPTYP        ; SKIP IF NOT TEMPLATE START\r
30275         JRST    RDTMPL\r
30276         SETZB   A,B\r
30277         EXCH    A,-1(TP)\r
30278         EXCH    B,(TP)\r
30279         PUSH    TP,A            ;BEGIN SETTING UP CHTYPE CALL\r
30280         PUSH    TP,B\r
30281         PUSHJ   P,IREAD1        ;NOW READ STRUCTURE\r
30282         JRST    RETER1\r
30283         MOVEM   C,-3(TP)        ; SAVE COMMENT\r
30284         MOVEM   D,-2(TP)\r
30285         EXCH    A,-1(TP)        ;USE AS FIRST ARG\r
30286         EXCH    B,(TP)\r
30287         PUSH    TP,A            ;USE OTHER AS 2D ARG\r
30288         PUSH    TP,B\r
30289         MCALL   2,CHTYPE        ;ATTEMPT TO MUNG\r
30290 RET13:  POP     TP,D\r
30291         POP     TP,C            ; RESTORE COMMENT\r
30292 RET12:  SETOM   (P)             ; DONT LOOOK FOR MORE!\r
30293         JRST    RET\r
30294 \r
30295 RDTMPL: PUSH    P,["}]          ; SET UP TERMINATE TEST\r
30296         MOVE    B,(TP)\r
30297         PUSHJ   P,IGVAL\r
30298         MOVEM   A,-1(TP)\r
30299         MOVEM   B,(TP)\r
30300         PUSH    P,[BLDTMP]      ; FLAG FOR VECTOR READING CODE\r
30301         JRST    LBRAK2\r
30302 \r
30303 BLDTMP: ADDI    A,1             ; 1 MORE ARGUMENT\r
30304         ACALL   A,APPLY         ; DO IT TO IT\r
30305         POPJ    P,\r
30306 \r
30307 RETER1: SUB     TP,[2,,2]\r
30308 RETERR: SKIPL   A,5(TB)\r
30309         MOVEI   A,5(TB)-LSTCH   ;NO CHANNEL, USE SLOT\r
30310         MOVEM   B,LSTCH(A)      ; RESTORE LAST CHAR\r
30311         PUSHJ   P,ERRPAR\r
30312         JRST    RET1\r
30313 \f\r
30314 ;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS\r
30315 ;BETWEEN (),  ARRIVED AT WHEN ( IS READ\r
30316 \r
30317 SEGIN:  PUSH    TP,$TSEG\r
30318         JRST    OPNAN1\r
30319 \r
30320 OPNANG: PUSH    TP,$TFORM       ;SAVE TYPE\r
30321 OPNAN1: PUSH    P,[">]\r
30322         JRST    LPARN1\r
30323 \r
30324 LPAREN: PUSH    P,[")]\r
30325         PUSH    TP,$TLIST       ;START BY ASSUMING NIL\r
30326 LPARN1: PUSH    TP,[0]\r
30327         PUSHJ   P,LSTCHR        ;DON'T REREAD PARENS\r
30328 LLPLOP: PUSHJ   P,IREAD1        ;READ IT\r
30329         JRST    LDONE           ;HIT TERMINATOR\r
30330 \r
30331 ;HERE WHEN MUST ADD CAR TO CURRENT WINNER\r
30332 \r
30333 GENCAR: PUSH    TP,C            ; SAVE COMMENT\r
30334         PUSH    TP,D\r
30335         MOVE    C,A             ; SET UP CALL\r
30336         MOVE    D,B\r
30337         PUSHJ   P,INCONS        ; CONS ON TO NIL\r
30338         POP     TP,D\r
30339         POP     TP,C\r
30340         POP     TP,E            ;GET CDR\r
30341         JUMPN   E,CDRIN         ;IF STACKED GOODIE NOT NIL SKIP\r
30342         PUSH    TP,B            ;AND USE AS TOTAL VALUE\r
30343         PUSH    TP,$TLIST       ;SAVE THIS AS FIRSST THING ON LIST\r
30344         MOVE    A,-2(TP)        ; GET REAL TYPE\r
30345         JRST    .+2             ;SKIP CDR SETTING\r
30346 CDRIN:  HRRM    B,(E)\r
30347         PUSH    TP,B            ;CLOBBER IN NEW PARTIAL GOODIE\r
30348         JUMPE   C,LLPLOP        ; JUMP IF NO COMMENT\r
30349         PUSH    TP,C\r
30350         PUSH    TP,D\r
30351         MOVSI   C,TATOM\r
30352         MOVE    D,MQUOTE COMMENT\r
30353         PUSHJ   P,IPUT\r
30354         JRST    LLPLOP          ;AND CONTINUE\r
30355 \r
30356 ; HERE TO RAP UP LIST\r
30357 \r
30358 LDONE:  CAME    B,(P)           ;CHECK VALIDITY OF CHARACTER\r
30359         PUSHJ   P,MISMAT        ;REPORT MISMATCH\r
30360         SUB     P, [1,,1]\r
30361         POP     TP,B            ;GET VALUE OF PARTIAL RESULT\r
30362         POP     TP,A            ;AND TYPE OF SAME\r
30363         JUMPE   B,RET           ;VALUE IS NIL, DON'T POP AGAIN\r
30364         POP     TP,B            ;POP FIRST LIST ELEMENT\r
30365         POP     TP,A            ;AND TYPE\r
30366         JRST    RET\r
30367 \f\r
30368 ;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS\r
30369 OPNBRA: PUSH    P,["}]          ; SAVE TERMINATOR\r
30370 UVECIN: PUSH    P,[135]         ; CLOSE SQUARE BRACKET\r
30371         PUSH    P,[IEUVECTOR]   ;PUSH NAME OF U VECT HACKER\r
30372         JRST    LBRAK2          ;AND GO\r
30373 \r
30374 LBRACK: PUSH    P,[135]         ; SAVE TERMINATE\r
30375         PUSH    P,[IEVECTOR]    ;PUSH GEN VECTOR HACKER\r
30376 LBRAK2: PUSHJ   P,LSTCHR        ;FORCE READING NEW CHAR\r
30377         PUSH    P,[0]           ; COUNT ELEMENTS\r
30378         PUSH    TP,$TLIST       ; AND SLOT FOR GOODIES\r
30379         PUSH    TP,[0]\r
30380 \r
30381 LBRAK1: PUSHJ   P,IREAD1        ;RECURSIVELY READ  ELEMENTS OF ARRAY\r
30382         JRST    LBDONE          ;RAP UP ON TERMINATOR\r
30383 \r
30384 STAKIT: EXCH    A,-1(TP)        ; STORE RESULT AND GET CURRENT LIST\r
30385         EXCH    B,(TP)\r
30386         AOS     (P)             ; COUNT ELEMENTS\r
30387         JUMPE   C,LBRAK3        ; IF NO COMMENT, GO ON\r
30388         MOVEI   E,(B)           ; GET CDR\r
30389         PUSHJ   P,ICONS         ; CONS IT ON\r
30390         MOVEI   E,(B)           ; SAVE RS\r
30391         MOVSI   C,TFIX          ; AND GET FIXED NUM\r
30392         MOVE    D,(P)\r
30393         PUSHJ   P,ICONS\r
30394 LBRAK3: PUSH    TP,A            ; SAVE CURRENT COMMENT LIST\r
30395         PUSH    TP,B\r
30396         JRST    LBRAK1\r
30397 \r
30398 ; HERE TO RAP UP VECTOR\r
30399 \r
30400 LBDONE: CAME    B,-2(P)         ; FINISHED RETURN (WAS THE RIGHT STOP USED?)\r
30401         PUSHJ   P,MISMAB        ; WARN USER\r
30402         POP     TP,1(TB)        ; REMOVE COMMENT LIST\r
30403         POP     TP,(TB)\r
30404         MOVE    A,(P)           ; COUNT TO A\r
30405         PUSHJ   P,-1@(P)        ; MAKE THE VECTOR\r
30406         SUB     P,[3,,3]        \r
30407 \r
30408 ; PUT COMMENTS ON VECTOR (OR UVECTOR)\r
30409 \r
30410         MOVNI   C,1             ; INDICATE TEMPLATE HACK\r
30411         CAMN    A,$TVEC\r
30412         MOVEI   C,1\r
30413         CAMN    A,$TUVEC        ; SKIP IF UVECTOR\r
30414         MOVEI   C,0\r
30415         PUSH    P,C             ; SAVE\r
30416         PUSH    TP,A            ; SAVE VECTOR/UVECTOR\r
30417         PUSH    TP,B\r
30418 \r
30419 VECCOM: SKIPN   C,1(TB)         ; ANY LEFT?\r
30420         JRST    RETVEC          ; NO, LEAVE\r
30421         MOVE    A,1(C)          ; ASSUME WINNING TYPES\r
30422         SUBI    A,1\r
30423         HRRZ    C,(C)           ; CDR THE LIST\r
30424         HRRZ    E,(C)           ; AGAIN\r
30425         MOVEM   E,1(TB)         ; SAVE CDR\r
30426         GETYP   E,(C)           ; CHECK DEFFERED\r
30427         MOVSI   D,(E)\r
30428         CAIN    E,TDEFER        ; SKIP IF NOT DEFERRED\r
30429         MOVE    C,1(C)\r
30430         CAIN    E,TDEFER\r
30431         GETYPF  D,(C)           ; GET REAL TYPE\r
30432         MOVE    B,(TP)          ; GET VECTOR POINTER\r
30433         SKIPGE  (P)             ; SKIP IF NOT TEMPLATE\r
30434         JRST    TMPCOM\r
30435         HRLI    A,(A)           ; COUNTER\r
30436         LSH     A,@(P)          ; MAYBE SHIFT IT\r
30437         ADD     B,A\r
30438         MOVE    A,-1(TP)        ; TYPE\r
30439 TMPCO1: PUSH    TP,D\r
30440         PUSH    TP,1(C)         ; PUSH THE COMMENT\r
30441         MOVSI   C,TATOM\r
30442         MOVE    D,MQUOTE COMMENT\r
30443         PUSHJ   P,IPUT\r
30444         JRST    VECCOM\r
30445 \r
30446 TMPCOM: MOVSI   A,(A)\r
30447         ADD     B,A\r
30448         MOVSI   A,TTMPLT\r
30449         JRST    TMPCO1\r
30450 \r
30451 RETVEC: SUB     P,[1,,1]\r
30452         POP     TP,B\r
30453         POP     TP,A\r
30454         JRST    RET\r
30455  \r
30456 ; BUILD A SINGLE CHARACTER ITEM\r
30457 \r
30458 SINCHR: PUSHJ   P,NXTC1         ;FORCE READ NEXT\r
30459         CAIN    B,ESCTYP                ;ESCAPE?\r
30460         PUSHJ   P,NXTC1         ;RETRY\r
30461         MOVEI   B,(A)\r
30462         MOVSI   A,TCHRS\r
30463         JRST    RETCL\r
30464 \r
30465 \f\r
30466 ; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C\r
30467 \r
30468 CLSBRA:\r
30469 CLSANG:                         ;CLOSE ANGLE BRACKETS\r
30470 RBRACK:                         ;COMMON RETURN FOR END OF ARRAY ALSO\r
30471 RPAREN: PUSHJ   P,LSTCHR        ;DON'T REREAD \r
30472 EOFCH1: MOVE    B,A             ;GETCHAR IN B\r
30473         MOVSI   A,TCHRS         ;AND TYPE IN A\r
30474 RET1:   SUB     P,[1,,1]\r
30475         POPJ    P,\r
30476 \r
30477 EOFCHR: SETZB   C,D\r
30478         JUMPL   A,EOFCH1        ; JUMP ON REAL EOF\r
30479         JRST    RRSUBR          ; MAYBE A BINARY RSUBR\r
30480 \r
30481 DOEOF:  MOVE    A,[-1,,3]\r
30482         SETZB   C,D\r
30483         JRST    EOFCH1\r
30484 \r
30485 \r
30486 ; NORMAL RETURN FROM IREAD/IREAD1\r
30487 \r
30488 RETCL:  PUSHJ   P,LSTCHR        ;DONT REREAD\r
30489 RET:    AOS     -1(P)           ;SKIP\r
30490         POP     P,E             ; POP FLAG\r
30491 RETC:   JUMPL   E,RET2          ; DONT LOOK FOR COMMENTS\r
30492         PUSH    TP,A            ; SAVE ITEM\r
30493         PUSH    TP,B\r
30494 CHCOMN: PUSHJ   P,NXTCH         ; READ A CHARACTER \r
30495         CAIE    B,COMTYP        ; SKIP IF COMMENT\r
30496         JRST    CHSPA\r
30497         PUSHJ   P,IREAD         ; READ THE COMMENT\r
30498         JRST    POPAJ\r
30499         MOVE    C,A\r
30500         MOVE    D,B\r
30501         JRST    .+2\r
30502 POPAJ:  SETZB   C,D\r
30503         POP     TP,B\r
30504         POP     TP,A\r
30505 RET2:   POPJ    P,\r
30506 \r
30507 CHSPA:  CAIN    B,SPATYP\r
30508         PUSHJ   P,SPACEQ        ; IS IT A REAL SPACE\r
30509         JRST    POPAJ\r
30510         PUSHJ   P,LSTCHR        ; FLUSH THE SPACE\r
30511         JRST    CHCOMN\r
30512 \r
30513 ;RANDOM MINI-SUBROUTINES USED BY THE READER\r
30514 \r
30515 ;READ A CHAR INTO A AND TYPE CODE INTO D\r
30516 \r
30517 NXTC1:  SKIPL   B,5(TB) ;GET CHANNEL\r
30518         JRST    NXTPR1          ;NO CHANNEL, GO READ STRING\r
30519         SKIPE   LSTCH(B)\r
30520         PUSHJ   P,CNTACC        ; COUNT ON ACCESS POINTER\r
30521         JRST    NXTC2\r
30522 NXTC:   SKIPL   B,5(TB) ;GET CHANNEL\r
30523         JRST    NXTPRS          ;NO CHANNEL, GO READ STRING\r
30524         SKIPE   A,LSTCH(B)      ;CHAR IN A IF REUSE\r
30525         JRST    PRSRET\r
30526 NXTC2:  PUSHJ   P,RXCT          ;GET CHAR FROM INPUT\r
30527         HLLZS   2(TB)           ;FLAG INDICATING ONE CHAR LOOK AHEAD\r
30528         MOVEM   A,LSTCH(B)      ;SAVE THE CHARACTER\r
30529 PRSRET: TRZE    A,400000        ;DONT SKIP IF SPECIAL\r
30530         JRST    RETYPE          ;GO HACK SPECIALLY\r
30531 GETCTP: CAILE   A,177           ; CHECK RANGE\r
30532         JRST    BADCHR\r
30533         PUSH    P,A     ;AND SAVE FROM DIVISION\r
30534         ANDI    A,177\r
30535         IDIVI   A,CHRWD ;YIELDS WORD AND CHAR NUMBER\r
30536         LDB     B,BYTPNT(B)     ;GOBBLE TYPE CODE\r
30537         POP     P,A\r
30538         POPJ    P,\r
30539 \r
30540 NXTPRS: SKIPE   A,5(TB)         ;GET OLD CHARACTER IF ONE EXISTS\r
30541         JRST    PRSRET\r
30542 NXTPR1: MOVEI   A,400033\r
30543         PUSH    P,C\r
30544         MOVE    C,11.(TB)\r
30545         HRRZ    B,(C)           ;GET THE STRING\r
30546         SOJL    B,NXTPR3\r
30547         HRRM    B,(C)\r
30548         ILDB    A,1(C)  ;GET THE CHARACTER FROM THE STRING\r
30549 NXTPR2: MOVEM   A,5(TB)         ;SAVE IT\r
30550         POP     P,C\r
30551         JRST    PRSRET          ;CONTINUE\r
30552 NXTPR3: SETZM   8.(TB)\r
30553         SETZM   9.(TB)          ;CLEAR OUT LOCATIVE, AT END OF STRING\r
30554         JRST    NXTPR2\r
30555 \r
30556 ; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !\r
30557 ; HACKS\r
30558 \r
30559 NXTCH1: PUSHJ   P,NXTC1         ;READ CHAR\r
30560         JRST    .+2\r
30561 NXTCH:  PUSHJ   P,NXTC          ;READ CHAR\r
30562         CAIGE   B,NTYPES+1      ;IF 1 > THAN MAX, MUST BE SPECIAL\r
30563         JRST    CHKUS1          ; CHECK FOR USER DISPATCH\r
30564 \r
30565         CAIN    B,NTYPES+1      ;FOR OBSCURE BUG FOUND BY MSG\r
30566         PUSHJ   P,NXTC1         ;READ NEXT ONE\r
30567         HLLOS   2(TB)           ;FLAG FOR TWO CHAR LOOK AHEAD\r
30568 \r
30569 RETYP1: CAIN    A,".            ;!.\r
30570         MOVEI   B,DOTEXT        ;YES, GET EXTENDED TYPE\r
30571         CAIN    A,"[\r
30572         MOVEI   B,LBREXT\r
30573         CAIN    A,"'\r
30574         MOVEI   B,QUOEXT\r
30575         CAIN    A,""\r
30576         MOVEI   B,CSEXT\r
30577         CAIN    A,"-\r
30578         MOVEI   B,PATHTY\r
30579         CAIN    A,"<\r
30580         MOVEI   B,SLMEXT\r
30581         CAIN    A,",\r
30582         MOVEI   B,GLMEXT\r
30583         CAIN    A,33\r
30584         MOVEI   B,MANYT         ;! ALTMODE\r
30585 \r
30586 CRMLST: ADDI    A,400000                ;CLOBBER LASTCHR\r
30587         PUSH    P,B\r
30588         SKIPL   B,5(TB)         ;POINT TO CHANNEL\r
30589         MOVEI   B,5(TB)-LSTCH   ;NO CHANNEL, POINT AT SLOT\r
30590         MOVEM   A,LSTCH(B)\r
30591         SUBI    A,400000                ;DECREASE CHAR\r
30592         POP     P,B\r
30593 \r
30594 CHKUS2: SKIPN   7(TB)           ; SKIP IF USER TABLE\r
30595         JRST    UPLO\r
30596         PUSH    P,A\r
30597         ADDI    A,200\r
30598         ASH     A,1             ; POINT TO SLOT\r
30599         HRLS    A\r
30600         ADD     A,7(TB)\r
30601         SKIPL   A               ;IS THERE VECTOR ENOUGH?\r
30602         JRST    CHKUS4\r
30603         SKIPN   1(A)            ; NON-ZERO==>USER FCN EXISTS\r
30604         JRST    CHKUS4          ; HOPE HE APPRECIATES THIS\r
30605         MOVEI   B,USTYP2\r
30606 CHKRDO: PUSH    P,0             ; CHECK FOR REDOING IF CHAR IN TABLE\r
30607         GETYP   0,(A)\r
30608         CAIE    0,TCHRS\r
30609         JRST    CHKUS5\r
30610         POP     P,0             ;WE ARE TRANSMOGRIFYING\r
30611         POP     P,(P)           ;FLUSH OLD CHAR\r
30612         MOVE    A,1(A)          ;GET NEW CHARACTER\r
30613         PUSH    P,7(TB)\r
30614         PUSH    P,2(TB)         ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD\r
30615         PUSH    P,5(TB)         ; TO AVOID SMASHING LSTCHR\r
30616         SETZM   5(TB)           ; CLEAR OUT CHANNEL\r
30617         SETZM   7(TB)   ;CLEAR OUT TABLE\r
30618         TRZE    A,200           ; ! HACK\r
30619         TRO     A,400000        ; TURN ON PROPER BIT\r
30620         PUSHJ   P,PRSRET\r
30621         POP     P,5(TB)         ; GET BACK CHANNEL\r
30622         POP     P,2(TB)\r
30623         POP     P,7(TB)         ;GET BACK OLD PARSE TABLE\r
30624         POPJ    P,\r
30625 \r
30626 CHKUS5: CAIE    0,TLIST\r
30627         JRST    .+4             ; SPECIAL NON-BREAK TYPE HACK\r
30628         MOVNS   -1(P)           ; INDICATE BY NEGATIVE \r
30629         MOVE    A,1(A)          ; GET <1 LIST>\r
30630         GETYP   0,(A)           ; AND GET THE TYPE OF THAT\r
30631         CAIE    0,TFIX          ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE\r
30632         JRST    CHKUS6          ; JUST A VANILLA HACK\r
30633         MOVE    A,1(A)          ; PRETEND IT IS SAME TYPE AS NEW CHAR\r
30634         PUSH    P,7(TB)         ; CLEAR OUT TRANSLATE TABLE\r
30635         PUSH    P,2(TB)         ; FLAGS FOR # OF CHRS IN LOOK AHEAD\r
30636         SETZM   7(TB)\r
30637         TRZE    A,200\r
30638         TRO     A,400000        ; TURN ON PROPER BIT IF ! HACK\r
30639         PUSHJ   P,PRSRET                ; REGET TYPE\r
30640         POP     P,2(TB)\r
30641         POP     P,7(TB) ; PUT TRANSLATE TABLE BACK\r
30642 CHKUS6: SKIPGE  -1(P)           ; SEE IF A SPECIAL NON-BREAK\r
30643         MOVNS   B               ; SEXY, HUH?\r
30644         POP     P,0\r
30645         POP     P,A\r
30646         MOVMS   A               ; FIX UP A POSITIVE CHARACTER\r
30647         POPJ    P,\r
30648 \r
30649 CHKUS4: POP     P,A\r
30650         JRST    UPLO\r
30651 \r
30652 CHKUS1: SKIPN   7(TB)           ; USER CHECK FOR NOT ! CASE\r
30653         POPJ    P,\r
30654         PUSH    P,A\r
30655         ASH     A,1\r
30656         HRLS    A\r
30657         ADD     A,7(TB)\r
30658         SKIPL   A\r
30659         JRST    CHKUS3\r
30660         SKIPN   1(A)\r
30661         JRST    CHKUS3\r
30662         MOVEI   B,USTYP1\r
30663         JRST    CHKRDO          ; TRANSMOGRIFY CHARACTER?\r
30664 \r
30665 CHKUS3: POP     P,A\r
30666         POPJ    P,\r
30667 \r
30668 UPLO:   POPJ    P,              ; LETS NOT AND SAY WE USED TO\r
30669                                 ; AVOID STRANGE ! BLECHAGE\r
30670 \r
30671 RETYPE: PUSHJ   P,GETCTP        ;GET TYPE OF CHAR\r
30672         JRST    RETYP1\r
30673 \r
30674 NXTCS:  PUSHJ   P,NXTC\r
30675         PUSH    P,A             ; HACK TO NOT TRANSLATE CHAR\r
30676         PUSHJ   P,CHKUS1        ; BUT DO TRANSLATION OF TYPE IF HE WANTS\r
30677         POP     P,A             ; USED TO BUILD UP STRINGS\r
30678         POPJ    P,\r
30679 \r
30680 CHKALT: CAIN    A,33            ;ALT?\r
30681         MOVEI   B,MANYT\r
30682         JRST    CRMLST\r
30683 \r
30684 \r
30685 TERM:   MOVEI   B,0             ;RETURN A 0\r
30686         JRST    RET1\r
30687                 ;AND RETURN\r
30688 \r
30689 CHKMIN: CAIN    A,"-            ; IF CHAR IS -, WINNER\r
30690         MOVEI   B,PATHTY\r
30691         JRST    CRMLST\r
30692 \r
30693 LOSPAT: PUSHJ   P,LSTCHR                ; FIX RECURSIVE LOSAGE\r
30694         PUSH    TP,$TATOM\r
30695         PUSH    TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR\r
30696         JRST    CALER1\r
30697 \r
30698 \f\r
30699 ; HERE TO SEE IF READING RSUBR\r
30700 \r
30701 RRSUBR: PUSHJ   P,LSTCHR        ; FLUSH JUST READ CHAR\r
30702         SKIPL   B,5(TB)         ; SKIP IF A CHANNEL EXISTS\r
30703         JRST    SPACE           ; ELSE LIKE A SPACE\r
30704         MOVE    C,@BUFSTR(B)    ; SEE IF FLAG SAYS START OF RSUBR\r
30705         TRNN    C,1             ; SKIP IF REAL RSUBR\r
30706         JRST    SPACE           ; NO, IGNORE FOR NOW\r
30707 \r
30708 ; REALLY ARE READING AN RSUBR\r
30709 \r
30710         HRRZ    0,4(TB)         ; GET READ/READB INDICATOR\r
30711         MOVE    C,ACCESS(B)     ; GET CURRENT ACCESS\r
30712         JUMPN   0,.+3           ; ALREADY WORDS, NO NEED TO DIVIDE\r
30713         ADDI    C,4             ; ROUND UP\r
30714         IDIVI   C,5\r
30715         PUSH    P,C             ; SAVE WORD ACCESS\r
30716         MOVEI   A,(C)           ; COPY IT FOR CALL\r
30717         JUMPN   0,.+3\r
30718         IMULI   C,5\r
30719         MOVEM   C,ACCESS(B)     ; FIXUP ACCESS\r
30720         HLLZS   ACCESS-1(B)     ; FOR READB LOSER\r
30721         PUSHJ   P,DOACCS        ; AND GO THERE\r
30722         PUSH    P,[0]           ; FOR READ IN\r
30723         HRROI   A,(P)           ; PREPARE TO READ LENGTH\r
30724         PUSHJ   P,DOIOTI        ; READ IT\r
30725         POP     P,C             ; GET READ GOODIE\r
30726         MOVEI   A,(C)           ; COPY FOR GETTING BLOCK\r
30727         ADDI    C,1             ; COUNT COUNT WORD\r
30728         ADDM    C,(P)\r
30729         PUSH    TP,$TUVEC       ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY\r
30730         PUSH    TP,[0]\r
30731         PUSHJ   P,IBLOCK        ; GET A BLOCK\r
30732         PUSH    TP,$TUVEC\r
30733         PUSH    TP,B            ; AND SAVE\r
30734         MOVE    A,B             ; READY TO IOT IT IN\r
30735         MOVE    B,5(TB)         ; GET CHANNEL BACK\r
30736         MOVSI   0,TUVEC         ; SETUP A'S TYPE\r
30737         MOVEM   0,ASTO(PVP)\r
30738         PUSHJ   P,DOIOTI                ; IN COMES THE WHOLE BLOCK\r
30739         SETZM   ASTO(PVP)       ; A NO LONGER SPECIAL\r
30740         MOVEI   C,BUFSTR-1(B)   ; NO RESET BUFFER\r
30741         PUSHJ   P,BYTDOP        ; A POINTS TO DOPW WORD\r
30742         SUBI    A,2\r
30743         HRLI    A,010700        ; SETUP BYTE POINTER TO END\r
30744         HLLZS   BUFSTR-1(B)     ; ZERO CHAR COUNNT\r
30745         MOVEM   A,BUFSTR(B)\r
30746         HRRZ    A,4(TB)         ; READ/READB FLG\r
30747         MOVE    C,(P)           ; ACCESS IN WORDS\r
30748         SKIPN   A               ; SKIP FOR ASCII\r
30749         IMULI   C,5             ; BUMP\r
30750         MOVEM   C,ACCESS(B)     ; UPDATE ACCESS\r
30751         PUSHJ   P,NIREAD        ; READ RSUBR VECTOR\r
30752         JRST    BRSUBR          ; LOSER\r
30753         GETYP   A,A             ; VERIFY A LITTLE\r
30754         CAIE    A,TVEC          ; DONT SKIP IF BAD\r
30755         JRST    BRSUBR          ; NOT A GOOD FILE\r
30756         PUSHJ   P,LSTCHR        ; FLUSH REREAD CHAR\r
30757         MOVE    C,(TP)          ; CODE VECTOR BACK\r
30758         MOVSI   A,TCODE\r
30759         HLR     A,B             ; FUNNY COUNT\r
30760         MOVEM   A,(B)           ; CLOBBER\r
30761         MOVEM   C,1(B)\r
30762         PUSH    TP,$TRSUBR      ; MAKE RSUBR\r
30763         PUSH    TP,B\r
30764 \r
30765 ; NOW LOOK OVER FIXUPS\r
30766 \r
30767         MOVE    B,5(TB)         ; GET CHANNEL\r
30768         MOVE    C,ACCESS(B)\r
30769         HLLZS   ACCESS-1(B)     ; FOR READB LOSER\r
30770         HRRZ    0,4(TB)         ; READ/READB FLG\r
30771         JUMPN   0,RSUB1\r
30772         ADDI    C,4             ; ROUND UP\r
30773         IDIVI   C,5             ; TO WORDS\r
30774         MOVEI   D,(C)           ; FIXUP ACCESS\r
30775         IMULI   D,5\r
30776         MOVEM   D,ACCESS(B)     ; AND STORE\r
30777 RSUB1:  ADDI    C,1             ; ACCOUNT FOR EXTRA COUNTERS\r
30778         MOVEM   C,(P)           ; SAVE FOR LATER\r
30779         MOVEI   A,-1(C)         ; FOR DOACS\r
30780         MOVEI   C,2             ; UPDATE REAL ACCESS\r
30781         SKIPN   0               ; SKIP FOR READB CASE\r
30782         MOVEI   C,10.\r
30783         ADDM    C,ACCESS(B)\r
30784         PUSHJ   P,DOACCS        ; DO THE ACCESS\r
30785         PUSH    TP,$TUVEC       ; SLOT FOR FIXUP BUFFER\r
30786         PUSH    TP,[0]\r
30787 \r
30788 ; FOUND OUT IF FIXUPS STAY\r
30789 \r
30790         MOVE    B,MQUOTE KEEP-FIXUPS\r
30791         PUSHJ   P,ILVAL         ; GET VALUE\r
30792         GETYP   0,A\r
30793         MOVE    B,5(TB)         ; CHANNEL BACK TO B\r
30794         CAIE    0,TUNBOU\r
30795         CAIN    0,TFALSE\r
30796         JRST    RSUB4           ; NO, NOT KEEPING FIXUPS\r
30797         PUSH    P,[0]           ; SLOT TO READ INTO\r
30798         HRROI   A,(P)           ; GET LENGTH OF SAME\r
30799         PUSHJ   P,DOIOTI\r
30800         POP     P,C\r
30801         MOVEI   A,(C)           ; GET UVECTOR FOR KEEPING\r
30802         ADDM    C,(P)           ; ACCESS TO END\r
30803         PUSH    P,C             ; SAVE LENGTH OF FIXUPS\r
30804         PUSHJ   P,IBLOCK\r
30805         MOVEM   B,-6(TP)        ; AND SAVE\r
30806         MOVE    A,B             ; FOR IOTING THEM IN\r
30807         ADD     B,[1,,1]        ; POINT PAST VERS #\r
30808         MOVEM   B,(TP)\r
30809         MOVSI   C,TUVEC\r
30810         MOVEM   C,ASTO(PVP)\r
30811         MOVE    B,5(TB)         ; AND CHANNEL\r
30812         PUSHJ   P,DOIOTI                ; GET THEM\r
30813         SETZM   ASTO(PVP)\r
30814         MOVE    A,(TP)          ; GET VERS\r
30815         PUSH    P,-1(A)         ; AND PUSH IT\r
30816         JRST    RSUB5\r
30817 \r
30818 RSUB4:  PUSH    P,[0]\r
30819         PUSH    P,[0]           ; 2 SLOTS FOR READING\r
30820         MOVEI   A,-1(P)\r
30821         HRLI    A,-2\r
30822         PUSHJ   P,DOIOTI\r
30823         MOVE    C,-1(P)\r
30824         MOVE    D,(P)\r
30825         ADDM    C,-2(P)         ; NOW -2(P) IS ACCESS TO END OF FIXUPS\r
30826 RSUB5:  MOVEI   C,BUFSTR-1(B)   ; FIXUP BUFFER \r
30827         PUSHJ   P,BYTDOP\r
30828         SUBI    A,2             ; POINT BEFORE D.W.\r
30829         HRLI    A,10700\r
30830         MOVEM   A,BUFSTR(B)\r
30831         HLLZS   BUFSTR-1(B)\r
30832         SKIPE   -6(TP)\r
30833         JRST    RSUB2A\r
30834         SUBI    A,BUFLNT-1      ; ALSO MAKE AN IOT FLAVOR BUFFER\r
30835         HRLI    A,-BUFLNT\r
30836         MOVEM   A,(TP)\r
30837         MOVSI   C,TUVEC\r
30838         MOVEM   C,ASTO(PVP)\r
30839         PUSHJ   P,DOIOTI\r
30840         SETZM   ASTO(PVP)\r
30841 RSUB2A: PUSH    P,-1(P)         ; ANOTHER COPY OF LENGTH OF FIXUPS\r
30842 \r
30843 ; LOOP FIXING UP NEW TYPES\r
30844 \r
30845 RSUB2:  PUSHJ   P,WRDIN         ; SEE WHAT NEXT THING IS\r
30846         JRST    RSUB3           ; NO MORE, DONE\r
30847         JUMPL   E,STSQ          ; MUST BE FIRST SQUOZE\r
30848         MOVNI   0,(E)           ; TO UPDATE AMNT OF FIXUPS\r
30849         ADDB    0,(P)\r
30850         HRLI    E,(E)           ; IS LENGTH OF STRING IN WORDS\r
30851         ADD     E,(TP)          ; FIXUP BUFFER POINTER\r
30852         JUMPL   E,.+3\r
30853         SUB     E,[BUFLNT,,BUFLNT]\r
30854         JUMPGE  E,.-1           ; STILL NOT RIGHT\r
30855         EXCH    E,(TP)          ; FIX UP SLOT\r
30856         HLRE    C,E             ; FIX BYTE POINTER ALSO\r
30857         IMUL    C,[-5]          ; + CHARS LEFT\r
30858         MOVE    B,5(TB)         ; CHANNEL\r
30859         PUSH    TP,BUFSTR-1(B)\r
30860         PUSH    TP,BUFSTR(B)\r
30861         HRRM    C,BUFSTR-1(B)\r
30862         HRLI    E,440700        ; AND BYTE POINTER\r
30863         MOVEM   E,BUFSTR(B)\r
30864         PUSHJ   P,NIREAD        ; READ ATOM NAME OF TYPE\r
30865         TDZA    0,0             ; FLAG LOSSAGE\r
30866         MOVEI   0,1             ; WINNAGE\r
30867         MOVE    C,5(TB)         ; RESET BUFFER\r
30868         POP     TP,BUFSTR(C)\r
30869         POP     TP,BUFSTR-1(C)\r
30870         JUMPE   0,BRSUBR        ; BAD READ OF RSUBR\r
30871         GETYP   A,A             ; A LITTLE CHECKING\r
30872         CAIE    A,TATOM\r
30873         JRST    BRSUBR\r
30874         PUSHJ   P,LSTCHR        ; FLUSH REREAD CHAR\r
30875         HRRZ    0,4(TB)         ; FIXUP ACCESS PNTR\r
30876         MOVE    C,5(TB)\r
30877         MOVE    D,ACCESS(C)\r
30878         HLLZS   ACCESS-1(C)     ; FOR READB HACKER\r
30879         ADDI    D,4\r
30880         IDIVI   D,5\r
30881         IMULI   D,5\r
30882         SKIPN   0\r
30883         MOVEM   D,ACCESS(C)     ; RESET\r
30884 TYFIXE: PUSHJ   P,TYPFND        ; SEE IF A LEGAL TYPE NAME\r
30885         JRST    TYPFIX          ; GO SEE USER ABOUT THIS\r
30886         PUSHJ   P,FIXCOD        ; GO FIX UP THE CODE\r
30887         JRST    RSUB2\r
30888 \r
30889 ; NOW FIX UP SUBRS ETC. IF NECESSARY\r
30890 \r
30891 STSQ:   MOVE    B,MQUOTE MUDDLE\r
30892         PUSHJ   P,IGVAL         ; GET CURRENT VERS\r
30893         CAME    B,-1(P)         ; SKIP IF NO FIXUPS NEEDED\r
30894         JRST    DOFIX0          ; MUST DO THEM\r
30895 \r
30896 ; ALL DONE, ACCESS PAST FIXUPS AND RETURN\r
30897 \r
30898 RSUB3:  MOVE    A,-3(P)\r
30899         MOVE    B,5(TB)\r
30900         MOVEI   C,(A)           ; UPDATE CHANNEL ACCESS IN CASE SKIPPING\r
30901         HRRZ    0,4(TB)         ; READ/READB FLAG\r
30902         SKIPN   0\r
30903         IMULI   C,5\r
30904         MOVEM   C,ACCESS(B)     ; INTO ACCESS SLOT\r
30905         HLLZS   ACCESS-1(B)\r
30906         PUSHJ   P,DOACCS        ; ACCESSED\r
30907         MOVEI   C,BUFSTR-1(B)   ; FIX UP BUFFER\r
30908         PUSHJ   P,BYTDOP\r
30909         SUBI    A,2\r
30910         HRLI    A,10700\r
30911         MOVEM   A,BUFSTR(B)\r
30912         HLLZS   BUFSTR-1(B)\r
30913         SKIPN   A,-6(TP)                ; SKIP IF KEEPING FIXUPS\r
30914         JRST    RSUB6\r
30915         PUSH    TP,$TUVEC\r
30916         PUSH    TP,A\r
30917         MOVSI   A,TRSUBR\r
30918         MOVE    B,-4(TP)\r
30919         MOVSI   C,TATOM\r
30920         MOVE    D,MQUOTE RSUBR\r
30921         PUSHJ   P,IPUT          ; DO THE ASSOCIATION\r
30922 \r
30923 RSUB6:  MOVE    B,-2(TP)        ; GET RSUBR\r
30924         MOVSI   A,TRSUBR\r
30925         SUB     P,[4,,4]        ; FLUSH P CRUFT\r
30926         SUB     TP,[10,,10]\r
30927         JRST    RET\r
30928 \r
30929 ; FIXUP SUBRS ETC.\r
30930 \r
30931 DOFIX0: SKIPN   C,-6(TP)                ; GET BUFFER IF KEEPING\r
30932         JRST    DOFIXE\r
30933         MOVEM   B,(C)           ; CLOBBER\r
30934         JRST    DOFIXE\r
30935 \r
30936 FIXUPL: PUSHJ   P,WRDIN\r
30937         JRST    RSUB3\r
30938 DOFIXE: JUMPGE  E,BRSUBR\r
30939         TLZ     E,740000        ; KILL BITS\r
30940         PUSHJ   P,SQUTOA        ; LOOK IT UP\r
30941         JRST    BRSUBR\r
30942         MOVEI   D,(E)           ; FOR FIXCOD\r
30943         PUSHJ   P,FIXCOD        ; FIX 'EM UP\r
30944         JRST    FIXUPL\r
30945 \r
30946 ; ROUTINE TO FIXUP ACTUAL CODE\r
30947 \r
30948 FIXCOD: MOVEI   E,0             ; FOR HWRDIN\r
30949         PUSH    P,D             ; NEW VALUE\r
30950         PUSHJ   P,HWRDIN        ; GET HW NEEDED\r
30951         MOVE    D,(P)           ; GET NEW VAL\r
30952         MOVE    A,(TP)          ; AND BUFFER POINTER\r
30953         SKIPE   -6(TP)          ; SAVING?\r
30954         HRLM    D,-1(A)         ; YES, CLOBBER\r
30955         SUB     C,(P)           ; DIFFERENCE\r
30956         MOVN    D,C\r
30957 \r
30958 FIXLP:  PUSHJ   P,HWRDIN        ; GET AN OFFSET\r
30959         JUMPE   C,FIXED\r
30960         HRRES   C               ; MAKE NEG IF NEC\r
30961         JUMPL   C,LHFXUP\r
30962         ADD     C,-4(TP)        ; POINT INTO CODE\r
30963         ADDM    D,-1(C)\r
30964         JRST    FIXLP\r
30965 \r
30966 LHFXUP: MOVMS   C\r
30967         ADD     C,-4(TP)\r
30968         MOVSI   0,(D)\r
30969         ADDM    0,-1(C)\r
30970         JRST    FIXLP\r
30971 \r
30972 FIXED:  SUB     P,[1,,1]\r
30973         POPJ    P,\r
30974 \r
30975 ; ROUTINE TO READ A WORD FROM BUFFER\r
30976 \r
30977 WRDIN:  PUSH    P,A\r
30978         PUSH    P,B\r
30979         SOSG    -3(P)           ; COUNT IT DOWN\r
30980         JRST    WRDIN1\r
30981         AOS     -2(P)           ; SKIP RETURN\r
30982         MOVE    B,5(TB)         ; CHANNEL\r
30983         HRRZ    A,4(TB)         ; READ/READB SW\r
30984         MOVEI   E,5\r
30985         SKIPE   A\r
30986         MOVEI   E,1\r
30987         ADDM    E,ACCESS(B)\r
30988         MOVE    A,(TP)          ; BUFFER\r
30989         MOVE    E,(A)\r
30990         AOBJP   A,WRDIN2        ; NEED NEW BUFFER\r
30991         MOVEM   A,(TP)\r
30992 WRDIN1: POP     P,B\r
30993         POP     P,A\r
30994         POPJ    P,\r
30995 \r
30996 WRDIN2: MOVE    B,-3(P)         ; IS THIS LAST WORD?\r
30997         SOJLE   B,WRDIN1        ; YES, DONT RE-IOT\r
30998         SUB     A,[BUFLNT,,BUFLNT]\r
30999         MOVEM   A,(TP)\r
31000         MOVSI   B,TUVEC\r
31001         MOVEM   B,ASTO(PVP)\r
31002         MOVE    B,5(TB)\r
31003         PUSHJ   P,DOIOTI\r
31004         SETZM   ASTO(PVP)\r
31005         JRST    WRDIN1\r
31006 \r
31007 ; READ IN NEXT HALF WORD\r
31008 \r
31009 HWRDIN: JUMPN   E,NOIOT         ; USE EXISTING WORD\r
31010         PUSH    P,-3(P)         ; FAKE OUT WRDIN IF NEC.\r
31011         PUSHJ   P,WRDIN\r
31012         JRST    BRSUBR\r
31013         POP     P,-4(P)         ; RESET COUNTER\r
31014         HLRZ    C,E             ; RET LH \r
31015         POPJ    P,\r
31016 \r
31017 NOIOT:  HRRZ    C,E\r
31018         MOVEI   E,0\r
31019         POPJ    P,\r
31020 \r
31021 TYPFIX: PUSH    TP,$TATOM\r
31022         PUSH    TP,EQUOTE BAD-TYPE-NAME\r
31023         PUSH    TP,$TATOM\r
31024         PUSH    TP,B\r
31025         PUSH    TP,$TATOM\r
31026         PUSH    TP,EQUOTE ERRET-TYPE-NAME-DESIRED\r
31027         MCALL   3,ERROR\r
31028         JRST    TYFIXE\r
31029 \r
31030 BRSUBR: PUSH    TP,$TATOM\r
31031         PUSH    TP,EQUOTE RSUBR-IN-BAD-FORMAT\r
31032         JRST    CALER1\r
31033 \f\r
31034 \r
31035 \r
31036 ;TABLE OF BYTE POINTERS FOR GETTING CHARS\r
31037 \r
31038 BYTPNT":        350700,,CHTBL(A)\r
31039         260700,,CHTBL(A)\r
31040         170700,,CHTBL(A)\r
31041         100700,,CHTBL(A)\r
31042         010700,,CHTBL(A)\r
31043 \r
31044 ;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS\r
31045 ;IN THE NUMBER LETTER CATAGORY)\r
31046 \r
31047 SETCHR 2,[0123456789]\r
31048 \r
31049 SETCHR 3,[+-]\r
31050 \r
31051 SETCHR 4,[.]\r
31052 \r
31053 SETCHR 5,[Ee]\r
31054 \r
31055 SETCOD 6,[15,12,11,14,40,33]    ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)\r
31056 \r
31057 INCRCH 7,[()[]'%"\#<>]  ;GIVE THESE INCREASRNG CODES FROM 3\r
31058 \r
31059 SETCOD 22,[3]   ;^C - EOF CHARACTER\r
31060 \r
31061 INCRCH 23,[;,{}!]               ;COMMENT AND GLOBAL VALUE AND SPECIAL\r
31062 \r
31063 CHTBL:\r
31064         OUTTBL                  ;OUTPUT THE TABLE RIGHT HERE\r
31065 \r
31066 \r
31067 \f; THIS CODE FLUSHES WANDERING COMMENTS\r
31068 \r
31069 COMNT:  PUSHJ   P,IREAD\r
31070         JRST    COMNT2\r
31071         JRST    BDLP\r
31072 \r
31073 COMNT2: SKIPL   A,5(TB)         ; RESTORE CHANNEL\r
31074         MOVEI   A,5(TB)-LSTCH   ;NO CHANNEL, POINT AT SLOT\r
31075         MOVEM   B,LSTCH(A)      ; CLOBBER IN CHAR\r
31076         PUSHJ   P,ERRPAR\r
31077         JRST    BDLP\r
31078 \f\r
31079 ;SUBROUTINE TO READ CHARS ONTO STACK\r
31080 \r
31081 GOBBL1: MOVEI   FF,0            ;KILL ALL FLAGS\r
31082         PUSHJ   P,LSTCHR        ;DON'T REREAD "\r
31083         TROA    FF,NOTNUM+INSTRN        ;SURPRESS NUMBER CONVERSION\r
31084 GOBBLE: MOVEI   FF,0            ;FLAGS CONCERRNING CURRENT GOODIE IN HERE\r
31085         MOVE    A,TP            ;GOBBLE CURRENT TP TO BE PUSHED\r
31086         MOVEI   C,6             ;NOW PUSH 6 0'S ON TO STACK\r
31087         PUSH    TP,$TFIX        ;TYPE IS FIXED\r
31088         PUSH    TP,FF           ;AND VALUE IS 0\r
31089         SOJG    C,.-2           ;FOUR OF THEM\r
31090         PUSH    TP,$TTP         ;NOW SAVE OLD TP\r
31091         ADD     A,[1,,1]        ;MAKE IT LOOK LIKE A TB\r
31092         PUSH    TP,A\r
31093         MOVEI   D,0             ;ZERO OUT CHARACTER COUNT\r
31094 GOB1:   MOVSI   C,(<440700,,(P)>)       ;SET UP FIRST WORD OF CHARS\r
31095         PUSH    P,[0]           ;BYTE POINTER\r
31096 GOB2:   PUSH    P,FF            ;SAVE FLAG REGISTER\r
31097         INTGO                   ; IN CASE P OVERFLOWS\r
31098         MOVEI   A,NXTCH\r
31099         TRNE    FF,INSTRN\r
31100         MOVEI   A,NXTCS         ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE\r
31101         PUSHJ   P,(A)\r
31102         POP     P,FF            ;AND RESTORE FLAG REGISTER\r
31103         CAIN    B,ESCTYP        ;IS IT A CHARACTER TO BE ESCAPED\r
31104         JRST    ESCHK           ;GOBBLE THE ESCAPED CHARACTER\r
31105         TRNE    FF,INSTRN       ;ARE WE BUILDING A CHAR STRING\r
31106         JRST    ADSTRN          ;YES, GO READ IN\r
31107         CAILE   B,NONSPC        ;IS IT SPECIAL\r
31108         JRST    DONEG           ;YES, RAP THIS UP\r
31109 \r
31110         TRNE    FF,NOTNUM       ;IS  NUMERIC STILL WINNING\r
31111         JRST    SYMB2           ;NO, ONLY DO CHARACTER HACKING\r
31112         CAIL    A,60            ;CHECK FOR DIGIT\r
31113         CAILE   A,71\r
31114         JRST    SYMB1   ;NOT A DIGIT\r
31115         JRST    CNV             ;GO CONVERT TO NUMBER\r
31116 \fCNV:\r
31117 \r
31118 ;ARRIVE HERE IF STILL BUILDING A NUMBER\r
31119 CNV:    MOVE    B,(TP)  ;GOBBLE POINTER TO TEMPS\r
31120         TRO     FF,NUMWIN       ;SAY DIGITSSEEN\r
31121         SUBI    A,60    ;CONVERT TO  A NUMBER\r
31122         TRNE    FF,EFLG ;HAS E BEEN SEEN\r
31123         JRST    ECNV            ;YES, CONVERT EXPONENT\r
31124         TRNE    FF,DOTSEN       ;HAS A DOT BEEN SEEN\r
31125 \r
31126         JRST    DECNV           ;YES, THIS IS A FLOATING NUMBER\r
31127 \r
31128         MOVE    E,ONUM(B)       ; OCTAL CONVERT\r
31129         LSH     E,3\r
31130         ADDI    E,(A)\r
31131         MOVEM   E,ONUM(B)\r
31132         TRNE    FF,OCTSTR       ; SKIP OTHER CONVERSIONS IF OCTAL FORCE\r
31133         JRST    CNV1\r
31134 \r
31135         JFCL    17,.+1  ;KILL ALL FLAGS\r
31136         MOVE    E,CNUM(B)       ;COMPUTE CURRENT RADIX\r
31137         IMUL    E,3(TB)\r
31138         ADD     E,A     ;ADD IN CURRENT DIGIT\r
31139         JFCL    10,.+2\r
31140         MOVEM   E,CNUM(B)       ;AND SAVE IT\r
31141 \r
31142 \r
31143 \r
31144 ;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY\r
31145         JRST    DECNV1          ;CONVERT TO DECIMAL(FIXED)\r
31146 \r
31147 \r
31148 DECNV:  TRO     FF,FLONUM       ;SET FLOATING FLAG\r
31149 DECNV1: JFCL    17,.+1  ;CLEAR ALL FLAGS\r
31150         MOVE    E,DNUM(B)       ;GET DECIMAL NUMBER\r
31151         IMULI   E,10.\r
31152         JFCL    10,CNV2 ;JUMP IF OVERFLOW\r
31153         ADD     E,A     ;ADD IN DIGIT\r
31154         MOVEM   E,DNUM(B)\r
31155         TRNE    FF,FLONUM       ;IS THIS FRACTION?\r
31156         SOS     NDIGS(B)        ;YES, DECREASE EXPONENT BY ONE\r
31157 \r
31158 CNV1:   PUSHJ   P,NXTCH         ;RE-GOBBLE CHARACTER\r
31159         JRST    SYMB2           ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
31160 CNV2:                           ;OVERFLOW IN DECIMAL NUMBER\r
31161         TRNE    FF,DOTSEN       ;IS THIS FRACTION PART?\r
31162         JRST    CNV1            ;YES,IGNORE DIGIT\r
31163         AOS     NDIGS(B)        ;NO, INCREASE IMPLICIT EXPONENT BY ONE\r
31164         TRO     FF,FLONUM       ;SET FLOATING FLAG BUT \r
31165         JRST    CNV1            ;DO NOT FORCE DECIMAL(DECFRC)\r
31166 \r
31167 ECNV:                   ;CONVERT A DECIMAL EXPONENT\r
31168         HRRZ    E,ENUM(B)       ;GET EXPONENT\r
31169         IMULI   E,10.\r
31170         ADD     E,A             ;ADD IN DIGIT\r
31171         TLNN    E,777777        ;IF OVERFLOW INTO LEFT HALF\r
31172         HRRM    E,ENUM(B)       ;DO NOT STORE(CATCH ERROR LATER)\r
31173         JRST    CNV1\r
31174         JRST    SYMB2           ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
31175 \r
31176 \f\r
31177 ;HERE TO PUT INTO IDENTIFIER BEING BUILT\r
31178 \r
31179 ESCHK:  PUSHJ   P,NXTC1         ;GOBBLE NEXT CHAR\r
31180 SYMB:   MOVE    B,(TP)          ;GET BACK TEM POINTER\r
31181         TRNE    FF,EFLG         ;IF E FLAG SET\r
31182         HLRZ    FF,ENUM(B)      ;RESTORE SAVED FLAGS\r
31183         TRO     FF,NOTNUM       ;SET NOT NUMBER FLAG\r
31184 SYMB2:  TRO     FF,NFIRST       ;NOT FIRST IN WORLD\r
31185 SYMB3:  IDPB    A,C             ;INSERT IT\r
31186         PUSHJ   P,LSTCHR        ;READ NEW CHARACTER\r
31187         TLNE    C,760000        ;WORD FULL?\r
31188         AOJA    D,GOB2          ;NO, KEEP TRYING\r
31189         AOJA    D,GOB1          ;COUNT WORD AND GO\r
31190 \r
31191 ;HERE TO CHECK FOR +,-,. IN NUMBER\r
31192 \r
31193 SYMB1:  TRNE    FF,NFIRST       ;IS THIS THE FIRST CHARACTER\r
31194         JRST    CHECK.          ;NO, ONLY LOOK AT DOT\r
31195         CAIE    A,"-            ;IS IT MINUS\r
31196         JRST    .+3             ;NO CHECK PLUS\r
31197         TRO     FF,NEGF         ;YES, NEGATE AT THE END\r
31198         JRST    SYMB2\r
31199         CAIN    A,"+            ;IS IT +\r
31200         JRST    SYMB2           ;ESSENTIALLY IGNORE IT\r
31201         CAIE    A,"*            ; FUNNY OCTAL CROCK?\r
31202         JRST    CHECK.\r
31203 \r
31204         TRO     FF,OCTSTR\r
31205         JRST    SYMB2\r
31206 \r
31207 ;COULD BE .\r
31208 \r
31209 CHECK.: PUSHJ   P,LSTCHR        ;FLUSH LAST CHARACTER\r
31210         MOVEI   E,0\r
31211         TRNN    FF,DOTSEN+EFLG  ;IF ONE ALREADY SEEN\r
31212         CAIE    A,".\r
31213         JRST    CHECKE          ;GO LOOK FOR E\r
31214 \r
31215 IFN FRMSIN,[\r
31216         TRNN    FF,NFIRST       ;IS IT THE FIRST\r
31217         JRST    DOT1            ;YES, COULD MEAN EVALUATE A VARIABLE\r
31218 ]\r
31219 \r
31220 CHCK.1: TRO     FF,DECFRC+DOTSEN        ;FORCE DECIMAL \r
31221 IFN FRMSIN,     TRNN    FF,FRSDOT       ;IF NOT FIRST ., PUT IN CHAR STRING\r
31222         JRST    SYMB2           ;ENTER INTO SYMBOL\r
31223 IFN FRMSIN,     JRST    GOB2            ;IGNORE THE "."\r
31224 \f\r
31225 \r
31226 \r
31227 IFN FRMSIN,[\r
31228 \r
31229 ;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>\r
31230 \r
31231 DOT1:   PUSH    P,FF            ;SAVE FLAGS\r
31232         PUSHJ   P,NXTCH1        ;GOBBLE A NEW CHARACTER\r
31233         POP     P,FF            ;RESTORE FLAGS\r
31234         TRO     FF,FRSDOT               ;SET FLAG IN CASE\r
31235         CAIN    B,NUMCOD                ;SKIP IF NOT NUMERIC\r
31236         JRST    CHCK.1          ;NUMERIC, COULD BE FLONUM\r
31237 \r
31238 ; CODE TO HANDLE ALL IMPLICIT CALLS  I.E. QUOTE, LVAL, GVAL\r
31239 \r
31240         MOVSI   B,TFORM         ;LVAL\r
31241         MOVE    A,MQUOTE LVAL\r
31242         SUB     P,[2,,2]        ;POP OFF BYTE POINTER AND GOBBLE CALL\r
31243         POP     TP,TP\r
31244         SUB     TP,[1,,1]       ;REMOVE  TP JUNK\r
31245         JRST    IMPCA1\r
31246 \r
31247 GLOSEG: SKIPA   B,$TSEG         ;SEG CALL TO GVAL\r
31248 GLOVAL: MOVSI   B,TFORM ;FORM CALL TO SAME\r
31249         MOVE    A,MQUOTE GVAL\r
31250         JRST    IMPCAL\r
31251 \r
31252 QUOSEG: SKIPA   B,$TSEG         ;SEG CALL TO QUOTE\r
31253 QUOTIT: MOVSI   B,TFORM\r
31254         MOVE    A,MQUOTE QUOTE\r
31255         JRST    IMPCAL\r
31256 \r
31257 SEGDOT: MOVSI   B,TSEG          ;SEG CALL TO LVAL\r
31258         MOVE    A,MQUOTE LVAL\r
31259 IMPCAL: PUSHJ   P,LSTCHR        ;FLUSH LAST CHAR EXCEPT\r
31260 IMPCA1: PUSH    TP,$TATOM       ;FOR .FOO FLAVOR\r
31261         PUSH    TP,A            ;PUSH ARGS\r
31262         PUSH    P,B             ;SAVE TYPE\r
31263         PUSHJ   P,IREAD1                ;READ\r
31264         JRST    USENIL          ; IF NO ARG, USE NIL\r
31265 IMPCA2: PUSH    TP,C\r
31266         PUSH    TP,D\r
31267         MOVE    C,A             ; GET READ THING\r
31268         MOVE    D,B\r
31269         PUSHJ   P,INCONS        ; CONS TO NIL\r
31270         MOVEI   E,(B)           ; PREPARE TON CONS ON\r
31271 POPARE: POP     TP,D            ; GET ATOM BACK\r
31272         POP     TP,C\r
31273         EXCH    C,-1(TP)        ; SAVE THAT COMMENT\r
31274         EXCH    D,(TP)\r
31275         PUSHJ   P,ICONS\r
31276         POP     P,A             ;GET FINAL TYPE\r
31277         JRST    RET13           ;AND RETURN\r
31278 \r
31279 \r
31280 USENIL: PUSH    TP,C\r
31281         PUSH    TP,D\r
31282         SKIPL   A,5(TB)         ; RESTOR LAST CHR\r
31283         MOVEI   A,5(TB)-LSTCH   ;NO CHANNEL, POINT AT SLOT\r
31284         MOVEM   B,LSTCH(A)\r
31285         MOVEI   E,0\r
31286         JRST    POPARE\r
31287 \f\r
31288 ;HERE AFTER READING ATOM TO CALL VALUE\r
31289 \r
31290 .SET:   SUB     P,[1,,1]        ;FLUSH GOBBLE CALL\r
31291         PUSH    P,$TFORM        ;GET WINNING TYPE\r
31292         MOVE    E,(P)\r
31293         PUSHJ   P,RETC          ; CHECK FOR POSSIBLE COMMENT\r
31294         PUSH    TP,$TATOM\r
31295         PUSH    TP,MQUOTE LVAL\r
31296         JRST    IMPCA2          ;GO CONS LIST\r
31297 \r
31298 ]\r
31299 \r
31300 ;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT\r
31301 \r
31302 CHECKE: CAIN    A,"*            ; CHECK FOR FINAL *\r
31303         JRST    SYMB4\r
31304         TRNN    FF,EFLG         ;HAS ONE BEEN SEEN\r
31305         CAIE    B,NONSPC                ;IF NOT, IS THIS ONE\r
31306         JRST    SYMB            ;NO, ENTER AS SYMBOL KILL NUMERIC WIN\r
31307 \r
31308         TRNN    FF,NUMWIN       ;HAVE DIGITS BEEN SEEN?\r
31309         JRST    SYMB            ;NO, NOT A NUMBER\r
31310         MOVE    B,(TP)          ;GET POINTER TO TEMPS\r
31311         HRLM    FF,ENUM(B)      ;SAVE FLAGS\r
31312         HRRI    FF,DECFRC+DOTSEN+EFLG   ;SET NEW FLAGS\r
31313         JRST    SYMB3           ;ENTER SYMBOL\r
31314 \r
31315 \r
31316 SYMB4:  TRZN    FF,OCTSTR\r
31317         JRST    SYMB\r
31318         TRZN    FF,OCTWIN       ; ALREADY WON?\r
31319         TROA    FF,OCTWIN       ; IF NOT DO IT NOW\r
31320         JRST    SYMB\r
31321         JRST    SYMB2\r
31322 \r
31323 ;HERE ON READING CHARACTER STRING\r
31324 \r
31325 ADSTRN: SKIPL   A               ; EOF?\r
31326         CAIN    B,MANYT         ;TERMINATE?\r
31327         JRST    DONEG           ;YES\r
31328         CAIE    B,CSTYP\r
31329         JRST    SYMB2           ;NO JUST INSERT IT\r
31330 ADSTN1: PUSHJ   P,LSTCHR        ;DON'T REREAD """\r
31331 \r
31332 \f\r
31333 ;HERE TO FINISH THIS CROCK\r
31334 \r
31335 DONEG:  TRNN    FF,OCTSTR       ; IF START OCTAL BUT NOT FINISH..\r
31336         TRNN    FF,NUMWIN       ;HAVE DIGITS BEEN SEEN?\r
31337         TRO     FF,NOTNUM       ;NO,SET NOT NUMBER FLAG\r
31338         SKIPGE  C               ; SKIP IF STUFF IN TOP WORD\r
31339         SUB     P,[1,,1]\r
31340         PUSH    P,D\r
31341         TRNN    FF,NOTNUM       ;NUMERIC?\r
31342         JRST    NUMHAK          ;IS NUMERIC, GO TO IT\r
31343 \r
31344 IFN FRMSIN,[\r
31345         MOVE    A,(TP)          ;GET POINTER TO TEMPS\r
31346         MOVEM   FF,NDIGS(A)     ;USE TO HOLD FLAGS\r
31347 ]\r
31348         TRNE    FF,INSTRN       ;ARE WE BUILDING A STRING\r
31349         JRST    MAKSTR          ;YES, GO COMPLETE SAME\r
31350 LOOPAT: PUSHJ   P,NXTCH         ; CHECK FOR TRAILER\r
31351         CAIN    B,PATHTY        ; PATH BEGINNER\r
31352         JRST    PATH0           ; YES, GO PROCESS\r
31353         CAIN    B,SPATYP        ; SPACER?\r
31354         PUSHJ   P,SPACEQ        ; CHECK FOR REAL SPACE\r
31355         JRST    PATH2\r
31356         PUSHJ   P,LSTCHR        ; FLUSH IT AND RETRY\r
31357         JRST    LOOPAT\r
31358 PATH0:  PUSHJ   P,NXTCH1        ; READ FORCED NEXT\r
31359         CAIE    B,SPCTYP        ; DO #FALSE () HACK\r
31360         CAIN    B,ESCTYP\r
31361         JRST    PATH4\r
31362         CAIL    B,SPATYP        ; SPACER?\r
31363         JRST    PATH3           ; YES, USE THE ROOT OBLIST\r
31364 PATH4:  PUSHJ   P,NIREA1        ; READ NEXT ITEM\r
31365         PUSHJ   P,ERRPAR        ; LOSER\r
31366         CAME    A,$TATOM        ; ONLY ALLOW ATOMS\r
31367         JRST    BADPAT\r
31368 \r
31369         PUSH    TP,A\r
31370         PUSH    TP,B\r
31371         PUSH    TP,A\r
31372         PUSH    TP,B\r
31373         PUSH    TP,$TATOM\r
31374         PUSH    TP,IMQUOTE OBLIST\r
31375         MCALL   2,GET           ; GET THE OBLIST\r
31376         CAMN    A,$TOBLS        ; IF NOT OBLIST, MAKE ONE\r
31377         JRST    PATH6\r
31378         MCALL   1,MOBLIS        ; MAKE ONE\r
31379         JRST    PATH1\r
31380 \r
31381 PATH6:  SUB     TP,[2,,2]\r
31382         JRST    PATH1\r
31383 \r
31384 \r
31385 PATH3:  MOVE    B,ROOT+1(TVP)   ; GET ROOT OBLIST\r
31386         MOVSI   A,TOBLS\r
31387 PATH1:  PUSHJ   P,RLOOKU                ; AND LOOK IT UP\r
31388 \r
31389 IFN FRMSIN,[\r
31390         MOVE    C,(TP)          ;SET TO REGOBBLE FLAGS\r
31391         MOVE    FF,NDIGS(C)\r
31392 ]\r
31393         JRST    FINID\r
31394 \r
31395 \r
31396 SPACEQ: ANDI    A,-1\r
31397         CAIE    A,33\r
31398         CAIN    A,400033\r
31399         POPJ    P,\r
31400         CAIE    A,3\r
31401         AOS     (P)\r
31402         POPJ    P,\r
31403 \f\r
31404 ;HERE TO RAP UP CHAR STRING ITEM\r
31405 \r
31406 MAKSTR: MOVE    C,D             ;SETUP TO CALL CHMAK\r
31407         PUSHJ   P,CHMAK         ;GO MAKE SAME\r
31408         JRST    FINID\r
31409 \r
31410 \r
31411 NUMHAK: MOVE    C,(TP)          ;REGOBBLETEMP POINTER\r
31412         POP     P,D     ;POP OFF STACK TOP\r
31413         ADDI    D,4\r
31414         IDIVI   D,5\r
31415         HRLI    D,(D)   ;TOO BOTH HALVES\r
31416         SUB     P,D             ;REMOVE CHAR STRING\r
31417         TRNE    FF,FLONUM+EFLG  ;IS IT A FLOATING POINT NUMBER\r
31418         JRST    FLOATIT         ;YES, GO MAKE IT WIN\r
31419         MOVE    B,CNUM(C)\r
31420         TRNE    FF,DECFRC\r
31421         MOVE    B,DNUM(C)       ;GRAB FIXED GOODIE\r
31422         TRNE    FF,OCTWIN       ; SKIP IF NOT OCTAL\r
31423         MOVE    B,ONUM(C)       ; USE OCTAL VALUE\r
31424 \r
31425 FINID2: MOVSI   A,TFIX          ;SAY FIXED POINT\r
31426 FINID1: TRNE    FF,NEGF         ;NEGATE\r
31427         MOVNS   B               ;YES\r
31428 FINID:  POP     TP,TP           ;RESTORE OLD TP\r
31429         SUB     TP,[1,,1]       ;FINISH HACK\r
31430 IFN FRMSIN,[\r
31431         TRNE    FF,FRSDOT       ;DID . START IT\r
31432         JRST    .SET            ;YES, GO HACK\r
31433 ]\r
31434         POPJ    P,              ;AND RETURN\r
31435 \r
31436 \r
31437 \r
31438 \r
31439 PATH2:  MOVE    B,IMQUOTE OBLIST\r
31440         PUSHJ   P,IDVAL\r
31441         JRST    PATH1\r
31442 \r
31443 BADPAT: PUSH    TP,$TATOM\r
31444         PUSH    TP,EQUOTE NON-ATOMIC-OBLIST-NAME\r
31445         JRST    CALER1\r
31446 \r
31447 \f\r
31448 FLOATIT:\r
31449         JFCL    17,.+1          ;CLEAR ALL ARITHMETIC FLAGS\r
31450 \r
31451         TRNE    FF,EFLG ;"E" SEEN?\r
31452         JRST    EXPDO   ;YES, DO EXPONENT\r
31453         MOVE    D,NDIGS(C)      ;GET IMPLICIT EXPONENT\r
31454 \r
31455 FLOATE: MOVE    A,DNUM(C)       ;GET DECIMAL NUMBER\r
31456         IDIVI   A,400000        ;SPLIT\r
31457         FSC     A,254   ;CONVERT MOST SIGNIFICANT\r
31458         FSC     B,233   ; AND LEAST SIGNIFICANT\r
31459         FADR    B,A             ;COMBINE\r
31460 \r
31461         MOVM    A,D             ;GET MAGNITUDE OF EXPONENT      \r
31462         CAILE   A,37.           ;HOW BIG?\r
31463         JRST    FOOR            ;TOO BIG-FLOATING OUT OF RANGE\r
31464         JUMPGE  D,FLOAT1        ;JUMP IF EXPONENT POSITIVE\r
31465         FDVR    B,TENTAB(A)     ;DIVIDE BY TEN TO THE EXPONENT\r
31466         JRST    SETFLO\r
31467 \r
31468 FLOAT1: FMPR    B,TENTAB(A)     ;SCALE UP\r
31469 \r
31470 SETFLO: JFCL    10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW\r
31471         MOVSI   A,TFLOAT\r
31472 IFN FRMSIN,     TRZ     FF,FRSDOT       ;FLOATING NUMBER NOT VALUE\r
31473         JRST    FINID1\r
31474 \r
31475 EXPDO:\r
31476         HRRZ    D,ENUM(C)       ;GET EXPONENT\r
31477         TRNE    FF,NEGF ;IS EXPONENT NEGATIVE?\r
31478         MOVNS   D               ;YES\r
31479         ADD     D,NDIGS(C)      ;ADD IMPLICIT EXPONENT\r
31480         HLR     FF,ENUM(C)      ;RESTORE FLAGS\r
31481         JUMPL   D,FLOATE        ;FLOATING IF EXPONENT NEGATIVE\r
31482         CAIG    D,10.           ;OR IF EXPONENT TOO LARGE\r
31483         TRNE    FF,FLONUM       ;OR IF FLAG SET\r
31484         JRST    FLOATE\r
31485         MOVE    B,DNUM(C)       ;\r
31486         IMUL    B,ITENTB(D)     \r
31487         JFCL    10,FLOATE               ;IF OVERFLOW, MAKE FLOATING\r
31488         JRST    FINID2          ;GO MAKE FIXED NUMBER\r
31489 \f\r
31490 ; HERE TO READ ONE CHARACTER FOR USER.\r
31491 \r
31492 CREDC1: SUBM    M,(P)\r
31493         PUSH    TP,A\r
31494         PUSH    TP,B\r
31495         PUSHJ   P,IREADC\r
31496         JFCL\r
31497         JRST    MPOPJ\r
31498 \r
31499 CNXTC1: SUBM    M,(P)\r
31500         PUSH    TP,A\r
31501         PUSH    TP,B\r
31502         PUSHJ   P,INXTRD\r
31503         JFCL\r
31504         JRST    MPOPJ\r
31505 \r
31506 CREADC: SUBM    M,(P)\r
31507         PUSH    TP,A\r
31508         PUSH    TP,B\r
31509         PUSHJ   P,IREADC\r
31510         JRST    RMPOPJ\r
31511         SOS     (P)\r
31512         JRST    RMPOPJ\r
31513 \r
31514 CNXTCH: SUBM    M,(P)\r
31515         PUSH    TP,A\r
31516         PUSH    TP,B\r
31517         PUSHJ   P,INXTRD\r
31518         JRST    RMPOPJ\r
31519         SOS     (P)\r
31520 RMPOPJ: SUB     TP,[2,,2]\r
31521         JRST    MPOPJ\r
31522 \r
31523 INXTRD: TDZA    E,E\r
31524 IREADC: MOVEI   E,1\r
31525         MOVE    B,(TP)          ; CHANNEL\r
31526         HRRZ    A,-4(B)         ; GET BLESS BITS\r
31527         TRNE    A,C.BIN\r
31528         TRNE    A,C.BUF\r
31529         JRST    .+3\r
31530         PUSHJ   P,GRB\r
31531         HRRZ    A,-4(B)\r
31532         TRC     A,C.OPN+C.READ\r
31533         TRNE    A,C.OPN+C.READ\r
31534         JRST    BADCHN\r
31535         SKIPN   A,LSTCH(B)\r
31536         PUSHJ   P,RXCT\r
31537         MOVEM   A,LSTCH(B)      ; SAVE CHAR\r
31538         CAMN    A,[-1]          ; SPECIAL PSEUDO TTY HACK?\r
31539         JRST    PSEUDO          ; YES, RET AS FIX\r
31540         TRZN    A,400000        ; UNDO ! HACK\r
31541         JRST    NOEXCL\r
31542         SKIPE   E\r
31543         MOVEM   A,LSTCH(B)\r
31544         MOVEI   A,"!            ; RETURN AN !\r
31545 NOEXC1: SKIPGE  B,A             ; CHECK EOF\r
31546         SOS     (P)             ; DO EOF RETURN\r
31547         MOVE    B,A             ; CHAR TO B\r
31548         MOVSI   A,TCHRS\r
31549 PSEUD1: AOS     (P)\r
31550         POPJ    P,\r
31551 \r
31552 PSEUDO: SKIPE   E\r
31553         PUSHJ   P,LSTCH2\r
31554         MOVE    B,A\r
31555         MOVSI   A,TFIX\r
31556         JRST    PSEUD1\r
31557 \r
31558 NOEXCL: SKIPE   E\r
31559         PUSHJ   P,LSTCH2\r
31560         JRST    NOEXC1\r
31561 \r
31562 ; READER ERRORS COME HERE\r
31563 \r
31564 ERRPAR: PUSH    TP,$TCHRS       ;DO THE OFFENDER\r
31565         PUSH    TP,B\r
31566         PUSH    TP,$TCHRS\r
31567         PUSH    TP,[40]         ;SPACE\r
31568         PUSH    TP,$TCHSTR\r
31569         PUSH    TP,CHQUOT UNEXPECTED\r
31570         JRST    MISMA1\r
31571 \r
31572 ;COMPLAIN ABOUT MISMATCHED CLOSINGS\r
31573 \r
31574 MISMAB: SKIPA   A,["]]\r
31575 MISMAT: MOVE    A,-1(P)         ;GOBBLE THE DESIRED CHARACTER\r
31576         JUMPE   B,CPOPJ         ;IGNORE UNIVERSAL CLOSE\r
31577         PUSH    TP,$TCHRS\r
31578         PUSH    TP,B\r
31579         PUSH    TP,$TCHSTR\r
31580         PUSH    TP,CHQUOT [ INSTEAD-OF ]\r
31581         PUSH    TP,$TCHRS\r
31582         PUSH    TP,A\r
31583 MISMA1: MCALL   3,STRING\r
31584         PUSH    TP,$TATOM\r
31585         PUSH    TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON\r
31586         PUSH    TP,A\r
31587         PUSH    TP,B\r
31588         PUSH    TP,$TATOM\r
31589         PUSH    TP,MQUOTE READ\r
31590         MCALL   3,ERROR\r
31591 CPOPJ:  POPJ    P,\r
31592 \f\r
31593 ; HERE ON BAD INPUT CHARACTER\r
31594 \r
31595 BADCHR: PUSH    TP,$TATOM\r
31596         PUSH    TP,EQUOTE BAD-ASCII-CHARACTER\r
31597         JRST    CALER1\r
31598 \r
31599 ; HERE ON YUCKY PARSE TABLE\r
31600 \r
31601 BADPTB: PUSH    TP,$TATOM\r
31602         PUSH    TP,EQUOTE BAD-MACRO-TABLE\r
31603         JRST    CALER1\r
31604 \r
31605 BDPSTR: PUSH    TP,$TATOM\r
31606         PUSH    TP,EQUOTE BAD-PARSE-STRING\r
31607         JRST    CALER1\r
31608 \r
31609 ILLSQG: PUSHJ   P,LSTCHR        ; DON'T MESS WITH IT AGAIN\r
31610         PUSH    TP,$TATOM\r
31611         PUSH    TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS\r
31612         JRST    CALER1\r
31613 \r
31614 \r
31615 ;FLOATING POINT NUMBER TOO LARGE OR SMALL\r
31616 FOOR:   PUSH    TP,$TATOM\r
31617         PUSH    TP,EQUOTE NUMBER-OUT-OF-RANGE\r
31618         JRST    CALER1\r
31619 \r
31620 \r
31621 NILSXP: 0,,0\r
31622 \r
31623 LSTCHR: PUSH    P,B\r
31624         SKIPL   B,5(TB) ;GET CHANNEL\r
31625         JRST    LSTCH1          ;NO CHANNEL, POINT AT SLOT\r
31626         PUSHJ   P,LSTCH2\r
31627         POP     P,B\r
31628         POPJ    P,\r
31629 \r
31630 LSTCH2: SKIPE   LSTCH(B)        ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?\r
31631         PUSHJ   P,CNTACC\r
31632         SETZM   LSTCH(B)\r
31633         POPJ    P,\r
31634 \r
31635 LSTCH1: SETZM   5(TB)           ;ZERO THE LETTER AND RETURN\r
31636         POP     P,B\r
31637         POPJ    P,\r
31638 \r
31639 CNTACC: PUSH    P,A\r
31640         HRRZ    A,-4(B)         ; GET BITS\r
31641         TRNE    A,C.BIN\r
31642         JRST    CNTBIN\r
31643         AOS     ACCESS(B)\r
31644 CNTDON: POP     P,A\r
31645         POPJ    P,\r
31646 \r
31647 CNTBIN: AOS     A,ACCESS-1(B)\r
31648         CAMN    A,[TFIX,,1]\r
31649         AOS     ACCESS(B)\r
31650         CAMN    A,[TFIX,,5]\r
31651         HLLZS   ACCESS-1(B)\r
31652         JRST    CNTDON\r
31653 \r
31654 \r
31655 ;TABLE OF NAMES OF ARGS AND ALLOWED TYPES\r
31656 \r
31657 ARGS:\r
31658         IRP     A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]\r
31659                 IRP B,C,[A]\r
31660                         B\r
31661                         IFSN [C],IMQUOTE C\r
31662                         .ISTOP\r
31663                 TERMIN\r
31664         TERMIN\r
31665 \r
31666 CHOBL:  CAIE    C,TLIST ;A LIST OR AN OBLIST\r
31667         CAIN    C,TOBLS\r
31668         AOS     (P)\r
31669         POPJ    P,\r
31670 \r
31671 END\r
31672 \r
31673 \fTITLE SAVE AND RESTORE STATE OF A MUDDLE\r
31674 \r
31675 RELOCATABLE\r
31676 \r
31677 .INSRT DSK:MUDDLE >\r
31678 \r
31679 SYSQ\r
31680 \r
31681 IFE ITS,[\r
31682 IF1,[\r
31683 .INSRT STENEX >\r
31684 EXPUNGE SAVE\r
31685 ]\r
31686 ]\r
31687 \r
31688 .GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS\r
31689 .GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS\r
31690 .GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RJNAM,INTINT,CLOSAL,TTYOPE\r
31691 .GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS\r
31692 \r
31693 MFUNCTION FSAVE,SUBR\r
31694 \r
31695         ENTRY\r
31696 \r
31697         PUSH    P,.             ; SAY WE ARE FAST SAVER\r
31698         JRST    SAVE1\r
31699 \r
31700 MFUNCTION SAVE,SUBR\r
31701 \r
31702         ENTRY\r
31703 \r
31704         PUSH    P,[0]           ; SAY WE ARE OLD SLOW SAVE\r
31705 SAVE1:  SKIPG   MUDSTR+2        ; DON'T SAVE FROM EXPERIMENTAL MUDDLE\r
31706         JRST    EXPVRS\r
31707         PUSH    P,[0]           ; GC OR NOT?\r
31708 IFE ITS,[\r
31709         MOVE    B,[400600,,]\r
31710         MOVE    C,[440000,,100000]\r
31711 ]\r
31712         PUSHJ   P,GTFNM         ; GET THE FILE NAME ONTO P\r
31713         JRST    .+2\r
31714         JRST    SAVEON\r
31715         JUMPGE  AB,TMA          ; TOO MUCH STRING\r
31716         GETYP   0,(AB)          ; WHAT IS ARG\r
31717         CAMGE   AB,[-3,,0]      ; NOT TOO MANY\r
31718         JRST    TMA\r
31719         CAIN    0,TFALSE\r
31720 IFN ITS,        SETOM   -4(P)           ; GC FLAG\r
31721 IFE ITS,        SETOM   (P)\r
31722 SAVEON:\r
31723 IFN ITS,[\r
31724         MOVSI   A,7             ; IMAGE BLOCK OUT\r
31725         HRR     A,-2(P)         ; DEVICE\r
31726         PUSH    P,A\r
31727         PUSH    P,[SIXBIT /_MUDS_/]\r
31728         PUSH    P,[SIXBIT />/]\r
31729         MOVEI   A,-2(P)         ; POINT TO BLOCK\r
31730         PUSHJ   P,MOPEN         ; ATTEMPT TO OPEN\r
31731         JRST    CANTOP\r
31732         SUB     P,[3,,3]        ; FLUSH OPEN BLOCK\r
31733         PUSH    P,-4(P)         ; GC FLAG TO TOP OF STACK\r
31734 ]\r
31735         EXCH    A,(P)           ; CHAN TO STACK GC TO A\r
31736         JUMPL   A,.+2\r
31737         MCALL   0,GC\r
31738 \r
31739 ; NOW GET VERSION OF MUDDLE FOR COMPARISON\r
31740 \r
31741         MOVE    A,MUDSTR+2      ; GET #\r
31742         MOVEI   B,177           ; CHANGE ALL RUBOUT CHARACTERS\r
31743         MOVEI   C,40            ; ----- TO SPACES\r
31744         PUSHJ   P,HACKV\r
31745 \r
31746         PUSHJ   P,WRDOUT\r
31747         MOVEI   A,0             ; WRITE ZERO IF FAST\r
31748 IFN ITS,        SKIPE   -6(P)\r
31749 IFE ITS,        SKIPE   -1(P)\r
31750         PUSHJ   P,WRDOUT\r
31751         MOVE    A,VECTOP        ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE\r
31752         PUSHJ   P,WRDOUT\r
31753 \r
31754 IFN ITS,[\r
31755         SETZB   A,B             ; FIRST, ALL INTS OFF\r
31756         .SETM2  A,\r
31757         SKIPE   DISXTR          ; IF HAVE DISPLAY, CLOSE IT\r
31758         .DSTOP                  ; STOP THE E&S IF RUNNING\r
31759 \r
31760 ; IF FAST SAVE JUMP OFF HERE\r
31761 \r
31762         SKIPE   -6(P)\r
31763         JRST    FSAVE1\r
31764 \r
31765 ; NOW DUMP OUT GC SPACE\r
31766         MOVEI   A,E+1           ; ADDRESS OF FIRST NON-SCRATCH WORD\r
31767         POP     P,0             ; CHAN TO 0\r
31768         LSH     0,23.           ; POSITION\r
31769         IOR     0,[.IOT A]\r
31770 ]\r
31771 \r
31772 IFE ITS,[\r
31773         MOVEI   A,400000        ; FOR THIS PROCESS\r
31774         DIR                     ; TURN OFF INT SYSTEM\r
31775 \r
31776 ; IF FAST, LEAVE HERE\r
31777 \r
31778         SKIPE   -1(P)\r
31779         JRST    FSAVE1\r
31780 \r
31781 ; NOW DUMP OUT GC SPACE\r
31782         POP     P,0             ; RESTORE JFN\r
31783         MOVE    A,[-<P-E>,,E]   ; NUMBER OF ACS TO GO\r
31784         PUSH    P,(A)\r
31785         AOBJN   A,.-1\r
31786         MOVE    A,0\r
31787         MOVE    B,P\r
31788         BOUT\r
31789         MOVEI   A,20            ; START AT LOCN 20\r
31790 ]\r
31791 DMPLP1: MOVEI   B,(A)           ; POINT TO START OF STUFF\r
31792         SUB     B,VECTOP        ; GET BLOCK LENGTH\r
31793         MOVSI   B,(B)\r
31794         HRRI    B,(A)           ; HAVE IOT POINTER\r
31795         SKIPL   B               ; SKIP IF OK AOBJN POINTER\r
31796         HRLI    B,400000        ; OTHER WISE AS MUCH AS POSSIBLE\r
31797 \r
31798 ; MAIN NON-ZERO DUMPING LOOP\r
31799 \r
31800 DMPLP:  SKIPN   C,(B)           ; FIND FIRST NON-ZERO\r
31801         AOBJN   B,.-1\r
31802         JUMPGE  B,DMPDON        ; NO MORE TO SCAN\r
31803 \r
31804 DMP4:   MOVEI   E,(B)           ; FOUND ONE, SAVE POINTER TO IT\r
31805 DMP3:   MOVSI   D,-5            ; DUPLICATE COUNTER SETUP\r
31806 \r
31807 DMP1:   CAMN    C,(B)           ; IS NEXT SAME AS THIS?\r
31808         JRST    CNTDUP          ; COUNT DUPS\r
31809         MOVSI   D,-5            ; RESET COUNTER\r
31810         SKIPE   C,(B)           ; SEARCH FOR ZERO\r
31811 DMP5:   AOBJN   B,DMP1          ; COUNT AND GO\r
31812         JUMPGE  B,DMP2          ; JUMP IF BLOCK FINISHED\r
31813 \r
31814         AOBJP   B,DMP2          ; CHECK FOR LONE ZERO\r
31815         SKIPE   C,(B)\r
31816         JRST    DMP1            ; LONE ZERO, DONT END BLOCK\r
31817 \r
31818 DMP2:   MOVEI   D,(E)           ; START COMPUTING OUTPUT IOT\r
31819         SUBI    D,(B)           ; D=> -LNTH OF BLOCK\r
31820         HRLI    E,(D)           ; E=> AOBJN PNTR TO OUTPUT\r
31821 IFN ITS,[\r
31822         HRROI   A,E             ; MAKE AN IOT POINTER TO IT\r
31823         XCT     0               ; WRITE IT\r
31824         MOVE    A,E             ; NOW FOR THE BLOCK\r
31825         XCT     0               ; ZAP!, OUT IT GOES\r
31826 ]\r
31827 IFE ITS,[\r
31828         EXCH    E,B             ; AOBJN TO B\r
31829         MOVE    A,0             ; JFN TO A\r
31830         BOUT                    ; WRITE IT\r
31831         MOVE    D,B             ; SAVE POINTER\r
31832         HRLI    B,444400        ; BYTPE POINTER\r
31833         HLRE    C,D             ; # OF BYTES\r
31834         SOUT\r
31835 ]\r
31836 ; NOW COMPUTE A CKS\r
31837 \r
31838 IFN ITS,[\r
31839         MOVE    D,E             ; FIRST WORD OF CKS\r
31840         ROT     E,1\r
31841         ADD     E,(D)\r
31842         AOBJN   D,.-2           ; COMP CKS\r
31843         HRROI   A,E\r
31844         XCT     0               ; WRITE OUT THE CKS\r
31845 ]\r
31846 IFE ITS,[\r
31847         MOVE    B,D\r
31848         ROT     B,1\r
31849         ADD     B,(D)\r
31850         AOBJN   D,.-2\r
31851         BOUT\r
31852         MOVE    B,E             ; MAIN POINTER BACK\r
31853 ]\r
31854 \r
31855 DMP7:   JUMPL   B,DMPLP         ; MORE TO  DO?\r
31856 DMPDON: SUB     B,VECTOP        ; DONE?\r
31857         JUMPGE  B,DMPDN1        ; YES, LEAVE\r
31858 IFN ITS,        MOVEI   A,400000+PVP    ; POINT TO NEXT WORD TO GO\r
31859 IFE ITS,        MOVEI   A,400020\r
31860         JRST    DMPLP1\r
31861 IFN ITS,[\r
31862 DMPDN1: HRROI   A,[-1]\r
31863         XCT     0               ; EOF\r
31864 DMPDN2: SETZB   A,B             ; SET UP RENAME WHILE OPEN ETC.\r
31865         MOVE    E,(P)\r
31866         MOVE    D,-1(P)\r
31867         LDB     C,[270400,,0]   ; GET CHANNEL\r
31868         .FDELE  A               ; RENAME IT\r
31869         FATAL SAVE RENAME FAILED\r
31870         XOR     0,[<.IOT A>#<.CLOSE>]   ; CHANGE TO A CLOSE\r
31871         XCT     0\r
31872 \r
31873         MOVE    A,MASK1         ; TURN INTS BACK ON\r
31874         MOVE    B,MASK2\r
31875         .SETM2  A,\r
31876         SKIPE   DISXTR          ; SKIP IF NO E&S\r
31877         .DCONTINUE              ; RESTART THE E&S IF WE HAVE IT\r
31878 ]\r
31879 \r
31880 IFE ITS,[\r
31881 DMPDN1: MOVNI   B,1\r
31882         MOVE    A,0             ; WRITE EOF\r
31883         BOUT\r
31884 DMPDN2: MOVE    A,0\r
31885         CLOSF\r
31886         FATAL CANT CLOSE SAVE FILE\r
31887         CIS                     ; CLEAR IT SYSTEM\r
31888         MOVEI   A,400000\r
31889         EIR                     ; AND RE-ENABLE\r
31890 ]\r
31891 \r
31892 SDONE:  MOVE    A,$TCHSTR\r
31893         MOVE    B,CHQUOTE SAVED\r
31894         JRST    FINIS\r
31895 \r
31896 ; SCAN FOR MANY OCCURENCES OF THE SAME THING\r
31897 \r
31898 CNTDUP: AOBJN   D,DMP5          ; 4 IN A ROW YET\r
31899         CAIN    E,-4(B)         ; ANY PARTIAL BLOCK?\r
31900         JRST    DMP6            ; NO, DUMP THESE\r
31901         SUB     B,[4,,4]        ; BACK UP POINTER\r
31902         JRST    DMP2\r
31903 DMP6:   CAMN    C,(B)           ; FIND ALL CONTIG\r
31904         AOBJN   B,.-1\r
31905         MOVEI   D,(B)           ; COMPUTE COUNT\r
31906         SUBI    D,(E)\r
31907         MOVSI   D,(D)\r
31908         HRRI    D,(E)           ; HEADER\r
31909 IFN ITS,[\r
31910         HRROI   A,D\r
31911         XCT     0\r
31912         HRROI   A,C             ; WRITE THE WORD\r
31913         XCT     0\r
31914 ]\r
31915 IFE ITS,[\r
31916         MOVE    A,0\r
31917         EXCH    D,B\r
31918         BOUT\r
31919         MOVE    B,C\r
31920         BOUT\r
31921         MOVE    B,D\r
31922 ]       JRST    DMP7\r
31923 \r
31924 ; HERE TO WRITE OUT FAST SAVE FILE\r
31925 \r
31926 FSAVE1: MOVE    A,PARTOP        ; DONT WRITE OUT "HOLE"\r
31927         ADDI    A,1777\r
31928         ANDCMI  A,1777\r
31929         MOVEI   E,(A)\r
31930         PUSHJ   P,WRDOUT\r
31931         MOVE    A,VECBOT\r
31932         ANDCMI  A,1777\r
31933         HRLI    E,(A)\r
31934         PUSHJ   P,WRDOUT\r
31935         POP     P,0             ; CHANNEL TO 0\r
31936 IFN ITS,[\r
31937         ASH     0,23.           ; TO AC FIELS\r
31938         IOR     0,[.IOT A]\r
31939         MOVEI   A,5             ; START AT WORD 5\r
31940 ]\r
31941 IFE ITS,[\r
31942         MOVE    A,[-<P-E>,,E]\r
31943         PUSH    P,(A)\r
31944         AOBJN   A,.-1\r
31945         MOVE    A,0\r
31946         MOVE    B,P             ; WRITE OUT P FOR WIINAGE\r
31947         BOUT\r
31948         MOVE    B,[444400,,20]\r
31949         MOVNI   C,20-6\r
31950         SOUT                    ; MAKE PAGE BOUNDARIES WIN\r
31951         MOVEI   A,20            ; START AT 20\r
31952 ]\r
31953         MOVEI   B,(E)           ; PARTOP TO B\r
31954         PUSHJ   P,FOUT          ; WRITE OUT UP TO PAIR TOP\r
31955         HLRZ    A,E             ; VECBOT TO A\r
31956         MOVE    B,VECTOP        ; AND THE REST\r
31957         PUSHJ   P,FOUT\r
31958         JRST    DMPDN2\r
31959 \r
31960 IFN ITS,[\r
31961 FOUT:   MOVEI   D,(A)           ; SAVE START\r
31962         SUB     A,B             ; COMPUTE LH OF IOT PNTR\r
31963         MOVSI   A,(A)\r
31964         SKIPL   A               ; IF + MEANS GROSS CORE SIZE\r
31965         MOVSI   A,400000        ; USE BIGGEST\r
31966         HRRI    A,(D)\r
31967         XCT     0               ; ZAP, OUT IT GOES\r
31968         CAMGE   A,B             ; SKIP IF ALL WENT\r
31969         JRST    FOUT            ; DO THE REST\r
31970         POPJ    P,              ; GO CLOSE FILE\r
31971 ]\r
31972 IFE ITS,[\r
31973 FOUT:   MOVEI   C,(A)\r
31974         SUBI    C,(B)           ; # OF BYTES TP C\r
31975         MOVEI   B,(A)           ; START TO B\r
31976         HRLI    B,444400\r
31977         MOVE    A,0\r
31978         SOUT                    ; WRITE IT OUT\r
31979         POPJ    P,\r
31980 ]\r
31981         \r
31982 \r
31983 ; HERE TO ATTEMPT TO RESTORE A SAVED STATE\r
31984 \r
31985 MFUNCTION RESTORE,SUBR\r
31986 \r
31987         ENTRY\r
31988         SKIPG   MUDSTR+2        ; DON'T RESTORE FROM EXPERIMENTAL MUDDLE\r
31989         JRST EXPVRS\r
31990 IFE ITS,[\r
31991         MOVE    B,[100600,,]\r
31992         MOVE    C,[440000,,240000]\r
31993 ]\r
31994         PUSHJ   P,GTFNM\r
31995         JRST    TMA\r
31996 IFN ITS,[\r
31997         MOVEI   A,6             ; READ/IMAGE/BLOCK\r
31998         HRLM    A,-2(P)\r
31999         MOVEI   A,-2(P)\r
32000         PUSHJ   P,MOPEN         ; OPEN THE LOSER\r
32001         JRST    FNF\r
32002         SUB     P,[4,,4]        ; REMOVE OPEN BLOCK\r
32003 \r
32004         PUSH    P,A             ; SAVE CHANNEL\r
32005         PUSHJ   P,SGSNAM        ; SAVE SNAME IN SYSTEM\r
32006 ]\r
32007 IFE ITS,        PUSH    P,A             ; SAVE JFN\r
32008         PUSHJ   P,WRDIN         ; READ MUDDLE VERSION\r
32009         MOVEI   B,40            ; CHANGE ALL SPACES\r
32010         MOVEI   C,177           ; ----- TO RUBOUT CHARACTERS\r
32011         PUSHJ   P,HACKV\r
32012         CAME    A,MUDSTR+2      ; AGREE ?\r
32013         JRST    BADVRS\r
32014 \r
32015 IFN ITS,        MCALL   0,IPCOFF        ; CLOSE ALL IPC CHANS\r
32016         PUSHJ   P,CLOSAL        ; CLOSE CHANNELS\r
32017 IFN ITS,[\r
32018         SETZB   A,B             ; KILL ALL POSSIBLE INTERRUPTION\r
32019         .SETM2  A,\r
32020 ]\r
32021 IFE ITS,[\r
32022         MOVEI   A,400000        ; DISABLE INTS\r
32023         DIR                     ; INTS OFF\r
32024 ]\r
32025         PUSHJ   P,PURCLN        ; DONT KEEP PURE SHAREDNESS\r
32026         POP     P,A             ; RETRIEVE CHANNEL\r
32027         MOVE    P,GCPDL\r
32028         PUSH    P,A             ; AND SAVE IT ON A GOOD PDL\r
32029         PUSHJ   P,WRDIN         ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE\r
32030         JUMPE   A,FASTR\r
32031         MOVEM   A,VECTOP        ; SAVE FOR LATER\r
32032         ASH     A,-10.          ; TO BLOCKS\r
32033         MOVE    C,A             ; SAVE A COPY\r
32034         ADDI    A,1             ; ROOM FOR GC PDL\r
32035         PUSHJ   P,P.CORE\r
32036         PUSHJ   P,NOCORE        ; LOSE,LOSE, LOSE\r
32037 \r
32038 ; NOW READY TO READ IN GC SPACE\r
32039         POP     P,0             ; GET CHAN\r
32040         MOVEI   E+1,0\r
32041         MOVE    B,[E+1,,E+2]    ; BLT SETUP TO ZERO CORE\r
32042         MOVE    E,NOTTY\r
32043         MOVE    A,VECTOP\r
32044         BLT     B,-1+2000(A)    ; THE WHOLE THING?\r
32045 IFN ITS,[\r
32046         LSH     0,23.\r
32047         IOR     0,[.IOT A]      ; BUILD IOT\r
32048 ]\r
32049 IFE ITS,[\r
32050         MOVE    A,0\r
32051         BIN                     ; READ IN NEW "P"\r
32052         MOVE    P,B\r
32053 ]\r
32054 LDLP:\r
32055 IFN ITS,[\r
32056         HRROI   A,B             ; READ A HDR\r
32057         XCT     0\r
32058         JUMPL   A,LD1           ; DONE\r
32059 ]\r
32060 IFE ITS,[\r
32061         MOVE    A,0\r
32062         BIN                     ; HDR TO B\r
32063 ]\r
32064         CAMN    B,[-1]\r
32065         JRST    LD1\r
32066 \r
32067         JUMPGE  B,LDDUPS        ; JUMP IF LOADING DUPS\r
32068 IFN ITS,[\r
32069         MOVE    A,B             ; TO IOTER\r
32070         XCT     0\r
32071 \r
32072         MOVE    C,B             ; COMP CKS\r
32073         ROT     C,1\r
32074         ADD     C,(B)\r
32075         AOBJN   B,.-2           ; COMP AWAY\r
32076 \r
32077         HRROI   A,D             ; GET FILES CKS\r
32078         XCT     0\r
32079         CAME    D,C             ; CHECK\r
32080         FATAL RESTORE CHECKSUM ERROR\r
32081         JRST    LDLP            ; LOAD MORE\r
32082 ]\r
32083 IFE ITS,[\r
32084         MOVE    D,B             ; SAVE\r
32085         HLRE    C,B\r
32086         HRLI    B,444400\r
32087         MOVE    A,0\r
32088         SIN                     ; READ IN A BUNCH\r
32089 \r
32090         MOVE    B,D\r
32091         ROT     D,1\r
32092         ADD     D,(B)\r
32093         AOBJN   B,.-2\r
32094 \r
32095         BIN                     ; READ STORED CKS\r
32096         CAME    D,B\r
32097         FATAL RESTORE CHECKSUM ERROR\r
32098         JRST    LDLP\r
32099 ]\r
32100 \r
32101 LDDUPS:\r
32102 IFN ITS,[\r
32103         HRROI   A,(B)           ; READ 1ST IN PLACE\r
32104         XCT     0\r
32105 ]\r
32106 IFE ITS,[\r
32107         MOVE    D,B             ; SAVE HDR\r
32108         BIN                     ; READ WORD OF INTEREST\r
32109         MOVEM   B,(D)\r
32110         MOVE    B,D\r
32111 ]\r
32112         HLRZ    A,B             ; # TO A\r
32113         HRLI    B,(B)           ; BUILD A BLT PONTER\r
32114         ADDI    B,1\r
32115         ADDI    A,-2(B)\r
32116         BLT     B,(A)\r
32117         JRST    LDLP\r
32118 \r
32119 LD1:\r
32120 IFN ITS,[\r
32121         XOR     0,[<.IOT A>#<.CLOSE>]   ; CHANGE TO CLOSE\r
32122         XCT     0               ; AND DO IT\r
32123 ]\r
32124 IFE ITS,[\r
32125         MOVE    A,0\r
32126         CLOSF\r
32127         JFCL\r
32128 FASTR1: MOVEI   A,P-1\r
32129         MOVEI   B,P-1-E\r
32130         POP     P,(A)\r
32131         SUBI    A,1\r
32132         SOJG    B,.-2\r
32133 ]\r
32134 \r
32135 IFN ITS,[\r
32136 FASTR1:\r
32137 ]\r
32138         MOVE    A,VECTOP        ; REAL CORE TOP\r
32139         ADDI    A,2000          ; ROOM FOR GC PDL\r
32140         MOVEM   A,P.TOP\r
32141         MOVEM   E,NOTTY         ; SAVE TTY FLAG\r
32142         PUSHJ   P,PURCLN        ; IN CASE RESTORED THING HAD PURE STUFF\r
32143         PUSHJ   P,INTINT        ; USE NEW INTRRRUPTS\r
32144 \r
32145 ; NOW CYCLE THROUGH CHANNELS\r
32146         MOVE    C,TVP\r
32147         ADD     C,[CHNL1+2,,CHNL1+2]    ; POINT TO REAL CHANNELS SLOTS\r
32148         PUSH    TP,$TVEC\r
32149         PUSH    TP,C\r
32150         PUSH    P,[N.CHNS]\r
32151 \r
32152 CHNLP:  SKIPN   B,-1(C)         ; GET CHANNEL\r
32153         JRST    NXTCHN\r
32154         PUSHJ   P,REOPN\r
32155         PUSHJ   P,CHNLOS\r
32156         MOVE    C,(TP)          ; GET POINTER\r
32157 NXTCHN: ADD     C,[2,,2]        ; AND BUMP\r
32158         MOVEM   C,(TP)\r
32159         SOSE    (P)\r
32160         JRST    CHNLP\r
32161 \r
32162         SKIPN   C,CHNL0(TVP)+1  ; ANY PSUEDO CHANNELS\r
32163         JRST    RDONE           ; NO, JUST GO AWAY\r
32164         MOVSI   A,TLIST         ; YES, REOPEN THEM\r
32165         MOVEM   A,(TP)-1\r
32166 CHNLP1: MOVEM   C,(TP)          ; SAVE POINTER\r
32167         SKIPE   B,(C)+1         ; GET CHANNEL\r
32168         PUSHJ   P,REOPN\r
32169         PUSHJ   P,CHNLO1\r
32170         MOVE    C,(TP)          ; GOBBLE POINTER\r
32171         HRRZ    C,(C)           ; REST LIST OF PSUEDO CHANNELS\r
32172         JUMPN   C,CHNLP1\r
32173 \r
32174 RDONE:  SUB     TP,[2,,2]\r
32175         SUB     P,[1,,1]\r
32176         PUSHJ   P,TTYOPE\r
32177 IFN ITS,[\r
32178         PUSHJ   P,IPCBLS        ;BLESS ALL THE IPC CHANNELS\r
32179         PUSHJ   P,SGSNAM        ; GET SNAME\r
32180         SKIPN   A\r
32181         .SUSET  [.RSNAM,,A]\r
32182         PUSHJ   P,6TOCHS        ; TO STRING\r
32183         PUSH    TP,A\r
32184         PUSH    TP,B\r
32185         MCALL   1,SNAME\r
32186 ]\r
32187         PUSHJ   P,%RUNAM\r
32188         PUSHJ   P,%RJNAM\r
32189         MOVE    A,$TCHSTR\r
32190         MOVE    B,CHQUOTE RESTORED\r
32191         JRST    FINIS\r
32192 \r
32193 FASTR:\r
32194 IFN ITS,[\r
32195         PUSHJ   P,WRDIN         ; GET CORE TOP\r
32196         ASH     A,-10.          ; TO PAGES\r
32197         MOVEI   B,(A)           ; SAVE\r
32198         ADDI    A,1             ; ROOM FOR GC PDL\r
32199         PUSHJ   P,P.CORE        ; GET ALL CORE\r
32200         PUSHJ   P,NOCORE        ; LOSE RETURN\r
32201         PUSHJ   P,WRDIN         ; GET PARTOP\r
32202         ASH     A,-10.          ; TO PAGES\r
32203         MOVEI   E,(A)\r
32204         PUSHJ   P,WRDIN         ; NOW GET VECBOT\r
32205         ASH     A,-10.          ; TO PAGES\r
32206         EXCH    A,E             ; AND SAVE IN E\r
32207         MOVNS   A\r
32208         MOVSI   A,(A)           ; TO PAGE AOBJN\r
32209         MOVE    C,A             ; COPY OF POINTER\r
32210         MOVE    0,NOTTY         ; SAVE NOTTY FLAG AROUND\r
32211         MOVE    D,(P)           ; CHANNEL\r
32212         DOTCAL  CORBLK,[[1000,,104000],[1000,,-1],A,D,C]\r
32213         FATAL   CORBLK ON RESTORE LOSSAGE\r
32214         SUBM    E,B             ; AOBJN LH TO E\r
32215         HRLI    E,(B)           ; AOBJN TO CORE\r
32216         HRLI    C,(B)           ; AND TO DISK\r
32217         DOTCAL  CORBLK,[[1000,,104000],[1000,,-1],E,D,C]\r
32218         FATAL   CORBLK ON RESTORE LOSSAGE\r
32219         MOVSI   A,(D)           ; CHANNEL BACK\r
32220         ASH     A,5\r
32221         MOVEI   B,E             ; WHERE TO STRAT IN FILE\r
32222         IOR     A,[.ACCESS B]\r
32223         XCT     A               ; ACCESS TO RIGHT ACS\r
32224         XOR     A,[<.IOT B>#<.ACCESS B>]\r
32225         MOVE    B,[D-P-1,,E]\r
32226         XCT     A               ; GET ACS\r
32227         MOVE    E,0             ; NO TTY FLAG BACK\r
32228         XOR     A,[<.IOT B>#<.CLOSE>]\r
32229         XCT     A\r
32230 ]\r
32231 IFE ITS,[\r
32232 FASTR:  POP     P,A             ; JFN TO A\r
32233         BIN                     ; CORE TOP TO B\r
32234         MOVE    E,B             ; SAVE\r
32235         BIN                     ; PARTOP\r
32236         MOVE    D,B\r
32237         BIN                     ; VECBOT\r
32238         MOVE    C,B\r
32239         BIN                     ; SAVED P\r
32240         MOVE    P,B\r
32241         MOVE    0,NOTTY         ; SAVE NOTTY FLAG AROUND\r
32242         HRL     E,C             ; SAVE VECTOP\r
32243         MOVSI   A,(A)           ; JFN TO LH\r
32244         MOVSI   B,400000        ; FOR ME\r
32245         MOVSI   C,120400        ; FLAGS\r
32246         ASH     D,-9.           ; PAGES TO D\r
32247         PMAP\r
32248         ADDI    A,1\r
32249         ADDI    B,1\r
32250         SOJG    D,.-3\r
32251 \r
32252         ASH     E,-9.           ; E==> CORTOP PAGE,,VECBOT PAGE\r
32253         HLR     B,E             ; B NOW READY\r
32254         MOVEI   D,(E)\r
32255         SUBI    D,(B)\r
32256         PMAP\r
32257         ADDI    A,1\r
32258         ADDI    B,1\r
32259         SOJG    D,.-3\r
32260 \r
32261         HLRZS   A\r
32262         CLOSF\r
32263         FATAL CANT CLOSE RESTORE FILE\r
32264         MOVE    E,0             ; NOTTY TO E\r
32265 ]\r
32266         MOVE    A,PARTOP        ; ZERO OUT NEW FREE\r
32267         HRLI    A,(A)\r
32268         MOVE    B,VECBOT\r
32269         SETZM   (A)\r
32270         ADDI    A,1\r
32271         BLT     A,-1(B)         ; ZAP...YOU'RE ZERO\r
32272         JRST    FASTR1\r
32273 \r
32274 \r
32275 ; HERE TO GROCK FILE NAME FROM ARGS\r
32276 \r
32277 GTFNM:\r
32278 IFN ITS,[\r
32279         PUSH    TP,$TPDL\r
32280         PUSH    TP,P\r
32281 \r
32282         IRP A,,[DSK,MUDDLE,SAVE]\r
32283         PUSH    P,[SIXBIT /A/]\r
32284         TERMIN\r
32285         PUSHJ   P,SGSNAM        ; GET SNAME\r
32286         PUSH    P,A             ; SAVE SNAME\r
32287 \r
32288         JUMPGE  AB,GTFNM1\r
32289         PUSHJ   P,RGPRS         ; PARSE THESE ARGS\r
32290         JRST    .+2\r
32291 GTFNM1: AOS     -4(P)           ; SKIP RETURN\r
32292 \r
32293         POP     P,A             ; GET SNAME\r
32294         .SUSET  [.SSNAM,,A]\r
32295         MOVE    A,-3(P)         ; GET RET ADDR\r
32296         HLRZS   -2(P)           ; FIXUP DEVICE SPEC\r
32297         SUB     TP,[2,,2]\r
32298         JRST    (A)\r
32299 \r
32300 ; HERE TOO OUT 1 WORD\r
32301 \r
32302 WRDOUT: PUSH    P,B\r
32303         PUSH    P,A\r
32304         HRROI   B,(P)           ; POINT AT C(A)\r
32305         MOVE    A,-3(P)         ; CHANNEL\r
32306         PUSHJ   P,MIOT           ;WRITE IT\r
32307 POPJB:  POP     P,A\r
32308         POP     P,B\r
32309         POPJ    P,\r
32310 \r
32311 ; HERE TO READ 1 WORD\r
32312 WRDIN==WRDOUT\r
32313 ]\r
32314 IFE ITS,[\r
32315         PUSH    P,C\r
32316         PUSH    P,B\r
32317         MOVE    B,IMQUOTE SNM\r
32318         PUSHJ   P,IDVAL1\r
32319         GETYP   0,A\r
32320         CAIN    0,TUNBOU\r
32321         MOVEI   B,0\r
32322         MOVEI   A,(P)\r
32323         PUSH    P,[377777,,377777]\r
32324         PUSH    P,[-1,,[ASCIZ /DSK/]]\r
32325         PUSH    P,B\r
32326         PUSH    P,[-1,,[ASCIZ /MUDDLE/]]\r
32327         PUSH    P,[-1,,[ASCIZ /SAVE/]]\r
32328         PUSH    P,[0]\r
32329         PUSH    P,[0]\r
32330         PUSH    P,[77]          ; USE AN OBSCURE JFN IF POSSIBLE\r
32331         MOVE    B,1(AB)\r
32332         GTJFN\r
32333         JRST    FNF\r
32334         SUB     P,[9.,,9.]\r
32335         POP     P,B\r
32336         OPENF\r
32337         JRST    FNF\r
32338         ADD     AB,[2,,2]\r
32339         SKIPL   AB\r
32340         AOS     (P)\r
32341         POPJ    P,\r
32342 \r
32343 WRDIN:  PUSH    P,B\r
32344         MOVE    A,-2(P)         ; JFN TO A\r
32345         BIN\r
32346         MOVE    A,B\r
32347         POP     P,B\r
32348         POPJ    P,\r
32349 \r
32350 WRDOUT: PUSH    P,B\r
32351         MOVE    B,-2(P)\r
32352         EXCH    A,B\r
32353         BOUT\r
32354         EXCH    A,B\r
32355         POP     P,B\r
32356         POPJ    P,\r
32357 ]\r
32358 \r
32359 \r
32360 ;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A\r
32361 HACKV:  PUSH    P,D\r
32362         PUSH    P,E\r
32363         MOVE    D,[440700,,A]\r
32364         MOVEI   E,5\r
32365 HACKV1: ILDB    0,D\r
32366         CAIN    0,(B)           ; MATCH ?\r
32367         DPB     C,D             ; YES, CLOBBER\r
32368         SOJG    E,HACKV1\r
32369         POP     P,E\r
32370         POP     P,D\r
32371         POPJ    P,\r
32372 \r
32373 \r
32374 CANTOP: PUSH    TP,$TATOM\r
32375         PUSH    TP,EQUOTE CANT-OPEN-OUTPUT-FILE\r
32376         JRST    CALER1\r
32377 \r
32378 FNF:    PUSH    TP,$TATOM\r
32379         PUSH    TP,EQUOTE FILE-NOT-FOUND\r
32380         JRST    CALER1\r
32381 \r
32382 BADVRS: PUSH    TP,$TATOM\r
32383         PUSH    TP,EQUOTE MUDDLE-VERSIONS-DIFFER\r
32384         JRST    CALER1\r
32385 \r
32386 EXPVRS: PUSH    TP,$TATOM\r
32387         PUSH    TP,EQUOTE EXPERIMENTAL-MUDDLE-VERSION\r
32388         JRST    CALER1\r
32389 \r
32390 CHNLO1: MOVE    C,(TP)\r
32391         SETZM   1(C)\r
32392         JRST    CHNLO2\r
32393 \r
32394 CHNLOS: MOVE    C,(TP)\r
32395         SETZM   (C)-1\r
32396 CHNLO2: MOVEI   B,[ASCIZ /\r
32397 CHANNEL-NOT-RESTORED\r
32398 /]\r
32399         JRST    MSGTYP"\r
32400 \r
32401 \r
32402 NOCORE: PUSH    P,A\r
32403         PUSH    P,B\r
32404         MOVEI   B,[ASCIZ /\r
32405 WAIT, CORE NOT YET HERE\r
32406 /]\r
32407         PUSHJ   P,MSGTYP"\r
32408         MOVE    A,(P)           ; RESTORE BLOCKS NEEDED\r
32409         MOVEI   B,1\r
32410         .SLEEP  B,\r
32411         PUSHJ   P,P.CORE\r
32412         JRST    .-4\r
32413         MOVEI   B,[ASCIZ /\r
32414 CORE ARRIVED\r
32415 /]\r
32416         PUSHJ   P,MSGTYP\r
32417         POP     P,B\r
32418         POP     P,A\r
32419         POPJ    P,\r
32420 END\r
32421 \f\fTITLE SPECS FOR MUDDLE\r
32422 \r
32423 RELOCA\r
32424 \r
32425 MAIN==1\r
32426 .GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC\r
32427 .GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN\r
32428 .GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF\r
32429 \r
32430 \r
32431 .INSRT MUDDLE >\r
32432 \r
32433 SYSQ\r
32434 \r
32435 CONSTANTS\r
32436 \r
32437 IFN ITS,[\r
32438         N.CHNS==16.\r
32439         FATINS==.VALUE\r
32440 ]\r
32441 IFE ITS,[\r
32442         N.CHNS==102\r
32443 ]\r
32444 \r
32445 IMPURE\r
32446 \r
32447 CRADIX:         10.\r
32448 %UNAM:          0               ; HOLDS UNAME\r
32449 %JNAM:          0               ; HOLDS JNAME\r
32450 IDPROC:         0               ; ENVIRONMENT NUMBER GENERATOR\r
32451 PTIME:          0               ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS\r
32452 OBLNT":         13.             ; LENGTH OF DEFAULT OBLISTS (SMALL)\r
32453 VECTOP":        VECLOC          ; TOP OF CURRENT GARBAGE COLLECTED SPACE\r
32454 VECBOT":        VECBASE         ; BOTTOM OF GARBAGE COLLECTED SPACE\r
32455 CODBOT:         0               ; ABSOLUTE BOTTOM OF CODE\r
32456 CODTOP":        PARBASE         ; TOP OF IMPURE CODE (INCLUDING "STORAGE")\r
32457 HITOP:          0               ; TOP OF INTERPRETER PURE CORE\r
32458 PARNEW":        0\r
32459 PARBOT":        PARBASE\r
32460 PARTOP":        PARLOC\r
32461 VECNEW":        0               ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP\r
32462 INTFLG:         0               ; INTERRUPT PENDING FLAG\r
32463 MAINPR:         0               ; HOLDS POINTER TO THE MAIN PROCESS\r
32464 NOTTY:          0               ; NON-ZERO==> THIS MUDDLE HAS NO TTY\r
32465 GCHAPN:         0               ; NON-ZERO A GC HAS HAPPENED RECENTLY\r
32466 INTHLD:         0               ; NON-ZERO INTERRUPTS CANT HAPPEN\r
32467 PURBOT:         HIBOT           ; BOTTOM OF DYNAMICALLY ALLOCATED PURE\r
32468 PURTOP:         HIBOT           ; TOP OF DYNAMICALLY ALLOCATED PURE\r
32469 SPCCHK:         SETZ            ; SPECIAL/UNSPECIAL CHECKING?\r
32470 NOSHUF:         0               ; FLAG TO BUILD A NON MOVING HI SEG\r
32471 \r
32472 ;PAGE MAP USAGE TABLE FOR MUDDLE\r
32473 ;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE\r
32474 ;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY\r
32475 ;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32.\r
32476 PMAP":  -1      ;SECTION 0 -- BELONGS TO AGC\r
32477         -1      ;SECTION 1 -- BELONGS TO AGC\r
32478         -1      ;SECTION 2 -- BELONGS TO AGC\r
32479         -1      ;SECTION 3 -- BELONGS TO AGC\r
32480         -1      ;SECTION 4 -- BELONGS TO AGC\r
32481         -1      ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT)\r
32482         -1      ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM)\r
32483         -1      ;SECTION 7 -- LAST TWO PAGES BELONG TO AGC'S PAGE MAPPER\r
32484 \r
32485 \r
32486 NINT==72.       ; NUMBER OF POSSIBLE ITS INTERRUPTS\r
32487 NASOCS==159.    ; LENGTH OF ASSOCIATION VECTOR\r
32488 PDLBUF==100     ; EXTRA INSURENCE PDL\r
32489 ASOLNT==10      ; LENGTH OF ASSOCIATION BLOCKS\r
32490 \r
32491 \r
32492 .GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2\r
32493 .GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS\r
32494 .GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES\r
32495 .GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA\r
32496 .GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST\r
32497 \r
32498 \r
32499 VECTGO\r
32500 TVBASE":        BLOCK   TVLNT\r
32501         GENERAL\r
32502         TVLNT+2,,0\r
32503 TVLOC==TVBASE\r
32504 \r
32505 \r
32506 \r
32507 ;INITIAL TYPE TABLE\r
32508 \r
32509 TYPVLC":\r
32510         BLOCK   2*NUMPRI+2\r
32511         GENERAL\r
32512         2*NUMPRI+2+2,,0\r
32513 \r
32514 TYPTP==.-2                      ; POINT TO TOP OF TYPES\r
32515 \r
32516 ; INITIAL SYMBOL TABEL FOR RSUBRS\r
32517 \r
32518 SQULOC==.\r
32519 SQUTBL: BLOCK   2*NSUBRS\r
32520         TWORD,,0\r
32521         2*NSUBRS+2,,0\r
32522 \r
32523 INTVCL: BLOCK   2*NINT\r
32524         TLIST,,0\r
32525         2*NINT+2,,0\r
32526 \r
32527 NODLST: TTP,,0\r
32528         0\r
32529         TASOC,,0\r
32530         BLOCK   ASOLNT-3\r
32531         GENERAL+<SASOC,,0>\r
32532         ASOLNT+2,,0\r
32533 \r
32534 NODDUM: BLOCK   ASOLNT\r
32535         GENERAL+<SASOC,,0>\r
32536         ASOLNT+2,,0\r
32537 \r
32538 \r
32539 \r
32540 ASOVCL: BLOCK   NASOCS\r
32541         TASOC,,0\r
32542         NASOCS+2,,0\r
32543 \r
32544 \r
32545 \r
32546 ;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION\r
32547 \r
32548 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]\r
32549 TYPVEC==TVOFF-1\r
32550 \r
32551 ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]\r
32552 TYPBOT==TVOFF-1                 ; POINT TO CURRENT TOP OF TYPE VECTORS\r
32553 \r
32554 ;ENTRY FOR ROOT,TTICHN,TTOCHN\r
32555 \r
32556 ADDTV TCHAN,0\r
32557 TTICHN==TVOFF-1\r
32558 \r
32559 ADDTV TCHAN,0\r
32560 TTOCHN==TVOFF-1\r
32561 \r
32562 ADDTV TOBLS,0\r
32563 ROOT==TVOFF-1\r
32564 ADDTV TOBLS,0\r
32565 INITIA==TVOFF-1\r
32566 ADDTV TOBLS,0\r
32567 INTOBL==TVOFF-1\r
32568 ADDTV TOBLS,0\r
32569 ERROBL==TVOFF-1\r
32570 ADDTV TOBLS,0\r
32571 MUDOBL==TVOFF-1\r
32572 ADDTV TVEC,0\r
32573 GRAPHS==TVOFF-1\r
32574 ADDTV TFIX,0\r
32575 INTNUM==TVOFF-1\r
32576 ADDTV TVEC,[-2*NINT,,INTVCL]\r
32577 INTVEC==TVOFF-1\r
32578 ADDTV TUVEC,[-NASOCS,,ASOVCL]\r
32579 ASOVEC==TVOFF-1\r
32580 \r
32581 ADDTV TLIST,0\r
32582 CHNL0"==TVOFF-1         ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS\r
32583 \r
32584 IFN ITS,[\r
32585 DEFINE ADDCHN N\r
32586         ADDTV TCHAN,0\r
32587         CHNL!N==TVOFF-1\r
32588         .GLOBAL CHNL!N\r
32589         TERMIN\r
32590 \r
32591 REPEAT 15.,ADDCHN \.RPCNT+1\r
32592         \r
32593 DEFINE ADDIPC N\r
32594         ADDTV TLIST,0\r
32595         IPCS!N==TVOFF-1\r
32596         .GLOBAL IPCS!N\r
32597         TERMIN\r
32598 \r
32599 REPEAT 15.,ADDIPC \.RPCNT+1\r
32600 ]\r
32601 \r
32602 IFE ITS,[\r
32603 ADDTV TCHAN,0\r
32604 CHNL1==TVOFF-1\r
32605 .GLOBAL CHNL1\r
32606 REPEAT N.CHNS-1,[ADDTV TCHAN,0\r
32607 ]\r
32608 ]\r
32609 \r
32610 ADDTV TASOC,[-ASOLNT,,NODLST]\r
32611 NODES==TVOFF-1\r
32612 \r
32613 ADDTV TASOC,[-ASOLNT,,NODDUM]\r
32614 DUMNOD==TVOFF-1\r
32615 \r
32616 ADDTV TVEC,0\r
32617 EVATYP==TVOFF-1\r
32618 \r
32619 ADDTV TVEC,0\r
32620 APLTYP==TVOFF-1\r
32621 \r
32622 ADDTV TVEC,0\r
32623 PRNTYP==TVOFF-1\r
32624 \r
32625 ; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES\r
32626 \r
32627 ADDTV TUVEC,0\r
32628 TD.GET==TVOFF-1\r
32629 \r
32630 ADDTV TUVEC,0\r
32631 TD.PUT==TVOFF-1\r
32632 \r
32633 ADDTV TUVEC,0\r
32634 TD.LNT==TVOFF-1\r
32635 \r
32636 ADDTV TUVEC,0\r
32637 TD.PTY==TVOFF-1\r
32638 \r
32639 \r
32640 \r
32641 ;GLOBAL SPECIAL PDL\r
32642 \r
32643 GSP:    BLOCK   GSPLNT\r
32644         GENERAL\r
32645         GSPLNT+2,,0\r
32646 \r
32647 ADDTV TVEC,[-GSPLNT,,GSP]\r
32648 GLOBASE==TVOFF-1\r
32649 GLOB==.-2\r
32650 ADDTV TVEC,GLOB\r
32651 GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP\r
32652 \r
32653 ; POINTER VECTOR TO PURE SHARED RSUBRS\r
32654 \r
32655 PURV:   BLOCK   3*20.           ; ENOUGH FOR 20 SUCH (INITIALLY)\r
32656         0\r
32657         3*20.+2,,0\r
32658 \r
32659 ADDTV TUVEC,[-3*20.,,PURV]\r
32660 PURVEC==TVOFF-1\r
32661 \r
32662 ADDTV TLIST,0\r
32663 STOLST==TVOFF-1\r
32664 \r
32665 ;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS\r
32666 \r
32667 GCPVP:  BLOCK   PVLNT*2\r
32668         GENERAL\r
32669         PVLNT*2+2,,0\r
32670 \r
32671 \r
32672 VECRET\r
32673 \r
32674 PURE\r
32675 \r
32676 ;INITIAL PROCESS VECTOR\r
32677 \r
32678 PVBASE":        BLOCK   PVLNT*2\r
32679         GENERAL\r
32680         PVLNT*2+2,,0\r
32681 PVLOC==PVBASE\r
32682 \r
32683 \r
32684 ;ENTRY FOR PROCESS I.D.\r
32685 \r
32686         ADDPV   TFIX,1,PROCID\r
32687 ;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS\r
32688 \r
32689 ZZZ==.\r
32690 \r
32691 IRP A,,[0,A,B,C,D,E,PVP,TVP,AB,TB,TP,SP,M,R,P]B,,[0\r
32692 0,0,0,0,0,TPVP,TTVP,TAB,TTB,TTP,TSP,TCODE,TRSUBR,TPDL]\r
32693 \r
32694 LOC PVLOC+2*A\r
32695 A!STO==.-PVBASE\r
32696 B,,0\r
32697 0\r
32698 TERMIN\r
32699 \r
32700 PVLOC==PVLOC+16.*2\r
32701 LOC ZZZ\r
32702 \r
32703 \r
32704 ADDPV TTB,0,TBINIT\r
32705 ADDPV TTP,0,TPBASE\r
32706 ADDPV TSP,0,SPBASE\r
32707 ADDPV TPDL,0,PBASE\r
32708 ADDPV 0,0,RESFUN\r
32709 ADDPV TLIST,0,.BLOCK\r
32710 ADDPV TLIST,0,MESS\r
32711 ADDPV TACT,0,FACTI\r
32712 ADDPV TPVP,0,LSTRES\r
32713 ADDPV TFIX,0,BINDID\r
32714 ADDPV TFIX,1,PSTAT\r
32715 ADDPV TPVP,0,1STEPR\r
32716 ADDPV TSP,0,CURFCN\r
32717 \r
32718 \r
32719 IMPURE\r
32720 \r
32721 END\r
32722 \f<PACKAGE "TTY">        ;"TENEX VERSION"\r
32723 \r
32724 <ENTRY TTY-SET TTY-GET TTY-ON TTY-OFF>\r
32725 \r
32726 <SETG CALICO-MOD #WORD *700000*>        ;"wakeup on all but alpha, no echo"\r
32727 MUDDLE-MOD      ;"gunnasigned initially"\r
32728 \r
32729 <GDECL (CALICO-MOD MUDDLE-MOD) WORD>\r
32730 \r
32731 <TITLE TTY-GET>\r
32732 <PSEUDO <SET SFMOD #OPCODE *104000000110*>>     ;"JSYS 110"\r
32733 <PSEUDO <SET RFMOD #OPCODE *104000000107*>>     ;"JSYS 107"\r
32734 <DECLARE ("VALUE" WORD)>\r
32735 <HRRZI A* -1>   ;"controlling tty file desig"\r
32736 <RFMOD>\r
32737 <MOVSI  A* TWORD>\r
32738 <JRST FINIS>\r
32739 \r
32740 <TITLE TTY-SET>\r
32741 <DECLARE ("VALUE" WORD <PRIMTYPE WORD>)>\r
32742 <HRRZI A* -1>\r
32743 <MOVE   B* 1 (AB)>\r
32744 <SFMOD>\r
32745 <MOVE   A* (AB)>\r
32746 <MOVE   B* 1 (AB)>\r
32747 <JRST FINIS>\r
32748 \r
32749 <END>\r
32750 \r
32751 <DEFINE TTY-OFF ()\r
32752 <COND (<NOT <GASSIGNED? MUDDLE-MOD>>\r
32753         <SETG MUDDLE-MOD <TTY-GET>>)>\r
32754         <TTY-SET ,CALICO-MOD>>\r
32755 \r
32756 <DEFINE TTY-ON ()\r
32757 <COND (<NOT <GASSIGNED? MUDDLE-MOD>>\r
32758         <SETG MUDDLE-MOD <TTY-GET>>)\r
32759         (<TTY-SET ,MUDDLE-MOD>)>>\r
32760 \r
32761 \r
32762 <ENDPACKAGE>\r
32763 \fTITLE UUO HANDLER FOR MUDDLE AND HYDRA\r
32764 RELOCATABLE\r
32765 .INSRT MUDDLE >\r
32766 \r
32767 ;GLOBALS FOR THIS PROGRAM\r
32768 \r
32769 .GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP\r
32770 .GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME\r
32771 .GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO\r
32772 \r
32773 ;SETUP UUO DISPATCH TABLE HERE\r
32774 \r
32775 UUOTBL: ILLUUO\r
32776 \r
32777 IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]]\r
32778 UUFOO==.IRPCNT+1\r
32779 IRP UUO,DISP,[UUOS]\r
32780 .GLOBAL UUO\r
32781 UUO=UUFOO_33\r
32782 DISP\r
32783 .ISTOP\r
32784 TERMIN\r
32785 TERMIN\r
32786 \r
32787 REPEAT 100-UUFOO,[ILLUUO\r
32788 ]\r
32789 \r
32790 \r
32791 RMT [\r
32792 IMPURE\r
32793 \r
32794 UUOH:\r
32795 LOC 41\r
32796         JSR     UUOH\r
32797 LOC UUOH\r
32798         0\r
32799         JRST    UUOPUR          ;GO TO PURE CODE FOR THIS\r
32800 \r
32801 SAVEC:  0                       ; USED TO SAVE WORKING AC\r
32802 NOLINK: 0\r
32803 \r
32804 PURE\r
32805 ]\r
32806 \r
32807 ;SEPARATION OF PURE FROM IMPURE CODE HERE\r
32808 \r
32809 UUOPUR: MOVEM   C,SAVEC         ; SAVE AC\r
32810         LDB     C,[330900,,40]\r
32811         JRST    @UUOTBL(C)      ;DISPATCH BASED ON THE UUO\r
32812 \r
32813 \r
32814 \r
32815 ILLUUO: FATAL ILLEGAL UUO\r
32816 \f;CALL HANDLER\r
32817 \r
32818 MQUOTE CALLER\r
32819 CALLER:\r
32820 \r
32821 DMCALL":\r
32822         MOVEI   D,0             ; FLAG NOT ENTRY CALL\r
32823         LDB     C,[270400,,40]  ; GET AC FIELD OF UUO\r
32824 COMCAL: LSH     C,1             ; TIMES 2\r
32825         MOVN    AB,C            ; GET NEGATED # OF ARGS\r
32826         HRLI    C,(C)           ; TO BOTH SIDES\r
32827         SUBM    TP,C            ; NOW HAVE TP TO SAVE\r
32828         MOVEM   C,TPSAV(TB)     ; SAVE IT\r
32829         MOVSI   AB,(AB)         ; BUILD THE AB POINTER\r
32830         HRRI    AB,1(C)         ; POINT TO ARGS\r
32831         HRRZ    C,UUOH          ; GET PC OF CALL\r
32832         CAMG    C,PURTOP        ; SKIP IF NOT IN GC SPACE\r
32833         CAIGE   C,STOSTR        ; SKIP IF IN GC SPACE\r
32834         JRST    .+3\r
32835         SUBI    C,(M)           ; RELATIVIZE THE PC\r
32836         HRLI    C,M             ; FOR RETURNER TO WIN\r
32837         MOVEM   C,PCSAV(TB)\r
32838         MOVEM   SP,SPSAV(TB)    ; SAVE BINDING GOODIE\r
32839         MOVSI   C,TENTRY        ; SET UP ENTRY WORD\r
32840         HRR     C,40            ; POINT TO CALLED SR\r
32841         ADD     TP,[FRAMLN,,FRAMLN]     ; ALLOCATE NEW FRAME\r
32842         JUMPGE  TP,TPLOSE\r
32843 CALDON: MOVEM   C,FSAV+1(TP)    ; CLOBBER THE FRAME\r
32844         MOVEM   TB,OTBSAV+1(TP)\r
32845         MOVEM   AB,ABSAV+1(TP)  ; FRAME BUILT\r
32846         MOVEM   P,PSAV(TB)\r
32847         HRRI    TB,(TP)         ; SETUP NEW TB\r
32848         MOVEI   C,(C)\r
32849         MOVEI   M,0             ; UNSETUP M FOR GC WINNAGE\r
32850         CAMG    C,VECTOP        ; SKIP IF NOT RSUBR\r
32851         CAMGE   C,VECBOT        ; SKIP IF RSUBR\r
32852         JRST    CALLS\r
32853         GETYP   A,(C)           ; GET CONTENTS OF SLOT\r
32854         JUMPN   D,EVCALL        ; EVAL CALLING ENTRY ?\r
32855         CAIE    A,TRSUBR        ; RSUBR CALLING RSUBR ?\r
32856         JRST    RCHECK          ; NO\r
32857         MOVE    R,(C)+1         ; YES, SETUP R\r
32858 CALLR0: HRRM    R,FSAV+1(TB)    ; FIXUP THE PROPER FSAV\r
32859 CALLR1: AOS     E,2(R)          ; COUNT THE CALLS\r
32860         TRNN    E,-1            ; SKIP IF OK\r
32861         JRST    COUNT1\r
32862 \r
32863         SKIPL   M,(R)+1         ; SETUP M\r
32864         JRST    SETUPM          ; JUMP IF A PURE RSUBR IN QUESTION\r
32865         AOBJP   TB,.+1          ; GO TO CALLED RSUBR\r
32866         INTGO                   ; CHECK FOR INTERRUPTS\r
32867         JRST    (M)\r
32868 \r
32869 COUNT1: SOS     2(R)            ; UNDO OVERFLOW\r
32870         HLLZS   2(R)\r
32871         JRST    CALLR1\r
32872 \r
32873 CALLS:  AOBJP   TB,.+1          ; GO TO CALLED SUBR\r
32874         INTGO                   ; CHECK FOR INTERRUPTS\r
32875         JRST    @C\r
32876 \f\r
32877 ; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)\r
32878 \r
32879 SETUPM: MOVEI   C,0             ; OFFSET (FOR MAIN ENTRIES)\r
32880 STUPM1: MOVEI   D,(M)           ; GET OFFSET INTO  CODE\r
32881         HLRS    M               ; GET VECTOR OFFSET IN BOTH HALVES\r
32882         ADD     M,PURVEC+1(TVP) ; GET IT\r
32883         SKIPL   M\r
32884         FATAL   LOSING PURE RSUBR POINTER\r
32885         HLLM    TB,2(M)         ; MARK FOR LRU ALGORITHM\r
32886         SKIPN   M,1(M)          ; POINT TO CORE IF LOADED\r
32887         AOJA    TB,STUPM2       ; GO LOAD IT\r
32888 STUPM3: ADDI    M,(D)           ; POINT TO REAL THING\r
32889         HRLI    C,M             ; POINT TO START PC\r
32890         AOBJP   TB,.+1\r
32891         INTGO\r
32892         JRST    @C              ; GO TO IT\r
32893 \r
32894 STUPM2: HLRZ    A,1(R)          ; SET UP TO CALL LOADER\r
32895         PUSH    P,D\r
32896         PUSH    P,C\r
32897         PUSHJ   P,PLOAD         ; LOAD IT\r
32898         JRST    PCANT1\r
32899         POP     P,C\r
32900         POP     P,D\r
32901         MOVE    M,B             ; GET LOCATION\r
32902         SOJA    TB,STUPM3\r
32903 \r
32904 RCHECK: CAIN    A,TPCODE        ; PURE RSUBR?\r
32905         JRST    .+3\r
32906         CAIE    A,TCODE         ; EVALUATOR CALLING RSUBR ?\r
32907         JRST    SCHECK          ; NO\r
32908         MOVS    R,(C)           ; YES, SETUP R\r
32909         HRRI    R,(C)\r
32910         JRST    CALLR1          ; GO FINISH THE RSUBR CALL\r
32911 \r
32912 \r
32913 SCHECK: CAIE    A,TSUBR         ; RSUBR CALLING SUBR AS REFERENCE ?\r
32914         CAIN    A,TFSUBR\r
32915         SKIPA   C,(C)+1         ; SKIP AND GET ROUTINE'S ADDRESS\r
32916         JRST    ECHECK\r
32917         HRRM    C,FSAV+1(TB)    ; FIXUP THE PROPER FSAV\r
32918         JRST    CALLS           ; GO FINISH THE SUBR CALL\r
32919 \r
32920 ECHECK: CAIE    A,TENTER        ; SKIP IF SUB ENTRY OF RSUBR\r
32921         JRST    ACHECK          ; COULD BE EVAL CALLING ONE\r
32922         MOVE    C,1(C)          ; POINT TO SUB ENTRY BLOCK\r
32923 ECHCK3: GETYP   A,(C)           ; SEE IF LINKED TO ITS MAIN ENTRY\r
32924         MOVE    B,1(C)\r
32925         CAIN    A,TRSUBR\r
32926         JRST    ECHCK2\r
32927 \r
32928 ; CHECK IF CAN LINK ATOM\r
32929 \r
32930         CAIE    A,TATOM\r
32931         JRST    BENTRY          ; LOSER , COMPLAIN\r
32932 ECHCK4: MOVE    B,1(C)          ; GET ATOM\r
32933         PUSH    TP,$TVEC\r
32934         PUSH    TP,C\r
32935         PUSHJ   P,IGVAL         ; TRY GLOBAL VALUE\r
32936         MOVE    C,(TP)\r
32937         SUB     TP,[2,,2]\r
32938         CAMN    A,$TUNBOU\r
32939         JRST    BADVAL\r
32940         CAME    A,$TRSUBR       ; IS IT A WINNER\r
32941         JRST    BENTRY\r
32942         SKIPE   NOLINK\r
32943         JRST    ECHCK2\r
32944         HLLM    A,(C)           ; FIXUP LINKAGE\r
32945         MOVEM   B,1(C)\r
32946         JRST    ECHCK2\r
32947 \r
32948 EVCALL: CAIN    A,TATOM         ; EVAL CALLING ENTRY?\r
32949         JRST    ECHCK4          ; COULD BE MUST FIXUP\r
32950         CAIE    A,TRSUBR        ; YES THIS IS ONE\r
32951         JRST    BENTRY\r
32952         MOVE    B,1(C)\r
32953 ECHCK2: MOVE    R,B             ; SET UP R\r
32954         HRRM    C,FSAV+1(TB)    ; SET POINTER INTO FRAME\r
32955         HRRZ    C,2(C)          ; FIND OFFSET INTO SAME\r
32956         SKIPL   M,1(R)          ; POINT TO START OF RSUBR\r
32957         JRST    STUPM1          ; JUMP IF A LOSER\r
32958         HRLI    C,M\r
32959         JRST    CALLS           ; GO TO SR\r
32960 \r
32961 ACHECK: CAIE    A,TATOM         ; RSUBR CALLING THROUGH REFERENCE ATOM ?\r
32962         JRST    DOAPP3          ; TRY APPLYING IT\r
32963         MOVE    A,(C)\r
32964         MOVE    B,(C)+1\r
32965         PUSHJ   P,IGVAL\r
32966         HRRZ    C,40            ; REGOBBLE POINTER TO SLOT\r
32967         GETYP   0,A             ; GET TYPE\r
32968         CAIN    0,TUNBOUND\r
32969         JRST    TRYLCL\r
32970 SAVEIT: CAIE    0,TRSUBR\r
32971         CAIN    0,TENTER\r
32972         JRST    SAVEI1          ; WINNER\r
32973         CAIE    0,TSUBR\r
32974         CAIN    0,TFSUBR\r
32975         JRST    SUBRIT\r
32976         JRST    BADVAL          ; SOMETHING STRANGE\r
32977 SAVEI1: SKIPE   NOLINK\r
32978         JRST    .+3\r
32979         MOVEM   A,(C)           ; CLOBBER NEW VALUE\r
32980         MOVEM   B,(C)+1\r
32981         CAIN    0,TENTER\r
32982         JRST    ENTRIT          ; HACK ENTRY TO SUB RSUBR\r
32983         MOVE    R,B             ; SETUP R\r
32984         JRST    CALLR0          ; GO FINISH THE RSUBR CALL\r
32985 \r
32986 ENTRIT: MOVE    C,B\r
32987         JRST    ECHCK3\r
32988 \r
32989 SUBRIT: SKIPE   NOLINK\r
32990         JRST    .+3\r
32991         MOVEM   A,(C)\r
32992         MOVEM   B,1(C)\r
32993         HRRM    B,FSAV+1(TB)    ; FIXUP THE PROPER FSAV\r
32994         MOVEI   C,(B)\r
32995         JRST    CALLS           ; GO FINISH THE SUBR CALL\r
32996 \r
32997 TRYLCL: MOVE    A,(C)\r
32998         MOVE    B,(C)+1\r
32999         PUSHJ   P,ILVAL\r
33000         GETYP   0,A\r
33001         CAIE    0,TUNBOUND\r
33002         JRST    SAVEIT\r
33003         SKIPA   D,EQUOTE UNBOUND-VARIABLE\r
33004 BADVAL: MOVEI   D,0\r
33005 ERCAL:  AOBJP   TB,.+1          ; MAKE TB A LIGIT FRAME PNTR\r
33006         MOVEI   E,CALLER\r
33007         HRRM    E,FSAV(TB)      ; SET A WINNING FSAV\r
33008         HRRZ    C,40            ; REGOBBLE POINTER TO SLOT\r
33009         JUMPE   D,DOAPPL\r
33010         SUBI    C,(R)           ; CALCULATE OFFSET\r
33011         HRLS    C\r
33012         ADD     C,R             ; MAKE INTO REAL RSUBR POINTER\r
33013         PUSH    TP,$TRSUBR      ; SAVE\r
33014         PUSH    TP,C\r
33015         HRRZ    C,40            ; REGOBBLE POINTER TO SLOT\r
33016         PUSH    TP,$TATOM\r
33017         PUSH    TP,D\r
33018         PUSH    TP,(C)\r
33019         PUSH    TP,(C)+1\r
33020         PUSH    TP,$TATOM\r
33021         PUSH    TP,MQUOTE CALLER\r
33022         MCALL   3,ERROR\r
33023         MOVE    C,(TP)          ; GET SAVED RSUBR POINTER\r
33024         SUB     TP,[2,,2]               ; POP STACK\r
33025         GETYP   0,A\r
33026         HRRM    C,40\r
33027         SOJA    TB,SAVEIT\r
33028 \r
33029 BENTRY: MOVE    D,EQUOTE BAD-ENTRY-BLOCK\r
33030         JRST    ERCAL\r
33031 \r
33032 ;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS\r
33033 \r
33034 DACALL":\r
33035         LDB     C,[270400,,40]  ; GOBBLE THE AC LOCN INTO C\r
33036         EXCH    C,SAVEC         ; C TO SAVE LOC RESTORE C\r
33037         MOVE    C,@SAVEC        ; C NOW HAS NUMBER OF ARGS\r
33038         MOVEI   D,0             ; FLAG NOT E CALL\r
33039         JRST    COMCAL          ; JOIN MCALL\r
33040 \r
33041 ; CALL TO ENTRY FROM EVAL (LIKE ACALL)\r
33042 \r
33043 DECALL:         LDB     C,[270400,,40]  ; GET NAME OF AC\r
33044         EXCH    C,SAVEC         ; STORE NAME\r
33045         MOVE    C,@SAVEC        ; C NOW HAS NUM OF ARGS\r
33046         MOVEI   D,1             ; FLAG THIS\r
33047         JRST    COMCAL\r
33048 \r
33049 ;HANDLE OVERFLOW IN THE TP\r
33050 \r
33051 TPLOSE: PUSHJ   P,TPOVFL\r
33052         JRST    CALDON\r
33053 \r
33054 ; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY\r
33055 \r
33056 DOAPPL: PUSH    TP,A            ; PUSH THE THING TO APPLY\r
33057         PUSH    TP,B\r
33058         MOVEI   A,1\r
33059 DOAPP2: JUMPGE  AB,DOAPP1       ; ARGS DONE\r
33060 \r
33061         PUSH    TP,(AB)\r
33062         PUSH    TP,1(AB)\r
33063         ADD     AB,[2,,2]\r
33064         AOJA    A,DOAPP2\r
33065 \r
33066 DOAPP1: ACALL   A,APPLY         ; APPLY THE LOSER\r
33067         JRST    FINIS\r
33068 \r
33069 DOAPP3: MOVE    A,(C)           ; GET VAL\r
33070         MOVE    B,1(C)\r
33071         JRST    BADVAL          ; GET SETUP FOR APPLY CALL\r
33072 \f\r
33073 ; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)\r
33074 \r
33075 BFRAME: HRLI    A,M             ; RELATIVIZE PC\r
33076         MOVEM   A,PCSAV(TB)     ; CLOBBER PC IN\r
33077         MOVEM   TP,TPSAV(TB)    ; SAVE STATE\r
33078         MOVEM   SP,SPSAV(TB)\r
33079         ADD     TP,[FRAMLN,,FRAMLN]\r
33080         SKIPL   TP\r
33081         PUSHJ   TPOVFL  ; HACK BLOWN PDL\r
33082         MOVSI   A,TCBLK         ; FUNNY FRAME\r
33083         HRRI    A,(R)\r
33084         MOVEM   A,FSAV+1(TP)    ; CLOBBER\r
33085         MOVEM   TB,OTBSAV+1(TP)\r
33086         MOVEM   AB,ABSAV+1(TP)\r
33087         POP     P,A             ; RET ADDR TO A\r
33088         MOVEM   P,PSAV(TB)\r
33089         HRRI    TB,(TP)\r
33090         AOBJN   TB,.+1\r
33091         JRST    (A)\r
33092 \f;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)\r
33093 \r
33094 FINIS:\r
33095 CNTIN1: HRRZS   C,OTBSAV(TB)    ; RESTORE BASE\r
33096         HRRI    TB,(C)\r
33097 CONTIN: MOVE    TP,TPSAV(TB)    ; START HERE FOR FUNNY RESTART\r
33098         MOVE    P,PSAV(TB)\r
33099         CAME    SP,SPSAV(TB)    ; ANY RESTORATION NEEDED\r
33100         PUSHJ   P,SPECSTO       ; YES, GO UNRAVEL THE WORLDS BINDINGS\r
33101         MOVE    AB,ABSAV(TB)    ; AND GET OLD ARG POINTER\r
33102         HRRZ    C,FSAV(TB)      ; CHECK FOR RSUBR\r
33103         MOVEI   M,0             ; UNSETUP M FOR GC WINNAGE\r
33104         CAMG    C,VECTOP\r
33105         CAMGE   C,VECBOT\r
33106         JRST    @PCSAV(TB)      ; AND RETURN\r
33107         GETYP   0,(C)           ; RETURN TO MAIN OR SUB ENTRY?\r
33108         CAIN    0,TCODE\r
33109         JRST    .+3\r
33110         CAIE    0,TPCODE\r
33111         JRST    FINIS1\r
33112         MOVS    R,(C)\r
33113         HRRI    R,(C)           ; RESET R\r
33114         SKIPGE  M,1(R)          ; GET LOC OF REAL SUBR\r
33115         JRST    @PCSAV(TB)\r
33116         JRST    FINIS2\r
33117 \r
33118 FINIS1: CAIE    0,TRSUBR\r
33119         JRST    FINISA          ; MAY HAVE BEEN PUT BACK TO ATOM\r
33120         MOVE    R,1(C)\r
33121         SKIPGE  M,1(R)\r
33122         JRST    @PCSAV(TB)\r
33123 \r
33124 FINIS2: MOVEI   C,(M)           ; COMPUTE REAL M FOR PURE RSUBR\r
33125         HLRS    M\r
33126         ADD     M,PURVEC+1(TVP)\r
33127         SKIPN   M,1(M)          ; SKIP IF LOADED\r
33128         JRST    FINIS3\r
33129         ADDI    M,(C)           ; POINT TO SUB PART\r
33130         JRST    @PCSAV(TB)\r
33131 \r
33132 FINIS3: PUSH    TP,A\r
33133         PUSH    TP,B\r
33134         HLRZ    A,1(R)          ; RELOAD IT\r
33135         PUSHJ   P,PLOAD\r
33136         JRST    PCANT\r
33137         POP     TP,B\r
33138         POP     TP,A\r
33139         MOVE    M,1(R)\r
33140         JRST    FINIS2\r
33141 \r
33142 FINISA: CAIE    0,TATOM\r
33143         JRST    BADENT\r
33144         PUSH    TP,A\r
33145         PUSH    TP,B\r
33146         PUSH    TP,$TENTER\r
33147         HRL     C,(C)\r
33148         PUSH    TP,C\r
33149         MOVE    B,1(C)          ; GET ATOM\r
33150         PUSHJ   P,IGVAL         ; GET VAL\r
33151         GETYP   0,A\r
33152         CAIE    0,TRSUBR\r
33153         JRST    BADENT\r
33154         MOVE    C,(TP)\r
33155         HLLM    A,(C)\r
33156         MOVEM   B,1(C)\r
33157         MOVE    A,-3(TP)\r
33158         MOVE    B,-2(TP)\r
33159         SUB     TP,[4,,4]\r
33160         JRST    FINIS1\r
33161 \r
33162 BADENT: PUSH    TP,$TATOM\r
33163         PUSH    TP,EQUOTE RSUBR-ENTRY-UNLINKED\r
33164         JRST    CALER1\r
33165 \r
33166 PCANT1: ADD     TB,[1,,]\r
33167 PCANT:  PUSH    TP,$TATOM\r
33168         PUSH    TP,EQUOTE PURE-LOAD-FAILURE\r
33169         JRST    CALER1\r
33170         \r
33171 REPEAT 0,[\r
33172 BCKTR1: PUSH    TP,A            ; SAVE VALUE TO BE RETURNED\r
33173         PUSH    TP,B            ; SAVE FRAME ON PP\r
33174         PUSHJ   P,BCKTRK\r
33175         POP     TP,B\r
33176         POP     TP,A\r
33177         JRST    CNTIN1\r
33178 ]\r
33179 \f\r
33180 ; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME\r
33181 \r
33182 MFUNCTION %RLINK,SUBR,[RSUBR-LINK]\r
33183 \r
33184         ENTRY   1\r
33185 \r
33186         GETYP   0,(AB)\r
33187         SETZM   NOLINK\r
33188         CAIN    0,TFALSE\r
33189         SETOM   NOLINK\r
33190         MOVE    A,(AB)\r
33191         MOVE    B,1(AB)\r
33192         JRST    FINIS\r
33193 \r
33194 ;HANDLER FOR DEBUGGING CALL TO PRINT\r
33195 \r
33196 DODP":\r
33197         PUSH    TP, @40\r
33198         AOS     40\r
33199         PUSH    TP,@40\r
33200         PUSH P,0\r
33201         PUSH P,1\r
33202         PUSH    P,2\r
33203         PUSH    P,SAVEC\r
33204         PUSH P,4\r
33205         PUSH P,5\r
33206         PUSH P,40\r
33207         PUSH    P,UUOH\r
33208         MCALL   1,PRINT\r
33209         POP     P,UUOH\r
33210         POP P,40\r
33211         POP P,5\r
33212         POP P,4\r
33213         POP P,3\r
33214         POP P,2\r
33215         POP P,1\r
33216         POP P,0\r
33217         JRST    2,@UUOH\r
33218 \r
33219 \r
33220 DFATAL: MOVEM   A,20\r
33221         MOVEM   B,21\r
33222         MOVE    B,40\r
33223         HRLI    B,440700\r
33224         PUSHJ   P,MSGTYP\r
33225         JRST    4,.\r
33226 END\r
33227 \f\ 3\ 3\ 3