sumex/initm.mcr186

   1 TITLE INITIALIZATION FOR MUDDLE\r
   2 \r
   3 RELOCATABLE\r
   4 \r
   5 LAST==1 ;POSSIBLE CHECKS DONE LATER\r
   6 \r
   7 .INSRT MUDDLE >\r
   8 \r
   9 SYSQ\r
  10 \r
  11 IFE ITS,[\r
  12 FATINS==.FATAL"\r
  13 SEVEC==104000,,204\r
  14 ]\r
  15 \r
  16 IMPURE\r
  17 \r
  18 OBSIZE==151.    ;DEFAULT OBLIST SIZE\r
  19 \r
  20 .LIFG <TVBASE+TVLNT-TVLOC>\r
  21 .LOP .VALUE\r
  22 .ELDC\r
  23 \r
  24 \r
  25 .GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP\r
  26 .GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE\r
  27 .GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER\r
  28 .GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC\r
  29 .GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1\r
  30 ; INIITAL AMOUNT OF AFREE SPACE\r
  31 \r
  32 STOSTR: BLOCK   400             ; A RANDOM AMOUNT\r
  33 ISTOST: 401,,0\r
  34 \r
  35 SETUP:\r
  36 IFN ITS,        .SUSET  [.RUNAM,,%UNAM]         ; FOR AGC'S BENFIT\r
  37         MOVE    P,GCPDL         ;GET A PUSH DOWN STACK\r
  38 IFN ITS,        .SUSET  [.SMASK,,[200000]]      ; ENABLE PDL OVFL\r
  39         MOVE    TVP,[-TVLNT,,TVBASE]    ;GET INITIAL TRANSFER VECTOR\r
  40         PUSHJ   P,TTYOPE                ;OPEN THE TTY\r
  41         AOS     A,20            ; TOP OF LOW SEGG\r
  42         HRRZM   A,P.TOP\r
  43         SOSN    A               ; IF NOTHING YET\r
  44 IFN ITS,        .SUSET  [.RMEMT,,P.TOP]\r
  45 IFE ITS,        JRST    4,\r
  46         HRRE    A,P.TOP         ; CHECK TOP\r
  47         TRNE    A,377777                ; SKIP IF ALL LOW SEG\r
  48         JUMPL   A,PAGLOS        ; COMPLAIN\r
  49         MOVE    A,HITOP         ; FIND HI SEG TOP\r
  50         ADDI    A,1777\r
  51         ANDCMI  A,1777\r
  52         MOVEM   A,RHITOP        ; SAVE IT\r
  53         MOVEI   A,200\r
  54         SUBI    A,PHIBOT\r
  55         JUMPE   A,HIBOK\r
  56         MOVSI   A,(A)\r
  57         HRRI    A,200\r
  58 IFN ITS,[\r
  59         .CALL   GIVCOR\r
  60         .VALUE\r
  61 ]\r
  62 HIBOK:  MOVEI   B,[ASCIZ /MUDDLE INITIALIZATION.\r
  63 /]\r
  64         PUSHJ   P,MSGTYP        ;PRINT IT\r
  65         MOVE    A,CODTOP        ;CHECK FOR A WINNING LOAD\r
  66         CAML    A,VECBOT        ;IT BETTER BE LESS\r
  67         JRST    DEATH1          ;LOSE COMPLETELY\r
  68         MOVE    B,PARBOT        ;CHECK FOR ANY PAIRS\r
  69         CAME    B,PARTOP        ;ANY LOAD/ASSEMBLE TIME PAIRS?\r
  70         JRST    PAIRCH          ;YES CHECK THEM\r
  71         ADDI    A,2000          ;BUMP UP\r
  72         ANDCMI  A,1777\r
  73         MOVEM   A,PARBOT        ;UPDATE PARBOT AND TOP\r
  74         MOVEM   A,PARTOP\r
  75 SETTV:  MOVE    PVP,[-PVLNT*2,,GCPVP]   ;AND A PROCESS VECTOR\r
  76         MOVEI   A,(PVP)         ;SET UP A BLT\r
  77         HRLI    A,PVBASE        ;FROM PROTOTYPE\r
  78         BLT     A,PVLNT*2-1(PVP)        ;INITIALIZE\r
  79         MOVE    TP,[-ITPLNT,,TPBAS]     ;GET A STACK FOR THIS PROCCESS\r
  80         MOVEI   TB,(TP)         ;AND A BASE\r
  81         HRLI    TB,1\r
  82         SUB     TP,[1,,1]       ;POP ONCE\r
  83 \r
  84 ; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS\r
  85 \r
  86         PUSH    P,[5]           ;COUNT INITIAL OBLISTS\r
  87 \r
  88         PUSH    P,OBLNT         ;SAVE CURRENT OBLIST DEFAULT SIZE\r
  89 \r
  90 MAKEOB: SOS     A,-1(P)\r
  91         MOVE    A,OBSZ(A)\r
  92         MOVEM   A,OBLNT\r
  93         MCALL   0,MOBLIST       ;GOBBLE AN OBLIST\r
  94         PUSH    TP,$TOBLS       ;AND SAVE THEM\r
  95         PUSH    TP,B\r
  96         MOVE    A,(P)-1         ;COUNT DOWN\r
  97         MOVEM   B,@OBTBL(A)     ;STORE\r
  98         JUMPN   A,MAKEOB\r
  99 \r
 100         POP     P,OBLNT         ;RESTORE DEFAULT OBLIST SIZE\r
 101 \r
 102         MOVE    C,TVP           ;MAKE 2 COPIES OF XFER VECTOR POINTER\r
 103         MOVE    D,TVP\r
 104 \r
 105 ;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE\r
 106 ;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR\r
 107 \r
 108 ILOOP:  HLRZ    A,(C)           ;FIRST TYPE\r
 109         JUMPE   A,TVEXAU        ;USEFUL STUFF EXHAUSTED\r
 110         CAIN    A,TCHSTR        ;CHARACTER STRING?\r
 111         JRST    CHACK           ;YES, GO HACK IT\r
 112         CAIN    A,TATOM         ;ATOM?\r
 113         JRST    ATOMHK          ;YES, CHECK IT OUT\r
 114         MOVE    A,(C)           ;MOVE TO NEW HOME (MAY BE SAME)\r
 115         MOVEM   A,(D)\r
 116         MOVE    A,1(C)\r
 117         MOVEM   A,1(D)\r
 118 SETLP:  AOS     (P)             ;COUNT NUMBER OF PAIRS IN XFER VECTOR\r
 119         ADD     D,[2,,2]        ;OUT COUNTER\r
 120 SETLP1: ADD     C,[2,,2]        ;AND IN COUNTER\r
 121         JUMPL   C,ILOOP         ;JUMP IF MORE TO DO\r
 122 \f;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST\r
 123 \r
 124 TVEXAU: HLRE    B,C             ;GET -LENGTH\r
 125         SUBI    C,(B)           ;POIT TO DOPE WORD\r
 126         ANDI    C,-1            ;NO LH\r
 127         HLRZ    A,1(C)          ;INTIAL LENGTH TO A\r
 128         MOVEI   E,(C)           ;COPY OF POINTER TO DOPW WD\r
 129         SUBI    E,(D)           ;AMOUNT LEFT OVER TO E\r
 130         HRLZM   E,1(C)          ;CLOBBER INTO DOPE WORD FOR GARBAGE\r
 131         MOVSI   E,(E)           ;PREPARE TO UPDATE TVP\r
 132         ADD     TVP,E           ;NOW POINTS TO THE RIGHT AMOUNT\r
 133         HLRE    B,D             ;-AMOUNT LEFT TO B\r
 134         ADD     B,A             ;AMOUNT OF GOOD STUFF\r
 135         HRLZM   B,1(D)          ;STORE IT IN GODD DOPE WORD\r
 136         MOVSI   E,400000        ;CLOBBER TO GENERAL IN BOTH CASES\r
 137         MOVEM   E,(C)\r
 138         MOVEM   E,(D)\r
 139 \r
 140 \r
 141 ; FIX UP TYPE VECTOR\r
 142 \r
 143         MOVE    A,TYPVEC+1(TVP) ;GET POINTER\r
 144         MOVEI   0,0             ;FOR POSSIBLE NULL SLOTS\r
 145         MOVSI   B,TATOM         ;SET TYPE TO ATOM\r
 146 \r
 147 TYPLP:  HLLM    B,(A)           ;CHANGE TYPE TO ATOM\r
 148         MOVE    C,@1(A)         ;GET ATOM\r
 149         MOVEM   C,1(A)\r
 150         ADD     A,[2,,2]                ;BUMP\r
 151         JUMPL   A,TYPLP\r
 152 \f; CLOSE TTY CHANNELS\r
 153 IFN ITS,[\r
 154 \r
 155         .CLOSE  1,\r
 156         .CLOSE  2,\r
 157 ]\r
 158 \r
 159 ;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS\r
 160 \r
 161 ;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL\r
 162 \r
 163         IRP     A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]\r
 164         IRP     B,C,[A]\r
 165         PUSH    TP,$!C\r
 166         PUSH    TP,CHQUOTE B\r
 167         .ISTOP\r
 168         TERMIN\r
 169         TERMIN\r
 170 \r
 171         MCALL   2,FOPEN         ;OPEN THE OUT PUT CHANNEL\r
 172         MOVEM   B,TTOCHN+1(TVP) ;SAVE IT\r
 173 \r
 174 ;ASSIGN AS GLOBAL VALUE\r
 175 \r
 176         PUSH    TP,$TATOM\r
 177         PUSH    TP,IMQUOTE OUTCHAN\r
 178         PUSH    TP,A\r
 179         PUSH    TP,B\r
 180         MOVE    A,[PUSHJ P,MTYO]        ;MORE WINNING INS\r
 181         MOVEM   A,IOINS(B)      ;CLOBBER\r
 182         MCALL   2,SETG\r
 183 \r
 184 ;SETUP A CALL TO OPEN THE TTY CHANNEL\r
 185 \r
 186         IRP     A,,[[READ,TCHSTR],[TTY:,TCHSTR]]\r
 187         IRP     B,C,[A]\r
 188         PUSH    TP,$!C\r
 189         PUSH    TP,CHQUOTE B\r
 190         .ISTOP\r
 191         TERMIN\r
 192         TERMIN\r
 193 \r
 194         MCALL   2,FOPEN         ;OPEN INPUTCHANNEL\r
 195         MOVEM   B,TTICHN+1(TVP) ;SAVE IT\r
 196         PUSH    TP,$TATOM       ;ASSIGN AS A GLOBAL VALUE\r
 197         PUSH    TP,IMQUOTE INCHAN\r
 198         PUSH    TP,A\r
 199         PUSH    TP,B\r
 200         MOVE    C,BUFRIN(B)     ;GET AUX BUFFER PTR\r
 201         MOVE    A,[PUSHJ P,MTYI]\r
 202         MOVEM   A,IOIN2(C)      ;MORE OF A WINNER\r
 203         MOVE    A,[PUSHJ P,MTYO]\r
 204         MOVEM   A,ECHO(C)       ;ECHO INS\r
 205         MCALL   2,SETG\r
 206 \r
 207 ;GENERATE AN INITIAL PROCESS AND SWAP IT IN\r
 208 \r
 209         PUSHJ   P,ICR   ;CREATE IT\r
 210         MOVEI   0,RUNING\r
 211         MOVEM   0,PSTAT"+1(B)\r
 212         MOVE    D,B     ;SET UP TO CALL SWAP\r
 213         JSP     C,SWAP  ;AND SWAP IN\r
 214         MOVEM   PVP,MAINPR"     ;SAVE AS THE MAIN PROCESS\r
 215         PUSH    TP,[TENTRY,,TOPLEV]     ;BUILD DUMMY FRAME\r
 216         PUSH    TP,[1,,0]\r
 217         MOVEI   A,-1(TP)\r
 218         PUSH    TP,A\r
 219         PUSH    TP,SP\r
 220         PUSH    TP,P\r
 221         MOVE    C,TP    ;COPY TP\r
 222         ADD     C,[3,,3]        ;FUDGE\r
 223         PUSH    TP,C    ;TPSAV PUSHED\r
 224         PUSH    TP,[TOPLEV]\r
 225         HRRI    TB,(TP) ;SETUP TB\r
 226         HRLI    TB,2\r
 227         ADD     TB,[1,,1]\r
 228         MOVEM   TB,TBINIT+1(PVP)\r
 229         MOVSI   A,TSUBR\r
 230         MOVEM   A,RESFUN(PVP)\r
 231         MOVEI   A,LISTEN"\r
 232         MOVEM   A,RESFUN+1(PVP)\r
 233         PUSH    TP,$TATOM\r
 234         PUSH    TP,IMQUOTE THIS-PROCESS\r
 235         PUSH    TP,$TPVP\r
 236         PUSH    TP,PVP\r
 237         MCALL   2,SETG\r
 238 \r
 239 ; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE\r
 240 \r
 241         MOVEI   A,MQUOTE T\r
 242         SUBI    A,(TVP)\r
 243 TVTOFF==0\r
 244         ADDSQU  TVTOFF\r
 245 \r
 246         MOVEM   A,SQULOC-1\r
 247 \r
 248         PUSH    TP,$TATOM\r
 249         PUSH    TP,IMQUOTE TVTOFF,,MUDDLE\r
 250         PUSH    TP,$TFIX\r
 251         PUSH    TP,A\r
 252         MCALL   2,SETG\r
 253 \r
 254 ; HERE TO SETUP SQUOZE TABLE IN PURE CORE\r
 255 \r
 256         PUSHJ   P,SQSETU        ; GO TO ROUTINE\r
 257 \r
 258         MOVEI   A,400000        ; FENCE POST PURE SR VECTOR\r
 259         HRRM    A,PURVEC(TVP)\r
 260         MOVE    A,TP\r
 261         HLRE    B,A\r
 262         SUBI    A,-PDLBUF(B)    ;POINT TO DOPE WORDS\r
 263         MOVEI   B,12    ;GROWTH SPEC\r
 264         IORM    B,(A)\r
 265         MOVEI   0,ISTOST\r
 266         MOVEM   0,CODTOP\r
 267         PUSHJ   P,AAGC  ;DO IT\r
 268         AOJL    A,.-1\r
 269         MOVE    A,TPBASE+1(PVP)\r
 270         SUB     A,[640.,,640.]\r
 271         MOVEM   A,TPBASE+1(PVP)\r
 272 \r
 273 ; CREATE LIST OF ROOT AND NEW OBLIST\r
 274 \r
 275         MOVEI   A,5\r
 276         PUSH    P,A\r
 277 \r
 278 NAMOBL: PUSH    TP,$TATOM\r
 279         PUSH    TP,@OBNAM-1(A)  ; NAME\r
 280         PUSH    TP,$TATOM\r
 281         PUSH    TP,IMQUOTE OBLIST\r
 282         PUSH    TP,$TOBLS\r
 283         PUSH    TP,@OBTBL-1(A)\r
 284         MCALL   3,PUT           ; NAME IT\r
 285         SOS     A,(P)\r
 286         PUSH    TP,$TOBLS\r
 287         PUSH    TP,@OBTBL(A)\r
 288         PUSH    TP,$TATOM\r
 289         PUSH    TP,IMQUOTE OBLIST\r
 290         PUSH    TP,$TATOM\r
 291         PUSH    TP,@OBNAM(A)\r
 292         MCALL   3,PUT\r
 293         SKIPE   A,(P)\r
 294         JRST    NAMOBL\r
 295         SUB     P,[1,,1]\r
 296 \r
 297 ;Define MUDDLE version number\r
 298         MOVEI   A,5\r
 299         MOVEI   B,0             ;Initialize result\r
 300         MOVE    C,[440700,,MUDSTR+2]\r
 301 VERLP:  ILDB    D,C             ;Get next charcter digit\r
 302         CAIG    D,"9            ;Non-digit ?\r
 303         CAIGE   D,"0\r
 304         JRST    VERDEF\r
 305         SUBI    D,"0            ;Convert to number\r
 306         IMULI   B,10.\r
 307         ADD     B,D             ;Include number into result\r
 308         SOJG    A,VERLP         ;Finished ?\r
 309 VERDEF:\r
 310         PUSH    TP,$TATOM\r
 311         PUSH    TP,MQUOTE MUDDLE\r
 312         PUSH    TP,$TFIX\r
 313         PUSH    TP,B\r
 314         MCALL   2,SETG          ;Make definition\r
 315 OPIPC:\r
 316 IFN ITS,[\r
 317         PUSH    TP,$TCHSTR\r
 318         PUSH    TP,CHQUOTE IPC\r
 319         PUSH    TP,$TATOM\r
 320         PUSH    TP,MQUOTE IPC-HANDLER\r
 321         MCALL   1,GVAL\r
 322         PUSH    TP,A\r
 323         PUSH    TP,B\r
 324         PUSH    TP,$TFIX\r
 325         PUSH    TP,[1]\r
 326         MCALL   3,ON\r
 327         MCALL   0,IPCON\r
 328 ]\r
 329 \r
 330 ; Allocate inital template tables\r
 331 \r
 332         MOVEI   A,10\r
 333         PUSHJ   P,CAFRE1\r
 334         ADD     B,[10,,10]              ; REST IT OFF\r
 335         MOVEM   B,TD.LNT+1(TVP)\r
 336         MOVEI   A,10\r
 337         PUSHJ   P,CAFRE1\r
 338         MOVEI   0,TUVEC         ; SETUP UTYPE\r
 339         HRLM    0,10(B)\r
 340         MOVEM   B,TD.GET+1(TVP)\r
 341         MOVEI   A,10\r
 342         PUSHJ   P,CAFRE1\r
 343         MOVEI   0,TUVEC         ; SETUP UTYPE\r
 344         HRLM    0,10(B)\r
 345         MOVEM   B,TD.PUT+1(TVP)\r
 346 \r
 347 PTSTRT: MOVEI   A,SETUP\r
 348         ADDI    A,1\r
 349         SUB     A,PARBOT        ;FIND WHERE PAIRS SHOULD GO\r
 350         MOVEM   A,PARNEW\r
 351 IFE ITS,[\r
 352         MOVEI   A,400000\r
 353         MOVE    B,[1,,START]\r
 354         SEVEC\r
 355 ]\r
 356         PUSH    P,[14.,,14.]    ;PUSH A SMALL PRGRM ONTO P\r
 357         MOVEI   A,1(P)  ;POINT TO ITS START\r
 358         PUSH    P,[JRST AAGC]   ;GO TO AGC\r
 359         PUSH    P,[MOVE B,PSTO+1(PVP)]  ;GET SAVED P\r
 360         PUSH    P,[SUB B,-13.(P)]       ;FUDGE TO POP OFF PROGRAM\r
 361         PUSH    P,[MOVEM B,PSAV(TB)]    ;INTO FRAME\r
 362         PUSH    P,[MOVE B,TPSTO+1(PVP)] ;GET TP\r
 363         PUSH    P,[MOVEM B,TPSAV(TB)]   ;STORE IT\r
 364         PUSH    P,[MOVE B,SPSTO+1(PVP)] ;SP\r
 365         PUSH    P,[MOVEM B,SPSAV(TB)]\r
 366         PUSH    P,[MOVEI B,TOPLEV]      ;WHERE TO GO\r
 367         PUSH    P,[MOVEM B,PCSAV(TB)]\r
 368 IFN ITS,        PUSH    P,[MOVSI B,(.VALUE )]\r
 369 IFE ITS,        PUSH    P,[MOVSI B,(JRST 4,)]\r
 370         PUSH    P,[HRRI B,C]\r
 371         PUSH    P,[JRST B]      ;GO DO VALRET\r
 372         PUSH    P,[B]\r
 373         PUSH    P,A             ; PUSH START ADDR\r
 374         MOVE    B,[JRST -11.(P)]\r
 375         MOVE    0,[JUMPA START]\r
 376         MOVE    C,[ASCII \\170/\e9\]\r
 377         MOVE    D,[ASCII \B/\e1Q\]\r
 378         MOVE    E,[ASCIZ \\r
 379 \16*\r
 380 \]              ;TERMINATE\r
 381         POPJ    P,              ; GO\r
 382 \f\r
 383 ; CHECK PAIR SPACE\r
 384 \r
 385 PAIRCH: CAMG    A,B\r
 386         JRST    SETTV           ;O.K.\r
 387 \r
 388 DEATH1: MOVEI   B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP\r
 389 /]\r
 390         PUSHJ   P,MSGTYP\r
 391         .VALUE\r
 392 \r
 393 ;CHARACTER STRING HACKER\r
 394 \r
 395 CHACK:  MOVE    A,(C)           ;GET TYPE\r
 396         HLLZM   A,(D)           ;STORE IN NEW HOME\r
 397         MOVE    B,1(C)          ;GET POINTER\r
 398         HLRZ    E,B             ;-LENGHT\r
 399         HRRM    E,(D)\r
 400         PUSH    P,E+1           ; IDIVI WILL CLOBBER\r
 401         ADDI    E,4+5*2         ; ROUND AND ACCOUNT FOR DOPE WORDS\r
 402         IDIVI   E,5             ; E/ WORDS LONG\r
 403         PUSHJ   P,EBPUR         ; MAKE A PURIFIED COPY\r
 404         POP     P,E+1\r
 405         HRLI    B,440700        ;MAKE POINT BYTER\r
 406         MOVEM   B,1(D)          ;AND STORE IT\r
 407         ANDI    A,-1    ;CLEAR LH OF A\r
 408         JUMPE   A,SETLP ;JUMP IF NO REF\r
 409         MOVE    E,(P)           ;GET OFFSET\r
 410         LSH     E,1\r
 411         HRRZ    B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR\r
 412         CAIE    B,$TCHSTR       ;SKIP IF IT DOES\r
 413         JRST    CHACK1  ;NO, JUST DO CHQUOTE PART\r
 414         HRRM    E,-1(A) ;CLOBBER\r
 415         MOVEI   B,TVP\r
 416         DPB     B,[220400,,-1(A)]       ;CLOBBER INDEX FIELD\r
 417 CHACK1: ADDI    E,1\r
 418         HRRM    E,(A)           ;STORE INTO REFERENCE\r
 419         JRST    SETLP\r
 420 \r
 421 ; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT\r
 422 \r
 423 EBPUR:  PUSH    P,E\r
 424         PUSH    P,A\r
 425         ADD     E,HITOP         ; GET NEW TOP\r
 426         CAMG    E,RHITOP        ; SKIP IF TOO BIG\r
 427         JRST    EBPUR1\r
 428 \r
 429 ;  CODE TO GROW HI SEG \r
 430 \r
 431         MOVEI   A,2000\r
 432         ADDB    A,RHITOP        ; NEW TOP\r
 433 IFN ITS,[\r
 434         ASH     A,-10.          ; NUM OF BLOCKS\r
 435         SUBI    A,1             ; BLOCK TO GET\r
 436         .CALL   HIGET\r
 437         .VALUE\r
 438 ]\r
 439 \r
 440 EBPUR1: MOVEI   A,-1(E)         ; NEEDED TO TERMINATE BLT\r
 441         EXCH    E,HITOP\r
 442         HRLI    E,(B)\r
 443         MOVEI   B,(E)\r
 444         BLT     E,(A)\r
 445         POP     P,A\r
 446         POP     P,E\r
 447         POPJ    P,\r
 448 \r
 449 GIVCOR: SETZ\r
 450         SIXBIT /CORBLK/\r
 451         1000,,0\r
 452         1000,,-1\r
 453         SETZ    A\r
 454 \r
 455 HIGET:  SETZ\r
 456         SIXBIT /CORBLK/\r
 457         1000,,100000\r
 458         1000,,-1\r
 459         A\r
 460         401000,,400001\r
 461 \r
 462 \f\r
 463 ; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T\r
 464 ; ALREADY THERE\r
 465 \r
 466 ATOMHK: PUSH    TP,$TOBLS       ; SAVE OBLIST\r
 467         PUSH    TP,[0]          ; FILLED IN LATER\r
 468         PUSH    TP,$TVEC        ;SAVE TV POINTERS\r
 469         PUSH    TP,C\r
 470         PUSH    TP,$TVEC\r
 471         PUSH    TP,D\r
 472         MOVE    B,1(C)          ;GET THE ATOM\r
 473         PUSH    TP,$TATOM       ;AND SAVE\r
 474         PUSH    TP,B\r
 475         HRRZ    A,(B)           ;GET OBLIST SPEC FROM ATOM\r
 476         LSH     A,1\r
 477         ADDI    A,1(TB)         ;POINT TO ITS HOME\r
 478         PUSH    TP,$TOBLS\r
 479         PUSH    TP,(A)          ;AND SAV IT\r
 480         MOVE    A,(A)\r
 481         MOVEM   A,-10(TP)       ; CLOBBER\r
 482         HLRE    E,A\r
 483         MOVNS   E\r
 484 \r
 485         ADD     B,[3,,3]        ;POINT TO ATOM'S PNAME\r
 486         MOVEI   A,0             ;FOR HASHING\r
 487         XOR     A,(B)\r
 488         AOBJN   B,.-1\r
 489         TLZ     A,400000        ;FORCE POSITIVE RESULT\r
 490         IDIV    A,E\r
 491         HRLS    B               ;REMAINDER IN B IS BUCKET\r
 492         ADDB    B,(TP)          ;UPDATE POINTER\r
 493 \r
 494         SKIPN   C,(B)           ;GOBBLE BUCKET CONTENTS\r
 495         JRST    USEATM          ;NONE, LEAVE AND USE THIS ATOM\r
 496 OBLOO3: MOVE    E,-2(TP)        ;RE-GOBBLE ATOM\r
 497         ADD     E,[3,,3]        ;POINT TO PNAME\r
 498         SKIPN   D,1(C)          ;CHECK LIST ELEMNT\r
 499         JRST    NXTBCK          ;0, CHECK NEXT IN THIS BUCKET\r
 500         ADD     D,[3,,3]        ;POINT TO PNAME\r
 501 OBLOO2: MOVE    A,(D)           ;GET A WORD\r
 502         CAME    A,(E)           ;COMPARE\r
 503         JRST    NXTBCK          ;THEY DIFFER, TRY NEX\r
 504 OBLOOP: AOBJP   E,CHCKD         ;COULD BE A MATCH, GO CHECK\r
 505         AOBJN   D,OBLOO2        ;HAVEN'T LOST YET\r
 506 \r
 507 NXTBCK: HRRZ    C,(C)           ;CDR THE LIST\r
 508         JUMPN   C,OBLOO3        ;IF NOT NIL, KEEP TRYING\r
 509 \r
 510 ;HERE IF THIS ATOM MUST BE PUT ON OBLIST\r
 511 \r
 512 USEATM: MOVE    B,-2(TP)                ; GET ATOM\r
 513         HLRZ    0,(B)           ; SEE IF PURE OR NOT\r
 514         TRNN    0,400000        ; SKIP IF IMPURE\r
 515         JRST    PURATM\r
 516         MOVE    B,(TP)          ;POINTER TO BUCKET\r
 517         HRRZ    C,(B)           ;POINTER TO LIST IN THIS BUCKET\r
 518         PUSH    TP,$TATOM       ;GENERATE CALL TO CONS\r
 519         PUSH    TP,-3(TP)\r
 520         PUSH    TP,$TLIST\r
 521         PUSH    TP,C\r
 522         MCALL   2,CONS          ;CONS IT UP\r
 523         MOVE    C,(TP)          ;REGOBBLE BUCKET POINTER\r
 524         HRRZM   B,(C)           ;CLOBBER\r
 525         MOVE    B,-2(TP)        ;POINT TO ATOM\r
 526         MOVE    C,-10(TP)               ; GET OBLIST\r
 527         MOVEM   C,2(B)          ; INTO ATOM\r
 528         PUSHJ   P,VALMAK        ;MAKE A GLOBAL VALUE FOR THIS LOSER\r
 529 PURAT2: MOVE    C,-6(TP)        ;RESET POINTERS\r
 530         MOVE    D,-4(TP)\r
 531         SUB     TP,[12,,12]\r
 532         MOVE    B,(C)           ;MOVE THE ENTRY\r
 533         HLLZM   B,(D)           ;DON'T WANT REF POINTER STORED\r
 534         MOVE    A,1(C)          ;AND MOVE ATOM\r
 535         MOVEM   A,1(D)\r
 536         MOVE    A,(P)           ;GET CURRENT OFFSET\r
 537         LSH     A,1\r
 538         ADDI    A,1\r
 539         ANDI    B,-1            ;CHECK FOR REAL REF\r
 540         JUMPE   B,SETLP1        ;DON'T SAVE THIS ATOM ON TVP\r
 541         HRRM    A,(B)           ;CLOBBER CODE\r
 542         JRST    SETLP\r
 543 \r
 544 \r
 545 ; HERE TO MAKE A PURE ATOM\r
 546 \r
 547 PURATM: HRRZ    B,-2(TP)        ; POINT TO IT\r
 548         HLRE    E,-2(TP)        ; - LNTH\r
 549         MOVNS   E\r
 550         ADDI    E,2\r
 551         PUSHJ   P,EBPUR         ; PURE COPY\r
 552         HRRM    B,-2(TP)        ; AND STORE BACK\r
 553         HRRO    B,(TP)          ; GET BUCKET BACK\r
 554 PURAT1: HRRZ    C,(B)           ; GET CONTENTS\r
 555         JUMPE   C,HICONS        ; AT END, OK\r
 556         CAIL    C,HIBOT         ; SKIP IF IMPURE\r
 557         JRST    HICONS  ; CONS IT ON\r
 558         MOVEI   B,(C)\r
 559         JRST    PURAT1\r
 560 \r
 561 HICONS: HRLI    C,TATOM\r
 562         PUSH    P,C\r
 563         PUSH    P,-2(TP)\r
 564         PUSH    P,B\r
 565         MOVEI   B,-2(P)\r
 566         MOVEI   E,2\r
 567         PUSHJ   P,EBPUR         ; MAKE PURE LIST CELL\r
 568 \r
 569         MOVE    C,(P)\r
 570         SUB     P,[3,,3]\r
 571         HRRM    B,(C)           ; STORE IT\r
 572         MOVE    B,1(B)          ; ATOM BACK\r
 573         MOVE    C,-6(TP)        ; GET TVP SLOT\r
 574         HRRM    B,1(C)          ; AND STORE\r
 575         HLRZ    0,(B)           ; TYPE OF VAL\r
 576         MOVE    C,B\r
 577         CAIN    0,TUNBOU        ; NOT UNBOUND?\r
 578         JRST    PURAT3          ; UNBOUND, NO VAL\r
 579         MOVEI   E,2             ; COUNT AGAIN\r
 580         PUSHJ   P,EBPUR         ; VALUE CELL\r
 581         MOVE    C,-2(TP)                ; ATOM BACK\r
 582         HLLZS   (B)             ; CLEAR LH\r
 583         MOVSI   0,TLOCI\r
 584         HLLM    0,(C)\r
 585         MOVEM   B,1(C)\r
 586 PURAT3: HRRZ    A,(C)           ; GET OBLIST CODE\r
 587         MOVE    A,OBTBL2(A)\r
 588         MOVEM   A,2(C)          ; STORE OBLIST SLOT\r
 589         HLLZS   (C)\r
 590         JRST    PURAT2\r
 591 \f\r
 592 ; A POSSIBLE MATCH ARRIVES HERE\r
 593 \r
 594 CHCKD:  AOBJN   D,NXTBCK        ;SIZES DIFFER, JUMP\r
 595         MOVE    D,1(C)          ;THEY MATCH!,  GET EXISTING ATOM\r
 596         MOVEI   A,(D)           ;GET TYPE OF IT\r
 597         MOVE    B,-2(TP)        ;GET NEW ATOM\r
 598         HLRZ    0,(B)\r
 599         TRZ     A,377777        ; SAVE ONLY 400000 BIT\r
 600         TRZ     0,377777\r
 601         CAIN    0,(A)           ; SKIP IF WIN\r
 602         JRST    IM.PUR\r
 603         MOVSI   0,400000\r
 604         ANDCAM  0,(B)\r
 605         ANDCAM  0,(D)\r
 606         HLRZ    A,(D)\r
 607         CAIE    A,TUNBOU        ;UNBOUND?\r
 608         JRST    A1VAL           ;YES, CONTINUE\r
 609         MOVE    A,(B)           ;MOVE VALUE\r
 610         MOVEM   A,(D)\r
 611         MOVE    A,1(B)\r
 612         MOVEM   A,1(D)\r
 613         MOVE    B,D             ;EXISTING ATOM TO B\r
 614         MOVEI   0,(B)\r
 615         CAIL    0,HIBOT\r
 616         JRST    .+3\r
 617         PUSHJ   P,VALMAK        ;MAKE A VALUE\r
 618         JRST    .+2\r
 619         PUSHJ   P,PVALM\r
 620 \r
 621 ;NOW FIND ATOMS OCCURENCE IN XFER VECTOR\r
 622 \r
 623 OFFIND: MOVE    D,-4(TP)        ;GET CURRENT POINTER INTO TP\r
 624         MOVE    C,TVP           ;AND A COPY OF TVP\r
 625         MOVEI   A,0             ;INITIALIZE COUNTER\r
 626 ALOOP:  CAMN    B,1(C)          ;IS THIS IT?\r
 627         JRST    AFOUND\r
 628         ADD     C,[2,,2]        ;BUMP COUNTER\r
 629         CAMGE   C,D             ;HAVE WE HIT END\r
 630         AOJA    A,ALOOP         ;NO, KEEP LOOKING\r
 631 \r
 632         MOVEI   B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED\r
 633 /]\r
 634 TYPIT:  PUSHJ   P,MSGTYP\r
 635         .VALUE\r
 636 \r
 637 AFOUND: LSH     A,1             ;FOUND ATOM, GET REAL OFFSET\r
 638         ADDI    A,1\r
 639         MOVE    C,-6(TP)        ;GET TV POINTER TO NEW ATOM\r
 640         HRRZ    B,(C)           ;POINT TO REFERENCE\r
 641         SKIPE   B               ;ANY THERE?\r
 642         HRRM    A,(B)           ;YES, CLOBBER AWAY\r
 643         SUB     TP,[12,,12]\r
 644         JRST    SETLP1          ;AND GO ON\r
 645 \r
 646 A1VAL:  HLRZ    C,(B)           ;GET VALUE'S TYPE\r
 647         MOVE    B,D             ;NOW PUT EXISTING ATOM IN B\r
 648         CAIN    C,TUNBOU        ;UNBOUND?\r
 649         JRST    OFFIND          ;YES, WINNER\r
 650 \r
 651         MOVEI   B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES\r
 652 /]\r
 653         JRST    TYPIT\r
 654 \r
 655 \r
 656 IM.PUR: MOVEI   B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE\r
 657 /]\r
 658         JRST    TYPIT\r
 659 \r
 660 PAGLOS: MOVEI   B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT\r
 661 /]\r
 662         JRST    TYPIT\r
 663 \f\r
 664 ;MAKE A VALUE IN SLOT ON GLOBAL SP\r
 665 \r
 666 VALMAK: HLRZ    A,(B)           ;TYPE OF VALUE\r
 667         CAIE    A,400000+TUNBOU\r
 668         CAIN    A,TUNBOU        ;VALUE?\r
 669         POPJ    P,              ;NO, ALL DONE\r
 670         MOVE    A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP\r
 671         SUB     A,[4,,4]        ;ALLOCATE SPACE\r
 672         CAMG    A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW\r
 673         JRST    SPOVFL\r
 674         MOVEM   A,GLOBSP+1(TVP) ;STORE IT BACK\r
 675         MOVE    C,(B)           ;GET TYPE CELL\r
 676         TLZ     C,400000\r
 677         HLLZM   C,2(A)          ;INTO TYPE CELL\r
 678         MOVE    C,1(B)          ;GET VALUE\r
 679         MOVEM   C,3(A)          ;INTO VALUE SLOT\r
 680         MOVSI   C,TGATOM        ;GET TATOM,,0\r
 681         MOVEM   C,(A)\r
 682         MOVEM   B,1(A)          ;AND POINTER TO ATOM\r
 683         MOVSI   C,TLOCI         ;NOW CLOBBER THE ATOM\r
 684         MOVEM   C,(B)           ;INTO TYPE CELL\r
 685         ADD     A,[2,,2]        ;POINT TO VALUE\r
 686         MOVEM   A,1(B)\r
 687         POPJ    P,\r
 688 \r
 689 SPOVFL: MOVEI   B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW\r
 690 /]\r
 691         JRST    TYPIT\r
 692 \r
 693 \r
 694 PVALM:  HLRZ    0,(B)\r
 695         CAIE    0,400000+TUNBOU\r
 696         CAIN    0,TUNBOU\r
 697         POPJ    P,\r
 698         MOVEI   E,2\r
 699         PUSH    P,B\r
 700         PUSHJ   P,EBPUR\r
 701         POP     P,C\r
 702         MOVEM   B,1(C)\r
 703         MOVSI   0,TLOCI\r
 704         MOVEM   0,(C)\r
 705         MOVE    B,C\r
 706         POPJ    P,\r
 707 \f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER\r
 708 \r
 709 VECTGO DUMMY1\r
 710 \r
 711 IRP     A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1\r
 712 ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER\r
 713 IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR\r
 714 MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS\r
 715 CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ\r
 716 CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN\r
 717 CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG\r
 718 CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR\r
 719 OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY\r
 720 CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO\r
 721 CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT\r
 722 CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C\r
 723 CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL\r
 724 CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC\r
 725 CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1\r
 726 CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS]\r
 727         .GLOBAL A\r
 728         ADDSQU A\r
 729         MAKAT [A]TFIX,A,MUDDLE,0\r
 730 TERMIN\r
 731 \r
 732 VECRET\r
 733 \r
 734 ; ROUTINE TO SORT AND PURIFY SQUOZE TABLE\r
 735 \r
 736 SQSETU: MOVE    A,[SQUTBL-SQULOC+2,,SQUTBL]\r
 737         MOVEI   0,1\r
 738 SQ2:    MOVE    B,(A)\r
 739         CAMG    B,2(A)\r
 740         JRST    SQ1\r
 741         MOVEI   0,0\r
 742         EXCH    B,2(A)\r
 743         MOVEM   B,(A)\r
 744         MOVE    B,1(A)\r
 745         EXCH    B,3(A)\r
 746         MOVEM   B,1(A)\r
 747 SQ1:    ADD     A,[2,,2]\r
 748         JUMPL   A,SQ2\r
 749         JUMPE   0,SQSETU\r
 750         MOVEI   E,SQULOC-SQUTBL\r
 751         MOVEI   B,SQUTBL\r
 752         PUSHJ   P,EBPUR         ; TO THE PURE WORLD\r
 753         HRLI    B,SQUTBL-SQULOC\r
 754         MOVEM   B,SQUPNT"\r
 755         POPJ    P,\r
 756         \r
 757 RHITOP: 0\r
 758 \r
 759 OBSZ:   151.\r
 760         151.\r
 761         151.\r
 762         151.\r
 763         317.\r
 764 \r
 765 OBTBL2: ROOT+1\r
 766         ERROBL+1\r
 767         INTOBL+1\r
 768         MUDOBL+1\r
 769         INITIAL+1\r
 770 \r
 771 OBTBL:  INITIAL+1(TVP)\r
 772         MUDOBL+1(TVP)\r
 773         INTOBL+1(TVP)\r
 774         ERROBL+1(TVP)\r
 775         ROOT+1(TVP)\r
 776 OBNAM:  MQUOTE INITIAL\r
 777         MQUOTE MUDDLE\r
 778         MQUOTE INTERRUPTS\r
 779         MQUOTE ERRORS\r
 780         MQUOTE ROOT\r
 781 \r
 782 END SETUP\r
 783 \r
 784 \r
 785 \f\f\f\r