mim/development/mim/20/zmimi20.mid

   1 ;Set FTKCN non-zero to include debugging count code
   2
   3 TITLE TOPS-20 MIM INTERPRETER (MIMI)
   4
   5 .SYMTAB 8001.,5000.
   6
   7 IF1,[   .TNXDF
   8         .DECSAV
   9         XJRST==JRST 5,                  ; DOESN'T SEEM TO EXIST??
  10         SS%EPN==10000                   ; MAGIC BIT
  11 IFNDEF SWTRP%,SWTRP%==JSYS 573
  12 IFNDEF XSIR%,XSIR%==JSYS 602
  13 IFNDEF SMAP%,SMAP%==JSYS 767
  14         XGVEC==JSYS 606
  15         XSVEC==JSYS 607
  16
  17 ]
  18
  19 FLIP==1                                 ; FLAG TO DO SECTION FLIPPING
  20 MON==0
  21 SBRFY==0                                ; ENABLE "SUBRIFY" STUFF
  22
  23 XBLT==123000,,[020000,,]
  24
  25 A=1
  26 B=2
  27 C=3
  28 D=4
  29 E=5
  30
  31 OP=6
  32 PC=7
  33
  34 O1=10
  35 O2=11
  36 O3=12
  37
  38 R=12
  39 M=13
  40 SP=14
  41 F=15
  42
  43 TP=16
  44 P=17
  45
  46 PV%OFF==3                               ; OFFSET FOR CODE IN PURVEC
  47 TOPGC==777000-1
  48 TOPMGC==777000-1
  49
  50
  51 ENTMAX==0
  52
  53 ZZZ==.
  54
  55 LOC 136                         ; POINTERS TO INTERESTING THING
  56         MIMSEC,,TTBIND
  57         MIMSEC,,BINDID          ; VARIABLE BINDING ID
  58         MIMSEC,,MPATM           ; ATOM TO CALL FOR MAPPING
  59         MIMSEC,,PURVEC          ; PURE VECTOR
  60         MIMSEC,,DBVEC           ; OTHER PURE INFO
  61         MIMSEC,,MINFO           ; POINTER TO INFO VEC
  62         MIMSEC,,TOPOBL          ; OBLIST TABLE
  63         MIMSEC,,PAGPTR          ; POINTER TO PAGE TABLE
  64         MIMSEC,,UWATM           ; UNWIND ATOM
  65         MIMSEC,,ICATM           ; INTERRUPT ATOM
  66         MIMSEC,,ECATM           ; ERROR ATOM
  67         MIMSEC,,NCATM           ; UNDEFINED CALL ATOM
  68
  69 DEFINE PR NM
  70         PRILOC NM,\NM
  71         TERMIN
  72
  73 DEFINE PRILOC M,N
  74 PRINTC /M = N
  75 /
  76 TERMIN
  77
  78 COMPERR:
  79         JRST @[MIMSEC,,CMPERR]
  80 PR COMPERR
  81 FROBBS: SETZ CIEMP
  82         SETZ CINTH
  83         SETZ CIRST
  84         SETZ CIMON
  85         SETZ CIGAS
  86         SETZ CIGVL
  87 FROBL==.-FROBBS
  88
  89 PR FROBBS
  90
  91 INGCPT: MIMSEC,,INGC
  92
  93 PR INGCPT
  94
  95 NOZONE: MIMSEC,,RCL     ; POINTER TO NON-ZONE GC-PARAMS
  96
  97 IRDBLK: 10
  98         RD%JFN                          ; JFNS COMING
  99         .PRIOU                          ; FOR EDITING
 100         0                               ; DESTINATION STRING
 101         0
 102         0
 103         0
 104         IRDBRK                          ; FOR FUTURE EXPANSION
 105         0
 106
 107 IRDBRK: 20000,,400                      ; BREAK ON CONTROL-D
 108         0
 109         0
 110         0
 111 ARDBRK: BLOCK   4                       ; ALTERNATE BREAK MASK FOR READ
 112
 113 DOSOUT: SOUT
 114         POPJ    P,
 115 CZONE:  0                               ; current fs zone
 116 FRAMID: 0
 117 NARGS:  0
 118 UWATM:  0
 119 ;DOCMPR:        0
 120 ;DIDCMP:        0
 121 PNTRET: MIMSEC,,RET2
 122 PNTSTK: MIMSEC,,STKERR
 123 ;TRACE: 0
 124 DOJSYS: XCT     O1
 125 ;        JUMP   16,.+2          ;errors on sin/sout go to EXEC
 126         AOS     (P)
 127         POPJ    P,
 128         0
 129 \f
 130 SUBTTL MACROS
 131
 132 ;Feature test switches:
 133         FTKCN==0                ;ne 0 to include kernel testing code
 134
 135 LOWOP==1000
 136
 137 CUROP==0
 138
 139 DEFINE ENTRY ENTLOC,JSPQ
 140         %!ENTLOC==CUROP
 141 IFE FTKCN,{SETZ ENTLOC  }
 142 IFN FTKCN,{
 143 IFSE JSPQ,,1,,kercal                    ;;all dispatches through this address
 144 IFSN JSPQ,,1,,kerjsp
 145 IF2,{   ZZZ==.
 146         loc kcltab+curop                ;;hide real address in
 147         xwd 1,entloc                    ;;other table (fake multi-sectioning)
 148         LOC ZZZ
 149 }
 150 }
 151         IFG <%!ENTLOC+ENTVEC-ENTMAX>,ENTMAX==%!ENTLOC+1+ENTVEC
 152         IFL <CUROP-LOWOP>,LOWOP==CUROP
 153         CUROP==CUROP+1
 154 TERMIN
 155
 156 IFN FTKCN,{
 157
 158 ;;Some routines are JRST'd to, so we can't account them...
 159 DEFINE OENTRY   ENTLOC,JSPQ
 160         %!ENTLOC==CUROP
 161         SETZ ENTLOC
 162         IFG <%!ENTLOC-ENTMAX+ENTVEC>,ENTMAX==%!ENTLOC+1+ENTVEC
 163         IFL <CUROP-LOWOP>,LOWOP==CUROP
 164         CUROP==CUROP+1
 165 TERMIN
 166 };End FTKCN
 167
 168 IFE FTKCN,{
 169         DEFINE OENTRY ENTLOC,JSPQ
 170         ENTRY ENTLOC,JSPQ
 171 TERMIN
 172 };End NFTKCN
 173
 174 DEFINE TYPREC   TBL,NAM\
 175         $W!NAM=[$TYPCNT_6+$PRECORD,,0]
 176         $T!NAM=$TYPCNT_6+$PRECORD
 177 ZZZ==.
 178         LOC RECTBL+<$TYPCNT*2>
 179         $TFIX,,0
 180         SETZ TBL
 181         LOC ZZZ
 182 $TYPCNT==$TYPCNT+1
 183 TERMIN
 184
 185 DEFINE TYPMAK   PT,NAM\
 186         $W!NAM=[$TYPCNT_6+PT,,0]
 187         $T!NAM=$TYPCNT_6+PT
 188 $TYPCNT==$TYPCNT+1
 189 TERMIN
 190
 191 \f
 192 ENTVEC:
 193 PR ENTVEC
 194 SUBTTL  OPCODE DEFINITIONS
 195
 196         ENTRY   FRAME,T
 197         oENTRY  MCALL,T
 198         oENTRY  ACTIVATION,T
 199         oENTRY  AGAIN
 200         oENTRY  RETURN
 201 RETOFF==.-ENTVEC
 202         oENTRY  RTUPLE
 203         oENTRY  INCALL,T
 204         ENTRY   ARGS,T
 205         ENTRY   TUPLE,T
 206         ENTRY   NEXTS,T
 207         ENTRY   MAKTUP,T
 208         ENTRY   RETRY
 209         ENTRY   CONTENTS,T
 210         ENTRY   PFRAME,T
 211         ENTRY   LEGAL,T
 212         ENTRY   NEWTYPE,T
 213         ENTRY   LIST
 214         ENTRY   UBLOCK
 215         ENTRY   RECORD
 216         ENTRY   NTHU
 217         ENTRY   NTHR
 218         ENTRY   PUTU
 219         ENTRY   PUTR
 220         ENTRY   RESTU,T
 221         ENTRY   BACKU,T
 222         ENTRY   TOPU,T
 223         ENTRY   CONS,T
 224         ENTRY   BIND,T
 225         ENTRY   FIXBIND,T
 226         ENTRY   UNBIND,T
 227         ENTRY   OPENX
 228         ENTRY   CLOSEX
 229         ENTRY   READX
 230         ENTRY   PRINTZ
 231         ENTRY   RESETX
 232         ENTRY   SAVEX
 233         ENTRY   RESTORE
 234         ENTRY   ATIC
 235         ENTRY   INTGO
 236         ENTRY   QUIT
 237         ENTRY   RANDOM,T
 238         ENTRY   MARKL,T
 239         ENTRY   MARKU,T
 240         ENTRY   MARKR,T
 241         ENTRY   MKL,T
 242         ENTRY   MKU,T
 243         ENTRY   MKR,T
 244         ENTRY   SWNEXT,T
 245         ENTRY   TMPTBL,T
 246         ENTRY   XRECOR
 247         ENTRY   RELL,T
 248         ENTRY   RELU,T
 249         ENTRY   RELR,T
 250         oENTRY  UNWCNT
 251         ENTRY   SETZON,T
 252         ENTRY   SINX
 253         ENTRY   SOUTX
 254         ENTRY   GTJFNX
 255         ENTRY   JFNSX
 256         ENTRY   ERSTRX
 257         ENTRY   GTJFNL
 258         ENTRY   IOERR
 259         oENTRY  ACALL
 260         ENTRY   SFRAME,T
 261         oENTRY  MRETUR
 262         ENTRY   RNTIME
 263         ENTRY   SUNWAT,T
 264         ENTRY   TYPEW,T
 265         ENTRY   DFATAL,T
 266         ENTRY   IENABLE
 267         ENTRY   UUBLOCK
 268         ENTRY   SBLOCK
 269         ENTRY   USBLOCK
 270         ENTRY   ILVAL,T
 271         ENTRY   IASS,T
 272         ENTRY   ISET,T
 273         ENTRY   MOVSTR,T
 274         ENTRY   SETSIZ
 275 IFN SBRFY,[
 276         ENTRY   SBFPMP,T
 277         ENTRY   SBFRAM,T
 278 ]
 279 ENDENT==.
 280 PR ENDENT
 281 \f
 282 SUBTTL  Kernel stuff left in section 0 for max winnage
 283
 284 IFN SBRFY,[
 285 SBRFLN==7
 286 SBRMYT==-6
 287 SBRMYM==-5
 288 SBRCLL=-4
 289 SBRFRM==-2
 290 SBRPC==-1
 291 SBRPRV==0
 292
 293 SBFRAM: MOVE    O1,@3(M)                ; get atom of current MSUBR
 294         PUSH    TP,(O1)
 295         ADDI    TP,SBRFLN-1
 296         MOVEM   M,SBRMYM(TP)
 297         SETZM   SBRCLL(TP)
 298         MOVEM   0,SBRPC(TP)
 299         SKIPL   O1,-1(F)
 300          HRROI  O1,(F)
 301         HRRZ    0,O1
 302         SUBI    0,SBRCLL-SBRFRM(TP)
 303         HRL     O1,0
 304         MOVEM   O1,SBRFRM(TP)
 305         MOVEM   F,SBRPRV(TP)
 306         JRST    (PC)
 307 ]
 308
 309 SFRAME: PUSH    TP,[$TSFRAM+$FRMDOPE,,0]
 310         JRST    .+2
 311 FRAME:  PUSH    TP,[$TFRAME+$FRMDOPE,,0]
 312         ADDI    TP,FR.LN
 313         SETZM   -FR.LN+1(TP)
 314         JRST    (PC)
 315
 316 BIND:   PUSH    TP,[$TBIND+$FRMDOPE,,0]
 317         ADDI    TP,8
 318         SETZM   -7(TP)
 319         MOVEI   A,-6(TP)
 320         HRLI    A,-7(TP)
 321         BLT     A,(TP)
 322         MOVEM   SP,-2(TP)
 323         XMOVEI  B,-7(TP)
 324         MOVE    SP,B
 325         MOVE    A,[$TBIND,,16.]         ; LENGTH CHANGED (WAS 6)
 326         JRST    (PC)
 327
 328 FIXBIN: MOVE    A,SP
 329         MOVEI   0,(F)
 330
 331 FIXBLP: MOVE    B,2(A)                  ; THE ATOM FOR THIS BINDING
 332         CAMLE   A,1(B)                  ; Survivored frob, we've already fixed this
 333          JRST   FIXBL1                  ;  guy
 334         MOVE    O1,1(B)                 ; get section
 335         CAMLE   O1,TP                   ; skip if not top level binding
 336 FIXBL1:  CAILE  0,(A)                   ; ARE WE BEHIND THE CURRENT FRAME?
 337           JRST  (PC)
 338 FIXBL2: MOVEM   A,1(B)                  ; MAKE ATOM POINT TO THIS BINDING
 339         SKIPE   A,5(A)                  ; GET PREVIOUS BINDING AND LOOP
 340          JRST   FIXBLP
 341         JRST    (PC)
 342
 343 MCALL:
 344 IFN FTKCN,<     AOS     @[MIMSEC,,KCNTAB+%CALL]>        ;Count calls
 345         SUB     PC,R
 346         HRLI    PC,(SETZ (R))
 347 CALLZ:
 348 CALLR:
 349 ;       SKIPE   TRACE
 350 ;        PUSHJ  P,@[MIMSEC,,TRACIN]
 351 CALLRX: MOVE    C,O2                    ; SAVE # OF ARGUMENTS
 352         SKIPN   B,(O1)                  ; GET GLOBAL BINDING
 353          JRST   @[MIMSEC,,CALNGS]       ; BARF, NOT GASSIGNED!
 354         HLRZ    A,(B)                   ; LOAD GVAL
 355         CAIE    A,$TMSUBR               ; IS IT AN MSUBR?
 356          JRST   @[MIMSEC,,CALNGS]       ; OH, FOO!
 357         MOVE    D,1(B)                  ; GET MSUBR
 358 ICRET:
 359 IFN FTKCN,{     SKIPE   @[MIMSEC,,TRACNT]       ;Trace count?
 360          PUSHJ  P,@[MIMSEC,,TRINCT]     ; Yup
 361 };End FTKCN
 362         SKIPE   B,@1(D)                 ; POINT TO GVAL OF ATOM OF IMSUBR
 363          SKIPN  M,1(B)
 364           JRST  COMPER                  ; If IMSUBR is not assigned...
 365         SKIPL   A,-1(F)                 ; GET PREVIOUS GLUED FRAME
 366          SKIPA  A,F                     ; OR ELSE CURRENT FRAME
 367         HLL     A,F
 368         HRRM    SP,FR.SP(A)             ; SAVE BINDING POINTER
 369         MOVEM   PC,FR.PC(A)             ; SAVE PC (THIS IS WRONG)
 370         LSH     C,1
 371         SUBM    TP,C                    ; POINT ABOVE FIRST ARG
 372         MOVEM   D,FR.MSA-1(C)           ; STORE MSUBR IN FRAME
 373         SKIPL   (F)
 374          SUBI   F,FR.OFF
 375         MOVEM   F,FR.FRA-1(C)           ; STORE PTR TO PREV FRAME
 376         AOS     F,FRAMID                ; GET A UNIQUE ID
 377         HRL     F,O2                    ; SAVE # ARGS IN LH
 378         MOVEM   F,FR.ARG-1(C)           ; STORE ARGS,,ID
 379         XMOVEI  F,-1(C)                 ; POINT AT FRAME
 380         SETZM   (F)                     ; FOR WINNAGE
 381         MOVE    D,7(D)                  ; OFFSET
 382         HLRZ    A,(M)                   ; CHECK FOR FBIN TYPE KLUDGE
 383         MOVE    R,1(M)
 384         CAIE    A,$TPCODE
 385          JRST   .+3
 386         SKIPN   R,PV%OFF(R)
 387          PUSHJ  P,@[MIMSEC,,DMAPIN]
 388         HRLI    D,400000+R
 389         SKIPE   INTFLG
 390          PUSHJ  P,@[MIMSEC,,INTGOC]
 391 ;       SKIPE   DOCMPR
 392 ;        JRST   @[MIMSEC,,STKERR]
 393 STKMNG:
 394 IFE FLIP&0,[    JRST    @D      ]
 395 IFN FLIP&0,[
 396         TLNN    M,1                     ; ODD/EVEN CHECK
 397          JRST   EVNSEC
 398         HRLI    TP,EVSEC
 399         HRLI    F,EVSEC
 400         HRLI    P,EVSEC
 401         JRST    @D
 402
 403 EVNSEC: HRLI    TP,ODDSEC
 404         HRLI    F,ODDSEC
 405         HRLI    P,ODDSEC
 406         JRST    @D ]
 407
 408
 409 UNBIND: SUBI    PC,(R)
 410         HRLI    PC,(SETZ (R))
 411 IUNBIN: MOVEI   C,0                     ; IN CASE NO BINDINGS FLUSHED
 412         SETZB   A,B                     ; IN CASE UNWINDER FOUND
 413         HRRZS   O1
 414 IUNBNL: CAIL    O1,(SP)                 ; IS BINDING POINTER ACCURATE?
 415          JRST   IUNBNQ                  ; YES, RETURN
 416         SKIPN   D,2(SP)                 ; THE ATOM BOUND
 417          JRST   NXTBND
 418         CAMN    D,UWATM                 ; REALLY AN UNWIND?
 419          JRST   @[MIMSEC,,DOUNWI]       ; AND LOOP UNTIL ALL DONE
 420 UNJOIN: MOVE    C,6(SP)                 ; THE OLD BINDING FOR THIS ATOM
 421         MOVEM   C,1(D)                  ; STUFF OLD BINDING INTO ATOM
 422 NXTBND: MOVE    C,SP                    ; SAVE LAST BINDING FLUSHED
 423         MOVE    SP,5(SP)                ; POINT TO PREVIOUS BINDING
 424         JRST    IUNBNL                  ; YES, GO HANDLE IT
 425
 426 IUNBNQ: JRST    @PC
 427 ;       JUMPE   C,@PC
 428 ;       HLL     C,TP
 429 ;       CAMGE   C,TP                    ; NEED  STACK TO FLUSH?
 430 ;        XMOVEI TP,-2(C)                ; FLUSH BINDING DW AS WELL
 431 ;       JRST    @PC
 432
 433 RETURN:
 434 IFN FTKCN,<     AOS     @[MIMSEC,,KCNTAB+%RETUR]>
 435 ;       SKIPE   DIDCMP                  ; SEE IF MUST CHECK FOR OVFL PAGE HACK
 436 ;        JRST   @[MIMSEC,,RET2]
 437 RET3:   SKIPL   C,(F)                   ;NOTE THIS INSTRUCTION CAN BE MUNGED!!!
 438          JRST   IRET1
 439         XMOVEI  TP,-2(F)
 440         HRR     F,1(F)
 441 IFE SBRFY,[     JRST    @C]
 442 IFN SBRFY,[     TLZN    C,SBRCAL        ; SKIP IF SUBRIFY
 443                  JRST   @C
 444                 MOVE    M,-2(TP)        ; CALLER'S M
 445                 SUBI    TP,4
 446                 HLRZ    0,(M)           ; CHECK FOR PMAPPED
 447                 MOVE    R,1(M)
 448                 CAIN    0,$TPCODE
 449                  SKIPE  R,PV%OFF(R)
 450                   JRST  @C
 451                 PUSHJ   P,@[MIMSEC,,DMAPI1]
 452                 JRST    @C]
 453
 454 IRET1:
 455 ;       SKIPE   TRACE
 456 ;        PUSHJ  P,@[MIMSEC,,TRACOUT]
 457         JSP     E,FRMFIX
 458         JRST    @PC
 459
 460 FRMFIX: MOVEI   O1,-FR.LN(F)
 461         CAIGE   O1,(SP)                 ; DO WE NEED SOME UNBINDING?
 462          JSP    PC,IUNBNL       ; YES. DO THEM
 463         XMOVEI  TP,-FR.LN(F)
 464         HRR     F,FR.FRA(F)             ; GET PREVIOUS FRAME
 465         SKIPL   (F)
 466          JRST   [ADDI   F,FR.OFF
 467                  MOVE   C,F
 468                  MOVEI  O2,0
 469                  JRST   CHPCO]
 470         MOVE    C,FR.FRA(F)
 471         SETCM   O2,C
 472         HLL     C,F
 473 CHPCO:  MOVE    PC,FR.PC(C)             ; RESTORE PC FROM FRAME
 474         SKIPN   M,FR.MSA(C)             ; RESTORE MSUBR PTR FROM FRAME
 475          JRST   RESTPC
 476         MOVE    M,@1(M)                 ; POINT TO GBIND THROUGH ATOM
 477         MOVE    M,1(M)                  ; GET IMSBUR INTO M
 478 RESTPC: JUMPE   M,(E)
 479         HLRZ    O1,(M)                  ; CHECK FOR FBIN TYPE KLUDGE
 480         MOVE    R,1(M)
 481         CAIE    O1,$TPCODE
 482          JRST   .+3
 483         SKIPN   R,PV%OFF(R)
 484          PUSHJ  P,@[MIMSEC,,DMAPI1]
 485 IFN SBRFY,[
 486         TLNN    O2,-1
 487 IFE FLIP&0,[    JRST    (E)]
 488 IFN FLIP&0,[    JRST    NOSBR]
 489         HLRZS   O2                      ; FIND FRAME OF SUBRIFIED THING
 490         ADD     C,O2                    ;  THROUGH GROSS HAIR
 491         DMOVE   R,@(C)                  ; ONLY WORKS CAUSE R=M-1
 492         JRST    RESTPC
 493 NOSBR:  ]
 494 IFE FLIP&0,[    JRST    (E)     ]
 495 IFN FLIP&0,[
 496         TLNN    M,1                     ; ODD/EVEN CHECK
 497          JRST   EVNSE3
 498         HRLI    TP,EVSEC
 499         HRLI    F,EVSEC
 500         HRLI    P,EVSEC
 501         JRST    (E)
 502
 503 EVNSE3: HRLI    TP,ODDSEC
 504         HRLI    F,ODDSEC
 505         HRLI    P,ODDSEC
 506         JRST    (E) ]
 507
 508 ; MAKTUP -- 0/ TOTAL ARGS PASSED, O1/ REQUIRED+OPT ARGS, O2/ #TEMPS
 509
 510 MAKTUP:
 511         SUB     0,O1                    ; SUBTRACT REQUIRED ARGUMENTS
 512         LSH     O2,1                    ; O2 IS NUMBER OF TEMPS
 513         ADJSP   TP,(O2)                 ; BUMP TP TO REFLECT THIS
 514         SKIPG   A,0                     ; A NOW HAS LENGTH OF TUPLE IN RH
 515          JRST   IMAKET                  ;       ZERO LENGTH TUPLE
 516         LSH     O1,1                    ; WORDS WORTH OF REQUIRED ARGS
 517         MOVN    C,0                     ; # ARGS TO MOVE (NEG FOR XBLT)
 518         ASH     C,1                     ;  TO NUMBER OF WORDS
 519         MOVEI   D,2(O1)                 ; D/ # OF REQ ARGS+2
 520         ADD     D,F                     ; D POINT TO FIRST TUPLE WORD
 521         SUB     D,C                     ; NOW LAST TUPLE WORD+1
 522         MOVE    E,D                     ; COMPUTE DEST
 523         ADD     E,O2                    ; ADD IN DELTA
 524         XBLT    C,
 525         HRLI    A,$TTUPLE
 526         MOVE    B,E
 527         JRST    PUSHDW
 528
 529 IMAKET:
 530         MOVSI   A,$TTUPLE
 531         XMOVEI  B,1(TP)                 ; POINT AT DOPE WORD FOR EMPTY TUPLE
 532 PUSHDW: LSH     0,1                     ; MAKE IT BE # OF WORDS INSTEAD OF ELTS
 533         HRLI    0,$TTUPLE+$FRMDOPE      ; GENERATE A DOPE WORD
 534         PUSH    TP,0
 535         PUSH    TP,[0]                  ; MUST PUT IN OTHER DOPE WORD
 536         SKIPGE  FR.TP(F)                ; SKIP IF MUST MUNG FRAME
 537          JRST   (PC)
 538         MOVEI   0,(F)
 539         SUBI    0,(TP)
 540         HRLM    0,FR.ARG(F)             ; INDICATE IN FRAME
 541         JRST    (PC)
 542
 543 CONS:   JSP     OP,ICELL1               ; GET LIST CELL
 544          JRST   @[MIMSEC,,CONS1]        ; REQS A GC
 545
 546         MOVEM   E,(A)
 547         DMOVEM  C,1(A)
 548         MOVE    B,A
 549         MOVSI   A,$TLIST
 550         JRST    (PC)
 551
 552
 553 ICELL1: SKIPN   B,CZONE
 554          XMOVEI B,NOZONE-GCPOFF
 555         MOVE    B,GCPOFF(B)
 556         SKIPE   A,RCLOFF(B)
 557          JRST   [MOVE   0,(A)
 558                  MOVEM  0,RCLOFF(B)
 559                  JRST   1(OP)]
 560 ;       MOVE    0,GCFLGO(B)
 561 ;       TLNE    0,$GC%PB                        ; ONLY PAGES FROM ZONE?
 562 ;        JRST   CMPERR
 563 ICELL2: MOVE    A,GCSBOF(B)
 564         MOVEI   0,3
 565         ADDB    0,GCSBOF(B)
 566         CAMG    0,GCSMXO(B)
 567          JRST   1(OP)                           ; SKIP RET, ALL IS WELL
 568         JRST    (OP)
 569
 570 TUPLE:  MOVE    B,TP                    ; POINT TO STACK
 571         MOVE    A,O1                    ; SAVE LENGTH
 572         LSH     O1,1
 573         SUBI    B,-1(O1)
 574         HRLI    O1,$TTUPLE+$FRMDOP
 575         PUSH    TP,O1
 576         PUSH    TP,[0]
 577         HRLI    A,$TTUPLE               ; TYPE/LENGTH IN A
 578         JRST    (PC)
 579
 580 SUBTTL OPEN COMPILER UTILITIES
 581
 582 CIEMP:
 583 IFN FTKCN,<AOS  @[MIMSEC,,KCNTAB+CUROP]>
 584         MOVE    0,A                     ; POSSIBLE COUNT
 585         LDB     A,[220300,,A]           ; ISOLATE PRIMTYPE
 586         JUMPE   A,COMPER
 587         JRST    CIMON1
 588 CIMON:
 589 IFN FTKCN,<AOS  @[MIMSEC,,KCNTAB+CUROP+1]>
 590         MOVE    0,A                     ; POSSIBLE COUNT
 591         LDB     A,[220300,,A]           ; GET PRIMTYPE
 592 CIMON1: CAIN    A,$PLIST
 593          JUMPN  B,CIMON3
 594         CAIL    A,$PBYTES
 595          TRNN   0,-1
 596           ADDI  PC,1
 597 CIMON3: MOVE    A,0
 598         JRST    (PC)
 599
 600 ;CIMTBL:        SKIPA
 601 ;       SKIPE   B
 602 ;       SKIPA                           ; THIS IS REALLY WRONG!!!
 603 ;       SKIPA
 604 ;       TRNE    0,-1
 605 ;       TRNE    0,-1
 606 ;       TRNE    0,-1
 607 ;       TRNE    0,-1
 608
 609 CINTH:
 610 IFN FTKCN,<AOS  @[MIMSEC,,KCNTAB+CUROP+2]>
 611         LDB     A,[220300,,A]
 612         XCT     CINTBL(A)
 613         JRST    (PC)
 614
 615 CINTBL: JRST    COMPER
 616         DMOVE   A,1(B)
 617         JRST    COMPER
 618         JRST    COMPER
 619         JRST    DOILD1
 620         JRST      [MOVSI  A,$TCHARACTER
 621                    JRST DOILDB ]
 622         JRST      [MOVE   B,(B)
 623                    MOVSI  A,$TFIX
 624                    JRST (PC)]
 625         DMOVE   A,(B)
 626
 627 DOILD1: MOVSI   A,$TFIX
 628 DOILDB: ILDB    B,B
 629         JRST    (PC)
 630
 631 CIRST:
 632 IFN FTKCN,<AOS  @[MIMSEC,,KCNTAB+CUROP+3]>
 633         LDB     0,[220300,,A]
 634         ADDI    0,CIRTBL
 635         TLO     0,(SETZ)
 636         JRST    @0
 637
 638 CIRTBL: JRST    COMPER
 639         JRST    [MOVE  B,(B)
 640                  MOVSI A,$TLIST
 641                  JRST   (PC)]
 642         JRST    COMPER
 643         JRST    COMPER
 644         JRST    [HRLI    A,$TBYTES
 645                  JRST DOIBP]
 646         JRST    DOIBP1
 647         AOJA    B,[HRLI  A,$TUVECTOR
 648                    SOJA  A,(PC)]
 649         ADDI    B,2
 650         HRLI    A,$TVECTOR
 651 ;       CAMG    B,[TPSEC+2,,]           ; Win with tuples???
 652 ;        HRLI   A,$TTUPLE
 653         SOJA    A,(PC)
 654
 655 DOIBP1: HRLI    A,$TSTRING
 656 DOIBP:  IBP     B
 657         SOJA    A,(PC)
 658
 659 CONSTANTS
 660
 661
 662 INSDIS: .+1
 663 INSDO:  0
 664         JRST    @INSRE1
 665         JRST    @INSRE2
 666 INSRE1: 0
 667 INSRE2: 0
 668 INSEFF: 0
 669 INTFLG: 0
 670 ENDP1==.
 671 PR ENDP1
 672 \f
 673
 674 RH==2200
 675 LH==222200
 676
 677 STACKL==20000.
 678 PDLLEN==1000.
 679
 680 LENWRD==2200                            ; LENGTH WORD
 681 TYPWRD==222200                          ; TYPE WORD
 682
 683 UPTBYT==220200                          ; UBLOCK-PRIMTYPE PART OF TYPE WORD
 684 PTPBYT==220300                          ; PRIMTYPE PART OF TYPE WORD
 685 TYPBYT==301200                          ; TYPE PART OF TYPE WORD
 686 RTYBYT==061200                          ; FOR A TYPE IN THE RH
 687 MONBYT==250200                          ; MONITOR PART OF TYPE WORD
 688 $FRMDOPE==40                            ; LH BIT FOR DOPE WORD
 689 $DOPEBIT==400000
 690 $QSFRB==100000                          ; BIT IN GLUED FRM PC IF SEG CALL
 691                                         ; **** CAUTION SUSPECT IN FUTURE
 692                                         ;      VERSIONS OF THE 20 ****
 693 SBRCAL==200000                          ; BIT IF "SUBRIFY CALL"
 694 ; Flags associated with gc spaces (see GCSFLGs) (LEFT HALF WORD)
 695
 696 $GC%DW==400000                          ; don't create dope words
 697 $GC%PB==200000                          ; only on page boundaries
 698
 699 LOC 1000
 700
 701 SPCSET: BLOCK   20.
 702 SPCGET: BLOCK   20.
 703
 704 STPG==._<-9.>
 705
 706 RECTBL: BLOCK   256.*2                  ; Each entry is a type/val pair
 707 FNBLK:  BLOCK   40.
 708 GTJFBK: BLOCK   20
 709 GTJFB2=GTJFBK+1
 710 GTJFOS=GTJFB2+.GJCPP
 711
 712 ; UVECTOR of machine dependent information
 713
 714 MINF:   100                             ; jfn for tty input
 715         101                             ; jfn for tty output
 716         36.                             ; bits per word
 717         7.                              ; bits per character
 718         512.                            ; words per page
 719         5                               ; characters per word
 720         0                               ; shift for address in word terms
 721         4                               ; bytes per word
 722         377777777777                    ; largest possible number (float)
 723         400000000001                    ; smallest possible number (float)
 724
 725 BOOTYP: 0
 726
 727 ; WHAT FOLLOWS IS THE INITIAL SET OF GC-PARAMS, USED UNTIL THE
 728 ; FS SYSTEM IS STARTED.
 729
 730 RCL:    0
 731
 732 ; RCLV IS A POINTER STRUCTURE OF FREE NON-LIST STORAGE.
 733 ; IT IS CHAINED TOGETHER SUCH THAT MOVE AC,(AC) WILL GET THE
 734 ; NEXT FREE BLOCK OF STORAGE.  THE LENGTH OF A GIVEN BLOCK
 735 ; POINTED AT BY AC IS TWO PLUS THE RIGHT HALF OF -1(AC).
 736 ; THIS WORD, I.E. -1(AC) IS THE FIRST DOPE WORD OF THE BLOCK
 737 ; WHICH WAS RECYCLED.
 738 ; BELOW IS A SCHEMATIC REPRESENTATION OF RCLV
 739
 740 ;          BITS,,LENGTH-2     BITS,,LENGTH-2
 741 ; RCLV ->  NEXT FREE BLOCK -> NEXT FREE BLOCK -> ... -> 0
 742
 743 ;       0                       ; 'TYPE WORD' FOR RCLV (ALWAYS 0)
 744 RCLVOF==.-RCL
 745 RCLV:   0                       ; RECYCLE VECTOR
 746 ;       0
 747 0
 748 RCLV2O==.-RCL
 749 RCLV2:  0
 750 ;       0
 751 RCLV3O==.-RCL
 752 RCLV3:  0
 753 ;       0
 754 RCLV4O==.-RCL
 755 RCLV4:  0
 756 ;       0
 757 0
 758 0
 759 RCLV7O==.-RCL
 760 RCLV7:  0
 761 ;       0
 762 RCLV8O==.-RCL
 763 RCLV8:  0
 764 ;       0
 765 0
 766 RCL10O==.-RCL
 767 RCLV10: 0
 768 GCSBOF==.-RCL
 769 GCSBOT: 0                       ; CURRENT GC POINTER
 770 GCSMIO==.-RCL
 771 GCSMIN: GCSTRT
 772 GCSMXO==.-RCL
 773 GCSMAX: 0
 774 GCFLGO==.-RCL
 775 GCFLGS: 0
 776 GCPL==.-RCL
 777
 778 SAVAC:  BLOCK   20
 779 SAVPC:  0
 780
 781 ;TRACE: 0
 782 TRACL:  10
 783 TRACTM: 0
 784
 785
 786 ICMPER: 0
 787         JRST    CMPERR
 788
 789 UUOH:   0
 790         XJRST   .+1
 791                 0
 792                 MIMSEC,,UUOH1
 793 PAGTLN==512.
 794 PAGTBL: REPEAT  PAGTLN,0
 795 INGC:   0
 796         0
 797 PCLEV1: 0                               ; two words per int pc for multi-sec
 798         0
 799 PCLEV2: 0
 800 DUALPC: 0
 801         0
 802 RUNINT: 0                               ; IF NON-ZERO, RUN INTS IMMEDIATELY
 803 MLTUUP: 0                               ; HOLDS UUO (SWAPPED SORT OF)
 804 MLTPC:  0                               ; 23 BIT PC
 805 UUOE:
 806 MLTEA:  0                               ; EFF ADDR OF UUO INSTRUCTION
 807 MLTUUH: MIMSEC,,MLTUOP                  ; RUN IN MIMSEC
 808
 809 INITZN==1                               ; for now...
 810
 811 $TANY==0
 812 $TBOOLEAN==0
 813
 814 $PFIX==0
 815 $PLIST==1
 816 $PRECORD==2
 817 $PSTRING==5
 818 $PUVECTOR==6
 819 $PVECTOR==7
 820 $PBYTES==4
 821 $PBITS==7
 822
 823 $TYPCNT==0
 824
 825 ; Offsets associated with FRAMEs
 826
 827 FR.LN==6                                ; Length of full frame
 828 FR.OFF==4                               ; Offset from F to real frame ptr
 829 FR.ACT==1                               ; Offset for PC for activation
 830 FR.SP==0                                ; Offset for saved binding (rh)
 831 FR.TP==0                                ; Offset for saved TP (lh)
 832 FR.FRA==-1                              ; Offset for previous frame
 833 FR.ARG==-2                              ; Offset for # of args to this guy (lh)
 834 FR.ID==-2                               ; Offset for frame id  (rh)
 835 FR.PC==-3                               ; Offset for saved PC
 836 FR.MSA==-4                              ; Offset for save MSUBR pointer
 837 FR.HDR==-5                              ; Offset for FRAME header
 838 \f
 839 SUBTTL MULTIS
 840
 841 ;  In multi-section/extended addressing mode, MIMI20 lives in section 1.
 842 ;  it is mapped there at startup time.  MIMI should be able to run in either
 843 ;  single or multi section mode.  The TP stack lives in a section of its own
 844 ;  and everything else is GC space (for now).
 845
 846 MIMSEC==1                               ; MIMI sections
 847 TPSEC==1                                ; STACK sections
 848 IFE FLIP,[ INIGC==TPSEC+2               ; First GC section
 849            ]
 850 IFN FLIP,[ INIGC==TPSEC+2
 851            IFE TPSEC&1,[        ODDSEC==TPSEC+1
 852                                 EVSEC==TPSEC ]
 853            IFN TPSEC&1,[        ODDSEC==TPSEC
 854                                 EVSEC==TPSEC+1 ] ]
 855
 856 COMPAG==0                               ; page mapped into all sections except
 857                                         ; stack
 858 NUMSEC==12                              ; total # of initial sections
 859                                         ; (initial value of CURSIZ...)
 860 STRTTP==200000                          ; begin control stack to avoid paging
 861                                         ;       problems
 862 STPDL==777000                           ; put P stack in a strange place also
 863 PGPDL==<<TPSEC_9>\<<STPDL>_<-9>>>       ; P STACK PAGE
 864 TPENDP==PGPDL-1                         ; illegal page to end TP
 865 TPWARN==TPENDP-5                        ; page to warn of end
 866 \f
 867
 868
 869 SUBTTL  TYPE DEFINITIONS
 870
 871         TYPMAK  $PFIX,UNBOUND
 872         TYPMAK  $PFIX,FIX
 873         TYPMAK  $PFIX,CHARACTER
 874         TYPMAK  $PFIX,FLOAT
 875
 876         TYPMAK  $PLIST,LIST
 877         TYPMAK  $PLIST,FALSE
 878         TYPMAK  $PLIST,DECL
 879
 880         TYPMAK  $PSTRING,STRING
 881         TYPMAK  $PUVECTOR,MCODE
 882
 883         TYPMAK  $PVECTOR,VECTOR
 884         TYPMAK  $PVECTOR,MSUBR
 885
 886         TYPREC  FRMTBL,FRAME
 887         TYPREC  BNDTBL,BINDING
 888         TYPREC  ATMTBL,ATOM
 889         TYPREC  ATMTBL,OBLIST
 890         TYPREC  GBNTBL,GBIND
 891
 892         TYPMAK  $PLIST,FORM
 893
 894 ; TYPES STARTING HERE SHOULD BE HANDLED DIFFERENTLY AT SOME
 895 ; FUTURE DATE.
 896
 897         TYPMAK  $PFIX,TYPC
 898         TYPMAK  $PFIX,TERMIN
 899
 900         TYPMAK  $PLIST,SEGMENT
 901         TYPMAK  $PLIST,DEFER
 902         TYPMAK  $PLIST,FUNCTION
 903         TYPMAK  $PLIST,MACRO
 904
 905         TYPMAK  $PVECTOR,CHANNEL
 906         TYPMAK  $PVECTOR,ENTRY
 907         TYPMAK  $PVECTOR,ADECL
 908         TYPMAK  $PVECTOR,OFFSET
 909
 910         TYPREC  ATMTBL,LVAL
 911         TYPREC  ATMTBL,GVAL
 912         TYPREC  ATMTBL,LINK
 913
 914         TYPMAK  $PVECTOR,TUPLE
 915         TYPMAK  $PUVECTOR,UVECTOR
 916         TYPMAK  $PVECTOR,IMSUBR
 917         TYPREC  QFTBL,QFRAME
 918         TYPMAK  $PVECTOR,TAT
 919         TYPMAK  $PVECTOR,I$SDTABLE
 920         TYPMAK  $PVECTOR,I$DISKCHANNEL
 921         TYPMAK  $PVECTOR,MUDCHAN
 922         TYPMAK  $PFIX,WORD
 923         TYPMAK  $PUVECTOR,PCODE
 924         TYPMAK  $PVECTOR,ZONE
 925         TYPMAK  $PUVECTOR,GCPARAMS
 926         TYPMAK  $PUVECTOR,AREA
 927         TYPREC  FRMTBL,SFRAME
 928         TYPMAK  $PBYTES,BYTES
 929         TYPMAK  $PFIX,TYPW
 930         TYPREC  QFTBL,QSFRAM
 931         TYPMAK  $PFIX,BITS
 932 \f
 933
 934 MPATM:                  0
 935 PURVEC:                 0
 936 DBVEC:                  0       ; LOCATIONS WHERE PURE VEC STUFF IS STORED
 937 MINFO:                  MINF
 938 TOPOBL:                 0
 939                         0
 940 PAGPTR:                 $TUVEC,,PAGTLN
 941                         0
 942 ICATM:                  0
 943 ECATM:                  0
 944 NCATM:                  0
 945 BINDID:                 0       ; USED IN BININING
 946 TTBIND:                 0       ; TOP LEV BIND
 947
 948 CURSIZ: NUMSEC                  ; Number of sections we have
 949
 950 PURZON: 0
 951 ATMZON: 0
 952
 953 RETPUR: MOVE    A,PURVEC
 954         MOVE    B,DBVEC
 955         HALTF
 956         MOVE    A,[SAVAC+B,,B]          ; Restore ACs
 957         BLT     A,P
 958         MOVE    B,PURZON                ; Pick up pure zone
 959         MOVE    C,ATMZON                ; and atom zone
 960         MOVEM   A,INTSAV                ; Make sure flag set
 961         PUSHJ   P,SAV1                  ; Go do the save
 962         HALTF
 963
 964 IFN FTKCN,{
 965 ;storage for metering
 966 ksava:  block 1         ;save ac a
 967 kcntab: block 400       ;count of calls
 968 kcltab: block 400       ;addresses of routines to call
 969 ;storage for trace counting
 970 tracnt: block 1         ;0 means don't count calls
 971         tranum==4000    ;number of different atoms we may see:
 972 tratab: block tranum+1  ;tbluk table for atom names
 973 trascr: block tranum*3  ;scratch space for atom names
 974 traptr: block 1         ;pointer to first free word in scratch space
 975 tranam: block 10        ;temp space for atom name before lookup
 976 trsava: block 2         ;save a,b
 977 trsavc: block 2         ;save c,d
 978 trsav5: block 2         ;save 5,6
 979 initra: push    p,a
 980         movei   a,trascr        ;address of scratch space
 981         movem   a,traptr        ;is first free at startup
 982         hrrzi   a,tranum        ;0,,num
 983         movem   a,tratab        ;tbluk table header
 984         pop     p,a             ;restore ac
 985         popj    p,              ;and return init'd
 986 ;print out the table (and zero it)
 987 pritab: dmovem  a,trsava
 988         dmovem  c,trsavc
 989         dmovem  5,trsav5
 990 priget: hrroi   a,[asciz/Output file for trace: /]
 991         PSOUT
 992         move    a,[gj%sht+gj%fns]
 993         move    b,[.priin,,.priout]
 994         GTJFN
 995          jrst   priget
 996         move    b,[070000,,300000]      ;7-bit read/write
 997         OPENF
 998          jrst   priget                  ;clever error handling
 999 prilup: hlrz    5,tratab                ;number of entries in table
1000         movn    5,5                     ;negate
1001          jumpe  5,pridun                ;done?
1002         hrlz    5,5                     ;in left half
1003         setz    3,                      ;largest count so far....
1004
1005 plup:   hrrz    4,tratab+1(5)           ;get a canditate count
1006         caml    4,3                     ;bigger or equal?
1007          jrst   [ hrrz  6,5             ;yes, store new index
1008                   hrrz  3,tratab+1(6)   ;and new count
1009                   jrst  .+1]
1010         aobjn   5,plup                  ;iterate
1011 ;index of largest entry in ac 6 now
1012         setzb   3,4
1013         hrroi   b,[asciz/
1014 /]
1015         SOUT
1016         hlro    b,tratab+1(6)           ;name
1017         SOUT
1018         hrrz    b,tratab+1(6)           ;count
1019         move    c,[100010,,12]          ;8 columns, leading filler, decimal
1020         NOUT
1021          jfcl
1022         hlrz    4,tratab                ;table size
1023         move    3,tratab+1(4)           ;top entry
1024         exch    3,tratab+1(6)           ;flush out biggest entry
1025         sos     4                       ;decrement used size
1026         hrlm    4,tratab                ;save nwe count
1027         jrst    prilup                  ;and iterate
1028 pridun: CLOSF                           ;close the file
1029          jfcl                           ;clever error handling
1030         dmove   a,trsava
1031         dmove   c,trsavc
1032         dmove   5,trsav5
1033         popj    p,                      ;and return to caller
1034 ;here to count a call
1035 trinct: dmovem  a,trsava
1036         dmovem  c,trsavc
1037         move    b,3(d)          ;get name of msubr
1038         move    a,3(b)          ;get string (count,,address)
1039         hrrz    b,2(b)          ;count into b
1040         move    c,[440700,,tranam]      ;temp space for name
1041         ildb    d,a             ;get bytes
1042         idpb    d,c             ;and put them
1043         sojg    b,.-2           ;until there ain't no more (assumes 1 or more)
1044         setz    d,              ;null terminator
1045         idpb    d,c
1046         movei   a,tratab        ;table address
1047         move    b,[440700,,tranam]      ;point to string
1048         TBLUK                   ;is it there?
1049         tlne    b,40000         ;set if exact match
1050          jrst   [aos (a)                ;bump count
1051                  jrst trret]            ;and return this call
1052 ;not in table, must add it
1053         move    c,traptr        ;get address of first free
1054         hrli    c,440700        ;byte pointer
1055         move    a,[440700,,tranam]      ;
1056         ildb    d,a             ;get bytes
1057         idpb    d,c             ;and put them
1058         jumpn   d,.-2           ;do til null
1059         movei   a,tratab        ;table address
1060         hrlz    b,traptr        ;address,,0
1061         aos     b               ;,,1 initial count
1062         TBADD                   ;add to table
1063         aos     c               ;bump pointer to next word boundary
1064         hrrzm   c,traptr        ;and store it
1065 trret:  dmove   a,trsava
1066         dmove   c,trsavc
1067         popj    p,
1068
1069 ;Dispatch routine to use for metering calls into the kernel
1070 kerjsp: movem   a,ksava         ;called with JSP PC,
1071         hrrz    a,-1(pc)        ;get table offset
1072         aos     kcntab-entvec(a)        ;bump counter
1073         move    a,kcltab-entvec(a)      ;get real addr
1074         exch    a,ksava         ;restore a and setup to call
1075         jrst    @ksava
1076 kercal: movem   a,ksava         ;save a
1077         move    a,(p)           ;return address
1078         sos     a               ;caller's address
1079         hrrz    a,(a)           ;table offset used in call
1080         subi    a,entvec        ;table index relative to table start
1081         aos     kcntab(a)       ;count calls to this routine
1082         move    a,kcltab(a)     ;get address of routine being called
1083         exch    a,ksava         ;restore a and save routine address
1084         jrst    @ksava          ;do the real kernel call
1085
1086 };End FTKCN
1087
1088 LOC <<.+777>&777000>
1089
1090 SUBTTL  STACK OPERATIONS & FLOW OF CONTROL
1091
1092 ; LEGAL? TAKES ARGUMENT IN A & B
1093
1094 LEGAL:  HLRZ    C,A             ; GET TYPE OF FROBBIE
1095         CAIN    C,$TFRAME
1096          JRST   LGLFRM
1097         CAIN    C,$TBIND
1098          JRST   LGLBND
1099         MOVE    C,B
1100         TLZ     C,770000        ; CLEAR OUT BYTE POINTER BITS
1101         CAML    C,[INIGC,,0]    ; SKIP IF IN STACK AREA
1102          JRST   LGLTRU
1103         HRRZ    C,TP
1104         HRRZ    D,B
1105         CAMLE   D,C             ; SKIP IF ON STACK
1106          JRST   LGLFLS          ; NO, A LOSER
1107         LDB     D,[220300,,A]   ; GET SAT
1108         JRST    @LGLTAB(D)      ; DISPATCH
1109 LGLTRU: MOVSI   A,$TFIX
1110         JRST    (PC)
1111 LGLTAB: SETZ    LGLTRU
1112         SETZ    LGLTRU
1113         SETZ    LGLTRU
1114         SETZ    LGLTRU
1115         SETZ    LGLBYT
1116         SETZ    LGLSTR
1117         SETZ    LGLUVC
1118         SETZ    LGLTUP
1119 LGLBYT:
1120 LGLSTR: TLZ     A,-1
1121         IBP     A,B             ; REST TO END OF STRING
1122         ADDI    A,1             ; TO NEXT WORD
1123 LGLCOM: HLRZ    B,(A)
1124         TRNN    B,$FRMDOPE      ; DOPE WORD?
1125          JRST   LGLFLS          ; NO, LOSER
1126         HRRZ    B,(A)
1127         MOVE    D,(A)
1128         SUB     A,B
1129         CAME    D,-1(A)
1130          JRST   LGLFLS
1131         JRST    LGLTRU
1132 LGLUVC: TLZ     A,-1
1133         MOVE    C,B
1134         ADD     A,C
1135         JRST    LGLCOM
1136
1137 LGLFRM: MOVSI   D,<$TFRAME+$FRMDOPE>
1138         MOVSI   E,<$TSFRAM+$FRMDOPE>
1139 LGLFR1: HRRZ    C,B
1140         CAILE   C,(TP)
1141          JRST   LGLFLS
1142         HLL     C,TP
1143         MOVE    C,-1(B)
1144         MOVSI   A,$TFIX
1145         CAME    C,E
1146          CAMN   C,D
1147           JRST  (PC)
1148 LGLFLS: SETZ    B,
1149         MOVSI   A,$TFALSE
1150         JRST    (PC)
1151
1152 LGLBND: CAML    B,[INIGC,,0]
1153          JRST   LGLTRU
1154         MOVSI   D,<$TBIND+$FRMDOPE>
1155         MOVE    E,D
1156         JRST    LGLFR1
1157
1158 LGLTUP: HRRZ    C,B
1159         CAILE   C,(TP)
1160          JRST   LGLFLS
1161         HRRZS   A
1162         LSH     A,1
1163         HLL     B,TP
1164         ADD     A,B
1165         HLRZ    D,(A)
1166         CAIE    D,$TVECTOR+$FRMDOPE
1167          CAIN   D,$TTUPLE+$FRMDOPE
1168           JRST  LGLTRU
1169         HLRZ    D,-FR.LN-1(B)           ; SEE IF ARGS OF A FRAME
1170         CAIE    D,$TFRAME+$FRMDOPE
1171          CAIN   D,$TSFRAM+$FRMDOPE
1172           JRST  LGLTRU
1173
1174 ;here to check for rested args of a frame
1175
1176         MOVE    D,F                     ; start at current frame
1177 LGLTU3: SKIPL   (D)                     ; glued frame
1178          JRST   LGLTU2
1179         HRRZ    D,-1(D)                 ; get real frame
1180         HLL     D,F
1181 LGLTU2: CAMG    D,B                     ; skip if frame above tuple
1182          JRST   LGLTU1
1183         MOVE    D,-1(D)
1184         SKIPL   (D)
1185          ADDI   D,FR.OFF
1186         JRST    LGLTU3
1187 LGLTU1: HLRE    C,FR.ARG(D)             ; get arg count
1188         JUMPL   C,LGLFLS
1189         LSH     C,1
1190         ADDI    D,2(C)                  ; should be tuple end
1191         CAME    D,A
1192          JRST   LGLFLS
1193         JRST    LGLTRU
1194
1195 PFRAME: HLL     O1,TP
1196         MOVE    B,3(O1)
1197         SKIPL   (B)
1198          JRST   IPFRM1
1199         HRRZ    B,-1(B)
1200         SUBI    B,FR.OFF
1201         HLL     B,F
1202 IPFRM1: MOVE    A,$WFRAME
1203         JRST    (PC)
1204
1205 IENABLE:
1206         SUBM    R,(P)
1207         PUSH    P,O1
1208         PUSHJ   P,RINTGO
1209         POP     P,RUNINT
1210         SUBM    R,(P)
1211         POPJ    P,
1212
1213 SUNWAT:
1214 IFN FLIP,[
1215         MOVEM   O1,@[MIMSEC,,UWATM]
1216         MOVEM   O1,@[MIMSEC+1,,UWATM]
1217 ]
1218 IFE FLIP        MOVEM   O1,UWATM
1219         JRST    (PC)
1220
1221 ARGS:   HLRE    A,FR.OFF+FR.ARG(O1)     ; COUNT OF ARGUMENTS
1222         JUMPL   A,IARG1                 ; FUNNY, CASE
1223         HRLI    A,$TTUPLE               ; SET TYPE WORD
1224         MOVEI   B,6(O1)                 ; POINT AT ARGUMENT BLOCK
1225         HLL     B,F
1226         JRST    (PC)
1227
1228 IARG1:  SUBM    O1,A                    ; POINT TO DW OF TUPLE
1229         HRRZ    B,FR.OFF-1(A)           ; GET LENGTH
1230         SUBM    A,B
1231         HRRZ    A,FR.OFF-1(A)
1232         LSH     A,-1
1233         HRLI    A,$TTUPLE
1234         ADDI    B,FR.OFF-1
1235         HLL     B,F
1236         JRST    (PC)
1237
1238 INCALL:
1239 IFN FTKCN,<     AOS     KCNTAB+%INCAL>          ;Count calls
1240         MOVE    B,PC
1241         JSP     PC,FRAME
1242         SUB     B,R
1243         HRLI    B,(SETZ (R))
1244         SKIPL   A,-1(F)                 ; GET PREVIOUS GLUED FRAME
1245          MOVE   A,F                     ; OR ELSE CURRENT FRAME
1246         XHLLI   A,(F)
1247         HRRM    SP,FR.SP(A)
1248         MOVEM   B,FR.PC(A)
1249         MOVE    0,FR.MSA(A)                     ; SO RETURN WINS
1250         XMOVEI  A,(F)
1251         SKIPL   (A)
1252          SUBI   A,FR.OFF
1253         MOVEM   A,-2(TP)
1254 IFN FLIP,[
1255         AOS     F,@[MIMSEC,,FRAMID]
1256         MOVEM   F,@[MIMSEC+1,,FRAMID]
1257 ]
1258 IFE FLIP        AOS     F,FRAMID
1259         HRRZM   F,-3(TP)
1260         XMOVEI  F,-1(TP)
1261         MOVEM   0,FR.MSA(F)                     ; SO RETURN WINS
1262         SETZM   (F)
1263         ADDI    B,1                             ; NOTE: DONT CHANGE TO AOJA!!!
1264         JRST    @B
1265
1266 ACALL:
1267 IFN FTKCN,<     AOS     KCNTAB+%ACALL>                  ;Count calls
1268         LDB     0,[222000,,A]
1269         CAIN    0,$TMSUBR
1270          JRST   [       MOVE    D,B             ; GET ATOM
1271                         SUB     PC,R
1272                         HRLI    PC,(SETZ (R))
1273                         MOVE    C,O2
1274                         JRST    ICRET ]
1275         MOVEI   O1,0
1276         SUB     PC,R
1277         HRLI    PC,(SETZ (R))
1278         JRST    CALNGS
1279
1280 CALNGS: SKIPN   NCATM                   ; CALL'ED ATOM IS NOT GASSIGNED
1281          PUSHJ  P,HALTX
1282         ADJSP   TP,2                    ; ROOM FOR EXTRA ARG
1283         XMOVEI  OP,(TP)
1284         SKIPN   E,O2                    ; # OF ARGS TO B
1285          JRST   CALNG5
1286         DMOVE   C,-3(OP)
1287         DMOVEM  C,-1(OP)
1288         SUBI    OP,2
1289         SOJG    E,.-3                   ; MAKE ROOM
1290
1291 CALNG5: JUMPE   O1,CALNG2               ; JUMP IF NOT A CALL TO AN ATOM
1292
1293 CALNG1: MOVE    B,[$TATOM,,$LATOM]
1294         MOVEM   B,-1(OP)
1295         MOVEM   O1,(OP)
1296 CALNG3: MOVE    O1,NCATM
1297         AOJA    O2,CALLR
1298
1299 CALNG2: DMOVEM  A,-1(OP)                ; MUNG IN WHATEVER IT IS
1300         JRST    CALNG3
1301
1302
1303 CALNMS: PUSHJ   P,HALTX                 ; VALUE OF CALL'ED ATOM ISN'T MSUBR
1304
1305 ACTIVA:
1306 IFN FTKCN,<     AOS     KCNTAB+%ACTIVA>         ;Count calls
1307         MOVEI   A,(PC)
1308         SUBI    A,(R)
1309         HRRM    A,FR.ACT(F)
1310         HRRZ    A,TP
1311         SUBI    A,(F)                   ; REL TP TO FRAME
1312         HRLM    A,FR.TP(F)
1313         JRST    (PC)
1314
1315 RETRY:  XMOVEI  F,FR.OFF(O1)
1316         HLRE    B,FR.ARG(F)             ; SEE IF TUPLE CASE
1317         JUMPGE  B,BLTDON
1318         SUBM    F,B                     ; B POINTS TO DW
1319         HRRZ    A,-1(B)                 ; A IS REAL # ARG
1320         LSH     A,-1
1321         HRLM    A,FR.ARG(F)             ; FIX UP # ARGS
1322         LSH     A,1                     ; TO # WORDS
1323         SUBI    B,1(A)                  ; B IS SOURCE (I.E. 1ST ARG WORD)
1324         XMOVEI  C,2(F)          ; FIRS DEST
1325         XBLT    A,
1326 BLTDON: PUSH    P,FR.ARG(F)             ; SAVE FOR NEW FRAME
1327         PUSH    P,FR.MSA(F)
1328         JSP     E,FRMFIX
1329         PUSH    P,PC
1330         JSP     PC,FRAME
1331         POP     P,PC
1332         POP     P,D
1333         POP     P,O2
1334         HLRZS   C,O2
1335         ADJSP   TP,(O2)
1336         ADJSP   TP,(O2)
1337         JRST    ICRET
1338
1339 AGAIN:
1340 IFN FTKCN,<     AOS     KCNTAB+%AGAIN>          ;Count
1341         ADDI    O1,FR.OFF
1342         SKIPGE  (F)                     ; CHECK FOR GLUEDNESS
1343          HRR    F,-1(F)                 ; GET THE REAL FRAME
1344         CAMN    F,O1
1345          JRST   IAGN1
1346         MOVE    F,O1
1347         HLRZ    O1,FR.TP(F)
1348         ADD     O1,F
1349         JSP     PC,IUNBIN
1350         MOVE    M,FR.MSA(F)
1351         MOVE    M,@1(M)                 ; GET ATOM OF IMSUBR
1352         MOVE    M,1(M)                  ; AND FINALLY IMSUBR
1353         HLRZ    A,(M)                   ; CHECK FOR FBIN TYPE KLUDGE
1354         MOVE    R,1(M)
1355         CAIN    A,$TPCODE
1356          JRST   [ SKIPN R,PV%OFF(R)     ; GET POINTER
1357                                         ; NOT THERE, MAP IT IN
1358                    PUSHJ P,MAPIN
1359                   JRST  .+1 ]
1360 IAGN1:  HRRZ    PC,FR.ACT(F)
1361         JUMPE   PC,CMPERR
1362         ADD     PC,R
1363         HLRZ    TP,FR.TP(F)
1364 IFE FLIP&0,[    ADD     TP,F
1365                 JRST    (PC) ]
1366 IFN FLIP&0,[
1367         TLNN    M,1                     ; ODD/EVEN CHECK
1368          JRST   EVNSE1
1369         HRLI    F,EVSEC
1370         HRLI    P,EVSEC
1371         ADD     TP,F
1372         JRST    (PC)
1373
1374 EVNSE1: HRLI    F,ODDSEC
1375         HRLI    P,ODDSEC
1376         ADD     TP,F
1377         JRST    (PC) ]
1378
1379 ; HERE TO HANDLE AN UNWINDER
1380
1381 DOUNWI: SKIPN   O2,1(SP)                        ; GET UNWIND FRAME
1382          JRST   UNJOIN
1383         SKIPN   M,FR.MSA+FR.OFF(O2)     ; RESTORE MSUBR PTR FROM FRAME
1384          JRST   CMPERR
1385         MOVE    M,1(M)                  ; POINT TO ATOM
1386         MOVE    M,(M)                   ; POINT TO GBIND
1387         MOVE    M,1(M)                  ; GET IMSBUR INTO M
1388         HLRZ    C,(M)                   ; CHECK FOR FBIN TYPE KLUDGE
1389         MOVE    R,1(M)
1390         CAIN    C,$TPCODE
1391          JRST   [ SKIPE R,PV%OFF(R)     ; GET POINTER
1392                    JRST .+1
1393                   PUSH  TP,A            ; NOT THERE, MAP IT IN
1394                   PUSH  TP,B
1395                   PUSH  P,O1
1396                   PUSH  P,O2
1397                   PUSHJ P,MAPIN
1398                   POP   P,O2
1399                   POP   P,O1
1400                   POP   TP,B
1401                   POP   TP,A
1402                   JRST  .+1 ]
1403         HRRZ    C,4(SP)                 ; GET PC OFFSET
1404         MOVEI   D,(SP)
1405         SUBI    D,(TP)
1406         ADJSP   TP,6(D)                 ; MUNG IT
1407         ADD     C,R
1408         PUSH    TP,A
1409         PUSH    TP,B
1410         PUSH    TP,$WFRAM
1411         PUSH    TP,F
1412         PUSH    TP,$WBIND
1413         PUSH    TP,O1
1414         PUSH    TP,$WFIX
1415         PUSH    TP,PC
1416         PUSH    TP,$WFIX
1417         PUSH    TP,E
1418         XMOVEI  F,FR.OFF(O2)
1419 IFE FLIP&0,[    JRST    (C)     ]
1420 IFN FLIP&0,[
1421         TLNN    M,1                     ; ODD/EVEN CHECK
1422          JRST   EVNSE2
1423         HRLI    TP,EVSEC
1424         HRLI    F,EVSEC
1425         HRLI    P,EVSEC
1426         JRST    (C)
1427
1428 EVNSE2: HRLI    TP,ODDSEC
1429         HRLI    F,ODDSEC
1430         HRLI    P,ODDSEC
1431         JRST    (C) ]
1432
1433 UNWCNT:
1434 IFN FTKCN,<     AOS     KCNTAB+%UNWCN>          ;Count calls
1435         MOVE    E,(TP)
1436         MOVE    PC,-2(TP)
1437         MOVE    O1,-4(TP)
1438         MOVE    F,-6(TP)
1439         ADJSP   TP,-10
1440         POP     TP,B
1441         POP     TP,A
1442         MOVE    D,2(SP)                 ; REALLY UNBIND IT IF SUCCESSFUL
1443         JRST    UNJOIN
1444
1445 ; HERE TO HANDLE FIXUP AFTER STACK LOSSAGE FROM RETURN
1446 RET2:   MOVEI   C,(TP)
1447         CAIL    C,<<TPWARN>_9.>         ; ARE WE BELOW
1448          JRST   [       SKIPL   C,(F)
1449                          JRST   RET3+1
1450                           JRST  RET3+2 ]; NO
1451         PUSH    P,A
1452         PUSH    P,B
1453         MOVSI   A,(SETZ)
1454         HRRI    A,TPWARN
1455         MOVSI   B,0
1456         SPACS
1457         HRRI    A,TPWARN+1000
1458         SPACS
1459         POP     P,B
1460         MOVSI   A,(SKIPL C,(F))
1461         MOVEM   A,RET3                  ; MUNG THAT INS!!!
1462         MOVEM   A,@[MIMSEC+1,,RET3]
1463         POP     P,A
1464         JRST    RET3
1465
1466 ; RTUPLE WILL NOT RUN IN MIM MODE
1467
1468 MRETUR: TDZA    D,D
1469
1470 RTUPLE: MOVEI   D,1
1471
1472 IFN FTKCN,[     SKIPN   D
1473                 AOSA    KCNTAB+%RTUPL
1474                 AOS     KCNTAB+%MRETU
1475 ]
1476         SKIPN   O2                      ; 0 ==> MRET FROM CURRENT FRAME
1477          XMOVEI O2,-FR.OFF(F)           ; UPDATE FRAME
1478 MRET2:  SKIPGE  C,FR.OFF(O2)            ; GLUED FRAME?
1479          JRST   GRTUPL
1480         JUMPN   D,MRET3                 ; JUMP IF RTUPLE
1481         HLRZ    C,FR.HDR+FR.OFF(O2)     ; SEE IF SEG FRAME
1482         CAIN    C,$TSFRAM+$FRMDOP
1483          JRST   MRET3
1484         MOVE    A,FR.FRA+FR.OFF(O2)     ; Previous frame
1485         SKIPGE  C,FR.OFF(A)             ; Glued?
1486          JRST   [HRR    A,-1(A)         ; Point to real frame
1487                  JRST   MRETFO]
1488         MOVE    C,FR.OFF+FR.PC(A)       ; Get return PC if not glued
1489 MRETFO: MOVE    M,FR.MSA+FR.OFF(A)      ; MSUBR
1490         MOVE    M,@1(M)
1491         MOVE    M,1(M)                  ; IMSUBR
1492         HLRZ    0,(M)
1493         MOVE    R,1(M)
1494         CAIE    0,$TPCODE               ; skip if fbin
1495          JRST   .+3
1496         SKIPN   R,PV%OFF(R)             ; skip if already mapped in
1497          PUSHJ  P,@[MIMSEC,,DMAPI1]     ; Map the guy in
1498         MOVE    B,@C                    ; THIS KLUDGE SEES IF WE CAN STEP TO
1499                                         ;  NEXT FRAME FOR THIS MRETURN
1500         CAMN    B,[JRST @<RETOFF+ENTVEC>]       ; IS IT A RETURN
1501          JRST   [ MOVE  O2,FR.OFF+FR.FRA(O2)    ; YES, MRETURN FROM IT
1502                   SKIPGE (O2)           ; skip if not glued frame
1503                    SUBI O2,FR.OFF       ; fix up pointer
1504                   JRST  MRET2 ]         ; try this all again
1505         MOVE    C,TP
1506         SUB     C,O1
1507         SUB     C,O1
1508         JSP     PC,FRAME
1509         PUSH    TP,[$TFRAME,,$LFRAME]
1510         PUSH    TP,O2
1511         MOVEI   O2,1(O1)
1512
1513         JUMPE   O1,MRET4
1514 MRET5:  PUSH    TP,1(C)
1515         PUSH    TP,2(C)
1516         ADDI    C,2
1517         SOJG    O1,MRET5
1518 MRET4:
1519         MOVE    O1,ECATM
1520         JSP     PC,CALLZ
1521         JRST    COMPER
1522
1523 MRET3:  XMOVEI  F,FR.OFF(O2)
1524         PUSH    P,O1                    ; SAVE NUMBER OF ITEMS
1525         PUSH    P,TP                    ; SAVE POINTER TO STACK
1526         PUSH    P,C
1527         PUSH    P,D
1528         JSP     E,FRMFIX                ; UNBIND, DO RETURN
1529         POP     P,E
1530         POP     P,D
1531         POP     P,A                     ; GET BACK STACK
1532         MOVE    C,(P)                   ; GET BACK TUPLE LENGTH
1533         LSH     C,1                     ; TWICE THAT FOR # OF WORDS
1534         SUB     A,C                     ; POINT TO FIRST ELEMENT
1535         XMOVEI  B,1(TP)                 ; SAVE POINTER TO TUPLE
1536         JUMPN   E,IRTPL2
1537         ADDI    PC,1
1538 IRTPL2: JUMPE   C,IRTPLE                ; AN EMPTY TUPLE
1539 IRTPLP: PUSH    TP,1(A)                 ; PUSH AN ELEMENT OF THE TUPLE
1540         PUSH    TP,2(A)
1541         ADDI    A,2                     ; MOVE THROUGH TUPLE
1542         SUBI    C,2                     ; DECREMENT COUNT
1543         JUMPN   C,IRTPLP                ; LOOP UNTIL DONE
1544 IRTPLE: JUMPE   E,IRTPL3
1545         POP     P,A                     ; RESTORE LENGTH
1546         HRLI    A,$TTUPLE
1547         JRST    @PC                     ; WIN AWAY
1548
1549 IRTPL3: POP     P,B
1550         MOVSI   A,$TFIX
1551         JRST    @PC
1552
1553
1554 GRTUPL: XMOVEI  E,FR.OFF-2(O2)          ; SAVE A COPY OF GLUED FRAME
1555                                         ; POP OF GLUED FRAME
1556         MOVE    F,FR.OFF+1(O2)          ; GET RESTORED
1557         MOVE    A,O1                    ; COPY # OF ELEMENTS
1558         LSH     O1,1                    ; TO NUMBER OF WORDS
1559         MOVE    O2,TP
1560         SUB     O2,O1                   ; POINT TO FIRST
1561         XMOVEI  B,1(E)
1562         MOVE    O1,A
1563         JUMPN   D,IGRTP3                ; JUMP IF RTUPLE NOT MRETURN
1564         TLZE    C,$QSFRB                ; SEG CALL
1565          AOJA   C,IGRTP3                ; YES, SKIP RETURN WITH STUFF ON STACK
1566         MOVE    B,@C                    ; THIS KLUDGE SEES IF WE CAN STEP TO
1567                                         ;  NEXT FRAME FOR THIS MRETURN
1568         CAMN    B,[JRST @<RETOFF+ENTVEC>]       ; IS IT A RETURN
1569          JRST   MRET2
1570         JUMPE   O1,COMPER               ; MUST HAVE AT LEAST ONE ARG
1571         DMOVE   A,1(O2)                 ; RET 1ST ELEMENT
1572         MOVE    TP,E
1573         JRST    @C
1574
1575 IGRTP3: JUMPE   O1,IGRTP1
1576 IGRTP2: PUSH    E,1(O2)
1577         PUSH    E,2(O2)
1578         ADDI    O2,2
1579         SOJG    O1,IGRTP2
1580
1581 IGRTP1: MOVE    TP,E
1582         JUMPE   D,IGRTP4                ; IF MRET, RET # OF ARGS
1583         HRLI    A,$TTUPLE
1584         JRST    @C
1585
1586 IGRTP4: MOVEI   B,(A)
1587         MOVSI   A,$TFIX
1588         JRST    @C
1589 \f
1590 SUBTTL CODE TO TRY TO MAP IN A FROB
1591
1592 IFN SBRFY,[
1593 SBFPMP: MOVE    R,1(M)          ;pointer to pcode
1594         SKIPE   R,PV%OFF(R)
1595          JRST   (PC)
1596
1597 SBFPM1: PUSH    TP,$TFIX
1598         PUSH    TP,5(B)
1599         PUSH    TP,$TFIX
1600         PUSH    TP,O2
1601         PUSHJ   P,MAPIN
1602         MOVE    O2,(TP)
1603         MOVE    0,-2(TP)
1604         SUBI    TP,4
1605         JRST    @0
1606 ]
1607 DMAPIN: PUSH    P,D             ; NOT THERE, MAP IT IN
1608         PUSH    P,O2
1609 IFE FLIP,       PUSH    P,NARGS
1610 IFN FLIP,[
1611         PUSH    P,@[MIMSEC,,NARGS]
1612         PUSH    P,@[MIMSEC+1,,NARGS]
1613 ]
1614         PUSHJ   P,MAPIN
1615 IFE FLIP,       POP     P,NARGS
1616 IFN FLIP,[
1617         POP     P,@[MIMSEC+1,,NARGS]
1618         POP     P,@[MIMSEC,,NARGS]
1619 ]
1620         POP     P,O2
1621         POP     P,D
1622         POPJ    P,
1623
1624 DMAPI1: PUSH    P,PC            ; NOT THERE, MAP IT IN
1625         PUSH    P,E
1626         PUSH    TP,A            ; SAVE RET VAL
1627         PUSH    TP,B
1628         PUSHJ   P,MAPIN
1629         DMOVE   A,-1(TP)
1630         ADJSP   TP,-2
1631         POP     P,E
1632         POP     P,PC
1633         POPJ    P,
1634
1635 MAPIN:  SKIPN   O1,MPATM                ; HAVE WE BEEN SUPPLIED WITH ATOM?
1636          JRST   COMPERR
1637         JSP     PC,FRAME                        ; CREATE A FRAME
1638         PUSH    TP,(M)                  ; CALL WITH THE PURVE PNTR OF INTEREST
1639         PUSH    TP,1(M)
1640         MOVEI   O2,1                    ; ONE ARG
1641         JSP     PC,CALLZ                        ; GO FOR IT
1642         MOVE    R,1(M)                  ; SET UP R NOW
1643         SKIPN   R,PV%OFF(R)             ; FROM THE VECTOR
1644          JRST   COMPER                  ; OOPS?
1645         POPJ    P,
1646 \f
1647
1648 CIGAS:
1649         MOVSI   A,$TFIX
1650         SKIPE   B,@(TP)
1651          SKIPN  B,(B)
1652           MOVSI A,$TFALSE
1653         JRST    FOOADJ
1654
1655 CIGVL:  SKIPN   B,@(TP)
1656          JRST   COMPER
1657         DMOVE   A,(B)
1658 FOOADJ: ADJSP   TP,-8.
1659         POPJ    P,
1660
1661 \f
1662 SUBTTL  UTILITY
1663
1664 HALTX:  PUSH    P,A
1665         HRROI   A,[ASCIZ /MIMI20 Not Running
1666 /]
1667         PSOUT
1668         POP     P,A
1669         HALTF
1670         JRST    .-1
1671
1672 ; GET THE NEXT ELEMENT ON THE STACK.  POINTER INTO THE STACK
1673 ; IS THE ARGUMENT (LOCAL).  RETURNS AN OBJECT, OR A #UNBOUND -1
1674 ; IF THERE IS NOTHING ELSE ON THE STACK
1675
1676 NEXTS:  SKIPN   O1
1677          JRST   [MOVE B,CZONE
1678                  MOVE B,GCPOFF(B)
1679                  IRP %A,,[RCLOFF,RCLVOF,RCLV2O,RCLV3O,RCLV4O,RCLV7O,RCLV8O
1680                           RCL10O]
1681                  SETZM  %A(B)           ; THIS IS THE START OF A GC
1682                  TERMIN                 ; SO RELEASE EVERYTHING
1683                  MOVEI  O1,STRTTP
1684                  HLL    O1,TP
1685 ;                SETOM  INGC            ; DONT PERMIT INTERRUPTS
1686                  JRST   INEXT4]
1687 INEXT2: HLRE    B,(O1)
1688         TRNE    B,$FRMDOPE              ; IS THIS A RECORD DOPE WORD?
1689          JRST   [CAIN   B,$TTUPLE+$FRMDOPE
1690                   JRST  INEXT3
1691                  LDB    A,[000300,,B]   ; GET SAT
1692                  CAIE   A,$PRECORD      ; RECORD?
1693                   JRST  INEXT6          ; NO, SKIP IT (STACK STRUCTURE)
1694                  LDB    B,[RTYBYT,,B]   ; YES. GET RECORD TYPE
1695                  ASH    B,1
1696                  MOVE   B,@RECTBL+1(B)  ; GET LENGTH FROM TABLE
1697                  LSH    B,-1            ; DIVIDE BY TWO FOR 36-BIT WORDS
1698                  ADDI   O1,1(B)         ; ADD ONE FOR HEADER WORD
1699                  JRST   INEXT5]         ; REENTER CODE
1700 INEXT3: ADDI    O1,2                    ; POINT TO NEXT ELEMENT
1701 INEXT5: XMOVEI  B,(TP)                  ; ARE WE DONE YET?
1702         CAML    O1,B
1703          JRST   [MOVEI B,0              ; YUP
1704                  JRST INEXT1 ]
1705 INEXT4: HLRE    B,(O1)
1706          JUMPL  B,[ADDI O1,3            ; SKIP PSEUDO-FRAME
1707                    JRST INEXT5]         ; TRY THAT
1708
1709         TRNE    B,$FRMDOPE
1710          JRST   [       LDB     A,[000300,,B]
1711                         CAIE    A,$PRECORD
1712                          CAIN   A,$PVECTOR
1713                           JRST  INEXT7
1714                         JRST    INEXT6 ]
1715
1716 INEXT7: SKIPN   1(O1)                   ; DONT RETURN 0 POINTER
1717          JRST   [ CAIE  B,$TBIND+$FRMDOPE
1718                    JRST INEXT2
1719                     JRST .+1 ]
1720         MOVE    B,O1
1721 INEXT1: MOVE    A,$WFIX
1722         JRST    (PC)
1723 INEXT6: HRRZ    B,(O1)
1724         ADDI    O1,2(B)
1725         JRST    INEXT5                  ; SKIP STRUCTURE, TRY AGAIN
1726
1727 CONTEN: DMOVE   A,(O1)                  ; GET THE PAIR FROM THE STACK
1728         TLZE    A,$FRMDOPE              ; IS THE TYPE-WORD A DOPE WORD?
1729          XMOVEI B,1(O1)                 ; POINT PAST THE DOPE WORD
1730         JRST    (PC)                    ; RETURN RECORD POINTER
1731
1732 \f
1733 SUBTTL  TYPE MANIPULATION
1734
1735 NEWTYP: LDB     B,[300,,O1]             ; GET PRIMTYPE BITS
1736         MOVE    A,$WTCNT                ; GET TYPE COUNT
1737         AOS     $WTCNT
1738         CAIL    A,1024.                 ; MAX NUMBER
1739          PUSHJ  P,COMPER                ; DIE
1740         DPB     A,[61300,,B]            ; STUFF NEW TYPE CODE
1741         MOVE    A,$WFIX                 ; AND RETURN IT
1742         JRST    (PC)
1743
1744 ; TYPEW - build a type word O1/ type-code O2/ type-code of prim
1745
1746 TYPEW:  LDB     B,[600,,O2]
1747         MOVSI   A,$TTYPW
1748         CAIE    B,$PRECORD
1749          JRST   [       HRLZ B,O1
1750                         JRST (PC) ]
1751         LDB     O2,[061200,,O2]
1752         ASH     O2,1
1753         MOVE    O2,RECTBL+1(O2)         ; GET POINTER TO RECORD TABLE
1754         HRRZ    B,(O2)                  ; GET LENGTH FROM TABLE
1755         HRL     B,O1
1756         JRST    (PC)
1757
1758 ; Add user template information to internal record table"
1759
1760 TMPTBL: LSH     O1,1
1761         DMOVEM  A,RECTBL(O1)
1762         JRST    (PC)
1763
1764 XRECOR: SUBM    R,(P)                   ; RELATIVIZE PC IN CASE OF GC
1765         MOVEI   A,2(O2)
1766         PUSH    P,E
1767         PUSH    P,O1
1768         PUSH    P,O2
1769         JSP     PC,IBLOCK
1770         POP     P,C
1771         MOVE    D,C                     ; CHANGED BY MARC (BAD DOPE WORD)
1772         ADD     C,A                     ; POINT TO DW
1773         POP     P,O1
1774         HRL     D,O1
1775         TLO     D,$DOPEBIT
1776         TLNN    0,$GC%DW                ; SKIP IF NO DW
1777          MOVEM  D,(C)
1778         MOVE    B,A
1779         POP     P,A
1780         HRL     A,O1
1781         ANDI    O1,$PBITS
1782         CAIN    O1,$PSTRING
1783          ADD    B,[657777,,-1]          ; MAKE GLOBAL BP
1784         CAIN    O1,$PBYTES
1785          ADD    B,[577777,,-1]
1786 RPOPJ:  SUBM    R,(P)
1787         POPJ    P,
1788 \f
1789 SUBTTL STRUCTURE CREATION
1790
1791 LIST:   SUBM    R,(P)
1792         SETZ    B,                      ; INITIALIZE CDR
1793 LISTL:  SOJL    O1,LISTE                ; LOOP UNTIL DONE
1794         PUSH    TP,$WLIST
1795         PUSH    TP,B
1796         PUSH    P,O1
1797         PUSHJ   P,ICELL                 ; GET A CELL IN 'A'
1798         POP     TP,(A)
1799         ADJSP   TP,-1
1800         POP     TP,2(A)                 ; POP VALUE
1801         POP     TP,1(A)                 ; AND TYPE/LENGTH INTO CELL
1802         POP     P,O1
1803         MOVE    B,A                     ; UPDATE CDR POINTER
1804         JRST    LISTL                   ; AND LOOP
1805
1806 LISTE:  MOVE    A,$WLIST                ; TYPE-WORD LIST
1807         SUBM    R,(P)
1808         POPJ    P,
1809
1810 UBLOCK: TLNE    O2,-1
1811          JRST   COMPER                  ; either negative of too big
1812         SUBM    R,(P)
1813         HRLZS   O1
1814         PUSHJ   P,UBLOKR
1815         SUBM    R,(P)
1816         POPJ    P,
1817
1818 UBLOKR: MOVE    A,O1
1819         HRR     O1,O2                   ; MAKE TYPE WORD (WRONG FOR STRING, BYTES)
1820         MOVE    D,O2
1821         LSH     D,1
1822         PUSH    P,D
1823         SUBM    TP,D                    ; POINT D AT FIRST ELEMENT
1824         LDB     A,[220200,,A]
1825         JRST    @UBLTBL(A)
1826
1827 UBLTBL: SETZ    UBLB
1828         SETZ    UBLS
1829         SETZ    UBLU
1830         SETZ    UBLV
1831
1832 UBLB:   MOVEI   A,4
1833         MOVSI   B,441000
1834         HRLOI   C,577777
1835         PUSHJ   P,DOSTR
1836         PUSH    P,A                     ; PUT # WORDS WHERE EXPECTED
1837         JRST    UBLR1
1838
1839 UBLS:   MOVEI   A,5
1840         MOVSI   B,440700
1841         HRLOI   C,657777
1842         PUSHJ   P,DOSTR
1843         PUSH    P,A
1844         JRST    UBLR1
1845
1846 ; COUNT IS IN O2; POINTER IN D.  RETURN COUNT IN A; CAN CLOBBER D.
1847 STRCNT: MOVEI   A,0
1848         PUSH    P,B
1849         PUSH    P,C
1850         MOVE    B,O2
1851         JUMPE   B,STRCDN
1852 STRCLP: LDB     C,[220304,,1]
1853         JUMPN   C,STRCST                ; A CHARACTER
1854         AOJA    A,STRELP
1855 STRCST: HRRZ    C,1(D)
1856         ADD     A,C                     ; LENGTH OF STRING/BYTES
1857 STRELP: ADDI    D,2
1858         SOJG    B,STRCLP
1859 STRCDN: POP     P,C
1860         POP     P,B
1861         POPJ    P,
1862
1863 ; BYTE POINTER IN B, ARG POINTER IN D, ARG COUNT IN O2, A IS SACRED
1864 ; (BYTE POINTER IS (A)).
1865 STRMOV: LDB     C,[220304,,1]           ; SAT OF THING IN 1(D)
1866         JUMPN   C,STRMVB
1867         MOVE    C,2(D)
1868         IDPB    C,B                     ; STUFF OUT A BYTE
1869 STRMEL: ADDI    D,2
1870         SOJG    O2,STRMOV
1871         POPJ    P,
1872 STRMVB: HRRZ    E,1(D)
1873         JUMPE   E,STRMEL
1874         MOVE    0,2(D)
1875 STRMVL: ILDB    C,0
1876         IDPB    C,B
1877         SOJG    E,STRMVL
1878         JRST    STRMEL
1879
1880 DOSTR:  ADJSP   P,3                     ; SPACE FOR EXTRA STUFF
1881         PUSH    P,A                     ; BYTES/WORD
1882         PUSH    P,B                     ; FROB TO MAKE LOCAL BYTE POINTER
1883         PUSH    P,C                     ; FROB TO MAKE GLOBAL BP WHEN DONE
1884         PUSH    P,D
1885         PUSHJ   P,STRCNT
1886         HRR     O1,A                    ; FIX UP SAVED TYPE WORD
1887         ADD     A,-3(P)
1888         SUBI    A,1                     ; ROUND UP TO NEXT FULL WORD
1889         IDIV    A,-3(P)
1890         MOVEM   A,-6(P)                 ; # OF WORDS FOR FROB
1891         ADDI    A,2
1892         PUSH    P,O1
1893         PUSH    P,O2
1894         JSP     PC,IBLOCK               ; GET STORAGE
1895         POP     P,O2
1896         POP     P,O1
1897         POP     P,D
1898         MOVEM   A,-4(P)
1899         MOVEM   0,-3(P)                 ; SAVE ADDRESS AND FLAGS
1900         MOVE    B,-1(P)                 ; ARGUMENT FROM B
1901         TLO     B,1                     ; MAKE BP (A)
1902         JUMPE   O2,STRMDN               ; OBVIOUSLY EMPTY?
1903         PUSH    P,D
1904         PUSHJ   P,STRMOV
1905         POP     P,D
1906 STRMDN: MOVE    0,-3(P)                 ; FLAGS
1907         MOVE    B,-4(P)                 ; ADDRESS
1908         MOVE    C,-5(P)                 ; # WORDS
1909         ADD     C,B                     ; POINT TO DOPE WORDS
1910         ADD     B,(P)                   ; GLOBAL BP
1911         ADJSP   P,-5                    ; FLUSH ALL BUT # OF WORDS
1912         POP     P,A                     ; VALUES IN A,B,C
1913         POPJ    P,
1914
1915 UBLR:   POP     P,B                     ; TP BECOMES PLACE OF FIRST ARG.
1916         MOVE    C,(P)                   ; # OF WORDS IN THE UBLOCK
1917         ADD     C,B
1918 UBLR1:  POP     P,D                     ; # OF WORDS
1919         TLNN    0,$GC%DW                ; MAYBE STUFF INTO DOPE WORDS
1920          HRRM   D,(C)
1921         MOVE    D,O1                    ; OTHER HALF OF DOPE WORD
1922         TLO     D,$DOPEBIT
1923         TLNN    0,$GC%DW
1924          JRST   [HLLM   D,(C)
1925                  SETZM  1(C)
1926                  JRST .+1]
1927         POP     P,D
1928         MOVNS   D
1929         ADJSP   TP,(D)
1930         MOVE    A,O1
1931         POPJ    P,
1932
1933 UBLU:   MOVE    A,O2                    ; GET # ARGUMENTS
1934         PUSH    P,A
1935         ADDI    A,2                     ; ADD DOPE WORDS
1936         PUSH    P,O1
1937         PUSH    P,D
1938         PUSH    P,O2
1939         JSP     PC,IBLOCK               ; GET CORE
1940         POP     P,O2
1941         POP     P,D
1942         POP     P,O1
1943         PUSH    P,A                     ; SAVE LOCATION
1944         JUMPE   O2,UBLR
1945 UBLUL:  MOVE    B,2(D)
1946         MOVEM   B,(A)
1947         ADDI    D,2
1948         ADDI    A,1
1949         SOJN    O2,UBLUL                ; AND LOOP
1950         JRST    UBLR
1951
1952 UBLV:   MOVE    A,O2                    ; GET # ARGUMENTS
1953         LSH     A,1                     ; 2 36-BIT WORDS FOR EACH
1954         PUSH    P,A
1955         ADDI    A,2                     ; ADD DOPE WORDS
1956         PUSH    P,O1
1957         PUSH    P,D
1958         PUSH    P,O2
1959         JSP     PC,IBLOCK               ; GET CORE
1960         POP     P,O2
1961         POP     P,D
1962         POP     P,O1
1963         PUSH    P,A                     ; SAVE LOCATION
1964         JUMPE   O2,UBLR                 ; CHOMPING EMPTY VECTOR
1965 UBLVL:  MOVE    B,1(D)
1966         MOVEM   B,(A)
1967         MOVE    B,2(D)
1968         MOVEM   B,1(A)                  ; STUFF
1969         ADDI    D,2
1970         ADDI    A,2
1971         SOJN    O2,UBLVL                ; AND LOOP
1972         JRST    UBLR
1973
1974 ; RETURN UNINITIALIZED STORAGE.  ARGS JUST LIKE UBLOCK (O1 TYPE, O2 # ELEMENTS),
1975 ; BUT NOTHING ON STACK.
1976 UUBLOCK:
1977         TLNE    O2,-1
1978          JRST   COMPER                  ; either negative or too big!
1979         HRLZS   O1
1980         SUBM    R,(P)                   ; IN CASE OF GC
1981         LDB     A,[220200,,O1]          ; GET TYPE
1982         JRST    @UUBLTB(A)              ; TYPE DISPATCH
1983 UUBLTB: SETZ    UUBLB
1984         SETZ    UUBLS
1985         SETZ    UUBLU
1986         SETZ    UUBLV
1987
1988 UUBLB:  MOVEI   A,4
1989          JRST   UUBLS1                  ; LIKE STRING, WITH 4 BYTES/WORD
1990 UUBLS:  MOVEI   A,5
1991 UUBLS1: MOVE    B,O2                    ; # OF ELEMENTS
1992         ADDI    B,-1(A)                 ; ROUND UP
1993         IDIV    B,A                     ; # OF WORDS NEEDED
1994         PUSHJ   P,UIB                   ; BUILD THE STORAGE
1995         HRLOI   C,657777
1996         CAME    O1,[$TSTRING,,0]
1997          HRLOI  C,577777
1998         ADD     B,C                     ; MAKE A BYTE POINTER
1999 UUBLR:  SUBM    R,(P)
2000         POPJ    P,
2001 UUBLU:  MOVE    B,O2
2002         PUSHJ   P,UIB
2003         JRST    UUBLR
2004 UUBLV:  MOVE    B,O2
2005         LSH     B,1
2006         PUSHJ   P,UIB
2007         PUSHJ   P,CLRVEC                ; THIS HAS TO BE ZEROED
2008         JRST    UUBLR
2009 ; TYPE IN O1, LENGTH IN O2, # WORDS (EXCLUSIVE OF DW) IN B.  RETURN
2010 ; POINTER IN A, B (SOMEBODY ELSE MAKES BYTE POINTER FOR STRINGS, BYTES
2011 UIB:    CAILE   B,777000-2              ;length better be less than a section
2012          JRST   COMPER
2013         PUSH    P,B
2014         PUSH    P,O1
2015         PUSH    P,O2
2016         MOVEI   A,2(B)                  ; # WORDS, WITH DW
2017         JSP     PC,IBLOCK               ; GET THE STORAGE
2018         POP     P,O2
2019         POP     P,O1
2020         TLNN    0,$GC%DW
2021          JRST   [MOVE   B,A
2022                  ADD    B,(P)           ; POINT AT DOPE WORDS
2023                  MOVE   D,O1
2024                  TLO    D,$DOPEBIT
2025                  HLLM   D,(B)
2026                  MOVE   D,(P)
2027                  HRRM   D,(B)
2028                  JRST   .+1]
2029         ADJSP   P,-1
2030         MOVE    B,A
2031         MOVE    A,O1
2032         HRR     A,O2
2033         POPJ    P,
2034
2035 ; BUILD STACK STRUCTURES.  O1 IS TYPE WORD, O2 IS # ELTS.
2036 SBLOCK: TLNE    O2,-1                   ; skip if not negative or too big
2037          PUSHJ  P,COMPER
2038         HRLZS   O1
2039         MOVE    D,O2
2040         LSH     D,1
2041         SUBM    TP,D                    ; POINT AT FIRST ARGUMENT (-1)
2042         LDB     A,[220200,,O1]          ; GET LOW BITS OF SAT
2043         JRST    @SBTBL(A)
2044 SBTBL:  SETZ    SBBYT
2045         SETZ    SBSTR
2046         SETZ    SBUVC
2047         SETZ    SBVEC
2048
2049 SBVEC:  EXCH    O1,O2                   ; THIS IS ALMOST LIKE TUPLE
2050         JSP     PC,TUPLE
2051         HLL     A,O2
2052         POPJ    P,
2053 SBUVC:  HRR     O1,O2
2054         MOVE    A,O1                    ; TYPE WORD
2055         TLO     O1,$FRMDOPE             ; DOPE WORD
2056         MOVEM   O1,1(D)                 ; STUFF OUT FIRST DOPE WORD
2057         XMOVEI  C,2(D)
2058         MOVE    B,C                     ; SAVE POINTER
2059         JUMPE   O2,SBUVCD
2060 SBUVCL: MOVE    E,2(D)                  ; PICK UP A FROB
2061         MOVEM   E,(C)                   ; STUFF IT OUT
2062         ADDI    D,2                     ; UPDATE POINTER TO SOURCE
2063         ADDI    C,1                     ; AND TO DEST
2064         SOJG    O2,SBUVCL               ; JUMP IF NOT DONE
2065 SBUVCD: MOVEM   O1,(C)                  ; OTHER DOPE WORD
2066         MOVE    TP,C                    ; UPDATE STACK
2067         POPJ    P,                      ; DONE
2068
2069 ; STACK BYTES AND STRINGS.  D STILL HAS POINTER TO FIRST ARGUMENT
2070 SBBYT:  MOVEI   A,4
2071         MOVSI   B,441000
2072         HRLOI   C,577777
2073         PUSHJ   P,STKSTR
2074         POPJ    P,
2075
2076 SBSTR:  MOVEI   A,5
2077         MOVSI   B,440700
2078         HRLOI   C,657777
2079         PUSHJ   P,STKSTR
2080         POPJ    P,
2081
2082 STKSTR: PUSH    P,O1
2083         PUSH    P,O2
2084         PUSH    P,A
2085         PUSH    P,B
2086         PUSH    P,C
2087         PUSH    P,D
2088         PUSHJ   P,STRCNT                ; GET LENGTH OF NEW STRING INTO A
2089         PUSH    P,A                     ; SAVE IT
2090         ADD     A,-4(P)
2091         SUBI    A,1
2092         IDIV    A,-4(P)                 ; # WORDS FOR STRING
2093         HRR     O1,A                    ; SAVE FOR DOPE WORDS
2094         ADDI    A,2                     ; PLUS DOPE
2095         TLO     O1,$FRMDOPE             ; MAKE IT A DOPE WORD
2096         MOVE    B,O2
2097         LSH     B,1                     ; WORDS OF ARGUMENT
2098         MOVE    C,-1(P)                 ; BEGINNING OF BLOCK, ALMOST
2099         ADDI    C,1                     ; REAL BEGINNING OF BLOCK
2100         PUSH    P,C                     ; WHICH WILL BE LOC OF 1ST DOPE WORD
2101         MOVE    D,C
2102         CAML    A,B                     ; ENSURE NO BACKWARDS BLT PROBLEMS
2103          JRST   [ADD    D,A
2104                  JRST   SSBCNT]
2105         ADD     D,B
2106 SSBCNT: MOVEM   D,-2(P)                 ; SAVE IT
2107         XBLT    B,                      ; BLT THE ARGS DOWN THE STACK
2108         POP     P,A                     ; GET POINTER TO STACK AREA WE'RE USING
2109         MOVEM   O1,(A)                  ; DUMP OUT FIRST DW
2110         ADDI    A,1
2111         PUSH    P,A                     ; SAVE ADDRESS OF RESULT
2112         MOVE    B,-4(P)                 ; LOCAL BYTE POINTER
2113         TLO     B,1                     ; MAKE IT BE (A)
2114         MOVE    O2,-6(P)
2115         JUMPE   O2,SSBNOM
2116         MOVE    D,-2(P)
2117         SUBI    D,1                     ; SHOULD POINT BEFORE ARG BLOCK
2118         PUSHJ   P,STRMOV                ; COPY THE STUFF IN
2119 SSBNOM: MOVE    B,(P)                   ; RESULT POINTER
2120         HRRI    C,(O1)
2121         ADDI    B,(C)                   ; POINT TO LAST DOPE WORD
2122         MOVEM   O1,(B)                  ; STUFF OUT DOPE WORD
2123         MOVE    TP,B
2124         POP     P,B                     ; POINTER
2125         POP     P,A
2126         HLL     A,O1
2127         TLZ     A,$FRMDOPE
2128         ADD     B,-1(P)
2129         ADJSP   P,-6
2130         POPJ    P,
2131
2132 ; RETURN UNINITIALIZED STORAGE ON STACK.  O1 IS TYPE WORD, O2 IS # ELTS.
2133 ; SAVE ACS EXCEPT A AND B.
2134 USBLOCK:
2135         TLNE    O2,-1
2136          JRST   COMPER                  ; either negative or too big
2137         HRLZS   O1
2138         PUSH    P,C
2139         LDB     A,[220200,,O1]
2140         JRST    @USTBL(A)
2141 USTBL:  SETZ    USBYT
2142         SETZ    USSTR
2143         SETZ    USUVC
2144         SETZ    USVEC
2145 USBYT:  MOVEI   A,3(O2)
2146         IDIVI   A,4                     ; # WORDS, EXCLUDING DOPE WORDS
2147         MOVE    C,O1
2148         TLO     C,$FRMDOPE
2149         HRRI    C,(A)
2150         PUSH    TP,C
2151         XMOVEI  B,1(TP)
2152         ADJSP   TP,(A)
2153         PUSH    TP,C
2154         ADD     B,[577777,,-1]
2155 USRET:  MOVE    A,O1
2156         HRR     A,O2
2157         POP     P,C
2158         POPJ    P,
2159 USSTR:  MOVEI   A,4(O2)
2160         IDIVI   A,5
2161         MOVE    C,O1
2162         TLO     C,$FRMDOPE
2163         HRRI    C,(A)
2164         PUSH    TP,C
2165         XMOVEI  B,1(TP)
2166         ADJSP   TP,(A)
2167         PUSH    TP,C
2168         ADD     B,[657777,,-1]
2169         JRST    USRET
2170
2171 USUVC:  MOVE    C,O1                    ; MAKE A DOPE WORD
2172         TLO     C,$FRMDOPE
2173         HRRI    C,(O2)                  ; # ELTS + 2 FOR DOPE WORD
2174         PUSH    TP,C                    ; PUSH HEADER DOPE WORD
2175         XMOVEI  B,1(TP)                 ; SAVE POINTER
2176         ADJSP   TP,(O2)                 ; CREATE SPACE
2177         PUSH    TP,C                    ; PUSH TRAILER DOPE WORD
2178         JRST    USRET                   ; RETURN
2179
2180 USVEC:  MOVE    A,O2
2181         LSH     A,1
2182         MOVE    C,O1
2183         TLO     C,$FRMDOPE
2184         HRRI    C,(A)
2185         XMOVEI  B,1(TP)
2186         ADJSP   TP,(A)
2187         PUSH    TP,C
2188         PUSH    TP,[0]
2189         MOVE    A,O1
2190         HRR     A,O2
2191         PUSHJ   P,CLRVEC
2192         POP     P,C
2193         POPJ    P,
2194
2195 ; ZERO A VECTOR
2196 CLRVEC: TRNN    A,-1
2197          POPJ   P,                      ; EMPTY
2198         PUSH    P,C                     ; SAVE ACS
2199         PUSH    P,D
2200         PUSH    P,E
2201         HRRZ    C,A                     ; GET LENGTH IN WORDS
2202         LSH     C,1
2203         SUBI    C,1                     ; LESS FIRST WORD
2204         SETZM   (B)                     ; CLEAR FIRST WORD
2205         MOVE    D,B                     ; SOURCE BLOCK
2206         XMOVEI  E,1(B)                  ; DEST BLOCK
2207         XBLT    C,                      ; DO IT
2208         POP     P,E
2209         POP     P,D
2210         POP     P,C
2211         POPJ    P,
2212
2213 RECORD: SUBM    R,(P)
2214         HRLZS   O1
2215         PUSHJ   P,RECORR
2216         SUBM    R,(P)
2217         POPJ    P,
2218
2219 RECORR: LDB     A,[301200,,O1]
2220         ASH     A,1
2221         MOVE    A,RECTBL+1(A)           ; GET POINTER TO RECORD TABLE
2222         ADDI    A,1                     ; POINT TO FIRST ENTRY
2223         PUSH    P,O1                    ; SAVE TYPE WORD FOR RETURN
2224         PUSH    P,A                     ; SAVE POINTER TO TABLE
2225
2226 ;       HLRZ    C,-1(A)
2227 ;       HRRM    C,-1(P)
2228 ;       HRRZ    A,-1(A)                 ; GET # 1/2 WORDS NEEDED FOR RECORD
2229
2230 ; THE SEMI'ED LINES ABOVE ARE CHANGED TO THE TWO FOLLOWING
2231 ; SHOULD CHANGE THE LENGTH FIELD OF RECORDS TO BE 'RIGHT'
2232 ; I.E. THE NUMBER OF 1/2 WORDS IN THE RECORD
2233
2234         HRRZ    A,-1(A)
2235         HRRM    A,-1(P)
2236
2237         ASH     A,-1
2238         PUSH    P,A                     ; SAVE THIS FOR A MOMENT
2239         ADDI    A,2                     ; ADD FOR DOPE WORDS
2240         PUSH    P,O1
2241         PUSH    P,O2
2242         JSP     PC,IBLOCK               ; HERE THEY ARE
2243         POP     P,O2
2244         POP     P,O1
2245         MOVE    C,A                     ; HOLD ON TO RECORD POINTER
2246         ADD     A,(P)                   ; POINT TO THE DOPE WORD
2247         POP     P,B                     ; HERE'S THE # WORDS AGAIN
2248         TLNN    0,$GC%DW
2249          JRST   [TLO    O1,$DOPEBIT             ; SET THE DOPEWORD BIT
2250                  HLLM   O1,(A)                  ; PUT TYPE WORD IN DOPES
2251                  HRRM   B,(A)                   ; STORE IT IN DOPE WORD
2252                  SETZM  1(A)
2253                  JRST   .+1]
2254         POP     P,A                     ; RESTORE TABLE POINTER
2255         PUSH    P,C                     ; SAVE POINTER TO RECORD FOR RETURN
2256         MOVE    D,C
2257         MOVSI   C,222200+D              ; MAKE BP TO RECORD
2258         MOVE    E,O2                    ; GET COUNT OF ELEMENTS
2259         LSH     E,1                     ; 2 WORDS PER ELEMENT
2260         PUSH    P,E
2261         SUBM    TP,E                    ; E POINTS TO FIRST ARG
2262         ADDI    E,1
2263 RECORL: HLRZ    C,1(A)                  ; BYTE OFFSET
2264         ADJBP   C,[222200+D,,0]
2265         HRRZ    B,1(A)                  ; SIZE OF THIS ELEMENT IN RECORD
2266         PUSHJ   P,@PUTRTB-1(B)          ; DO A 'PUTR'
2267         ADDI    A,2                     ; ADVANCE POINTER IN TABLE
2268         ADDI    E,2                     ; ADVANCE POINTER TO ELEMENT
2269         SOJN    O2,RECORL               ; LOOP UNTIL DONE
2270         POP     P,D
2271         MOVNS   D
2272         ADJSP   TP,(D)                  ; RESTORE TP
2273         POP     P,B                     ; RESTORE VALUE WORD (POINTER)
2274         POP     P,A                     ; RESTORE TYPE/LENGTH WORD
2275         POPJ    P,
2276
2277 \f
2278 SUBTTL STRUCTURE MANIPULATION
2279
2280 NTHU:   LDB     A,[UPTBYT,,A]   ; TYPE IN A, PTR IN O1, NUM IN O2
2281         JRST    @NTHUTB(A)
2282
2283 NTHUTB: SETZ    NTHUS
2284         SETZ    NTHUS
2285         SETZ    NTHUU
2286         SETZ    NTHUV
2287
2288 NTHUB:  ADJBP   O2,O1
2289         LDB     B,O2
2290         MOVE    A,$WFIX
2291         POPJ    P,
2292
2293 NTHUS:  ADJBP   O2,O1
2294         LDB     B,O2
2295         MOVE    A,$WCHARACTER
2296         POPJ    P,
2297
2298 NTHUU:  SUBI    O2,1
2299         ADD     O2,O1
2300         MOVE    A,$WFIX
2301         MOVE    B,(O2)
2302         POPJ    P,
2303
2304 NTHUV:  SUBI    O2,1
2305         LSH     O2,1
2306         ADD     O2,O1
2307         DMOVE   A,(O2)
2308         POPJ    P,
2309
2310 ;; NTHR CODE
2311
2312 NTHR:
2313 NTHRR:  ASH     A,1
2314         SKIPN   A,RECTBL+1(A)           ; AND POINTER TO TABLE
2315          PUSHJ  P,HALTX
2316         LSH     O2,1                    ; 4 16-BIT WORDS / ENTRY
2317         ADDI    A,-1(O2)                ; POINT TO CORRECT ENTRY
2318         HRRZ    B,1(A)                  ; GET SIZE OF ITEM TO EXTRACT
2319         HLRZ    C,1(A)                  ; WORD OFFSET TO START FROM
2320         MOVE    O2,O1                   ; COPY IN CASE MULTI SECT
2321 ;       HRLI    O1,222240               ; MAKE WORK IN MULTI SECT
2322         MOVSI   O1,222200+O2
2323         ADJBP   C,O1                    ; MAKE BYTE POINTER TO ITEM
2324                                         ;  IN MULTI SECT, C & D ARE BPTR
2325         JRST    @NTHRTB-1(B)            ; DISPATCH
2326
2327 NTHRTB: SETZ    NTHRBB                  ; BOOLEAN
2328         SETZ    NTHRE                   ; ERROR - SHOULDN'T HAPPEN
2329         SETZ    NTHRBB                  ; ENUMERATION
2330         SETZ    NTHRBB                  ; SUB-RANGE
2331         SETZ    NTHRBB                  ; SUB-RANGE (SBOOL)
2332         SETZ    NTHRLF                  ; LIST OR FIX
2333         SETZ    NTHRLF                  ; LIST OR FIX (SBOOL)
2334         SETZ    NTHRS3                  ; STRUC IN 3 HALF WORDS
2335         SETZ    NTHRS3                  ; SAME WITH SBOOL
2336         SETZ    NTHRS2                  ; STRUC WITH DEFINED LENGTH
2337         SETZ    NTHRS2                  ; SAME SBOOL
2338         SETZ    NTHRA                   ; ANY
2339         SETZ    NTHRHW                  ; SPECIAL TYPE-C CASE
2340
2341 ; HERE TO EXTRACT A BOOLEAN
2342
2343 NTHRBB: LDB     B,C                     ; GET WORD OF BOOLEANS
2344         LSH     B,18.                   ; SHIFT OVER
2345         ILDB    C,C                     ; GET NEXT 16 BITS
2346         IOR     B,C                     ; THEN OR THEM TOGETHER
2347         LDB     C,[111100,,(A)]         ; GET LEFT SHIFT
2348         LSH     B,(C)                   ; SHIFT IT
2349         LDB     C,[001100,,(A)]         ; GET RIGHT SHIFT
2350         MOVNS   C
2351         LSH     B,(C)                   ; SHIFT RIGHT
2352         HLLZ    A,(A)
2353         POPJ    P,
2354
2355 ; HERE FOR LOSER
2356
2357 NTHRE:  PUSHJ   P,COMPER
2358
2359 ; HERE TO EXTRACT LIST OR FIX
2360
2361 NTHRLF: HLLZ    A,(A)                   ; GET TYPE/LENGTH FROM TABLE
2362         LDB     B,C                     ; GET VALUE BYTE
2363         LSH     B,18.                   ; SHIFT OVER
2364         ILDB    C,C                     ; GET NEXT 16 BITS
2365         IOR     B,C                     ; THEN OR THEM TOGETHER
2366         POPJ    P,
2367
2368 ; HERE TO EXTRACT 2-WORD ITEM
2369
2370 NTHRS3: HLLZ    A,(A)                   ; GET TYPE/LENGTH FROM TABLE
2371         LDB     0,C                     ; LOAD FIRST 16 BITS
2372         ILDB    B,C                     ; GET NEXT 16 BITS
2373         LSH     B,18.                   ; SHIFT OVER
2374         ILDB    C,C                     ; GET NEXT 16 BITS
2375         IOR     B,C                     ; THEN OR THEM TOGETHER
2376         HRR     A,0
2377 NTHRX:  JUMPN   B,CPOPJ
2378         MOVE    A,$WFALSE
2379 CPOPJ:  POPJ    P,
2380
2381 ; HERE TO EXTRACT STRUC WITH KNOWN LENGTH ITEM
2382
2383 NTHRS2: LDB     B,C                     ; GET LENGTH WORD
2384         LSH     B,18.                   ; SHIFT OVER
2385         ILDB    C,C                     ; GET NEXT 16 BITS
2386         IOR     B,C                     ; THEN OR THEM TOGETHER
2387         MOVE    A,(A)                   ; GET TYPE WORD FROM TABLE
2388         ILDB    C                       ; FIX POINTER (SHOULD BE IBP)
2389         JRST    NTHRX
2390
2391 ; HERE TO EXTRACT 4-WORD ITEM (ANY)
2392
2393 NTHRA:  LDB     B,C                     ; GET TYPE WORD
2394         HRLZS   B
2395         ILDB    A,C                     ; GET LENGTH WORD
2396         IOR     A,B                     ; PUT EM TOGETHER
2397         ILDB    B,C                     ; LOAD FIRST 16 BITS
2398         LSH     B,18.                   ; SHIFT OVER
2399         ILDB    C,C                     ; GET NEXT 16 BITS
2400         IOR     B,C                     ; THEN OR THEM TOGETHER
2401         POPJ    P,
2402
2403 NTHRHW: LDB     B,C                     ; GET POSSIBLE TYPE CODE
2404         CAIN    B,-1
2405          JRST   [       MOVEI   B,0
2406                         MOVSI   A,$TFALSE
2407                         POPJ    P, ]
2408         HLLZ    A,(A)                   ; TYPE FROM TABLE
2409         POPJ    P,
2410
2411 PUTU:   LDB     A,[UPTBYT,,A]
2412         JRST    @PUTUTB(A)
2413
2414 PUTUTB: SETZ    PUTUS
2415         SETZ    PUTUS
2416         SETZ    PUTUU
2417         SETZ    PUTUV
2418
2419 PUTUS:  ADJBP   O2,B
2420         DPB     D,O2
2421         POPJ    P,
2422
2423 PUTUU:  ADDI    B,-1(O2)
2424         MOVEM   D,(B)
2425         POPJ    P,
2426
2427 PUTUV:  SUBI    O2,1
2428         LSH     O2,1
2429         ADD     B,O2
2430         DMOVEM  C,(B)
2431         POPJ    P,
2432
2433 PUTR:   ASH     A,1
2434         SKIPN   A,RECTBL+1(A)           ; AND POINTER TO TABLE
2435          PUSHJ  P,HALTX
2436         PUSH    TP,(D)                  ; SAVE VALUE
2437         PUSH    TP,1(D)
2438         LSH     O2,1                    ; 4 16-BIT WORDS / ENTRY
2439         ADDI    A,-1(O2)                ; POINT TO CORRECT ENTRY (REMEMBER TOP)
2440         HRRZ    B,1(A)                  ; GET SIZE OF ITEM TO EXTRACT
2441         HLRZ    C,1(A)                  ; WORD OFFSET TO START FROM
2442         MOVE    O2,O1
2443         XMOVEI  E,-1(TP)                ; SEND VALUE IN E
2444 ;       HRLI    O1,LH+40
2445         MOVSI   O1,LH+O2
2446         ADJBP   C,O1                    ; MAKE BYTE POINTER TO ITEM
2447         PUSHJ   P,@PUTRTB-1(B)          ; DISPATCH
2448         ADJSP   TP,-2
2449         POPJ    P,
2450
2451 PUTRTB: SETZ    PUTRBB                  ; BOOLEAN
2452         SETZ    PUTRE                   ; ERROR - SHOULDN'T HAPPEN
2453         SETZ    PUTRBB                  ; ENUMERATION
2454         SETZ    PUTRBB                  ; SUB-RANGE
2455         SETZ    PUTRBB                  ; SUB-RANGE (SBOOL)
2456         SETZ    PUTRLF                  ; LIST OR FIX
2457         SETZ    PUTRLF                  ; LIST OR FIX (SBOOL)
2458         SETZ    PUTRS3                  ; STRUC IN 3 HALF WORDS
2459         SETZ    PUTRS3                  ; SAME WITH SBOOL
2460         SETZ    PUTRS2                  ; STRUC WITH DEFINED LENGTH
2461         SETZ    PUTRS2                  ; SAME SBOOL
2462         SETZ    PUTRA                   ; ANY
2463         SETZ    PUTRHW                  ; SPECIAL CASE FOR TYPE-C
2464
2465 ; HERE TO SET A BOOLEAN
2466
2467 PUTRBB: LDB     0,[111100,,(A)]         ; GET LSHIFT
2468         LDB     A,[001100,,(A)]         ; GET RSHIFT
2469         MOVE    B,A
2470         SUB     B,0
2471         LSH     B,30.                   ; BUILD BYTE POINTER
2472         MOVEI   0,36.
2473         SUBI    0,(A)
2474         LSH     0,24.
2475         IOR     0,B                     ; HAVE LH OF BYTE POINTER
2476         LDB     B,C
2477         LSH     B,18.
2478         ILDB    A,C
2479         IOR     A,B
2480         HRRI    0,A                     ; POINT TO AC
2481         MOVE    B,1(E)                  ; NEW VAL
2482         DPB     B,0                     ; SMASH REGISTER
2483         DPB     A,C                     ; PUT IT BACK
2484         MOVNI   B,1
2485         ADJBP   B,C                     ; SMASH OTHER BYTE
2486         HLRZS   A
2487         DPB     A,B                     ; OTHER HALF BACK IN
2488         POPJ    P,
2489
2490
2491 PUTRE:  PUSHJ   P,COMPER
2492
2493 PUTRLF: LDB     B,[LH,,1(E)]            ; GET LH OF VALUE OF 3RD ARG
2494         DPB     B,C                     ; AND STUFF
2495         LDB     B,[RH,,1(E)]            ; GET RH OF VALUE OF 3RD ARG
2496         IDPB    B,C                     ; AND STUFF
2497         POPJ    P,
2498
2499 PUTRS2: HLRZ    B,(E)                   ; TYPE OF ARG
2500         CAIN    B,$WFALSE
2501          SETZM  1(E)                    ; MAKE SURE 0
2502         JRST    PUTRLF
2503
2504 ; HERE FOR 3 WORD ITEM (IE LENGTH AND POINTER)
2505
2506 PUTRS3: LDB     B,[LENWRD,,(E)]         ; GET LENGTH
2507         DPB     B,C                     ; STUFF IT
2508         ILDB    C                       ; FIX POINTER (SHOULD BE IBP)
2509         JRST    PUTRS2
2510
2511 ; HERE TO SET 4-WORD ITEM (ANY)
2512
2513 PUTRA:  LDB     B,[TYPWRD,,(E)]         ; GET TYPE
2514         DPB     B,C                     ; AND STUFF IT
2515         LDB     B,[LENWRD,,(E)]
2516         IDPB    B,C
2517         ILDB    B,C
2518         JRST    PUTRLF
2519
2520 PUTRHW: LDB     B,[TYPWRD,,(E)]         ; TYPE OF ARG
2521         CAIE    B,$TFALSE               ; FALSE ==> ZERO SLOT
2522          SKIPA  B,1(E)                  ; NOT FALSE USE TYPEC
2523           MOVEI B,-1
2524         DPB     B,C                     ; STORE IT
2525         POPJ    P,
2526
2527 BACKU:  MOVNS   O2
2528 RESTU:  LDB     C,[UPTBYT,,A]
2529         JRST    @RESUTB(C)
2530
2531 RESUTB: SETZ    RESUB
2532         SETZ    RESUS
2533         SETZ    RESUU
2534         SETZ    RESUV
2535
2536 RESUU:  SUB     A,O2
2537         ADD     B,O2
2538         HRLI    A,$TUVECTOR
2539         JRST    (PC)
2540
2541 RESUB:  SUB     A,O2
2542         EXCH    B,O2
2543         ADJBP   B,O2
2544         HRLI    A,$TBYTES
2545         JRST    (PC)
2546
2547 RESUS:  SUB     A,O2
2548         EXCH    B,O2
2549         ADJBP   B,O2
2550         HRLI    A,$TSTRING
2551         JRST    (PC)
2552
2553 RESUV:  SUB     A,O2
2554         LSH     O2,1
2555         ADD     B,O2
2556         HRLI    A,$TVECTOR
2557 ;       CAMG    B,TP
2558 ;        HRLI   A,$TTUPLE               ; Win with tuples???
2559         JRST    (PC)
2560
2561 TOPU:   HRRZ    C,A
2562         LDB     D,[UPTBYT,,A]
2563         JRST    @TOPUTB(D)
2564
2565 TOPUTB: SETZ    TOPUB
2566         SETZ    TOPUS
2567         SETZ    TOPUU
2568         SETZ    TOPUV
2569
2570 TOPUB:  MOVEI   D,60
2571         MOVEI   E,4
2572         HRLI    0,$TBYTES
2573         JRST    TOPUS1
2574
2575 TOPUS:  MOVEI   D,66
2576         MOVEI   E,5
2577         HRLI    0,$TSTRING
2578 TOPUS1: ADJBP   C,B                     ; ADJUST TO THE END
2579         MOVE    B,C
2580         LDB     C,[360600,,B]
2581         SUBI    C,(D)                   ; # BYTES UNUSED IN LAST WORD
2582         TLZ     B,770000                ; MAKE WORD POINTER
2583         HRRZ    A,1(B)                  ; THIS IS TOTAL LENGTH (FROM DOPE)
2584         SUB     B,A                     ; TO WORD ADDRESS OF STRING START
2585         IMUL    A,E
2586         LSH     D,12.
2587         TLO     B,(D)                   ; MAKE CORRECT GLOBAL BP
2588         ADD     A,C                     ; ADJUST LENGTH
2589         HLL     A,0                     ; MAKE A TYPE WORD
2590         JRST    (PC)
2591
2592 TOPUU:  ADD     B,C                     ; POINT TO DOPE WORD
2593         HRRZ    A,(B)                   ; GET TOTAL LENGTH
2594         SUB     B,A                     ; BACK IT UP
2595         HRLI    A,$TUVECTOR             ; HERE'S THE TYPE WORD
2596         JRST    (PC)
2597
2598 TOPUV:  LSH     C,1
2599         ADD     B,C                     ; POINT TO DOPE WORD
2600         HRRZ    A,(B)                   ; HERE IS TOTAL LENGTH
2601         SUB     B,A                     ; POINTS TO TOP OF VECTOR
2602         LSH     A,-1                    ; GET LENGTH
2603         HRLI    A,$TVECTOR              ; AND FINISH TYPE WORD
2604         JRST    (PC)
2605
2606 ; HERE FOR CONS NEEDING GC
2607
2608 CONS1:  PUSH    P,PC
2609         SUBM    R,(P)
2610         PUSH    TP,C
2611         PUSH    TP,D
2612         PUSH    TP,$WLIST
2613         PUSH    TP,E                    ; IN CASE A GC OCCURS
2614         PUSHJ   P,ICELL
2615         POP     TP,(A)
2616         ADJSP   TP,-1
2617         POP     TP,2(A)
2618         POP     TP,1(A)
2619         MOVE    B,A
2620         MOVE    A,$WLIST
2621         JRST    RPOPJ
2622
2623
2624 \f
2625 SUBTTL  INPUT / OUTPUT
2626
2627 BPS:    440700,,(D)
2628         350700,,(D)
2629         260700,,(D)
2630         170700,,(D)
2631         100700,,(D)
2632
2633 OPENX:  MOVE    E,D
2634         PUSHJ   P,OPNAM                 ; MAKE FILE NAME STRING
2635         HRROI   B,FNBLK
2636         XCT     GTJMOD(O1)              ; PERFORM GTJFN BITS MAGIC
2637         GTJFN
2638          JUMP   16,JFSERR
2639         MOVE    B,O2
2640         LSH     B,30.
2641         XCT     OPNMOD(O1)              ; PERFORM OPENF BITS MAGIC
2642         OPENF
2643          JUMP   16,JFSERR
2644         MOVE    B,$WFIX                 ; RETURN JFN NUMBER
2645         EXCH    A,B
2646         POPJ    P,
2647
2648 OPNAM:  MOVE    B,[440700,,FNBLK]       ; BP TO FILE NAME BLOCK
2649         HRRZS   C
2650 OPNAML: ILDB    0,E                     ; GET CHARACTER
2651         IDPB    0,B                     ; AND STUFF IT
2652         SOJN    C,OPNAML                ; LOOP UNTIL DONE
2653         SETZ    0,
2654         IDPB    0,B                     ; MAKE IT ASCIZ
2655         POPJ    P,
2656
2657 GTJMOD: MOVSI   A,(GJ%SHT+GJ%OLD)
2658         MOVSI   A,(GJ%SHT+GJ%FOU)
2659         JRST    COMPER
2660         JRST    COMPER
2661
2662 OPNMOD: HRRI    B,OF%RD
2663         HRRI    B,OF%WR
2664         JRST    COMPER
2665         JRST    COMPER
2666
2667 CLOSEX: CLOSF                           ; ATTEMPT TO CLOSE JFN
2668          JRST   RETERR                  ; CHOMP
2669         MOVE    A,$WFIX                 ; RETURNS 1 IF WINNING
2670         MOVEI   B,1
2671         POPJ    P,
2672
2673 RESETX: POPJ    P,
2674
2675 ATIC:   AOS     A,ATICNM'
2676         MOVEI   C,35.
2677         SUB     C,A
2678         MOVEI   B,1
2679         LSH     B,(C)
2680         TDNN    B,[770000,,003777]
2681          JRST   ATIC                    ; TRY different char
2682         MOVEI   A,.FHSLF
2683         AIC
2684         JUMPL   O1,ATICDN               ; If not a char, don't do ATI
2685         MOVE    A,ATICNM
2686         HRL     A,O1
2687         CAIN    O1,7                    ; store channel for ^G and ^A
2688          MOVEM  B,CTLGCH
2689         CAIN    O1,1
2690          MOVEM  B,CTLACH
2691         ATI
2692 ATICDN: MOVE    A,$WFIX
2693         MOVE    B,ATICNM
2694         POPJ    P,
2695
2696 RETERR: PUSH    P,A                     ; SAVE ERROR CODE
2697         PUSHJ   P,ICELL                 ; GET A LIST CELL
2698         MOVE    B,$WFIX                 ; STUFF THE CELL WITH ERROR CODE
2699         SETZM   (A)
2700         MOVEM   B,1(A)
2701         POP     P,2(A)
2702         MOVE    B,A
2703         MOVE    A,$WFALSE               ; AND RETURN AS FALSE
2704         POPJ    P,
2705
2706 IOERR:  SUBM    R,(P)
2707         MOVEI   A,400000                ; GET ERROR
2708         GETER
2709         HRRZ    A,B
2710         PUSHJ   P,RETERR                ; CONS IT UP
2711         MOVEI   O2,1
2712         JRST    CMPER2                  ; GO GIVE IT TO USER
2713
2714 ; Return run time of process, in seconds, as float
2715 RNTIME: PUSH    P,C
2716         MOVEI   A,.FHSLF
2717         RUNTM
2718         FLTR    B,A
2719         FDVR    B,[1000.0]
2720         MOVE    A,$WFLOAT
2721         POP     P,C
2722         POPJ    P,
2723
2724 PRINTZ: MOVNS   C
2725         SOUT
2726         POPJ    P,
2727
2728 READX:  PUSH    P,C
2729         PUSH    P,D
2730         MOVEM   OP,.RDRTY+IRDBLK        ; SET UP PROMPT
2731         JUMPN   OP,READX1
2732         PUSH    TP,$WFALSE              ; SAVE IF NO PROMPT
2733         PUSH    TP,OP
2734         JRST    READX4
2735 READX1: MOVEI   D,1                     ; OTHERWISE, GET LENGTH, SAVE STRING
2736 READX3: ILDB    C,OP
2737         JUMPE   C,READX2
2738         AOJA    D,READX3
2739 READX2: HRLI    D,$TSTRING
2740         PUSH    TP,D
2741         PUSH    TP,.RDRTY+IRDBLK
2742 READX4: MOVEI   C,IRDBRK
2743         MOVEM   C,.RDBRK+IRDBLK         ; SETUP BREAK MASK
2744         PUSH    TP,$WFIX
2745         PUSH    TP,[0]
2746         JUMPE   E,READNM
2747         SETOM   (TP)
2748         SETZM   ARDBRK
2749         MOVE    C,[ARDBRK,,ARDBRK+1]
2750         BLT     C,ARDBRK+3
2751         MOVEI   C,ARDBRK
2752         MOVEM   C,.RDBRK+IRDBLK
2753         SKIPA   C,[4]                   ; Turn on ctrl-D
2754 READLP:  ILDB   C,E
2755         JUMPE   C,READNM
2756         IDIVI   C,32.
2757         MOVSI   OP,400000
2758         MOVNS   D
2759         LSH     OP,(D)
2760         IORM    OP,ARDBRK(C)
2761         JRST    READLP
2762 READNM: MOVE    C,-1(P)
2763         MOVE    D,(P)
2764         HRLM    A,.RDIOJ+IRDBLK         ; INPUT JFN
2765         MOVEM   B,.RDBFP+IRDBLK         ; DESTINATION BUFFER POINTER
2766         MOVEM   B,.RDBKL+IRDBLK         ; BACKUP LIMIT
2767         SUB     C,D                     ; GET LENGTH OF STRING
2768         MOVEM   C,.RDDBC+IRDBLK         ; AND SUBTRACT CHRS ALREADY READ
2769         ADJBP   D,B                     ; ADJUST STRING FOR CHRS ALREADY READ
2770         MOVEM   D,.RDDBP+IRDBLK         ; DESTINATION STRING
2771         MOVEI   C,.NULIO
2772         CAIN    A,.PRIIN
2773          MOVEI  C,.PRIOU
2774         HRRM    C,.RDIOJ+IRDBLK
2775         PUSH    TP,$WFIX
2776         PUSH    TP,IRDBLK+.RDIOJ
2777         MOVE    C,-1(P)                 ; STRING LENGTH
2778         HRLI    C,$TSTRING
2779         PUSH    TP,C
2780         PUSH    TP,IRDBLK+.RDBFP
2781         MOVE    C,IRDBLK+.RDBRK
2782         PUSH    TP,$WFIX
2783         PUSH    TP,(C)
2784         PUSH    TP,$WFIX
2785         PUSH    TP,1(C)
2786         PUSH    TP,$WFIX
2787         PUSH    TP,2(C)
2788         PUSH    TP,$WFIX
2789         PUSH    TP,3(C)
2790         ADJSP   P,-2                    ; NOW NOTHING ON P STACK
2791 BRESTA: MOVEI   A,IRDBLK
2792         TEXTI                           ; DO IT
2793 RRESTA:  JFCL
2794 ; This now has a giant kludge to make ctrl-D redisplay the buffer without
2795 ; clearing the screen.
2796         LDB     B,.RDDBP+IRDBLK ; Look at last character read
2797         CAIE    B,^D            ; ctrl-D?
2798          JRST   DTEXTI
2799         HRRZ    A,.RDIOJ+IRDBLK ; Yes, pick up output jfn to use
2800         MOVEI   B,^M            ; do crlf
2801         BOUT
2802         MOVEI   B,^J
2803         BOUT
2804         SKIPN   B,.RDRTY+IRDBLK
2805          JRST   NOPRMP
2806         MOVEI   C,0
2807         SOUT                    ; Output prompt
2808 NOPRMP: MOVE    B,.RDBFP+IRDBLK ; pick up pointer to buffer beginning
2809         HRRZ    C,-11(TP)       ; ORIGINAL LENGTH OF BUFFER
2810         AOS     .RDDBC+IRDBLK   ; ADD 1 TO CHARS AVAILABLE
2811         SUB     C,.RDDBC+IRDBLK ; REAL NUMBER CHARS IN BUFFER
2812         MOVNS   C               ; - # CHARS IN BUFFER
2813         SKIPE   C               ; don't print if none there
2814          SOUT                   ; print buffer
2815         MOVEM   B,.RDDBP+IRDBLK ; update dest string pointer
2816         MOVEI   A,IRDBLK
2817         JRST    BRESTA          ; try again
2818
2819 DTEXTI: HRRZ    B,-11(TP)               ; GET ORIGINAL LENGTH
2820         SUB     B,.RDDBC+IRDBLK         ; FIXUP COUNT
2821         MOVE    A,$WFIX
2822         ADJSP   TP,-20                  ; EIGHT THINGS PUSHED ON STACK
2823         POPJ    P,
2824
2825 SOUTX:  SKIPA   O1,[SOUT]
2826
2827 SINX:   MOVE    O1,[SIN]
2828 RSINX:  MOVEI   O2,1
2829         PUSH    P,B
2830         PUSH    P,0
2831         LDB     0,[220300,,0]
2832         CAIN    0,$PUVECT
2833          JRST   [HLL    0,B
2834                  HRLI   B,444400
2835                  HRRI   0,DOJSYS
2836                  PUSHJ  P,@0
2837                   MOVEI O2,0                    ; INDICATE FAILURE
2838                  POP    P,A
2839                  POP    P,C
2840                  SKIPLE B
2841                   ADDI  B,1
2842                  SUBM   B,C
2843                  SUBI   A,(C)
2844                  JRST   SINXXX]
2845         PUSH    P,0                     ; SAVE TYPE OF FROB
2846         CAIE    0,$PSTRIN
2847          CAIN   0,$PBYTES
2848           CAIA
2849            JRST COMPER
2850         XCT     O1
2851          JUMP   16,[    MOVEI   O2,0
2852                         JRST    .+1 ]
2853         HRL     O1,A                    ; SAVE JFN
2854         POP     P,0
2855         LDB     E,[360600,,B]           ; GET BYTE PART
2856         LDB     A,[360600,,-1(P)]       ;  OF BOTH
2857         SUB     E,A                     ; ODD BYTES
2858         MOVE    C,B                     ; COPY POINTER
2859         TLZ     C,770000                ; JUST WORD POINTER
2860         POP     P,A                     ; GET ORIGINAL COUNT WORD
2861         POP     P,D                     ; AND ORIG PNTR
2862         TLZ     D,770000
2863         SUB     C,D
2864         CAIE    0,$PBYTES
2865          JRST   [IMULI  C,5
2866                  JRST   SINXX1]
2867         IMULI   C,4
2868 SINXX1: ADD     C,E
2869         SUBI    A,(C)                   ; AND FIX IT
2870 SINXXX: SKIPE   O2                      ; IF ERROR, SKIP
2871          POPJ   P,
2872
2873 SINLSR: PUSH    TP,A
2874         PUSH    TP,B
2875         MOVEI   A,400000                ; GET ERROR
2876         GETER
2877         MOVEI   A,(B)                   ; ERROR TO A
2878         CAIN    A,IOX4                  ; IS THIS EOF
2879          JRST   [       POP     TP,B    ; yes just return rested string
2880                         POP     TP,A
2881                         POPJ    P,]
2882         PUSH    TP,$WFIX                ; save SIN/SOUT and JFN
2883         PUSH    TP,O1
2884         PUSH    TP,$WFIX
2885         POP     P,0
2886         SUB     0,R
2887         PUSH    TP,0                    ;relativized ret PC
2888         PUSH    TP,-5(TP)
2889         PUSH    TP,-5(TP)
2890         PUSHJ   P,RETERR                ; cons up error code
2891         PUSH    TP,A
2892         PUSH    TP,B
2893         PUSHJ   P,ICELL                 ; include buffer in false
2894         MOVE    B,(TP)
2895         MOVEM   A,(B)
2896         ADJSP   TP,-2
2897         POP     TP,2(A)
2898         POP     TP,1(A)
2899         SKIPN   O1,ECATM                ; call error-in compiled code handler
2900          JRST   CMPERX
2901         JSP     PC,FRAME
2902         PUSH    TP,$WFALS
2903         PUSH    TP,B
2904         MOVEI   O2,1
2905         JSP     PC,CALLZ
2906         MOVE    PC,(TP)                 ; returned from error, try i/o again
2907         ADD     PC,R
2908         PUSH    P,PC
2909         MOVE    O1,-2(TP)               ; unrelativized PC to stack
2910         DMOVE   A,-5(TP)                ; buffer back
2911         MOVEI   C,(A)
2912         MOVNS   C
2913         MOVE    0,A
2914         HLRZ    A,O1
2915         HRLI    O1,(JSYS)
2916         ADJSP   TP,-6
2917         JRST    RSINX
2918
2919 GTJFNX: TLNN    A,(GJ%FNS)              ; STRING ARG?
2920          JRST   [MOVE E,B
2921                  PUSHJ P,OPNAM          ; FORCE ASCIZ IN THIS SECTION
2922                  HRROI  B,FNBLK
2923                  JRST GTJFN1 ]
2924 GTJFN1: GTJFN
2925          JUMP   16,JFSERR
2926         MOVE    B,A
2927         MOVSI   A,$TFIX
2928         POPJ    P,
2929
2930 JFNSX:  CAIGE   A,177                   ; SKIP IF JFNSing to a string
2931          JUMPGE A,[     JFNS            ; DO IT
2932                          JUMP   16,JFSERR
2933                         MOVSI   A,$TFIX
2934                         POPJ    P,]
2935
2936         MOVE    O1,A
2937         HRROI   A,FNBLK
2938         JFNS
2939          JUMP   16,JFSERR               ; LOSE...
2940
2941         EXCH    E,O1
2942         MOVE    C,[440700,,FNBLK]
2943         MOVEI   B,0
2944 JFNSL:  ILDB    0,C
2945         JUMPE   0,JFNSM
2946         ADDI    B,1
2947         IDPB    0,E                     ; MOVE CHARS
2948         CAMN    C,A                     ; ARE WE DONE
2949          JRST   JFNSM
2950         SOJG    O1,JFNSL
2951
2952         MOVNS   B                       ; RETURN NEGATIVE LENGTH
2953 JFNSM:  MOVSI   A,$TFIX
2954         POPJ    P,
2955
2956 JFSERR: MOVEI   A,400000        ; GET ERROR
2957         GETER
2958         MOVEI   A,(B)           ; ERROR TO A
2959         JRST    RETERR
2960
2961 ERSTRX: CAIG    A,177                   ; SKIP IF TO STRING
2962          JUMPGE A,[     ERSTR
2963                          JUMP   16,RETF1
2964                           JRST  RETF2
2965                            MOVSI A,$TFIX
2966                            POPJ P,]
2967
2968         MOVE    O2,A                    ; SAVE ORG STR PNTR
2969         ERSTR
2970          JUMP   16,RETF1
2971           JRST  RETF2
2972
2973         LDB     B,[360600,,A]           ; GET BYTE PART
2974         LDB     0,[360600,,O2]
2975         SUB     B,0
2976         TLZ     A,770000
2977         TLZ     O2,770000
2978         SUB     A,O2
2979         IMULI   A,5
2980         ADD     B,A
2981         MOVSI   A,$TFIX
2982         POPJ    P,
2983
2984 RETF1:  TDZA    A,A
2985 RETF2:  MOVEI   A,1
2986         AOJA    A,RETERR
2987
2988 ; do long form GTJFN
2989
2990 GTJFNL: MOVNI   A,(O1)                  ; FIND BASE OF ARGS
2991         ADD     A,A
2992         MOVE    O2,TP                   ; COPY STACK POINTER
2993         ADJSP   O2,(A)                  ; POINT TO FIRS ARG
2994         MOVE    B,[440700,,FNBLK]       ; FOR COPIED STRINGS
2995         MOVEI   A,GTJFBK                ; POINT TO ARG BLOCK
2996         PUSH    P,O2
2997         PUSH    P,O1
2998
2999 GTJFLP: HLRZ    0,1(O2)
3000         CAIE    0,$TSTRING              ; STRING
3001          JRST   [       MOVE    0,2(O2) ; NO GET FIX
3002                         MOVEM   0,(A)   ; INTO BLOCK
3003                         JRST    GTJFNA]
3004
3005         HRRZ    C,1(O2)                 ; STRING LENGTH
3006         JUMPE   C,[     SETZM   (A)
3007                         JRST    GTJFNA]
3008         MOVEM   B,(A)                   ; STORE BYTE POINTER
3009         MOVE    E,2(O2)                 ; STR PNTR
3010         PUSHJ   P,OPNAML                ; FORCE ASCIZ IN THIS SECTION
3011 GTJFNA: ADJSP   O2,2                    ; NEXT ARG
3012         ADDI    A,1
3013         SOJG    O1,GTJFLP
3014
3015         MOVE    B,GTJFBK
3016         MOVEI   A,GTJFB2
3017         MOVE    O2,GTJFOS
3018         GTJFN                           ; DO THE GTJFN
3019          JUMP   16,GTERR                ; ERROR
3020
3021         POP     P,O1
3022         POP     P,TP
3023         MOVE    B,A
3024         MOVSI   A,$TFIX
3025         SKIPN   GTJFOS
3026          POPJ   P,
3027
3028         MOVE    D,.GJCPP+.GJCPP+4(TP)
3029         HRRZ    C,.GJCPP+.GJCPP+3(TP)
3030
3031         ILDB    0,O2
3032         IDPB    0,D
3033         SOJG    C,.-2
3034         POPJ    P,
3035
3036 GTERR:  POP     P,O1
3037         POP     P,TP
3038         JRST    JFSERR
3039
3040 ; MOVED TO PAGE ZERO SO EXCESSIBLE FROM ALL SECTIONS
3041 ;IRDBLK:        10
3042 ;       RD%BRK+RD%JFN                   ; JFNS COMING
3043 ;       .PRIOU                          ; FOR EDITING
3044 ;       0                               ; DESTINATION STRING
3045 ;       0
3046 ;       0
3047 ;       0
3048 ;       IRDBRK                          ; FOR FUTURE EXPANSION
3049 ;       0
3050
3051 ;IRDBRK:        0
3052 ;       0
3053 ;       0
3054 ;       0
3055
3056 \f
3057 SUBTTL  ARITHMETIC
3058
3059 RANDOM: GTAD
3060         IDIV    A,O1
3061         ADDI    B,1
3062         MOVE    A,$WFIX
3063         JRST    (PC)
3064
3065 SUBTTL LVAL MANIPULATION
3066
3067 ;ILVAL RECEIVES ATOM IN IN O1
3068
3069 ILVAL:  SKIPN   O2,1(O1)                ;SEE IF BINDING
3070          JRST   ILVAL1
3071         MOVE    0,7(O2)                 ; GET BINDID
3072         CAME    0,BINDID                ; SKIP IF OK
3073          JRST   ILVAL1
3074         DMOVE   A,(O2)                  ; GET VALUE
3075         JUMPN   A,(PC)                  ; RETURN IF BOUND
3076 ILVAL2: PUSH    P,PC
3077         JSP     PC,FRAME                ; Have binding with no value
3078         PUSH    TP,[$TATOM,,$LATOM]     ; So strictly error case of EICC
3079         PUSH    TP,O1
3080         MOVEI   O2,1
3081         MOVE    O1,ECATM                ; ERROR IN COMPILED CRUFT...
3082         POP     P,PC
3083         JRST    MCALL
3084
3085 ILVAL1: MOVE    A,PC                    ; SAVE PC
3086         JSP     PC,IASS                 ; SEE IF ASSIGNED AT ALL
3087          MOVEI  O2,0                    ; IF NOT , SO INDICATE
3088         MOVE    PC,A
3089         JUMPE   O2,ILVAL2               ; GENERATE ERROR
3090         DMOVE   A,(O2)
3091         JRST    (PC)
3092
3093 ;IASS -- ASSIGNED? O1 IS ATOM, SKIP IF ASSIGNED?
3094
3095 IASS:   SKIPN   O2,1(O1)                ; BINDING PNTR?
3096          JRST   (PC)                    ; NO, NO SKIP
3097         MOVE    0,7(O2)                 ; BIND ID?
3098         CAME    0,BINDID                ; SKIP IF NO SEARCH
3099          JRST   IASS1
3100 IASS4:  SKIPE   (O2)                    ; BOUND?
3101          ADDI   PC,1
3102         JRST    (PC)
3103
3104 IASS1:  MOVE    O2,SP                   ; SEARCH
3105 IASS2:  CAMN    O1,2(O2)                ; SKIP IF NOT IT
3106          JRST   IASS4                   ; CHECK VALUE OK
3107         SKIPE   O2,5(O2)                ; NEXT BINDING
3108          JRST   IASS2
3109         MOVE    O2,TTBIND               ; SAME THING FOR TOP BINDING
3110 IASS3:  CAMN    O1,2(O2)
3111          JRST   IASS4
3112         SKIPE   O2,5(O2)
3113          JRST   IASS3
3114         JRST    (PC)
3115
3116 ;ISET -- RECEIVES ATOM IN O1 , NEW VAL IN A,B
3117
3118 ISET:   SKIPN   O2,1(O1)                ;SEE IF BINDING
3119          JRST   ISET1
3120         MOVE    0,7(O2)                 ; GET BINDID
3121         CAME    0,BINDID                ; SKIP IF OK
3122          JRST   ISET1
3123         DMOVEM  A,(O2)                  ; SET VALUE
3124         JRST    (PC)                    ; RETURN
3125
3126 ISET1:  PUSH    P,PC
3127         JSP     PC,FRAME
3128         PUSH    TP,[$TATOM,,$LATOM]
3129         PUSH    TP,O1
3130         PUSH    TP,A
3131         PUSH    TP,B
3132         MOVEI   O2,2
3133         MOVE    O1,ECATM                ; ERROR IN COMPILED CRUFT...
3134         POP     P,PC
3135         JRST    MCALL
3136
3137 ;MOVSTR - O1 FROM, O2 TO, O #CHARS
3138
3139 MOVSTR: SKIPG   C,0                     ; make sure something to move
3140          JRST   (PC)                    ; ret immediately
3141         MOVE    A,O1                    ; compute word addrs of strs
3142         MOVE    D,O2
3143         MOVE    E,0
3144         ADJBP   C,A                     ;C is end of from
3145         ADJBP   E,D                     ;E is end of to
3146         TLZ     O1,770000               ; clear byte pntr part, O1 start of from
3147         TLZ     O2,770000               ; O2 start of to
3148         TLZ     C,770000
3149         TLZ     E,770000
3150         CAMG    O1,E                    ; skip if start from is grtr than end to
3151          CAMLE  O2,C                    ; dont skip if start of to is grt end from
3152           JRST  NOOVER                  ; jump to use movestr instruction
3153
3154         CAMN    O1,O2                   ; same word, check bp
3155          JRST   [       CAMG    A,D
3156                          JRST   MOVBAK
3157                           JRST  MOVFWD ]
3158         CAMG    O1,O2
3159          JRST   MOVBAK                  ; must go backwards
3160 MOVFWD: ILDB    O1,A
3161         IDPB    O1,D
3162         SOJG    0,MOVFWD
3163         JRST    (PC)
3164
3165 ;hairy back move
3166
3167 MOVBAK: MOVE    O1,0
3168         MOVE    O2,0
3169         ADJBP   O1,A                    ; point to last byte in both
3170         ADJBP   O2,D
3171
3172 MOVBK1: LDB     C,O1                    ; move a byte
3173         DPB     C,O2
3174 ADJBP1: MOVNI   A,1                     ; now tediously backup the 2 bps
3175         ADJBP   A,O1
3176         TLNE    A,770000                ; check for micro code bug
3177          JRST   .+3
3178         AOS     BUGS
3179         JRST    ADJBP1
3180         MOVE    O1,A
3181 ADJBP2: MOVNI   A,1
3182         ADJBP   A,O2
3183         TLNE    A,770000                ; check for micro code bug
3184          JRST   .+3
3185         AOS     BUGS
3186         JRST    ADJBP2
3187         MOVE    O2,A
3188         SOJG    0,MOVBK1
3189         JRST    (PC)
3190
3191 ; here if strings dont overlap 0 & A & C are setup ok
3192
3193 MOVSLJ==123000,,[016000,,]
3194
3195 NOOVER: MOVE    C,0
3196         SETZB   B,E                     ; superstition
3197         MOVSLJ  0,
3198         JRST    COMPER
3199         JRST    (PC)
3200
3201 \f
3202 SUBTTL  GARBAGE COLLECTION UTILITIES
3203
3204 MARKR:  CAMG    B,[INIGC,,]     ; DON'T MARK STACK OBJECTS
3205          JRST   (PC)
3206         HRRZ    D,A
3207         LSH     D,-1
3208         ADD     B,D             ; MOVE TO DOPE WORD
3209         JRST    MRKUX
3210
3211 MARKU:  LDB     D,[UPTBYT,,A]
3212         JRST    @MRKTBL(D)
3213
3214 MRKTBL: SETZ    MRKUS
3215         SETZ    MRKUS
3216         SETZ    MRKUU
3217         SETZ    MRKUV
3218
3219 MRKUS:  ANDI    A,-1
3220         ADJBP   A,B
3221         TLZ     A,770000
3222         XMOVEI  B,1(A)
3223         JRST    MRKUX
3224
3225 MRKUU:  HRRZ    D,A
3226         JRST    MRKUUV
3227
3228 MRKUV:  HRRZ    D,A
3229         LSH     D,1
3230 MRKUUV: ADD     B,D
3231 MRKUX:  MOVSI   D,200000
3232         JUMPE   C,[ANDCAM D,(B)
3233                    JRST (PC)]
3234         CAME    C,[200000,,]
3235          MOVEM  C,1(B)                  ; STORE RELOCATION
3236         IORM    D,(B)
3237         JRST    (PC)
3238
3239 MARKL:  JUMPE   B,(PC)
3240         ADDI    B,1
3241         JUMPE   C,MRKUX
3242         MOVSI   C,200000
3243         JRST    MRKUX
3244
3245 ; HERE FOR MARK PREDICATE
3246
3247 MKL:    JUMPE   B,[MOVEI B,1
3248                    JRST IMKL1]
3249         LDB     B,[MARKBIT,,1(B)]
3250         JUMPE   B,IMKL1         ; JUMP IF NOT MARKED
3251         MOVE    B,(B)           ; RETURN RELOCATION
3252         MOVSI   A,$WLIST
3253         JRST    (PC)
3254
3255 IMKL1:  MOVE    A,$WFIX
3256         JRST    (PC)
3257
3258 MKR:    CAMG    B,[INIGC,,]     ; SAY IT'S MARKED IF ITS ON THE STACK
3259          JRST   MKRT
3260         HRRZ    D,A
3261         LSH     D,-1
3262         ADD     B,D             ; MOVE TO DOPE WORD
3263         LDB     B,[MARKBIT,,(B)] ; MUNG IT
3264         JUMPE   B,MKRT
3265         MOVE    B,1(B)          ; RELOCATED WITH OLD TYPE
3266         SUBI    D,1(D)          ; BACK TO TOP
3267         JRST    (PC)
3268
3269 MKRT:   MOVE    A,$WFIX
3270         JRST    (PC)
3271
3272 MKU:    LDB     C,[UPTBYT,,A]
3273         JRST    @MKTB(C)
3274
3275 MKTB:   SETZ    MKUS
3276         SETZ    MKUS
3277         SETZ    MKUU
3278         SETZ    MKUV
3279
3280 MKUS:   ANDI    A,-1                    ; GET TO DW
3281         MOVE    0,A
3282         ADJBP   A,B
3283         LDB     B,[MARKBIT,,1(A)]
3284         JUMPE   B,MKRT
3285         SKIPN   B,2(A)
3286          AOJA   B,MKRT
3287         HRRZ    A,1(A)
3288         SUB     B,A
3289         JRST    (PC)
3290
3291 MKUU:   HRRZ    C,A
3292         JRST    MKUUV
3293
3294 MKUV:   HRRZ    C,A
3295         LSH     C,1
3296 MKUUV:  ADD     B,C
3297         LDB     B,[MARKBIT,,(B)]
3298         JUMPE   B,MKRT
3299         MOVE    B,1(B)
3300         SUBI    B,1(C)
3301         JRST    (PC)
3302
3303 MARKBIT==420100
3304
3305 ; SWEEP PHASE INSTRUCTIONS
3306
3307 ; SWEEPNEXT - GIVEN IN O1 A POINTER TO GC SPACE, IN A  A POINTER TO
3308 ; GC PARAMS
3309 ;  RETURNS A POINTER TO THE NEXT FROB IN GC SPACE
3310
3311 SWNEXT: SKIPN   B,O2
3312          MOVE   B,GCSBOF(A)
3313         LDB     E,[PTPBYT,,O1]
3314         CAIE    E,$PSTRING
3315          CAIN   E,$PBYTES
3316           TLZ   B,770000
3317         CAMG    B,GCSMIO(A)
3318          JRST   [SETZ   B,
3319                  MOVE   A,$WFIX
3320                  JRST (PC)]
3321         MOVE    A,-2(B)         ; GET THE DOPE WORD
3322         TLZE    A,$DOPEBIT      ; IS THE DOPE BIT SET?
3323          JRST   ISWVR           ; YES. EITHER A UBLOCK OR RECORD
3324         SUBI    B,3             ; NEXT FROB IS THREE BACK
3325         MOVE    A,$WLIST
3326         JRST    (PC)
3327
3328 ISWVR:  HRRZ    D,A             ; GET LENGTH
3329         SUBI    B,2(D)          ; FIND THE NEXT ONE
3330         LDB     E,[PTPBYT,,A]   ; GET THE TYPE WORD
3331         CAIN    E,$PRECORD
3332          JRST   [ADDI   A,(A)   ; RECORD DOPE WORD IS FULL WORDS (SIGH)
3333                  JRST   (PC)]
3334         CAIN    E,$PVECTOR      ; VECTOR DOPE WORD HAS TWICE LENGTH (SIGH)
3335          JRST   [LSH    D,-1
3336                  HRR    A,D
3337                  JRST   (PC)]
3338         CAIN    E,$PSTRING
3339          JRST   ISWVRS
3340         CAIN    E,$PBYTES
3341          JRST   ISWVRB
3342         JRST    (PC)
3343 ; The byte pointers returned here are NOT standard--they are
3344 ; 440700,,x rather than 010700,,x-1.  This works because everyone
3345 ; deals with them the adjbp and such; it avoids confusion in the
3346 ; sweep phase due to the x-1.
3347 ISWVRS: TLO     B,610000        ; FIXUP STRING POINTER
3348         IMULI   D,5             ; AND TYPE WORD
3349         HRR     A,D             ; SIGH. THIS SEEMS KLUDGY...
3350         JRST    (PC)
3351 ISWVRB: TLO     B,540000
3352         IMULI   D,4
3353         HRR     A,D
3354         JRST    (PC)
3355
3356 RELL:   SKIPN   C,CZONE
3357          XMOVEI C,-GCPOFF+IGCPR
3358         MOVE    C,GCPOFF(C)
3359         MOVE    0,RCLOFF(C)     ; GET FREE LIST POINTER
3360         MOVEM   0,(B)           ; CHAIN FREE LIST
3361         MOVEM   B,RCLOFF(C)     ; UPDATE FREE LIST POINTER
3362         SETZM   1(B)
3363         SETZM   2(B)
3364         JRST    (PC)
3365
3366 RELR:   HRRZ    D,A
3367         LSH     D,-1
3368         ADD     D,B
3369         ADDI    D,1
3370         JSP     OP,RELB
3371         JRST    (PC)
3372
3373 RELU:   LDB     C,[UPTBYT,,A]   ; GET THE PRIMTYPE
3374         JSP     E,@RELUTB(C)    ; POINT D AT THE DOPE WORDS
3375         JSP     OP,RELB         ; RECYCLE THE BLOCK OF STORAGE
3376         JRST    (PC)            ; DON'T WORK EITHER
3377
3378 RELUTB: SETZ    RELUB
3379         SETZ    RELUS
3380         SETZ    RELUU
3381         SETZ    RELUV
3382
3383 RELUB:
3384
3385 RELUS:  HRRZ    C,A             ; GETLENGTH
3386 RELUSX: ADJBP   C,B             ; ADJUST TO THE END
3387         MOVE    D,C             ; ROUND UP
3388         TLZ     D,770000
3389         ADDI    D,2             ; POINT TO SECOND DOPE WORD
3390         JRST    (E)
3391
3392 RELUU:  HRRZ    C,A             ; GET LENGTH
3393 RELUX:  MOVE    D,B             ; POINT TO UVECTOR
3394         ADDI    D,1(C)          ; POINT TO SECOND DOPE WORD
3395         JRST    (E)
3396
3397 RELUV:  HRRZ    C,A             ; GET LENGTH
3398         LSH     C,1             ; TIMES TWO FOR GOOD LUCK
3399         JRST    RELUX           ; REJOIN CODE
3400
3401
3402 ; set the current free storage zone (arg in A and B)
3403 ; if passed 0, return current, if current is zero, return gc params
3404
3405 SETZON: JUMPN   B,SETZN1        ; set it
3406         SKIPE   B,CZONE         ; get current if any
3407          JRST   [MOVE A,[$TZONE,,7]
3408                  JRST   (PC)]
3409         HRRZ    B,IGCPR
3410         HRLI    B,MIMSEC
3411         MOVE    A,[$TUVEC,,GCPL]
3412         JRST    (PC)
3413
3414 SETZN1:
3415 ;       SETZM   INGC                    ; THIS TENDS TO HAPPEN AFTER A GC
3416         SKIPE   ONOISY
3417          JRST   [       HRROI   A,[ASCIZ /OK int soon/]
3418                         PSOUT
3419                         SETZM   ONOISY
3420                         JRST    .+1 ]
3421 IFN FLIP,[
3422         MOVEM   B,@[MIMSEC,,CZONE]
3423         MOVEM   B,@[MIMSEC+1,,CZONE]
3424         MOVE    B,SECL(B)               ; FIRST AREA
3425         MOVE    B,@2(B)                 ; BOUND OF AREA
3426         TLNN    B,1                     ; ODD/EVEN CHECK
3427          JRST   STZSE2
3428         HRLI    TP,EVSEC
3429         HRLI    F,EVSEC
3430         HRLI    P,EVSEC
3431         JRST    (PC)
3432
3433 STZSE2: HRLI    TP,ODDSEC
3434         HRLI    F,ODDSEC
3435         HRLI    P,ODDSEC
3436         JRST    (PC) ]
3437 IFE FLIP,[
3438         MOVEM   B,CZONE
3439         JRST    (PC)
3440 ]
3441
3442 IGCPR:  -GCPL,,RCL
3443
3444 ; HERE IS THE BLOCK STORAGE RECYCLER
3445 ; D POINTS TO THE SECOND DOPE WORD OF THE FROB BEING RECYCLED
3446
3447 ; RCL IS A LIST OF FREE CELLS
3448
3449 GCPOFF==1
3450 GCFCN==3
3451 SECL==11.
3452 RCLOFF==0
3453
3454 RCLTB:  PUSHJ   P,COMPER        ; ZERO LENGTH?
3455         PUSHJ   P,COMPER        ; ONE LENGTH?
3456         XMOVEI  B,RCLV2O(A)
3457         XMOVEI  B,RCLV3O(A)
3458         XMOVEI  B,RCLV4O(A)
3459         XMOVEI  B,RCLVOF(A)
3460         XMOVEI  B,RCLVOF(A)
3461         XMOVEI  B,RCLV7O(A)
3462         XMOVEI  B,RCLV8O(A)
3463         XMOVEI  B,RCLVOF(A)
3464         XMOVEI  B,RCL10O(A)
3465
3466 RELB:   HRRZ    E,-1(D)         ; FIRST GET BLOCK LENGTH
3467         ADDI    E,2
3468         CAIG    E,2
3469          JRST   RELB1           ; JUST DOPE WORDS
3470         MOVE    B,D
3471         SUBI    B,-2(E)         ; ZERO EVERYTHING EXCEPT DOPE WORDS
3472         SETZM   -1(B)
3473         HRLI    B,-1(B)
3474         CAILE   E,3
3475          BLT    B,-2(D)
3476 RELB1:  SKIPN   B,CZONE
3477          XMOVEI B,-GCPOFF+IGCPR
3478         MOVE    A,GCPOFF(B)
3479         CAILE   E,10.
3480          XMOVEI B,RCLVOF(A)
3481         CAIG    E,10.
3482          XCT    RCLTB(E)
3483         TLZ     OP,400000
3484         MOVEI   0,(B)
3485         CAIE    0,RCLVOF(A)
3486          TLO    OP,400000
3487         SKIPN   A,(B)           ; GET THE POINTER TO THE CHAIN
3488          JRST   [MOVEM  D,(B)
3489                  SETZM  (D)
3490                  TLZ    OP,400000
3491                  JRST   (OP) ]
3492         MOVE    A,B             ; START FROM RCLV
3493
3494 RECBL:  MOVE    B,(A)           ; GET POINTER TO NEXT FREE BLOCK
3495         CAML    B,D             ; DOES IT GO HERE?
3496          JRST   RECIN           ; YES. INSERT IT
3497         JUMPE   B,RECIN
3498         MOVE    A,B             ; GO ON TO NEXT FREE BLOCK
3499         JRST    RECBL
3500
3501 RECIN:  TLZE    OP,400000
3502          JRST   RECIN1
3503         MOVE    C,D             ; GET POINTER TO OUR BLOCK
3504         SUB     C,E             ; BACK OFF TO THE TOP
3505         CAMN    C,A             ; DOES IT TOUCH PREVIOUS BLOCK?
3506          JFCL                   ; THIS GETS HAIRY.  MORE CODE TO FOLLOW
3507         MOVE    C,B             ; GET CDR FOR THIS BLOCK
3508         HRRZ    0,-1(B)         ; GET ITS LENGTH+2
3509         ADDI    0,2
3510         SUB     C,0             ; SUBTRACT OFF THE BLOCK
3511         CAMN    C,D             ; DO WE TOUCH ON THE BOTTOM?
3512          JRST   [ADDM   E,-1(B) ; YES. SIMPLY UPDATE LENGTH
3513                  JRST   (OP)]
3514 RECIN1: MOVEM   B,(D)           ; CHAIN THE NEW BLOCK IN
3515         MOVEM   D,(A)
3516         MOVEI   B,$TUVECTOR+$DOPEBIT
3517         HRLM    B,-1(D)         ; MAKE SURE THIS IS A UV
3518         JRST    (OP)
3519
3520 \f
3521 SUBTTL  CORE ALLOCATION
3522
3523 ICELL:  JSP     OP,ICELL1
3524          CAIA
3525         POPJ    P,
3526         MOVEI   A,3             ; # WORDS NEEDED
3527         PUSHJ   P,RUNGC
3528         JRST    ICELL
3529
3530 ; HERE TO THE GARBAGE COLLECTOR FOR THE CURRENT ZONE
3531
3532 RUNGC:  JSP     PC,FRAME
3533         PUSH    TP,$WFIX
3534         PUSH    TP,A
3535         SKIPN   A,CZONE                         ; MUST HAVE A ZONE
3536          HALTF
3537         MOVE    O1,GCFCN(A)
3538         MOVEI   O2,1
3539         JSP     PC,CALLZ
3540         POPJ    P,
3541
3542
3543 IBLOCK: MOVE    E,A
3544         SKIPN   B,CZONE
3545          XMOVEI B,-GCPOFF+IGCPR
3546         MOVE    A,GCPOFF(B)
3547         XMOVEI  B,RCLVOF(A)     ; DEFAULT RCL CHAIN
3548         MOVE    0,GCFLGO(A)     ; IF NO DWS, FUDGE HERE
3549         TLNE    0,$GC%DW
3550          SUBI   E,2
3551 ;       TLNE    0,$GC%PB        ; ONLY EVEN # OF PAGES?
3552 ;        TRNN   E,777
3553 ;         CAIA
3554 ;          JRST COMPERR
3555         CAIG    E,10.
3556          XCT    RCLTB(E)        ; GET POINTER TO CORRECT RCL CHAIN
3557         SKIPN   (B)             ; DON'T BOTHER IF NOTHING'S ON THE CHAIN
3558           JRST  IBLNEW          ; OLD STYLE BLOCK ALLOCATOR
3559         MOVEI   0,(B)
3560         CAIE    0,RCLVOF(A)
3561          JRST   IBLFIX          ; FIXED SIZE OBJECT
3562         MOVE    D,B             ; SETUP BACK POINTER
3563         MOVE    B,(B)           ; GET THE RECYCLE CHAIN ITSELF
3564 IBLCL:  HRRZ    C,-1(B)         ; HOW MUCH STUFF HERE
3565         ADDI    C,2             ; PLUS DOPE WORDS
3566         CAMN    C,E             ; IS THIS AN EXACT MATCH?
3567          JRST   IBLC1           ; YES. DO THE RIGHT THING
3568
3569         CAIL    E,-2(C)         ; CAN IT BE BROKEN UP
3570          JRST   IBLC2           ; NO, KEEP LOOKING
3571
3572         SUBI    C,2(E)          ; C ==> LENGTH OF REMAINDER
3573         HRRM    C,-1(B)         ; STORE IT
3574         CAILE   C,10.           ; SKIP IF MUST PUT IT ON OTHER CHAIN
3575          JRST   IBLC3
3576         MOVE    0,(B)           ; SPLICE IT OUT
3577         MOVEM   0,(D)
3578         SETZM   (B)             ; FLUSH OLD POINTER
3579         PUSH    P,A
3580         PUSH    P,B
3581         PUSH    P,C
3582         PUSH    P,E
3583         PUSH    P,OP
3584         MOVE    D,B
3585         JSP     OP,RELB         ; CALL BLOCK RECYCLER
3586         POP     P,OP
3587         POP     P,E
3588         POP     P,C
3589         POP     P,B
3590         POP     P,A
3591
3592 IBLC3:  SUBI    B,2(C)          ; NEW DW
3593         SUBI    E,2
3594         HRRZM   E,-1(B)         ; DW LENGTH
3595         SETZM   (B)
3596         MOVE    0,GCFLGO(A)     ; GET FLAGS
3597         MOVE    A,B             ; PNTR TO A
3598         SUBI    A,1(E)          ; POINT TO TOP
3599 IBLRET: TLNE    0,$GC%PB        ; REQUIRE PAGE BOUNDARY?
3600          TRNN   A,777
3601           JRST  (PC)            ; NO RETURN
3602         JRST    CMPERR
3603
3604 IBLC2:  MOVE    D,B             ; GET NEW BACK POINTER
3605         SKIPN   B,(B)           ; GET NEXT ENTRY
3606          JRST   IBLNEW          ; END OF CHAIN
3607         JRST    IBLCL           ; LOOP WITH NEW BLOCK
3608
3609 IBLC1:  MOVE    (B)             ; FOUND AN EXACT MATCH
3610         MOVEM   (D)             ; UPDATE CHAIN POINTER
3611         SETZM   (B)             ; CLEAR CHAIN POINTER
3612         MOVE    0,GCFLGO(A)     ; FLAGS
3613         MOVE    A,B
3614         SUBI    A,-1(C)         ; SUBTRACT OFF TO GET TO TOP
3615
3616 IBLPOP:
3617         JRST    (PC)
3618
3619 IBLNEW: MOVE    0,GCSBOF(A)
3620         ADDB    E,GCSBOF(A)
3621         SUBI    E,1
3622         CAMLE   E,GCSMXO(A)
3623          JRST   [ADDI E,1
3624                  SUB E,0
3625                  PUSH P,E
3626                  PUSH P,PC
3627                  MOVEM 0,GCSBOF(A)
3628                  MOVE A,E       ; # WORDS NEEDED
3629                  PUSHJ P,RUNGC
3630                  POP  P,PC
3631                  POP  P,A
3632                  JRST IBLOCK ]                  ; WILL GC
3633         MOVE    A,GCFLGO(A)                     ; RET FLAGS IN 0
3634         EXCH    A,0
3635         JRST    (PC)
3636
3637 IBLFIX: MOVE    0,GCFLGO(A)
3638         MOVE    A,(B)
3639         MOVE    E,(A)
3640         SETZM   (A)
3641         MOVEM   E,(B)
3642         HRRZ    C,-1(A)
3643         SUBI    A,1(C)
3644         JRST    (PC)
3645
3646 $WTCNT: $TYPCNT
3647
3648 \f
3649 SUBTTL  KNOWN RECORD TYPE TABLES
3650
3651 ATMTBL: 5,,$LATOM
3652         $TGBIND,,$LGBIND
3653         0,,11.
3654         $TBIND,,$LBIND
3655         2,,11.
3656         $TSTRING,,$LANY
3657         5,,8.
3658         $TOBLIST,,$LATOM
3659         8,,11.
3660         $TTYPC,,0
3661         4.,,13.
3662
3663 FRMTBL: 8.,,$LFRAME
3664         $TMSUBR,,4
3665         0,,10.
3666         $TFIX,,0
3667         2,,6
3668         $TFIX,,<<0._9.>\18.>
3669         4,,3
3670         $TFIX,,<<18._9.>\18.>
3671         4,,3
3672         $TFRAME,,8.
3673         6,,10.
3674         $TFIX,,<<0._9.>\18.>
3675         8.,,3
3676         $TBIND,,<<18._9.>\18.>
3677         8.,,3
3678         $TFIX,,0
3679         10.,,6
3680
3681 BNDTBL: 6,,$LBIND
3682         $TANY,,$LANY
3683         0,,12.
3684         $TATOM,,$LATOM
3685         4,,11.
3686         $TANY,,$LANY
3687         6,,12.
3688         $TBIND,,$LBIND
3689         10.,,11.
3690         $TBIND,,$LBIND
3691         12.,,11.
3692         $TFIX,,0
3693         14.,,6
3694
3695 GBNTBL: 3,,$LGBIND
3696         $TANY,,$LANY
3697         0,,12.
3698         $TATOM,,$LATOM
3699         4,,11.
3700         $TANY,,$LANY
3701         6,,12.
3702
3703 QFTBL==.                                        ; will build tabel later
3704
3705 $LANY==0
3706 $LATOM==10.
3707 $LFRAME==12.
3708 $LGBIND==10.
3709 $LBIND==16.
3710 \f
3711 SUBTTL  ERROR ROUTINES & UTILITIES
3712
3713 CMPERR: MOVEI   O2,0
3714 CMPER2: SKIPE   O1,ECATM
3715          JRST   CMPER1
3716 CMPERX: HRROI   A,[ASCIZ /Error in Compiled Code
3717 /]
3718         PSOUT
3719         PUSHJ   P,HALTX
3720
3721 CMPER1: PUSH    P,02
3722         JSP     PC,FRAME
3723         JUMPE   O2,CMPER3
3724         PUSH    TP,A
3725         PUSH    TP,B
3726 CMPER3: MOVEI   A,.FHSLF                        ; in case turned off by ill mem
3727         MOVSI   B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
3728         AIC
3729         JSP     PC,CALLZ
3730         POP     P,O2
3731         JUMPE   O2,CMPERR
3732         JRST    RPOPJ
3733
3734 \f
3735 SUBTTL DEBUGGING UTILITIES
3736
3737 ; CALL TO SAVE FROM THE INTERPRETER
3738 ; PASSED:       A/      JFN
3739 ;               B/      0 or pointer-to-pure-zone
3740 ;               C/      0 or pointer-to-frozen-atom-zone
3741
3742 SAVEX:  MOVEM   A,INTSAV'
3743         MOVEM   B,PURZON
3744         MOVEM   C,ATMZON        ; SAVE ZONES IN CASE NEED TO RE-SAVE
3745         TLO     A,400000
3746         CLOSF                   ; LIKE RESTORE, FILE SHOULDN'T BE OPEN...
3747          HALTF
3748         MOVE    E,(P)           ; GET RETURN PC
3749         CAIA
3750
3751 SAV:    SETZM   INTSAV
3752
3753 SAV1:   MOVEI   SAVAC
3754         BLT     SAVAC+17
3755         MOVEI   A,400000
3756         MOVEI   B,4
3757         MOVEI   C,[JRST RST
3758                    JRST [XJRST  [0
3759                                 MIMSEC,,CMPERR] ]
3760                    -1
3761                    JRST RETPUR ]
3762         SKIPE   INTSAV          ; DIFFERENT STARTING ADDRESS FOR .SAVE
3763          MOVEI  C,[JRST RST1
3764                    JRST [XJRST  [0
3765                                 MIMSEC,,CMPERR] ]
3766                    -1
3767                    JRST RETPUR ]
3768         XSVEC
3769         SKIPE   A,INTSAV
3770          JRST   SAV2
3771         HRROI   A,[ASCIZ /Output name: /]
3772         PSOUT
3773         MOVE    A,[GJ%FOU+GJ%SHT+GJ%NEW+GJ%FNS]
3774         MOVE    B,[100,,101]
3775         GTJFN
3776          HALTF
3777 SAV2:                                   ; Special save for multi sect
3778 ; Here to write out multi-sect file
3779 ;
3780 MSSAVE:
3781 ; FORMAT of extended page map for file
3782 ;
3783 ;       even words:     -count,,flags
3784 ;       odd words:      starting job page number
3785 ;
3786         MOVEI   0,SVMAP+6               ; SET UP MAP
3787         MOVEM   0,SVMAPP
3788         SKIPE   O1,CZONE                ; zones set up?
3789          JRST   ZND1                    ;  yes, do it for them
3790
3791         MOVE    O1,GCSBOT               ; get bounds
3792         MOVE    O2,GCSMIN
3793
3794         PUSHJ   P,PMSEC
3795         JRST    ZND3A
3796
3797 ZND1:   MOVE    B,SAVAC+2               ; restore possible pure zone
3798         MOVE    C,SAVAC+3               ;  and atom zone
3799         SKIPN   INTSAV                  ; skip if from user
3800          SETZB  B,C                     ;  otherwise, no pure or atom zones
3801         PUSH    P,B
3802         PUSH    P,C
3803 ZND6:   PUSH    P,SECL(O1)              ; list of section bounds
3804         MOVE    O1,GCPOFF(O1)
3805         PUSH    P,GCSBOF(O1)
3806         PUSH    P,GCSMIO(O1)
3807
3808 ZND2:   SKIPE   E,-2(P)                 ; any more bounds
3809          JRST   ZND4
3810
3811         SKIPN   O1,-3(P)                ; atom zone?
3812          JRST   ZND5
3813         SETZM   -3(P)                   ; dont look again
3814         ADJSP   P,-3                    ; remove old zone
3815         JRST    ZND6
3816
3817 ZND5:   SKIPN   O1,-4(P)
3818          JRST   ZND3
3819         SETZM   -4(P)
3820         ADJSP   P,-3
3821         JRST    ZND6
3822
3823 ZND4:   MOVE    O1,2(E)                 ; pointer to UVEC
3824         MOVE    0,3(O1)                 ; areas flags
3825         MOVE    O2,1(O1)                ; bounds of gcspace
3826         CAMN    O2,(P)                  ; current zone?
3827          JRST   [       MOVE    O2,-1(P)
3828                         MOVEM   O2,(O1)
3829                         JRST    .+1 ]
3830         DMOVE   O1,(O1)
3831         MOVE    E,(E)
3832         MOVEM   E,-2(P)
3833         PUSHJ   P,PMSEC                 ; write it out
3834         JRST    ZND2
3835
3836 PMSEC:  MOVE    B,O2
3837         SUB     B,O1
3838         JUMPE   B,CPOPJ
3839 ;       SUBI    B,777                   ; dividing neg number by shift, so
3840                                         ;   dont' round
3841         ASH     B,9.
3842         HRRI    B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3843         TRNE    0,2                     ; skip if not read-only
3844          HRRI   B,SS%RD+SS%EXE+SS%EPN
3845         MOVE    D,SVMAPP
3846         MOVEM   B,(D)
3847         MOVE    B,O2
3848         LSH     B,-9.
3849         MOVEM   B,1(D)
3850         ADDI    D,2
3851         MOVEM   D,SVMAPP
3852         POPJ    P,
3853
3854 ZND3:   ADJSP   P,-5
3855 ZND3A:  MOVEI   B,STRTTP-777            ; compute pages of stack
3856         SUBI    B,(TP)
3857         ASH     B,9.
3858         HRRI    B,SS%RD+SS%CPY+SS%EXE+SS%EPN
3859         MOVE    D,SVMAPP
3860         MOVEM   B,(D)
3861         MOVEI   B,<TPSEC_9.>+<STRTTP_-9.>       ; add in core page for stack
3862         MOVEM   B,1(D)
3863         SETZM   2(D)
3864
3865 ; now write out the actual cruft
3866
3867         HRLI    A,400000
3868         MOVEI   B,SVMAP
3869         MOVEI   C,0
3870         SSAVE
3871          ERJMP  SAVLOS
3872         SKIPN   INTSAV
3873          JRST   [       HALTF           ; give chance to save symbols
3874                         JRST    RST2 ]
3875         MOVE    A,$WFIX
3876         MOVEI   B,0
3877         POPJ    P,
3878 SAVLOS: SKIPN   INTSAV
3879          JRST   [HRROI  A,[ASCIZ /?/]
3880                  ESOUT
3881                  MOVEI  A,.PRIOU
3882                  MOVE   B,[.FHSLF,,-1]
3883                  MOVEI  C,0
3884                  ERSTR
3885                   JFCL
3886                   JFCL
3887                  HALTF]
3888         MOVEI   A,.FHSLF
3889         GETER
3890         HRRZ    A,B
3891         PUSHJ   P,RETERR                        ; return a false with error code
3892         POPJ    P,
3893
3894 RST:    SETZM   INTSAV
3895 RST1:
3896 IFN <MIMSEC-TPSEC>,[
3897         MOVEI   A,0
3898         MOVE    B,[.FHSLF,,MIMSEC]              ; create brand new section
3899         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]  ; bits for mapping
3900         SMAP%
3901 ]
3902         MOVE    D,[.FHSLF,,1]
3903 RMAPLP: MOVE    A,D
3904         RMAP
3905         TLZN    B,(RM%PEX)
3906          JRST   RNXTMP
3907         MOVSI   C,(PM%RD+PM%WR+PM%EX)
3908         MOVE    A,D
3909         MOVE    B,D
3910         ADDI    B,<MIMSEC_9.>
3911         PMAP
3912 IFN FLIP,[
3913         MOVSI   C,(PM%RD+PM%WR+PM%EX)
3914         MOVE    A,D
3915         MOVE    B,D
3916         ADDI    B,<<MIMSEC+1>_9.>
3917         PMAP
3918 ]
3919 RNXTMP: ADDI    D,1
3920         CAME    D,[.FHSLF,,1000]
3921          JRST   RMAPLP
3922 IFN FLIP,[
3923         MOVE    A,[.FHSLF,,<<TPSEC_9>+<STRTTP_<-9>>>]
3924         MOVE    B,A
3925         ADDI    B,1000
3926         MOVSI   C,(PM%RD+PM%WR+PM%EX+PM%CNT)
3927         HRRI    C,1000-<STRTTP_<-9>>
3928         PMAP
3929 ]
3930 RSTTPD: MOVE    0,CURSIZ
3931         LSH     0,-1
3932 ;       MOVEI   0,<<NUMSEC+INIGC>_<-1>>
3933         MOVE    A,[.FHSLF,,1000]
3934 IFN FLIP,MOVE   B,[.FHSLF,,3000]
3935 IFE FLIP,MOVE   B,[.FHSLF,,2000]
3936         MOVSI   C,(PM%RD+PM%WR+PM%EX)
3937
3938 RSTX:   HRRI    A,1000
3939         PMAP
3940 IFN FLIP,[
3941         ADDI    B,1000
3942         HRRI    A,2000
3943         PMAP
3944 ]
3945         ADDI    B,1000
3946         SOJG    0,RSTX
3947
3948 RST2:   MOVSI   SAVAC
3949         BLT     17
3950         PUSHJ   P,INTON
3951         MOVSI   SAVAC
3952         BLT     17
3953         MOVE    O1,B
3954         XJRST   [0
3955                  MIMSEC,,.+1]
3956         ADJSP   P,-1
3957
3958         MOVEI   A,.FHSLF
3959         MOVEI   B,2             ; CODE FOR SETUP OF UUO TABLE
3960         MOVE    C,[MIMSEC,,MLTUUP]
3961         SWTRP%
3962
3963         MOVE    A,[TPWARN_9]
3964         MOVES   (A)
3965         MOVES   <<TPENDP-TPWARN>_9>(A)
3966         ADD     A,[1,,]
3967         MOVES   (A)
3968         MOVES   <<TPENDP-TPWARN>_9>(A)
3969         MOVSI   A,(SETZ)
3970         HRRI    A,TPENDP
3971         MOVSI   B,0
3972         SPACS
3973         MOVSI   A,(SETZ)
3974         HRRI    A,TPWARN
3975         MOVSI   B,0
3976         SPACS
3977 IFN FLIP,[
3978         MOVSI   A,(SETZ)
3979         HRRI    A,TPENDP+1000
3980         MOVSI   B,0
3981         SPACS
3982         MOVSI   A,(SETZ)
3983         HRRI    A,TPWARN+1000
3984         MOVSI   B,0
3985         SPACS
3986 ]
3987         SKIPE   INTSAV
3988          JRST   [MOVE   A,$WFIX
3989                  MOVEI  B,1
3990                  JRST   (E)]
3991         PUSH    P,PC
3992         JSP     PC,FRAME
3993         POP     P,PC
3994         MOVEI   O2,0
3995         JRST    CALLR
3996
3997 ; RESTORE CALLED FROM MUM
3998 ; TAKES JFN IN ACCUMULATOR A
3999
4000 RESTOR: MOVE    D,A
4001         MOVNI   A,1
4002         MOVE    B,[.FHSLF,,TPWARN]
4003         MOVE    C,[PM%CNT\<<TPENDP-TPWARN>+1>]  ; unmap end-of-stack warning
4004         PMAP
4005 IFN FLIP,[
4006         MOVE    B,[.FHSLF,,<TPWARN+1000>]
4007         MOVE    C,[PM%CNT\<<TPENDP-TPWARN>+1>]
4008         PMAP
4009 ]
4010         MOVNI   A,1
4011         MOVE    B,[SETZ INIGC]  ; FLUSH MANY SECTIONS
4012         MOVE    C,CURSIZ
4013         SMAP%                   ; FLUSH LOTS OF STUFF
4014         MOVE    A,D             ; RESTORE CHANNEL
4015         SETOM   INTSAV          ; CALLED FROM MUM
4016         TLO     A,400000        ; KEEP THE JFN
4017         CLOSF                   ; FOR REASONS KNOWN ONLY TO GOD, AND
4018          HALTF                  ; I EVEN DOUBT THAT, THE FILE CAN'T
4019         HRLI    A,.FHSLF        ; BE OPEN WHEN A GET IS DONE.  SIGH.
4020         MOVE    C,[GET]
4021         MOVE    D,[MOVEI A,.FHSLF]
4022         MOVE    E,[XGVEC]
4023         MOVE    OP,[JRST @C]
4024         JRST    C
4025
4026 ; Take fix or false in A/B.  If false, return first GC sec,,# GC secs;
4027 ; otherwise, set.
4028 SETSIZ: PUSH    P,C
4029         LDB     C,[TYPWRD,,A]
4030         CAIE    C,$TFALSE
4031          JRST   SETSZ1
4032 SETSZD: MOVSI   A,$TFIX
4033         MOVE    B,CURSIZ
4034         HRLI    B,INIGC
4035 SETSZ0: POP     P,C
4036         POPJ    P,
4037 SETSZ1: MOVEM   B,CURSIZ
4038         JRST    SETSZ0
4039
4040 DFATAL: PUSH    TP,A
4041         PUSH    TP,B
4042         PUSH    P,C
4043         HRROI   A,[ASCIZ /Fatal error--/]
4044         ESOUT
4045         MOVEI   A,.PRIOU
4046         POP     TP,B
4047         POP     TP,C
4048         TLZ     C,-1
4049         MOVNS   C
4050         SOUT
4051         POP     P,C
4052         HALTF
4053         JRST    (PC)
4054
4055 QUIT:   HALTF
4056         POPJ    P,
4057
4058 TRACIN: PUSH    P,A
4059         PUSH    P,B
4060         PUSH    P,C
4061         PUSH    P,D
4062         PUSHJ   P,TRACSP
4063         MOVEI   A,">
4064         PBOUT
4065         DC
4066         HRROI   A,[ASCIZ / (/]
4067         PSOUT
4068         MOVE    A,(O1)
4069         MOVE    A,1(A)
4070         MOVE    B,1(A)
4071         MOVE    B,(B)
4072         MOVE    B,1(B)
4073         MOVE    B,1(B)
4074         ADD     B,7(A)
4075         MOVE    A,$WFIX
4076         PUSHJ   P,UPDISP
4077         HRROI   A,[ASCIZ /.) [/]
4078         PSOUT
4079         MOVE    C,O2                    ; # OF ARGUMENTS
4080         MOVE    D,C
4081         LSH     C,1
4082         SUBM    TP,C                    ; POINT THERE
4083 TRACA:  SOJL    D,TRACB
4084         DMOVE   A,1(C)
4085         PUSH    P,C
4086         PUSH    P,D
4087         PUSHJ   P,UPDISP
4088         POP     P,D
4089         POP     P,C
4090         ADDI    C,2
4091         MOVEI   A,40
4092         PBOUT
4093         JRST    TRACA
4094
4095 TRACB:  AOS     TRACL
4096         AOS     TRACL
4097         MOVEI   A,"]
4098         PBOUT
4099         SKIPE   A,TRACTM
4100         DISMS
4101 TRACEX: MOVEI   A,^M
4102         PBOUT
4103         MOVEI   A,^J
4104         PBOUT
4105         POP     P,D
4106         POP     P,C
4107         POP     P,B
4108         POP     P,A
4109         POPJ    P,
4110
4111 TRACOU: SOS     TRACL
4112         SOS     TRACL
4113         PUSH    P,A
4114         PUSH    P,B
4115         PUSH    P,C
4116         PUSH    P,D
4117         PUSHJ   P,TRACSP
4118         MOVEI   A,"<
4119         PBOUT
4120         MOVEI   A,40
4121         PBOUT
4122         DMOVE   A,-3(P)
4123         PUSHJ   P,UPDISP
4124         JRST    TRACEX
4125
4126 TRACSP: MOVEI   A,40
4127         MOVE    B,TRACL
4128         SOJL    B,CPOPJ
4129         PBOUT
4130         JRST    .-2
4131
4132 \f
4133
4134 SVMAPP: SVMAP
4135 SVMAP:  -ENDPG,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4136         0
4137         -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4138         <MIMSEC_9>
4139         -1,,SS%CPY+SS%RD+SS%EXE+SS%EPN
4140         <<MIMSEC+1>_9>
4141         BLOCK   30.
4142
4143
4144 \f
4145 SUBTTL INTERRUPT HANDLER
4146
4147 LEVTAB: 0,,PCLEV1
4148         0,,PCLEV2
4149         0
4150
4151 CHNTAB: REPEAT  36.,[   2,,CHNS+<.RPCNT*2>
4152                         ]
4153
4154 CHNS:   REPEAT  36.,[   PUSH    P,[.RPCNT]
4155                         JRST    CHNSRV
4156                         ]
4157
4158 CHNSRV: EXCH    A,(P)
4159         PUSH    P,B
4160         PUSH    P,C
4161         CAIE    A,PREAD
4162          CAIN   A,PWRIT                         ; have we touched "magic" page
4163           JRST  STKCHK
4164         MOVEI   B,1
4165         MOVEI   C,35.
4166         SUB     C,A
4167         LSH     B,(C)
4168         MOVE    C,@[MIMSEC,,INTFLG]
4169 IFN FLIP,[
4170         IORM    B,@[MIMSEC,,INTFLG]
4171         IORM    B,@[MIMSEC+1,,INTFLG]
4172 ]
4173 IFE FLIP,       IORM    B,INTFLG
4174         AND     C,B
4175         HRRZ    A,PCLEV2
4176         CAIN    A,RRESTA
4177          JRST   CHNS1
4178         CAME    B,CTLGCH
4179          CAMN   B,CTLACH
4180           CAIA
4181            JRST CHNS3
4182         SKIPE   INGC
4183          JRST   [       SKIPN   NOISY
4184                          JRST   CHNS3
4185                         HRROI   A,[ASCIZ /GCing--please wait../]
4186                         PSOUT
4187                         SETOM   ONOISY
4188                         JRST    CHNS3 ]
4189         AOS     C,CTLGS                         ; how many successive ^G or ^As
4190         CAIGE   C,3                             ; if more than 5, int anyway
4191          JRST   CHNS3
4192
4193         HRROI   A,[ASCIZ /Forced interrupt, here's hoping...
4194 /]
4195         PSOUT
4196
4197         SETZM   CTLGS
4198         POP     P,C
4199         POP     P,B
4200         POP     P,A
4201         JRST    CHNS41
4202
4203 CHNS3:  POP     P,C
4204         POP     P,B
4205         POP     P,A
4206         SKIPGE  PCLEV2                          ; REALLY DEBRK?
4207          JRST   [       EXCH    A,PCLEV2
4208                         TLZ     A,400000
4209                         EXCH    A,PCLEV2
4210                         JRST    @PCLEV2 ]
4211         SKIPN   RUNINT
4212          DEBRK
4213 ; Come here when interrupts enabled
4214         EXCH    A,@LEVTAB+1
4215         TLNN    A,10000                         ; Test for user mode
4216          JRST   CHNS4
4217         EXCH    A,@LEVTAB+1
4218         DEBRK
4219 CHNS4:  EXCH    A,@LEVTAB+1
4220 CHNS41: PUSHJ   P,SAVALL
4221         XMOVEI  B,CHNS5
4222         DMOVEM  A,@LEVTAB+1
4223         DEBRK                   ; Leave int level, go to rest of handler
4224 CHNS5:  PUSHJ   P,RINTGO        ; Process interrupts
4225 CHNS52: SUBM    R,-1(TP)        ; Get real PC back
4226         SOS     A,-1(TP)        ; Back it up
4227         HRRZ    C,(A)
4228         LDB     B,[331100,,(A)] ; Get opcode
4229         SKIPN   -12.(TP)        ; skip if from JSYS
4230          AOJA   A,CHNS51
4231         CAIE    B,104           ; Not JSYS; assume XCT 0
4232          HRRZ   C,-11.(TP)
4233         ADDI    A,1
4234         CAIE    C,BIN
4235          JRST   CHNS51
4236         PUSH    P,A
4237         MOVEI   A,.FHSLF
4238         MOVEI   B,IOX4          ; Return with error code
4239         SETER
4240         POP     P,A
4241         MOVE    A,(A)           ; Get ERJMP instruction
4242         TLZ     A,777760
4243         TLO     A,400000
4244         XMOVEI  A,@A            ; Get address of error routine
4245 CHNS51: PUSH    P,A
4246 RSTALL: MOVE    0,-15(TP)       ; saved CZONE
4247         CAME    0,CZONE         ; no, change -- no GC
4248          SKIPE  -14(TP)
4249           CAIA                  ; here if either no GC, or doesn't matter
4250            JRST [               HRROI   A,[ASCIZ /GC has occurred, you may lose..
4251 /]
4252                                 PSOUT
4253                                 JRST .+1
4254 ]
4255         MOVE    O2,-2(TP)
4256         MOVE    O1,-3(TP)
4257         MOVE    PC,-4(TP)
4258         MOVE    OP,-5(TP)
4259         MOVE    E,-6(TP)
4260         MOVE    D,-7(TP)
4261         MOVE    C,-10(TP)
4262         MOVE    B,-11(TP)
4263         MOVE    A,-12(TP)
4264         MOVE    0,-13(TP)
4265         SKIPE   -14(TP)
4266          SETOM  RUNINT          ; Re-enable interrupts
4267         ADJSP   TP,-18.
4268         POPJ    P,              ; Back into code
4269
4270 CHNS1:  MOVEI   B,CHNS2
4271         HRRM    B,PCLEV2        ; Go back to section originally in
4272         JRST    CHNS3
4273
4274 SAVALL: PUSH    TP,[$TUVEC+$FRMDO,,16.]
4275         ADDI    TP,3
4276         PUSH    TP,CZONE
4277         PUSH    TP,RUNINT
4278         SETZM   RUNINT
4279         PUSH    TP,0
4280         PUSH    TP,A
4281         PUSH    TP,B
4282         PUSH    TP,C
4283         PUSH    TP,D            ; Save ACs for system call
4284         PUSH    TP,E
4285         PUSH    TP,OP
4286         PUSH    TP,PC
4287         PUSH    TP,O1
4288         PUSH    TP,O2
4289         DMOVE   A,@LEVTAB+1
4290         PUSH    TP,B
4291         PUSH    TP,[$TUVEC+$FRMDO,,16.]
4292         SUBM    R,-1(TP)        ; Save rel PC
4293         POPJ    P,
4294
4295 ; come here when interrupt out of TEXTI.  Everything needed for TEXTI
4296 ; except .rddbp and .rddbc is on tp; those two can be computed.
4297 CHNS2:  PUSH    TP,$WFIX
4298         PUSH    TP,IRDBLK+.RDDBC        ; SAVE BYTE COUNT
4299         PUSHJ   P,RINTGO                ; HACK INTERRUPTS
4300         MOVE    A,-20(TP)               ; PROMPT
4301         MOVEM   A,IRDBLK+.RDRTY
4302         MOVEI   A,IRDBRK
4303         SKIPE   -16(TP)
4304          MOVEI  A,ARDBRK
4305         MOVE    B,-10(TP)
4306         MOVEM   B,(A)
4307         MOVE    B,-6(TP)
4308         MOVEM   B,1(A)
4309         MOVE    B,-4(TP)
4310         MOVEM   B,2(A)
4311         MOVE    B,-2(TP)
4312         MOVEM   B,3(A)                  ; GET BREAKS SET UP
4313         MOVEM   A,IRDBLK+.RDBRK         ; Restore right word
4314         MOVE    A,-14(TP)               ; JFN WORD
4315         MOVEM   A,IRDBLK+.RDIOJ
4316         MOVE    A,-12(TP)               ; ORIGINAL STRING
4317         MOVEM   A,IRDBLK+.RDBFP
4318         MOVEM   A,IRDBLK+.RDBKL
4319         HRRZ    B,-13(TP)
4320         SUB     B,(TP)                  ; # CHARS USED
4321         ADJBP   B,A                     ; POINT TO EMPTY PAART
4322         MOVEM   B,IRDBLK+.RDDBP
4323         MOVE    B,(TP)
4324         MOVEM   B,IRDBLK+.RDDBC         ; SPACE REMAINING
4325         ADJSP   TP,-2
4326         JRST    BRESTA                  ; FALL BACKK INTO TEXTI
4327
4328 INTGO:  HALTF
4329
4330 INTGOC: SKIPE   INGC                    ; DONT INTERRUPT POOR GC
4331          POPJ   P,
4332         SETZM   CTLGS
4333         PUSH    TP,$WFIX
4334         PUSH    TP,(P)
4335         PUSH    TP,$WFIX
4336         PUSH    TP,D
4337         PUSH    TP,$WFIX
4338         PUSH    TP,O2
4339 IFN FLIP,[
4340         PUSH    TP,$WFIX
4341         PUSH    TP,@[MIMSEC,,NARGS]
4342         PUSH    TP,$WFIX
4343         PUSH    TP,@[MIMSEC+1,,NARGS]
4344 ]
4345 IFE FLIP,[
4346         PUSH    TP,$WFIX
4347         PUSH    TP,NARGS
4348 ]
4349         PUSHJ   P,RINTGO
4350 IFN FLIP,[
4351         POP     TP,@[MIMSEC+1,,NARGS]
4352         ADJSP   TP,-1
4353         POP     TP,@[MIMSEC,,NARGS]
4354         ADJSP   TP,-1
4355 ]
4356 IFE FLIP,[
4357         POP     TP,NARGS
4358         ADJSP   TP,-1
4359 ]
4360         POP     TP,O2
4361         ADJSP   TP,-1
4362         POP     TP,D
4363         ADJSP   TP,-1
4364         POP     TP,(P)
4365         ADJSP   TP,-1
4366         POPJ    P,
4367
4368 RINTGO: PUSH    TP,$WFIX
4369         PUSH    TP,(P)
4370
4371 INTLP:  SETZM   CTLGS
4372         MOVE    A,INTFLG
4373         JFFO    A,INTL1
4374         POP     TP,(P)
4375         ADJSP   TP,-1
4376         POPJ    P,
4377
4378 INTL1:  MOVEI   A,36.
4379         SUB     A,B
4380         MOVEI   C,1
4381         LSH     C,-1(A)
4382 IFN FLIP,[
4383         ANDCAM  C,@[MIMSEC,,INTFLG]
4384         ANDCAM  C,@[MIMSEC+1,,INTFLG]
4385 ]
4386 IFE FLIP,       ANDCAM  C,INTFLG                ; AND CLEAR IT
4387 INTL2:  JSP     PC,FRAME
4388         PUSH    TP,$WFIX
4389         PUSH    TP,B
4390         MOVE    O1,ICATM
4391         MOVEI   O2,1
4392         JSP     PC,CALLZ
4393         JRST    INTLP
4394
4395 INTINI: MOVE    A,[-36.,,CHNTAB]
4396         HLRZ    0,(A)
4397         LSH     0,12.                           ; move level over
4398         IORI    0,MIMSEC                        ; cause it to run int MIM
4399         HRLM    0,(A)
4400         AOBJN   A,.-4
4401
4402         MOVEI   0,MIMSEC
4403         HRLM    0,LEVTAB                        ; also mung LEVTAB
4404         SOS     LEVTAB
4405         HRLM    0,LEVTAB+1
4406         SOS     LEVTAB+1
4407         HRLM    0,LEVTAB+2
4408
4409 INTON:  SETZM   ATICNM
4410         MOVEI   A,.FHSLF
4411         MOVEI   B,[     3
4412                         LEVTAB
4413                         CHNTAB ]
4414         XSIR%                                   ; enable ints
4415         EIR
4416 PWRIT==17.                                      ; Bit for page write int
4417 PREAD==16.
4418 INFINT==19.                                     ; bit for inferior interrupt
4419         MOVEI   A,.FHSLF
4420         MOVSI   B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
4421         TRO     B,<SETZ>_<-INFINT>
4422         AIC                                     ; Activate the int
4423         POPJ    P,
4424 \f
4425 ;Here to see if illegal page access is really stack overflow
4426
4427 STKCHK: XMOVEI  B,1(TP)                 ; lets see which page
4428         LSH     B,-9                    ; to page number
4429         CAIE    B,TPWARN+1000
4430          CAIN   B,TPWARN                ; warning page?
4431           JRST  [MOVSI  A,(SETZ)
4432                  HRRI   A,TPWARN
4433                  MOVSI  B,(PA%RD+PA%EX+PA%WT)
4434                  SPACS
4435                  HRRI   A,TPWARN+1000
4436                  SPACS
4437                  MOVE   A,[JRST @PNTSTK]
4438                  MOVEM  A,STKMNG
4439                  MOVEM  A,@[MIMSEC+1,,STKMNG]
4440                  JRST   CHNS3 ]
4441
4442         HRROI   A,[ASCIZ /Fatal error:  stack overflow
4443 /]
4444         CAIE    B,TPENDP+1000
4445          CAIN   B,TPENDP
4446           CAIA
4447            JRST CNLOSE
4448         PSOUT
4449         POP     P,C
4450         POP     P,B
4451         POP     P,A
4452         JRST    HALTX
4453
4454 MONBIT==100
4455
4456 CNLOSE:
4457 ;       MOVEI   A,.FHSLF
4458 ;       PUSH    P,[3]
4459 ;       XMOVEI  B,(P)
4460 ;       PUSH    P,[0]
4461 ;       PUSH    P,[0]
4462 ;       XGTPW%                                  ; get info about lossage
4463 ;       MOVE    C,(P)                           ; get address
4464 ;       TLNE    C,MONBIT                        ; monitored?
4465 ;        JRST   DOMON                           ; yes, handle it, else lose
4466         PUSH    P,D                             ; need more regs
4467         PUSH    P,E
4468         PUSH    P,OP
4469         DMOVE   A,@LEVTAB+1                     ; get instruction
4470         PUSHJ   P,EFFADR
4471         LDB     D,[331100,,A]                   ; and opcode
4472         TLZE    E,MONBIT                        ; is it monitored
4473          JRST   NOTBP
4474         CAIL    D,134                           ; see if a bp ins
4475          CAILE  D,137
4476           JRST  REALER                          ; this is a real lossage
4477
4478         SKIPG   A,(E)                           ; get byte pointer (skip if
4479                                                 ;                   local)
4480          CAMG   A,[450000,,0]                   ; skip if global
4481           JRST  [       MOVE    B,E
4482                         PUSHJ   P,EFFADR        ; treat like ins
4483                         JRST    GBPTR1 ]
4484         MOVE    B,E                             ; point to where BP is
4485         MOVE    E,A
4486 GBPTR1: TLZN    E,MONBIT
4487          JRST   REALER
4488         SKIPN   INGC
4489          JRST   MONIT                           ; not int GC, cause monitor
4490         MOVE    A,@PCLEV2+1                     ; get ins
4491         TLON    A,1000                          ; skip if no incr
4492          IBP    (B)                             ; ok
4493 NOTBP:  SKIPN   INGC
4494          JRST   MONIT
4495 NOTBP1: TLZ     A,37                            ; kill index etc.
4496         MOVEM   E,INSEFF
4497         HRRI    A,INSEFF
4498         TLO     A,20
4499         MOVEM   A,INSDO                         ; set up to do ins
4500         AOS     A,PCLEV2                        ; get pc
4501         TLZ     A,400000
4502         MOVEM   A,INSRE1
4503         ADDI    A,1
4504         MOVEM   A,INSRE2
4505         XMOVEI  B,INSDO
4506         SKIPGE  PCLEV2
4507          TLO    B,400000
4508         MOVEM   B,PCLEV2
4509         JRST    GCNT
4510
4511 REALER: MOVSI   B,(<<SETZ>_<-PREAD>>+<<SETZ>_<-PWRIT>>)
4512         MOVEI   A,.FHSLF
4513         DIC                                     ; turn of interrupt
4514 GCNT:   POP     P,OP                            ; need more regs
4515         POP     P,E
4516         POP     P,D
4517         JRST    CHNS3
4518
4519 MONIT:  POP     P,OP
4520         EXCH    E,(P)
4521         EXCH    D,-1(P)
4522         EXCH    C,-2(P)
4523         EXCH    B,-3(P)
4524         EXCH    A,-4(P)
4525         PUSHJ   P,SAVALL
4526         POP     P,-16(TP)                       ; save monitored address
4527         SUBI    P,3
4528         POP     P,-17(TP)
4529 ;       MOVE    A,PCLEV2
4530 ;       MOVEM   A,-20(TP)
4531         XMOVEI  A,MONIT1                        ; here to trigger monitor
4532         MOVEM   A,PCLEV2                        ; set to disable ints
4533         DMOVE   A,-17(TP)                       ; leave funny in A
4534         DEBRK
4535
4536 MONIT1: JSP     PC,FRAME
4537         PUSH    TP,$WFIX
4538         PUSH    TP,A
4539         PUSH    TP,$WFIX
4540         PUSH    TP,B
4541         MOVE    O1,ICATM
4542         MOVEI   O2,2
4543         JSP     PC,CALLZ
4544         PUSH    P,-1(TP)
4545         PUSH    P,-16(TP)
4546         PUSH    P,-17(TP)
4547         PUSHJ   P,RSTALL
4548         EXCH    A,-2(P)
4549         EXCH    B,-1(P)
4550         EXCH    C,(P)
4551         PUSH    P,D
4552         PUSH    P,E
4553         PUSH    P,OP
4554         SUBM    R,A
4555         TLO     A,400000                        ; SO WE DONT DEBRK
4556         MOVEM   A,PCLEV2
4557         MOVE    E,B
4558         MOVE    A,C
4559         JRST    NOTBP1
4560
4561 MONIT2:
4562
4563 ; Compute effective address
4564 ;       B/              pc of ins
4565
4566
4567 EFFADR: MOVE    A,(B)                           ; get ins
4568         HRRE    E,A
4569         LDB     D,[220400,,A]                   ; get index
4570         MOVEI   OP,0                            ; indirect?
4571         TLNE    A,20
4572          MOVEI  OP,1                            ; yes
4573
4574         PUSH    P,A
4575         HRRES   E               ; make negative offsets work
4576
4577 EFF1:   JUMPE   D,EFF2          ; jump if no index field
4578
4579         CAIG    D,OP            ; reg on stack?
4580          ADDI   D,-8.(P)
4581         SKIPN   D,(D)           ; get its contents
4582          JRST   EFF2            ; zero in index, ignore
4583
4584         TLNE    D,-1            ; skip if rh only (local index)
4585          JUMPG  D,EFF3          ; jump if global index
4586
4587         ADD     E,D             ; do local indexing
4588         ANDI    E,-1            ; but prevent overflowing
4589         JRST    EFF2
4590
4591 EFF3:   ADD     E,D             ; add global index
4592
4593 EFF2:   CAIGE   E,17            ; AC?
4594          JRST   EFF6
4595         TLNN    E,400000        ; negative addr also get current section
4596          TLNN   E,-1            ; skip if section already here
4597           HLL   E,B             ; use PC section
4598
4599 EFF6:   JUMPE   OP,EFF5         ; no indirection, leave
4600
4601         PUSHJ   P,GETVAL        ; get indirect word
4602
4603         JUMPGE  A,EFF7          ; jump if global ind
4604
4605         LDB     D,[220400,,A]   ; get index field
4606         TLNN    A,20            ; skip if indirect
4607          MOVEI  OP,0            ; turn it on
4608         HRRE    E,A             ; keep original section with new address
4609         JRST    EFF1            ; loop back
4610
4611 EFF7:   LDB     D,[360400,,A]
4612         TLNN    A,200000        ; global indirect bit?
4613          MOVEI  OP,0
4614         TLZ     A,770000        ; kill index and indirect
4615         MOVE    E,A
4616         JRST    EFF1
4617
4618 EFF5:   POP     P,A
4619         POPJ    P,
4620
4621 ; here to extract value
4622
4623 GETVAL: TLZ     E,MONBIT
4624         CAIG    E,OP            ; skip if register
4625          ADDI   E,-9.(P)
4626         TLZ     E,777740
4627         MOVE    A,(E)           ; get word
4628         POPJ    P,
4629
4630
4631 DOMON:  JFCL
4632 STKERR:
4633 IFE FLIP&0,[    MOVE    0,[JRST @D]]
4634 IFN FLIP&0,[    MOVE    0,[TLNN M,1]]
4635         MOVEM   0,STKMNG
4636         MOVEM   0,@[MIMSEC+1,,STKMNG]
4637         MOVE    0,[JRST @PNTRET]                ; CHANGE INS IN RETURN
4638         MOVEM   0,RET3
4639         MOVEM   0,@[MIMSEC+1,,RET3]
4640         MOVEI   O2,1
4641         MOVE    A,$WFIX
4642         MOVEI   B,0
4643         JRST    CMPER2
4644
4645 \f
4646 SUBTTL DEBUGGING UUOS
4647
4648 ZZZ==.
4649 LOC 40
4650         0
4651         JSR UUOH
4652 LOC ZZZ
4653
4654 UUOCT==0
4655 UUOTAB: SETZ ILUUO
4656         IRPS X,,[FRM DP DC TON TOFF EX GVERR MADJBP]
4657         UUOCT==UUOCT+1
4658         X==UUOCT_33
4659         SETZ  U!X
4660         TERMIN
4661
4662 UUOMAX==.-UUOTAB
4663 MLTUOP: PUSH    P,MLTUUP
4664         PUSH    P,MLTPC
4665         JRST    UUOSAV
4666
4667 UUOH1:  PUSH    P,UUOH
4668
4669 ; Here if in multi-section mode but running a section 0 uuo
4670
4671         EXCH    0,(P)                   ;GET PC AND SAVE 0
4672         HRRZM   0,MLTPC
4673         HLLZM   0,MLTUUP
4674         MOVE    0,40
4675         HRRZM   0,MLTEA
4676         HLRM    0,MLTUUP
4677         POP     P,0
4678         XJRST   .+1
4679                 0
4680                 MIMSEC,,MLTUOP
4681
4682 UUOSAV: PUSH    P,
4683         PUSH    P,A
4684         PUSH    P,B
4685         PUSH    P,C
4686         PUSH    P,D
4687         MOVE    @UUOE
4688         MOVEM   UUOD'                   ; CONTENTS OF EFF ADR
4689         MOVE    B,UUOE                  ; EFF ADR
4690         LDB     A,[050400,,MLTUUP]      ; GET UUO AC,
4691         LDB     C,[110400,,MLTUUP]      ; AND OPCODE
4692         JRST    UUODSP
4693
4694 UUODS1: LDB     A,[270400,,40]          ; GET UUO AC,
4695         LDB     C,[330600,,40]          ; OP CODE
4696 UUODSP: CAIL    C,UUOMAX
4697         MOVEI   C,0     ; GRT=>ILLEGAL
4698         JRST    @UUOTAB(C)      ; GO TO PROPER ROUT
4699
4700 UUORET: POP     P,D
4701         POP     P,C
4702         POP     P,B
4703         POP     P,A             ; RESTORE AC'S
4704 UUORT1: POP     P,
4705         POP     P,MLTPC
4706         POP     P,MLTUUP
4707         XJRST   MLTUUP
4708
4709 ILUUO:  HALTF
4710
4711 ; KLUDGE TO DO ADJBP GIVEN MICROCODE BUG
4712 UMADJBP:
4713         CAILE   A,D             ; CHECK AC ARG
4714          JRST   ADJB2           ; Not pushed, so continue
4715         SUBI    A,D             ; Make A point to stack slot
4716         ADD     A,P
4717 ADJB2:  MOVE    C,(A)           ; PICK UP AC
4718         IBP     C,UUOD          ; Do the IBP
4719         TLNE    C,770000        ; Skip if lost
4720          JRST   ADJBO
4721         AOS     BUGS            ; Count it
4722         JRST    ADJB2           ; And try again
4723 ADJBO:  MOVEM   C,(A)           ; Won, stuff bp out
4724         JRST    UUORET          ; And return
4725
4726 UGVERR: SUBM    R,-5(P)         ; RELATIVE RETURN PC
4727         SKIPN   O1,ECATM
4728          JRST   CMPER2
4729         JSP     PC,FRAME
4730         PUSH    P,O2
4731         CAIGE   B,20            ; IF EA IS REGISTER, HACK IT
4732          JRST   [               PUSH    TP,[$TGVAL,,$LATOM]
4733                                 CAIG    B,D
4734                                  JRST   [       ADDI    B,-4(P)
4735                                                 HLL     B,P
4736                                                 JRST    UGVER1 ]
4737                                 HRLI    B,1
4738                                 JRST    UGVER1 ]
4739         MOVE    0,-1(B)         ; CHANGE ATOM TO GVAL
4740         CAME    0,[$TGBIND,,$LGBIND]
4741          MOVE   0,[$TGVAL,,$LATOM]
4742         PUSH    TP,0            ; PUSH GBIND POINTER OR ATOM POINTER
4743 UGVER1: PUSH    TP,(B)
4744         MOVEI   O2,1
4745         JSP     PC,CALLZ        ; CALL EICC
4746         POP     P,O2
4747         ADJSP   P,-4            ; PRESERVE NEW CONT. OF A AND B
4748         SUBM    R,-1(P)
4749         AOS     -1(P)           ; SKIP RETURN
4750         JRST    UUORT1
4751
4752 UFRM:   SKIPGE  (F)
4753          JRST   [HRRZ   C,-1(F)
4754                  SUBI   C,FR.OFF
4755                  XHLLI  C,(F)
4756                  JRST   .+2]
4757         XMOVEI  C,-FR.OFF(F)
4758         SETO    D,
4759 UFRML:  AOJ     D,
4760         MOVE    B,(C)
4761         DP      2(B)
4762         HRROI   A,[ASCIZ / /]
4763         PSOUT
4764         MOVSI   A,$TVECT
4765         SKIPGE  2(C)
4766          JRST   [HRROI  A,[ASCIZ /< TUPLE >/]
4767                  PSOUT
4768                  JRST   UFRMLX]
4769         HLR     A,2(C)
4770         XMOVEI  B,6(C)
4771         PUSH    TP,A
4772         PUSH    TP,B
4773         DP      -1(TP)
4774         ADJSP   TP,-2                           ; SUB   TP,[2,,2]
4775 UFRMLX: HRROI   A,[ASCIZ /
4776 /]
4777         PSOUT
4778         SKIPGE  C,3(C)                  ; GET NEXT FRAME
4779          JRST   [HRROI  A,[ASCIZ / <GLUED FRAME(S)>
4780 /]
4781                  PSOUT
4782                  HRRZ   C,-1(C)         ; GET REAL FRAME
4783                  XHLLI  C,(F)
4784                  SUBI   C,FR.OFF
4785                  JRST   .+1]
4786         SKIPGE  (C)
4787          JRST   [HRROI  A,[ASCIZ / <GLUED FRAME(S)>
4788 /]
4789                  PSOUT
4790                  HRRZ   C,-1(C)
4791                  SUBI   C,FR.OFF
4792                  XHLLI  C,(F)
4793                  JRST   .+1]
4794         JUMPG   C,UFRML
4795         JRST    UUORET
4796
4797 UDC:    MOVE    B,3(O1)
4798         PUSHJ   P,UDPSTR
4799         JRST    UUORET
4800
4801 UDP:    MOVE    A,(B)           ; TYPE WORD
4802         MOVE    B,1(B)
4803         PUSHJ   P,UPDISP
4804         JRST    UUORET
4805
4806 UPDISP: HLRZ    C,A
4807         TLZE    C,200000        ; IS IT MARKED?
4808          JRST   [PUSH   P,A
4809                  MOVEI  A,"@
4810                  PBOUT
4811                  POP    P,A
4812                  JRST   .+1]
4813         JUMPE   C,UDPUNB
4814         CAIN    C,$TFORM
4815          JRST   UDPFRM
4816         CAIN    C,$TTUPLE
4817          JRST   UDPTUP
4818         CAIN    C,$TOBLI
4819          JRST   UDPOBL
4820         CAIN    C,$TATOM
4821          JRST   UDPATM
4822         CAIN    C,$TSTRING
4823          JRST   UDPSTR
4824         CAIN    C,$TFIX
4825          JRST   UDPFIX
4826         CAIN    C,$TFALS
4827          JRST   UDPFLS
4828         CAIN    C,$TCHAR
4829          JRST   UDPCHR
4830         CAIN    C,$TFLOAT
4831          JRST   UDPFLT
4832         CAIN    C,$TLIST
4833          JRST   UDPLST
4834         CAIN    C,$TMSUBR
4835          JRST   UDPMSB
4836         CAIN    C,$TMCODE
4837          JRST   UDPMCD
4838         CAIN    C,$TVECTOR
4839          JRST   UDPVCT
4840         CAIN    C,$TCHANNEL
4841          JRST   UDPSTM
4842         HRROI   A,[ASCIZ /??/]
4843 UPOUT:  PSOUT
4844         POPJ    P,
4845
4846 UDPUNB: HRROI   A,[ASCIZ /#UNBOUND /]
4847         PSOUT
4848         JRST    UDPFIX
4849
4850 UDPMCD: HRROI   A,[ASCIZ /#MCODE |??|/]
4851         JRST    UPOUT
4852
4853 UDPFLS: HRROI   A,[ASCIZ /#FALSE ()/]
4854         PSOUT
4855         POPJ    P,
4856
4857 UDPMSB: HRROI   A,[ASCIZ /#MSUBR ??/]
4858         PSOUT
4859         POPJ    P,
4860
4861 UDPCHR: HRROI   A,[ASCIZ /!\/]
4862         PSOUT
4863         MOVE    A,B
4864         PBOUT
4865         POPJ    P,
4866
4867 UDPFIX: MOVEI   A,.PRIOU
4868         MOVEI   C,10.
4869         NOUT
4870          JFCL
4871         POPJ    P,
4872
4873 UDPFLT: MOVEI   A,.PRIOU
4874         FLOUT
4875          JFCL
4876         POPJ    P,
4877
4878 UDPSTR: PUSH    P,A
4879         HRROI   A,[ASCIZ /"/]
4880         PSOUT
4881         POP     P,A
4882         HRRZ    C,A
4883         MOVEI   A,.PRIOU
4884         SOUT
4885         HRROI   A,[ASCIZ /"/]
4886         PSOUT
4887         POPJ    P,
4888
4889 UDPOBL: HRROI   A,[ASCIZ /#OBLIST /]
4890         PSOUT
4891 UDPATM: HRRZ    C,2(B)
4892         MOVE    B,3(B)
4893         PUSH    P,C
4894         POP     P,C
4895         MOVEI   A,.PRIOU
4896         SOUT
4897         POPJ    P,
4898
4899 UDPTUP: PUSH    P,A
4900         HRROI   A,[ASCIZ /#TUPLE /]
4901         PSOUT
4902         POP     P,A
4903 UDPVCT: PUSH    P,B
4904         HRRZ    C,A
4905         PUSH    P,C
4906         HRROI   A,[ASCIZ /[/]
4907         PSOUT
4908         JUMPE   C,UDPVCE
4909 UDPVCL: MOVE    A,(B)
4910         MOVE    B,1(B)
4911         PUSHJ   P,UPDISP
4912         SOSG    (P)
4913          JRST   UDPVCE
4914         AOS     -1(P)
4915         AOS     B,-1(P)
4916         HRROI   A,[ASCIZ / /]
4917         PSOUT
4918         JRST    UDPVCL
4919
4920 UDPVCE: HRROI   A,[ASCIZ /]/]
4921         PSOUT
4922         ADJSP   P,-2                            ; SUB   P,[2,,2]
4923         POPJ    P,
4924
4925 UDPFRM: HRROI   A,[ASCIZ /#FORM /]
4926         PSOUT
4927 UDPLST: HRROI   A,[ASCIZ /(/]
4928         PSOUT
4929         JUMPE   B,UPLSTE
4930 UPLSTL: PUSH    P,B
4931         DMOVE   A,1(B)
4932         PUSHJ   P,UPDISP
4933         POP     P,B
4934         MOVE    B,(B)
4935         JUMPE   B,UPLSTE
4936         HRROI   A,[ASCIZ / /]
4937         PSOUT
4938         JRST    UPLSTL
4939
4940 UPLSTE: HRROI   A,[ASCIZ /)/]
4941         PSOUT
4942         POPJ    P,
4943
4944 UDPSTM: PUSH    P,A
4945         HRROI   A,[ASCIZ /#CHANNEL [/]
4946         PSOUT
4947         POP     P,A
4948         PUSH    P,B
4949         PUSH    P,C
4950         MOVE    A,(B)
4951         MOVE    B,1(B)
4952         PUSHJ   P,UPDISP
4953         MOVEI   A,40
4954         PBOUT
4955         MOVE    B,-1(P)
4956         MOVE    A,4(B)
4957         MOVE    B,5(B)
4958         PUSHJ   P,UPDISP
4959         MOVEI   A,"]
4960         PBOUT
4961         ADJSP   P,-2
4962         POPJ    P,
4963
4964 UTON:;  SETOM   TRACE
4965         JRST    UUORET
4966
4967 UTOFF:; SETZM   TRACE
4968         JRST    UUORET
4969
4970 UEX:    MOVE    D,(P)
4971         MOVE    C,-1(P)
4972         MOVE    B,-2(P)
4973         MOVE    A,-3(P)
4974         MOVE    0,-4(P)
4975         XCT     @MLTEA                          ; get ins to execute
4976         JRST    UUORET
4977 \f
4978 SUBTTL  END OF THE ROAD
4979
4980 CONSTANTS
4981 NOISY:  1                                       ; non-zero, say if int in GC
4982 ONOISY: 0                                       ; non-zero, say ok after GC
4983 BUGS:   0                                       ; count bad ADJBP
4984 CTLGS:  0                                       ; count ^Gs and ^As
4985 CTLGCH: 0                                       ; int channel for ^G
4986 CTLACH: 0                                       ; int channel for ^A
4987 PAT:
4988 PATCH:  BLOCK   100
4989 PATEND: 0
4990 VARIABLES
4991
4992 IFN MON,.INSRT M20:INSINT.MID
4993
4994 ;MUMBLE:        BLOCK   1000
4995 LOC     <<.+777>&777000>                ; GO TO PAGE BOUNDARY
4996 ENDPG==<.+777>_<-9.>
4997
4998 STACK:  BLOCK   STACKL
4999 PDL:    BLOCK   256.
5000
5001 LOC <<.+777>&777000>
5002
5003 GCSTRT==.
5004 GCSPST==._<-9.>
5005 \f
5006 SUBTTL  BOOTSTRAP MSUBR READER
5007
5008 ZZZ==.
5009 BOOTGC==15000.
5010 LOC     STACK+BOOTGC
5011
5012 BSATBL: BLOCK   256.
5013 BSAPTR: -256.,,BSATBL-1
5014
5015 BOOTER: MOVE    A,GCSMIN
5016         MOVEM   A,GCSBOT
5017         SETZM   (A)
5018         MOVEI   B,1(A)
5019         HRLI    B,(A)
5020         MOVE    A,[MIMSEC,,PAGTBL]
5021         MOVEM   A,PAGPTR+1
5022         MOVE    A,[MIMSEC,,MINF]
5023         MOVEM   A,MINFO
5024         MOVEI   A,TOPGC
5025         MOVEM   A,GCSMAX
5026         HRROI   A,[ASCIZ /MIMI20 Initialization
5027 /]
5028         PSOUT
5029         SKIPN   A,BOOTYP
5030          JRST   BNIN
5031         HRRO    A,[[ASCIZ /Using msubrs
5032 /]
5033                    [ASCIZ /Using mbins
5034 /]
5035                    [ASCIZ /Using big mbins
5036 /]]+1(A)
5037         PSOUT
5038         JRST    BNIN1
5039 BNIN:   HRROI   A,[ASCIZ /Enter type (1 big mbins, 0 mbins, -1 msubrs):   /]
5040         PSOUT
5041         MOVEI   A,.PRIOUT
5042         MOVEI   C,10.
5043         NIN
5044         JRST    BNIN
5045         MOVEM   B,BOOTYP
5046
5047 BNIN1:  MOVE    P,[-PDLLEN,,PDL-1]
5048         MOVE    TP,[-STACKLEN,,STACK-1]
5049
5050         PUSHJ   P,SMAPIT                ; setup multi sections
5051
5052         PUSHJ   P,INTINI
5053         MOVEI   A,<238.*2>
5054         JSP     PC,IBLOCK
5055         MOVE    B,[$TVECTOR,,237.]
5056         MOVEM   B,TOPOBL
5057         MOVEM   A,TOPOBL+1
5058         MOVEI   B,237.
5059         MOVE    C,$WLIST
5060         MOVEM   C,(A)
5061         SETZM   1(A)
5062         ADDI    A,2
5063         SOJN    B,.-3
5064         MOVE    B,[$DOPEBIT+$TVECT,,<237.*2>]
5065         MOVEM   B,(A)
5066         SETZM   1(A)
5067
5068         MOVSI   A,(GJ%SHT+GJ%OLD)
5069         HRROI   B,[ASCIZ /<MIM.BOOT>BOOT.MSUBR/]
5070         GTJFN
5071          JRST   BSNOF
5072         MOVE    B,[070000,,OF%RD]
5073         OPENF
5074          JRST   BSNOF
5075         MOVEM   A,BSJFN'
5076         SETZM   BSCHR'
5077         PUSHJ   P,BSREAD
5078         SKIPN   BSENDF'
5079          JRST   .-2
5080         MOVE    A,BSJFN
5081         CLOSF
5082          JFCL
5083         HRROI   D,BSATBL
5084         MOVE    C,[.BYTE 7 ? "B ? "O ? "O ? "T]
5085         PUSHJ   P,BSLKPL                ; GET ATOM BOOT IN A/B
5086          CAIA
5087           JRST  BSNOB
5088         MOVE    O1,B
5089         SETZB   O2,F
5090         SETZM   STACK
5091         MOVE    A,[STACK,,STACK+1]
5092         BLT     A,STACK+300
5093         JSP     PC,FRAME                ; MAKE A FRAME
5094         XMOVEI  F,-1(TP)
5095         JSP     PC,FRAME
5096         HRROI   A,[ASCIZ /Bootstrap Loaded
5097 /]
5098         PSOUT
5099         PUSH    TP,$WFIX
5100         PUSH    TP,BOOTYP
5101         MOVEI   O2,1                    ; Actually call with 1 arg
5102         MOVEI   SP,0                    ; START SP IN RIGHT SECT
5103         JSP     PC,CALLZ                ; CALL BOOTSTRAP WITH NO ARGS
5104         JRST    SAV                     ; AND ATTEMPT TO SAVE OURSELVES
5105
5106 BSSEP:  CAIE    B,"
5107          CAIN   B,^J
5108           POPJ  P,
5109         CAIE    B,^L
5110          CAIN   B,^M
5111           POPJ  P,
5112         CAIE    B,"]
5113          CAIN   B,^J
5114           POPJ  P,
5115         CAIE    B,""
5116          CAIN   B,")
5117           POPJ  P,
5118         CAIE    B,^Z
5119          CAIN   B,0
5120           JRST  BSEND
5121 POPJ1:  AOS     (P)
5122         POPJ    P,
5123
5124 BSEND:  SETOM   BSENDF
5125         POPJ    P,
5126
5127 BSREAD: SKIPE   BSENDF
5128          POPJ   P,
5129         MOVE    A,BSJFN
5130         SKIPN   B,BSBRK
5131          BIN
5132 BSRD1:  SETZM   BSBRK
5133         CAIN    B,"|
5134          JRST   BSCOD
5135         CAIN    B,"#
5136          JRST   BSTYP
5137         CAIN    B,"[
5138          JRST   BSVEC
5139         CAIN    B,"(
5140          JRST   BSLST
5141         CAIN    B,"%
5142          JRST   BSIMM
5143         CAIN    B,""
5144          JRST   BSSTR
5145         CAIE    B,")
5146          CAIN   B,"]
5147           JRST  [MOVE   A,$WUNBOUND
5148                  POPJ   P,]
5149         CAIN    B,"!
5150          JRST   BSCHAR
5151         PUSHJ   P,BSSEP
5152          JRST   BSREAD
5153         CAIL    B,"0
5154          CAILE  B,"9
5155           JRST  BSATM
5156         JRST    BSFIX
5157
5158 ; HERE TO READ # FORMAT
5159
5160 BSTYP:  PUSHJ   P,BSREAD                ; GET TYPE NAME
5161         MOVE    B,3(B)                  ; GET PNAME
5162         TLZ     B,770000
5163         MOVE    C,1(B)
5164         TRZ     C,377
5165         CAMN    C,[.BYTE 7 ? "M ? "S ? "U ? "B]
5166          PUSH   P,$WMSUBR
5167         CAMN    C,[.BYTE 7 ? "I ? "M ? "S ? "U]
5168          PUSH   P,$WIMSUB
5169         CAMN    C,[.BYTE 7 ? "D ? "E ? "C ? "L]
5170          PUSH   P,$WDECL
5171         CAMN    C,[.BYTE 7 ? "U ? "N ? "B ? "O]
5172          PUSH   P,$WUNBOUND
5173         CAMN    C,[.BYTE 7 ? "F ? "A ? "L ? "S]
5174          PUSH   P,$WFALSE
5175         PUSHJ   P,BSREAD                ; GET PRIMITIVE STRUCTURE
5176         HLL     A,(P)                   ; GET NEW TYPE WORD
5177         ADJSP   P,-1
5178         HLLZ    C,A
5179         CAME    C,$WIMSUB
5180          CAMN   C,$WMSUBR
5181           CAIA
5182            POPJ P,
5183         PUSH    TP,A
5184         PUSH    TP,B
5185         PUSH    TP,A
5186         PUSH    TP,B
5187         REPEAT  4,PUSH TP,[0]
5188         MOVE    O1,$WGBIND
5189         MOVEI   O2,3
5190         PUSHJ   P,RECORR                ; MAKE A BINDING
5191         PUSH    P,B
5192         POP     TP,B
5193         POP     TP,A                    ; RESTORE THE MSUBR
5194         MOVE    C,3(B)                  ; THE ATOM
5195         CAMN    C,$WMSUBR
5196          MOVE   C,1(B)
5197         POP     P,A
5198         MOVEM   A,(C)                   ; STUFF BINDING IN ATOM
5199         MOVEM   C,2(A)                  ; STUFF ATOM IN BINDING
5200         POPJ    P,
5201
5202
5203 ; HERE TO READ A FIX
5204
5205 BSFRC:  0
5206
5207 BSFIX:  SETZM   BSFRC
5208         MOVEI   C,-"0(B)                ; C WILL HOLD FIX
5209         SETZ    D,                      ; D IS FRACTION / E IS # OF DIGITS
5210         MOVEI   E,1
5211 BSFIXL: BIN                             ; GET NEXT CHARACTER
5212         PUSHJ   P,BSSEP                 ; IS IT A SEPARATOR
5213          JRST   BSFIXE                  ; YES, FINISH
5214         SKIPE   BSFRC
5215          JRST   [IMULI D,10.            ; UPDATE INFO
5216                  ADDI D,-"0(B)
5217                  IMULI E,10.
5218                  JRST BSFIXL]
5219         CAIN    B,".                    ; DECIMAL?
5220          JRST   [SETOM  BSFRC
5221                  JRST BSFIXL]
5222         IMULI   C,10.                   ; SHIFT OVER SOME
5223         ADDI    C,-"0(B)                ; ADD IN THE NEXT DIGIT
5224         JRST    BSFIXL                  ; AND LOOP
5225
5226 BSFIXE: MOVEM   B,BSBRK'
5227         MOVE    A,$WFIX
5228         SKIPE   BSFRC
5229          JRST   [FLTR C,C
5230                  FLTR D,D
5231                  FLTR E,E
5232                  FDVR D,E
5233                  FADR C,D
5234                  MOVE A,$WFLOAT
5235                  JRST .+1]
5236         MOVE    B,C
5237         POPJ    P,
5238
5239 ; HERE TO READ A CHARACTER
5240
5241 BSCHAR: BIN
5242         CAIE    B,"\
5243          HALTF
5244         BIN
5245         MOVE    A,$WCHARACTER
5246         POPJ    P,
5247
5248 ; HERE TO READ A STRING
5249
5250 BSSTR:  PUSH    P,[0]                   ; CLEAR COUNT (PREPARE TO MAKE STRING)
5251 BSSTRL: BIN
5252         SKIPE   BSQUOT
5253          JRST   [SETZM BSQUOT
5254                  JRST BSSTR1]
5255         CAIN    B,"\
5256          SETOM  BSQUOT'
5257         CAIN    B,""
5258          JRST   BSSTR2
5259 BSSTR1: PUSH    TP,$WCHARACTER          ; PUT CHARACTER ON STACK
5260         PUSH    TP,B
5261         AOS     (P)
5262         JRST    BSSTRL                  ; AND LOOP
5263 BSSTR2: MOVE    O1,$WSTRING
5264         POP     P,O2
5265         PUSHJ   P,UBLOKR                ; MAKE THE STRING
5266         POPJ    P,
5267
5268 ; HERE TO READ AN ATOM
5269
5270 BSATM:  PUSH    P,[0]                   ; CLEAR COUNT (PREPARE TO MAKE STRING)
5271         JRST    BSATM1
5272 BSATML: BIN
5273         PUSHJ   P,BSSEP
5274          JRST   BSATM2
5275 BSATM1: PUSH    TP,$WCHARACTER          ; PUT CHARACTER ON STACK
5276         PUSH    TP,B
5277         AOS     (P)
5278         JRST    BSATML                  ; AND LOOP
5279 BSATM2: MOVEM   B,BSBRK
5280         MOVE    O1,$WSTRING
5281         POP     P,O2
5282         PUSHJ   P,UBLOKR                ; MAKE THE STRING
5283         TLZ     B,770000
5284         PUSHJ   P,BSLKP
5285          POPJ   P,
5286 BSGBND: TLO     B,660000
5287         PUSH    TP,A
5288         PUSH    TP,B
5289         PUSH    TP,$WUNBOUND
5290         PUSH    TP,[0]
5291         PUSH    TP,[0]
5292         PUSH    TP,[0]
5293         PUSH    TP,[0]
5294         PUSH    TP,[0]
5295         MOVE    O1,$WGBIND
5296         MOVEI   O2,3
5297         PUSHJ   P,RECORR
5298         POP     TP,D
5299         POP     TP,C
5300         PUSH    TP,A                    ; PUSH GLOBAL BINDING
5301         PUSH    TP,B
5302         PUSH    TP,$WFIX                ; PUSH LOCAL BINDING
5303         PUSH    TP,[0]
5304         PUSH    TP,C                    ; PUSH PNAME
5305         PUSH    TP,D
5306         TLZ     D,770000
5307         PUSH    P,1(D)
5308         MOVE    O1,$WATOM
5309         MOVEI   O2,3
5310         PUSHJ   P,RECORR                ; MAKE AN ATOM (ISN'T THIS FUN?)
5311         MOVE    D,(B)                   ; GET GLOBAL BINDING
5312         MOVEM   B,2(D)                  ; STUFF IT IN ATOM
5313         MOVE    D,BSAPTR
5314         PUSH    D,(P)
5315         PUSH    D,B
5316         MOVEM   D,BSAPTR
5317         ADJSP   P,-1
5318         POPJ    P,
5319
5320 BSLKP:  HRROI   D,BSATBL
5321         MOVE    C,1(B)                  ; POINT TO START OF PNAME
5322 BSLKPL: SKIPN   E,(D)
5323          JRST   POPJ1
5324         CAMN    E,C
5325          JRST   BSLKP1
5326         ADDI    D,2
5327         JRST    BSLKPL
5328 BSLKP1: MOVE    B,1(D)
5329         MOVE    A,[$TATOM,,10.]         ; CHANGED (WAS 4)
5330         POPJ    P,
5331
5332 ; HERE TO READ SOME MCODE
5333
5334 BSCOD:  PUSH    P,[0]                   ; CLEAR THE COUNTER
5335 BSCODL: MOVEI   D,0
5336         MOVEI   E,4
5337 BSCDL:  BIN
5338         CAIG    B,"A-1
5339          JRST   .-2
5340         CAIN    B,"|
5341          JRST   BSCODE
5342         MOVEI   C,-"A(B)
5343         LSH     C,5
5344         BIN
5345         CAIG    B,"A-1
5346          JRST   .-2
5347         SUBI    B,"A
5348         IOR     C,B
5349         LSH     D,9.
5350         IOR     D,C
5351         SOJG    E,BSCDL
5352
5353         PUSH    TP,$WFIX                ; PUT IT ON THE STACK
5354         PUSH    TP,D                    ; P.S. - IT HAD BETTER BE A FIX
5355         AOS     (P)
5356         JRST    BSCODL          ; AND LOOP
5357 BSCODE: CAIN    E,4
5358          JRST   [IMULI E,9
5359                  LSH D,(E)
5360                  PUSH TP,$WFIX
5361                  PUSH TP,D
5362                  AOS (P)
5363                  JRST .+1]
5364         MOVE    O1,$WMCODE              ; TYPE WORD SET
5365         POP     P,O2
5366         PUSHJ   P,UBLOKR                ; MAKE THE UBLOCK (STRING)
5367         POPJ    P,
5368
5369 ; HERE TO READ A VECTOR
5370
5371 BSVEC:  PUSH    P,[0]
5372 BSVECL: PUSHJ   P,BSREAD
5373         CAMN    A,$WUNBOUND
5374          CAIE   B,"]
5375           CAIA
5376            JRST BSVECE
5377         PUSH    TP,A
5378         PUSH    TP,B
5379         AOS     (P)
5380         JRST    BSVECL
5381 BSVECE: MOVE    O1,$WVECTOR
5382         POP     P,O2
5383         PUSHJ   P,UBLOKR
5384         POPJ    P,
5385
5386 BSIMM:  MOVE    A,BSJFN
5387         BIN
5388         CAIE    B,"<            ; This is the only % frob we know how to read
5389          HALTF
5390         BIN
5391         CAIE    B,">
5392          HALTF
5393         MOVEI   B,0
5394         MOVE    A,$WFALSE
5395         POPJ    P,
5396
5397 ; HERE TO READ A LIST
5398
5399 BSLST:  PUSH    P,[0]
5400 BSLSTL: PUSHJ   P,BSREAD
5401         CAMN    A,$WUNBOUND
5402          CAIE   B,")
5403           CAIA
5404            JRST BSLSTE
5405         PUSH    TP,A
5406         PUSH    TP,B
5407         AOS     (P)
5408         JRST    BSLSTL
5409 BSLSTE: POP     P,O1
5410         PUSHJ   P,LIST
5411         POPJ    P,
5412
5413 ; HERE FOR BOOTSTRAP ERRORS
5414
5415 BSNOB:  HRROI   A,[ASCIZ /No MSUBR named BOOT
5416 /]
5417         PSOUT
5418         PUSHJ   P,HALTX
5419
5420 BSNOF:  HRROI   A,[ASCIZ /Can't open BOOT.MSUBR
5421 /]
5422         PSOUT
5423         PUSHJ   P,HALTX
5424 SUBTTL SMAP% CODE FOR MULTI SECTION HACKING
5425
5426 SMAPIT: PUSH    P,A
5427         PUSH    P,B
5428         PUSH    P,C
5429 ; Create 1 or 2 stack sections, depending on FLIP
5430         MOVEI   A,0
5431         MOVE    B,[.FHSLF,,MIMSEC]              ; create brand new section
5432         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]  ; bits for mapping
5433         SMAP%
5434 IFN FLIP,[
5435         MOVEI   A,0
5436         MOVE    B,[.FHSLF,,MIMSEC+1]            ; create brand new section
5437         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]  ; bits for mapping
5438         SMAP%
5439 ]
5440         MOVSI   C,(PM%RD+PM%EX+PM%CPY)
5441         MOVSI   A,.FHSLF
5442         MOVE    B,[.FHSLF,,<MIMSEC_9>]
5443         PMAP
5444 IFN FLIP,[
5445         MOVSI   C,(PM%RD+PM%EX+PM%CPY)
5446         MOVSI   A,.FHSLF
5447         MOVE    B,[.FHSLF,,<<MIMSEC+1>_9>]
5448         PMAP
5449 ]
5450         MOVE    D,[.FHSLF,,1]
5451 MAPLP:  MOVE    A,D
5452         MOVSI   C,(PM%RD+PM%WR+PM%EX)
5453         MOVE    B,D
5454         ADDI    B,<MIMSEC_9.>
5455         PMAP
5456 IFN FLIP,[
5457         MOVSI   C,(PM%RD+PM%WR+PM%EX)
5458         MOVE    A,D
5459         MOVE    B,D
5460         ADDI    B,<<MIMSEC+1>_9.>
5461         PMAP
5462 ]
5463 NXTMAP: ADDI    D,1
5464         CAME    D,[.FHSLF,,1000]
5465          JRST   MAPLP
5466
5467 ; create  stack section
5468 IFN <MIMSEC-TPSEC>,[
5469         MOVEI   A,0
5470         MOVE    B,[.FHSLF,,TPSEC]
5471         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]  ; bits for mapping
5472         SMAP%
5473 ]
5474 ; create initial GC space section and section following (for MAPPUR)
5475
5476         MOVEI   A,0
5477         MOVE    B,[.FHSLF,,INIGC]
5478         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+2]  ; bits for mapping
5479         SMAP%
5480
5481 ; and map special page in from 0
5482
5483         MOVE    A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5484         MOVE    B,[.FHSLF,,<<INIGC_9.>+COMPAG>]
5485         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]  ; bits for mapping
5486         PMAP
5487 IFN FLIP,MOVE   A,[.FHSLF,,COMPAG+<<MIMSEC+1>_9>]
5488 IFE FLIP,MOVE   A,[.FHSLF,,COMPAG+<MIMSEC_9>]
5489         MOVE    B,[.FHSLF,,<<<INIGC+1>_9.>+COMPAG>]
5490         MOVE    C,[PM%CNT+PM%RD+PM%EX+PM%WR+1]
5491         PMAP
5492
5493 ; now all that is left to do is set up UUOs, fix ENTRY table  and make stacks
5494 ;       happy
5495
5496         XJRST   .+1
5497                 0
5498                 MIMSEC,,.+1
5499         MOVE    A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5500 IFN FLIP,       MOVEI   B,MIMSEC+1
5501 IFE FLIP,       MOVEI   B,MIMSEC
5502
5503         HRRZ    C,(A)
5504         CAILE   C,777
5505          HRLM   B,(A)           ; MAKE POINT TO CORRECT SECTION
5506         AOBJN   A,.-3
5507
5508         MOVE    A,[-FROBL,,FROBBS]
5509         HRRZ    C,(A)
5510         CAILE   C,777
5511          HRLM   B,(A)
5512         AOBJN   A,.-3
5513
5514 IFN FLIP,[
5515         XJRST   .+1
5516                 0
5517                 MIMSEC+1,,.+1
5518         MOVE    A,[<ENTVEC+LOWOP-ENTMAX-1>,,ENTVEC+LOWOP]
5519         MOVEI   B,MIMSEC
5520
5521         HRRZ    C,(A)
5522         CAILE   C,777
5523          HRLM   B,(A)           ; MAKE POINT TO CORRECT SECTION
5524         AOBJN   A,.-3
5525 ]
5526         MOVE    A,[-FROBL,,FROBBS]
5527         HRRZ    C,(A)
5528         CAILE   C,777
5529          HRLM   B,(A)
5530         AOBJN   A,.-3
5531
5532         JRST    @.+1
5533                 .+1
5534         MOVEI   A,.FHSLF
5535         MOVEI   B,2             ; CODE FOR SETUP OF UUO TABLE
5536         MOVE    C,[MIMSEC,,MLTUUP]
5537         SWTRP%
5538
5539         MOVE    TP,[TPSEC,,STRTTP]      ; now have good TP
5540         MOVE    A,[INIGC,,1000] ; MAKE THIS START GC
5541         MOVEM   A,GCSMIN
5542         MOVEM   A,GCSBOT
5543         MOVE    A,[INIGC,,TOPMGC]
5544         MOVEM   A,GCSMAX
5545         MOVE    B,[MPAGM,,PAGTBL]
5546         BLT     B,PAGTBL+MPAGME-MPAGM
5547         POP     P,C
5548         POP     P,B
5549         POP     P,A
5550         POP     P,DUALPC+1
5551         MOVEI   0,MIMSEC
5552         HRLM    DUALPC+1
5553         MOVE    P,[TPSEC,,STPDL]        ; p-stack in MIM section
5554         SETZM   DUALPC
5555         XJRST   DUALPC          ; poof we are outta here!
5556
5557 MPAGM:  ENDPG
5558         0
5559         SETZ
5560         1000-ENDPG
5561         ENDPG
5562         -1
5563         ENDPG
5564         <MIMSEC_9.>
5565         SETZ
5566 IFN <TPSEC-MIMSEC>,[
5567         1000-ENDPG
5568         <MIMSEC_9.>+ENDPG
5569         -1
5570 ]
5571         1000-<STRTTP_<-9.>>
5572         <STRTTP_<-9.>>+<TPSEC_9>
5573         SETZ
5574         ENDPG
5575         <<MIMSEC+1>_9.>
5576         SETZ
5577 IFN <TPSEC-MIMSEC>,[
5578         1000-ENDPG
5579         <<MIMSEC+1>_9.>+ENDPG
5580         -1
5581 ]
5582         1000-<STRTTP_<-9.>>
5583         <STRTTP_<-9.>>+<<TPSEC+1>_9>
5584         SETZ
5585         1
5586         <INIGC_9>
5587         SETZ
5588         <TOPMGC_<-9.>>+1
5589         <INIGC_9>+1
5590         INITZN
5591         REPEAT <NUMSEC-1>,[1
5592                        <<INIGC+.RPCNT+1>_9.>
5593                        SETZ
5594                        1000-1
5595                        <<INIGC+.RPCNT+1>_9.>+1
5596                        0
5597                        ]
5598
5599 MPAGME: 0
5600
5601
5602 CONSTANTS
5603 VARIABLES
5604 LOC ZZZ
5605
5606         END     BOOTER