<mdl.int>/primit.mid.315

   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 DEFSTU: PUSH    TP,$TLIST
1787         PUSH    TP,B
1788         PUSH    TP,C
1789         PUSH    TP,D
1790         PUSHJ   P,CELL2         ; GET WORDS
1791         POP     TP,1(B)
1792         POP     TP,(B)
1793         MOVE    E,(TP)
1794         SUB     TP,[2,,2]
1795         MOVEM   B,1(E)
1796         HLLZ    0,(E)           ; GET OLD MONITORS
1797         TLZ     0,TYPMSK        ; KILL TYPES
1798         TLO     0,TDEFER        ; MAKE DEFERRED
1799         HLLM    0,(E)
1800         POPJ    P,
1801
1802 ; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
1803
1804 APUT:   PUSHJ   P,AAT
1805         JRST    .+2
1806
1807 VPUT:   PUSHJ   P,VAT           ; TREAT LIKE VECTOR
1808         POP     TP,D            ; GET GOODIE BACK
1809         POP     TP,C
1810
1811 ; AVSTUF --  CLOBBER ARGS AND VECTORS
1812
1813 ASTUF:
1814 VSTUF:  PUSHJ   P,MONCH0
1815         MOVEM   C,(B)
1816         MOVEM   D,1(B)
1817         POPJ    P,
1818
1819 \f
1820
1821
1822 ; UPUT  --  CLOBBER A UVECTOR
1823
1824 UPUT:   PUSHJ   P,UAT           ; GET IT RESTED
1825         POP     TP,D
1826         POP     TP,C
1827
1828 ; USTUF -- HERE TO CLOBBER A UVECTOR
1829
1830 USTUF:  HLRE    E,B
1831         SUBM    B,E             ; C POINTS TO DOPE
1832         GETYP   A,(E)           ; GET UTYPE
1833         GETYP   0,C
1834         CAIE    0,(A)           ; CHECK SAMENESS
1835         JRST    WRNGUT
1836         HLLZ    0,(E)           ; MONITOR BITS IN DOPE WORD
1837         MOVSI   A,TLOCU         ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
1838         PUSHJ   P,MONCH
1839         MOVEM   D,(B)           ; SMASH
1840         POPJ    P,
1841
1842 ; BPUT -- HERE TO PUT A BYTE-STRING
1843
1844 BPUT:   PUSHJ   P,BTAT
1845         POP     TP,D
1846         POP     TP,C
1847 BSTUF:  MOVEI   E,TFIX
1848         JRST    SSTUF1
1849
1850 ; SPUT -- HERE TO PUT A STRING
1851
1852 SPUT:   PUSHJ   P,STAT          ; REST IT
1853         POP     TP,D
1854         POP     TP,C
1855
1856 ; SSTUF -- STUFF A STRING
1857
1858 SSTUF:  MOVEI   E,TCHRS
1859 SSTUF1: GETYP   0,C             ; BETTER BE CHAR
1860         CAIE    0,(E)
1861         JRST    WTYP3
1862         PUSH    P,C
1863         PUSH    TP,A
1864         PUSH    TP,B
1865         MOVEI   C,-1(TP)        ; FIND D.W.
1866         PUSHJ   P,BYTDOP
1867         SKIPGE  (A)-1           ; SKIP IF NOT REALLY ATOM
1868         JRST    PNMNG
1869         HLLZ    0,(A)-1         ; GET MONITORS
1870         POP     TP,B
1871         POP     TP,A
1872         POP     P,C
1873         PUSHJ   P,MONCH
1874         IDPB    D,B             ; STASH
1875         POPJ    P,
1876
1877 PNMNG:  POP     TP,B
1878         POP     TP,A
1879         PUSH    TP,$TATOM
1880         PUSH    TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
1881         HRLI    A,TCHSTR
1882         PUSH    TP,A
1883         PUSH    TP,B
1884         MOVEI   A,2
1885         JRST    CALER
1886
1887 ; TSTUF -- SETLOC A TEMPLATE
1888
1889 TSTUF:  PUSH    TP,C
1890         PUSH    TP,D
1891         MOVEI   C,0
1892
1893 ; PUTTMP -- TEMPLATE PUTTER
1894
1895 TMPPUT: ADDI    C,1
1896         PUSHJ   P,TM.TOE        ; GET E POINTING TO SLOT #
1897         ADD     A,TD.PUT+1      ; POINT TO INS
1898         MOVE    A,(A)           ; GET VECTOR OF INS
1899         ADDI    E,-1(A)
1900         POP     TP,B            ; NEW VAL TO A AND B
1901         POP     TP,A
1902         SUBI    D,1
1903         XCT     (E)             ; DO IT
1904         JRST    BADPUT
1905         POPJ    P,
1906
1907 TM.LN1: SUBI    0,NUMSAT+1
1908         HRRZ    A,0             ; RET FIXED OFFSET
1909         HRLS    0
1910         ADD     0,TD.LNT+1      ; USE LENGTHERS FOR TEST
1911         JUMPGE  0,BADTPL
1912         PUSH    P,C
1913         MOVE    C,B
1914         HRRZS   0               ; POINT TO TABLE ENTRY
1915         PUSH    P,A
1916         XCT     @0              ; DO IT
1917         POP     P,A
1918         POP     P,C
1919         POPJ    P,
1920
1921 TM.TBL: MOVEI   E,(D)           ; TENTATIVE WINNER IN E
1922         TLNN    B,-1            ; SKIP IF REST HAIR EXISTS
1923         POPJ    P,              ; NO, WIN
1924
1925         PUSH    P,A             ; SAVE OFFSET
1926         HRLS    A               ; A IS REL OFFSET TO INS TABLE
1927         ADD     A,TD.GET+1      ; GET ONEOF THE TABLES
1928         MOVE    A,(A)           ; TABLE POINTER TO A
1929         MOVSI   0,-1(D)         ; START SEEING IF PAST TEMP SPEC
1930         ADD     0,A
1931         JUMPL   0,CPOPJA        ; JUMP IF E STILL VALID
1932         HLRZ    E,B             ; BASIC LENGTH TO E
1933         HLRE    0,A             ; LENGTH OF TEMPLATE TO 0
1934         ADDI    0,(E)           ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
1935         MOVNS   0
1936         SUBM    D,E             ; E ==> # PAST BASIC WANTED
1937         EXCH    0,E
1938         IDIVI   0,(E)           ; A ==> REL REST GUY WANTED
1939         HLRZ    E,B
1940         ADDI    E,1(A)
1941 CPOPJA: POP     P,A
1942         POPJ    P,
1943
1944 ; TM.TOE -- GET RIGHT TEMPLATE # IN E
1945 ; C/ OBJECT #, B/ OBJECT POINTER
1946
1947 TM.TOE: GETYP   0,(B)           ; GET REAL SAT
1948         MOVEI   D,(C)           ; OBJ # TO D
1949         HLRZ    C,B             ; REST COUNT
1950         ADDI    D,(C)           ; FUDGE FOR REST COUNTER
1951         MOVE    C,B             ; POINTER TO C
1952         PUSHJ   P,TM.LN1        ; GET LENGTH IN B (WATCH LH!)
1953         CAILE   D,(B)           ; CHECK RANGE
1954         JRST    OUTRNG          ; LOSER, QUIT
1955         JRST    TM.TBL          ; GO COMPUTE TABLE OFFSET
1956
1957 \f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
1958 ; FIXES (P)
1959
1960 CPTYEE: MOVE    E,A
1961         GETYP   A,A
1962         PUSHJ   P,CPTYPE
1963         JUMPE   A,WTYPUN
1964         SUBM    M,-1(P)
1965         EXCH    E,A
1966         POPJ    P,
1967
1968 ; COMPILER CALLS TO MANY OF THESE GUYS
1969
1970 CIREST: PUSHJ   P,CPTYEE        ; TYPE OF DISP TO E
1971         HRRES   C               ; CLEAR LH, IN CASE IT'S AN OFFSET
1972         JUMPL   C,OUTRNG
1973         CAIN    0,SSTORE
1974         JRST    CIRST1
1975         PUSHJ   P,@RESTBL(E)
1976         JRST    MPOPJ
1977
1978 CIRST1: PUSHJ   P,STORST
1979         JRST    MPOPJ
1980
1981 CINTH:  PUSHJ   P,CPTYEE
1982         HRRES   C               ; CLEAR LH
1983         SOJL    C,OUTRNG        ; CHECK BOUNDS
1984         PUSHJ   P,@NTHTBL(E)
1985         JRST    MPOPJ
1986
1987 CIAT:   PUSHJ   P,CPTYEE
1988         SOJL    C,OUTRNG
1989         PUSHJ   P,@ATTBL(E)
1990         JRST    MPOPJ
1991
1992 CSETLO: PUSHJ   P,CTYLOC
1993         MOVSS   E               ; REAL DISPATCH
1994         GETYP   0,A             ; INCASE LOCAS OR LOCD
1995         PUSH    TP,C
1996         PUSH    TP,D
1997         PUSHJ   P,@SETTBL(E)
1998         POP     TP,B
1999         POP     TP,A
2000         JRST    MPOPJ
2001
2002 CIN:    PUSHJ   P,CTYLOC
2003         MOVSS   E               ; REAL DISPATCH
2004         GETYP   C,A
2005         PUSHJ   P,@INTBL(E)
2006         JRST    MPOPJ
2007
2008 CTYLOC: MOVE    E,A
2009         GETYP   A,A
2010         PUSHJ   P,CPTYPE
2011         SUBM    M,-1(P)
2012         EXCH    A,E
2013         POPJ    P,
2014
2015 ; COMPILER'S PUT,GET AND GETL
2016
2017 CIGET:  PUSH    P,[0]
2018         JRST    .+2
2019
2020 CIGETL: PUSH    P,[1]
2021         MOVE    E,A
2022         GETYP   A,A
2023         PUSHJ   P,CPTYPE
2024         EXCH    A,E
2025         JUMPE   E,CIGET1        ; REAL GET, NOT NTH
2026         GETYP   0,C             ; INDIC FIX?
2027         CAIE    0,TFIX
2028          CAIN   0,TOFFS
2029           JRST  .+2
2030         JRST    CIGET1
2031         POP     P,E             ; GET FLAG
2032         AOS     (P)             ; ALWAYS SKIP
2033         MOVE    C,D             ; # TO AN AC
2034         JRST    @.+1(E)
2035                 SETZ CINTH
2036                 SETZ CIAT
2037
2038 CIGET1: POP     P,E             ; GET FLAG
2039         JRST    @GETTR(E)       ; DO A REAL GET
2040
2041 GETTR:          SETZ CIGTPR
2042                 SETZ CIGETP
2043
2044 CIPUT:  SUBM    M,(P)
2045         MOVE    E,A
2046         GETYP   A,A
2047         PUSHJ   P,CPTYPE
2048         EXCH    A,E
2049         PUSH    TP,-1(TP)               ; PAIN AND SUFFERING
2050         PUSH    TP,-1(TP)
2051         MOVEM   A,-3(TP)
2052         MOVEM   B,-2(TP)
2053         JUMPE   E,CIPUT1
2054         GETYP   0,C
2055         CAIE    0,TFIX          ; YES DO STRUCT
2056          CAIN   0,TOFFS
2057           JRST  .+2
2058         JRST    CIPUT1
2059         MOVE    C,D
2060         HRRES   C
2061         SOJL    C,OUTRNG        ; CHECK BOUNDS
2062         PUSHJ   P,@IPUTBL(E)
2063 PMPOPJ: POP     TP,B
2064         POP     TP,A
2065         JRST    MPOPJ
2066
2067 CIPUT1: PUSHJ   P,IPUT
2068         JRST    PMPOPJ
2069 \f
2070 ; SMON -- SET MONITOR BITS
2071 ;       B/ <POINTER TO LOCATIVE>
2072 ;       D/ <IORM> OR <ANDCAM>
2073 ;       E/ BITS
2074
2075 SMON:   GETYP   A,(B)
2076         PUSHJ   P,PTYPE         ; TO PRIM TYPE
2077         HLRZS   A
2078         SKIPE   A,SMONTB(A)     ; DISPATCH?
2079         JRST    (A)
2080
2081 ; COULD STILL BE LOCN OR LOCD
2082
2083         GETYP   A,(B)           ; TYPE BACK
2084         CAIE    A,TLOCN
2085         JRST    SMON2           ; COULD BE LOCD
2086         MOVE    C,1(B)          ; POINT
2087         HRRI    D,VAL(C)        ; MAKE INST POINT
2088         JRST    SMON3
2089
2090 SMON2:  CAIE    A,TLOCD
2091         JRST    WRONGT
2092
2093
2094 ; SET LIST/TUPLE/ID LOCATIVE
2095
2096 SMON4:  HRR     D,1(B)          ; POINT TO TYPE WORD
2097 SMON3:  XCT     D
2098         POPJ    P,
2099
2100 ; SET UVEC LOC
2101
2102 SMON5:  HRRZ    C,1(B)          ; POINT TO TOP OF UV
2103         HLRE    0,1(B)
2104         SUB     C,0             ; POINT TO DOPE
2105         HRRI    D,(C)           ; POINT IN INST
2106         JRST    SMON3
2107
2108 ; SET CHSTR LOC
2109
2110 SMON6:  MOVEI   C,(B)           ; FOR BYTDOP
2111         PUSHJ   P,BYTDOP        ; POINT TO DOPE
2112         HRRI    D,(A)-1
2113         JRST    SMON3
2114
2115 PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
2116 [PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
2117
2118 \f
2119 ; COMPILER'S MONAD?
2120
2121 CIMON:  PUSH    P,A
2122         GETYP   A,A
2123         PUSHJ   P,CPTYPE
2124         JUMPE   A,CIMON1
2125         POP     P,A
2126         JRST    CEMPTY
2127
2128 CIMON1: POP     P,A
2129         JRST    YES
2130
2131 ; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
2132
2133 MFUNCTION MONAD,SUBR,MONAD?
2134
2135         ENTRY   1
2136
2137         MOVE    B,AB            ; CHECK PRIM TYPE
2138         PUSHJ   P,PTYPE
2139         JUMPE   A,ITRUTH                ;RETURN ARGUMENT
2140         SKIPE   B,1(AB)
2141         JRST    @MONTBL(A)      ;DISPATCH ON PTYPE
2142         JRST    ITRUTH
2143
2144 PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
2145 [PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
2146
2147 MON1:   JUMPGE  B,ITRUTH                ;EMPTY VECTOR
2148         JRST    IFALSE
2149
2150 CHMON:  HRRZ    B,(AB)
2151         JUMPE   B,ITRUTH
2152         JRST    IFALSE
2153
2154 TMPMON: PUSHJ   P,LNTMPL
2155         JUMPE   B,ITRUTH
2156         JRST    IFALSE
2157
2158 CISTRU: GETYP   A,A             ; COMPILER CALL
2159         PUSHJ   P,ISTRUC
2160         JRST    NO
2161         JRST    YES
2162
2163 ISTRUC: PUSHJ   P,SAT           ; STORAGE TYPE
2164         SKIPE   A,PRMTYP(A)
2165         AOS     (P)             ; SKIP IF WINS
2166         POPJ    P,
2167
2168 ; SUBR TO CHECK FOR LOCATIVE
2169
2170 MFUNCTION %LOCA,SUBR,[LOCATIVE?]
2171
2172         ENTRY   1
2173         GETYP   A,(AB)
2174         PUSHJ   P,LOCQQ
2175         JRST    IFALSE
2176         JRST    ITRUTH
2177
2178 ; SKIPS IF TYPE IN A IS A LOCATIVE
2179
2180 LOCQ:   GETYP   A,(B)           ; GET TYPE
2181 LOCQQ:  PUSH    P,A             ; SAVE FOR LOCN/LOCD
2182         PUSHJ   P,SAT
2183         MOVE    A,PRMTYP(A)
2184         JUMPE   A,LOCQ1
2185         SUB     P,[1,,1]
2186         TRNN    A,-1
2187 LOCQ2:  AOS     (P)
2188         POPJ    P,
2189
2190 LOCQ1:  POP     P,A             ; RESTORE TYPE
2191         CAIE    A,TLOCN
2192         CAIN    A,TLOCD
2193         JRST    LOCQ2
2194         POPJ    P,
2195
2196 \f
2197 ; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
2198
2199 MFUNCTION MEMBER,SUBR
2200
2201         MOVE    E,[PUSHJ P,EQLTST]      ;TEST ROUTINE IN E
2202         JRST    MEMB
2203
2204 MFUNCTION MEMQ,SUBR
2205
2206         MOVE    E,[PUSHJ P,EQTST]       ;EQ TESTER
2207
2208 MEMB:   ENTRY   2
2209         MOVE    B,AB            ;POINT TO FIRST ARG
2210         PUSHJ   P,PTYPE         ;CHECK PRIM TYPE
2211         ADD     B,[2,,2]        ;POINT TO 2ND ARG
2212         PUSHJ   P,PTYPE
2213         JUMPE   A,WTYP2         ;2ND WRONG TYPE
2214         PUSH    TP,(AB)
2215         PUSH    TP,1(AB)
2216         MOVE    C,2(AB)         ; FOR TUPLE CASE
2217         SKIPE   B,3(AB)         ;GOBBLE LIST VECTOR ETC. POINTER
2218         PUSHJ   P,@MEMTBL(A)    ;DISPATCH
2219         JRST    IFALSE          ;OR REPORT LOSSAGE
2220         JRST    FINIS
2221
2222 PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
2223 [PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
2224
2225
2226
2227 MEMLST: MOVSI   0,TLIST         ;SET B'S TYPE TO LIST
2228         MOVE    PVP,PVSTOR+1
2229         MOVEM   0,BSTO(PVP)
2230         JUMPE   B,MEMLS6        ; EMPTY LIST LOSE IMMEDIATE
2231
2232 MEMLS1: INTGO                   ;CHECK INTERRUPTS
2233         MOVEI   C,(B)           ;COPY POINTER
2234         GETYP   D,(C)           ;GET TYPE
2235         MOVSI   A,(D)           ;COPY
2236         CAIE    D,TDEFER                ;DEFERRED?
2237         JRST    MEMLS2
2238         MOVE    C,1(C)          ;GET DEFERRED DATUM
2239         GETYPF  A,(C)           ;GET FULL TYPE WORD
2240 MEMLS2: MOVE    C,1(C)          ;GET DATUM
2241         XCT     E               ;DO THE COMPARISON
2242         JRST    MEMLS3          ;NO MATCH
2243         MOVSI   A,TLIST
2244 MEMLS5: AOS     (P)
2245 MEMLS6: MOVE    PVP,PVSTOR+1
2246         SETZM   BSTO(PVP)               ;RESET B'S TYPE
2247         POPJ    P,
2248
2249 MEMLS3: HRRZ    B,(B)           ;STEP THROGH
2250         JUMPN   B,MEMLS1        ;STILL MORE TO DO
2251 MEMLS4: MOVSI   A,TFALSE        ;RETURN FALSE
2252         JRST    MEMLS6          ;RETURN 0
2253
2254 MEMTUP: HRRZ    A,C
2255         TLOA    A,TARGS
2256 MEMVEC: MOVSI   A,TVEC          ;CLOBBER B'S TYPE TO VECTOR
2257         JUMPGE  B,MEMLS4        ;EMPTY VECTOR
2258         MOVE    PVP,PVSTOR+1
2259         MOVEM   A,BSTO(PVP)
2260
2261 MEMV1:  INTGO                   ;CHECK FOR INTS
2262         GETYPF  A,(B)           ;GET FULL TYPE
2263         MOVE    C,1(B)          ;AND DATA
2264         XCT     E               ;DO COMPARISON INS
2265         JRST    MEMV2           ;NOT EQUAL
2266         MOVE    PVP,PVSTOR+1
2267         MOVE    A,BSTO(PVP)
2268         JRST    MEMLS5          ;RETURN WITH POINTER
2269 \f
2270 MEMV2:  ADD     B,[2,,2]        ;INCREMENT AND GO
2271         JUMPL   B,MEMV1         ;STILL WINNING
2272 MEMV3:  MOVEI   B,0
2273         JRST    MEMLS4          ;AND RETURN FALSE
2274
2275 MUVEC:  JUMPGE  B,MEMLS4
2276         GETYP   A,-1(TP)        ;GET TYPE OF GODIE
2277         HLRE    C,B             ;LOOK FOR UNIFORM TYPE
2278         SUBM    B,C             ;DOPE POINTER TO C
2279         GETYP   C,(C)           ;GET THE TYPE
2280         CAIE    A,(C)           ;ARE THEY THE SAME?
2281         JRST    MEMLS4          ;NO, LOSE
2282         MOVSI   A,TUVEC
2283         CAIN    0,SSTORE
2284         MOVSI   A,TSTORA
2285         PUSH    P,A
2286         MOVE    PVP,PVSTOR+1
2287         MOVEM   A,BSTO(PVP)
2288         MOVSI   A,(C)           ;TYPE TO LH
2289         PUSH    P,A             ; SAVE FOR EACH TEST
2290
2291 MUVEC1: INTGO                   ;CHECK OUT INTS
2292         MOVE    C,(B)           ;GET DATUM
2293         MOVE    A,(P)           ; GET TYPE
2294         XCT     E               ;COMPARE
2295         AOBJN   B,MUVEC1        ;LOOP TO WINNAGE
2296         SUB     P,[1,,1]
2297         POP     P,A
2298         JUMPGE  B,MEMV3         ;LOSE RETURN
2299
2300 MUVEC2: JRST    MEMLS5
2301
2302
2303 MEMBYT: MOVEI   0,TFIX
2304         MOVEI   D,TBYTE
2305         JRST    MEMBY1
2306
2307 MEMCH:  MOVEI   0,TCHRS
2308         MOVEI   D,TCHSTR
2309 MEMBY1: GETYP   A,-1(TP)        ;IS ARG A SINGLE CHAR
2310         CAIE    0,(A)           ;SKIP IF POSSIBLE WINNER
2311         JRST    MEMSTR
2312         MOVEI   0,(C)
2313         MOVE    D,(TP)          ; AND CHAR
2314
2315 MEMCH1: SOJL    0,MEMV3
2316         MOVE    E,B
2317         ILDB    A,B
2318         CAIE    A,(D)           ;CHECK IT
2319         SOJA    C,MEMCH1
2320
2321 MEMCH2: MOVE    B,E
2322         MOVE    A,C
2323         JRST    MEMLS5
2324
2325 MEMSTR: CAIN    A,(D)
2326         CAME    E,[PUSHJ P,EQLTST]
2327         JRST    MEMV3
2328         LDB     A,[300600,,(TP)]
2329         LDB     0,[300600,,B]
2330         CAIE    0,(A)
2331         JRST    MEMV3
2332         MOVEI   0,(C)           ; GET # OF CHAR INTO 0
2333         ILDB    D,(TP)
2334         PUSH    P,D             ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
2335
2336 MEMST1: SOJL    0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
2337         MOVE    E,B
2338         ILDB    A,B
2339         CAME    A,(P)
2340         SOJA    C,MEMST1        ; MATCH FAILS TRY NEXT
2341
2342         PUSH    P,B
2343         PUSH    P,E
2344         PUSH    P,C
2345         PUSH    P,0
2346         MOVE    E,(TP)          ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
2347         HRRZ    C,-1(TP)        ; LENGTH OF 1ARG
2348 MEMST2: SOJE    C,MEMWN         ; WON -RAN OUT OF 1ARG FIRST-
2349         SOJL    MEMLSR          ; LOST -RAN OUT OF 2ARG-
2350         ILDB    A,B
2351         ILDB    D,E
2352         CAIN    A,(D)           ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
2353         JRST    MEMST2
2354
2355         POP     P,0
2356         POP     P,C
2357         POP     P,E
2358         POP     P,B
2359         SOJA    C,MEMST1
2360
2361 MEMWN:  MOVE    B,-2(P)         ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
2362         MOVE    A,-1(P)
2363         SUB     P,[5,,5]
2364         JRST    MEMLS5
2365
2366 MEMLSR: SUB     P,[5,,5]
2367         JRST    MEMV3
2368
2369 MEMLS:  SUB     P,[1,,1]
2370         JRST    MEMV3
2371
2372 ; MEMBERSHIP FOR TEMPLATE HACKER
2373
2374 MEMTMP: GETYP   0,(B)           ; GET REAL SAT
2375         PUSH    P,E
2376         PUSH    P,0
2377         PUSH    TP,A
2378         PUSH    TP,B            ; SAVE GOOEIE
2379         PUSHJ   P,TM.LN1        ; GET LENGTH
2380         MOVEI   B,(B)
2381         HLRZ    A,(TP)          ; FUDGE FOR REST
2382         SUBI    B,(A)
2383         PUSH    P,B             ; SAVE LENGTH
2384         PUSH    P,[-1]
2385         POP     TP,B
2386         POP     TP,A
2387         MOVE    PVP,PVSTOR+1
2388         MOVEM   B,BSTO+1(PVP)
2389
2390 MEMTM1: MOVE    PVP,PVSTOR+1
2391         SETZM   BSTO(PVP)
2392         AOS     C,(P)
2393         SOSGE   -1(P)
2394         JRST    MEMTM2
2395         MOVE    0,-2(P)
2396         PUSHJ   P,TMPLNT        ; GET ITEM
2397         EXCH    C,B             ; VALUE TO C, POINTER BACK TO B
2398         MOVE    E,-3(P)
2399         MOVSI   0,TTMPLT
2400         MOVE    PVP,PVSTOR+1
2401         MOVEM   0,BSTO(PVP)
2402         XCT     E
2403         SKIPA
2404         JRST    MEMTM3
2405         MOVE    PVP,PVSTOR+1
2406         MOVE    B,BSTO+1(PVP)
2407         JRST    MEMTM1
2408
2409 MEMTM3: MOVE    PVP,PVSTOR+1
2410         MOVE    B,BSTO+1(PVP)
2411         HRL     B,(P)           ; DO APPROPRIATE REST
2412         AOS     -4(P)
2413 MEMTM2: SUB     P,[4,,4]
2414         MOVSI   A,TTMPLT
2415         MOVE    PVP,PVSTOR+1
2416         SETZM   BSTO(PVP)
2417         POPJ    P,
2418
2419 EQTST:  GETYP   A,A
2420         GETYP   0,-1(TP)
2421         CAMN    C,(TP)          ;CHECK VALUE
2422         CAIE    0,(A)           ;AND TYPE
2423         POPJ    P,
2424         JRST    CPOPJ1
2425
2426 EQLTST: MOVE    PVP,PVSTOR+1
2427         PUSH    TP,BSTO(PVP)
2428         PUSH    TP,B
2429         PUSH    TP,A
2430         PUSH    TP,C
2431         SETZM   BSTO(PVP)
2432         PUSH    P,E             ;SAVE INS
2433         MOVEI   C,-5(TP)        ;SET UP CALL TO IEQUAL
2434         MOVEI   D,-1(TP)
2435         AOS     -1(P)           ;ASSUME SKIP
2436         PUSHJ   P,IEQUAL        ;GO INO EQUAL
2437         SOS     -1(P)           ;UNDO SKIP
2438         SUB     TP,[2,,2]       ;AND POOP OF CRAP
2439         POP     TP,B
2440         MOVE    PVP,PVSTOR+1
2441         POP     TP,BSTO(PVP)
2442         POP     P,E
2443         POPJ    P,
2444
2445 ; COMPILER MEMQ AND MEMBER
2446
2447 CIMEMB: SKIPA   E,[PUSHJ P,EQLTST]
2448
2449 CIMEMQ: MOVE    E,[PUSHJ P,EQTST]
2450         SUBM    M,(P)
2451         PUSH    TP,A
2452         PUSH    TP,B
2453         GETYP   A,C
2454         PUSHJ   P,CPTYPE
2455         JUMPE   A,WTYPUN
2456         MOVE    B,D             ; STRUCT TO B
2457         PUSHJ   P,@MEMTBL(A)
2458         TDZA    0,0             ; FLAG NO SKIP
2459         MOVEI   0,1             ; FLAG SKIP
2460         SUB     TP,[2,,2]
2461         JUMPE   0,NOM
2462         SOS     (P)             ; SKIP RETURN
2463         JRST    MPOPJ
2464 \f
2465
2466 ; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
2467
2468 MFUNCTION TOP,SUBR
2469
2470         ENTRY   1
2471
2472         MOVE    B,AB            ;CHECK ARG
2473         PUSHJ   P,PTYPE
2474         MOVEI   E,(A)
2475         MOVE    A,(AB)
2476         MOVE    B,1(AB)
2477         PUSHJ   P,@TOPTBL(E)    ;DISPATCH
2478         JRST    FINIS
2479
2480 PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
2481 [PTMPLT,BCKTOP],[PBYTE,BTOP]]
2482
2483 BCKTOP: MOVEI   B,(B)           ; FIX UP POINTER
2484         MOVSI   A,TTMPLT
2485         POPJ    P,
2486
2487 UVTOP:  SKIPA   A,$TUVEC
2488 VTOP:   MOVSI   A,TVEC
2489         CAIN    0,SSTORE
2490         MOVSI   A,TSTORA
2491         JUMPE   B,CPOPJ
2492         HLRE    C,B             ;AND -LENGTH
2493         HRRZS   B
2494         SUB     B,C             ;POINT TO DOPE WORD
2495         HLRZ    D,1(B)          ;TOTAL LENGTH
2496         SUBI    B,-2(D)         ;POINT TO TOP
2497         MOVNI   D,-2(D)         ;-LENGTH
2498         HRLI    B,(D)           ;B NOW POINTS TO TOP
2499         POPJ    P,
2500
2501 BTOP:   SKIPA   E,$TBYTE
2502 CHTOP:  MOVSI   E,TCHSTR
2503         JUMPE   B,CPOPJ
2504         PUSH    P,E
2505         PUSH    TP,A
2506         PUSH    TP,B
2507         LDB     0,[360600,,(TP)]        ; POSITION FIELD
2508         LDB     E,[300600,,(TP)]        ; AND SIZE FILED
2509         IDIVI   0,(E)           ; 0/ BYTES IN 1ST WORD
2510         MOVEI   C,36.           ; BITS PER WORD
2511         IDIVI   C,(E)           ; BYTES PER WORD
2512         PUSH    P,C
2513         SUBM    C,0             ; UNUSED BYTES I 1ST WORD
2514         ADD     0,-1(TP)        ; LENGTH OF WORD BOUNDARIED STRING
2515         MOVEI   C,-1(TP)        ; GET DOPE WORD
2516         PUSHJ   P,BYTDOP
2517         HLRZ    C,(A)           ; GET LENGTH
2518         SKIPGE  -1(A)           ; SKIP IF NOT REALLY ATOM
2519         SUBI    C,3             ; IF IT IS, 3 LESS WORDS
2520         SUBI    A,-1(C)         ;  START +1
2521         MOVEI   B,-1(A)         ; SETUP BYTER
2522         SUB     A,(TP)          ; WORDS DIFFERENT
2523         IMUL    A,(P)           ; CHARS EXTRA
2524         SUBM    0,A             ; FINAL TOTAL TO A
2525         HLL     A,-1(P)
2526         MOVE    C,(P)
2527         SUB     P,[2,,2]
2528         DPB     E,[300600,,B]
2529         IMULI   E,(C)           ; BITS USED IN FULL WORD
2530         MOVEI   C,36.
2531         SUBI    C,(E)           ; WHERE TO POINT IN EMPTY? CASE
2532         DPB     C,[360600,,B]
2533         SUB     TP,[2,,2]
2534         POPJ    P,
2535 \f
2536
2537
2538 ATOP:
2539
2540 GETATO: HLRE    C,B             ;GET -LENGTH
2541         HRROS   B
2542         SUB     B,C             ;POINT PAST
2543         GETYP   0,(B)           ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
2544         CAIN    0,TENTRY                ;IF ENTRY
2545         JRST    EASYTP          ;WANT UNEVALUATED ARGS
2546         HRRE    C,(B)           ;ELSE-- GET NO. OF ARGS (*-2)
2547         SUBI    B,(C)           ;GO TO TOP
2548         TLCA    B,-1(C)         ;STORE NUMBER IN TOP POINTER
2549 EASYTP: MOVE    B,FRAMLN+ABSAV(B)       ;GET ARG POINTER
2550         HRLI    A,TARGS
2551         POPJ    P,
2552
2553 ; COMPILERS ENTRY TO TOP
2554
2555 CITOP:  PUSHJ   P,CPTYEE
2556         CAIN    E,P2WORD        ; LIST?
2557         JRST    WTYPL
2558         PUSHJ   P,@TOPTBL(E)
2559         JRST    MPOPJ
2560
2561 ; FUNCTION TO CLOBBER THE CDR OF A LIST
2562
2563 MFUNCTION PUTREST,SUBR,[PUTREST]
2564         ENTRY   2
2565
2566         MOVE    B,AB            ;COPY ARG POINTER
2567         PUSHJ   P,PTYPE         ;CHECK IT
2568         CAIE    A,P2WORD        ;LIST?
2569         JRST    WTYP1           ;NO, LOSE
2570         ADD     B,[2,,2]        ;AND NEXT ONE
2571         PUSHJ   P,PTYPE
2572         CAIE    A,P2WORD
2573         JRST    WTYP2           ;NOT LIST, LOSE
2574         HRRZ    B,1(AB)         ;GET FIRST
2575         JUMPE   B,OUTRNG
2576         MOVE    D,3(AB)         ;AND 2D LIST
2577         CAIL    B,HIBOT
2578         JRST    PURERR
2579         HRRM    D,(B)           ;CLOBBER
2580         MOVE    A,(AB)          ;RETURN CALLED TYPE
2581         JRST    FINIS
2582
2583 \f
2584
2585 ; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
2586
2587 MFUNCTION BACK,SUBR
2588
2589         ENTRY
2590
2591         MOVEI   C,1             ;ASSUME BACKING UP ONE
2592         JUMPGE  AB,TFA          ;NO ARGS IS TOO FEW
2593         CAML    AB,[-2,,0]      ;SKIP IF MORE THAN 2 ARGS
2594         JRST    BACK1           ;ONLY ONE ARG
2595         GETYP   A,2(AB)         ;GET TYPE
2596         CAIE    A,TFIX          ;MUST BE FIXED
2597         JRST    WTYP2
2598         SKIPGE  C,3(AB)         ;GET NUMBER
2599         JRST    OUTRNG
2600         CAMGE   AB,[-4,,0]      ;SKIP IF WINNING NUMBER OF ARGS
2601         JRST    TMA
2602 BACK1:  MOVE    B,AB            ;SET UP TO FIND TYPE
2603         PUSHJ   P,PTYPE         ;GET PRIM TYPE
2604         MOVEI   E,(A)
2605         MOVE    A,(AB)
2606         SKIPN   B,1(AB)         ;GET DATUM
2607         JRST    OUTRNG
2608         PUSHJ   P,@BCKTBL(E)
2609         JRST    FINIS
2610
2611 PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
2612 [PTMPLT,BCKTMP],[PBYTE,BACKB]]
2613
2614 BACKV:  LSH     C,1             ;GENERAL, DOUBLE AMOUNT
2615         SKIPA   A,$TVEC
2616 BACKU:  MOVSI   A,TUVEC
2617         CAIN    0,SSTORE
2618         MOVSI   A,TSTORA
2619         HRLI    C,(C)           ;TO BOTH HALVES
2620         SUB     B,C             ;BACK UP VECTOR POINTER
2621         HLRE    C,B             ;FIND OUT IF OVERFLOW
2622         SUBM    B,C             ;DOPE POINTER TO C
2623         HLRZ    D,1(C)          ;GET LENGTH
2624         SUBI    C,-2(D)         ;POINT TO TOP
2625         ANDI    C,-1
2626         CAILE   C,(B)           ;SKIP IF A WINNER
2627         JRST    OUTRNG          ;COMPLAIN
2628 BACKUV: POPJ    P,
2629
2630 BCKTMP: MOVSI   C,(C)
2631         SUB     B,C             ; FIX UP POINTER
2632         JUMPL   B,OUTRNG
2633         MOVSI   A,TTMPLT
2634         POPJ    P,
2635
2636 BACKB:  SKIPA   E,[TBYTE]
2637 BACKC:  MOVEI   E,TCHSTR
2638         PUSH    TP,A
2639         PUSH    TP,B
2640         ADDI    A,(C)           ; NEW LENGTH
2641         HRLI    A,(E)
2642         PUSH    P,A             ; SAVE COUNT
2643         LDB     E,[300600,,B]   ;BYTE SIZE
2644         MOVEI   0,36.           ;BITS PER WORD
2645         IDIVI   0,(E)           ;DIVIDE TO FIND BYTES/WORD
2646         IDIV    C,0             ;C/ WORDS BACK, D/BYTES BACK
2647         SUBI    B,(C)           ;BACK WORDS UP
2648         JUMPE   D,CHBOUN        ;CHECK BOUNDS
2649
2650         IMULI   0,(E)           ;0/ BITS OCCUPIED BY FULL WORD
2651         LDB     A,[360600,,B]   ;GET POSITION FILED
2652 BACKC2: ADDI    A,(E)           ;BUMP
2653         CAIGE   A,36.
2654         JRST    BACKC1          ;O.K.
2655         SUB     A,0
2656         SUBI    B,1             ;DECREMENT POINTER PART
2657 BACKC1: SOJG    D,BACKC2        ;DO FOR ALL BYTES
2658 \f
2659
2660
2661         DPB     A,[360600,,B]   ;FIX UP POINT BYTER
2662 CHBOUN: MOVEI   C,-1(TP)
2663         PUSHJ   P,BYTDOP                ; FIND DOPE WORD
2664         HLRZ    C,(A)
2665         SKIPGE  -1(A)           ; SKIP IF NOT REALLY AN ATOM
2666         SUBI    C,3             ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
2667         SUBI    A,-1(C)         ; POINT TO TOP
2668         MOVE    C,B             ; COPY BYTER
2669         IBP     C
2670         CAILE   A,(C)           ; SKIP IF OK
2671         JRST    OUTRNG
2672         POP     P,A             ; RESTORE COUNT
2673         SUB     TP,[2,,2]
2674         POPJ    P,
2675
2676
2677 BACKA:  LSH     C,1             ;NUMBER TIMES 2
2678         HRLI    C,(C)           ;TO BOTH HALVES
2679         SUB     B,C             ;FIX POINTER
2680         MOVE    E,B             ;AND SAVE
2681         PUSHJ   P,GETATO                ;LOOK A T TOP
2682         CAMLE   B,E             ;COMPARE
2683         JRST    OUTRNG
2684         MOVE    B,E
2685         POPJ    P,
2686
2687 ; COMPILER'S BACK
2688
2689 CIBACK: PUSHJ   P,CPTYEE
2690         JUMPL   C,OUTRNG
2691         CAIN    E,P2WORD
2692         JRST    WTYPL
2693         PUSHJ   P,@BCKTBL(E)
2694         JRST    MPOPJ
2695 \f
2696 MFUNCTION STRCOMP,SUBR
2697
2698         ENTRY   2
2699
2700         MOVE    A,(AB)
2701         MOVE    B,1(AB)
2702         MOVE    C,2(AB)
2703         MOVE    D,3(AB)
2704         PUSHJ   P,ISTRCM
2705         JRST    FINIS
2706
2707 ISTRCM: GETYP   0,A
2708         CAIE    0,TCHSTR
2709         JRST    ATMCMP          ; MAYBE ATOMS
2710
2711         GETYP   0,C
2712         CAIE    0,TCHSTR
2713         JRST    WTYP2
2714
2715         MOVEI   A,(A)           ; ISOLATR LENGHTS
2716         MOVEI   C,(C)
2717
2718 STRCO2: SOJL    A,CHOTHE        ; ONE STRING EXHAUSTED, CHECK OTHER
2719         SOJL    C,1BIG          ; 1ST IS BIGGER
2720         ILDB    0,B
2721         ILDB    E,D
2722         CAIN    0,(E)           ; SKIP IF DIFFERENT
2723         JRST    STRCO2
2724         CAIL    0,(E)           ; SKIP IF 2D BIGGER THAN 1ST
2725         JRST    1BIG
2726 2BIG:   MOVNI   B,1
2727         JRST    RETFIX
2728
2729 CHOTHE: JUMPN   C,2BIG          ; 2 IS BIGGER
2730 SM.CMP: TDZA    B,B             ; RETURN 0
2731 1BIG:   MOVEI   B,1
2732 RETFIX: MOVSI   A,TFIX
2733         POPJ    P,
2734
2735 ATMCMP: CAIE    0,TATOM         ; COULD BE ATOM
2736         JRST    WTYP1           ; NO, QUIT
2737         GETYP   0,C
2738         CAIE    0,TATOM
2739         JRST    WTYP2
2740
2741         CAMN    B,D             ; SAME ATOM?
2742         JRST    SM.CMP
2743         ADD     B,[3,,3]        ; SKIP VAL CELL ETC.
2744         ADD     D,[3,,3]
2745
2746 ATMCM1: MOVE    0,(B)           ; GET A  WORD OF CHARS
2747         CAME    0,(D)           ; SAME?
2748         JRST    ATMCM3          ; NO, GET DIF
2749         AOBJP   B,ATMCM2
2750         AOBJN   D,ATMCM1        ; MORE TO COMPARE
2751         JRST    1BIG            ; 1ST IS BIGGER
2752
2753
2754 ATMCM2: AOBJP   D,SM.CMP        ; EQUAL
2755         JRST    2BIG
2756
2757 ATMCM3: LSH     0,-1            ; AVOID SIGN LOSSAGE
2758         MOVE    C,(D)
2759         LSH     C,-1
2760         CAMG    0,C
2761         JRST    2BIG
2762         JRST    1BIG
2763
2764 \f;ERROR COMMENTS FOR SOME PRIMITIVES
2765
2766 OUTRNG: ERRUUO  EQUOTE OUT-OF-BOUNDS
2767
2768 WRNGUT: ERRUUO  EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
2769
2770 IIGETP: JRST    IGETP           ;FUDGE FOR MIDAS/STINK LOSSAGE
2771 IIPUTP: JRST    IPUTP
2772
2773 \f;SUPER USEFUL ERROR MESSAGES   (USED BY WHOLE WORLD)
2774
2775 WNA:    ERRUUO  EQUOTE WRONG-NUMBER-OF-ARGUMENTS
2776
2777 TFA:    ERRUUO  EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2778
2779 TMA:    ERRUUO  EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2780
2781 WRONGT:
2782 WTYP:   ERRUUO  EQUOTE ARG-WRONG-TYPE
2783
2784 IWTYP1:
2785 WTYP1:  ERRUUO  EQUOTE FIRST-ARG-WRONG-TYPE
2786
2787 IWTYP2:
2788 WTYP2:  ERRUUO  EQUOTE SECOND-ARG-WRONG-TYPE
2789
2790 BADTPL: ERRUUO  EQUOTE BAD-TEMPLATE-DATA
2791
2792 BADPUT: ERRUUO  EQUOTE TEMPLATE-TYPE-VIOLATION
2793
2794 WTYP3:  ERRUUO  EQUOTE THIRD-ARG-WRONG-TYPE
2795
2796 WTYPL:  ERRUUO  EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
2797
2798 WTYPUN: ERRUUO  EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
2799
2800 CALER1: MOVEI   A,1
2801 CALER:  HRRZ    C,FSAV(TB)
2802         PUSH    TP,$TATOM
2803         CAIL    C,HIBOT
2804         SKIPA   C,@-1(C)        ; SUBRS AND FSUBRS
2805         MOVE    C,3(C)          ; FOR RSUBRS
2806         PUSH    TP,C
2807         ADDI    A,1
2808         ACALL   A,ERROR
2809         JRST    FINIS
2810
2811
2812 GETWNA: HLRZ    B,(E)-2         ;GET LOSING COMPARE INSTRUCTION
2813         CAIE    B,(CAIE A,)     ;AS EXPECTED ?
2814         JRST    WNA             ;NO,
2815         HRRE    B,(E)-2         ;GET DESIRED NUMBER OF ARGS
2816         HLRE    A,AB            ;GET ACTUAL NUMBER OF ARGS
2817         CAMG    B,A
2818         JRST    TFA
2819         JRST    TMA
2820
2821 END
2822 \f