sumex/primit.mcr169

   1 TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM\r
   2 \r
   3 RELOCATABLE\r
   4 \r
   5 .INSRT MUDDLE >\r
   6 \r
   7 .GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP\r
   8 .GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP\r
   9 .GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0\r
  10 .GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM\r
  11 .GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST\r
  12 .GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK\r
  13 .GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY\r
  14 .GLOBAL TMPLNT,ISTRCM\r
  15 \r
  16 ; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE\r
  17 \r
  18 PRMTYP:\r
  19 \r
  20 REPEAT NUMSAT,[0]                       ;INITIALIZE TABLE TO ZEROES\r
  21 \r
  22 IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]\r
  23 \r
  24 LOC PRMTYP+S!A\r
  25 P!A==.IRPCN+1\r
  26 P!A\r
  27 \r
  28 TERMIN\r
  29 \r
  30 PTMPLT==PBYTE+1\r
  31 \r
  32 ; FUDGE FOR STRUCTURE LOCATIVES\r
  33 \r
  34 IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]\r
  35 [LOCT,TMPLT]]\r
  36         IRP B,C,[A]\r
  37         LOC PRMTYP+S!B\r
  38         P!B==P!C,,0\r
  39         P!B\r
  40         .ISTOP\r
  41         TERMIN\r
  42 TERMIN\r
  43 \r
  44 LOC PRMTYP+SSTORE       ;SPECIAL HACK FOR AFREE STORAGE\r
  45 PNWORD\r
  46 \r
  47 LOC PRMTYP+NUMSAT+1\r
  48 \r
  49 PNUM==PTMPLT+1\r
  50 \r
  51 ; MACRO TO BUILD PRIMITIVE DISPATCH TABLES\r
  52 \r
  53 DEFINE PRDISP NAME,DEFAULT,LIST\r
  54         TBLDIS NAME,DEFAULT,[LIST]PNUM\r
  55         TERMIN\r
  56 \r
  57 \r
  58 ; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL\r
  59 \r
  60 PTYPE:  GETYP   A,(B)   ;CALLE D WITH B POINTING TO PAIR\r
  61         CAIN    A,TILLEG        ;LOSE IF ILLEGAL\r
  62         JRST    ILLCHOS\r
  63 \r
  64         PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE\r
  65         CAIE    A,SLOCA\r
  66         CAIN    A,SARGS         ;SPECIAL HAIR FOR ARGS\r
  67         PUSHJ   P,CHARGS\r
  68         CAIN    A,SFRAME\r
  69         PUSHJ   P,CHFRM\r
  70         CAIN    A,SLOCID\r
  71         PUSHJ   P,CHLOCI\r
  72 PTYP1:  MOVEI   0,(A)           ; ALSO RETURN PRIMTYPE\r
  73         CAILE   A,NUMSAT        ; SKIP IF NOT TEMPLATE\r
  74         SKIPA   A,[PTMPLT]\r
  75         MOVE    A,PRMTYP(A)     ;GET PRIM TYPE,\r
  76         POPJ    P,\r
  77 \r
  78 ; COMPILERS CALL TO ABOVE (LESS CHECKING)\r
  79 \r
  80 CPTYPE: PUSHJ   P,SAT\r
  81         MOVEI   0,(A)\r
  82         CAILE   A,NUMSAT\r
  83         SKIPA   A,[PTMPLT]\r
  84         MOVE    A,PRMTYP(A)\r
  85         POPJ    P,\r
  86 \r
  87 \r
  88 MFUNCTION SUBSTRUC,SUBR\r
  89 \r
  90         ENTRY\r
  91         JUMPGE  AB,TFA  ;need at least one arg\r
  92         CAMGE   AB,[-10,,0]     ;NO MORE THEN 4\r
  93         JRST    TMA\r
  94         MOVE    B,AB\r
  95         PUSHJ   P,PTYPE ;get primtype in A\r
  96         PUSH    P,A\r
  97         JRST    @TYTBL(A)\r
  98 \r
  99 RESSUB: CAMLE   AB,[-2,,0]      ;if only one arg skip rest\r
 100         JRST    @COPYTB(A)\r
 101         HLRZ    B,(AB)2 ;GET TYPE\r
 102         CAIE    B,TFIX  ;IF FIX OK\r
 103         JRST    WRONGT\r
 104         MOVE    B,(AB)1 ;ptr to object of resting\r
 105         MOVE    C,(AB)3 ;# of times to rest\r
 106         MOVEI   E,(A)\r
 107         MOVE    A,(AB)\r
 108         PUSHJ   P,@MRSTBL(E)\r
 109         PUSH    TP,A    ;type\r
 110         PUSH    TP,B    ;put rested sturc on stack\r
 111         JRST    ALOCOK\r
 112 \r
 113 PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB]\r
 114 [PNWORD,RESSUB],[PCHSTR,RESSUB]]\r
 115 \r
 116 PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST]\r
 117 [PNWORD,UREST],[PCHSTR,SREST]]\r
 118 \r
 119 PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC]\r
 120 [PNWORD,CPYUVC],[PCHSTR,CPYSTR]]\r
 121 \r
 122 PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC]\r
 123 [PNWORD,ALUVEC],[PCHSTR,ALSTR]]\r
 124 \r
 125 ALOCFX: MOVE    B,(TP)  ;missing 3rd arg aloc for "rest" of struc\r
 126         MOVE    C,-1(TP)\r
 127         MOVE    A,(P)\r
 128         PUSH    P,[377777,,-1]\r
 129         PUSHJ   P,@LENTBL(A) ;get length of rested struc\r
 130         SUB     P,[1,,1]\r
 131         POP     P,C\r
 132         MOVE    A,B     ;# of elements needed\r
 133         JRST    @ALOCTB(C)\r
 134 \r
 135 ALOCOK: CAML    AB,[-4,,0]  ;exactly 3 args\r
 136         JRST    ALOCFX\r
 137         HLRZ    C,(AB)4\r
 138         CAIE    C,TFIX  ;OK IF TYPE FIX\r
 139         JRST    WRONGT\r
 140         POP     P,C     ;C HAS PRIMTYYPE\r
 141         MOVE    A,(AB)5 ;# of elements needed\r
 142         JRST    @ALOCTB(C)      ;DO ALLOCATION\r
 143 \r
 144 \r
 145 CPYVEC: HLRE    A,(AB)1 ;USE WHEN ONLY ONE ARG\r
 146         MOVNS   A\r
 147         ASH     A,-1    ;# OF ELEMENTS FOR ALLOCATION\r
 148         PUSH    TP,(AB)\r
 149         PUSH    TP,(AB)1\r
 150 \r
 151 ALVEC:  PUSH    P,A     \r
 152         ASH     A,1\r
 153         HRLI    A,(A)\r
 154         ADD     A,(TP)\r
 155         CAIL    A,-1    ;CHK FOR OUT OF RANGE\r
 156         JRST    OUTRNG\r
 157         CAMGE   AB,[-6,,]       ; SKIP IF WE GET VECTOR\r
 158         JRST    ALVEC2          ; USER SUPPLIED VECTOR\r
 159         MOVE    A,(P)\r
 160         PUSHJ   P,IBLOK1\r
 161 ALVEC1: MOVE    A,(P)   ;# OF WORDS TO ALLOCATE\r
 162         MOVE    C,B             ; SAVE VECTOR POINTER\r
 163         ASH     A,1     ;TIMES 2\r
 164         HRLI    A,(A)\r
 165         ADD     A,B     ;PTING TO FIRST DOPE WORD -ALLOCATED \r
 166         CAIL    A,-1\r
 167         JRST    OUTRNG\r
 168         SUBI    A,1     ;ptr to last element of the block\r
 169         HRL     B,(TP)  ;bleft-ptr to source ,  b right -ptr to allocated space\r
 170         BLT     B,(A)\r
 171         MOVE    B,C\r
 172         POP     P,A\r
 173         SUB     TP,[2,,2]\r
 174         MOVSI   A,TVEC\r
 175         JRST    FINIS\r
 176 \r
 177 ALVEC2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
 178         CAIE    0,TVEC\r
 179         JRST    WTYP\r
 180         HLRE    A,7(AB)         ; CHECK SIZE\r
 181         MOVNS   A\r
 182         ASH     A,-1            ; # OF ELEMENTS\r
 183         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
 184         JRST    OUTRNG\r
 185         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
 186         JRST    ALVEC1\r
 187 \r
 188 CPYUVC: HLRE    A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION\r
 189         MOVNS   A\r
 190         PUSH    TP,(AB)\r
 191         PUSH    TP,1(AB)\r
 192 \r
 193 ALUVEC: PUSH    P,A\r
 194         HRLI    A,(A)\r
 195         ADD     A,(TP)  ;PTING TO DOPE WORD OF ORIG VEC\r
 196         CAIL    A,-1\r
 197         JRST    OUTRNG\r
 198         CAMGE   AB,[-6,,]       ; SKIP IF WE SUPPLY UVECTOR\r
 199         JRST    ALUVE2\r
 200         MOVE    A,(P)\r
 201         PUSHJ   P,IBLOCK\r
 202 ALUVE1: MOVE    A,(P)   ;# of owrds to allocate\r
 203         HRLI    A,(A)\r
 204         ADD     A,B     ;LOCATION O FIRST ALLOCATED DOPE WORD\r
 205         HLR     D,(AB)1 ;# OF ELEMENTS IN UVECTOR\r
 206         MOVNS   D\r
 207         ADD     D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE\r
 208         GETYP   E,(D)   ;GET UTYPE\r
 209         CAML    AB,[-6,,]       ; SKIP IF USER SUPPLIED OUTPUT UVECTOR\r
 210         HRLM    E,(A)   ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC\r
 211         CAMGE   AB,[-6,,]\r
 212         CAIN    0,(E)           ; 0 HAS USER UVEC UTYPE\r
 213         JRST    .+2\r
 214         JRST    WRNGUT\r
 215         CAIL    A,-1\r
 216         JRST    OUTRNG\r
 217         MOVE    C,B             ; SAVE POINTER TO FINAL GUY\r
 218         HRL     C,(TP)  ;Bleft- ptr to source, Bright-ptr to allocated space\r
 219         BLT     C,-1(A)\r
 220         POP     P,A\r
 221         MOVSI   A,TUVEC\r
 222         JRST    FINIS\r
 223 \r
 224 ALUVE2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
 225         CAIE    0,TUVEC\r
 226         JRST    WTYP\r
 227         HLRE    A,7(AB)         ; CHECK SIZE\r
 228         MOVNS   A\r
 229         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
 230         JRST    OUTRNG\r
 231         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
 232         HLRE    A,B\r
 233         SUBM    B,A\r
 234         GETYP   0,(A)           ; GET UTYPE OF USER UVECTOR\r
 235         JRST    ALUVE1\r
 236 \r
 237 CPYSTR: HRR     A,(AB)  ;#OF CHAR TO COPY\r
 238         PUSH    TP,(AB) ;ALSTR EXPECTS STRING IN TP\r
 239         PUSH    TP,1(AB)\r
 240 \r
 241 ALSTR:  PUSH    P,A\r
 242         HRRZ    0,-1(TP)        ;0 IS LENGTH OFF VECTOR\r
 243         CAIGE   0,(A)\r
 244         JRST    OUTRNG\r
 245         CAMGE   AB,[-6,,]       ; SKIP IF WE SUPPLY STRING\r
 246         JRST    ALSTR2\r
 247         ADDI    A,4\r
 248         IDIVI   A,5\r
 249         PUSHJ   P,IBLOCK ;ALLOCATE SPACE\r
 250         HRLI    B,440700\r
 251         MOVE    A,(P)           ; # OF CHARS TO A\r
 252 ALSTR1: PUSH    P,B     ;BYTE PTR TO ALOC SPACE\r
 253         POP     TP,C ;PTR TO ORIGINAL STR\r
 254         POP     TP,D ;USELESS\r
 255 COPYST: ILDB    D,C ;GET NEW CHAR\r
 256         IDPB    D,B ;DEPOSIT CHAR\r
 257         SOJG    A,COPYST        ;FINISH TRANSFER?\r
 258 \r
 259 CLOSTR: POP     P,B ;BYTE PTR TO COPY\r
 260         POP     P,A ;# FO ELEMENTS\r
 261         HRLI    A,TCHSTR\r
 262         JRST    FINIS\r
 263 \r
 264 ALSTR2: GETYP   0,6(AB)         ; CHECK IT IS A VECTOR\r
 265         CAIE    0,TCHSTR\r
 266         JRST    WTYP\r
 267         HRRZ    A,6(AB)\r
 268         CAMGE   A,(P)           ; SKIP IF BIG ENOUGH\r
 269         JRST    OUTRNG\r
 270         EXCH    A,(P)\r
 271         MOVE    B,7(AB)         ; WINNER, JOIN COMMON CODE\r
 272         JRST    ALSTR1\r
 273 \r
 274 CPYLST: SKIPN   1(AB)\r
 275         JRST    ZEROLT\r
 276         PUSHJ   P,CELL2\r
 277         POP     P,C\r
 278         HRLI    C,TLIST ;TP JUNK FOR GAR. COLLECTOR\r
 279         PUSH    TP,C    ;TYPE\r
 280         PUSH    TP,B    ;VALUE -PTR TO NEW LIST\r
 281         PUSH    TP,C    ;TYPE\r
 282         MOVE    C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST\r
 283 REPLST: MOVE    D,(C)\r
 284         MOVE    E,1(C)  ;GET LIST ELEMENT INTO ALOC SPACE\r
 285         HLLM    D,(B)\r
 286         MOVEM   E,1(B)  ;PUT INTO ALLOCATED SPACE\r
 287         HRRZ    C,(C)   ;UPDATE PTR\r
 288         JUMPE   C,CLOSWL        ;END OF LIST?\r
 289         PUSH    TP,B\r
 290         PUSHJ   P,CELL2\r
 291         POP     TP,D\r
 292         HRRM    B,(D)   ;LINK ALLOCATED LIST CELLS\r
 293         JRST    REPLST\r
 294 \r
 295 CLOSWL: POP     TP,B    ;USELESS\r
 296         POP     TP,B    ;PTR TO NEW LIST\r
 297         POP     TP,A    ;TYPE\r
 298         JRST    FINIS\r
 299 \r
 300 \r
 301 \r
 302 ALLIST: CAMGE   AB,[-6,,]       ; SKIP IF WE BUILD THE LIST\r
 303         JRST    CPYLS2\r
 304         JUMPE   A,ZEROLT\r
 305         PUSH    P,A\r
 306         PUSHJ   P,CELL\r
 307         POP     P,A     ;# OF ELEMENTS\r
 308         PUSH    P,B     ;ptr to allocated list\r
 309         POP     TP,C    ;ptr to orig list\r
 310         JRST    ENTCOP\r
 311 \r
 312 COPYL:  ADDI    B,2\r
 313         HRRM    B,-2(B) ;LINK ALOCATED LIST CELLS\r
 314 ENTCOP: JUMPE   C,OUTRNG\r
 315         MOVE    D,(C)   \r
 316         MOVE    E,1(C)  ;get list element into D+E\r
 317         HLLM    D,(B)\r
 318         MOVEM   E,1(B)  ;put into allocated space\r
 319         HRRZ    C,(C)   ;update ptrs\r
 320         SOJG    A,COPYL ;finish transfer?\r
 321 \r
 322 CLOSEL: POP     P,B     ;PTR TO NEW LIST\r
 323         POP     TP,A    ;type\r
 324         JRST    FINIS\r
 325 \r
 326 ZEROLT: SUB     TP,[1,,1]       ;IF RESTED ALL OF LIST\r
 327         SUB     TP,[1,,1]\r
 328         MOVSI   A,TLIST\r
 329         MOVEI   B,0\r
 330         JRST    FINIS\r
 331 \r
 332 CPYLS2: GETYP   0,6(AB)\r
 333         CAIE    0,TLIST\r
 334         JRST    WTYP\r
 335         MOVE    B,7(AB)         ; GET DEST LIST\r
 336         MOVE    C,(TP)\r
 337 \r
 338         JUMPE   A,CPYLS3\r
 339 CPYLS4: JUMPE   B,OUTRNG\r
 340         JUMPE   C,OUTRNG\r
 341         MOVE    D,1(C)\r
 342         MOVEM   D,1(B)\r
 343         GETYP   0,(C)\r
 344         HRLM    0,(B)\r
 345         HRRZ    B,(B)\r
 346         HRRZ    C,(C)\r
 347         SOJG    A,CPYLS4\r
 348 \r
 349 CPYLS3: MOVE    B,7(AB)\r
 350         MOVSI   A,TLIST\r
 351         JRST    FINIS\r
 352 \r
 353 \r
 354 ; PROCESS TYPE ILLEGAL\r
 355 \r
 356 ILLCHO: HRRZ    B,1(B)  ;GET CLOBBERED TYPE\r
 357         CAIN    B,TARGS ;WAS IT ARGS?\r
 358         JRST    ILLAR1\r
 359         CAIN    B,TFRAME                ;A FRAME?\r
 360         JRST    ILFRAM\r
 361         CAIN    B,TLOCD         ;A LOCATIVE TO AN ID\r
 362         JRST    ILLOC1\r
 363 \r
 364         LSH     B,1             ;NONE OF ABOVE LOOK IN TABLE\r
 365         ADDI    B,TYPVEC+1(TVP)\r
 366         PUSH    TP,$TATOM\r
 367         PUSH    TP,EQUOTE ILLEGAL\r
 368         PUSH    TP,$TATOM\r
 369         PUSH    TP,(B)          ;PUSH ATOMIC NAME\r
 370         MOVEI   A,2\r
 371         JRST    CALER           ;GO TO ERROR REPORTER\r
 372 \r
 373 ; CHECK AN ARGS POINTER\r
 374 \r
 375 CHARGS: PUSHJ   P,ICHARG                ; INTERNAL CHECK\r
 376         JUMPN   B,CPOPJ\r
 377 \r
 378 ILLAR1: PUSH    TP,$TATOM\r
 379         PUSH    TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK\r
 380         JRST    CALER1\r
 381 \r
 382 ICHARG: PUSH    P,A             ;SAVE SOME ACS\r
 383         PUSH    P,B\r
 384         PUSH    P,C\r
 385         SKIPN   C,1(B)  ;GET POINTER\r
 386         JRST    ILLARG          ; ZERO POINTER IS ILLEGAL\r
 387         HLRE    A,C             ;FIND ASSOCIATED FRAME\r
 388         SUBI    C,(A)           ;C POINTS TO FRAME OR FRAME POINTER\r
 389         GETYP   A,(C)           ;GET TYPE OF NEXT GOODIE\r
 390         CAIN    A,TCBLK\r
 391         JRST    CHARG1\r
 392         CAIE    A,TENTRY        ;MUST BE EITHER ENTRY OR TINFO\r
 393         CAIN    A,TINFO\r
 394         JRST    CHARG1          ;WINNER\r
 395         JRST    ILLARG\r
 396 \r
 397 CHARG1: CAIN    A,TINFO         ;POINTER TO FRAME?\r
 398         ADD     C,1(C)          ;YES, GET IT\r
 399         CAIE    A,TINFO         ;POINTS TO ENTRT?\r
 400         MOVEI   C,FRAMLN(C)     ;YES POINT TO END OF FRAME\r
 401         HLRZ    C,OTBSAV(C)     ;GET TIME FROM FRAME\r
 402         HRRZ    B,(B)           ;AND ARGS TIME\r
 403         CAIE    B,(C)           ;SAME?\r
 404 ILLARG: SETZM   -1(P)           ; RETURN ZEROED B\r
 405 POPBCJ: POP     P,C\r
 406         POP     P,B\r
 407         POP     P,A\r
 408         POPJ    P,              ;GO GET PRIM TYPE\r
 409 \f\r
 410 \r
 411 \r
 412 ; CHECK A FRAME POINTER\r
 413 \r
 414 CHFRM:  PUSHJ   P,CHFRAM\r
 415         JUMPN   B,CPOPJ\r
 416 \r
 417 ILFRAM: PUSH    TP,$TATOM\r
 418         PUSH    TP,EQUOTE ILLEGAL-FRAME\r
 419         JRST    CALER1\r
 420 \r
 421 CHFRAM: PUSH    P,A             ;SAVE SOME REGISTERS\r
 422         PUSH    P,B\r
 423         PUSH    P,C\r
 424         HRRZ    A,(B)           ; GE PVP POINTER\r
 425         HLRZ    C,(A)           ; GET LNTH\r
 426         SUBI    A,-1(C)         ; POINT TO TOP\r
 427         CAIN    A,(PVP)         ; SKIP  IF NOT THIS PROCESS\r
 428         MOVEM   TP,TPSTO+1(A)   ; MAKE CURRENT BE STORED\r
 429         HRRZ    A,TPSTO+1(A)    ; GET TP FOR THIS PROC\r
 430         HRRZ    C,1(B)          ;GET POINTER PART\r
 431         CAILE   C,1(A)          ;STILL WITHIN STACK\r
 432         JRST    BDFR\r
 433         HLRZ    A,FSAV(C)       ;CHECK STILL AN ENTRY BLOCK\r
 434         CAIN    A,TCBLK\r
 435         JRST    .+3\r
 436         CAIE    A,TENTRY\r
 437         JRST    BDFR\r
 438         HLRZ    A,1(B)          ;GET TIME FROM POINTER\r
 439         HLRZ    C,OTBSAV(C)     ;AND FROM FRAME\r
 440         CAIE    A,(C)           ;SAME?\r
 441 BDFR:   SETZM   -1(P)           ; RETURN 0 IN B\r
 442         JRST    POPBCJ          ;YES, WIN\r
 443 \r
 444 ; CHECK A LOCATIVE TO AN IDENTIFIER\r
 445 \r
 446 CHLOCI: PUSHJ   P,ICHLOC\r
 447         JUMPN   B,CPOPJ\r
 448 \r
 449 ILLOC1: PUSH    TP,$TATOM\r
 450         PUSH    TP,EQUOTE ILLEGAL-LOCATIVE\r
 451         JRST    CALER1\r
 452 \r
 453 ICHLOC: PUSH    P,A\r
 454         PUSH    P,B\r
 455         PUSH    P,C\r
 456 \r
 457         HRRZ    A,(B)           ;GET TIME FROM POINTER\r
 458         JUMPE   A,POPBCJ        ;ZERO, GLOBAL VARIABLE NO TIME\r
 459         HRRZ    C,1(B)          ;POINT TO STACK\r
 460         CAMLE   C,VECTOP\r
 461         JRST    ILLOC           ;NO\r
 462         HRRZ    C,2(C)          ; SHOULD BE DECL,,TIME\r
 463         CAIE    A,(C)\r
 464 ILLOC:  SETZM   -1(P)           ; RET 0 IN B\r
 465         JRST    POPBCJ\r
 466 \r
 467 \r
 468         \r
 469 \f\r
 470 ; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED\r
 471 \r
 472 MFUNCTION %STRUC,SUBR,[STRUCTURED?]\r
 473 \r
 474         ENTRY   1\r
 475 \r
 476         GETYP   A,(AB)          ; GET TYPE\r
 477         PUSHJ   P,ISTRUC        ; INTERNAL\r
 478         JRST    IFALSE\r
 479         JRST    ITRUTH\r
 480 \r
 481 \r
 482 ; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE\r
 483 \r
 484 MFUNCTION %LEGAL,SUBR,[LEGAL?]\r
 485 \r
 486         ENTRY   1\r
 487 \r
 488         MOVEI   B,(AB)          ; POINT TO ARG\r
 489         PUSHJ   P,ILEGQ\r
 490         JRST    IFALSE\r
 491         JRST    ITRUTH\r
 492 \r
 493 ILEGQ:  GETYP   A,(B)\r
 494         CAIN    A,TILLEG\r
 495         POPJ    P,\r
 496         PUSHJ   P,SAT           ; GET STORG TYPE\r
 497         CAIN    A,SFRAME        ; FRAME?\r
 498         PUSHJ   P,CHFRAM\r
 499         CAIN    A,SARGS ; ARG TUPLE\r
 500         PUSHJ   P,ICHARG\r
 501         CAIN    A,SLOCID        ; ID LOCATIVE\r
 502         PUSHJ   P,ICHLOC\r
 503         JUMPE   B,CPOPJ\r
 504         JRST    CPOPJ1\r
 505 \r
 506 \r
 507 ; COMPILERS CALL\r
 508 \r
 509 CILEGQ: PUSH    TP,A\r
 510         PUSH    TP,B\r
 511         MOVEI   B,-1(TP)\r
 512         PUSHJ   P,ILEGQ\r
 513         TDZA    0,0\r
 514         MOVEI   0,1\r
 515         SUB     TP,[2,,2]\r
 516         JUMPE   0,NO\r
 517 \r
 518 YES:    MOVSI   A,TATOM\r
 519         MOVE    B,MQUOTE T\r
 520         JRST    CPOPJ1\r
 521 \r
 522 NOM:    SUBM    M,(P)\r
 523 NO:     MOVSI   A,TFALSE\r
 524         MOVEI   B,0\r
 525         POPJ    P,\r
 526 \r
 527 YESM:   SUBM    M,(P)\r
 528         JRST    YES\r
 529 \f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS\r
 530 \r
 531 MFUNCTION BITS,SUBR\r
 532         ENTRY\r
 533         JUMPGE  AB,TFA          ;AT LEAST ONE ARG ?\r
 534         GETYP   A,(AB)\r
 535         CAIE    A,TFIX\r
 536         JRST    WTYP1\r
 537         SKIPLE  C,(AB)+1        ;GET FIRST AND CHECK TO SEE IF POSITIVE\r
 538         CAILE   C,44            ;CHECK IF FIELD NOT GREATER THAN WORD SIZE\r
 539         JRST    OUTRNG\r
 540         MOVEI   B,0\r
 541         CAML    AB,[-2,,0]      ;ONLY ONE ARG ?\r
 542         JRST    ONEF            ;YES\r
 543         CAMGE   AB,[-4,,0]      ;MORE THAN TWO ARGS ?\r
 544         JRST    TMA             ;YES, LOSE\r
 545         GETYP   A,(AB)+2\r
 546         CAIE    A,TFIX\r
 547         JRST    WTYP2\r
 548         SKIPGE  B,(AB)+3        ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE\r
 549         JRST    OUTRNG\r
 550         ADD     C,(AB)+3        ;CALCULATE LEFTMOST EXTENT OF THE FIELD\r
 551         CAILE   C,44            ;SHOULD BE LESS THAN WORD SIZE\r
 552         JRST    OUTRNG\r
 553         LSH     B,6\r
 554 ONEF:   ADD     B,(AB)+1\r
 555         LSH     B,30            ;FORM BYTE POINTER'S LEFT HALF\r
 556         MOVSI   A,TBITS\r
 557         JRST    FINIS\r
 558 \r
 559 \r
 560 \r
 561 MFUNCTION GETBITS,SUBR\r
 562         ENTRY 2\r
 563         GETYP   A,(AB)\r
 564         PUSHJ   P,SAT\r
 565         CAIN    A,SSTORE\r
 566         JRST    .+3\r
 567         CAIE    A,S1WORD\r
 568         JRST    WTYP1\r
 569         GETYP   A,(AB)+2\r
 570         CAIE    A,TBITS\r
 571         JRST    WTYP2\r
 572         MOVEI   A,(AB)+1        ;GET ADDRESS OF THE WORD\r
 573         HLL     A,(AB)+3        ;GET LEFT HALF OF BYTE POINTER\r
 574         LDB     B,A\r
 575         MOVSI   A,TWORD         ; ALWAYS RETURN WORD\b\b\b\b____\r
 576         JRST    FINIS\r
 577 \r
 578 \r
 579 MFUNCTION PUTBITS,SUBR\r
 580         ENTRY\r
 581         CAML    AB,[-2,,0]      ;AT LEAST TWO ARGS ?\r
 582         JRST    TFA             ;NO, LOSE\r
 583         GETYP   A,(AB)\r
 584         PUSHJ   P,SAT\r
 585         CAIE    A,S1WORD\r
 586         JRST    WTYP1\r
 587         GETYP   A,(AB)+2\r
 588         CAIE    A,TBITS\r
 589         JRST    WTYP2\r
 590         MOVEI   B,0             ;EMPTY THIRD ARG DEFAULT\r
 591         CAML    AB,[-4,,0]      ;ONLY TWO ARGS ?\r
 592         JRST    TWOF\r
 593         CAMGE   AB,[-6,,0]      ;MORE THAN THREE ARGS ?\r
 594         JRST    TMA             ;YES, LOSE\r
 595         GETYP   A,(AB)+4\r
 596         PUSHJ   P,SAT\r
 597         CAIE    A,S1WORD\r
 598         JRST    WTYP3\r
 599         MOVE    B,(AB)+5\r
 600 TWOF:   MOVEI   A,(AB)+1        ;ADDRESS OF THE TARGET WORD\r
 601         HLL     A,(AB)+3        ;GET THE LEFT HALF OF THE BYTE POINTER\r
 602         DPB     B,A\r
 603         MOVE    B,(AB)+1\r
 604         MOVE    A,(AB)          ;SAME TYPE AS FIRST ARG'S\r
 605         JRST    FINIS\r
 606 \f\r
 607 \r
 608 ; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS\r
 609 \r
 610 MFUNCTION       LNTHQ,SUBR,[LENGTH?]\r
 611 \r
 612         ENTRY 2\r
 613         GETYP   A,(AB)2\r
 614         CAIE    A,TFIX\r
 615         JRST    WTYP2\r
 616         PUSH    P,(AB)3\r
 617         JRST    LNTHER\r
 618 \r
 619 \r
 620 MFUNCTION LENGTH,SUBR\r
 621 \r
 622         ENTRY   1\r
 623         PUSH    P,[377777777777]\r
 624 LNTHER: MOVE    B,AB            ;POINT TO ARGS\r
 625         PUSHJ   P,PTYPE         ;GET ITS PRIM TYPE\r
 626         MOVE    B,1(AB)\r
 627         MOVE    C,(AB)\r
 628         PUSHJ   P,@LENTBL(A)    ; CALL RIGTH ONE\r
 629         JRST    LFINIS          ;OTHERWISE USE 0\r
 630 \r
 631 PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]\r
 632 [PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]]\r
 633 \r
 634 LNLST:  SKIPN   C,B             ; EMPTY?\r
 635         JRST    LNLST2          ; YUP, LEAVE\r
 636         MOVEI   B,1             ; INIT COUNTER\r
 637         MOVSI   A,TLIST         ;WILL BECOME INTERRUPTABLE\r
 638         HLLM    A,CSTO(PVP)     ;AND C WILL BE A LIST POINTER\r
 639 LNLST1: INTGO           ;IN CASE CIRCULAR LIST\r
 640         CAMLE   B,(P)-1\r
 641         JRST    LNLST2\r
 642         HRRZ    C,(C)           ;STEP\r
 643         JUMPE   C,.+2           ;DONE, RETRUN LENGTH\r
 644         AOJA    B,LNLST1        ;COUNT AND GO\r
 645 LNLST2: SETZM   CSTO(PVP)\r
 646         POPJ    P,\r
 647 \r
 648 LFINIS: POP     P,C\r
 649         CAMLE   B,C\r
 650         JRST    IFALSE\r
 651         MOVSI   A,TFIX          ;LENGTH IS AN INTEGER\r
 652         JRST    FINIS\r
 653 \r
 654 LNVEC:  ASH     B,-1            ;GENERAL VECTOR DIVIDE BY 2\r
 655 LNUVEC: HLRES   B               ;GET LENGTH\r
 656         MOVMS   B               ;MAKE POS\r
 657         POPJ    P,\r
 658 \r
 659 LNCHAR: HRRZ    B,C             ; GET COUNT\r
 660         POPJ    P,\r
 661 \r
 662 LNTMPL: GETYP   A,(B)           ; GET REAL SAT\r
 663         SUBI    A,NUMSAT+1\r
 664         HRLS    A               ; READY TO HIT TABLE\r
 665         ADD     A,TD.LNT+1(TVP)\r
 666         JUMPGE  A,BADTPL\r
 667         MOVE    C,B             ; DATUM TO C\r
 668         XCT     (A)             ; GET LENGTH\r
 669         HLRZS   C               ; REST COUNTER\r
 670         SUBI    B,(C)           ; FLUSH IT OFF\r
 671         MOVEI   B,(B)           ; IN CASE FUNNY STUFF\r
 672         MOVSI   A,TFIX\r
 673         POPJ    P,\r
 674 \r
 675 ; COMPILERS ENTRIES\r
 676 \r
 677 CILNT:  SUBM    M,(P)\r
 678         PUSH    P,[377777,,-1]\r
 679         MOVE    C,A\r
 680         GETYP   A,A\r
 681         PUSHJ   P,CPTYPE        ; GET PRIMTYPE\r
 682         JUMPE   A,COMPERR\r
 683         PUSHJ   P,@LENTBL(A)    ; DISPATCH\r
 684         MOVSI   A,TFIX\r
 685         SUB     P,[1,,1]\r
 686 MPOPJ:  SUBM    M,(P)\r
 687         POPJ    P,\r
 688 \r
 689 CILNQ:  SUBM    M,(P)\r
 690         PUSH    P,C\r
 691         MOVE    C,A\r
 692         GETYP   A,A\r
 693         PUSHJ   P,CPTYPE\r
 694         JUMPE   A,COMPERR\r
 695         PUSHJ   P,@LENTBL(A)\r
 696         POP     P,C\r
 697         SUBM    M,(P)\r
 698         MOVSI   A,TFIX\r
 699         CAMG    B,C\r
 700         JRST    CPOPJ1\r
 701         MOVSI   A,TFALSE\r
 702         MOVEI   B,0\r
 703         POPJ    P,\r
 704 \f\r
 705 \r
 706 \r
 707 IDNT1:  MOVE    A,(AB)          ;RETURN THE FIRST ARG\r
 708         MOVE    B,1(AB)\r
 709         JRST    FINIS\r
 710 \r
 711 MFUNCTION QUOTE,FSUBR\r
 712 \r
 713         ENTRY   1\r
 714 \r
 715         GETYP   A,(AB)\r
 716         CAIE    A,TLIST         ;ARG MUST BE A LIST\r
 717         JRST    WTYP1\r
 718         SKIPN   B,1(AB)         ;SHOULD HAVE A BODY\r
 719         JRST    TFA\r
 720 \r
 721         HLLZ    A,(B)           ; GET IT\r
 722         MOVE    B,1(B)\r
 723         JSP     E,CHKAB\r
 724         JRST    FINIS\r
 725 \r
 726 MFUNCTION       NEQ,SUBR,[N==?]\r
 727         \r
 728         MOVEI   D,1\r
 729         JRST    EQR\r
 730 \r
 731 MFUNCTION EQ,SUBR,[==?]\r
 732 \r
 733         MOVEI   D,0\r
 734 EQR:    ENTRY   2\r
 735 \r
 736         GETYP   A,(AB)          ;GET 1ST TYPE\r
 737         GETYP   C,2(AB)         ;AND 2D TYPE\r
 738         MOVE    B,1(AB)\r
 739         CAIN    A,(C)           ;CHECK IT\r
 740         CAME    B,3(AB)\r
 741         JRST    @TABLE2(D)\r
 742         JRST    @TABLE1(D)\r
 743 \r
 744 ITRUTH: MOVSI   A,TATOM         ;RETURN TRUTH\r
 745         MOVE    B,MQUOTE T\r
 746         JRST    FINIS\r
 747 \r
 748 IFALSE: MOVSI   A,TFALSE                ;RETURN FALSE\r
 749         MOVEI   B,0\r
 750         JRST    FINIS\r
 751 \r
 752 TABLE1: ITRUTH\r
 753 TABLE2: IFALSE\r
 754         ITRUTH\r
 755 \r
 756 \f\r
 757 \r
 758 \r
 759 MFUNCTION EMPTY,SUBR,EMPTY?\r
 760 \r
 761         ENTRY   1\r
 762 \r
 763         MOVE    B,AB\r
 764         PUSHJ   P,PTYPE         ;GET PRIMITIVE TYPE\r
 765 \r
 766         MOVEI   A,(A)\r
 767         JUMPE   A,WTYP1\r
 768         SKIPN   B,1(AB)         ;GET THE ARG\r
 769         JRST    ITRUTH\r
 770 \r
 771         CAIN    A,PTMPLT        ; TEMPLATE?\r
 772         JRST    EMPTPL\r
 773         CAIE    A,P2WORD                ;A LIST?\r
 774         JRST    EMPT1           ;NO VECTOR OR CHSTR\r
 775         JUMPE   B,ITRUTH                ;0 POINTER MEANS EMPTY LIST\r
 776         JRST    IFALSE\r
 777 \r
 778 \r
 779 EMPT1:  CAIE    A,PCHSTR                ;CHAR STRING?\r
 780         JRST    EMPT2           ;NO, VECTOR\r
 781         HRRZ    B,(AB)          ; GET COUNT\r
 782         JUMPE   B,ITRUTH        ;0 STRING WINS\r
 783         JRST    IFALSE\r
 784 \r
 785 EMPT2:  JUMPGE  B,ITRUTH\r
 786         JRST    IFALSE\r
 787 \r
 788 EMPTPL: PUSHJ   P,LNTMPL        ; GET LENGTH\r
 789         JUMPE   B,ITRUTH\r
 790         JRST    IFALSE\r
 791 \r
 792 ; COMPILER'S ENTRY TO EMPTY\r
 793 \r
 794 CEMPTY: PUSH    P,A\r
 795         GETYP   A,A\r
 796         PUSHJ   P,CPTYPE\r
 797         POP     P,0\r
 798         JUMPE   A,COMPERR\r
 799         JUMPE   B,YES           ; ALWAYS EMPTY\r
 800         CAIN    A,PTMPLT\r
 801         JRST    CEMPTP\r
 802         CAIN    A,P2WORD\r
 803         JRST    NO\r
 804         CAIN    A,PCHSTR\r
 805         JRST    .+3\r
 806         JUMPGE  B,YES\r
 807         JRST    NO\r
 808         TRNE    0,-1            ; STRING, SKIP ON ZERO LENGTH FIELD\r
 809         JRST    NO\r
 810         JRST    YES\r
 811 \r
 812 CEMPTP: PUSHJ   P,LNTMPL\r
 813         JUMPE   B,YES\r
 814         JRST    NO\r
 815 \r
 816 MFUNCTION       NEQUAL,SUBR,[N=?]\r
 817         PUSH    P,[1]\r
 818         JRST    EQUALR\r
 819 \r
 820 MFUNCTION EQUAL,SUBR,[=?]\r
 821         PUSH    P,[0]\r
 822 EQUALR: ENTRY   2\r
 823 \r
 824         MOVE    C,AB            ;SET UP TO CALL INTERNAL\r
 825         MOVE    D,AB\r
 826         ADD     D,[2,,2]        ;C POINTS TO FIRS, D TO SECOND\r
 827         PUSHJ   P,IEQUAL        ;CALL INTERNAL\r
 828         JRST    EQFALS          ;NO SKIP MEANS LOSE\r
 829         JRST    EQTRUE\r
 830 EQFALS: POP     P,C\r
 831         JRST    @TABLE2(C)\r
 832 EQTRUE: POP     P,C\r
 833         JRST    @TABLE1(C)\r
 834 \r
 835 \f\r
 836 ; COMPILER'S ENTRY TO =? AND N=?\r
 837 \r
 838 CINEQU: PUSH    P,[0]\r
 839         JRST    .+2\r
 840 \r
 841 CIEQUA: PUSH    P,[1]\r
 842         PUSH    TP,A\r
 843         PUSH    TP,B\r
 844         PUSH    TP,C\r
 845         PUSH    TP,D\r
 846         MOVEI   C,-3(TP)\r
 847         MOVEI   D,-1(TP)\r
 848         SUBM    M,-1(P)         ; MAY BECOME INTERRUPTABLE\r
 849         PUSHJ   P,IEQUAL\r
 850         JRST    NOE\r
 851         POP     P,C\r
 852         SUB     TP,[4,,4]       ; FLUSH TEMPS\r
 853         JRST    @CTAB1(C)\r
 854 \r
 855 NOE:    POP     P,C\r
 856         SUB     TP,[4,,4]\r
 857         JRST    @CTAB2(C)\r
 858 \r
 859 CTAB1:  NOM\r
 860 CTAB2:  YESM\r
 861         NOM\r
 862         \r
 863 ; INTERNAL EQUAL SUBROUTINE\r
 864 \r
 865 IEQUAL: MOVE    B,C             ;NOW CHECK THE ARGS\r
 866         PUSHJ   P,PTYPE\r
 867         MOVE    B,D\r
 868         PUSHJ   P,PTYPE\r
 869         GETYP   0,(C)           ;NOW CHECK FOR EQ\r
 870         GETYP   B,(D)\r
 871         MOVE    E,1(C)\r
 872         CAIN    0,(B)           ;DONT SKIP IF POSSIBLE WINNER\r
 873         CAME    E,1(D)          ;DEFINITE WINNER, SKIP\r
 874         JRST    IEQ1\r
 875 CPOPJ1: AOS     (P)             ;EQ, SKIP RETURN\r
 876         POPJ    P,\r
 877 \r
 878 \r
 879 IEQ1:   CAIE    0,(B)           ;SKIP IF POSSIBLE MATCH\r
 880 CPOPJ:  POPJ    P,              ;NOT POSSIBLE WINNERS\r
 881         JRST    @EQTBL(A)       ;DISPATCH\r
 882 \r
 883 PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]\r
 884 [PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]]\r
 885 \r
 886 \r
 887 EQLIST: PUSHJ   P,PUSHCD        ;PUT ARGS ON STACK\r
 888 \r
 889 EQLST1: INTGO                   ;IN CASE OF CIRCULAR\r
 890         HRRZ    C,-2(TP)        ;GET FIRST\r
 891         HRRZ    D,(TP)          ;AND 2D\r
 892         CAIN    C,(D)           ;EQUAL?\r
 893         JRST    EQLST2          ;YES, LEAVE\r
 894         JUMPE   C,EQLST3        ;NIL LOSES\r
 895         JUMPE   D,EQLST3\r
 896         GETYP   0,(C)           ;CHECK DEFERMENT\r
 897         CAIN    0,TDEFER\r
 898         HRRZ    C,1(C)          ;PICK UP POINTED TO CROCK\r
 899         GETYP   0,(D)\r
 900         CAIN    0,TDEFER\r
 901         HRRZ    D,1(D)          ;POINT TO REAL GOODIE\r
 902         PUSHJ   P,IEQUAL        ;CHECK THE CARS\r
 903         JRST    EQLST3          ;LOSE\r
 904         HRRZ    C,@-2(TP)       ;CDR THE LISTS\r
 905         HRRZ    D,@(TP\r
 906         HRRZM   C,-2(TP)        ;AND STORE\r
 907         HRRZM   D,(TP)\r
 908         JRST    EQLST1\r
 909 \r
 910 EQLST2: AOS     (P)             ;SKIP RETRUN\r
 911 EQLST3: SUB     TP,[4,,4]       ;REMOVE CRUFT\r
 912         POPJ    P,\r
 913 \f\r
 914 ; HERE FOR HACKING TEMPLATE STRUCTURES\r
 915 \r
 916 EQTMPL: PUSHJ   P,PUSHCD        ; SAVE GOODIES\r
 917         PUSHJ   P,PUSHCD\r
 918         MOVE    C,1(C)          ; CHECK REAL SATS\r
 919         GETYP   C,(C)\r
 920         MOVE    D,1(D)\r
 921         GETYP   0,(D)\r
 922         CAIE    0,(C)           ; SKIP IF WINNERS\r
 923         JRST    EQTMP4\r
 924         PUSH    P,0             ; SAVE MAGIC OFFSET\r
 925         MOVE    B,-2(TP)\r
 926         PUSHJ   P,TM.LN1        ; RET LENGTH IN B\r
 927         MOVEI   B,-1(B)         ; FLUSH FUNNY\r
 928         HLRZ    C,-2(TP)\r
 929         SUBI    B,(C)\r
 930         PUSH    P,B\r
 931         MOVE    C,(TP)          ; POINTER TO OTHER GUY\r
 932         ADD     A,TD.LNT+1(TVP)\r
 933         XCT     (A)             ; OTHER LENGTH TO B\r
 934         HLRZ    0,B             ; REST OFFSETTER\r
 935         PUSH    P,0\r
 936         MOVEI   B,-1(B)\r
 937         HLRZ    C,(TP)\r
 938         SUBI    B,(C)\r
 939         CAME    B,-1(P)\r
 940         JRST    EQTMP1\r
 941 \r
 942 EQTMP2: AOS     C,(P)\r
 943         SOSGE   -1(P)\r
 944         JRST    EQTMP3          ; WIN!!\r
 945 \r
 946         MOVE    B,-6(TP)        ; POINTER\r
 947         MOVE    0,-2(P)         ; GET MAGIC OFFSET\r
 948         PUSHJ   P,TM.TOE        ; GET OFFSET TO TEMPLATE\r
 949         ADD     A,TD.GET+1(TVP)\r
 950         MOVE    A,(A)\r
 951         ADDI    E,(A)\r
 952         XCT     (E)             ; VAL TO A AND B\r
 953         MOVEM   A,-3(TP)\r
 954         MOVEM   B,-2(TP)\r
 955         MOVE    C,(P)\r
 956         MOVE    B,-4(TP)        ; OTHER GUY\r
 957         MOVE    0,-2(P)\r
 958         PUSHJ   P,TM.TOE\r
 959         ADD     A,TD.GET+1(TVP)\r
 960         MOVE    A,(A)\r
 961         ADDI    E,(A)\r
 962         XCT     (E)             ; GET OTHER VALUE\r
 963         MOVEM   A,-1(TP)\r
 964         MOVEM   B,(TP)\r
 965         MOVEI   C,-3(TP)\r
 966         MOVEI   D,-1(TP)\r
 967         PUSHJ   P,IEQUAL        ; RECURSE\r
 968         JRST    EQTMP1          ; LOSER\r
 969         JRST    EQTMP2          ; WINNER\r
 970 \r
 971 EQTMP3: AOS     -3(P)           ; WIN RETURN\r
 972 EQTMP1: SUB     P,[3,,3]        ; FLUSH JUNK\r
 973 EQTMP4: SUB     TP,[10,,10]\r
 974         POPJ    P,\r
 975 \r
 976 \r
 977 \r
 978 EQVEC:  HLRE    A,1(C)          ;GET LENGTHS\r
 979         HLRZ    B,1(D)\r
 980         CAIE    B,(A)           ;SKIP IF EQUAL LENGTHS\r
 981         POPJ    P,              ;LOSE\r
 982         JUMPGE  A,CPOPJ1        ;SKIP RETRUN WIN\r
 983         PUSHJ   P,PUSHCD        ;SAVE ARGS\r
 984 \r
 985 EQVEC1: INTGO                   ;IN CASE LONG VECTOR\r
 986         MOVE    C,(TP)\r
 987         MOVE    D,-2(TP)        ;ARGS TO C AND D\r
 988         PUSHJ   P,IEQUAL\r
 989         JRST    EQLST3\r
 990         MOVE    C,[2,,2]        ;GET BUMPER\r
 991         ADDM    C,(TP)\r
 992         ADDB    C,-2(TP)        ;BUMP BOTH POINTERS\r
 993         JUMPL   C,EQVEC1\r
 994         JRST    EQLST2\r
 995 \r
 996 EQUVEC: HLRE    A,1(C)          ;GET LENGTHS\r
 997         HLRZ    B,1(D)\r
 998         CAIE    B,(A)           ;SKIP IF EQUAL\r
 999         POPJ    P,\r
1000 \r
1001         HRRZ    B,1(C)          ;START COMPUTING DOPE WORD LOCN\r
1002         SUB     B,A             ;B POINTS TO DOPE WORD\r
1003         GETYP   0,(B)           ;GET UNIFORM TYPE\r
1004         HRRZ    B,1(D)          ;NOW FIND OTHER DOPE WORD\r
1005         SUB     B,A\r
1006         HLRZ    B,(B)           ;OTHER UNIFORM TYPE\r
1007         CAIE    0,(B)           ;TYPES THE SAME?\r
1008         POPJ    P,              ;NO, LOSE\r
1009 \r
1010         JUMPGE  A,CPOPJ1        ;IF ZERO LENGTH ALREADY WON\r
1011 \r
1012         HRLZI   B,(B)           ;TYPE TO LH\r
1013         PUSH    P,B             ;AND SAVED\r
1014         PUSHJ   P,PUSHCD        ;SAVE ARGS\r
1015 \r
1016 EQUV1:  MOVEI   C,1(TP)         ;POINT TO WHERE WILL GO\r
1017         PUSH    TP,(P)\r
1018         MOVE    A,-3(TP)        ;PUSH ONE OF THE VECTORS\r
1019         PUSH    TP,(A)          ; PUSH ELEMENT\r
1020         MOVEI   D,1(TP)         ;POINT TO 2D ARG\r
1021         PUSH    TP,(P)\r
1022         MOVE    A,-3(TP)        ;AND PUSH ITS POINTER\r
1023         PUSH    TP,(A)\r
1024         PUSHJ   P,IEQUAL\r
1025         JRST    UNEQUV\r
1026 \r
1027         SUB     TP,[4,,4]       ;POP TP\r
1028         MOVE    A,[1,,1]\r
1029         ADDM    A,(TP)          ;BUMP POINTERS\r
1030         ADDB    A,-2(TP)\r
1031         JUMPL   A,EQUV1         ;JUMP IF STILL MORE STUFF\r
1032         SUB     P,[1,,1]        ;POP OFF TYPE\r
1033         JRST    EQLST2\r
1034 \r
1035 UNEQUV: SUB     P,[1,,1]\r
1036         SUB     TP,[10,,10]\r
1037         POPJ    P,\r
1038 \f\r
1039 \r
1040 \r
1041 EQCHST: HRRZ    B,(C)           ; GET LENGTHS\r
1042         HRRZ    A,(D)\r
1043         CAIE    A,(B)           ;SAME\r
1044         JRST    EQCHS3          ;NO, LOSE\r
1045         MOVE    C,1(C)\r
1046         MOVE    D,1(D)\r
1047         JUMPE   A,EQCHS4        ;BOTH 0 LENGTH, WINS\r
1048 \r
1049 EQCHS2:\r
1050         ILDB    0,C             ;GET NEXT CHARS\r
1051         ILDB    E,D\r
1052         CAIE    0,(E)           ; SKIP IF STILL WINNING\r
1053         JRST    EQCHS3          ; NOT =\r
1054         SOJG    A,EQCHS2\r
1055 \r
1056 EQCHS4: AOS     (P)\r
1057 EQCHS3: POPJ    P,\r
1058 \r
1059 PUSHCD: PUSH    TP,(C)\r
1060         PUSH    TP,1(C)\r
1061         PUSH    TP,(D)\r
1062         PUSH    TP,1(D)\r
1063         POPJ    P,\r
1064 \r
1065 \f\r
1066 ; REST/NTH/AT/PUT/GET\r
1067 \r
1068 ; ARG CHECKER\r
1069 \r
1070 ARGS1:  MOVE    E,[JRST WTYP2]  ; ERROR CONDITION FOR 2D ARG NOT FIXED\r
1071 ARGS2:  HLRE    0,AB            ; CHECK NO. OF ARGS\r
1072         ASH     0,-1            ; TO - NO. OF ARGS\r
1073         AOJG    0,TFA           ; 0--TOO FEW\r
1074         AOJL    0,TMA           ; MORE THAT 2-- TOO MANY\r
1075         MOVEI   C,1             ; DEFAULT ARG2\r
1076         JUMPN   0,ARGS4         ; GET STRUCTURED ARG\r
1077 ARGS3:  GETYP   A,2(AB)\r
1078         CAIE    A,TFIX          ; SHOULD BE FIXED NUMBER\r
1079         XCT     E               ; DO ERROR THING\r
1080         SKIPGE  C,3(AB)         ; BETTER BE NON-NEGATIVE\r
1081         JRST    OUTRNG\r
1082 ARGS4:  MOVEI   B,(AB)          ; POINT TO STRUCTURED POINTER\r
1083         PUSHJ   P,PTYPE         ; GET PRIM TYPE\r
1084         MOVEI   E,(A)           ; DISPATCH CODE TO E\r
1085         MOVE    A,(AB)          ; GET ARG 1\r
1086         MOVE    B,1(AB)\r
1087         POPJ    P,\r
1088 \r
1089 ; REST \r
1090 \r
1091 MFUNCTION REST,SUBR\r
1092 \r
1093         ENTRY\r
1094         PUSHJ   P,ARGS1         ; GET AND CHECK ARGS\r
1095         PUSHJ   P,@RESTBL(E)    ; DO IT BASED ON TYPE\r
1096         MOVE    C,A             ; THE FOLLOWING IS TO MAKE STORAGE WORK\r
1097         GETYP   A,(AB)\r
1098         PUSHJ   P,SAT\r
1099         CAIN    A,SSTORE        ; SKIP IF NOT STORAGE\r
1100         MOVSI   C,TSTORA        ; USE ITS PRIMTYPE\r
1101         MOVE    A,C\r
1102         JRST    FINIS\r
1103 \r
1104 PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]\r
1105 [PCHSTR,SREST],[PTMPLT,TMPRST]]\r
1106 \r
1107 ; AT\r
1108 \r
1109 MFUNCTION AT,SUBR\r
1110 \r
1111         ENTRY\r
1112         PUSHJ   P,ARGS1\r
1113         SOJL    C,OUTRNG\r
1114         PUSHJ   P,@ATTBL(E)\r
1115         JRST    FINIS\r
1116 \r
1117 PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
1118 [PCHSTR,STAT],[PTMPLT,TAT]]\r
1119 \r
1120 \f\r
1121 ; NTH\r
1122 \r
1123 MFUNCTION NTH,SUBR\r
1124 \r
1125         ENTRY\r
1126 \r
1127         PUSHJ   P,ARGS1\r
1128         SOJL    C,OUTRNG\r
1129         PUSHJ   P,@NTHTBL(E)\r
1130         JRST    FINIS\r
1131 \r
1132 PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]\r
1133 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
1134 \r
1135 ; GET\r
1136 \r
1137 MFUNCTION GET,SUBR\r
1138 \r
1139         ENTRY\r
1140         MOVE    E,IIGETP        ; MAKE ARG CHECKER FAIL INTO GETPROP\r
1141         PUSHJ   P,ARGS5         ; CHECK ARGS\r
1142         SOJL    C,OUTRNG\r
1143         SKIPN   E,IGETBL(E)     ; GET DISPATCH ADR\r
1144         JRST    IGETP           ; REALLY PUTPROP\r
1145         JUMPE   0,TMA\r
1146         PUSHJ   P,(E)           ; DISPATCH\r
1147         JRST    FINIS\r
1148 \r
1149 PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]\r
1150 [PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
1151 \r
1152 ; GETL\r
1153 \r
1154 MFUNCTION GETL,SUBR\r
1155 \r
1156         ENTRY\r
1157         MOVE    E,IIGETL        ; ERROR HACK\r
1158         PUSHJ   P,ARGS5\r
1159         SOJL    C,OUTRNG        ; LOSER\r
1160         SKIPN   E,IGTLTB(E)\r
1161         JRST    IGETLO          ; REALLY GETPL\r
1162         JUMPE   0,TMA\r
1163         PUSHJ   P,(E)           ; DISPATCH\r
1164         JRST    FINIS\r
1165 \r
1166 IIGETL: JRST    IGETLO\r
1167 \r
1168 PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
1169 [PCHSTR,STAT]]\r
1170 \r
1171 \r
1172 ; ARG CHECKER FOR PUT/GET/GETL\r
1173 \r
1174 ARGS5:  HLRE    0,AB            ; -# OF ARGS\r
1175         ASH     0,-1\r
1176         ADDI    0,2             ; 0 OR -1 WIN\r
1177         JUMPG   0,TFA\r
1178         AOJL    0,TMA           ; MORE THAN 3\r
1179         JRST    ARGS3           ; GET ARGS\r
1180 \f\r
1181 ; PUT\r
1182 \r
1183 MFUNCTION PUT,SUBR\r
1184 \r
1185         ENTRY\r
1186         MOVE    E,IIPUTP\r
1187         PUSHJ   P,ARGS5         ; GET ARGS\r
1188         SKIPN   E,IPUTBL(E)\r
1189         JRST    IPUTP\r
1190         CAML    AB,[-5,,]       ; SKIP IF GOOD ARRGS\r
1191         JRST    TFA\r
1192         SOJL    C,OUTRNG\r
1193         PUSH    TP,4(AB)\r
1194         PUSH    TP,5(AB)\r
1195         PUSHJ   P,(E)\r
1196         MOVE    A,(AB)          ; RET STRUCTURE\r
1197         MOVE    B,1(AB)\r
1198         JRST    FINIS\r
1199 \r
1200 PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]\r
1201 [PCHSTR,SPUT],[PTMPLT,TMPPUT]]\r
1202 \r
1203 ; IN\r
1204 \r
1205 MFUNCTION IN,SUBR\r
1206 \r
1207         ENTRY   1\r
1208 \r
1209         MOVEI   B,(AB)          ; POINT TO ARG\r
1210         PUSHJ   P,PTYPE\r
1211         MOVS    E,A             ; REAL DISPATCH TO E\r
1212         MOVE    B,1(AB)\r
1213         MOVE    A,(AB)\r
1214         GETYP   C,A             ; IN CASE NEEDED\r
1215         PUSHJ   P,@INTBL(E)\r
1216         JRST    FINIS\r
1217 \r
1218 PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]\r
1219 [PCHSTR,SIN],[PTMPLT,TIN]]\r
1220 \r
1221 OTHIN:  CAIE    C,TLOCN         ; ASSOCIATION LOCATIVE\r
1222         JRST    OTHIN1          ; MAYBE LOCD\r
1223         HLLZ    0,VAL(B)\r
1224         PUSHJ   P,RMONCH\r
1225         MOVE    A,VAL(B)\r
1226         MOVE    B,VAL+1(B)\r
1227         POPJ    P,\r
1228 \r
1229 OTHIN1: CAIE    C,TLOCD\r
1230         JRST    WTYP1\r
1231         JRST    VIN\r
1232 \r
1233 \f\r
1234 ; SETLOC\r
1235 \r
1236 MFUNCTION SETLOC,SUBR\r
1237 \r
1238         ENTRY   2\r
1239 \r
1240         MOVEI   B,(AB)          ; POINT TO ARG\r
1241         PUSHJ   P,PTYPE         ; DO TYPE\r
1242         MOVS    E,A             ; REAL TYPE\r
1243         MOVE    B,1(AB)\r
1244         MOVE    C,2(AB)         ; PASS ARG\r
1245         MOVE    D,3(AB)\r
1246         MOVE    A,(AB)          ; IN CASE\r
1247         GETYP   0,A\r
1248         PUSHJ   P,@SETTBL(E)\r
1249         MOVE    A,2(AB)\r
1250         MOVE    B,3(AB)\r
1251         JRST    FINIS\r
1252 \r
1253 PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]\r
1254 [PCHSTR,SSTUF],[PTMPLT,TSTUF]]\r
1255 \r
1256 OTHSET: CAIE    0,TLOCN         ; ASSOC?\r
1257         JRST    OTHSE1\r
1258         HLLZ    0,VAL(B)        ; GET MONITORS\r
1259         PUSHJ   P,MONCH\r
1260         MOVEM   C,VAL(B)\r
1261         MOVEM   D,VAL+1(B)\r
1262         POPJ    P,\r
1263 \r
1264 OTHSE1: CAIE    0,TLOCD\r
1265         JRST    WTYP1\r
1266         JRST    VSTUF\r
1267 \r
1268 ; LREST  -- REST A LIST IN B BY AMOUNT IN C\r
1269 \r
1270 LREST:  MOVSI   A,TLIST\r
1271         JUMPE   C,CPOPJ\r
1272         MOVEM   A,BSTO(PVP)\r
1273 \r
1274 LREST2: INTGO                   ;CHECK INTERRUPTS\r
1275         JUMPE   B,OUTRNG        ; CANT CDR NIL\r
1276         HRRZ    B,(B)           ;CDR THE LIST\r
1277         SOJG    C,LREST2        ;COUNT DOWN\r
1278         SETZM   BSTO(PVP)       ;RESET BSTO\r
1279         POPJ    P,\r
1280 \r
1281 \f\r
1282 ; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK\r
1283 \r
1284 VREST:  SKIPA   A,$TVEC         ; FINAL TYPE\r
1285 AREST:  HRLI    A,TARGS\r
1286         ASH     C,1             ; TIMES 2\r
1287         JRST    UREST1\r
1288 \r
1289 ; UREST  -- REST A UVECTOR\r
1290 \r
1291 STORST: SKIPA   A,$TSTORA\r
1292 UREST:  MOVSI   A,TUVEC\r
1293 UREST1: JUMPE   C,CPOPJ\r
1294         HRLI    C,(C)\r
1295         JUMPL   C,OUTRNG\r
1296         ADD     B,C             ; REST IT\r
1297         CAILE   B,-1            ; OUT OF RANGE ?\r
1298         JRST    OUTRNG\r
1299         POPJ    P,\r
1300 \r
1301 \r
1302 ; SREST -- REST A STRING\r
1303 \r
1304 SREST:  JUMPE   C,SREST1\r
1305         PUSH    P,A             ; SAVE TYPE WORD\r
1306         PUSH    P,C             ; SAVE AMOUNT\r
1307         MOVEI   D,(A)           ; GET LENGTH\r
1308         CAILE   C,(D)           ; SKIP IF OK\r
1309         JRST    OUTRNG\r
1310         LDB     D,[366000,,B]   ;POSITION FIELD OF BYTE POINTER\r
1311         LDB     A,[300600,,B]   ;SIZE FIELD\r
1312         PUSH    P,A             ;SAVE SIZE\r
1313         IDIVI   D,(A)           ;COMPUT BYTES IN 1ST WORD\r
1314         MOVEI   0,36.           ;NOW COMPUTE BYTES PER WORD\r
1315         IDIVI   0,(A)           ;BYTES PER WORD IN 0\r
1316         MOVE    E,0             ;COPY OF BYTES PER WORD TO E\r
1317         SUBI    0,(D)           ;0 # OF UNSUED BYTES IN 1ST WORD\r
1318         ADDB    C,0             ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY\r
1319         IDIVI   C,(E)           ;C/ REL WORD D/ CHAR IN LAST\r
1320         ADDI    C,(B)           ;POINTO WORD WITH C\r
1321         POP     P,A             ;RESTORE BITS PER BYTE\r
1322         IMULI   A,(D)           ;A/ BITS USED IN LAST WORD\r
1323         MOVEI   0,36.\r
1324         SUBI    0,(A)           ;0 HAS NEW POSITION FIELD\r
1325         DPB     0,[360600,,B]   ;INTO BYTE POINTER\r
1326         HRRI    B,(C)           ;POINT TO RIGHT WORD\r
1327         POP     P,C             ; RESTORE AMOUNT\r
1328         POP     P,A\r
1329         SUBI    A,(C)           ; NEW LENGTH\r
1330 SREST1: HRLI    A,TCHSTR\r
1331         POPJ    P,\r
1332 \r
1333 ; TMPRST -- REST A TEMPLATE DATA STRUCTURE\r
1334 \r
1335 TMPRST: PUSHJ   P,TM.TOE        ; CHECK ALL BOUNDS ETC.\r
1336         MOVSI   D,(D)\r
1337         HLL     C,D\r
1338         MOVE    B,C             ; RET IN B\r
1339         MOVSI   A,TTMPLT\r
1340         POPJ    P,\r
1341 \r
1342 ; LAT  --  GET A LOCATIVE TO A LIST\r
1343 \r
1344 LAT:    PUSHJ   P,LREST         ; GET POINTER\r
1345         JUMPE   B,OUTRNG        ; YOU LOSE!\r
1346         MOVSI   A,TLOCL         ; NEW TYPE\r
1347         POPJ    P,\r
1348 \r
1349 \f\r
1350 ; UAT  --  GET A LOCATIVE TO A UVECTOR\r
1351 \r
1352 UAT:    PUSHJ   P,UREST \r
1353         MOVSI   A,TLOCU\r
1354         JRST    POPJL\r
1355 \r
1356 ; VAT  --  GET A LOCATIVE TO A VECTOR\r
1357 \r
1358 VAT:    PUSHJ   P,VREST         ; REST IT AND TYPE IT\r
1359         MOVSI   A,TLOCV\r
1360         JRST    POPJL\r
1361 \r
1362 ; AAT  --  GET A LOCATIVE TO AN ARGS BLOCK\r
1363 \r
1364 AAT:    PUSHJ   P,AREST\r
1365         HRLI    A,TLOCA\r
1366 POPJL:  JUMPGE  B,OUTRNG        ; LOST\r
1367         POPJ    P,\r
1368 \r
1369 ; STAT  --  LOCATIVE TO A STRING\r
1370 \r
1371 STAT:   PUSHJ   P,SREST\r
1372         TRNN    A,-1            ; SKIP IF ANY LEFT\r
1373         JRST    OUTRNG\r
1374         HRLI    A,TLOCS         ; LOCATIVE\r
1375         POPJ    P,\r
1376 \r
1377 ; TAT -- LOCATIVE TO A TEMPLATE\r
1378 \r
1379 TAT:    PUSHJ   P,TMPRST\r
1380         PUSH    TP,A\r
1381         PUSH    TP,B\r
1382         GETYP   A,(B)           ; GET REAL SAT\r
1383         SUBI    A,NUMSAT+1\r
1384         HRLS    A               ; READY TO HIT TABLE\r
1385         ADD     A,TD.LNT+1(TVP)\r
1386         JUMPGE  A,BADTPL\r
1387         MOVE    C,B             ; DATUM TO C\r
1388         XCT     (A)             ; GET LENGTH\r
1389         HLRZS   C               ; REST COUNTER\r
1390         SUBI    B,(C)           ; FLUSH IT OFF\r
1391         JUMPE   B,OUTRNG\r
1392         MOVE    B,(TP)\r
1393         SUB     TP,[2,,2]\r
1394         MOVSI   A,TLOCT\r
1395         POPJ    P,\r
1396         \r
1397 \r
1398 ; LNTH  --  NTH OF LIST\r
1399 \r
1400 LNTH:   PUSHJ   P,LAT\r
1401 LNTH1:  PUSHJ   P,RMONC0        ; CHECK READ MONITORS\r
1402         HLLZ    A,(B)           ; GET GOODIE\r
1403         MOVE    B,1(B)\r
1404         JSP     E,CHKAB         ; HACK DEFER\r
1405         POPJ    P,\r
1406 \r
1407 ; VNTH  --  NTH A VECTOR, ANTH  --  NTH AN ARGS BLOCK\r
1408 \r
1409 ANTH:   PUSHJ   P,AAT\r
1410         JRST    .+2\r
1411 \r
1412 VNTH:   PUSHJ   P,VAT\r
1413 AIN:\r
1414 VIN:    PUSHJ   P,RMONC0\r
1415         MOVE    A,(B)\r
1416         MOVE    B,1(B)\r
1417         POPJ    P,\r
1418 \r
1419 ; UNTH  --  NTH OF UVECTOR\r
1420 \r
1421 UNTH:   PUSHJ   P,UAT\r
1422 UIN:    HLRE    C,B             ; FIND DW\r
1423         SUBM    B,C\r
1424         HLLZ    0,(C)           ; GET MONITORS\r
1425         MOVE    D,0\r
1426         TLZ     D,TYPMSK#<-1>\r
1427         PUSH    P,D\r
1428         PUSHJ   P,RMONCH        ; CHECK EM\r
1429         POP     P,A\r
1430         MOVE    B,(B)           ; AND VALUE\r
1431         POPJ    P,\r
1432 \r
1433 \f\r
1434 ; SNTH  --  NTH A STRING\r
1435 \r
1436 SNTH:   PUSHJ   P,STAT\r
1437 SIN:    PUSH    TP,A\r
1438         PUSH    TP,B            ; SAVE POINT BYTER\r
1439         MOVEI   C,-1(TP)        ; FIND DOPE WORD\r
1440         PUSHJ   P,BYTDOP\r
1441         HLLZ    0,-1(A)         ; GET \r
1442         POP     TP,B\r
1443         POP     TP,A\r
1444         PUSHJ   P,RMONCH\r
1445         ILDB    B,B             ; GET CHAR\r
1446         MOVSI   A,TCHRS\r
1447         POPJ    P,\r
1448 \r
1449 ; TIN -- IN OF A TEMPLATE\r
1450 \r
1451 TIN:    MOVEI   C,0\r
1452 \r
1453 ; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE\r
1454 \r
1455 TMPLNT: ADDI    C,1\r
1456         PUSHJ   P,TM.TOE        ; GET POINTER TO INS IN E\r
1457         ADD     A,TD.GET+1(TVP) ; POINT TO GETTER\r
1458         MOVE    A,(A)           ; GET VECTOR OF INS\r
1459         ADDI    E,-1(A)         ; POINT TO INS\r
1460         SUBI    D,1\r
1461         XCT     (E)             ; DO IT\r
1462         POPJ    P,              ; RETURN\r
1463 \r
1464 ; LPUT  --  PUT ON A LIST\r
1465 \r
1466 LPUT:   PUSHJ   P,LAT           ; POSITION\r
1467         POP     TP,D\r
1468         POP     TP,C\r
1469 \r
1470 ; LSTUF -- HERE TO STUFF A LIST ELEMENT\r
1471 \r
1472 LSTUF:  PUSHJ   P,MONCH0        ; CHECK OUT MONITOR BITS\r
1473         GETYP   A,C             ; ISOLATE TYPE\r
1474         PUSHJ   P,NWORDT        ; NEED TO DEFER?\r
1475         SOJN    A,DEFSTU\r
1476         HLLM    C,(B)   \r
1477         MOVEM   D,1(B)          ; AND VAL\r
1478         POPJ    P,\r
1479 \r
1480 DEFSTU: PUSH    TP,$TLIST\r
1481         PUSH    TP,B\r
1482         PUSH    TP,C\r
1483         PUSH    TP,D\r
1484         PUSHJ   P,CELL2         ; GET WORDS\r
1485         POP     TP,1(B)\r
1486         POP     TP,(B)\r
1487         MOVE    E,(TP)\r
1488         SUB     TP,[2,,2]\r
1489         MOVEM   B,1(E)\r
1490         HLLZ    0,(E)           ; GET OLD MONITORS\r
1491         TLZ     0,TYPMSK        ; KILL TYPES\r
1492         TLO     0,TDEFER        ; MAKE DEFERRED\r
1493         HLLM    0,(E)\r
1494         POPJ    P,\r
1495 \r
1496 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK\r
1497 \r
1498 APUT:   PUSHJ   P,AAT\r
1499         JRST    .+2\r
1500 \r
1501 VPUT:   PUSHJ   P,VAT           ; TREAT LIKE VECTOR\r
1502         POP     TP,D            ; GET GOODIE BACK\r
1503         POP     TP,C\r
1504 \r
1505 ; AVSTUF --  CLOBBER ARGS AND VECTORS\r
1506 \r
1507 ASTUF:\r
1508 VSTUF:  PUSHJ   P,MONCH0\r
1509         MOVEM   C,(B)\r
1510         MOVEM   D,1(B)\r
1511         POPJ    P,\r
1512 \r
1513 \f\r
1514 \r
1515 \r
1516 ; UPUT  --  CLOBBER A UVECTOR\r
1517 \r
1518 UPUT:   PUSHJ   P,UAT           ; GET IT RESTED\r
1519         POP     TP,D\r
1520         POP     TP,C\r
1521 \r
1522 ; USTUF -- HERE TO CLOBBER A UVECTOR\r
1523 \r
1524 USTUF:  HLRE    E,B\r
1525         SUBM    B,E             ; C POINTS TO DOPE\r
1526         GETYP   A,(E)           ; GET UTYPE\r
1527         GETYP   0,C\r
1528         CAIE    0,(A)           ; CHECK SAMENESS\r
1529         JRST    WRNGUT\r
1530         HLLZ    0,(E)           ; MONITOR BITS IN DOPE WORD\r
1531         MOVSI   A,TUVEC\r
1532         PUSHJ   P,MONCH\r
1533         MOVEM   D,(B)           ; SMASH\r
1534         POPJ    P,\r
1535 \r
1536 ; SPUT -- HERE TO PUT A STRING\r
1537 \r
1538 SPUT:   PUSHJ   P,STAT          ; REST IT\r
1539         POP     TP,D\r
1540         POP     TP,C\r
1541 \r
1542 ; SSTUF -- STUFF A STRING\r
1543 \r
1544 SSTUF:  GETYP   0,C             ; BETTER BE CHAR\r
1545         CAIE    0,TCHRS\r
1546         JRST    WTYP3\r
1547         PUSH    TP,A\r
1548         PUSH    TP,B\r
1549         MOVEI   C,-1(TP)        ; FIND D.W.\r
1550         PUSHJ   P,BYTDOP\r
1551         HLLZ    0,(A)-1         ; GET MONITORS\r
1552         POP     TP,B\r
1553         POP     TP,A\r
1554         MOVSI   C,TCHRS\r
1555         PUSHJ   P,MONCH\r
1556         IDPB    D,B             ; STASH\r
1557         POPJ    P,\r
1558 \r
1559 ; TSTUF -- SETLOC A TEMPLATE\r
1560 \r
1561 TSTUF:  PUSH    TP,C\r
1562         PUSH    TP,D\r
1563         MOVEI   C,0\r
1564 \r
1565 ; PUTTMP -- TEMPLATE PUTTER\r
1566 \r
1567 TMPPUT: ADDI    C,1\r
1568         PUSHJ   P,TM.TOE        ; GET E POINTING TO SLOT #\r
1569         ADD     A,TD.PUT+1(TVP) ; POINT TO INS\r
1570         MOVE    A,(A)           ; GET VECTOR OF INS\r
1571         ADDI    E,-1(A)\r
1572         POP     TP,B            ; NEW VAL TO A AND B\r
1573         POP     TP,A\r
1574         SUBI    D,1\r
1575         XCT     (E)             ; DO IT\r
1576         JRST    BADPUT\r
1577         POPJ    P,\r
1578 \r
1579 TM.LN1: SUBI    0,NUMSAT+1\r
1580         HRRZ    A,0             ; RET FIXED OFFSET\r
1581         HRLS    0\r
1582         ADD     0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST\r
1583         JUMPGE  0,BADTPL\r
1584         PUSH    P,C\r
1585         MOVE    C,B\r
1586         HRRZS   0               ; POINT TO TABLE ENTRY\r
1587         PUSH    P,A\r
1588         XCT     @0              ; DO IT\r
1589         POP     P,A\r
1590         POP     P,C\r
1591         POPJ    P,\r
1592 \r
1593 TM.TBL: MOVEI   E,(D)           ; TENTATIVE WINNER IN E\r
1594         TLNN    B,-1            ; SKIP IF REST HAIR EXISTS\r
1595         POPJ    P,              ; NO, WIN\r
1596 \r
1597         PUSH    P,A             ; SAVE OFFSET\r
1598         HRLS    A               ; A IS REL OFFSET TO INS TABLE\r
1599         ADD     A,TD.GET+1(TVP) ; GET ONEOF THE TABLES\r
1600         MOVE    A,(A)           ; TABLE POINTER TO A\r
1601         MOVSI   0,-1(D)         ; START SEEING IF PAST TEMP SPEC\r
1602         ADD     0,A\r
1603         JUMPL   0,CPOPJA        ; JUMP IF E STILL VALID\r
1604         HLRZ    E,B             ; BASIC LENGTH TO E\r
1605         HLRE    0,A             ; LENGTH OF TEMPLATE TO 0\r
1606         ADDI    0,(E)           ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE\r
1607         MOVNS   0\r
1608         SUBM    D,E             ; E ==> # PAST BASIC WANTED\r
1609         EXCH    0,E\r
1610         IDIVI   0,(E)           ; A ==> REL REST GUY WANTED\r
1611         HLRZ    E,B\r
1612         ADDI    E,1(A)\r
1613 CPOPJA: POP     P,A\r
1614         POPJ    P,\r
1615 \r
1616 ; TM.TOE -- GET RIGHT TEMPLATE # IN E\r
1617 ; C/ OBJECT #, B/ OBJECT POINTER\r
1618 \r
1619 TM.TOE: GETYP   0,(B)           ; GET REAL SAT\r
1620         MOVEI   D,(C)           ; OBJ # TO D\r
1621         HLRZ    C,B             ; REST COUNT\r
1622         ADDI    D,(C)           ; FUDGE FOR REST COUNTER\r
1623         MOVE    C,B             ; POINTER TO C\r
1624         PUSHJ   P,TM.LN1        ; GET LENGTH IN B (WATCH LH!)\r
1625         CAILE   D,(B)           ; CHECK RANGE\r
1626         JRST    OUTRNG          ; LOSER, QUIT\r
1627         JRST    TM.TBL          ; GO COMPUTE TABLE OFFSET\r
1628                 \r
1629 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B\r
1630 ; FIXES (P)\r
1631 \r
1632 CPTYEE: MOVE    E,A\r
1633         GETYP   A,A\r
1634         PUSHJ   P,CPTYPE\r
1635         JUMPE   A,COMPERR\r
1636         SUBM    M,-1(P)\r
1637         EXCH    E,A\r
1638         POPJ    P,\r
1639 \r
1640 ; COMPILER CALLS TO MANY OF THESE GUYS\r
1641 \r
1642 CIREST: PUSHJ   P,CPTYEE        ; TYPE OF DISP TO E\r
1643         JUMPL   C,OUTRNG\r
1644         CAIN    0,SSTORE\r
1645         JRST    CIRST1\r
1646         PUSHJ   P,@RESTBL(E)\r
1647         JRST    MPOPJ\r
1648 \r
1649 CIRST1: PUSHJ   P,STORST\r
1650         JRST    MPOPJ\r
1651 \r
1652 CINTH:  PUSHJ   P,CPTYEE\r
1653         SOJL    C,OUTRNG        ; CHECK BOUNDS\r
1654         PUSHJ   P,@NTHTBL(E)\r
1655         JRST    MPOPJ\r
1656 \r
1657 CIAT:   PUSHJ   P,CPTYEE\r
1658         SOJL    C,OUTRNG\r
1659         PUSHJ   P,@ATTBL(E)\r
1660         JRST    MPOPJ\r
1661 \r
1662 CSETLO: PUSHJ   P,CTYLOC\r
1663         MOVSS   E               ; REAL DISPATCH\r
1664         GETYP   0,A             ; INCASE LOCAS OR LOCD\r
1665         PUSH    TP,C\r
1666         PUSH    TP,D\r
1667         PUSHJ   P,@SETTBL(E)\r
1668         POP     TP,B\r
1669         POP     TP,A\r
1670         JRST    MPOPJ\r
1671 \r
1672 CIN:    PUSHJ   P,CTYLOC\r
1673         MOVSS   E               ; REAL DISPATCH\r
1674         GETYP   C,A\r
1675         PUSHJ   P,@INTBL(E)\r
1676         JRST    MPOPJ\r
1677 \r
1678 CTYLOC: MOVE    E,A\r
1679         GETYP   A,A\r
1680         PUSHJ   P,CPTYPE\r
1681         SUBM    M,-1(P)\r
1682         EXCH    A,E\r
1683         POPJ    P,\r
1684 \r
1685 ; COMPILER'S PUT,GET AND GETL\r
1686 \r
1687 CIGET:  PUSH    P,[0]\r
1688         JRST    .+2\r
1689 \r
1690 CIGETL: PUSH    P,[1]\r
1691         MOVE    E,A\r
1692         GETYP   A,A\r
1693         PUSHJ   P,CPTYPE\r
1694         EXCH    A,E\r
1695         JUMPE   E,CIGET1        ; REAL GET, NOT NTH\r
1696         GETYP   0,C             ; INDIC FIX?\r
1697         CAIE    0,TFIX\r
1698         JRST    CIGET1\r
1699         POP     P,E             ; GET FLAG\r
1700         AOS     (P)             ; ALWAYS SKIP\r
1701         MOVE    C,D             ; # TO AN AC\r
1702         JRST    @.+1(E)\r
1703                 CINTH\r
1704                 CIAT\r
1705 \r
1706 CIGET1: POP     P,E             ; GET FLAG\r
1707         JRST    @GETTR(E)       ; DO A REAL GET\r
1708 \r
1709 GETTR:          CIGTPR\r
1710                 CIGETP\r
1711 \r
1712 CIPUT:  SUBM    M,(P)\r
1713         MOVE    E,A\r
1714         GETYP   A,A\r
1715         PUSHJ   P,CPTYPE\r
1716         EXCH    A,E\r
1717         PUSH    TP,-1(TP)               ; PAIN AND SUFFERING\r
1718         PUSH    TP,-1(TP)\r
1719         MOVEM   A,-3(TP)\r
1720         MOVEM   B,-2(TP)\r
1721         JUMPE   E,CIPUT1\r
1722         GETYP   0,C\r
1723         CAIE    0,TFIX          ; YES DO STRUCT\r
1724         JRST    CIPUT1\r
1725         MOVE    C,D\r
1726         SOJL    C,OUTRNG        ; CHECK BOUNDS\r
1727         PUSHJ   P,@IPUTBL(E)\r
1728 PMPOPJ: POP     TP,B\r
1729         POP     TP,A\r
1730         JRST    MPOPJ\r
1731 \r
1732 CIPUT1: PUSHJ   P,IPUT\r
1733         JRST    PMPOPJ\r
1734 \f\r
1735 ; SMON -- SET MONITOR BITS\r
1736 ;       B/ <POINTER TO LOCATIVE>\r
1737 ;       D/ <IORM> OR <ANDCAM>\r
1738 ;       E/ BITS\r
1739 \r
1740 SMON:   GETYP   A,(B)\r
1741         PUSHJ   P,PTYPE         ; TO PRIM TYPE\r
1742         HLRZS   A\r
1743         SKIPE   A,SMONTB(A)     ; DISPATCH?\r
1744         JRST    (A)\r
1745 \r
1746 ; COULD STILL BE LOCN OR LOCD\r
1747 \r
1748         GETYP   A,(B)           ; TYPE BACK\r
1749         CAIE    A,TLOCN\r
1750         JRST    SMON2           ; COULD BE LOCD\r
1751         MOVE    C,1(B)          ; POINT\r
1752         HRRI    D,VAL(C)        ; MAKE INST POINT\r
1753         JRST    SMON3\r
1754 \r
1755 SMON2:  CAIE    A,TLOCD\r
1756         JRST    WRONGT\r
1757 \r
1758 \r
1759 ; SET LIST/TUPLE/ID LOCATIVE\r
1760 \r
1761 SMON4:  HRR     D,1(B)          ; POINT TO TYPE WORD\r
1762 SMON3:  XCT     D\r
1763         POPJ    P,\r
1764 \r
1765 ; SET UVEC LOC\r
1766 \r
1767 SMON5:  HRRZ    C,1(B)          ; POINT TO TOP OF UV\r
1768         HLRE    0,1(B)\r
1769         SUB     C,0             ; POINT TO DOPE\r
1770         HRRI    D,(C)           ; POINT IN INST\r
1771         JRST    SMON3\r
1772 \r
1773 ; SET CHSTR LOC\r
1774 \r
1775 SMON6:  MOVEI   C,(B)           ; FOR BYTDOP\r
1776         PUSHJ   P,BYTDOP        ; POINT TO DOPE\r
1777         HRRI    D,(A)-1\r
1778         JRST    SMON3\r
1779 \r
1780 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]\r
1781 [PNWORD,SMON5],[PCHSTR,SMON6]]\r
1782 \r
1783 \f\r
1784 ; COMPILER'S MONAD?\r
1785 \r
1786 CIMON:  PUSH    P,A\r
1787         GETYP   A,A\r
1788         PUSHJ   P,CPTYPE\r
1789         JUMPE   A,CIMON1\r
1790         POP     P,A\r
1791         JRST    CEMPTY\r
1792 \r
1793 CIMON1: POP     P,A\r
1794         JRST    YES\r
1795 \r
1796 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE\r
1797 \r
1798 MFUNCTION MONAD,SUBR,MONAD?\r
1799 \r
1800         ENTRY   1\r
1801 \r
1802         MOVE    B,AB            ; CHECK PRIM TYPE\r
1803         PUSHJ   P,PTYPE\r
1804         JUMPE   A,ITRUTH                ;RETURN ARGUMENT\r
1805         SKIPE   B,1(AB)\r
1806         JRST    @MONTBL(A)      ;DISPATCH ON PTYPE\r
1807         JRST    ITRUTH\r
1808 \r
1809 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]\r
1810 [PCHSTR,CHMON],[PTMPLT,TMPMON]]\r
1811 \r
1812 MON1:   JUMPGE  B,ITRUTH                ;EMPTY VECTOR\r
1813         JRST    IFALSE\r
1814 \r
1815 CHMON:  HRRZ    B,(AB)\r
1816         JUMPE   B,ITRUTH\r
1817         JRST    IFALSE\r
1818 \r
1819 TMPMON: PUSHJ   P,LNTMPL\r
1820         JUMPE   B,ITRUTH\r
1821         JRST    IFALSE\r
1822 \r
1823 CISTRU: GETYP   A,A             ; COMPILER CALL\r
1824         PUSHJ   P,ISTRUC\r
1825         JRST    NO\r
1826         JRST    YES\r
1827 \r
1828 ISTRUC: PUSHJ   P,SAT           ; STORAGE TYPE\r
1829         SKIPE   A,PRMTYP(A)\r
1830         AOS     (P)             ; SKIP IF WINS\r
1831         POPJ    P,\r
1832 \r
1833 ; SUBR TO CHECK FOR LOCATIVE\r
1834 \r
1835 MFUNCTION %LOCA,SUBR,[LOCATIVE?]\r
1836 \r
1837         ENTRY   1\r
1838         GETYP   A,(AB)  \r
1839         PUSHJ   P,LOCQQ\r
1840         JRST    IFALSE\r
1841         JRST    ITRUTH\r
1842 \r
1843 ; SKIPS IF TYPE IN A IS A LOCATIVE\r
1844 \r
1845 LOCQ:   GETYP   A,(B)           ; GET TYPE\r
1846 LOCQQ:  PUSH    P,A             ; SAVE FOR LOCN/LOCD\r
1847         PUSHJ   P,SAT\r
1848         MOVE    A,PRMTYP(A)\r
1849         JUMPE   A,LOCQ1\r
1850         SUB     P,[1,,1]\r
1851         TRNN    A,-1\r
1852 LOCQ2:  AOS     (P)\r
1853         POPJ    P,\r
1854 \r
1855 LOCQ1:  POP     P,A             ; RESTORE TYPE\r
1856         CAIE    A,TLOCN\r
1857         CAIN    A,TLOCD\r
1858         JRST    LOCQ2\r
1859         POPJ    P,\r
1860 \r
1861 \f\r
1862 ; MUDDLE SORT ROUTINE\r
1863 \r
1864 ; P-STACK OFFSETS MUDDLE SORT ROUTINE\r
1865 \r
1866 ; P-STACK OFFSETS FOR THIS PROGRAM\r
1867 \r
1868 XCHNG==0                ; FLAG SAYING AN EXCHANGE HAS HAPPENED\r
1869 PLACE==-1               ; WHERE WE ARE NOW\r
1870 UTYP==-2                ; TYPE OF UNIFORM VECTOR\r
1871 DELT==-3                ; DIST BETWEEN COMPARERS\r
1872 \r
1873 MFUNCTION SORT,SUBR\r
1874 \r
1875         ENTRY\r
1876 \r
1877         HLRZ    0,AB            ; CHECK FOR ENOUGH ARGS\r
1878         CAILE   0,-4\r
1879         JRST    TFA\r
1880         GETYP   A,(AB)          ; 1ST MUST EITHER BE FALSE OR APPLICABLE\r
1881         CAIN    A,TFALSE\r
1882         JRST    SORT1           ; FALSE, OK\r
1883         PUSHJ   P,APLQ          ; IS IT APPLICABLE\r
1884         JRST    NAPT            ; NO, LOSER\r
1885 \r
1886 SORT1:  MOVE    B,AB\r
1887         ADD     B,[2,,2]        ; BUMP TO POINT TO MAIN ARRAY\r
1888         SETZB   D,E             ; 0 # OF STUCS AND LNTH\r
1889 \r
1890 SORT2:  GETYP   A,(B)           ; GET ITS TYPE\r
1891         PUSHJ   P,PTYPE         ; IS IT STRUCTURED?\r
1892         MOVEI   C,1             ; CHECK TYPE OF STRUC\r
1893         CAIN    A,PNWORD        ; UVEC?\r
1894         MOVEI   C,0             ; YUP\r
1895         CAIE    A,PARGS\r
1896         CAIN    A,P2NWORD       ; VECTOR\r
1897         MOVNI   C,1\r
1898         JUMPG   C,WTYP\r
1899         PUSH    TP,(B)          ; PUSH IT\r
1900         PUSH    TP,1(B)\r
1901         ADD     B,[2,,2]        ; GO ON\r
1902         MOVEI   A,1             ; DEFAULT REC SIZE\r
1903         PUSHJ   P,NXFIX         ; SIZE OF RECORD?\r
1904         HLRZ    0,-2(TP)        ; -LNTH OF STUC\r
1905         HRRZ    A,(TP)          ; LENGTH OF REC\r
1906         IDIVI   0,(A)           ; DIV TO GET - # OF RECS\r
1907         SKIPN   D               ; PREV LENGTH EXIST?\r
1908         MOVE    D,0             ; NO USE THIS\r
1909         CAME    0,D\r
1910         JRST    SLOSE0\r
1911         MOVEI   A,0             ; DEF REC SIZE\r
1912         PUSHJ   P,NXFIX         ; AND OFFSET OF KEY\r
1913         SUBI    E,1\r
1914         JUMPL   B,SORT2         ; GO ON\r
1915         HRRM    E,4(TB)         ; SAVE THAT IN APPROPRIATE PLACE\r
1916 \r
1917         MOVE    0,3(TB)\r
1918         CAMG    0,5(TB)         ; CHECK FOR BAD OFFSET\r
1919         JRST    SLOSE3\r
1920 \r
1921 ; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS\r
1922 \r
1923         HLRE    B,1(TB)         ; COMP LENGTH\r
1924         MOVNS   B\r
1925         HRRZ    C,2(TB)         ; GET VEC/UVEC FLAG\r
1926         MOVEI   D,(B)\r
1927         ASH     B,(C)           ; FUDGE\r
1928         JUMPE   C,.+3           ; SKIP FOR UVEC\r
1929         MOVE    0,[1,,1]        ; ELSE FUDGE KEY OFFSET\r
1930         ADDM    0,5(TB)\r
1931         HRRZ    0,3(TB)         ; GET REC LENGTH\r
1932         IDIV    D,0             ; # OF RECS\r
1933         JUMPN   E,SLOSE4\r
1934         CAIG    D,1             ; MORE THAN 1?\r
1935         JRST    SORTD           ; NO, DONE ALREADY\r
1936         GETYP   0,(AB)          ; TYPE OF COMPARER\r
1937         CAIE    0,TFALSE        ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING\r
1938         JRST    SORT3           ; USER SUPPLIED COMPARER, LET HIM WORRY\r
1939 \r
1940 ; NOW CHECK OUT ELEMENT TYPES\r
1941 \r
1942         JUMPN   C,SORT5         ; JUMP IF GENERAL\r
1943         MOVEI   D,1(B)          ; FIND END OF VECTOR\r
1944         ADD     D,1(TB)         ; D POINTS TO END\r
1945         PUSHJ   P,TYPCH1        ; GET TYPE AND CHECK IT\r
1946         JRST    SORT6\r
1947 \r
1948 SORT5:  MOVE    D,1(TB)         ; POINT TO VEC\r
1949         ADD     D,5(TB)         ; INTO REC TO KEY\r
1950         PUSHJ   P,TYPCH1\r
1951 \r
1952 SAMELP: GETYP   C,-1(D)         ; GET TYPE\r
1953         CAIE    0,(C)           ; COMPARE TYPE\r
1954         JRST    SLOSE2\r
1955         ADD     D,3(TB)         ; TO NEXT RECORD\r
1956         JUMPL   D,SAMELP\r
1957 \r
1958 SORT6:  CAIE    A,S1WORD        ; 1 WORDS?\r
1959         JRST    SORT7\r
1960         MOVEI   E,INTSRT\r
1961         MOVSI   A,400000        ; SET UP MASK\r
1962 SORT9:  PUSHJ   P,ISORT\r
1963         MOVE    A,2(AB)\r
1964         MOVE    B,3(AB)\r
1965         JRST    FINIS\r
1966 \r
1967 SORT7:  CAIE    A,SATOM         ; ATOMS?\r
1968         JRST    SORT8\r
1969         MOVE    E,[-3,,ATMSRT]  ; SET UP FOR ATOMS\r
1970         MOVE    A,[430140,,3(D)]        ; BIT POINTER FOR ATOMS\r
1971         JRST    SORT9\r
1972 \r
1973 SORT8:  MOVE    E,[1,,STRSRT]   ; MUST BE STRING SORT\r
1974         MOVE    A,[430140,,(D)] ; BYTE POINTER FOR STRINGER\r
1975         JRST    SORT9\r
1976 \r
1977 ; TABLES FOR RADIX SORT CHECKERS\r
1978 \r
1979 INTSRT==0\r
1980 ATMSRT==1\r
1981 STRSRT==2\r
1982 \r
1983 TST1:   PUSHJ   P,I.TST1\r
1984         PUSHJ   P,A.TST1\r
1985         PUSHJ   P,S.TST1\r
1986 \r
1987 TST2:   PUSHJ   P,I.TST2\r
1988         PUSHJ   P,A.TST2\r
1989         PUSHJ   P,S.TST2\r
1990 \r
1991 NXBIT:  ROT     A,-1\r
1992         PUSHJ   P,A.NXBI\r
1993         PUSHJ   P,S.NXBI\r
1994 \r
1995 PREBIT: ROT     A,1\r
1996         PUSHJ   P,A.PREB\r
1997         PUSHJ   P,S.PREB\r
1998 \r
1999 ENDTST: SKIPGE  A\r
2000         TLOE    A,40\r
2001         TLOE    A,40\r
2002 \r
2003 ; INTEGER SORT SPECIFIC ROUTINES\r
2004 \r
2005 I.TST1: JUMPL   A,I.TST3\r
2006 I.TST4: TDNE    A,(D)\r
2007         AOS     (P)\r
2008         POPJ    P,\r
2009 \r
2010 I.TST2: JUMPL   A,I.TST4\r
2011 I.TST3: TDNN    A,(D)\r
2012         AOS     (P)\r
2013         POPJ    P,\r
2014 \r
2015 ; ATOM SORT SPECIFIC ROUTINES\r
2016 \r
2017 A.TST1: MOVE    D,(D)           ; GET AN ATOM\r
2018         CAMG    E,D             ; SKIP IF NOT EXHAUSTED\r
2019         POPJ    P,\r
2020         TLZ     A,40            ; TELL A BIT HAS HAPPENED\r
2021         LDB     D,A             ; GET THE BIT\r
2022         SKIPE   D\r
2023         AOS     (P)             ; SKIP IF ON\r
2024         POPJ    P,\r
2025 \r
2026 A.TST2: PUSHJ   P,A.TST1        ; USE OTHER ROUTINE\r
2027         AOS     (P)\r
2028         POPJ    P,\r
2029 \r
2030 A.NXBI: TLNN    A,770000        ; CHECK FOR WORD CHANGE\r
2031         SUB     E,[1,,0]        ; FIX WORD CHECKER\r
2032         IBP     A\r
2033         POPJ    P,\r
2034 \r
2035 A.PREB: ADD     A,[10000,,]     ; AH FOR A DECR BYTE POINTER\r
2036         SKIPG   A\r
2037         CAMG    A,[437777,,-1]  ; SKIP IF BACKED OVER WORD\r
2038         POPJ    P,\r
2039         TLZ     A,770000        ; CLOBBER POSIT FIELD\r
2040         SUBI    A,1             ; DECR WORD POS FIELD\r
2041         ADD     E,[1,,0]        ; AND FIX WORD HACKER\r
2042         POPJ    P,\r
2043 \r
2044 ; STRING SPECIFIC SORT ROUTINES\r
2045 \r
2046 S.TST1: HRLZ    0,-1(D)         ; LENGTH OF STRING\r
2047         IMULI   0,7             ; IN BITS\r
2048         HRRI    0,-1            ; MAKE SURE BIGGER RH\r
2049         CAMG    0,E             ; SKIP IF MORE BITS LEFT\r
2050         POPJ    P,              ; DON TSKIP\r
2051         TLZ     A,40            ; BIT FOUND\r
2052         HLRZ    0,(D)           ; CHECK FOR SIMPLE CASE\r
2053         HRRZ    D,(D)           ; POINT TO STRING\r
2054         CAIN    0,440700        ; SKIP IF HAIRY\r
2055         JRST    S.TST3\r
2056 \r
2057         PUSH    P,A             ; SAVE BYTER\r
2058         MOVEI   A,440700        ; COMPUTE BITS NOT USED 1ST WORD\r
2059         SUBI    A,@0\r
2060         HLRZ    0,(P)           ; GET BIT POINTER\r
2061         SUBI    0,(A)           ; UPDATE POS FIELD\r
2062         JUMPGE  0,.+2           ; NO NEED FOR NEXT WORD\r
2063         ADD     0,[1,,440000]\r
2064         MOVSS   0\r
2065         HRRZ    A,(P)   ; REBUILD BYTE POINTER\r
2066         ADDI    0,(A)\r
2067         LDB     0,0             ; GET THE DAMN BYTE\r
2068         POP     P,A\r
2069         JRST    .+2\r
2070 \r
2071 S.TST3: LDB     0,A             ; GET BYTE FOR EASY CASE\r
2072         SKIPE   0\r
2073         AOS     (P)\r
2074         POPJ    P,\r
2075 \r
2076 S.TST2: PUSHJ   P,S.TST1\r
2077         AOS     (P)\r
2078         POPJ    P,\r
2079 \r
2080 S.NXBI: IBP     A               ; BUMP BYTER\r
2081         TLNN    A,770000        ; SKIP IF NOT END BIT\r
2082         IBP     A               ; SKIP END BIT (NOT USED IN ASCII STRINGS)\r
2083         ADD     E,[1,,0]        ; COUNT BIT\r
2084         POPJ    P,\r
2085 \r
2086 S.PREB: SUB     E,[1,,0]        ; DECR CHAR COUNT\r
2087         ADD     A,[10000,,0]    ; PLEASE GIVE ME A DECRBYTEPNTR\r
2088         SKIPG   A\r
2089         CAMG    A,[437777,,-1]\r
2090         POPJ    P,\r
2091         TLC     A,450000        ; POINT TO LAST USED BIT IN WORD\r
2092         SUBI    A,1\r
2093         POPJ    P,\r
2094 \r
2095 ; SIMPLE RADIX EXCHANGE\r
2096 \r
2097 ISORT:  MOVE    B,1(TB)         ; START OF VECTOR\r
2098         HLRE    D,B             ; COMPUTE POINTER TO END OF IT\r
2099         SUBM    B,D             ; FIND END\r
2100         MOVEI   C,(D)\r
2101 \r
2102 ISORT1: PUSH    TP,(TB)\r
2103         PUSH    TP,C\r
2104         MOVE    0,C             ; SEE IF HAVE MET AT MIDDLE\r
2105         SUB     0,3(TB)\r
2106         ANDI    0,-1\r
2107         CAIGE   0,(B)\r
2108         JRST    ISORT7          ; HAVE MET, LEAVE\r
2109         PUSH    TP,(TB)         ; SAVE OTHER POINTER\r
2110         PUSH    TP,B\r
2111 \r
2112         INTGO\r
2113         MOVE    B,(TP)          ; IN CASE MOVED\r
2114         MOVE    C,-2(TP)\r
2115 \r
2116 ISORT3: HRRZ    D,5(TB)         ; OFFSET TO KEY\r
2117         ADDI    D,(B)           ; POINT TO KEY\r
2118         XCT     TST1(E)         ; CHECK FOR LOSER\r
2119         JRST    ISORT4\r
2120         SUB     C,3(TB)         ; IS THERE ONE TO EXCHANGE WITH\r
2121         HRRZ    D,5(TB)\r
2122         ADDI    D,(C)\r
2123         XCT     TST2(E)         ; SKIP IF A POSSIBLE EXCHANGE\r
2124         JRST    ISORT2          ; NO EXCH, KEEP LOOKING\r
2125 \r
2126         PUSHJ   P,EXCHM         ; DO THE EXCHANGE\r
2127 \r
2128 ISORT4: ADD     B,3(TB)         ; HAVE EXCHANGED, MOVE ON\r
2129 ISORT2: CAME    B,C             ; MET?\r
2130         JRST    ISORT3          ; MORE TO CHECK\r
2131         XCT     NXBIT(E)        ; NEXT BIT\r
2132         MOVE    B,(TP)          ; RESTORE TOP POINTER\r
2133         SUB     TP,[2,,2]       ; FLUSH IT\r
2134         XCT     ENDTST(E)\r
2135         JRST    ISORT6\r
2136         PUSHJ   P,ISORT1        ; SORT SUB AREA\r
2137         MOVE    C,(TP)          ; AND OTHER SUB AREA\r
2138         PUSHJ   P,ISORT1\r
2139 ISORT6: XCT     PREBIT(E)\r
2140 ISORT7: MOVE    B,(TP)\r
2141         SUB     TP,[2,,2]\r
2142         POPJ    P,\r
2143 \r
2144 ; SCHELL SORT FOR USER SUPPLIED COMPARER\r
2145 \r
2146 SORT3:  ADDI    D,1\r
2147         ASH     D,-1            ; COMPUTE INITIAL D\r
2148         PUSH    P,D             ; AND SAVE IT\r
2149         PUSH    P,[0]           ; MAY HOLD UTYPE OF VECTOR\r
2150         HRRZ    0,(TB)          ; 0 NON ZERO MEANS GEN VECT\r
2151         JUMPN   0,SSORT1        ; DONT COMPUTE UTYPE\r
2152         HLRE    C,1(TB)\r
2153         HRRZ    D,1(TB)         ; FIND TYPE\r
2154         SUBI    D,(C)\r
2155         GETYP   D,(D)\r
2156         MOVSM   D,(P)           ; AND SAVE\r
2157 SSORT1: PUSH    P,[0]           ; CURRENT PLACE IN VECTOR\r
2158         PUSH    P,[0]           ; EXCHANGE FLAG\r
2159         PUSH    TP,[0]\r
2160         PUSH    TP,[0]\r
2161 \r
2162 ; OUTER LOOP STARTS HERE\r
2163 \r
2164 OUTRLP: SETZM   XCHNG(P)        ; NO EXHCANGE YET\r
2165         SETZM   PLACE(P)\r
2166 \r
2167 INRLP:  PUSH    TP,(AB)         ; PUSH USER COMPARE FCN\r
2168         PUSH    TP,1(AB)\r
2169         MOVE    C,PLACE(P)      ; GET CURRENT PLACE\r
2170         ADD     C,1(TB)         ; ADD POINTER TO VEC IN\r
2171         ADD     C,5(TB)         ; OFFSET TO KEY\r
2172         PUSHJ   P,GETELM\r
2173         MOVE    D,3(TB)\r
2174         IMUL    D,DELT(P)       ; TIMES WORDS PER REC\r
2175         ADD     C,D\r
2176         PUSHJ   P,GETELM\r
2177         MCALL   3,APPLY         ; APPLY IT\r
2178         GETYP   0,A             ; TYPE OF RETURN\r
2179         CAIN    0,TFALSE        ; SKIP IF MUST CHANGE\r
2180         JRST    INRLP1\r
2181 \r
2182         MOVE    C,1(TB)         ; POINT TO START\r
2183         ADD     C,PLACE(P)\r
2184         MOVE    B,3(TB)\r
2185         IMUL    B,DELT(P)\r
2186         ADD     B,C\r
2187         PUSHJ   P,EXCHM         ; EXCHANGE THEM\r
2188         SETOM   XCHNG(P)        ; SAY AN EXCHANGE TOOK PLACE\r
2189 \r
2190 INRLP1: MOVE    C,3(TB)         ; GET OFFSET\r
2191         ADDB    C,PLACE(P)\r
2192         MOVE    D,3(TB)\r
2193         IMUL    D,DELT(P)\r
2194         ADD     C,D             ; CHECK FOR OVERFLOW\r
2195         ADD     C,1(TB)\r
2196         JUMPL   C,INRLP\r
2197         SKIPE   XCHNG(P)        ; ANY EXCHANGES?\r
2198         JRST    OUTRLP          ; YES, RESET PLACE AND GO\r
2199         SOSG    D,DELT(P)       ; SKIP IF DIST WAS 1\r
2200         JRST    SORTD\r
2201         ADDI    D,2             ; COMPUTE NEW DIST\r
2202         ASH     D,-1\r
2203         MOVEM   D,DELT(P)\r
2204         JRST    OUTRLP\r
2205 \r
2206 SORTD:  MOVE    A,2(AB)         ; DONE, RET 1ST STRUC\r
2207         MOVE    B,3(AB)\r
2208         JRST    FINIS\r
2209 \r
2210 ; ROUTINE TO GET NEXT ARG IF ITS FIX\r
2211 \r
2212 NXFIX:  JUMPGE  B,NXFIX1        ; NONE LEFT, USE DEFAULT\r
2213         GETYP   0,(B)           ; TYPE\r
2214         CAIE    0,TFIX          ; FIXED?\r
2215         JRST    NXFIX1          ; NO, USE DEFAULT\r
2216         MOVE    A,1(B)          ; GET THE NUMBER\r
2217         ADD     B,[2,,2]        ; BUMP TO NEXT ARG\r
2218 NXFIX1: HRLI    C,TFIX\r
2219         TRNE    C,-1            ; SKIP IF UV\r
2220         ASH     A,1             ; FUDGE FOR VEC/UVEC\r
2221         HRLI    A,(A)\r
2222         PUSH    TP,C\r
2223         PUSH    TP,A\r
2224         POPJ    P,\r
2225 \r
2226 GETELM: SKIPN   A,UTYP-1(P)     ; SKIP IF UVECT\r
2227         MOVE    A,-1(C)         ; GGET GEN TYPE\r
2228         PUSH    TP,A\r
2229         PUSH    TP,(C)\r
2230         POPJ    P,\r
2231 \r
2232 TYPCH1: GETYP   A,-1(D)         ; GET TYPE\r
2233         MOVEI   0,(A)           ; SAVE IN 0\r
2234         PUSHJ   P,SAT           ; AND SAT\r
2235         CAIE    A,SCHSTR        ; STRING\r
2236         CAIN    A,SATOM\r
2237         POPJ    P,\r
2238         CAIN    A,S1WORD        ; 1-WORD GOODIE\r
2239         POPJ    P,\r
2240         JRST    SLOSE1\r
2241 \r
2242 ; HERE TO DO EXCHANGE\r
2243 \r
2244 EXCHM:  PUSH    P,E\r
2245         PUSH    P,A             ; SAVE VITAL ACS\r
2246         PUSH    P,B\r
2247         PUSH    P,C\r
2248         SUB     B,1(TB)         ; COMPUTE RECORD #\r
2249         HLRZS   B               ; TO RH\r
2250         HRRZ    0,3(TB)         ; GET REC LENGTH\r
2251         IDIV    B,0             ; DIV BY REC LENGTH\r
2252         MOVE    C,(P)\r
2253         SUB     C,1(TB)         ; SAME FOR C\r
2254         HLRZS   C\r
2255         IDIV    C,0             ; NOW HAVE OTHER RECORD\r
2256 \r
2257         HRRE    D,4(TB)         ; - # OF STUCS\r
2258         MOVSI   D,(D)           ; MAKE AN AOBJN POINTER\r
2259         HRRI    D,(TB)          ; TO TEMPPS\r
2260 \r
2261 RECLP:  HRRZ    0,3(D)          ; GET REC LENGTH\r
2262         MOVN    E,3(D)          ; NOW AOBJN TO REC\r
2263         MOVSI   E,(E)\r
2264         HRR     E,1(D)\r
2265         MOVEI   A,(C)           ; COMP START OF REC\r
2266         IMUL    A,0             ; TIMES REC LENGTH\r
2267         ADDI    E,(A)\r
2268         MOVEI   A,(B)\r
2269         IMUL    A,0\r
2270         ADD     A,1(D)          ; POINT TO OTHER RECORD\r
2271 \r
2272 EXCHLP: EXCH    0,(A)\r
2273         EXCH    0,(E)\r
2274         EXCH    0,(A)\r
2275         ADDI    A,1\r
2276         AOBJN   E,EXCHLP\r
2277 \r
2278         ADD     D,[1,,6]        ; TO NEXT STRUC\r
2279         JUMPL   D,RECLP         ; IF MORE\r
2280 \r
2281         POP     P,C\r
2282         POP     P,B\r
2283         POP     P,A\r
2284         POP     P,E\r
2285         POPJ    P,\r
2286 \f\r
2287 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS\r
2288 \r
2289 MFUNCTION MEMBER,SUBR\r
2290 \r
2291         MOVE    E,[PUSHJ P,EQLTST]      ;TEST ROUTINE IN E\r
2292         JRST    MEMB\r
2293 \r
2294 MFUNCTION MEMQ,SUBR\r
2295 \r
2296         MOVE    E,[PUSHJ P,EQTST]       ;EQ TESTER\r
2297 \r
2298 MEMB:   ENTRY   2\r
2299         MOVE    B,AB            ;POINT TO FIRST ARG\r
2300         PUSHJ   P,PTYPE         ;CHECK PRIM TYPE\r
2301         ADD     B,[2,,2]        ;POINT TO 2ND ARG\r
2302         PUSHJ   P,PTYPE\r
2303         JUMPE   A,WTYP2         ;2ND WRONG TYPE\r
2304         PUSH    TP,(AB)\r
2305         PUSH    TP,1(AB)\r
2306         MOVE    C,2(AB)         ; FOR TUPLE CASE\r
2307         SKIPE   B,3(AB)         ;GOBBLE LIST VECTOR ETC. POINTER\r
2308         PUSHJ   P,@MEMTBL(A)    ;DISPATCH\r
2309         JRST    IFALSE          ;OR REPORT LOSSAGE\r
2310         JRST    FINIS\r
2311 \r
2312 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]\r
2313 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]]\r
2314 \r
2315 \r
2316 \r
2317 MEMLST: MOVSI   0,TLIST         ;SET B'S TYPE TO LIST\r
2318         MOVEM   0,BSTO(PVP)\r
2319         JUMPE   B,MEMLS6        ; EMPTY LIST LOSE IMMEDIATE\r
2320 \r
2321 MEMLS1: INTGO                   ;CHECK INTERRUPTS\r
2322         MOVEI   C,(B)           ;COPY POINTER\r
2323         GETYP   D,(C)           ;GET TYPE\r
2324         MOVSI   A,(D)           ;COPY\r
2325         CAIE    D,TDEFER                ;DEFERRED?\r
2326         JRST    MEMLS2\r
2327         MOVE    C,1(C)          ;GET DEFERRED DATUM\r
2328         GETYPF  A,(C)           ;GET FULL TYPE WORD\r
2329 MEMLS2: MOVE    C,1(C)          ;GET DATUM\r
2330         XCT     E               ;DO THE COMPARISON\r
2331         JRST    MEMLS3          ;NO MATCH\r
2332         MOVSI   A,TLIST\r
2333 MEMLS5: AOS     (P)\r
2334 MEMLS6: SETZM   BSTO(PVP)               ;RESET B'S TYPE\r
2335         POPJ    P,\r
2336 \r
2337 MEMLS3: HRRZ    B,(B)           ;STEP THROGH\r
2338         JUMPN   B,MEMLS1        ;STILL MORE TO DO\r
2339 MEMLS4: MOVSI   A,TFALSE        ;RETURN FALSE\r
2340         JRST    MEMLS6          ;RETURN 0\r
2341 \r
2342 MEMTUP: HRRZ    A,C\r
2343         TLOA    A,TARGS\r
2344 MEMVEC: MOVSI   A,TVEC          ;CLOBBER B'S TYPE TO VECTOR\r
2345         JUMPGE  B,MEMLS4        ;EMPTY VECTOR\r
2346         MOVEM   A,BSTO(PVP)\r
2347 \r
2348 MEMV1:  INTGO                   ;CHECK FOR INTS\r
2349         GETYPF  A,(B)           ;GET FULL TYPE\r
2350         MOVE    C,1(B)          ;AND DATA\r
2351         XCT     E               ;DO COMPARISON INS\r
2352         JRST    MEMV2           ;NOT EQUAL\r
2353         MOVE    A,BSTO(PVP)\r
2354         JRST    MEMLS5          ;RETURN WITH POINTER\r
2355 \f\r
2356 MEMV2:  ADD     B,[2,,2]        ;INCREMENT AND GO\r
2357         JUMPL   B,MEMV1         ;STILL WINNING\r
2358 MEMV3:  MOVEI   B,0\r
2359         JRST    MEMLS4          ;AND RETURN FALSE\r
2360 \r
2361 MUVEC:  JUMPGE  B,MEMLS4\r
2362         GETYP   A,-1(TP)        ;GET TYPE OF GODIE\r
2363         HLRE    C,B             ;LOOK FOR UNIFORM TYPE\r
2364         SUBM    B,C             ;DOPE POINTER TO C\r
2365         GETYP   C,(C)           ;GET THE TYPE\r
2366         CAIE    A,(C)           ;ARE THEY THE SAME?\r
2367         JRST    MEMLS4          ;NO, LOSE\r
2368         MOVSI   A,TUVEC\r
2369         CAIN    0,SSTORE\r
2370         MOVSI   A,TSTORA\r
2371         PUSH    P,A\r
2372         MOVEM   A,BSTO(PVP)\r
2373         MOVSI   A,(C)           ;TYPE TO LH\r
2374         PUSH    P,A             ; SAVE FOR EACH TEST\r
2375 \r
2376 MUVEC1: INTGO                   ;CHECK OUT INTS\r
2377         MOVE    C,(B)           ;GET DATUM\r
2378         MOVE    A,(P)           ; GET TYPE\r
2379         XCT     E               ;COMPARE\r
2380         AOBJN   B,MUVEC1        ;LOOP TO WINNAGE\r
2381         SUB     P,[1,,1]\r
2382         POP     P,A\r
2383         JUMPGE  B,MEMV3         ;LOSE RETURN\r
2384 \r
2385 MUVEC2: JRST    MEMLS5\r
2386 \r
2387 \r
2388 MEMCH:  GETYP   A,-1(TP)                ;IS ARG A SINGLE CHAR\r
2389         CAIE    A,TCHRS         ;SKIP IF POSSIBLE WINNER\r
2390         JRST    MEMSTR\r
2391         MOVEI   0,(C)\r
2392         MOVE    D,(TP)          ; AND CHAR\r
2393 \r
2394 MEMCH1: SOJL    0,MEMV3\r
2395         MOVE    E,B\r
2396         ILDB    A,B\r
2397         CAIE    A,(D)           ;CHECK IT\r
2398         SOJA    C,MEMCH1\r
2399 \r
2400 MEMCH2: MOVE    B,E\r
2401         MOVE    A,C\r
2402         JRST    MEMLS5\r
2403 \r
2404 MEMSTR: CAME    E,[PUSHJ P,EQLTST]\r
2405         JRST    MEMV3\r
2406         HLRZ    A,C\r
2407         CAIE    A, TCHSTR       ; A SHOULD HAVE TCHSTR IN RIGHT HALF\r
2408         JRST    MEMV3\r
2409         MOVEI   0,(C)           ; GET # OF CHAR INTO 0\r
2410         ILDB    D,(TP)\r
2411         PUSH    P,D             ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK\r
2412 \r
2413 MEMST1: SOJL    0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR\r
2414         MOVE    E,B\r
2415         ILDB    A,B\r
2416         CAME    A,(P)\r
2417         SOJA    C,MEMST1        ; MATCH FAILS TRY NEXT\r
2418 \r
2419         PUSH    P,B\r
2420         PUSH    P,E\r
2421         PUSH    P,C\r
2422         PUSH    P,0\r
2423         MOVE    E,(TP)          ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP\r
2424         HRRZ    C,-1(TP)        ; LENGTH OF 1ARG\r
2425 MEMST2: SOJE    C,MEMWN         ; WON -RAN OUT OF 1ARG FIRST-\r
2426         SOJL    MEMLSR          ; LOST -RAN OUT OF 2ARG-\r
2427         ILDB    A,B\r
2428         ILDB    D,E\r
2429         CAIN    A,(D)           ; SKP IF POSSIBLY LOST -BACK TO MEMST1-\r
2430         JRST    MEMST2\r
2431 \r
2432         POP     P,0\r
2433         POP     P,C\r
2434         POP     P,E\r
2435         POP     P,B\r
2436         SOJA    C,MEMST1\r
2437 \r
2438 MEMWN:  MOVE    B,-2(P)         ; SETS UP ARGS LIKE MEMCH2 - HAVE WON\r
2439         MOVE    A,-1(P)\r
2440         SUB     P,[5,,5]\r
2441         JRST    MEMLS5\r
2442 \r
2443 MEMLSR: SUB     P,[5,,5]\r
2444         JRST    MEMV3\r
2445 \r
2446 MEMLS:  SUB     P,[1,,1]\r
2447         JRST    MEMV3\r
2448 \r
2449 ; MEMBERSHIP FOR TEMPLATE HACKER\r
2450 \r
2451 MEMTMP: GETYP   0,(B)           ; GET REAL SAT\r
2452         PUSH    P,E\r
2453         PUSH    P,0\r
2454         PUSH    TP,A\r
2455         PUSH    TP,B            ; SAVE GOOEIE\r
2456         PUSHJ   P,TM.LN1        ; GET LENGTH\r
2457         MOVEI   B,(B)\r
2458         HLRZ    A,(TP)          ; FUDGE FOR REST\r
2459         SUBI    B,(A)\r
2460         PUSH    P,B             ; SAVE LENGTH\r
2461         PUSH    P,[-1]\r
2462         POP     TP,B\r
2463         POP     TP,A\r
2464         MOVEM   A,BSTO+1(PVP)\r
2465 \r
2466 MEMTM1: SETZM   BSTO(PVP)\r
2467         AOS     C,(P)\r
2468         SOSGE   -1(P)\r
2469         JRST    MEMTM2\r
2470         MOVE    0,-2(P)\r
2471         PUSHJ   P,TMPLNT        ; GET ITEM\r
2472         EXCH    C,B             ; VALUE TO C, POINTER BACK TO B\r
2473         MOVE    E,-3(P)\r
2474         MOVSI   0,TTMPLT\r
2475         MOVEM   0,BSTO(PVP)\r
2476         XCT     E\r
2477         JRST    MEMTM1\r
2478 \r
2479         HRL     B,(P)           ; DO APPROPRIATE REST\r
2480         AOS     -4(P)\r
2481 MEMTM2: SUB     P,[4,,4]\r
2482         MOVSI   A,TTMPLT\r
2483         SETZM   BSTO(PVP)\r
2484         POPJ    P,\r
2485 \r
2486 EQTST:  GETYP   A,A\r
2487         GETYP   0,-1(TP)\r
2488         CAMN    C,(TP)          ;CHECK VALUE\r
2489         CAIE    0,(A)           ;AND TYPE\r
2490         POPJ    P,\r
2491         JRST    CPOPJ1\r
2492 \r
2493 EQLTST: PUSH    TP,BSTO(PVP)\r
2494         PUSH    TP,B\r
2495         PUSH    TP,A\r
2496         PUSH    TP,C\r
2497         SETZM   BSTO(PVP)\r
2498         PUSH    P,E             ;SAVE INS\r
2499         MOVEI   C,-5(TP)        ;SET UP CALL TO IEQUAL\r
2500         MOVEI   D,-1(TP)\r
2501         AOS     -1(P)           ;ASSUME SKIP\r
2502         PUSHJ   P,IEQUAL        ;GO INO EQUAL\r
2503         SOS     -1(P)           ;UNDO SKIP\r
2504         SUB     TP,[2,,2]       ;AND POOP OF CRAP\r
2505         POP     TP,B\r
2506         POP     TP,BSTO(PVP)\r
2507         POP     P,E\r
2508         POPJ    P,\r
2509 \r
2510 ; COMPILER MEMQ AND MEMBER\r
2511 \r
2512 CIMEMB: SKIPA   E,[PUSHJ P,EQLTST]\r
2513 \r
2514 CIMEMQ: MOVE    E,[PUSHJ P,EQTST]\r
2515         SUBM    M,(P)\r
2516         PUSH    TP,A\r
2517         PUSH    TP,B\r
2518         GETYP   A,C\r
2519         PUSHJ   P,CPTYPE\r
2520         JUMPE   A,COMPERR\r
2521         MOVE    B,D             ; STRUCT TO B\r
2522         PUSHJ   P,@MEMTBL(A)\r
2523         TDZA    0,0             ; FLAG NO SKIP\r
2524         MOVEI   0,1             ; FLAG SKIP\r
2525         SUB     TP,[2,,2]\r
2526         JUMPE   0,NOM\r
2527         SOS     (P)             ; SKIP RETURN\r
2528         JRST    MPOPJ\r
2529 \f\r
2530 \r
2531 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR\r
2532 \r
2533 MFUNCTION TOP,SUBR\r
2534 \r
2535         ENTRY   1\r
2536 \r
2537         MOVE    B,AB            ;CHECK ARG\r
2538         PUSHJ   P,PTYPE\r
2539         MOVEI   E,(A)\r
2540         MOVE    A,(AB)\r
2541         MOVE    B,1(AB)\r
2542         PUSHJ   P,@TOPTBL(E)    ;DISPATCH\r
2543         JRST    FINIS\r
2544 \r
2545 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]\r
2546 [PTMPLT,BCKTOP]]\r
2547 \r
2548 BCKTOP: MOVEI   B,(B)           ; FIX UP POINTER\r
2549         MOVSI   A,TTMPLT\r
2550         POPJ    P,\r
2551 \r
2552 UVTOP:  SKIPA   A,$TUVEC\r
2553 VTOP:   MOVSI   A,TVEC\r
2554         CAIN    0,SSTORE\r
2555         MOVSI   A,TSTORA\r
2556         HLRE    C,B             ;AND -LENGTH\r
2557         HRRZS   B\r
2558         SUB     B,C             ;POINT TO DOPE WORD\r
2559         HLRZ    D,1(B)          ;TOTAL LENGTH\r
2560         SUBI    B,-2(D)         ;POINT TO TOP\r
2561         MOVNI   D,-2(D)         ;-LENGTH\r
2562         HRLI    B,(D)           ;B NOW POINTS TO TOP\r
2563         POPJ    P,\r
2564 \r
2565 CHTOP:  PUSH    TP,A\r
2566         PUSH    TP,B\r
2567         LDB     0,[360600,,(TP)]        ; POSITION FIELD\r
2568         LDB     E,[300600,,(TP)]        ; AND SIZE FILED\r
2569         IDIVI   0,(E)           ; 0/ BYTES IN 1ST WORD\r
2570         MOVEI   C,36.           ; BITS PER WORD\r
2571         IDIVI   C,(E)           ; BYTES PER WORD\r
2572         PUSH    P,C\r
2573         SUBM    C,0             ; UNUSED BYTES I 1ST WORD\r
2574         ADD     0,-1(TP)        ; LENGTH OF WORD BOUNDARIED STRING\r
2575         MOVEI   C,-1(TP)        ; GET DOPE WORD\r
2576         PUSHJ   P,BYTDOP\r
2577         HLRZ    C,(A)           ; GET LENGTH\r
2578         SUBI    A,-1(C)         ;  START +1\r
2579         MOVEI   B,(A)           ; SETUP BYTER\r
2580         HRLI    B,440000\r
2581         SUB     A,(TP)          ; WORDS DIFFERENT\r
2582         IMUL    A,(P)           ; CHARS EXTRA\r
2583         SUBM    0,A             ; FINAL TOTAL TO A\r
2584         HRLI    A,TCHSTR\r
2585         POP     P,C\r
2586         DPB     E,[300600,,B]\r
2587         SUB     TP,[2,,2]\r
2588         POPJ    P,\r
2589 \f\r
2590 \r
2591 \r
2592 ATOP:\r
2593 \r
2594 GETATO: HLRE    C,B             ;GET -LENGTH\r
2595         HRROS   B\r
2596         SUB     B,C             ;POINT PAST\r
2597         GETYP   0,(B)           ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)\r
2598         CAIN    0,TENTRY                ;IF ENTRY\r
2599         JRST    EASYTP          ;WANT UNEVALUATED ARGS\r
2600         HRRE    C,(B)           ;ELSE-- GET NO. OF ARGS (*-2)\r
2601         SUBI    B,(C)           ;GO TO TOP\r
2602         TLCA    B,-1(C)         ;STORE NUMBER IN TOP POINTER\r
2603 EASYTP: MOVE    B,FRAMLN+ABSAV(B)       ;GET ARG POINTER\r
2604         HRLI    A,TARGS\r
2605         POPJ    P,\r
2606 \r
2607 ; COMPILERS ENTRY TO TOP\r
2608 \r
2609 CITOP:  PUSHJ   P,CPTYEE\r
2610         CAIN    E,P2WORD        ; LIST?\r
2611         JRST    COMPERR\r
2612         PUSHJ   P,@TOPTBL(E)\r
2613         JRST    MPOPJ\r
2614 \r
2615 ; FUNCTION TO CLOBBER THE CDR OF A LIST\r
2616 \r
2617 MFUNCTION PUTREST,SUBR,[PUTREST]\r
2618         ENTRY   2\r
2619 \r
2620         MOVE    B,AB            ;COPY ARG POINTER\r
2621         PUSHJ   P,PTYPE         ;CHECK IT\r
2622         CAIE    A,P2WORD        ;LIST?\r
2623         JRST    WTYP1           ;NO, LOSE\r
2624         ADD     B,[2,,2]        ;AND NEXT ONE\r
2625         PUSHJ   P,PTYPE\r
2626         CAIE    A,P2WORD\r
2627         JRST    WTYP2           ;NOT LIST, LOSE\r
2628         HRRZ    B,1(AB)         ;GET FIRST\r
2629         MOVE    D,3(AB)         ;AND 2D LIST\r
2630         CAIL    B,HIBOT\r
2631         JRST    PURERR\r
2632         HRRM    D,(B)           ;CLOBBER\r
2633         MOVE    A,(AB)          ;RETURN CALLED TYPE\r
2634         JRST    FINIS\r
2635 \r
2636 \f\r
2637 \r
2638 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING\r
2639 \r
2640 MFUNCTION BACK,SUBR\r
2641 \r
2642         ENTRY\r
2643 \r
2644         MOVEI   C,1             ;ASSUME BACKING UP ONE\r
2645         JUMPGE  AB,TFA          ;NO ARGS IS TOO FEW\r
2646         CAML    AB,[-2,,0]      ;SKIP IF MORE THAN 2 ARGS\r
2647         JRST    BACK1           ;ONLY ONE ARG\r
2648         GETYP   A,2(AB)         ;GET TYPE\r
2649         CAIE    A,TFIX          ;MUST BE FIXED\r
2650         JRST    WTYP2\r
2651         SKIPGE  C,3(AB)         ;GET NUMBER\r
2652         JRST    OUTRNG\r
2653         CAMGE   AB,[-4,,0]      ;SKIP IF WINNING NUMBER OF ARGS\r
2654         JRST    TMA\r
2655 BACK1:  MOVE    B,AB            ;SET UP TO FIND TYPE\r
2656         PUSHJ   P,PTYPE         ;GET PRIM TYPE\r
2657         MOVEI   E,(A)\r
2658         MOVE    A,(AB)\r
2659         MOVE    B,1(AB)         ;GET DATUM\r
2660         PUSHJ   P,@BCKTBL(E)\r
2661         JRST    FINIS\r
2662 \r
2663 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]\r
2664 [PTMPLT,BCKTMP]]\r
2665 \r
2666 BACKV:  LSH     C,1             ;GENERAL, DOUBLE AMOUNT\r
2667         SKIPA   A,$TVEC\r
2668 BACKU:  MOVSI   A,TUVEC\r
2669         CAIN    0,SSTORE\r
2670         MOVSI   A,TSTORA\r
2671         HRLI    C,(C)           ;TO BOTH HALVES\r
2672         SUB     B,C             ;BACK UP VECTOR POINTER\r
2673         HLRE    C,B             ;FIND OUT IF OVERFLOW\r
2674         SUBM    B,C             ;DOPE POINTER TO C\r
2675         HLRZ    D,1(C)          ;GET LENGTH\r
2676         SUBI    C,-2(D)         ;POINT TO TOP\r
2677         ANDI    C,-1\r
2678         CAILE   C,(B)           ;SKIP IF A WINNER\r
2679         JRST    OUTRNG          ;COMPLAIN\r
2680 BACKUV: POPJ    P,\r
2681 \r
2682 BCKTMP: MOVSI   C,(C)\r
2683         SUB     B,C             ; FIX UP POINTER\r
2684         JUMPL   B,OUTRNG\r
2685         MOVSI   A,TTMPLT\r
2686         POPJ    P,\r
2687 \r
2688 BACKC:  PUSH    TP,A\r
2689         PUSH    TP,B\r
2690         ADDI    A,(C)           ; NEW LENGTH\r
2691         HRLI    A,TCHSTR\r
2692         PUSH    P,A             ; SAVE COUNT\r
2693         LDB     E,[300600,,B]   ;BYTE SIZE\r
2694         MOVEI   0,36.           ;BITS PER WORD\r
2695         IDIVI   0,(E)           ;DIVIDE TO FIND BYTES/WORD\r
2696         IDIV    C,0             ;C/ WORDS BACK, D/BYTES BACK\r
2697         SUBI    B,(C)           ;BACK WORDS UP\r
2698         JUMPE   D,CHBOUN        ;CHECK BOUNDS\r
2699 \r
2700         IMULI   0,(E)           ;0/ BITS OCCUPIED BY FULL WORD\r
2701         LDB     A,[360600,,B]   ;GET POSITION FILED\r
2702 BACKC2: ADDI    A,(E)           ;BUMP\r
2703         CAIGE   A,36.\r
2704         JRST    BACKC1          ;O.K.\r
2705         SUB     A,0\r
2706         SUBI    B,1             ;DECREMENT POINTER PART\r
2707 BACKC1: SOJG    D,BACKC2        ;DO FOR ALL BYTES\r
2708 \f\r
2709 \r
2710 \r
2711         DPB     A,[360600,,B]   ;FIX UP POINT BYTER\r
2712 CHBOUN: MOVEI   C,-1(TP)\r
2713         PUSHJ   P,BYTDOP                ; FIND DOPE WORD\r
2714         HLRZ    C,(A)\r
2715         SUBI    A,-1(C)         ; POINT TO TOP\r
2716         MOVE    C,B             ; COPY BYTER\r
2717         IBP     C\r
2718         CAILE   A,(C)           ; SKIP IF OK\r
2719         JRST    OUTRNG\r
2720         POP     P,A             ; RESTORE COUNT\r
2721         SUB     TP,[2,,2]\r
2722         POPJ    P,\r
2723 \r
2724 \r
2725 BACKA:  LSH     C,1             ;NUMBER TIMES 2\r
2726         HRLI    C,(C)           ;TO BOTH HALVES\r
2727         SUB     B,C             ;FIX POINTER\r
2728         MOVE    E,B             ;AND SAVE\r
2729         PUSHJ   P,GETATO                ;LOOK A T TOP\r
2730         CAMLE   B,E             ;COMPARE\r
2731         JRST    OUTRNG\r
2732         MOVE    B,E\r
2733         POPJ    P,\r
2734 \r
2735 ; COMPILER'S BACK\r
2736 \r
2737 CIBACK: PUSHJ   P,CPTYEE\r
2738         JUMPL   C,OUTRNG\r
2739         CAIN    E,P2WORD\r
2740         JRST    COMPERR\r
2741         PUSHJ   P,@BCKTBL(E)\r
2742         JRST    MPOPJ\r
2743 \f\r
2744 MFUNCTION STRCOMP,SUBR\r
2745 \r
2746         ENTRY   2\r
2747 \r
2748         MOVE    A,(AB)\r
2749         MOVE    B,1(AB)\r
2750         MOVE    C,2(AB)\r
2751         MOVE    D,3(AB)\r
2752         PUSHJ   P,ISTRCM\r
2753         JRST    FINIS\r
2754 \r
2755 ISTRCM: GETYP   0,A\r
2756         CAIE    0,TCHSTR\r
2757         JRST    ATMCMP          ; MAYBE ATOMS\r
2758 \r
2759         GETYP   0,C\r
2760         CAIE    0,TCHSTR\r
2761         JRST    WTYP2\r
2762 \r
2763         MOVEI   A,(A)           ; ISOLATR LENGHTS\r
2764         MOVEI   C,(C)\r
2765 \r
2766 STRCO2: SOJL    A,CHOTHE        ; ONE STRING EXHAUSTED, CHECK OTHER\r
2767         SOJL    C,1BIG          ; 1ST IS BIGGER\r
2768         ILDB    0,B\r
2769         ILDB    E,D\r
2770         CAIN    0,(E)           ; SKIP IF DIFFERENT\r
2771         JRST    STRCO2\r
2772         CAIL    0,(E)           ; SKIP IF 2D BIGGER THAN 1ST\r
2773         JRST    1BIG\r
2774 2BIG:   MOVNI   B,1\r
2775         JRST    RETFIX\r
2776 \r
2777 CHOTHE: JUMPN   C,2BIG          ; 2 IS BIGGER\r
2778 SM.CMP: TDZA    B,B             ; RETURN 0\r
2779 1BIG:   MOVEI   B,1\r
2780 RETFIX: MOVSI   A,TFIX\r
2781         POPJ    P,\r
2782 \r
2783 ATMCMP: CAIE    0,TATOM         ; COULD BE ATOM\r
2784         JRST    WTYP1           ; NO, QUIT\r
2785         GETYP   0,C\r
2786         CAIE    0,TATOM\r
2787         JRST    WTYP2\r
2788 \r
2789         CAMN    B,D             ; SAME ATOM?\r
2790         JRST    SM.CMP\r
2791         ADD     B,[3,,3]        ; SKIP VAL CELL ETC.\r
2792         ADD     D,[3,,3]\r
2793 \r
2794 ATMCM1: MOVE    0,(B)           ; GET A  WORD OF CHARS\r
2795         CAME    0,(D)           ; SAME?\r
2796         JRST    ATMCM3          ; NO, GET DIF\r
2797         AOBJP   B,ATMCM2\r
2798         AOBJN   D,ATMCM1        ; MORE TO COMPARE\r
2799         JRST    1BIG            ; 1ST IS BIGGER\r
2800 \r
2801 \r
2802 ATMCM2: AOBJP   D,SM.CMP        ; EQUAL\r
2803         JRST    2BIG\r
2804 \r
2805 ATMCM3: LSH     0,-1            ; AVOID SIGN LOSSAGE\r
2806         MOVE    C,(D)\r
2807         LSH     C,-1\r
2808         CAMG    0,C\r
2809         JRST    2BIG\r
2810         JRST    1BIG\r
2811 \r
2812 \f;ERROR COMMENTS FOR SOME PRIMITIVES\r
2813 \r
2814 OUTRNG: PUSH    TP,$TATOM\r
2815         PUSH    TP,EQUOTE OUT-OF-BOUNDS\r
2816         JRST    CALER1\r
2817 \r
2818 WRNGUT: PUSH    TP,$TATOM\r
2819         PUSH    TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS\r
2820         JRST    CALER1\r
2821 \r
2822 SLOSE0: PUSH    TP,$TATOM\r
2823         PUSH    TP,EQUOTE VECTOR-LENGTHS-DIFFER\r
2824         JRST    CALER1\r
2825 \r
2826 SLOSE1: PUSH    TP,$TATOM\r
2827         PUSH    TP,EQUOTE KEYS-WRONG-TYPE\r
2828         JRST    CALER1\r
2829 \r
2830 SLOSE2: PUSH    TP,$TATOM\r
2831         PUSH    TP,EQUOTE KEY-TYPES-DIFFER\r
2832         JRST    CALER1\r
2833 \r
2834 SLOSE3: PUSH    TP,$TATOM\r
2835         PUSH    TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD\r
2836         JRST    CALER1\r
2837 \r
2838 SLOSE4: PUSH    TP,$TATOM\r
2839         PUSH    TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS\r
2840         JRST    CALER1\r
2841 \r
2842 IIGETP: JRST    IGETP           ;FUDGE FOR MIDAS/STINK LOSSAGE\r
2843 IIPUTP: JRST    IPUTP\r
2844 \r
2845 \f;SUPER USEFUL ERROR MESSAGES   (USED BY WHOLE WORLD)\r
2846 \r
2847 WNA:    PUSH    TP,$TATOM\r
2848         PUSH    TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS\r
2849         JRST    CALER1\r
2850 \r
2851 TFA:    PUSH    TP,$TATOM\r
2852         PUSH    TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED\r
2853         JRST    CALER1\r
2854 \r
2855 TMA:    PUSH    TP,$TATOM\r
2856         PUSH    TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED\r
2857         JRST    CALER1\r
2858 \r
2859 WRONGT: \r
2860 WTYP:   PUSH    TP,$TATOM\r
2861         PUSH    TP,EQUOTE ARG-WRONG-TYPE\r
2862         JRST    CALER1\r
2863 \r
2864 IWTYP1:\r
2865 WTYP1:  PUSH    TP,$TATOM\r
2866         PUSH    TP,EQUOTE FIRST-ARG-WRONG-TYPE\r
2867         JRST    CALER1\r
2868 \r
2869 IWTYP2:\r
2870 WTYP2:  PUSH    TP,$TATOM\r
2871         PUSH    TP,EQUOTE SECOND-ARG-WRONG-TYPE\r
2872         JRST    CALER1\r
2873 \r
2874 BADTPL: PUSH    TP,$TATOM\r
2875         PUSH    TP,EQUOTE BAD-TEMPLATE-DATA\r
2876         JRST    CALER1\r
2877 \r
2878 BADPUT: PUSH    TP,$TATOM\r
2879         PUSH    TP,EQUOTE TEMPLATE-TYPE-VIOLATION\r
2880         JRST    CALER1\r
2881 \r
2882 WTYP3:  PUSH    TP,$TATOM\r
2883         PUSH    TP,EQUOTE THIRD-ARG-WRONG-TYPE\r
2884         JRST    CALER1\r
2885 \r
2886 CALER1: MOVEI   A,1\r
2887 CALER:  HRRZ    C,FSAV(TB)\r
2888         PUSH    TP,$TATOM\r
2889         CAMGE   C,VECTOP\r
2890         CAMGE   C,VECBOT\r
2891         SKIPA   C,@-1(C)        ; SUBRS AND FSUBRS\r
2892         MOVE    C,3(C)          ; FOR RSUBRS\r
2893         PUSH    TP,C\r
2894         ADDI    A,1\r
2895         ACALL   A,ERROR\r
2896         JRST    FINIS\r
2897   \r
2898 \r
2899 GETWNA: HLRZ    B,(E)-2         ;GET LOSING COMPARE INSTRUCTION\r
2900         CAIE    B,(CAIE A,)     ;AS EXPECTED ?\r
2901         JRST    WNA             ;NO,\r
2902         HRRE    B,(E)-2         ;GET DESIRED NUMBER OF ARGS\r
2903         HLRE    A,AB            ;GET ACTUAL NUMBER OF ARGS\r
2904         CAMG    B,A\r
2905         JRST    TFA\r
2906         JRST    TMA\r
2907 \r
2908 END\r
2909 \f