<mdl.int>/primit.mid.316

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