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