src/loader.nih

   1         SUBTTL  RP GRUEN/NGP/WFW/DMN  V.052     7-SEP-70
   2 ; RFS 11-30-70
   3 ;       TURNED ON FAILSW,SAILSW FOR NIH USAGE.
   4
   5
   6         VLOADER==52
   7         VPATCH==0               ;DEC PATCH LEVEL
   8         VCUSTOM==0              ;NON-DEC PATCH LEVEL
   9
  10         LOC <JOBVER==137>
  11         XWD VCUSTOM,VLOADER+1000*VPATCH
  12         RELOC
  13
  14 COMMENT *       ASSEMBLY FEATURE SWITCHES (ACTION WHEN NON-ZERO)
  15
  16         SWITCHES ON (NON-ZERO) IN DEC VERSION
  17 SEG2SW          GIVES TWO SEGMENT CODE (IF MACRO ALLOWS IT)
  18 PURESW          GIVES PURE CODE (VARIABLES IN LOW SEG)
  19 REENT           GIVES REENTRANT CAPABILITY PDP-10
  20         (REENT=0 FOR PDP-10/30 OR PDP-6 OR EARLY PDP-10)
  21 RPGSW           INCLUDE CCL FEATURE
  22 TEMP            INCLUDE TMPCOR FEATURE
  23 DMNSW            SYMBOL TABLE WILL BE MOVED DOWN FROM TOP OF CORE
  24 KUTSW            GIVES CORE CUTBACK ON /K
  25 EXPAND           FOR AUTOMATIC CORE EXPANSION
  26 PP              ALLOW PROJ-PROG #
  27 DIDAL           GIVES DIRECT ACCESS LIBRARY SEARCH MODE
  28 ALGSW           WILL LOAD ALGOL OWN BLOCK (TYPE 15)
  29
  30         SWITCHES OFF (ZERO) IN DEC VERSION
  31 K               GIVES 1KLOADER - NO F4
  32 L                FOR LISP LOADER
  33 SPMON           GIVES SPMON LOADER (MONITOR LOADER)
  34 TEN30           FOR 10/30 LOADER
  35 STANSW           GIVES STANFORD FEATURES
  36 LNSSW           GIVES LNS VERSION
  37 FAILSW          INCLUDE PROVISIONS FOR SPECIAL FAIL FIXUPS.
  38 LDAC             MEANS LOAD CODE INTO ACS
  39         (LDAC DOES NOT WORK WITH KUTSW=1.CORE UUO CLEARS JOBBLT)
  40 WFWSW           GIVES BLOCK TYPE 13 (VARIABLS INTO LOW SEG)
  41 SYMARG          ACCEPT SYMBOLIC (GLOBAL) ARGUMENTS FOR SWITCHES
  42 SPCHN           WILL DO SPECIAL OVERLAYING
  43 SAILSW          GIVES BLOCK TYPE 15 (FORCE LOAD OF REL FILES)
  44                 AND 16 (FORCE SEARCH OF LIBRARIES) FOR SAIL
  45 *
  46
  47
  48 SUBTTL  DEFAULT ASSEMBLY SWITCH SETTINGS
  49
  50 IFNDEF SPMON,<SPMON=0>
  51 IFN SPMON,<     TEN30==1
  52                 K==1>
  53
  54 IFNDEF L,<L=0>
  55
  56 IFNDEF TEN30,<TEN30=0>
  57
  58 IFN TEN30!L,<   RPGSW=0
  59                 PP=0
  60 IFNDEF DMNSW,<  DMNSW=0>
  61 IFNDEF DIDAL,<  DIDAL=0>
  62                 ALGSW=0
  63                 PURESW=0
  64                 REENT=0
  65                 LDAC=0
  66                 KUTSW=0
  67                 SEG2SW=0
  68                 NAMESW=0>
  69 IFN TEN30,<     EXPAND=0>
  70
  71 IFNDEF  K,<K=0>
  72
  73 IFNDEF STANSW,<STANSW=0>
  74 IFN STANSW,<    LDAC=1
  75                 FAILSW=1>
  76
  77 IFNDEF LNSSW,<LNSSW=0>
  78 IFN LNSSW,<LDAC=1
  79         PP=0>
  80
  81 FAILSW==1
  82 IFNDEF FAILSW,<FAILSW=0>
  83
  84 IFNDEF RPGSW,<RPGSW==1>
  85 IFN RPGSW,<PP==1>       ;REQUIRE DISK FOR CCL
  86 IFE RPGSW,<TEMP=0>
  87
  88 IFNDEF PP,<PP==1>
  89
  90 IFNDEF TEMP,<TEMP==1>
  91
  92 IFNDEF NAMESW,<NAMESW==1>
  93
  94 IFNDEF LDAC,<LDAC=0>
  95 IFN LDAC,<KUTSW=0>
  96
  97 IFNDEF KUTSW,<KUTSW==1>
  98
  99 IFNDEF EXPAND,< IFN K,<EXPAND==0>
 100                 IFE K,<EXPAND==1>>
 101
 102 IFNDEF DMNSW,<DMNSW==1>
 103 IFN DMNSW!LDAC,<IFNDEF SYMPAT,<SYMPAT==20>
 104         IFN LDAC,<IFG 20-SYMPAT,<SYMPAT==20>>>
 105
 106 IFNDEF REENT,<REENT==1>
 107 IFE REENT,<PURESW=0
 108         SEG2SW=0>
 109
 110 IFDEF TWOSEG,<IFNDEF SEG2SW,<SEG2SW==1>>
 111 IFNDEF SEG2SW,<SEG2SW==0>
 112 IFN SEG2SW,<PURESW==1>
 113
 114 IFNDEF PURESW,<PURESW==1>
 115
 116 IFNDEF WFWSW,<WFWSW==0>
 117
 118 IFN K,<SYMARG=0
 119         SPCHN=0>
 120
 121 IFNDEF SYMARG,<SYMARG==0>
 122
 123 IFNDEF SPCHN,<SPCHN==0>
 124
 125 IFNDEF DIDAL,<DIDAL==1>
 126
 127 IFNDEF ALGSW,<ALGSW==0>
 128
 129 SAILSW==1
 130 IFNDEF SAILSW,<SAILSW==0>
 131
 132
 133 SUBTTL  ACCUMULATOR ASSIGNMENTS
 134         F=0             ;FLAGS IN BOTH HALVES OF F
 135         N=1             ;FLAGS IN LH, PROGRAM NAME POINTER IN RH
 136         X=2             ;LOADER OFFSET
 137         H=3             ;HIGHEST LOC LOADED
 138         S=4             ;UNDEFINED POINTER
 139         R=5             ;RELOCATION CONSTANT
 140         B=6             ;SYMBOL TABLE POINTER
 141         D=7
 142         T=10
 143         V=T+1
 144         W=12            ;VALUE
 145         C=W+1           ;SYMBOL
 146         E=C+1           ;DATA WORD COUNTER
 147         Q=15            ;RELOCATION BITS
 148         A=Q+1           ;SYMBOL SEARCH POINTER
 149         P=17            ;PUSHDOWN POINTER
 150
 151
 152 ;MONITOR LOCATIONS IN THE USER AREA
 153
 154 JOBDA==140
 155 JOBHDA==10
 156
 157 EXTERN  JOBDDT,JOBFF,JOBSA,JOBREL,JOBSYM,JOBUSY,JOB41
 158 IFN REENT,<     EXTERN  JOBHRL,JOBCOR>
 159 IFE K,<EXTERN   JOBCHN          ;RH = PROG BREAK OF FIRST BLOCK DATA
 160                                 ;LH = PROG BREAK OF FIRST F4 PROG>
 161 IFN RPGSW,<     EXTERN  JOBERR>
 162 IFN LDAC,<      EXTERN  JOBBLT>
 163 IFN FAILSW,<    EXTERN  JOBAPR>
 164
 165 NEGOFF==400             ;NEGATIVE OFFSET OF HIGH SEGMENT
 166
 167
 168 IFN FAILSW,<;LENGTH OF PUSHDOWN LIST FOR POLISH FIXUPS
 169 PPDL==60>
 170
 171
 172 ;FLAGS  F(0 - 17)
 173         CSW==1                  ;ON - COLON SEEN
 174         ESW==2                  ;ON - EXPLICIT EXTENSION IDENT.
 175         SKIPSW==4               ;ON - DO NOT LOAD THIS PROGRAM
 176         FSW==10                 ;ON - SCAN FORCED TO COMPLETION
 177         FCONSW==20              ;ON - FORCE CONSOLE OUTPUT
 178 IFN REENT,<HIPROG==40   ;LOADING HI PROGRAM, SET BY HISEG. CLEARED BY EOF>
 179         ASW==100                ;ON - LEFT ARROW ILLEGAL
 180         FULLSW==200             ;ON - STORAGE EXCEEDED
 181         SLIBSW==400             ;ON - LIB SEARCH IN THIS PROG
 182         RMSMSW==1000            ;REMEMBER IF LOADING WITH SYMBOLS DURING LIB SEARCH
 183         REWSW==2000             ;ON - REWIND AFTER INIT
 184         LIBSW==4000             ;ON - LIBRARY SEARCH MODE
 185         NAMSSW==10000           ;NAME BLOCK HAS BEEN SEEN FOR THIS PROG
 186         ISW==20000              ;ON - DO NOT PERFORM INIT
 187         SYMSW==40000            ;ON - LOAD LOCAL SYMBOLS
 188         DSW==100000             ;ON - CHAR IN IDENTIFIER
 189         NSW==200000             ;ON - SUPPRESS LIBRARY SEARCH
 190         SSW==400000             ;ON - SWITCH MODE
 191
 192
 193 ;FLAGS  N(0 - 17)
 194         ALLFLG==1               ;ON - LIST ALL GLOBALS
 195         ISAFLG==2               ;ON - IGNORE STARTING ADDRESSES
 196         COMFLG==4               ;ON - SIZE OF COMMON SET
 197 IFE K,< F4SW==10                ;F4 IN PROGRESS
 198         RCF==20                 ;READ DATA COUNT
 199         SYDAT==40;              SYMBOL IN DATA>
 200         SLASH==100              ;SLASH SEEN
 201 IFE K,< BLKD1==200              ;ON- FIRST BLOCK DATA SEEN
 202         PGM1==400               ;ON FIRST F4 PROG SEEN
 203         DZER==1000              ;ON - ZERO SECOND DATA WORD>
 204         EXEQSW==2000            ;IMMEDIATE EXECUTION
 205         DDSW==4000              ;GO TO DDT
 206 IFN RPGSW,<RPGF==10000          ;IN RPG MODE>
 207         AUXSWI==20000           ;ON - AUX. DEVICE INITIALIZED
 208         AUXSWE==40000           ;ON - AUX. DEVICE ENTERED
 209 IFN PP,<PPSW==100000            ;ON - READING PROJ-PROG #>
 210 IFN PP!SPCHN,<PPCSW==200000     ;ON - READING PROJ #>
 211 IFN FAILSW,<HSW==400000         ;USED IN BLOCK 11 POLISH FIXUPS>
 212
 213
 214
 215 ;MORE FLAGS IN F (18-35)
 216 IFN REENT,<
 217 SEENHI==1               ;HAVE SEEN HI STUFF
 218 NOHI==2                 ;LOAD AS NON-REENTRANT>
 219 IFN RPGSW,<NOTTTY==4    ;DEV "TTY" IS NOT A TTY>
 220 NOHI6==10               ;PDP-6 TYPE SYSTEM
 221 IFN DMNSW,<HISYM==20    ;BLT SYMBOLS INTO HIGH SEGMENT>
 222 SEGFL==40               ;LOAD INTO HI-SEG>
 223 IFN DIDAL,<XFLG==100            ;INDEX IN CORE (BLOCK TYPE 14)
 224 LSTLOD==200             ;LAST PROG WAS LOADED
 225 DTAFLG==400             ;LIBRARY DEVICE IS A DTA (NEEDED FOR INDEXING)>
 226 IFN DMNSW,<DMNFLG==1000>        ;SYMBOL TABLE TO BE MOVED DOWN
 227 IFN REENT,<VFLG==2000   ;DO LIB SEARCH OF IMP40.REL BEFORE LIB40>
 228 IFN SYMARG,<ARGFL==4000 ;TREAT $%. AS RADIX-50 CHAR.>
 229 TWOFL==10000            ;TWO SEGMENTS IN THIS BINARY FILE
 230 LOCAFL==20000           ;PRINT LOCAL SYMBOLS IN MAP
 231 TTYFL==40000                    ;AUX. DEV. IS TTY
 232
 233
 234 IFE K,<F4FL==400000             ;FORTRAN SEEN>
 235 COBFL==200000                   ;COBOL SEEN
 236 IFN ALGSW,<ALGFL==100000        ;ALGOL SEEN>
 237
 238 DEFINE ERROR (X,Y)<
 239 JSP A,ERRPT'X
 240 SIXBIT Y>
 241
 242
 243
 244 IFE K,< TITLE   LOADER - LOADS MACRO AND FORTRAN FOUR>
 245 IFN K,< TITLE   1KLOAD - LOADS MACRO>
 246
 247 IFN PURESW,<
 248 IFE SEG2SW,<HISEG>
 249 IFN SEG2SW,<TWOSEGMENTS
 250         RELOC   400000>>
 251
 252
 253
 254 IFN SPCHN,<
 255 DSKBLK==200     ;LENGTH OF DISK BLOCKS
 256 VECLEN==↑D25  ;LENGTH OF VECTOR TABLE FOR OVERLAYS>
 257
 258 IFN SAILSW,<
 259 RELLEN==↑D5   ;#NUMBER OF REL FILES OR LIBRARIES (MUST BE SAME)>
 260
 261 ;CALLI DEFINITIONS
 262
 263 OPDEF   RESET   [CALLI   0]
 264 OPDEF   SETDDT  [CALLI   2]
 265 OPDEF   DDTOUT  [CALLI   3]
 266 OPDEF   DEVCHR  [CALLI   4]
 267 OPDEF   CORE    [CALLI  11]
 268 OPDEF   EXIT    [CALLI  12]
 269 OPDEF   UTPCLR  [CALLI  13]
 270 OPDEF   DATE    [CALLI  14]
 271 OPDEF   MSTIME  [CALLI  23]
 272 OPDEF   PJOB    [CALLI  30]
 273 OPDEF   SETUWP  [CALLI  36]
 274 OPDEF   REMAP   [CALLI  37]
 275 OPDEF   GETSEG  [CALLI  40]
 276 OPDEF   SETNAM  [CALLI  43]
 277 OPDEF   TMPCOR  [CALLI  44]
 278
 279
 280         MLON
 281 IFDEF SALL,<    SALL>
 282
 283
 284 SUBTTL  CCL INITIALIZATION
 285 IFN RPGSW,<
 286 BEG:    JRST    LD      ;NORMAL INITIALIZATION
 287 RPGSET: RESET           ;RESET UUO.
 288 IFN TEMP,<MOVEI F,CTLBUF-1      ;USE CCL BUFFER FOR COMMANDS
 289         HRRM F,CTLIN+1          ;DUMMY UP BYTE POINTER
 290         HRLI F,-200     ;MAKE IT AN IOWD
 291         MOVEM F,TMPFIL+1
 292         MOVSI F,(SIXBIT /LOA/)
 293         MOVEM F,TMPFIL
 294         MOVE N,[XWD 2,TMPFIL]   ;POINTER FOR TMPCOR READ
 295         TMPCOR  N,              ;READ AND DELETE LOA FILE
 296         JRST RPGTMP             ;NO SUCH FILE IN CORE, TRY DISK
 297         IMULI N,5               ;GET CHAR COUNT
 298         ADDI N,1
 299         MOVEM N,CTLIN+2         ;STORE IN BUFFER HEADER
 300         MOVEI N,700             ;BYTE POINTER FOR LOA FILE
 301         HRLM N,CTLIN+1          ;BYTE POINTER NOW COMPLETE
 302         SETOM TMPFLG            ;MARK THAT A TMPCOR READ WAS DONE
 303         SETZM NONLOD            ;NOT YET STARTED SCAN
 304         JRST RPGS3C             ;GET BACK IN MAIN STREAM
 305 RPGTMP: SETZM TMPFLG    ;MARK AS NOT TMP>
 306         INIT    17,1    ;SET UP DSK FOR COMMAND FILE INPUT.
 307         SIXBIT /DSK/
 308         XWD 0,CTLIN
 309         JRST    NUTS    ;CAN'T INIT, GET INPUT FROM TTY.
 310         MOVEI   F,3
 311         PJOB    N,      ;GET JOB NUMBER
 312 LUP:    IDIVI   N,12    ;STRIP OFF LAST DIGIT
 313         ADDI    N+1,"0"-40      ;CONVERT TO SIXBIT
 314         LSHC    N+1,-6  ;SAVE
 315         SOJG    F,LUP   ;3 DIGITS YET?
 316         HLLZ    N+2     ;YES.
 317         HRRI    (SIXBIT /LOA/)  ;LOADER NAME PART OF FILE NAME.
 318         MOVEM   CTLNAM
 319         MOVSI   (SIXBIT /TMP/)  ;AND EXTENSION.
 320         MOVEM   CTLNAM+1
 321         SETZM   CTLNAM+3
 322         LOOKUP  17,CTLNAM       ;FILE THERE?
 323         JRST    NUTS            ;NO.
 324         INIT 16,1       ;GET SET TO DELETE FILE
 325         SIXBIT /DSK/
 326         0
 327         JRST RPGS3A     ;GIVE UP
 328         SETZM CTLNAM+3  ;PUT STUFF BACK AS IT WAS
 329         LOOKUP 16,CTLNAM
 330         JRST RPGS3B
 331         SETZM CTLNAM    ;SET FOR RENAME
 332         RENAME 16,CTLNAM
 333         JFCL            ;IGNORE FAILURE
 334 RPGS3B: RELEASE 16,     ;GET RID OF DEVICE
 335 RPGS3A: SETZM   NONLOD          ;TO INDICATE WE HAVE NOT YET STARTED TO SCAN
 336                                 ;COMMAND IN FILE.
 337
 338
 339 RPGS3:  MOVEI   CTLBUF
 340         MOVEM   JOBFF
 341         INBUF   17,1            ;SET UP BUFFER.
 342 RPGS3C: TTCALL  3,[ASCIZ /LOADING/]     ;PRINT MESSAGE THAT WE ARE STARTING.
 343         SKIPE   NONLOD          ;CONTIUATION OF COMMAND?
 344         JRST    RPGS2           ;YES, SPECIAL SETUP.
 345 CCLCHN: MOVSI   N,RPGF          ;@ CHAIN FILES CYCLE FROM HERE
 346         JRST    CTLSET          ;SET UP TTY
 347
 348 RPGS1:  PUSHJ   P,[TLNE F,ESW   ;HERE FROM FOO@ COMMAND, STORE NAME.
 349                    JRST LDDT3   ;SAVE EXTENSION.
 350                    TLZE F,CSW!DSW  ;AS NAME
 351                    MOVEM W,DTIN ;STORE AS NAME
 352                    SETZM W,DTIN1        ;TRY BLANK EXTENSION FIRST.
 353                    JRST LDDT4]
 354         MOVEM   0,SVRPG         ;SAVE 0 JUST IN CASE
 355         SETZM   NONLOD          ;DETERMINE IF CONTINUATION.
 356         MOVEI   0,2(B)          ;BY SEEING IF ANY SYMBOLS LOADED.
 357         CAME    0,JOBREL
 358         SETOM   NONLOD          ;SET TO -1 AND SKIP CALLI
 359 IFN TEMP,<SETZM TMPFLG>
 360         MOVE    0,ILD1
 361         MOVEM   0,RPG1
 362         OPEN    17,OPEN1                ;KEEP IT PURE
 363         JRST    [MOVE   W,RPG1
 364                 JRST    ILD5]
 365         LOOKUP  17,DTIN         ;THE FILE NAME.
 366         JRST    [MOVE   0,SVRPG ;RESTORE AC0=F
 367                 TLOE    F,ESW   ;WAS EXT EXPLICIT?
 368                 JRST    ILD9    ;YES, DON'T TRY AGAIN.
 369                 MOVEM   0,SVRPG ;SAVE AC0 AGAIN
 370                 MOVSI   0,(SIXBIT /TMP/)        ;TRY TMP INSTEAD
 371                 MOVEM   0,DTIN1
 372                 PUSHJ P,LDDT4   ;SET UP PPN
 373                 JRST    .-1]    ;TRY AGAIN
 374         JRST    RPGS3
 375
 376 RPGS2:  MOVSI   0,RPGF  ;SET FLAG
 377         IORM    0,F.C+N
 378         TLO     N,RPGF
 379         MOVE    0,SVRPG
 380         JRST    LD2Q            ;BACK TO INPUT SCANNING.
 381
 382 >
 383
 384
 385
 386 SUBTTL NORMAL INITIALIZATION
 387
 388 LD:     IFE RPGSW,<BEG:>
 389 IFN L,< HRRZM 0,LSPXIT
 390         MOVEI 0,0
 391         HRRZM R,RINITL
 392         RESET>
 393 IFE L,<IFN RPGSW,<
 394         HLLZS   JOBERR          ;MAKE SURE ITS CLEAR.>
 395         RESET                   ;INITIALIZE THIS JOB
 396 NUTS:   SETZ    N,              ;CLEAR N
 397 CTLSET: SETZB   F,S             ;CLEAR THESE AS WELL
 398         HLRZ    X,JOBSA         ;TOP OF LOADER
 399         HRLI    X,V             ;PUT IN INDEX
 400         HRRZI   H,JOBDA(X)      ;PROGRAM BREAK
 401         MOVE    R,[XWD W,JOBDA] ;INITIAL RELOCATION
 402         MOVSI   E,(SIXBIT /TTY/)
 403         DEVCHR  E,
 404         TLNN    E,10            ;IS IT A REAL TTY?
 405 IFN RPGSW,<JRST [TLNN   F,RPGF  ;IN CCL MODE?>
 406                 EXIT            ;NO, EXIT IF NOT TTY
 407 IFN RPGSW,<     TRO F,NOTTTY    ;SET FLAG
 408                 JRST    LD1]    ;SKIP INIT>
 409         INIT    3,1             ;INITIALIZE CONSOLE
 410         SIXBIT    /TTY/
 411         XWD     BUFO,BUFI
 412 CALLEX: EXIT                    ;DEVICE ERROR, FATAL TO JOB
 413         MOVEI     E,TTY1
 414         MOVEM     E,JOBFF
 415         INBUF     3,1
 416         OUTBUF    3,1           ;INITIALIZE OUTPUT BUFFERS
 417         OUTPUT    3,                    ;DO INITIAL REDUNDANT OUTPUT
 418 LD1:
 419 IFE L,< HRRZ    B,JOBREL        ;MUST BE JOBREL FOR LOADING REENTRANT>
 420 IFN L,< MOVE    B,JOBSYM        ;USED INSTEAD OF JOBREL FOR SYMBOL TABLE FIXUPS>
 421         HRRZM   B,HISTRT
 422         SUB     B,SE3           ;INITIALIZE SYMBOL TABLE POINTER
 423         CAILE     H,1(B)        ;TEST CORE ALLOCATION>
 424         JRST    [HRRZ   B,JOBREL;TOP OF CORE
 425                 ADDI    B,2000  ;1K MORE
 426                 CORE    B,      ;TRY TO GET IT
 427                 EXIT            ;INSUFFICIENT CORE, FATAL TO JOB
 428                 JRST    LD1]    ;TRY AGAIN
 429 IFN EXPAND,<SETZ S,
 430         CORE    S,              ;GET PERMITTED CORE
 431         JFCL
 432         LSH     S,12
 433         SUBI    S,1             ;CONVERT TO NUMBER OF WORDS
 434         MOVEM   S,ALWCOR        ;SAVE IT FOR XPAND TEST>
 435 IFN PURESW,<MOVE S,[XWD HICODE,LOWCOD]
 436         BLT S,LOWCOD+CODLN-1>
 437 IFE L,< MOVS    E,X             ;SET UP BLT POINTER
 438         HRRI    E,1(X)>
 439 IFN L,<MOVS E,H
 440         HRRI E,1(H)>
 441         SETZM     -1(E)                 ;ZERO FIRST WORD
 442         BLT     E,(B)           ;ZERO CORE UP TO THE SYMBOL AREA
 443         HRRZ    S,B             ;INITIALIZE UNDEF. POINTER
 444         HRR     N,B             ;INITIALIZE PROGRAM NAME POINTER
 445 IFE L,< HRRI    R,JOBDA         ;INITIALIZE THE LOAD ORIGIN
 446         MOVE    E,COMM          ;SET .COMM. AS THE FIRST PROGRAM
 447         MOVEM     E,1(B)                ;STORE IN SYMBOL TABLE
 448         HRRZM     R,2(B)                ;STORE COMMON ORIGIN>
 449         MOVEI     E,F.C         ;INITIALIZE STATE OF THE LOADER
 450         BLT     E,B.C
 451         SETZM   MDG             ;MULTIPLY DEFINED GLOBAL COUNT
 452         SETZM   STADDR          ;CLEAR STARTING ADDRESS
 453 IFN REENT,<MOVSI W,1
 454         MOVEM W,HVAL1
 455         MOVEM W,HVAL
 456         MOVEM X,LOWX
 457         SETZM HILOW
 458         MOVEM R,LOWR
 459         HRRZI   W,1
 460         SETUWP  W,              ;SETUWP UUO.
 461         TRO     F,NOHI6         ;PDP-6 COMES HERE.
 462         MOVEM   F,F.C           ;PDP-10 COMES HERE.>
 463 IFN SAILSW,<MOVE W,[XWD -RELLEN-1,LIBFLS-1]     ;SET UP POINTERS
 464         MOVEM W,LIBPNT# ;IN THE FORM OF AOBJN WORDS
 465         MOVE W,[XWD -RELLEN-1,PRGFLS-1]
 466         MOVEM W,PRGPNT#>
 467 IFE L,< MOVSI   W,254200        ;STORE HALT IN JOB41
 468         MOVEM   W,JOB41(X)      ;...>
 469 IFN L,< MOVE W,JOBREL
 470         HRRZM W,OLDJR>
 471 IFN SPCHN,<SETZM CHNACB ;USED AS DEV INITED FLAG TOO>
 472 IFN NAMESW,<SETZM       CURNAM>
 473 IFN FAILSW,<MOVEI W,440000      ;SET UP THE SPECIAL BITS OF HEADNUM(ADD+POLISH)
 474         MOVEM   W,HEADNM
 475         SETZM   POLSW   ;SWITCH SAYS WE ARE DOING POLISH
 476         MOVEI   W,PDLOV ;ENABLE FOR PDL OV
 477         MOVEM   W,JOBAPR
 478         MOVEI   W,200000
 479         CALLI   W,16
 480         SETZM LINKTB    ;ZERO OUT TABLE OF LINKS
 481
 482
 483         MOVE W,[XWD LINKTB,LINKTB+1]
 484         BLT W,LINKTB+20>
 485 IFN DMNSW,<MOVEI W,SYMPAT
 486         MOVEM W,KORSP>
 487 IFN KUTSW,<SETOM CORSZ>
 488
 489
 490 IFN RPGSW,<JRST LD2Q>
 491 LD2:    IFN RPGSW,<MOVSI B,RPGF ;HERE ON ERRORS, TURN OFF RPG
 492         ANDCAM B,F.C+N  ;IN CORE>
 493 ;LOADER SCAN FOR FILE NAMES
 494
 495 LD2Q:   MOVSI     B,F.C         ;RESTORE ACCUMULATORS
 496         BLT     B,B
 497         MOVE    P,PDLPT         ;INITIALIZE PUSHDOWN LIST
 498         SETZM     BUFI2         ;CLEAR INPUT BUFFER POINTER
 499 IFE PP,<        SETZM     ILD1          ;CLEAR INPUT DEVICE NAME>
 500 IFN PP,<        MOVSI   T,(SIXBIT /DSK/)        ;ASSUME DSK.
 501         MOVEM   T,ILD1
 502         SETZM   OLDDEV  ;TO MAKE IT GO BACK AFTER /D FOR LIBSR>
 503         SETZM     DTIN          ;CLEAR INPUT FILE NAME
 504
 505 LD2B:   RELEAS    1,                    ;RELEASE BINARY INPUT DEVICE
 506 IFN RPGSW,<     TLNE    N,RPGF          ;NOT IF DOING CCL STUFF
 507         JRST    LD2BA>
 508         MOVEI     T,"*"
 509         IDPB    T,BUFO1         ;OUTPUT ASTERISK TO START INPUT
 510         OUTPUT    3,
 511 LD2BA:  TLZ     F,FULLSW+ASW+ISW+CSW+ESW+SKIPSW+SLIBSW+REWSW
 512 LD2BP:  TLNE    F,LIBSW         ;WAS LIBRARY MODE ON?
 513         TLO     F,SKIPSW        ;YES, NORMAL MODE IS SKIPPING
 514
 515 LD2D:   IFN PP,<SETZM   PPN             ;DON'T REMEMBER PPN FROM ONE FILE TO NEXT.
 516 LD2DB:  SKIPE   W,OLDDEV                ;RESET DEVICE IF NEEDED.
 517         CAMN    W,ILD1          ;IS IT SAME?
 518         JRST    LD2DA           ;YES, FORGET IT.
 519         TLZ     F,ISW+DSW+FSW+REWSW
 520         MOVEM   W,ILD1>
 521 LD2DA:  MOVEI     W,0           ;INITIALIZE IDENTIFIER SCAN
 522         MOVEI     E,6           ;INITIALIZE CHARACTER COUNTER
 523         MOVE    V,LSTPT         ;INITIALIZE BYTE POINTER TO W
 524         TLZ     F,SSW+DSW+FSW   ;LEAVE SWITCH MODE
 525 LD3:    IFN RPGSW,<TLNE N,RPGF  ;CHECK RPG FEATURE
 526         JRST    RPGRD>
 527         SOSG    BUFI2           ;DECREMENT CHARACTER COUNTER
 528         INPUT     3,                    ;FILL TTY BUFFER
 529         ILDB    T,BUFI1         ;LOAD T WITH NEXT CHARACTER
 530 LD3AA:  CAIN    T,175   ;OLD ALTMOD
 531         MOVEI   T,33    ;NEW ONE
 532         CAIL    T,140   ;LOWER CASE?
 533         TRZ     T,40    ;CONVERT TO UPPER CASE
 534         MOVE    Q,T
 535         HRLM    Q,LIMBO         ;SAVE THIS CHAR.
 536         MOVSS   LIMBO           ;AND LAST ONE
 537         IDIVI     Q,11          ;TRANSLATE TO 4 BIT CODE
 538         LDB     Q,LD8(A)                ;LOAD CLASSIFICATION CODE
 539         CAIGE     Q,4           ;MODIFY CODE IF .GE. 4
 540         TLNN    F,SSW           ;MODIFY CODE IF SWITCH MODE OFF
 541         ADDI    Q,4             ;MODIFY CLASS. CODE FOR DISPATCH
 542 IFN SYMARG,<CAIL Q,20                   ;SKIP UNLESS SECOND FORM OF DISPATCH
 543         JRST    LD3AB                   ;DIFFERENT DISPATCH>
 544         HRRZ    A,LD3A(Q)               ;LOAD RH DISPATCH ENTRY
 545         CAIL    Q,10            ;SKIP IF CORRECT DISPATCH ENTRY
 546         HLRZ    A,LD3A-10(Q)    ;LOAD LH DISPATCH ENTRY
 547         JRST    @A                      ;JUMP TO INDICATED LOCATION
 548
 549 ;COMMAND DISPATCH TABLE
 550
 551 LD3A:   XWD     LD3,LD7B                ;IGNORED CHAR, BAD CHAR (SWITCH)
 552         XWD     LD6A,LD6                ;</> OR <(>, LETTER (SWITCH)
 553         XWD     LD5,LD6C                ;<:>, DIGIT (SWITCH ARG.)
 554         XWD     LD5A,LD6D               ;<.>, ESCAPE SWITCH MODE <)>
 555         XWD     LD5C,LD7                ;<=> OR <L. ARROW>, BAD CHAR.
 556         XWD     LD5B,LD4                ;<,>, ALPHABETIC CHAR.
 557         XWD     LD5D,LD4                ;<CR.>, NUMERIC CHAR.
 558         XWD     LD5E1,LD7               ;<ALT MODE>, BAD CHAR. <)>
 559 IFN SYMARG,<XWD LD7,LD10                ;BAD CHAR,&>
 560
 561 IFN RPGSW,<
 562 RPGRD1: MOVNI T,5
 563         ADDM T,CTLIN+2
 564         AOS     CTLIN+1
 565 RPGRD:  SOSG    CTLIN+2 ;CHECK CHARACTER COUNT.
 566         JRST    [IFN TEMP,<SKIPE TMPFLG ;TMPCOR UUO READ DONE?
 567                 JRST LD2        ;YES, JUST LEAVE>
 568                 IN 17,0
 569                 JRST .+1
 570                 STATO 17,740000
 571                 JRST LD2
 572                 JSP A,ERRPT
 573                 SIXBIT /ERROR WHILE READING COMMAND FILE%/
 574                 JRST LD2]
 575         IBP     CTLIN+1 ;ADVANCE POINTER
 576
 577
 578         MOVE    T,@CTLIN+1      ;AND CHECK FOR LINE #
 579
 580
 581         TRNE    T,1
 582         JRST    RPGRD1
 583         LDB     T,CTLIN+1       ;GET CHR
 584         JRST    LD3AA           ;PASS IT ON>
 585 IFN SYMARG,<
 586 LD3AB:  ROT     Q,-1                    ;CUT Q IN HALF
 587         HRRZ    A,LD3A(Q)               ;PULL OFF RIGHT HALF OF TABLE ENTRY
 588         JUMPGE  Q,@A                    ;WHICH IS CORRECT FOR EVEN ENTRIES
 589         HLRZ    A,LD3A(Q)               ;BUT USE LEFT HALF FOR ODD ENTRIES
 590         JRST    @A>
 591
 592
 593 SUBTTL  CHARACTER HANDLING
 594
 595 ;ALPHANUMERIC CHARACTER, NORMAL MODE
 596 LD4:    SOJL    E,LD3           ;JUMP IF NO SPACE FOR CHAR IN W
 597         CAIGE   T,141           ;WORRY ABOUT LOWER CASE LETTERS
 598         SUBI    T,40            ;CONVERT FROM ASCII TO SIXBIT
 599         IDPB    T,V             ;DEPOSIT CHAR OF IDENTIFIER IN W
 600         TLO     F,DSW           ;SET IDENTIFIER FLAG
 601         JRST    LD3             ;RETURN FOR NEXT CHARACTER
 602
 603 ;DEVICE IDENTIFIER DELIMITER <:>
 604
 605 LD5:    PUSH    P,W             ;SAVE W
 606         TLOE    F,CSW           ;TEST AND SET COLON FLAG
 607         PUSHJ     P,LDF         ;FORCE LOADING
 608         POP     P,W             ;RESTORE W
 609         TLNE    F,ESW           ;TEST SYNTAX
 610         JRST    LD7A            ;ERROR, MISSING COMMA ASSUMED
 611         JUMPE     W,LD2D                ;JUMP IF NULL DEVICE IDENTIFIER
 612         MOVEM     W,ILD1                ;STORE DEVICE IDENTIFIER
 613 IFN PP,<MOVEM   W,OLDDEV        ;WE HAVE A NEW ONE, DO IGNORE OLD.>
 614         TLZ     F,ISW+DSW+FSW+REWSW     ;CLEAR OLD DEVICE FLAGS
 615         JRST    LD2D            ;RETURN FOR NEXT IDENTIFIER
 616
 617 ;FILE NAME EXTENSION IDENTIFIER DELIMITER <.>
 618 LD5A:   IFN SYMARG,<
 619         TRNE    F,ARGFL         ;IS "." SPECIAL
 620         JRST    LD4             ;YES,RADIX-50>
 621         TLOE    F,ESW           ;TEST AND SET EXTENSION FLAG
 622         JRST    LD7A            ;ERROR, TOO MANY PERIODS
 623         TLZE    F,CSW+DSW       ;SKIP IF NULL IDENT AND NO COLON
 624         MOVEM     W,DTIN        ;STORE FILE IDENTIFIER
 625         JRST    LD2D            ;RETURN FOR NEXT IDENTIFIER
 626
 627 ;INPUT SPECIFICATION DELIMITER <,>
 628 LD5B:
 629 IFN PP,<TLZE    N,PPCSW                 ;READING PP #?
 630         JRST    [
 631 IFE STANSW,<    HRLM    D,PPN           ;STORE PROJ #
 632                 JRST    LD6A1           ];GET PROG #>
 633 IFN STANSW,<    PUSHJ   P,RJUST         ;RIGHT JUSTIFY W
 634                 HRLM    W,PPN           ;STORE PROJ NAME
 635                 JRST    LD2DB           ];GET PROG NAME>
 636         PUSHJ   P,RBRA          ;CHECK FOR MISSING RBRA>
 637         SETOM   LIMBO           ;USED TO INDICATE COMMA SEEN
 638         TLZN    F,FSW           ;SKIP IF PREV. FORCED LOADING
 639         PUSHJ     P,FSCN2               ;LOAD (FSW NOT SET)
 640         JRST    LD2BP           ;RETURN FOR NEXT IDENTIFIER
 641
 642 LD5B1:  TLNE    F,ESW           ;TEST EXTENSION FLAG
 643         JRST    LDDT3           ;EXPLICIT EXTENSION IDENTIFIER
 644         TLZN    F,CSW+DSW               ;SKIP IF IDENT. OR COLON
 645         POPJ    P,
 646         MOVEM     W,DTIN                ;STORE FILE IDENTIFIER
 647         JRST    LDDT2           ;ASSUME <.REL> IN DEFAULT CASE
 648
 649
 650 ;OUTPUT SPECIFICATION DELIMITER <=> OR <LEFT ARROW>
 651 ;OR PROJ-PROG # BRACKETS <[> AND <]>
 652
 653 LD5C:
 654 IFN SPCHN,<CAIN T,"="   ;DO A /= AS SWITCH
 655         TLNN F,SSW
 656         SKIPA
 657         JRST LD6>
 658 IFN RPGSW,<CAIN T,"@"   ;CHECK FOR * COMMAND.
 659         JRST    RPGS1>
 660 IFN PP,<CAIN    T,"["                   ;PROJ-PROG #?
 661         JRST    [TLO    N,PPSW+PPCSW    ;SET FLAGS
 662                 MOVEM   W,PPNW          ;SAVE W
 663                 MOVEM   E,PPNE          ;SAVE E
 664                 MOVEM   V,PPNV          ;SAVE V
 665 IFE STANSW,<    JRST    LD6A2]>         ;READ NUMBERS AS SWITCHES
 666 IFN STANSW,<    JRST    LD2DB]>
 667         CAIN    T,"]"                   ;END OF PP #?
 668         JRST    [PUSHJ  P,RBRA          ;PROCESS RIGHT BRACKET
 669                 JRST    LD3]            ;READ NEXT IDENT>
 670         TLOE    F,ASW                   ;TEST AND SET LEFT ARROW FLAG
 671         JRST    LD7A                    ;ERROR, MISPLACED LEFT ARROW
 672         PUSHJ     P,LD5B1               ;STORE IDENTIFIER
 673         TLZN    F,ESW                   ;TEST EXTENSION FLAG
 674         MOVSI     W,554160              ;ASSUME <.MAP> IN DEFAULT CASE
 675         MOVEM     W,DTOUT1              ;STORE FILE EXTENSION IDENTIFIER
 676         MOVE    W,DTIN                  ;LOAD INPUT FILE IDENTIFIER
 677         MOVEM     W,DTOUT               ;USE AS OUTPUT FILE IDENTIFIER
 678 IFN SPCHN,<MOVEM W,CHNENT       ;AND FOR SPECAIL CHAINING>
 679 IFN PP,<MOVE    W,PPN                   ;PROJ-PROG #
 680         MOVEM   W,DTOUT+3               ;...>
 681         MOVE    W,ILD1                  ;LOAD INPUT DEVICE IDENTIFIER
 682         MOVEM   W,LD5C1                 ;USE AS OUTPUT DEVICE IDENTIFIER
 683 IFN PP,<SKIPE   W,OLDDEV                ;RESTORE OLD
 684         MOVEM   W,ILD1>
 685 ;INITIALIZE AUXILIARY OUTPUT DEVICE
 686         TRZ     F,TTYFL
 687         TLZE    N,AUXSWI+AUXSWE         ;FLUSH CURRENT DEVICE
 688         RELEASE 2,                      ;...
 689         DEVCHR  W,                      ;IS DEVICE A TTY?
 690         TLNE    W,10                    ;...
 691         JRST    [TRO    F,TTYFL         ;TTY IS AUX. DEV.
 692                 JRST    LD2D]           ;YES, SKIP INIT
 693         OPEN    2,OPEN2                 ;KEEP IT PURE
 694         JRST    ILD5A
 695         TLNE    F,REWSW                 ;REWIND REQUESTED?
 696         UTPCLR  2,                      ;DECTAPE REWIND
 697         TLZE    F,REWSW                 ;SKIP IF NO REWIND REQUESTED
 698         MTAPE   2,1                     ;REWIND THE AUX DEV
 699         MOVEI   E,AUX                   ;SET BUFFER ORIGIN
 700         MOVEM     E,JOBFF
 701         OUTBUF  2,1                     ;INITIALIZE SINGLE BUFFER
 702         TLO     N,AUXSWI                        ;SET INITIALIZED FLAG
 703 IFN LNSSW,<EXCH E,JOBFF
 704         SUBI    E,AUX
 705         IDIV    C,E
 706         OUTBUF  2,(C)>
 707         JRST    LD2D                    ;RETURN TO CONTINUE SCAN
 708
 709
 710
 711 ;RIGHT SQUARE BRACKET (PROJ-PROG NUMBERS)
 712 IFN PP,<
 713 RBRA:   TLZN    N,PPSW          ;READING PP #?
 714         POPJ    P,              ;NOPE, RETURN
 715         TLZE    N,PPCSW         ;COMMA SEEN?
 716         JRST    LD7A            ;NOPE, INDICATE ERROR
 717 IFE STANSW,<HRRM        D,PPN           ;STASH PROG NUMBER
 718                 TLZ     F,SSW   ;AND TURN OFF SWITCH MODE>
 719 IFN STANSW,<PUSHJ       P,RJUST         ;RIGHT JUSTIFY W
 720         HRRM    W,PPN           ;STASH PROG NAME>
 721         MOVE    W,PPNW          ;PICKUP OLD IDENT
 722         MOVE    E,PPNE          ;RESTORE CHAR COUNT
 723         MOVE    V,PPNV          ;RESTORE BYTE PNTR
 724         POPJ    P,              ;TRA 1,4
 725
 726 ;RIGHT JUSTIFY W
 727
 728 IFN STANSW,<
 729 RJUST:  JUMPE   W,LD7A          ;NOTHING TO RIGHT JUSTIFY
 730         TRNE    W,77            ;IS W RJUSTED YET?
 731         POPJ    P,              ;YES, TRA 1,4
 732         LSH     W,-6            ;NOPE, TRY AGAIN
 733         JRST    .-3             ;...>>
 734
 735 IFN SYMARG,<
 736 ;& SELECTS A SYMBOL RATHER THAN ANUMBER FOR A SWITCH ARGUMENT
 737 ;& MUST ALSO FOLLOW THW SYMBOL; THE FORM IS /&SYMBOL&SWITHCH
 738 LD10:   TRC     F,ARGFL         ;SET OR CLEAR SPECIAL CHARS.
 739         TLCE    F,SSW           ;IF IN SWITCH MODE, EXIT TO GET IDENTIFIER
 740         JRST    LD10B
 741         PUSHJ   P,ASCR50        ;IF NOT, REENTER IT, CONVERT IDENTIFIER TO R50
 742         PUSHJ   P,SDEF          ;AND SEE IF IT EXISTS
 743         JRST    LD10A           ;YES IT DOES
 744         PUSHJ   P,PRQ           ;NO, COMPLAIN. OUTPUT ?
 745         PUSHJ   P,SPACE         ;FOLLOWED BY A SPACE
 746         PUSHJ   P,PRNAME        ;FOLLOWED BY THIS SYMBOL
 747         ERROR   0,</ DOESN'T EXIST@/>
 748         JRST    LD2
 749 LD10A:  MOVE    D,2(A)          ;SET D=VALUE OF SYMBOL AS NUMERIC ARG
 750         TLZ     F,DSW!FSW
 751         MOVEI   E,6             ;INITIALIZE NEW IDENTIFIER SCAN
 752         MOVE    V,LSTPT         ;(W IS ALREADY 0)
 753         JRST    LD3             ;NOW EAT SWITCH AND CONTINUE PROCESSING COMMAND
 754 LD10B:  PUSHJ   P,FSCN1         ;FORCE SCAN TO COMPLETION TO MAKE SURE FILE IS LOADED
 755         JRST    LD2DA>
 756
 757
 758
 759         IFN SYMARG,<
 760 ;CONVERT SYMBOL IN W TO RADIX-50 IN C
 761 ;ALSO USES A
 762 ASCR50: MOVEI   A,0
 763 R50A:   MOVEI   C,0
 764         ROTC    W,6             ;C IS NEXT SIXBIT CHAR
 765         CAIGE   C,20
 766         JRST    R50B            ;UNDER 20, MAY BE ., $, OR %
 767         CAILE   C,31
 768         JRST    R50C            ;OVER 31
 769         SUBI    C,20-1          ;IS NUMBER
 770 R50D:   IMULI   A,50
 771         ADD     A,C
 772         JUMPN   W,R50A          ;LOOP FOR ALL CHARS
 773         MOVE    C,A             ;WIND UP WITH CHAR IN C
 774         TLO     C,040000        ;MAKE IT GLOBAL DEFINITION
 775         POPJ    P,
 776 R50B:   JUMPE   C,R50D          ;OK IF SPACE
 777         CAIE    C,16            ;TEST IF .
 778         JRST    .+3             ;NO
 779         MOVEI   C,45            ;YES
 780         JRST    R50D
 781         CAIE    C,4             ;SKIP IF $
 782 R50E:   MOVEI   C,5             ;ASSUME % IF NOTHING ELSE
 783         ADDI    C,42
 784         JRST    R50D
 785 R50C:   CAIGE   C,41
 786         JRST    R50E            ;BETWEEN 31 AND 41
 787         CAILE   C,72
 788         JRST    R50E            ;OVER 72
 789         SUBI    C,41-13         ;IS LETTER
 790         JRST    R50D>
 791
 792 ;DEFINE PUTS A SYMBOL IN THE UNDEFINED SYMBOL TABLE
 793 ;SO LOADER CAN SCAN LIBRARY AND LOAD PROGRAMS BEFORE THEY ARE REQUESTED
 794 ;THE FORM IS /&SYMBOL# WHERE SYMBOL IS CONVERTED TO RADIX-50
 795 IFN SYMARG,<
 796 DEFINE: PUSHJ   P,ASCR50        ;CONVRT TO R-50
 797         MOVEI   W,-2(S)         ;WHERE SYMBOL WILL GO
 798         CAIG    W,(H)           ;ENOUGH ROOM
 799 IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
 800                 TLOA    F,FULLSW
 801                 JRST    POPJM3
 802                 POPJ    P,]>
 803 IFE EXPAND,<TLO F,FULLSW>
 804         SUB     S,SE3           ;ADJUST POINTER
 805         MOVEM   C,1(S)          ;R-50 SYMBOL
 806         SETZM   2(S)            ;VALUE
 807         TLZ     F,DSW!SSW       ;TURN OFF SWITCHES
 808         JRST    LD2D            ;CONTINUE TO SCAN
 809 >
 810
 811
 812 SUBTTL  TERMINATION
 813 ;LINE TERMINATION <CARRIAGE RETURN>
 814
 815 LD5D:
 816 IFN PP,<PUSHJ   P,RBRA          ;CHECK FOR UNTERMINATED PP #>
 817         SKIPGE  LIMBO           ;WAS LAST CHAR. BEFORE CR A COMMA?
 818         TLO     F,DSW           ;YES ,SO LOAD ONE MORE FILE
 819         PUSHJ   P,FSCN          ;FORCE SCAN TO COMPLETION
 820         JRST    LD2B            ;RETURN FOR NEXT LINE
 821
 822 ;TERMINATE LOADING <ALT MODE>
 823
 824 LD5E:   JUMPE   D,LD5E1         ;ENTER FROM G COMMAND
 825         TLO     N,ISAFLG        ;AND IGNORE ANY STARTING ADDRESS TO COME
 826         HRRZM   D,STADDR        ;USE NUMERIC STARTING ADDRESS
 827 LD5E1:  PUSHJ   P,CRLF          ;START A NEW LINE
 828 IFN RPGSW,<RELEASE 17,0         ;RELEASE COMMAND DEVICE>
 829         PUSHJ   P,SASYM         ;SETUP JOBSA,JOBFF,JOBSYM,JOBUSY
 830         MOVE    W,[SIXBIT ?LOADER?]     ;FINAL MESSAGE
 831         PUSHJ P,BLTSET          ;SETUP FOR FINAL BLT
 832         RELEASE 2,              ;RELEASE AUX. DEV.
 833         RELEASE 1,0     ;INPUT DEVICE
 834         RELEASE 3,0     ;TTY
 835 IFN SPCHN,<RELEASE 4,0  ;SPECIAL CHAINING CHANEL>
 836 IFN NAMESW,<HRRZ        W,HISTRT        ;IN CASE NO NAME SET, USE FIRST LOADED
 837         MOVE    W,-1(W)
 838         SKIPN   CURNAM
 839         PUSHJ   P,LDNAM
 840         SKIPE   W,CURNAM
 841         CAMN    W,[SIXBIT /MAIN/]       ;FORTRAN MAIN PROG, OR MACRO NO TITLE
 842         SKIPE   W,PRGNAM        ;USE BINARY FILE NAME IN EITHER CASE
 843         SETNAM  W,                      ;SETNAME>
 844 IFN L,<JRST @LSPXIT>
 845
 846
 847 IFN PURESW,<
 848         MOVE    V,[XWD HHIGO,HIGO]
 849         BLT     V,HIGONE        ;MOVE DOWN CODE TO EXIT>
 850         TLNN N,EXEQSW   ;DO WE WANT TO START
 851         JRST LD5E3
 852 IFN RPGSW,<TLNN N,RPGF  ;IF IN RPG MODE
 853         JRST LD5E2
 854         HRRZ C,JOBERR   ;CHECK FOR ERRORS
 855         JUMPE C,LD5E2   ;NONE
 856 EXDLTD: TTCALL 3,[ASCIZ /?EXECUTION DELETED
 857 /]
 858         JRST LD5E3>
 859 LD5E2:  HRRZ W,JOBSA(X)
 860         TLNE N,DDSW     ;SHOULD WE START DDT??
 861         HRRZ W,JOBDDT(X)
 862 IFN RPGSW,<     TLNE    N,RPGF  ;IF IN RPG MODE
 863         JUMPE   W,[TTCALL 3,[ASCIZ /?NO STARTING ADDRESS
 864 /]
 865                 JRST    EXDLTD]>
 866         JUMPE   W,LD5E3 ;ANYTHING THERE?
 867         TLOA W,(JRST)   ;SET UP A JRST
 868 LD5E3:  SKIPA W,CALLEX  ;NO OR NO EXECUTE, SET CALLI 12
 869         TTCALL 3,[ASCIZ /EXECUTION
 870 /]
 871 IFN LDAC,<      HRLZ P,BOTACS   ;SET UP FOR ACBLT
 872         MOVEM W,JOBBLT+1(X)     ;SET JOBBLT
 873         MOVE W,[BLT P,P]
 874         MOVEM W,JOBBLT(X)>
 875         MOVSI LSTAC,LODACS      ;SET UP TO BLT BLT CODE INTO ACS
 876         BLT LSTAC,LSTAC
 877 IFN KUTSW,<SKIPGE E,CORSZ       ;DO WE WANT CORE ADJUST
 878         MOVE CORAC,JFCLAC       ;NO, CLEAR COREUUO>
 879 IFE LDAC,<MOVE LSTAC,W          ;SET END CONDITION>
 880 IFN REENT,<
 881         MOVSI   V,LD            ;DOES IT HAVE HISEG
 882         JUMPG   V,HINOGO        ;NO,DON'T DO CORE UUO
 883         MOVSI   V,1             ;SET HISEG CORE NONE ZERO
 884         JRST    HIGO            ;AND GO>
 885 IFE REENT,<JRST 0>
 886
 887 LODACS: PHASE 0
 888         BLT Q,(A)       ;BLT CODE DOWN
 889 IFN KUTSW,<CORAC:       CORE E, ;CUT BACK CORE
 890 JFCLAC: JFCL    ;SHOULD NEVER HAVE AN ERROR SINCE REDUCING CORE>
 891 LSTAC: IFN LDAC,<JRST JOBBLT>
 892 IFE LDAC,<EXIT>
 893 DEPHASE
 894
 895
 896 SUBTTL  PRINT FINAL MESSAGE
 897 ; SET UP BLT AC'S, SETDDT, RELEAS
 898
 899 BLTSET: IFN RPGSW,<IFE K,<
 900         JUMPE   W,.+4   ;NO MESSAGE FROM CHAIN IN CCL@>>
 901         PUSHJ P,FCRLF   ;A RETURN
 902         PUSHJ P,PWORD   ;AND CHAIN OR LOADER
 903         PUSHJ P,SPACE
 904 IFN FAILSW,<MOVSI Q,-20 ;FINISH UP LINK STUFF
 905 FREND:  HLRZ V,LINKTB+1(Q)
 906         JUMPE V,NOEND
 907         HRRZ A,LINKTB+1(Q)
 908 IFN REENT,<CAMGE V,HVAL1
 909         SKIPA X,LOWX
 910         MOVE X,HIGHX>
 911 IFN L,<CAML V,RINITL>
 912         HRRM A,@X       ;PUT END OF LINK CHAIN IN PROPER PLACE
 913 NOEND:  AOBJN Q,FREND
 914 IFN REENT,<MOVE X,LOWX  ;RESET THINGS>>
 915 IFN KUTSW,<SKIPGE C,CORSZ       ;NEG MEANS DO NOT KUT BACK CORE
 916         JRST NOCUT
 917         JUMPE C,MINCUT  ;0 IS KUT TO MIN. POSSIBLE
 918         LSH C,12        ;GET AS A NUMBER OF WORDS
 919         SUBI C,1
 920         CAMG C,JOBREL   ;DO WE NEED MORE THAN WE HAVE??
 921         JRST TRYSML     ;NO, SEE IF NUMBER REQUESTED IS TOO SMALL
 922         MOVEI Q,0
 923         CORE Q,
 924         JFCL            ;WE JUST WANT TO KNOW HOW MUCH
 925         HRRZS Q
 926         CAMGE Q,CORSZ
 927         JRST CORERR
 928         JRST NOCUT1     ;SET FOR DO NOT CHANGE SIZE
 929 TRYSML: CAIG C,(R)      ;IS DESIRED AMOUNT BIGGER THAN NEEDED
 930 MINCUT: HRRZ C,R        ;GET MIN AMOUNT
 931         IORI C,1777     ;CONVERT TO A 1K MULTIPLE
 932 IFN DMNSW,<     TRNN F,DMNFLG   ;DID WE MOVE SYMBOLS??
 933         SKIPN JOBDDT(X) ;IF NOT IS DDT THERE??
 934         JRST    .+2>
 935 IFE DMNSW,<SKIPE JOBDDT(X)      ;IF NO SYMBOL MOVING JUST CHECK DDT>
 936         JRST NOCUT      ;DO NOT CUT IF SYMBOLS AT TOP AND DDT
 937 NOCUT1: MOVEM C,JOBREL(X)       ;SAVE FOR CORE UUO
 938         MOVEM C,CORSZ   ;SAVE AWAY FOR LATER
 939         JRST    .+2
 940 NOCUT:  SETOM CORSZ     ;SET FOR NO CUT  BACK>
 941 IFN RPGSW,<IFE K,<
 942         JUMPE   W,NOMAX ;NO MESSAGE IF CHAIN IN CCL@>>
 943 IFN L,<HRRZ Q,JOBREL
 944         SUB Q,OLDJR     ;PROPER SIZE>
 945 IFE L,<HRRZ Q,JOBREL(X)
 946         LSH Q,-12       ;GET CORE SIZE TO PRINT
 947         ADDI Q,1
 948         PUSHJ P,RCNUM
 949 IFN REENT,<MOVE Q,HVAL
 950         SUB Q,HVAL1
 951         HRRZS Q
 952         JUMPE   Q,NOHY          ;NO HIGH SEGMENT
 953         MOVEI   T,"+"-40        ;THERE IS A HISEG
 954         PUSHJ   P,TYPE
 955         LSH     Q,-12
 956         ADDI    Q,1
 957         PUSHJ   P,RCNUM
 958 NOHY:>>
 959         MOVE W,[SIXBIT /K CORE/]
 960         PUSHJ P,PWORD
 961         PUSHJ P,CRLF
 962 IFE L,<
 963 IFN RPGSW,<TLNE N,RPGF
 964         JRST NOMAX      ;DO NOT PRINT EXTRA JUNK IN RPG MODE>
 965         MOVE Q,JOBREL
 966         LSH Q,-12
 967         ADDI Q,1
 968         PUSHJ P,RCNUM   ;PRINT MAX LOW CORE SIZE
 969 IFN REENT,<     SKIPE Q,JOBHRL  ;GET SIZE OF HIGH SEGMENT
 970         PUSHJ P,[MOVEI Q,400001(Q) ;CLEAR HIGH ORDER BIT
 971                 MOVEI T,"+"-40  ;PRINT A HIGH CORE PART
 972                 PUSHJ P,TYPE
 973                 LSH Q,-12
 974                 JRST RCNUM]>
 975         MOVE W,[SIXBIT /K MAX/]
 976         PUSHJ P,PWORD
 977 IFN DMNSW,<TRNN F,DMNFLG>
 978         SKIPN JOBDDT(X)
 979         SKIPA Q,JOBREL(X)>
 980         MOVEI Q,1(S)    ;FIND THE AMOUNT OF SPACE LEFT OVER
 981         SUB Q,JOBFF(X)
 982         PUSHJ P,RCNUM
 983         MOVE W,[SIXBIT / WORDS/]
 984         PUSHJ P,PWORD
 985         MOVE W,[SIXBIT / FREE/]
 986         PUSHJ P,PWORD
 987         PUSHJ P,CRLF
 988 NOMAX:  MOVE W,JOBDDT(X)
 989         SETDDT W,
 990 IFE TEN30,<HRLI Q,20(X) ;SET UP BLT FOR CODE
 991         HRRI Q,20>
 992 IFN TEN30,<HRLI Q,JOBDDT(X)
 993         HRRI Q,JOBDDT>
 994         HRRZ A,R
 995         POPJ P,         ;WE HAVE SET R UP BY CLEVER CODE IN SASYM
 996 IFN KUTSW,<CORERR:      TTCALL 3,[ASCIZ /?NOT ENOUGH CORE
 997 /]
 998         EXIT>
 999
1000
1001 SUBTTL  SET UP JOBDAT
1002 SASYM:  TLNN F,NSW
1003         PUSHJ P,LIBF    ;SEARCH LIBRARY IF REQUIRED
1004         PUSHJ P,FSCN    ;FORCE END OF SCAN
1005 IFN ALGSW,<MOVE C,[RADIX50 44,%OWN]
1006         MOVE    W,%OWN          ;GET VALUE
1007         TRNE    F,ALGFL         ;IF ALGOL PROG LOADED
1008         PUSHJ   P,SYMPT         ;DEFINE %OWN>
1009 IFN RPGSW,<HLRE A,S
1010         MOVNS A
1011         LSH A,-1
1012         ADD A,JOBERR
1013         HRRM A,JOBERR>
1014         PUSHJ P,PMS1    ;PRINT UNDEFS
1015         HRRZ A,H        ;DO NOT CLOBBER H IF STILL INSERTING SYMBOLS
1016         SUBI A,(X)      ;HIGHEST LOC LOADED INCLUDES LOC STMTS
1017         CAILE A,(R)     ;CHECK AGAINST R
1018         HRR R,A         ;AND USE LARGER
1019 IFE L,< HRRZ    A,STADDR        ;GET STARTING ADDRESS
1020         HRRM    A,JOBSA(X)      ;STORE STARTING ADDRESS
1021         HRRZM R,JOBFF(X)        ;AND CURRENT END OF PROG
1022         HRLM R,JOBSA(X)>
1023 IFN DMNSW,<MOVE C,[RADIX50 44,PAT..]    ;MARK PATCH SPACE FOR RPG
1024         MOVEI W,(R)
1025         SKIPE   JOBDDT(X)               ;BUT ONLY IF DDT LOADED
1026         PUSHJ P,SYMPT
1027 IFN REENT,<TRNE F,HISYM         ;SHOULD SYMBOLS GO IN HISEG?
1028         JRST    BLTSYM          ;YES>>
1029 IFN DMNSW!LDAC,<                ;ONLY ASSEMBLE IF EITHER SET
1030 IFE LDAC,<      TRNN F,DMNFLG   ;GET EXTRA  SPACE IF SYMBOLS
1031         JRST    NODDT   ;MOVED OR IF LOADING ACS>
1032 IFE DMNSW,<     MOVEI A,20      ;FOR LOADING ACS>
1033 IFN DMNSW,<     MOVE A,KORSP
1034 IFN LDAC,<      TRNN F,DMNFLG   ;ONLY 20 IF SYMBOLS NOT MOVED
1035         MOVEI A,20>>
1036         ADDI A,(R)      ;GET ACTUAL PLACE TO PUT END OF SPACE
1037         ADDI A,(X)
1038         CAIL A,(S)      ;DO NOT OVERWRITE SYMBOLS
1039 IFN EXPAND,<JRST [PUSHJ P,XPAND>
1040                 PUSHJ P,MORCOR
1041 IFN EXPAND,<    JRST .-1]>
1042 IFN LDAC,<HRRM R,BOTACS ;SAVE BOTTOM OF WHERE WE PUT ACS
1043         HRRZ A,R
1044         ADDI A,(X)
1045         HRL A,X ;SET UP BLT FROM (X) TO R(X)
1046         MOVEI Q,17(A)
1047         BLT A,(Q)>>
1048 IFN DMNSW,<TRNN F,DMNFLG        ;NOW THE CODE TO MOVE SYMBOLS
1049         JRST NODDT
1050         HRRZ A,R
1051         ADD A,KORSP
1052         MOVE W,A        ;SAVE POINTER TO FINAL LOC OF UNDEFS
1053         ADDI A,(X)
1054         HLLZ Q,S        ;COMPUTE LENGTH OF SYMBOL TABLE
1055         ADD Q,B
1056         HLROS Q
1057         MOVNS Q
1058         ADDI Q,-1(A)    ;GET PLACE TO STOP BLT
1059         HRLI A,1(S)     ;WHERE TO BLT FROM
1060         SUBI W,1(S)     ;GET AMOUNT TO CHANGE S AND B BY
1061         BLT A,(Q)       ;MOVE SYMBOL TABLE
1062         ADD S,W
1063         ADD B,W ;CORRECT S AND B FOR MOVE
1064         SKIPN JOBDDT(X) ;IS DDT LOADED
1065         JRST NODDT      ;NO DO NOT RESET R
1066         HRRI R,1(Q)     ;SET R TO POINT TO END OF SYMBOLS
1067         SUBI R,(X)
1068         HRRM R,JOBFF(X)
1069         HRLM R,JOBSA(X) ;AND SAVE AWAY NEW JOBFF
1070 IFN LDAC,<SKIPA>        ;SKIP THE ADD TO R
1071 NODDT:>
1072 IFN LDAC,<ADDI R,20>    ;MAKE SURE R IS CORRECT FOR BLT
1073         MOVE A,B
1074         ADDI A,1        ;SET UP JOBSYM, JOBUSY
1075 IFE L,<MOVEM A,JOBSYM(X)>
1076 IFN L,<MOVEM A,JOBSYM>
1077         MOVE A,S
1078         ADDI A,1
1079 IFE L,<MOVEM A,JOBUSY(X)
1080         MOVE A,HISTRT   ;TAKE POSSIBLE REMAP INTO ACCOUNT
1081         MOVEM A,JOBREL(X)       ;SET UP FOR IMEDIATE EXECUTION>
1082 IFN L,<MOVEM A,JOBUSY>
1083 IFN REENT,<
1084         SKIPE A,HILOW   ;SET UP TOP LOC OF LOW CORE EXCLUDING BLOCKS
1085         SUBI A,1(X)     ;IF NON-ZERO THEN IT NEEDS RELOCATION
1086         HRLM A,JOBCOR(X)
1087         TRNN F,SEENHI
1088         POPJ P,
1089         HRRZ A,HVAL
1090         HRRM A,JOBHRL(X)
1091         SUB A,HVAL1
1092         HRLM A,JOBHRL(X)>
1093         POPJ P,
1094
1095
1096
1097 SUBTTL  BLT SYMBOL TABLE INTO HIGH SEGMENT
1098 IFN DMNSW&REENT,<
1099 BLTSYM: MOVE    Q,HVAL  ;GET ORIGIN OF HISEG
1100         CAMN    Q,HVAL1 ;HAS IT CHANGED?
1101         JRST    NOBLT   ;NO
1102         HLLZ    Q,S     ;COMPUTE LENGTH OF SYMBOL TABLE
1103         HLRS    S       ;PUT NEG COUNT IN BOTH HALVES
1104         JUMPE   S,.+2   ;SKIP IF S IS ZERO
1105         HRLI    S,-1(S) ;SUB 1 FROM LEFT TO FIX CARRY PROBLEM
1106         ADD     Q,B
1107         HLROS   Q
1108         MOVNS   Q
1109         ADD     Q,HVAL  ;ADD LENGTH OF HISEG
1110         SUB     Q,HVAL1 ;BUT REMOVE ORIGIN
1111         ADD     Q,HISTRT        ;START OF HISEG IN CORE
1112         HRRZS   Q       ;CLEAR INDEX FROM Q
1113         ADD     Q,KORSP ;SAVE SPACE FOR SYMBOL PATCHES
1114         CORE    Q,      ;EXPAND IF NEEDED
1115         PUSHJ   P,MORCOR
1116         PUSH    P,B     ;SAVE B
1117         SOJ     B,      ;REMOVE CARRY FROM ADD TO FOLLOW
1118         MOVSS   B       ;SWAP SYMBOL POINTER
1119         ADD     B,JOBREL
1120         HRRM    B,(P)   ;SAVE NEW B
1121         MOVE    Q,JOBREL
1122         ADD     B,S     ;INCASE ANY UNDEFS.
1123         BLT     B,(Q)   ;MOVE SYMBOLS
1124         POP     P,B     ;GET NEW B
1125         SUB     B,HISTRT
1126         ADD     B,HVAL1
1127         SOJ     B,      ;REMOVE CARRY
1128         ADDI    S,(B)   ;SET UP JOBUSY
1129 BLTSY1: MOVE    Q,JOBREL
1130         SUB     Q,HISTRT
1131         ADD     Q,HVAL1
1132         SUBI    Q,1     ;ONE TOO HIGH
1133         MOVEM   Q,HVAL
1134         JRST    NODDT
1135
1136
1137
1138 NOBLT:  HRRZ    Q,HILOW ;GET HIGHEST LOC LOADED
1139         HRRZ    A,S     ;GET BOTTOM OF UNDF SYMBOLS
1140         SUB     A,KORSP ;DON'T FORGET PATCH SPACE
1141         IORI    A,1777  ;MAKE INTO A K BOUND
1142         IORI    Q,1777
1143         CAIN    A,(Q)   ;ARE THEY IN SAME K
1144 IFN EXPAND,<JRST        [PUSHJ  P,XPAND>
1145                 PUSHJ   P,MORCOR
1146 IFN EXPAND,<    JRST    NOBLT]>
1147         MOVEM   Q,HISTRT        ;SAVE AS START OF HIGH
1148         MOVEI   A,400000        ;HISEG ORIGIN
1149         MOVEM   A,HVAL1         ;SAVE AS ORIGIN
1150         SUB     S,HISTRT        ;GET POSITION OF UNDF POINTER
1151         ADDI    S,377777        ;RELATIVE TO ORG
1152         SUB     B,HISTRT        ;SAME FOR SYM POINTER
1153         ADDI    B,377777
1154         TRO     F,SEENHI        ;SO JOBHRL WILL BE SET UP
1155         JRST    BLTSY1          ;AND USE COMMON CODE
1156 >
1157
1158 IFN DMNSW!LDAC,<
1159 MORCOR: ERROR ,</MORE CORE NEEDED#/>
1160         EXIT>
1161
1162
1163 SUBTTL  WRITE CHAIN FILES
1164
1165 IFE K,<                 ;DONT INCLUDE IN 1KLOAD
1166 CHNC:   SKIPA   A,JOBCHN(X)     ;CHAIN FROM BREAK OF FIRST BLOCK DATA
1167 CHNR:   HLR     A,JOBCHN(X)     ;CHAIN FROM BREAK OF FIRST F4 PROG
1168 IFN ALGSW,<TRNE F,ALGFL         ;IF ALGOL LOADING
1169         POPJ    P,              ;JUST RETURN>
1170         HRRZS   A               ;ONLY RIGHT HALF IS SIGNIFICANT
1171         JUMPE   A,LD7C          ;DON'T CHAIN IF ZERO
1172         TLNN    N,AUXSWI        ;IS THERE AN AUX DEV?
1173         JRST    LD7D            ;NO, DON'T CHAIN
1174         PUSH    P,A             ;SAVE WHEREFROM TO CHAIN
1175         JUMPE   D,.+2           ;STARTING ADDR SPECIFIED?
1176         HRRZM   D,STADDR        ;USE IT
1177         CLOSE   2,              ;INSURE END OF MAP FILE
1178         TLZ     N,AUXSWI+AUXSWE ;INSURE NO PRINTED OUTPUT
1179         PUSHJ   P,SASYM         ;DO LIB SEARCH, SETUP JOBSA, ETC.
1180 IFN RPGSW,<TLNE N,RPGF          ;IF IN CCL MODE
1181         TDZA    W,W             ;NO MESSAGES>
1182         MOVE    W,[SIXBIT ?CHAIN?]      ;FINAL MESSAGE
1183         PUSHJ   P,BLTSET        ;SETUP BLT PNTR, SETDDT, RELEAS
1184         POP     P,A             ;GET WHEREFROM
1185         HRRZ    W,R             ;CALCULATE MIN IOWD NECESSARY
1186         SKIPE   JOBDDT(X)       ;IF JOBDDT KEEP SYMBOLS
1187         CAILE   W,1(S)
1188         JRST    CHNLW1
1189         HRRZ    W,JOBREL        ;NEED SYMBOLS AND THEY HAVE NOT MOVED DOWN
1190         SUBI    W,(X)           ;BECAUSE WE WILL NOT HAVE BLITTED
1191         SUBI    B,-1(X)         ;SYMBOL TABLE WILL COME OUT IN A
1192         MOVEM   B,JOBSYM(X)     ;DIFFERENT PLACE
1193 CHNLW1: MOVNS   W
1194         ADDI    W,-7(A)
1195         ADDI    A,-7(X)
1196         PUSH    A,W     ;SAVE LENGTH
1197         HRLI    W,-1(A)
1198         MOVSM   W,IOWDPP        ;...
1199         SETZM   IOWDPP+1        ;JUST IN CASE
1200         PUSH    A,JOBCHN(X)
1201         PUSH    A,JOBSA(X)      ;SETUP SIX WORD TABLE
1202         PUSH    A,JOBSYM(X)     ;...
1203         PUSH    A,JOB41(X)
1204         PUSH    A,JOBDDT(X)
1205         SETSTS  2,17            ;SET AUX DEV TO DUMP MODE
1206         MOVSI   W,435056        ;USE .CHN AS EXTENSION
1207         MOVEM   W,DTOUT1        ;...
1208         PUSHJ   P,IAD2          ;DO THE ENTER
1209         OUTPUT  2,IOWDPP        ;WRITE THE CHAIN FILE
1210         STATZ   2,IOBAD!IODEND
1211         JRST    LOSEBIG
1212         CLOSE   2,
1213         STATZ   2,IOBAD!IODEND
1214 IFN RPGSW,<JRST LOSEBIG
1215         TLNE    N,RPGF          ;IF IN CCL MODE
1216         JRST    CCLCHN          ;LOAD NEXT LINK
1217         EXIT>
1218 LOSEBI: TTCALL  3,[ASCIZ /?DEVICE ERROR/]
1219         EXIT>
1220
1221
1222 SUBTTL  SPECIAL CHAINB
1223 IFE SPCHN,<     XLIST   >
1224 IFN SPCHN,<
1225 CHNBG:
1226         PUSHJ   P,FSCN1A                ;FORCE SCAN TO COMPLETION FOR CURRENT FILE
1227         TLNN N,AUXSWI   ;IS THERE AN AUX DEV??
1228         JRST LD7D
1229         HRLZI   W,-1(R)         ;CHNTAB-L = ADDRESS OF VECTOR TABLE
1230         HRRI    W,1             ;CHNTAB-R = NEXT DISK BLOCK TO RITE INTO
1231         MOVEM   W,CHNTAB
1232         MOVE    C,[RADIX50 4,OVTAB]     ;DEFINE GLOBAL SYMBOL OVTAB
1233         MOVEI   W,(R)           ;TO HAVE VALUE THE BEGINNING OF THE VECTOR TABLE
1234         PUSHJ   P,SYMPT
1235         ADDI    R,VECLEN        ;RESERVE SPACE FOR VECTOR TABLE
1236         MOVE    C,[RADIX50 4,OVBEG]     ;OVBEG IS BEGINNING OF OVERLAY AREA
1237         MOVEI   W,(R)
1238         PUSHJ   P,SYMPT
1239         HRRZM   R,BEGOV         ;AND SAVE IN OVBEG
1240         OPEN    4,CHNOUT        ;OPEN FILE FOR CHAIN
1241         JRST    ILD5            ;CANT OPEN CHAIN FILE
1242         ENTER   4,CHNENT        ;ENTER CHAIN FILE
1243         JRST    IMD3            ;NO CAN DO
1244         HRRZ    W,N
1245         SUB     W,HISTRT        ;KEEP N RIGHT HALF AS RELATIVE TO HISTRT
1246         HRRZM W,CHNACN  ;SAVE FOR RESTORING
1247         MOVEM B,CHNACB  ;ALSO B R IS SAVED IN BEGOV
1248         POPJ    P,
1249
1250 CHNENS: TLOA N,PPCSW    ;THIS FLAG UNUSED AT THIS POINT
1251 CHNEN:  TLZ N,PPCSW     ;ON TO NOT DELETE NEW SYMBOLS
1252         SKIPN CHNACB    ;WILL BE NON-ZERO IF WE SAW A /<  (> TO KEEP  MACRO HAPPY)
1253         JRST LD7D       ;ERROR MESSAGE
1254         PUSHJ P,FSCN1A          ;LOAD LIB (IF DESIRED) AND FORCE SCAN
1255         SKIPL Q,S       ;CHECK SYMBOL TABLE FOR MISSED UNDEFS
1256         JRST NOER       ;NONE THERE
1257         MOVEI E,0       ;COUNT OF ERRORS
1258 ONCK:
1259         IFN FAILSW,<SKIPL V,1(Q)        ;IF HIGH ORDER BIT IS ON
1260         TLNN V,740000   ;OR IF ALL CODE BITS 0
1261         JRST NXTCK      ;THEN NOT TO BE CHECKED>
1262         MOVE V,2(Q)     ;GET FIXUP WORD
1263         TLNE V,100000   ;BIT INDICATES SYMBOL TABLE FIXUP
1264         JRST SMTBFX
1265 IFN FAILSW,<TLNE V,40000        ;BIT INDICATES POLISH FIXUP
1266         JRST POLCK>
1267         TLZE V,740000   ;THESE BITS WOULD MEAN ADDITIVE
1268         JRST    [JSP A,CORCKL
1269                 JRST NXTCK]     ;ONLY TRY FIRST LOCATION
1270 CORCK:  JSP A,CORCKL
1271         HRRZ V,@X       ;THE WAY TO LINK
1272 CORCKL: IFN REENT,<CAMGE V,HVAL1>
1273         CAMGE V,BEGOV
1274         SKIPA   ;NOT IN BAD RANGE
1275         JRST ERCK       ;BAD, GIVE ERROR
1276         JUMPE V,NXTCK   ;CHAIN HAS RUN OUT
1277 IFN REENT,<CAMGE V,HVAL1        ;GET CORRECT LINK
1278         SKIPA X,LOWX
1279         MOVE X,HIGHX>
1280         XCT (A)         ;TELLS US WHAT TO DO
1281         JRST CORCKL     ;GO ON WITH NEXT LINK
1282
1283
1284 SMTBFX: TLNE N,PPCSW    ;IF NOT CUTTING BACK SYMBOL TABLE
1285         JRST NXTCK      ;THE ALL OK
1286         ADD V,HISTRT    ;GET PLACE TO POINT TO
1287         HRRZS V
1288         HLRE D,CHNACB   ;OLD LENGTH OF TABLE (NEGATIVE)
1289         HLRE T,B        ;NEW LENGTH
1290         SUB D,T         ;-OLD LEN+NEW LEN
1291         ADDI D,(B)      ;OLD BOTTOM=NEW BOTTOM+NEW LEN-OLD LEN
1292         CAIG V,(D)      ;IS IT IN THE PART WE ARE KEEPING
1293         JRST ERCK
1294         JRST NXTCK      ;YES
1295 IFN FAILSW,<POLCK:      HLRZ C,V        ;FIND HEADER
1296         PUSHJ P,SREQ
1297         SKIPA
1298         JRST LOAD4A     ;SHOULD BE THERE
1299         HRL C,2(A)      ;NOW FIRST OPERATOR (STORE)
1300         MOVSS C
1301         PUSHJ P,SREQ
1302         SKIPA
1303         JRST LOAD4A
1304         ANDI C,37       ;GET OPERATION
1305         HRRZ V,2(A)     ;DESTINATION
1306         JRST @CKSMTB-15(C)      ;DISPATCH
1307 CKSMTB: EXP SMTBFX,SMTBFX,SMTBFX,CORCK,LCORCK,CORCK,NXTCK
1308 LCORCK: JSP A,CORCKL
1309         HLRZ V,@X>
1310 ERCK:   MOVE C,1(Q)     ;GET SYMBOL NAME
1311         PUSHJ P,FCRLF   ;FORCE CRLF AND OUTPUT ON TTY
1312         PUSHJ P,PRNAME  ;PRINT IT
1313         ADDI E,1        ;MARK ERROR
1314 NXTCK:  ADD Q,SE3       ;TRY ANOTHER
1315         JUMPL Q,ONCK
1316 IFN REENT,<PUSHJ P,RESTRX       ;GET PROPER X BACK>
1317         JUMPE E,NOER    ;DID ANYTHING GO WRONG??
1318         ERROR   ,</UNDEFINED GLOBAL(S) IN LINK@/>
1319         JRST LD2        ;GIVE UP
1320 NOER:   MOVE A,BEGOV    ;GET START OF OVERLAY
1321         ADDI A,(X)      ;GET ACTUAL CURRENT LOCATION
1322 IFN REENT,<HRRZ W,HILOW ;AND END OF OVERLAY+1
1323         HRRZM A,HILOW   ;RESET>
1324 IFE REENT,<HRRZ W,R
1325         ADDI R,(X)      ;A GOOD GUESS>
1326         SUBM A,W        ;W=-LENGTH
1327         SUBI A,1        ;SET TO BASE-1 (FOR IOWD)
1328         HRL A,W         ;GET COUNT
1329         MOVEM A,IOWDPP
1330         HRR A,CHNTAB    ;BLOCK WE ARE WRITING ON
1331         HLRZ V,CHNTAB   ;POINTER TO SEGMENT TABLE
1332         ADDI V,1        ;NEXT LOCATION
1333         HRLM V,CHNTAB   ;REMEMBER IT
1334         CAML V,BEGOV    ;CHECK FOR OVERRUN
1335         JRST    [ERROR </?TOO MANY LINKS@/>
1336                 JRST LD2];GIVE UP
1337         MOVEM A,@X      ;PUT INTO TABLE
1338         MOVN W,W        ;GET POSITIVE LENGTH
1339         ADDI W,DSKBLK-1
1340         IDIVI W,DSKBLK  ;GET NUMBER OF BLOCKS
1341         ADDM W,CHNTAB   ;AND UPDATE
1342         TLZE N,PPCSW
1343         JRST NOMVB      ;DO NOT ADJUST SYMBOLS
1344         HLRE W,CHNACB   ;GET OLD LENGTH OF DEF SYMBOLS
1345         HLRE C,B        ;AND NEW LENGTH
1346         SUB W,C         ;-OLD LEN+NEW LEN
1347         HRRZ C,B        ;SAVE POINTER TO CURRENT S
1348         ADD S,W
1349         HRL W,W
1350         ADD B,W         ;UPDATE B (COUNT AND LOC)
1351         JUMPGE S,UNLNKD ;JUST IN CASE NOTHING TO MOVE
1352         HRRZ A,B        ;PLACE TO PUT UNDEFS
1353 UNLNK:  MOVE W,(C)
1354         MOVEM W,(A)     ;TRANSFER
1355         SUBI A,1
1356         CAIE A,(S)      ;HAVE WE MOVED LAST WORD??
1357         SOJA C,UNLNK    ;NO, CONTINUE
1358 UNLNKD: HRRZ W,CHNACN   ;GET SAVED N
1359         ADD W,HISTRT
1360         HRR N,W ;AND RESET IT
1361 NOMVB:  HRR R,BEGOV     ;PICK UP BASE OF AREA
1362         OUTPUT 4,IOWDPP ;DUMP IT
1363         STATZ 4,IOBAD!IODEND    ;AND ERROR CHECK
1364         JRST LOSEBI
1365         HRRZ V,R        ;GET AREA TO ZERO
1366         MOVEI W,@X
1367         CAIL W,1(S)     ;MUST MAKE SURE SOME THERE
1368         POPJ P, ;DONE
1369         SETZM (W)
1370         CAIL W,(S)
1371         POPJ P,
1372         HRLS W
1373         ADDI W,1
1374         BLT W,(S)       ;ZERO WORLD
1375         POPJ P,
1376 >
1377         LIST
1378
1379
1380 SUBTTL  EXPAND CORE
1381
1382 IFN EXPAND,<
1383 XPAND:  TLNE    F,FULLSW        ;IF CORE  EXCEEDED
1384         POPJ    P,              ;DON'T WASTE TIME  ON  CORE UUO
1385         PUSH    P,Q
1386         HRRZ    Q,JOBREL
1387         ADDI    Q,2000
1388 XPAND1: PUSH P,H        ;GET SOME REGISTERS TO USE
1389         PUSH P,X
1390         PUSH P,N
1391         PUSH    P,JOBREL        ;SAVE PREVIOUS SIZE
1392         CAMG    Q,ALWCOR        ;CHECK TO SEE IF RUNNING OVER
1393         CORE Q,
1394         JRST XPAND6
1395 IFE K,< HRRZ H,MLTP     ;GET LOWEST LOCATION
1396         TLNN N,F4SW     ;IS FORTRAN LOADING>
1397         MOVEI H,1(S)    ;NO, USE S
1398         POP     P,X     ;LAST JOBREL
1399         HRRZ    Q,JOBREL;NEW JOBREL
1400         SUBI    Q,(X)   ;GET DIFFERENCE
1401         HRLI    Q,X     ;PUT X IN INDEX FIELD
1402 XPAND2: MOVE N,(X)
1403         MOVEM N,@Q
1404         CAMLE X,H       ;TEST FOR END
1405         SOJA X,XPAND2
1406         HRLI    H,-1(Q)
1407         TLC     H,-1    ;MAKE IT NEGATIVE
1408         SETZM (H)       ;ZERO NEW CORE
1409         AOBJN H,.-1
1410         MOVEI H,(Q)
1411 XPAND8: ADD     S,H
1412         ADD     B,H
1413         ADDM H,HISTRT   ;UPDATE START OF HISEG
1414 IFN REENT,<ADDM H,HIGHX ;AND STORE LOCATION
1415         TLNE F,HIPROG
1416         ADDM H,-1(P)    ;X IS CURRENTLY IN THE STACK>
1417         POP P,N
1418         ADD N,H
1419 IFE K,< TLNN N,F4SW     ;F4?
1420         JRST    XPAND3
1421         ADDM H,PLTP
1422         ADDM H,BITP
1423         ADDM H,SDSTP
1424         ADDM H,MLTP
1425         TLNE N,SYDAT
1426         ADDM H,V>
1427 XPAND3: AOSA -3(P)
1428 XPAND5: POP P,N
1429         POP P,X
1430         POP P,H
1431         POP     P,Q
1432         POPJ P,
1433
1434
1435
1436 XPAND6: POP     P,A     ;CLEAR JOBREL OUT OF STACK
1437         ERROR   ,</MORE CORE NEEDED#/>
1438         JRST XPAND5
1439
1440 XPAND7: PUSHJ   P,XPAND
1441         JRST    SFULLC
1442         JRST    POPJM2
1443
1444 XPAND9: PUSH    P,Q             ;SAVE Q
1445         HRRZ    Q,JOBREL        ;GET CORE SIZE
1446         ADDI    Q,(V)           ;ADD XTRA NEEDED
1447         JRST    XPAND1          ;AND JOIN COMMON CODE
1448
1449 POPJM3: SOS     (P)             ;POPJ TO CALL-2
1450 POPJM2: SOS     (P)             ;POPJ TO CALL-1
1451         SOS     (P)             ;SAME AS POPJ TO
1452         POPJ    P,              ;NORMAL POPJ MINUS TWO
1453 >
1454
1455
1456
1457 SUBTTL  SWITCH HANDLING
1458
1459 ;ENTER SWITCH MODE
1460
1461 LD6A:   CAIN    T,57            ;WAS CHAR A SLASH?
1462         TLO     N,SLASH         ;REMEBER THAT
1463 LD6A2:  TLO     F,SSW           ;ENTER SWITCH MODE
1464 LD6A1:  SETZB   D,C     ;ZERO TWO REGS FOR DECIMAL AND OCTAL
1465         JRST    LD3             ;EAT A SWITCH
1466
1467 ;ALPHABETIC CHARACTER, SWITCH MODE
1468
1469 LD6:
1470         CAIL    T,141           ;ACCEPT LOWER CASE SWITCHES
1471         SUBI    T,40
1472 IFN SPCHN,<XCT  LD6B-74(T)      ;EXECUTE SWITCH FUNCTION>
1473 IFE SPCHN,<XCT  LD6B-101(T)     ;EXECUTE SWITCH FUNCTION>
1474         TLZE    N,SLASH ;SWITCH MODE ENTERED W/ SLASH?
1475         JRST    LD6D            ;LEAVE SWITCH MODE
1476         JRST    LD6A1           ;STAY IN SWITCH MODE
1477
1478
1479
1480 ;DISPATCH TABLE FOR SWITCHES
1481
1482 ;       THE INSTRUCTION AT THE CHARACTER LOCATION IS EXECUTED
1483
1484 LD6B:
1485 IFN SPCHN,<PUSHJ P,CHNBG        ;LESS THAN - BEGINNING OF OVERLAY
1486         PUSHJ   P,CHNENS        ;= - PUT OUT CHAIN RETAINING SYMBOLS
1487         PUSHJ   P,CHNEN         ;GREATER THAN - END OF OVERLAY
1488         JRST    LD7B            ;? - ERROR
1489         JRST    LD7B            ;@ - ERROR>
1490         PUSHJ   P,ASWTCH        ;A - LIST ALL GLOBALS
1491 IFN DMNSW,<PUSHJ P,DMN2         ;B - BLOCKS DOWN SYMBOL TABLE >
1492 IFE DMNSW,<JRST LD7B            ;B - ERROR>
1493 IFE K,< PUSHJ   P,CHNC          ;C - CHAIN, START W/ COMMON>
1494 IFN K,< JRST    LD7B            ;C - ILLEGAL IN 1KLOAD>
1495         PUSHJ   P,LDDT          ;D - DEBUG OPTION, LOAD DDT
1496         TLO     N,EXEQSW        ;E - LOAD AND GO
1497         PUSHJ    P,LIBF         ;F - LIBRARY SEARCH
1498         PUSHJ    P,LD5E         ;G - GO INTO EXECUTION
1499 IFN REENT,<PUSHJ P,HSET         ;H - REENTRANT. PROGRAM>
1500 IFE REENT,<JFCL                 ;JUST IGNORE /H>
1501         PUSHJ   P,ISWTCH        ;I - IGNORE STARTING ADDRESSES
1502         TLZ     N,ISAFLG        ;J - USE STARTING ADDRESSES
1503 IFE KUTSW,<JRST LD7B            ;K - ERROR>
1504 IFN KUTSW,<MOVEM C,CORSZ        ;K - SET DESIRED CORE SIZE>
1505         PUSHJ   P,LSWTCH        ;L - ENTER LIBRARY SEARCH
1506         PUSHJ   P,PRMAP         ;M - PRINT STORAGE MAP
1507         TLZ     F,LIBSW+SKIPSW  ;N - LEAVE LIBRARY SEARCH
1508         HRR     R,D             ;O - NEW PROGRAM ORIGIN
1509         PUSHJ   P,PSWTCH        ;P - PREVENT AUTO. LIB. SEARCH
1510         TLZ     F,NSW           ;Q - ALLOW AUTO. LIB. SEARCH
1511 IFE K,< PUSHJ   P,CHNR          ;R - CHAIN, START W/ RESIDENT>
1512 IFN K,< JRST    LD7B            ;R - ILLEGAL IN 1KLOAD>
1513         PUSHJ   P,SSWTCH        ;S - LOAD WITH SYMBOLS
1514         PUSHJ   P,LDDTX         ;T - LOAD AND GO TO DDT
1515         PUSHJ   P,PMS           ;U - PRINT UNDEFINED LIST
1516 IFN REENT,<PUSHJ P,VSWTCH       ;V - LOAD REENTRANT LIB40>
1517 IFE REENT,<JRST LD7B            ;V - ERROR>
1518         TLZ     F,SYMSW+RMSMSW  ;W - LOAD WITHOUT SYMBOLS
1519         TLZ     N,ALLFLG        ;X - DO NOT LIST ALL GLOBALS
1520         TLO     F,REWSW         ;Y - REWIND BEFORE USE
1521         JRST    LDRSTR          ;Z - RESTART LOADER
1522
1523
1524
1525 ; PAIRED SWITCHES ( +,-)
1526
1527 ASWTCH: JUMPL   D,.+2           ;SKIP IF /-A
1528         TLOA    N,ALLFLG        ;LIST ALL GLOBALS
1529         TLZ     N,ALLFLG        ;DON'T
1530         POPJ    P,
1531
1532 ISWTCH: JUMPL   D,.+2           ;SKIP IF /-I
1533         TLOA    N,ISAFLG        ;IGNORE STARTING ADDRESSES
1534         TLZ     N,ISAFLG        ;DON'T
1535         POPJ    P,
1536
1537 LSWTCH: JUMPL   D,.+2           ;SKIP IF /-L
1538         TLOA    F,LIBSW!SKIPSW  ;ENTER LIBRARY SEARCH
1539         TLZ     F,LIBSW!SKIPSW  ;DON'T
1540         POPJ    P,
1541
1542 PSWTCH: JUMPL   D,.+2           ;SKIP IF /-P
1543         TLOA    F,NSW           ;PREVENT AUTO. LIB SEARCH
1544         TLZ     F,NSW           ;ALLOW
1545         POPJ    P,
1546
1547 SSWTCH: JUMPL   D,.+2           ;SKIP IF /-S
1548         TLOA    F,SYMSW!RMSMSW  ;LOAD WITH SYMBOLS
1549         TLZ     F,SYMSW!RMSMSW  ;DON'T
1550         POPJ    P,
1551
1552 IFN REENT,<
1553 VSWTCH: JUMPL   D,.+2           ;SKIP IF /-V
1554         TROA    F,VFLG          ;SEARCH RE-ENTRANT LIBRARY
1555         TRZ     F,VFLG          ;DON'T
1556         POPJ    P,>
1557
1558
1559 IFN REENT,<
1560 ; H SWITCH --- EITHER /H OR /NH
1561 HSET:   JUMPE   D,SETNUM        ;/H ALWAYS LEGAL
1562         CAIGE   D,2             ;WANT TO CHANGE SEGMENTS
1563         JRST    SETSEG          ;YES,GO DO IT
1564         TRNN    F,SEENHI        ;STARTED TO LOAD YET?
1565         JRST    HCONT           ;NO, CONTINUE.
1566         ERROR   ,<?/H ILLEGAL AFTER FIRST HISEG FILE IS LOADED@?>>
1567
1568 LDRSTR: ERROR   0,</LOADER RESTARTED@/>
1569         JRST    LD              ;START AGAIN
1570 IFN REENT,<
1571 REMPFL: ERROR   ,</?LOADER REMAP FAILURE@/>
1572         JRST LDRSTR
1573 HCONT:  HRRZ C,D
1574         ANDCMI C,1777
1575         CAIL C,400000
1576         CAIG C,(H)
1577         JRST COROVL     ;BEING SET LOWER THEN 400000 OR MORE THAN TO OF LOW SEG
1578         HRRZM C,HVAL1   ;WE HAVE REMOVED THE ODD BITS TO MAKE A 1K MULT
1579         ADDI C,JOBHDA
1580         CAILE C,(D)     ;MAKE SURE OF ENOUGH ROOM
1581         MOVE D,C
1582         HRLI D,W        ;SET UP W IN LEFT HALF
1583         MOVEM D,HVAL
1584         POPJ    P,      ;RETURN.
1585
1586 COROVL: ERROR   ,</HISEG STARTING ADDRESS TOO LOW@/>
1587         JRST LDRSTR
1588 SETNUM: TRO     F,NOHI  ;SET NO-HIGH-SEG SWITCH.
1589         POPJ    P,>
1590
1591
1592 ;SWITCH MODE NUMERIC ARGUMENT
1593
1594 LD6C:   LSH     D,3             ;BUILD OCTAL NUMERIC ARGUMENT
1595         ADDI    D,-60(T)
1596         IMULI C,↑D10
1597         ADDI C,-"0"(T)  ;ACCUMULATE DEC AND OCTAL
1598         JRST    LD3
1599
1600 ;EXIT FROM SWITCH MODE
1601
1602 LD6D:   TLZ     F,SSW           ;CLEAR SWITCH MODE FLAG
1603         TLNE    F,FSW           ;TEST FORCED SCAN FLAG
1604         JRST    LD2D            ;SCAN FORCED, START NEW IDENT.
1605         JRST    LD3             ;SCAN NOT FORCED, USE PREV IDENT
1606 ;ILLEGAL CHARACTER, NORMAL MODE
1607
1608 LD7:    IFN SYMARG,<
1609         CAIN    T,"#"           ;DEFINING THIS SYMBOL
1610         JRST    DEFINE          ;YES
1611         TRNN    F,ARGFL         ;TREAT AS SPECIAL
1612         JRST    .+4             ;NO
1613         CAIE    T,"$"
1614         CAIN    T,"%"
1615         JRST    LD4             ;YES>
1616         CAIN    T,"Z"-100       ;TEST FOR ↑Z
1617         JRST    LD5E1           ;TREAT AS ALTMODE FOR BATCH
1618         ERROR   8,</CHAR.%/>
1619         JRST    LD2     ;TRY TO CONTINUE
1620
1621 ;SYNTAX ERROR, NORMAL MODE
1622
1623 LD7A:   ERROR   8,</SYNTAX%/>
1624         JRST    LD2
1625
1626 ;ILLEGAL CHARACTER, SWITCH MODE
1627
1628 LD7B:   CAIN T,"-"      ;SPECIAL CHECK FOR -
1629         JRST    [SETOB C,D
1630                 JRST LD3]
1631         CAIN    T,"Z"-100       ;CHECK FOR /↑Z
1632         JRST    LD5E1           ;SAME AS ↑Z
1633         ERROR   8,</SWITCH%/>
1634         JRST    LD2
1635
1636
1637 ;ATTEMPT TO CHAIN WITH SPECIFIED HALF OF JOBCHN = 0
1638
1639 IFE K,<
1640 LD7C:   ERROR   ,<?UNCHAINABLE AS LOADED@?>
1641         JRST    LD2
1642
1643 ;ATTEMP TO CHAIN WITHOUT SPECIFYING DEVICE
1644
1645 LD7D:   ERROR   ,<?NO CHAIN DEVICE@?>
1646         JRST    LD2>
1647
1648 IFN DMNSW,<
1649 DMN2:
1650 IFN ALGSW,<TRNE F,ALGFL         ;IF LOADING ALGOL
1651         POPJ    P,              ;JUST RETURN>
1652         CAIN    D,1             ;SPECIAL CASE
1653         TROA    F,HISYM         ;YES ,BLT SYMBOLS INTO HISEG
1654         JUMPL   D,.+2
1655         TROA    F,DMNFLG        ;TURN ON /B
1656 IFN KUTSW,<TRZA F,DMNFLG        ;TURN OFF IF /-B
1657         SETZM   CORSZ           ;SET TO CUT BACK CORE>
1658 IFE KUTSW,<TRZ  F,DMNFLG        ;TURN OFF IF /-B>
1659         CAMLE D,KORSP
1660         MOVEM D,KORSP
1661         POPJ    P,               ;RETURN>
1662
1663
1664
1665 SUBTTL  CHARACTER CLASSIFICATION TABLE DESCRIPTION:
1666
1667 ;       EACH CHARACTER HAS ASSOCIATED WITH IT A FOUR BIT BYTE
1668 ;       PACKED IN THE CHARACTER CLASSIFICATION TABLE.  THE CHARACTER
1669 ;       CLASSIFICATION CODES ARE ORDERED IN SUCH A WAY AS TO GIVE
1670 ;       DELIMITERS OF HIGHER PRECEDENCE LOWER CLASSIFICATION NUMBERS.
1671 ;       CERTAIN CHARACTERS HAVE NO EFFECT ON THE COMMAND STRING, AND
1672 ;       THEREFORE DO NOT EFFECT ORDERING OF DELIMITERS.  FOUR CODES
1673 ;       ARE RESERVED FOR ALTERNATE DISPATCHES WHILE THE SWITCH MODE IS
1674 ;       IN EFFECT.
1675
1676
1677 ;CLASSIFICATION BYTE CODES:
1678
1679 ;       BYTE DISP CLASSIFICATION
1680
1681 ;       00 - 00  ILLEGAL CHARACTER, SWITCH MODE
1682 ;       01 - 01  ALPHABETIC CHARACTER, SWITCH MODE
1683 ;       02 - 02  NUMERIC CHARACTER, SWITCH MODE
1684 ;       03 - 03  SWITCH MODE ESCAPE, SWITCH MODE
1685
1686 ;       00 - 04  ILLEGAL CHARACTER, NORMAL MODE
1687 ;       01 - 05  ALPHABETIC CHARACTER, NORMAL MODE
1688 ;       02 - 06  NUMERIC CHARACTER, NORMAL MODE
1689 ;       03 - 07  SWITCH MODE ESCAPE, NORMAL MODE
1690
1691 ;       04 - 10  IGNORED CHARACTER
1692 ;       05 - 11  ENTER SWITCH MODE CHARACTER
1693 ;       06 - 12  DEVICE IDENTIFIER DELIMITER
1694 ;       07 - 13  FILE EXTENSION DELIMITER
1695 ;       10 - 14  OUTPUT SPECIFICATION DELIMITER
1696 ;       11 - 15  INPUT SPECIFICATION DELIMITER
1697 ;       12 - 16  LINE TERMINATION
1698 ;       13 - 17  JOB TERMINATION
1699
1700
1701 ;BYTE POINTERS TO CHARACTER CLASSIFICATION TABLE
1702
1703 LD8:    POINT     4,LD9(Q),3
1704         POINT     4,LD9(Q),7
1705         POINT     4,LD9(Q),11
1706         POINT     4,LD9(Q),15
1707         POINT     4,LD9(Q),19
1708         POINT     4,LD9(Q),23
1709         POINT     4,LD9(Q),27
1710         POINT     4,LD9(Q),31
1711         POINT     4,LD9(Q),35
1712
1713 ;CHARACTER CLASSIFIACTION TABLE
1714
1715 LD9:    BYTE    (4)4,0,0,0,0,0,0,0,0
1716         BYTE    (4)4,4,4,4,12,0,0,0,0
1717         BYTE    (4)0,0,0,0,0,0,0,0,0
1718         BYTE    (4)13,0,0,0,0,4,0,4,0
1719 IFE SYMARG,<    BYTE    (4)0,0,0,0,5,3,0,0,11>
1720 IFN SYMARG,<    BYTE    (4)0,0,14,0,5,3,0,0,11>
1721                 BYTE    (4)0,7,5,2,2,2,2,2,2
1722 IFE SPCHN,<     BYTE    (4)2,2,2,2,6,0,0,10,0>
1723 IFN SPCHN,<     BYTE    (4)2,2,2,2,6,0,1,10,1>
1724 IFE RPGSW,<     BYTE    (4)0,0,1,1,1,1,1,1,1>
1725 IFN RPGSW,<     BYTE (4) 0,10,1,1,1,1,1,1,1>
1726         BYTE    (4)1,1,1,1,1,1,1,1,1
1727         BYTE    (4)1,1,1,1,1,1,1,1,1
1728 IFE PP,<BYTE    (4)1,0,0,0,0,10,0,1,1>
1729 IFN PP,<BYTE    (4)1,10,0,10,0,10,0,1,1>
1730         BYTE    (4)1,1,1,1,1,1,1,1,1
1731         BYTE    (4)1,1,1,1,1,1,1,1,1
1732         BYTE    (4)1,1,1,1,1,1,0,0,13
1733         BYTE    (4)13,4
1734
1735
1736 SUBTTL  INITIALIZE LOADING OF A FILE
1737
1738 ILD:    MOVEI     W,BUF1                ;LOAD BUFFER ORIGIN
1739         MOVEM     W,JOBFF
1740         TLOE    F,ISW           ;SKIP IF INIT REQUIRED
1741         JRST    ILD6            ;DONT DO INIT
1742 ILD7:   OPEN    1,OPEN3                 ;KEEP IT PURE
1743         JRST    ILD5B
1744 ILD6:   TLZE    F,REWSW         ;SKIP IF NO REWIND
1745         MTAPE   1,1             ;REWIND
1746 ILD2:   LOOKUP    1,DTIN                ;LOOK UP FILE FROM DIRECTORY
1747         JRST    ILD3            ;FILE NOT IN DIRECTORY
1748 IFE LNSSW,<
1749 IFE K,< INBUF     1,2           ;SET UP BUFFERS>
1750 IFN K,< INBUF   1,1             ;SET UP BUFFER>>
1751 IFN LNSSW,<INBUF        1,1
1752         MOVEI   W,BUF1
1753         EXCH    W,JOBFF
1754         SUBI    W,BUF1
1755 IFE K,<MOVEI    C,4*203+1>
1756 IFN K,<MOVEI    C,203+1>
1757         IDIV    C,W
1758         INBUF   1,(C)>
1759         TLO     F,ASW           ;SET LEFT ARROW ILLEGAL FLAG
1760         TLZ     F,ESW           ;CLEAR EXTENSION FLAG
1761         POPJ    P,
1762
1763 ;       LOOKUP FAILURE
1764
1765 ILD3:   TLOE    F,ESW           ;SKIP IF .REL WAS ASSUMED
1766         JRST    ILD4            ;FATAL LOOKUP FAILURE
1767         SETZM     DTIN1         ;ZERO FILE EXTENSION
1768         JRST    ILD2            ;TRY AGAIN WITH NULL EXTENSION
1769
1770 ILD4:   IFE REENT,<IFE TEN30,<  ;PDP-6 ONLY
1771         MOVE    W,[SIXBIT /LIB40/]
1772         CAME    W,DTIN          ;WAS THIS A TRY FOR LIB40?
1773         JRST    ILD4A           ;NO
1774         TRZ     W,(SIXBIT / 0/) ;YES
1775         MOVEM   W,DTIN          ;TRY LIB4
1776         PUSHJ   P,LDDT2         ;USE .REL EXTENSION
1777         TLZ     F,ESW           ;...
1778         JRST    ILD2            ;GO TRY AGAIN
1779 ILD4A:>>
1780 IFN PP,<MOVSI   W,(SIXBIT /DSK/)
1781         CAMN    W,ILD1          ;TRIED DSK ONCE?
1782         JRST    ILD9            ;YES, FILE DOES NOT EXIST
1783         MOVEM   W,ILD1          ;SET IT UP
1784         SETZM   PPN             ;CLEAR OLD VALUE
1785         PUSHJ   P,LDDT2         ;SET UP .REL
1786         TLZ     F,ESW           ;SO WE CAN TRY BLANK EXT
1787         JRST    ILD7            ;OPEN DSK,TRY AGAIN>
1788
1789 ILD9:   ERROR   ,</CANNOT FIND#/>
1790         JRST    LD2
1791
1792 ;       DEVICE SELECTION ERROR
1793
1794 ILD5A:  SKIPA   W,LD5C1
1795 ILD5B:  MOVE    W,ILD1
1796 ILD5:   TLO     F,FCONSW        ;INSURE TTY OUTPUT
1797         PUSHJ   P,PRQ           ;START W/ ?
1798         PUSHJ   P,PWORD         ;PRINT DEVICE NAME
1799         ERROR   7,</UNAVAILABLE@/>
1800         JRST    LD2
1801
1802
1803 SUBTTL  LIBRARY SEARCH CONTROL AND LOADER CONTROL
1804
1805 ;LIBF ENABLES A LIBRARY SEARCH OF <SYS:LIB4.REL>
1806
1807 LIBF:   PUSHJ     P,FSCN1               ;FORCE SCAN TO COMPLETION
1808         PUSH P,ILD1     ;SAVE DEVICE NAME
1809         PUSHJ   P,LIBF1                 ;LOAD SYS:JOBDAT.REL
1810 IFN SAILSW,<LIBAGN:     PUSHJ P,SALOAD  ;LOAD RELS AND SEARCH LIBS>
1811 IFN REENT,<TRNN F,SEENHI        ;IF ANY HISEG LOADED NO RE-ENT OP SYSTEM
1812         TRNN F,VFLG
1813         JRST LIBF3
1814 IFN ALGSW,<TRNE F,ALGFL ;SPECIAL ACTION IF LOADING ALGOL
1815         JRST    [MOVE C,[RADIX50 44,%ALGDR]
1816                 MOVEI W,400010  ;JOBHDA
1817                 PUSHJ P,SYMPT   ;DEFINE IT
1818                 JRST    LIBF3]  ;DON'T LOAD IMP40>
1819         MOVE W,[SIXBIT /IMP40/]
1820         PUSHJ P,LIBF2
1821 LIBF3:>
1822         TRNN    F,COBFL                 ;COBOL SEEN?
1823         SKIPA   W,[SIXBIT /LIB40/]      ;FIRST TRY AT NAME
1824         MOVE    W,[SIXBIT /LIBOL/]      ;YES, SEARCH COBOL'S LIBRARY ONLY
1825         PUSHJ   P,LIBF2                 ;LOAD SYS:LIB40.REL
1826 IFN SAILSW,<MOVE W,LIBPNT       ;SEE IF ANY MORE TO DO
1827         CAME W,[XWD -RELLEN-1,LIBFLS-1]
1828         JRST LIBAGN
1829         MOVE W,PRGPNT   ;IT COULD BE DANGEROUS TO LOAD PROGRAMS HERE
1830         CAME W,[XWD -RELLEN-1,PRGFLS-1]
1831         JRST LIBAGN     ;MORE TO DO, TRY AGAIN>
1832         POP P,ILD1      ;CALL TO LDDT1 WILL PUT IT IN OLDDEV
1833 LIBF1:  MOVE    W,[SIXBIT /JOBDAT/]     ;LOAD SYS:JOBDAT.REL
1834 LIBF2:  PUSHJ     P,LDDT1
1835 LIBGO:  JUMPGE    S,EOF2                ;JUMP IF NO UNDEFINED GLOBALS
1836         TLO     F,SLIBSW+SKIPSW ;ENABLE LIBRARY SEARCH
1837         TLZ     F,SYMSW ;DISABLE LOADING WITH SYMBOLS
1838         JRST    LDF             ;INITIALIZE LOADING LIB4
1839
1840
1841 ;       LIB CONTROLS THE LIBRARY SEARCH OF ONE FILE
1842
1843 LIB:    JUMPGE  S,EOF1          ;JUMP IF NO UNDEFINED GLOBALS
1844         TLO     F,SKIPSW        ;SET SKIPSW TO IGNORE MODE
1845 IFN DIDAL,<TRNE F,XFLG          ;INDEX IN CORE?
1846         JRST    INDEX1          ;YES>
1847         JRST    LOAD            ;CONTINUE LIB. SEARCH
1848
1849 LIB1:   CAIE    A,4             ;TEST FOR ENTRY BLOCK
1850         JRST    LIB29           ;NOT AN ENTRY BLOCK, IGNORE IT
1851 LIB2:   PUSHJ   P,RWORD         ;READ ONE DATA WORD
1852         MOVE    C,W
1853         TLO     C,040000                ;SET CODE BITS FOR SEARCH
1854         PUSHJ     P,SREQ
1855         TLZA    F,SKIPSW                ;REQUEST MATCHES ENTRY, LOAD
1856         JRST    LIB2            ;NOT FOUND
1857 LIB3:   PUSHJ     P,RWORD               ;READ AND IGNORE ONE DATA WORD
1858         JRST    LIB3            ;LOOP TO IGNORE INPUT
1859
1860 LIB29:
1861 IFN DIDAL,<CAIN A,14            ;INDEX BLOCK?
1862         JRST    INDEX0          ;YES>
1863 LIB30:  HRRZ    C,W             ;GET WORD COUNT
1864         JUMPE   C,LOAD1         ;IF NUL BLOCK RETURN
1865         CAILE   C,↑D18                ;ONLY ONE SUB-BLOCK
1866         JRST    LIB3            ;NO,SO USE OLD SLOW METHOD
1867         AOJA    C,LIB31         ;ONE FOR RELOCATION WORD
1868
1869 BLOCK0: HRRZ    C,W             ;GET WORD COUNT
1870         JUMPE   C,LOAD1         ;NOISE WORD
1871 LIB31:  CAML    C,BUFR2         ;DOES BLOCK OVERLAP BUFFERS?
1872         SOJA    C,LIB32         ;YES,ALLOW FOR INITIAL ILDB
1873         ADDM    C,BUFR1         ;ADD TO BYTE POINTER
1874         MOVNS   C               ;NEGATE
1875         ADDM    C,BUFR2         ;TO SUBTRACT C FROM WORD COUNT
1876         JRST    LOAD1           ;GET NEXT BLOCK
1877
1878 LIB32:  SUB     C,BUFR2         ;ACCOUNT FOR REST OF THIS BUFFER
1879         PUSHJ   P,WORD+1        ;GET ANOTHER BUFFERFUL
1880         JRST    LIB31           ;TRY AGAIN
1881
1882
1883 IFN SAILSW,<
1884
1885 COMMENT * BLOCK TYPE 15 AND 16 USED TO SPECIFY PROGRAMS AND
1886 LIBRARIES WHICH MUST BE LOADED (SEARCHED) IF THE PROGRAM
1887 IN WHICH THE BLOCK APPEARS IS LOADED. IT IS NOW TIME TO
1888 LOAD AND SEARCH THESE FILES. IF ANY MAKE REQUESTS, THEY ARE ADDED
1889 TO THE END. WE WILL COME BACK AND LOOK AGAIN IN CASE A
1890 LIBRARY PROGRAM LOAD A REL PROGRAM. ORIGINAL CODE BY DCS*
1891
1892 SALOAD: MOVE T,[XWD -RELLEN-1,PRGFLS-1] ;TO RESET WITH AT END
1893         MOVEI D,PRGPNT  ;OINTER TO UPPER LIMIT
1894         PUSHJ P,PRGPRG  ;LOAD THEM IF ANY
1895
1896 ;NOW FOR LIBRARY SEARCH
1897
1898         MOVE T,[XWD -RELLEN-1,LIBFLS-1]
1899         MOVEI D,LIBPNT
1900
1901 PRGPRG: MOVEM D,LODLIM# ;SAVE POINTER TO LIMIT
1902         MOVEM T,LODSTP# ;START FOR RESETTING
1903 PRGBAK: MOVEM T,LODPNT# ;AND START
1904         CAMN T,@LODLIM  ;GOTTEN TO END YET?
1905         JRST PRGDON     ;YES, DUMP IT
1906         SKIPN W,PRGDEV(T)       ;IS DEVICE SPECIFIED?
1907         MOVSI W,(SIXBIT /DSK/)  ;NO, DSK
1908         MOVEM W,ILD1    ;WHERE WE INIT FROM
1909         MOVSI W,(SIXBIT /REL/)  ;EXTENSION
1910         MOVEM W,DTIN1
1911         MOVE W,PRGFIL(T)
1912         MOVEM W,DTIN    ;FILE NAME
1913         MOVE W,PRGPPN(T)        ;THE PROJECT PROG
1914         MOVEM W,DTIN+3
1915         PUSH P,JRPRG    ;A RETURN ADDRESS
1916         TLZ F,ISW       ;FORCE NEW INIT
1917         HRRZ T,LODLIM
1918         CAIN T,LIBPNT   ;WHICH ONE
1919         JRST LIBGO
1920         JRST LDF
1921 PRGRET: MOVE T,LODPNT   ;RETURNS HERE, GET NEXT ONE
1922         AOBJN T,PRGBAK
1923
1924 PRGDON: MOVE T,LODSTP   ;RESTE POINTER IN CASE MORE ON OTHER LIBS
1925         MOVEM T,@LODLIM
1926 JRPRG:  POPJ P,PRGRET   ;PUSHED TO GET A RETURN ADDRESS
1927
1928 PRGFIL==1       ;REL INDEX FOR FILE NAMES
1929 PRGPPN==RELLEN+1        ;AND FOR PPNS
1930 PRGDEV==2*RELLEN+1      ;AND FOR DEVICES
1931 >       ;END OF IFN SAILSW
1932
1933
1934 SUBTTL  LDDT LOADS <SYS:DDT.REL> AND SETS SYMSW
1935
1936 LDDTX:
1937 IFN ALGSW,<TRNE F,ALGSW
1938         POPJ    P,>
1939         TLO     N,DDSW+EXEQSW           ;T - LOAD AND GO TO DDT
1940 LDDT:
1941 IFN ALGSW,<TRNE F,ALGFL
1942         POPJ    P,>
1943 IFN DMNSW,<     PUSH    P,D             ;SAVE INCASE /NNND >
1944         PUSHJ     P,FSCN1               ;FORCE SCAN TO COMPLETION
1945         MOVSI     W,444464              ;FILE IDENTIFIER <DDT>
1946         TLZ     F,SYMSW!RMSMSW  ;DON'T LOAD DDT WITH LOCAL SYMBOLS
1947         PUSHJ     P,LDDT1
1948         PUSHJ     P,LDF         ;LOAD <SYS:DDT.REL>
1949         TLO     F,SYMSW!RMSMSW          ;ENABLE LOADING WITH SYMBOLS
1950 IFN DMNSW,<     POP     P,D     ;RESTORE D
1951         JRST    DMN2            ;MOVE SYMBOL TABLE >
1952 IFE DMNSW,<     POPJ    P,>
1953
1954 LDDT1:  MOVEM     W,DTIN                ;STORE FILE IDENTIFIER
1955 IFN PP,<MOVE    W,ILD1          ;SAVE OLD DEV
1956         MOVEM   W,OLDDEV>
1957         MOVSI     W,637163              ;DEVICE IDENTIFIER <SYS>
1958         MOVEM     W,ILD1                ;STORE DEVICE IDENTIFIER
1959         TLZ     F,ISW+LIBSW+SKIPSW+REWSW        ;CLEAR OLD FLAGS
1960 LDDT2:  MOVSI     W,624554              ;EXTENSION IDENTIFIER <.REL>
1961 LDDT3:  MOVEM     W,DTIN1               ;STORE EXTENSION IDENTIFIER
1962 LDDT4:IFN PP,<EXCH W,PPN        ;GET PROJ-PROG #
1963         MOVEM W,DTIN+3
1964         EXCH    W,PPN   ;W MUST BE SAVED SINCE IT MAY BE USED LATER>
1965         POPJ    P,
1966
1967
1968 SUBTTL  EOF TERMINATES LOADING OF A FILE
1969
1970 EOF:    MOVE    P,PDSAV         ;RESTORE PUSHDOWN POINTER
1971 EOF1:   TLZ F,SLIBSW!SKIPSW     ;CLEAR ONE FILE LIB. SEARCH FLAG
1972 IFN DIDAL,<TRZ  F,XFLG!LSTLOD   ;CLEAR DIDAL FLAGS>
1973 EOF2:   TLNE F,RMSMSW   ;IF REMEMBER LOADING WITH SYMBOLS IS ON
1974         TLO F,SYMSW     ;THEN RESTORE SYMBOL LOADING STATE
1975         POPJ    P,
1976
1977 ;       FORCE SCAN TO COMPLETION, LOAD IF NECESSARY
1978
1979 FSCN:   PUSHJ     P,FSCN1               ;FORCED LOAD BEFORE TEST
1980         TLNN    F,FULLSW                ;TEST FOR OVERLAP
1981         POPJ    P,                      ;NO OVERLAP, RETURN
1982         MOVE    W,H             ;FETCH CORE SIZE REQUIRED
1983         SUBI W,1(S) ; COMPUT DEFICIENCY
1984         JUMPL     W,EOF2                ;JUMP IF NO OVERLAP
1985         TLO     F,FCONSW                ;INSURE TTY OUTPUT
1986         PUSHJ   P,PRQ                   ;START WITH ?
1987         PUSHJ     P,PRNUM0              ;INFORM USER
1988         ERROR   7,</WORDS OF OVERLAP#/>
1989         JRST    LD2             ;ERROR RETURN
1990
1991 IFN SPCHN,<FSCN1A:      TLNN F,NSW
1992         PUSHJ P,LIBF>
1993 FSCN1:  TLON    F,FSW           ;SKIP IF NOT FIRST CALL TO FSCN
1994         TLNN    F,CSW+DSW+ESW   ;TEST SCAN FOR COMPLETION
1995         POPJ    P,
1996 FSCN2:  PUSHJ     P,LD5B1               ;STORE FILE OR EXTENSION IDENT.
1997
1998 ;       LOADER CONTROL, NORMAL MODE
1999
2000 LDF:    PUSHJ     P,ILD         ;INITIALIZE LOADING
2001
2002
2003 SUBTTL  LOAD SUBROUTINE
2004
2005 LOAD:   MOVEM   P,PDSAV         ;SAVE PUSHDOWN POINTER
2006 IFN WFWSW,<SETZM VARLNG         ;LENGTH OF VARIABLE AREA-ADDED TO RELOC>
2007 IFN ALGSW,<SETZM OWNLNG         ;LENGTH OF OWN AREA-ADDED TO RELOC>
2008 IFN FAILSW,<SETZM LFTHSW        ;RESET LOAD LEFT HALF FIXUP SW>
2009 LOAD1:  MOVE    P,PDSAV         ;RESTORE PUSHDOWN POINTER
2010 LOAD1A: PUSHJ   P,WORD          ;INPUT BLOCK HEADER WORD
2011         MOVNI   E,400000(W)     ;WORD COUNT - FROM RH OF HEADER
2012         HLRZ    A,W             ;BLOCK TYPE - FROM LH OF HEADER
2013 IFN FAILSW,<SKIPN POLSW         ;ERROR IF STILL DOING POLISH>
2014         CAIL    A,DISPL*2       ;TEST BLOCK TYPE NUMBER
2015         JRST    LOAD4           ;ERROR, ILLEGAL BLOCK TYPE
2016         TLNE    F,SKIPSW        ;BLOCK OK - TEST LOAD STATUS
2017         JRST    LIB1            ;RETURN TO LIB. SEARCH CONTROL
2018         HRRZ    T,LOAD2(A)      ;LOAD RH DISPATCH ENTRY
2019         CAIL    A,DISPL         ;SKIP IF CORRECT
2020         HLRZ    T,LOAD2-DISPL(A);LOAD LH DISPATCH ENTRY
2021         TLNE    F,FULLSW        ;TEST CORE OVERLAP INDICATOR
2022         SOJG    A,HIGH0         ;IGNORE BLOCK IF NOT TYPE 1
2023         JRST    @T              ;DISPATCH TO BLOCK SUBROUTINE
2024
2025 ;DISPATCH TABLE - BLOCK TYPES
2026 IFE FAILSW,<POLFIX==LOAD4A
2027         LINK==LOAD4A>
2028 IFE WFWSW,<LVARB==LOAD4A>
2029 IFE DIDAL,<INDEX==LOAD4A>
2030 IFE ALGSW!SAILSW,<ALGBLK==LOAD4A>
2031 IFE SAILSW,<LDLIB==LOAD4A>
2032
2033 LOAD2:  XWD     LOCD,   BLOCK0  ;10,,0
2034         XWD     POLFIX, PROG    ;11,,1
2035         XWD     LINK,   SYM     ;12,,2
2036         XWD     LVARB,  HISEG   ;13,,3
2037         XWD     INDEX,  LIB30   ;14,,4
2038         XWD     ALGBLK, HIGH    ;15,,5
2039         XWD     LDLIB,  NAME    ;16,,6
2040         XWD     LOAD4A, START   ;17,,7
2041
2042         DISPL==.-LOAD2
2043
2044 ;ERROR EXIT FOR BAD HEADER WORDS
2045
2046 LOAD4:  IFE K,<
2047         CAIN    A,400           ;FORTRAN FOUR BLOCK
2048         JRST    F4LD>
2049 LOAD4A: MOVE    W,A             ;GET BLOCK TYPE
2050         ERROR   ,</ILL. FORMAT BLOCK TYPE !/>
2051         PUSHJ   P,PRNUM         ;PRINT BLOCK TYPE
2052         JRST    ILC1            ;PRINT SUBROUTINE NAME
2053
2054
2055 SUBTTL  LOAD PROGRAMS AND DATA (BLOCK TYPE 1)
2056
2057 PROG:   MOVEI   V,-1(W)                 ;LOAD BLOCK LENGTH
2058         PUSHJ     P,RWORD               ;READ BLOCK ORIGIN
2059         ADD     V,W             ;COMPUTE NEW PROG. BREAK
2060 IFN REENT,<TLNN F,HIPROG
2061         JRST    PROGLW  ;NOT HIGH SEGMENT
2062 PROG3:  CAMGE W,HVAL1   ;CHECK TO SEE IF IN TOP SEG
2063         JRST LOWCOR
2064         MOVE T,JOBREL   ;CHECK FOR OVERFLOW ON HIGH
2065         CAIL T,@X
2066         JRST PROG2
2067         PUSHJ P,HIEXP
2068         JRST FULLC
2069         JRST PROG3>
2070
2071 PROGLW: MOVEI T,@X
2072         CAMG    H,T             ;COMPARE WITH PREV. PROG. BREAK
2073         MOVE H,T
2074         TLNE F,FULLSW
2075         JRST FULLC      ;NO ERROR MESSAGE
2076 IFN REENT,<CAML H,HVAL1
2077         JRST COROVL     ;WE HAVE OVERFLOWED THE LOW SEGMENT
2078         CAMLE T,HILOW
2079         MOVEM T,HILOW   ;HIGHEST LOW CODE LOADED INTO>
2080         CAILE H,1(S)  ; SKIP IF SUFFICIENT CORE AVAILABLE
2081 IFN EXPAND,<JRST [PUSHJ P,XPAND>
2082                 JRST FULLC
2083 IFN REENT,<     TLNE F,HIPROG
2084                 SUBI W,2000     ;HISEG LOADING LOW SEG>
2085 IFN EXPAND,<    JRST .-1]>
2086 PROG2:  MOVE    V,W
2087 PROG1:  PUSHJ     P,RWORD               ;READ DATA WORD
2088 IFN TEN30,<CAIN V,41    ;CHANGE FOR 10/30 JOBDAT
2089         MOVEI V,JOB41   ;JOB41 IS DIFFERENT
2090         CAIN V,74       ;SO IS JOBDAT
2091         MOVEI V,JOBDDT>
2092 IFN L,<CAML V,RINITL    ;CHECK FOR BAD STORE>
2093         MOVEM     W,@X          ;STORE DATA WORD IN PROG. AT LLC
2094         AOJA    V,PROG1         ;ADD ONE TO LOADER LOC. COUNTER
2095
2096 IFN REENT,<
2097 LOWCOR: SUB V,HIGHX     ;RELOC FOR PROPER
2098         ADD V,LOWX      ;LOADING OF LOW SEQMENT
2099         SUB W,HIGHX
2100         ADD W,LOWX
2101         JRST PROGLW>
2102
2103
2104 SUBTTL  LOAD SYMBOLS (BLOCK TYPE 2)
2105
2106 SYM:    PUSHJ   P,PRWORD        ;READ TWO DATA WORDS
2107         PUSHJ   P,SYMPT;                PUT INTO TABLE
2108 IFN REENT,<PUSHJ P,RESTRX>
2109         JRST    SYM
2110
2111 SYMPT:  TLNE C,200000   ;GLOBAL REQUEST? WFW
2112         JUMPL C,SYM3    ;CHECK FOR 60 NOT JUST HIGH BIT WFW
2113         TLNN    C,40000
2114         JRST    SYM1A           ;LOCAL SYMBOL
2115         TLNE C,100000
2116         JRST SYM1B
2117         PUSHJ     P,SREQ                ;GLOBAL DEF., SEARCH FOR REQUEST
2118         JRST    SYM2            ;REQUEST MATCHES
2119         PUSHJ     P,SDEF                ;SEARCH FOR MULTIPLE DEFINITIONS
2120         JRST    SYM1            ;MULTIPLY DEFINED GLOBAL
2121         JRST    SYM1B
2122
2123 ;       PROCESS MULTIPLY DEFINED GLOBAL
2124
2125 SYM1:   CAMN    W,2(A)          ;COMPARE NEW AND OLD VALUE
2126         POPJ    P,;
2127         AOS     MDG             ;COUNT MULTIPLY DEFINED GLOBALS
2128         PUSHJ   P,PRQ           ;START W/ ?
2129         PUSHJ     P,PRNAM               ;PRINT SYMBOL AND VALUE
2130 IFN RPGSW,<MOVE W,JOBERR        ;RECORD THIS AS AN ERROR
2131         ADDI W,1
2132         HRRM W,JOBERR>
2133         MOVE    W,2(A)          ;LOAD OLD VALUE
2134         PUSHJ     P,PRNUM               ;PRINT OLD VALUE
2135         ERROR   7,</MUL. DEF. GLOBAL IN PROG.  !/>
2136         MOVE    C,SBRNAM        ;GET PROGRAM NAME
2137         PUSHJ   P,PRNAME        ;PRINT R-50 NAME
2138         ERROR   0,</#/>
2139         POPJ    P,              ;IGNORE MUL. DEF. GLOBAL SYM
2140
2141
2142 ;       LOCAL SYMBOL
2143
2144 SYM1A:  TLNN    F,SYMSW         ;SKIP IF LOAD LOCALS SWITCH ON
2145         POPJ    P,;             IGNORE LOCAL SYMBOLS
2146 SYM1B:  CAIL    H,(S)           ;STORE DEFINED SYMBOL
2147 IFN EXPAND,<    PUSHJ P,XPAND7>
2148 IFE EXPAND,<    JRST SFULLC>
2149 SYM1C:  IFE K,<
2150         TLNE    N,F4SW;         FORTRAN FOUR REQUIRES A BLT
2151         PUSHJ   P,MVDWN;        OF THE TABLES>
2152         MOVEI   A,-2(S)         ;LOAD A TO SAVE INST. AT SYM2
2153 SYM1D:  SUBI    S,2;            UPDATE UNDEFINED POINTER
2154         POP     B,2(A)          ;MOVE UNDEFINED VALUE POINTER
2155         POP     B,1(A)          ;MOVE UNDEFINED SYMBOL
2156         MOVEM   W,2(B)          ;STORE VALUE
2157         MOVEM  C,1(B)           ;STORE SYMBOL
2158         POPJ    P,
2159
2160
2161 ;       GLOBAL DEFINITION MATCHES REQUEST
2162
2163 SYM2:   PUSH    P,SYM2C ;NEXT MUST BE A SUBROUTINE FOR LATER, SET RETURN
2164 SYM2B:  MOVE    V,2(A)          ;LOAD REQUEST POINTER
2165         PUSHJ   P,REMSYM
2166         JUMPL V,SYM2W   ;ADDITIVE REQUEST? WFW
2167         PUSHJ     P,SYM4A               ;REPLACE CHAIN WITH DEFINITION
2168 SYM2W1: PUSHJ P,SREQ    ;LOOK FOR MORE REQUESTS FOR THIS SYMBOL
2169         JRST SYM2B      ;FOUND MORE
2170         MOVE A,SVA      ;RESTORE A
2171 SYM2C:  POPJ    P,SYM1D ;RETURN, SEE SYM2 FOR USE OF ADDRESS
2172
2173 ;       REQUEST MATCHES GLOBAL DEFINITION
2174
2175 SYM2A:  MOVE    V,W             ;LOAD POINTER TO CHAIN
2176         MOVE    W,2(A)          ;LOAD VALUE
2177         JUMPL V,FIXWP   ;HANDLE ATTITIVE REQUEST WFW
2178         JRST SYM4A
2179
2180 ;       PROCESS GLOBAL REQUEST
2181
2182 SYM3:   TLNE    C,040000;               COMMON NAME
2183         JRST    SYM1B
2184         TLC     C,640000;               PERMUTE BITS FROM 60 TO 04
2185         PUSHJ     P,SDEF                ;SEARCH FOR GLOBAL DEFINITION
2186         JRST    SYM2A           ;MATCHING GLOBAL DEFINITION
2187         JUMPL W,SYM3X1  ;ADDITIVE FIXUP WFW
2188         PUSHJ     P,SREQ                ;SEARCH FOR EXISTING REQUEST WFW
2189         JRST    SYM3A           ;EXISTING REQUEST FOUND WFW
2190 SYM3X1: TLNN W,100000   ;CHECK SYMBOL TABLE FIXUP
2191         JRST     SYM3X2 ;NO
2192         MOVE     V,1(B) ;MUST BE LAST SYMBOL DEFINED. GET SYMBOL
2193         XOR      V,W            ;CHECK FOR IDENTITY
2194         TDNE     V,[XWD 77777,-1]       ;BUT IGNORE HIGH 3 BITS
2195         POPJ     P,             ;NOT SAME, ASSUME NOT LOADED LOCAL
2196         HRRI     W,2(B)         ;GET LOCATION IN RIGHT HALF
2197         TLO      W,1
2198         SUB      W,HISTRT               ;AND MAKE RELATIVE
2199 IFN FAILSW,<TLZ W,040000>
2200 SYM3X2: CAIL    H,(S)           ;STORE REQUEST IN UNDEF. TABLE WFW
2201 IFN EXPAND,<    PUSHJ P,XPAND7>
2202 IFE EXPAND,<    JRST SFULLC>
2203 SYM3X:  IFE K,<
2204         TLNE    N,F4SW;         FORTRAN FOUR
2205         PUSHJ   P,MVDWN;                ADJUST TABLES IF F4>
2206         SUB     S,SE3           ;ADVANCE UNDEFINED POINTER
2207         MOVEM     W,2(S)                ;STORE UNDEFINED VALUE POINTER
2208         MOVEM     C,1(S)                ;STORE UNDEFINED SYMBOL
2209         POPJ    P,;
2210
2211
2212
2213 ;       COMBINE TWO REQUEST CHAINS
2214
2215 SYM3A:  SKIPL 2(A)      ;IS IT ADDITIVE WFW
2216         JRST SYM3A1     ;NO, PROCESS WFW
2217 SYM3A4: PUSHJ P,SDEF2   ;YES, CONTINUE WFW
2218         JRST SYM3A      ;FOUND ANOTHER WFW
2219         JRST SYM3X2     ;REALLY NO CHAIN THERE WFW
2220 SYM3A1: SKIPE   V,2(A)  ;IF ADDRESS OF CHAIN IS 0, THROW IT AWAY
2221         JRST    SYM3A2  ;AND USE THE NEW ONE, ELSE ADD THE CHAINS
2222         MOVEM   W,2(A)  ;W IS ADDRESS OF NEW CHAIN,STORE ON TOP OF OLD 0
2223         POPJ    P,
2224 SYM3A2:
2225 SYM3A3: MOVE A,2(A)
2226 SYM3B:  HRRZ V,A
2227 IFN L,<CAMGE V,RINITL
2228         HALT>
2229 IFN REENT,<CAMGE V,HVAL1
2230         SKIPA X,LOWX
2231         MOVE X,HIGHX>
2232         HRRZ A,@X ; LOAD NEXT ADDRESS IN CHAIN
2233         JUMPN A,SYM3B  ; JUMP IF NOT THE LAST ADDR. IN CHAIN
2234         HRRM    W,@X            ;COMBINE CHAINS
2235         POPJ    P,;
2236
2237 ;WFW PATCH FOR ADDITIVE GLOBAL REQUESTS
2238
2239 FIXWP:  TLNN     V,100000       ;CHECK FOR SYMBOL TABLE FIXUP
2240         JRST     FIXW
2241         MOVE     T,1(B) ;SYMBOL FIXUP, MUST BE LAST SYMBOL DEFINED
2242         XOR      T,V            ;CHECK FO SAME
2243         TDNE     T,[XWD 77777,-1]       ;EXCEPT FOR HIGH CODE BITS
2244         POPJ     P,             ;ASSUME NON-LOADED LOCAL
2245         HRRI     V,2(B)         ;GET LOCATION
2246         SUBI     V,(X)          ;SO WE CAN USE @X
2247         JRST FIXW1
2248 FIXW:   IFN REENT,<HRRZ T,V
2249         CAMGE T,HVAL1
2250         SKIPA X,LOWX
2251         MOVE X,HIGHX>
2252 IFN L,< HRRZ T,V
2253         CAMGE R,RINITL
2254         POPJ P,>
2255 FIXW1:  TLNE    V,200000        ;IS IT LEFT HALF
2256         JRST FIXWL
2257         MOVE T,@X       ;GET WORD
2258         ADD T,W         ;VALUE OF GLOBAL
2259         HRRM T,@X       ;FIX WITHOUT CARRY
2260         MOVSI   D,200000        ;SET UP TO REMOVE DEFERED INTERNAL IF THERE
2261         JRST    SYMFIX
2262
2263
2264 FIXWL:  HRLZ    T,W             ;UPDATE VALUE OF LEFT HALF
2265         ADDM    T,@X            ;BY VALUE OF GLOBAL
2266         MOVSI   D,400000        ;LEFT DEFERED INTERNAL
2267 SYMFIX: TLNN V,100000   ;CHECK FOR SYMBOL TABLE FIXUP
2268         POPJ P,         ;NO, RETURN
2269         ADDI V,(X)      ;GET THE LOCATION
2270 SYMFX1: MOVE T,-1(V)    ;GET THE SYMBOL NAME
2271         TLNN T,40000    ;CHECK TO SEE IF INTERNAL
2272         POPJ P,         ;NO, LEAVE
2273         ANDCAB D,-1(V)  ;REMOVE PROPER BIT
2274         TLNE D,600000   ;IS IT STILL DEFERED?
2275         POPJ P,         ;YES, ALL DONE
2276         EXCH C,D        ;NO, CHECK FOR A REQUEST FOR IT
2277         PUSHJ P,SREQ
2278         JRST CHNSYM     ;YES, WILL HAVE TO CALL THE FIXUP ROUTINE
2279         MOVE C,D        ;GET C BACK
2280         POPJ P,
2281 CHNSYM: PUSH P,D        ;HAS THE OLD C IN IT
2282         PUSH P,W        ;WE MAY NEED IT LATER
2283         MOVE W,(V)      ;GET VALUE
2284         PUSHJ P,SYM2B   ;CALL THE FOUND GLOBAL TO MATCH REQUEST ROUTINE
2285         POP P,W
2286         POP P,C         ;RESTORE FOR CALLER
2287         POPJ P,         ;AND GO AWAY
2288
2289 SYM2W:  IFN FAILSW,<
2290         TLNE V,40000    ;CHECK FOR POLISH
2291         JRST POLSAT>
2292         TLNN V,100000   ;SYMBOL TABLE?
2293         JRST SYM2WA
2294         ADD V,HISTRT    ;MAKE ABSOLUTE
2295         SUBI V,(X)      ;GET READY TO ADD X
2296         PUSHJ P,FIXW1
2297         JRST SYM2W1
2298 SYM2WA: PUSHJ P,FIXW    ;DO FIXUP
2299         JRST SYM2W1     ;AND LOOK FOR MORE REQUESTS
2300
2301 ;END WFW PATCH
2302
2303
2304 ;PATCH VALUES INTO CHAINED REQUEST
2305
2306 SYM4:   IFN L,<CAMGE V,RINITL
2307         POPJ P,>
2308 IFN REENT,<CAMGE V,HVAL1
2309         SKIPA X,LOWX
2310         MOVE X,HIGHX>
2311         HRRZ    T,@X    ;LOAD NEXT ADDRESS IN CHAIN
2312         HRRM    W,@X            ;INSERT VALUE INTO PROGRAM
2313         MOVE    V,T
2314 SYM4A:  JUMPN     V,SYM4                ;JUMP IF NOT LAST ADDR. IN CHAIN
2315         POPJ    P,
2316
2317 IFE     K,<
2318 MVDWN:  HRRZ T,MLTP
2319 IFN EXPAND,<    SUBI T,2>
2320         CAIG    T,(H);          ANY ROOM LEFT?
2321 IFN EXPAND,<    JRST    [PUSHJ P,XPAND>
2322                         TLOA F,FULLSW
2323 IFN EXPAND,<            JRST MVDWN
2324                         POPJ P,]>
2325         TLNE    F,SKIPSW+FULLSW
2326         POPJ    P,      ;       ABORT BLT
2327         HRREI   T,-2
2328         ADDM    T,PLTP;         ADJUST PROGRAMMER LABEL POINTER
2329         ADDM    T,BITP;         AND BIT TABLE POINTER
2330         ADDM    T,SDSTP;        FIRST DATA STATEMENT
2331         ADDM    T,LTC
2332         ADDM    T,ITC
2333         TLNE    N,SYDAT
2334         ADDM    T,V
2335         ADDB    T,MLTP;         AND FINALLY TO MADE LABEL TABLE
2336         HRLS    T;              SET UP BLT POINTER
2337         ADD     T,[XWD 2,0]
2338         BLT     T,(S)
2339         POPJ    P,
2340 >
2341
2342
2343 SUBTTL  HIGH-SEGMENT (BLOCK TYPE 3)
2344 ;THIS PROGRAM IS INTENDED FOR HI SEGMENT IF RUNNING ON A PDP-10.
2345 ; THIS BLOCK TYPE OCCURS AFTER ENTRY AND NAME BLOCKS.
2346
2347 HISEG:  PUSHJ   P,WORD          ;GOBBLE UP A WORD.
2348         JUMPE   W,HISEG2        ;MACRO V36
2349         PUSHJ   P,WORD          ;GET THE OFSET
2350 IFE REENT,<HISEG2==LOAD1A
2351         JUMPGE  W,LOAD1A        ;NOT TWO SEG PROG.>
2352 IFN REENT,<JUMPE W,HISEG2       ;IGNORE ZERO
2353         JUMPG   W,HISEG3        ;NEG. IF TWOSEG PSEUDO-OP>
2354         TRO     F,TWOFL         ;SET FLAG
2355 IFN REENT,<
2356         TRNE    F,NOHI!NOHI6    ;TWO SEGMENTS LEGAL?
2357         JRST    ONESEG          ;LOAD AS ONE SEGMENT
2358 HISEG3: HRRZ    D,W             ;GET START OF HISEG
2359         JUMPE   D,.+2           ;NOT SPECIFIED
2360         PUSHJ   P,HCONT         ;AS IF /H
2361 HISEG2: PUSHJ   P,HISEG1
2362         JRST    LOAD1           ;GET NEXT BLOCK
2363 FAKEHI:                         ;AS IF BLOCK TYPE 3
2364 HISEG1: TRNE    F,NOHI!NOHI6    ;LOAD REENT?
2365         POPJ    P,
2366         TLOE    F,HIPROG        ;LOADING HI PROG
2367         POPJ    P,              ;IGNORE 2'ND HISEG
2368         TRON    F,SEENHI        ;HAVE WE LOADED ANY OTHER HI STUFF?
2369         PUSHJ   P,SETUPH        ;NO,SET UP HI SEG.
2370         MOVEM R,LOWR
2371         MOVE R,HIGHR
2372         HRRM    R,2(N)          ;CALL THIS THE START OF THE PROGRAM
2373         MOVE X,HIGHX
2374         POPJ    P,
2375 SETUPH: MOVE X,HVAL1
2376         CAIGE X,-1      ;SEE IF IT HAS BEEN CHANGED FROM ORIG
2377         JRST SEENHS     ;YES, MUST HAVE SEEN /H
2378         MOVEI X,400000
2379         MOVEM X,HVAL1
2380         CAIG X,(H)      ;HAVE WE RUN OVER WITH THE LOW SEG
2381         JRST COROVL
2382         ADDI X,JOBHDA
2383         HRLI X,W
2384         MOVEM X,HVAL
2385 SEENHS: MOVE X,HVAL
2386         MOVEM X,HIGHR
2387         HRRZ X,JOBREL
2388         SUB X,HVAL1
2389         ADDI X,1
2390         HRLI X,V
2391         MOVEM X,HIGHX
2392         POPJ P,
2393
2394
2395
2396 SETSEG: TRZ     F,NOHI!SEGFL    ;ALLOW HI-SEG
2397         JUMPL   D,.+2           ;/-H TURNS OFF NOHI ONLY
2398         TRO     F,SEGFL         ;/1H FORCES  HI
2399         POPJ    P,
2400 >
2401
2402 ONESEG: HLRZ    D,W             ;GET LENGTH OF HISEG
2403         SUBI    D,(W)           ;REMOVE OFSET
2404         JUMPLE  D,TWOERR        ;LENGTH NOT AVAILABLE
2405         MOVEM   R,LOWR          ;SAVE LOW SEGMENT RELOCATION
2406         ADDM    D,LOWR          ;ADD TO LOW SEG RELOCATION
2407         HRRZM   W,HVAL1         ;SO RELOC WILL WORK
2408         JRST    LOAD1           ;GET NEXT BLOCK
2409
2410 TWOERR: ERROR   7,</TWO SEGMENTS ILLEGAL#/>
2411         JRST    LDRSTR
2412
2413
2414 SUBTTL  HIGHEST RELOCATABLE POINT (BLOCK TYPE 5)
2415 SFULLC: TLOE    F,FULLSW        ;PREVIOUS OVERFLOW?
2416         JRST    FULLC           ;YES, DON'T PRINT MESSAGE
2417         ERROR   ,<?SYMBOL TABLE OVERLAP#?>
2418 FULLC:  TLO     F,FULLSW        ;CORE OVERLAP ERROR RETURN
2419 IFE K,< TLNE    N,F4SW
2420         POPJ    P,>
2421         JRST    LIB3            ;LOOK FOR MORE
2422 HIGH2:  PUSHJ   P,RWORD         ;GET HISEG BREAK
2423         TRZ     F,TWOFL         ;CLEAR FLAG NOW
2424 IFE REENT,<     MOVE    R,LOWR
2425         JRST    HIGH2A>
2426 IFN REENT,<     TRNE    F,NOHI!NOHI6    ;SINGLE SEGMENT LOAD?
2427         JRST    [MOVE   R,LOWR  ;YES,GET LARGER RELOC
2428                 MOVE    W,HVAL  ;ORIGINAL VALUE
2429                 MOVEM   W,HVAL1 ;RESET
2430                 JRST    HIGH2A] ;CONTINUE AS IF LOW ONLY
2431         HRR     R,W             ;PUT BREAK IN R
2432         CAMLE   R,HVAL
2433         MOVEM   R,HVAL
2434         MOVEM   R,HIGHR
2435         MOVE    R,LOWR          ;NEXT WORD IS LOW SEG BREAK
2436         TLZ     F,HIPROG        ;CLEAR HIPROG
2437         PUSHJ   P,PRWORD        ;GET WORD PAIR
2438         HRR     R,C             ;GET LOW SEG BREAK
2439         MOVEM   R,LOWR          ;SAVE IT
2440         MOVE    R,HIGHR         ;GET HIGH BREAK
2441         JRST    HIGHN3          ;AND JOIN COMMON CODE>
2442
2443 HIGH0:  CAIE    A,4             ; TEST FOR END BLOCK (OVERLAP)
2444         JRST    LIB30
2445
2446 HIGH:   TRNE    F,TWOFL         ;IS THIS A TWO SEGMENT PROGRAM?
2447         JRST    HIGH2           ;YES
2448 HIGH2A: PUSHJ   P,PRWORD        ;READ TWO DATA WORDS.
2449 IFN REENT,<     TLZE F,HIPROG
2450         JRST HIGHNP>
2451 IFN WFWSW,<ADD C,VARLNG         ;IF LOW SEG THEN VARIABLES GO AT END>
2452 IFN ALGSW,<ADD  C,OWNLNG        ;ADD IN LENGTH OF OWN BLOCK>
2453         HRR R,C         ;SET NEW PROGRAM BREAK
2454         CAMGE C,W       ;CHECK 2ND WORD (LOC PROG BRK IF PRESENT)
2455         MOVE C,W
2456 HIGH31: ADDI C,(X)
2457         CAIG H,(C)
2458         MOVEI H,(C)     ;SET UP H
2459         CAILE   H,1(S)  ;TEST PROGRAM BREAK
2460 IFN EXPAND,<PUSHJ P,[   PUSHJ P,XPAND
2461                         TLOA F,FULLSW
2462                         JRST POPJM2
2463                         POPJ    P,]>
2464 IFE EXPAND,<TLO F,FULLSW>
2465 HIGH3:  MOVEI A,F.C
2466         BLT A,B.C
2467 IFN REENT,<TRNE F,NOHI!NOHI6    ;ONE SEGMENT PROGRAM?
2468         JRST    HIGHN4          ;YES
2469         HRLZ    W,HIGHR         ;GET HIGH PROG BREAK
2470         JUMPE   W,[HRRZ W,R     ;NO HIGH SEGMENT YET
2471                 JRST    .+2]    ;SO USE LOW RELOCATION ONLY
2472         HRR     W,LOWR          ;GET LOW BREAK
2473         SETZ    C,              ;ZERO SYMBOL NAME
2474         PUSHJ   P,SYM1B         ;PUT IN SYMBOL TABLE
2475         MOVEM   S,F.C+S         ;SAVE NEW S AND B
2476         MOVEM   B,F.C+B         ;INCASE OF ERROR
2477 HIGHN4:>
2478         TLZ     F,NAMSSW        ;RELAX, RELOCATION BLOCK FOUND
2479         TLNE    F,SLIBSW+LIBSW  ;NORMAL MODE EXIT THROUGH LOAD1
2480         JRST    LIB             ;LIBRARY SEARCH EXIT
2481         JRST LOAD1
2482 IFN REENT,<
2483 HIGHNP: HRR R,C
2484 HIGHN1: CAMLE R,HVAL
2485         MOVEM R,HVAL
2486         MOVEM R,HIGHR
2487 HIGHN3: PUSH    P,W     ;SAVE W,CONTAIN HIGHEST ABSOLUTE ADDRESS
2488         ADD W,LOWX      ;LOC PROG BRK
2489         CAIGE H,(W)     ;CHECK FOR TOP OF LOW CORE
2490         MOVEI H,(W)
2491         POP     P,W     ;RESTORE
2492         CAML H,HVAL1
2493         JRST COROVL     ;OVERFLOW OF LOW SEGMENT
2494 HIGHN2: HRRZ R,HVAL
2495         SUB R,HVAL1
2496         ADD R,HISTRT
2497         CAMLE R,JOBREL
2498         JRST    [PUSHJ P,HIEXP
2499                 JRST FULLC
2500                 JRST HIGHN2]
2501         MOVE R,LOWR
2502         MOVE X,LOWX
2503 IFN WFWSW,<ADD R,VARLNG ;VARIABLES IN LOW SEG>
2504 IFN ALGSW,<ADD R,OWNLNG ;OWN BLOCK IN LOW SEGMENT>
2505         HRRZ C,R
2506         CAIGE   C,(W)   ;IS ABSOLUTE LOCATION GREATER
2507         HRR     R,W     ;YES USE IT
2508
2509
2510         HRRZ    C,R     ;SET UP C AGAIN
2511         JRST HIGH31     ;GO CHECK PROGRAM BREAK
2512
2513
2514 SUBTTL  EXPAND HIGH SEGMENT
2515
2516 HIEXP:  TLNE    F,FULLSW
2517         POPJ    P,
2518 IFN EXPAND,<PUSH P,Q>
2519         PUSH P,H
2520         PUSH P,X
2521         PUSH P,N
2522 IFE K,<HRRZ X,MLTP
2523         TLNN N,F4SW>
2524         MOVEI X,1(S)
2525         HRRZ N,X
2526         SUB N,H
2527         CAILE N,1777
2528         JRST MOVHI
2529 IFE EXPAND,<POPJ P,>
2530 IFN EXPAND,<HRRZ N,JOBREL
2531         ADDI N,2000
2532         CAMG    N,ALWCOR
2533         CORE N,
2534         JRST XPAND6
2535         PUSHJ P,ZTOP
2536         POP P,N
2537         JRST XPAND3>
2538
2539 MOVHI:  MOVEI N,-2000(X)
2540         HRL N,X
2541         HRRZ X,JOBREL
2542         BLT N,-2000(X)
2543         PUSHJ P,ZTOP
2544         MOVNI H,2000
2545 IFN EXPAND,<JRST XPAND8>
2546 IFE EXPAND,<ADDM H,HISTRT
2547         ADDM H,S
2548         ADDM H,B
2549         ADDM H,HIGHX
2550         TLNE F,HIPROG
2551         ADDM H,-1(P)
2552         POP P,N
2553         SUBI N,2000     ;ADJUST POINTER TO NAME
2554 IFE K,< TLNN F4SW
2555         JRST HIXP1
2556         ADDM H,PLTP
2557         ADDM H,BITP
2558         ADDM H,SDSTP
2559         ADDM H,MLTP
2560         TLNE N,SYDAT
2561         ADDM H,V
2562 HIXP1:>
2563         POP P,X
2564         POP P,H
2565         AOS (P)
2566         POPJ P,>
2567
2568 ZTOP:   HRRZ N,JOBREL
2569         MOVEI X,-1776(N)
2570         HRLI X,-1777(N)
2571         SETZM -1(X)
2572         BLT X,(N)
2573         POPJ P,>
2574
2575
2576 SUBTTL  PROGRAM NAME (BLOCK TYPE 6)
2577
2578 NAME:   TLOE    F,NAMSSW        ;HAVE WE SEEN TWO IN A ROW?
2579         JRST    NAMERR          ;YES, NO END BLOCK SEEN
2580         PUSHJ   P,PRWORD        ;READ TWO DATA WORDS
2581         MOVEM   C,SBRNAM        ;SAVE SUBROUTINE NAME
2582 NCONT:  HLRE    V,W             ;GET COMPILER TYPE
2583         HRRZS   W               ;CLEAR TYPE
2584         JUMPL   V,.+3
2585         CAIGE   V,CMPLEN-CMPLER ;ONLY IF LEGAL TYPE
2586         XCT     CMPLER(V)       ;DO SPECIAL FUNCTION
2587         TLOE    N,COMFLG        ;SKIP IF COMMON NOT PREV. SET
2588         JRST    NAME1           ;SIZE OF COMMON PREV. SET
2589         MOVEM   W,COMSAV        ;STORE LENGTH OF COMMON
2590         JUMPE   W,NAME2         ;JUMP IF NO COMMON IN THIS JOB
2591         HRRI    R,@R            ;FIRST PROGRAM SET LOAD ORIGIN
2592 NAME1:  CAILE   H,-1(S)         ;TEST FOR AVAIL. SYMBOL SPACE
2593 IFN EXPAND,<    PUSHJ P,XPAND7>
2594 IFE EXPAND,<    JRST SFULLC>
2595         SUBI    S,2             ;UPDATE UNDEF. TABLE POINTER
2596         POP     B,2(S)
2597         POP     B,1(S)
2598         HRRZ    V,N             ;POINTER TO PREVIOUS NAME
2599         SUBM    B,V             ;COMPUTE RELATIVE POSITIONS
2600         HRLM    V,2(N)          ;STORE FORWARD POINTER
2601         HRR     N,B             ;UPDATE NAME POINTER
2602 NAME2:  MOVEM   C,1(B)          ;STORE PROGRAM NAME
2603         HRRZM   R,2(B)          ;STORE PROGRAM ORIGIN
2604         CAMG    W,COMSAV        ;CHECK COMMON SIZE
2605 IFE REENT,<JRST LIB3            ;COMMON OK>
2606 IFN REENT,<JRST [TRNE F,SEGFL   ;LOAD LOW IN HI-SEG
2607                 PUSHJ P,FAKEHI  ;YES
2608                 JRST    LIB3]>
2609         SKIPA   C,COMM
2610 ILC:    MOVE    C,1(A)          ;NAME
2611         PUSH    P,C             ;SAVE COMMON NAME
2612         ERROR   ,</ILL. COMMON !/>
2613         POP     P,C
2614         PUSHJ   P,PRNAME
2615 ILC1:   SKIPN   SBRNAM
2616         JRST    ILC2
2617         ERROR   0,</ PROG. !/>
2618         MOVE    C,SBRNAM        ;RECOVER SUBROUTINE NAME
2619         PUSHJ   P,PRNAME
2620 ILC2:   ERROR   0,</ #/>
2621         JRST    LD2
2622
2623 NAMERR: SETZM   DTIN            ;CLEAR WRONG FILE NAME FOR MESSAGE
2624         ERROR   ,</NO END BLOCK !/>
2625         JRST    ILC1
2626
2627
2628
2629 ;COMPILER TYPE - DO SPECIAL FUNCTION FOR IT
2630
2631 DEFINE CTYPE (CONDITION,TRUE,FALSE)
2632 <IFN CONDITION,<TRUE>
2633 IFE CONDITION,<FALSE>>
2634
2635 CMPLER: CTYPE 1,JFCL,JFCL               ;0 MACRO
2636         CTYPE K-1,<TRO F,F4FL>,JFCL     ;1 FORTRAN
2637         CTYPE 1,<TRO F,COBFL>,JFCL      ;2 COBOL
2638         CTYPE ALGSW,<PUSHJ P,ALGNAM>,JFCL       ;3 ALGOL
2639                                         ;4 NELIAC
2640                                         ;5 PL/1
2641 CMPLEN:
2642
2643
2644
2645 SUBTTL  STARTING ADDRESS (BLOCK TYPE 7)
2646
2647
2648 START:  PUSHJ   P,PRWORD        ;READ TWO DATA WORDS
2649         TLNN    N,ISAFLG        ;SKIP IF IGNORE SA FLAG ON
2650         HRRZM   C,STADDR        ;SET STARTING ADDRESS
2651 IFN NAMESW,<
2652         MOVE    W,DTIN          ;PICK UP BINARY FILE NAME
2653         TLNN N,ISAFLG
2654         MOVEM   W,PRGNAM        ;SAVE IT
2655         MOVE    W,1(N)          ;SET UP NAME OF THIS PROGRAM
2656         TLNN    N,ISAFLG        ;DONT SET NAME IF IGNORING SA'S
2657         PUSHJ   P,LDNAM>
2658         PUSHJ   P,PRWORD        ;**OBSCURE RETURN TO LOAD1**
2659
2660 IFN REENT,<
2661 RESTRX: TLNE F,HIPROG
2662         SKIPA X,HIGHX
2663         MOVE X,LOWX
2664         POPJ P,>
2665
2666
2667 SUBTTL  ONE PASS LOCAL DEFINITION (BLOCK TYPE 10)
2668
2669                                 ;PMP PATCH FOR LEFT HALF FIXUPS
2670 IFN FAILSW!WFWSW,<
2671 LOCDLH: IFN L,<CAMGE V,RINITL
2672         POPJ P,>
2673 IFN REENT,<CAMGE V,HVAL1
2674         SKIPA X,LOWX
2675         MOVE X,HIGHX>
2676         HLRZ T,@X       ;LOAD NEXT ADDRESS IN CHAIN
2677         HRLM W,@X       ;INSERT VALUE INTO PROGRAM
2678         MOVE V,T
2679 LOCDLF: JUMPN V,LOCDLH  ;JUMP IF NOT LAST ADDR. IN CHAIN
2680         POPJ    P,>
2681 IFN FAILSW,<
2682 LOCDLI: PUSHJ   P,LOCDLF
2683 IFN REENT,<PUSHJ P,RESTRX>
2684         AOSA LFTHSW     ;TURN OFF LEFT HALF FIX SW (WAS -1) AND SKIP
2685 LOCDLG: SETOM LFTHSW    ;TURN ON LEFT HALF FIX SW>
2686                         ;END PMP PATCH
2687 LOCD:   PUSHJ     P,RWORD               ;READ ONE DATA WORD
2688         HLRZ    V,W             ;STORAGE POINTER IN LEFT HALF
2689 IFN FAILSW,<
2690         SKIPE LFTHSW    ;LEFT HALF CHAINED? PMP
2691         JRST LOCDLI     ;YES PMP
2692         CAMN W,[-1]     ;LEFT HALF NEXT? PMP
2693         JRST LOCDLG     ;YES, SET SWITCH PMP>
2694         PUSHJ     P,SYM4A               ;LINK BACK REFERENCES
2695 IFN REENT,<PUSHJ P,RESTRX>
2696         JRST    LOCD
2697
2698
2699 SUBTTL  LVAR FIX-UP (BLOCK TYPE 13)
2700 IFN WFWSW,<
2701 LVARB:  PUSHJ P,PRWORD  ;THE FIRST TWO WORDS IN THE BLOCK
2702         MOVEM W,VARLNG  ;AR SPECIAL. SECOND IS LENGTH OF VARIABLES
2703 IFN REENT,<     TLNE F,HIPROG
2704                 MOVE C,LOWR     ;USE LOW RELOC IF LOADING HI SEG>
2705                 ;ELSE C HAS RELOC FOR THIS PROGRAM, USE IT
2706         HRRZM C,VARREL  ;THIS IS LOCATION 0 OF VARIABLE AREA
2707 LVLP:   PUSHJ P,PRWORD  ;THINGS COME IN PAIRS
2708         TLNE C,200000   ;BIT ON IF SYMBOL TABLE FIXUP
2709         JRST LVSYM
2710         HLRZ V,W        ;NO GET LOC FROM LEFTH HALF OF SECOND
2711         ADD W,VARREL    ;AND RELOCATE VARIABLE
2712         TLNE C,400000   ;ON FOR LEFT HALF
2713         JRST    [PUSHJ P,LOCDLF ;TAKE CARE OF IT
2714 IFN REENT,<     JRST LVLCOM]    ;RESET X>
2715 IFN REENT,<     JRST LVLP]      ;MUST BE LOW SEG X OK>
2716         PUSHJ P,SYM4A   ;RIGHT HALF CHAIN
2717 IFN REENT,<LVLCOM:      PUSHJ P,RESTRX>
2718         JRST LVLP
2719 LVSYM:  MOVE V,B        ;GET SYMBOL TABLE POINTER
2720         ADD C,VARREL    ;VALUE IS IN FIRST WORD FOR THESE
2721         TLZ W,740000    ;MAKE SURE NO BITS ON
2722         ADDI V,2        ;CORRECT POINTER TO SYMBOL TABLE
2723 SRSYM:  MOVE A,-1(V)    ;GET A NAME
2724         TLZN A,740000   ;CHECK FOR PROGRAM NAME
2725         JRST LVLP       ;LEAVE (PROBABLY A NON-LOADED LOCAL)
2726         CAMN A,W        ;IS IT THE RIGHT ONE??
2727         JRST LVSYMD     ;YES
2728         ADD V,SE3       ;CHECK NEXT ONE
2729         JUMPL V,SRSYM   ;BUT ONLY IF SOME ARE THERE
2730         JRST LVLP       ;GIVE UP
2731 LVSYMD: TLNE C,400000   ;WHICH HALF??
2732         JRST LVSYML     ;LEFT
2733         ADD C,(V)       ;ADDITIVE FIXUP
2734         HRRM C,(V)
2735         MOVSI D,200000  ;DEFERED BITS
2736 LVSM1:  PUSHJ P,COMSFX  ;GO TAKE CARE OF IT
2737         JRST LVLP       ;NEXT PLEASE
2738 LVSYML: HRLZS C
2739         ADDM C,(V)      ;WE DON'T HAVE TO WORRY ABOUT OVERFLOW HERE
2740         MOVSI D,400000  ;LEFT DEFERED BITS
2741         JRST LVSM1      ;GO WORRY ABOUT DEFERED INTERNALS>
2742
2743
2744 SUBTTL  FAIL LOADER
2745 ;ONLY LIST IF FAILSW=1
2746         XLIST
2747 IFN FAILSW,<LIST>
2748 REPEAT 0,<IF POLISH FIXUPS CONTAIN GLOBAL REQUESTS WHICH
2749 CAN NOT BE SATISFIED WHEN THEY ARE SEEN, THEY MUST BE
2750 SAVED UNTIL THESE GLOBAL SYMBOLS BECOME DEFINED.
2751 THE POLISH FIXUP IS SAVED IN THE UNDEFINED TABLE (POINTED
2752 TO BY S). THE FIXUP IS SAVED IN TWO WORD BLOCKS THE FIRST
2753 WORD OF WHICH (THE ONE WHICH WOULD NORMALL CONTAIN THE SYMBOL)
2754 HAS SPECIAL BITS ON SO IT WILL NOT BE FOUND BY A SEARCH FOR
2755 A GLOBAL REQUEST. SINCE THE UNDEFINED TABLE MAY BE
2756 SHUFFELED INTO A RANDOM ORDER, IT IS NOT POSSIBLE TO KEEP
2757 ALL OF A POLISH FIXUP TOGETHER OR TO HAVE POINTERS IN
2758 THE USUAL SENCE FROM ONE TWO WORD BLOCK TO ANOTHER.
2759 SUFFICIENT INFORMATION IS THEREFORE GIVEN TO DETERMINE
2760 WHAT THE FIRST WORD OF THE NEXT DESIRED BLOCK IS AND THIS
2761 BLOCK IS FOUND BY SEARCHING THE UNDEFINED TABLE FOR A MATCH.
2762 EACH POLISH FIXUP WHICH IS ENTERED INTO THE UNDEFINED
2763 TABLE IS GIVEN A UNIQUE NUMBER CALLED THE "HEAD NUMBER".
2764 EACH ELEMENT OF THE FIXUP (EITHER OPERAND OR OPERATOR)
2765 IS ASSIGNED A NUMBER CALLED THE "OP NUMBER". THUS
2766 THE OP NUMBER AND HEAD NUMBER TOGETHER DETERMINE
2767 A SPECIFIC ELEMENT OF A SPECIFIC FIXUP. EACH ELEMENT
2768 (TWO WORD BLOCK) IS ARRANGED AS FOLLOWS:
2769 WORD 1:
2770         BITS 0-4  THESE ARE THE USUAL CODE BITS OF A RADIX50
2771                 SYMBOL AND CONTAIN 44 TO DISTINGUISH
2772                 AN ELEMENT OF A POLISH FIXUP FROM OTHER
2773                 SYMBOLS IN THE UNDEFINED TABLE
2774         BITS 5-17 THE HEAD NUMBER OF THIS FIXUP
2775         BITS 18-30 THE OP NUMBER OF THIS ELEMENT
2776         BITS 31-35 THE OPERAND FOR THIS ELEMENT
2777                 OPERAND 2 INDICATES A WORD OF DATA
2778 WORD 2:
2779         IF THE OPERAND IS 2 THIS WORD CONTAINS THE DATA
2780
2781         IF THIS IS NOT A DATA OPERATOR THEN THE LEFT AND
2782         RIGHT HALVES OF THIS WORD POINT TO THE TWO OPERANDS
2783         THE CONTENTS OF THE HALF WORD IS THE RIGHT HALF
2784         OF THE FIRST WORD OF THE BLOCK POINTED
2785         TO. THUS THE LEFT HALF OF THE FIRST WORD COMBINED
2786         WITH ONE OF THESE HALF WORDS IS THE FIRST WORD
2787         OF THE BLOCK POINTED TO AND CAN BE FOUND BY SEARCHING
2788
2789 EACH FIXUP ALSO HAS A HEADER BLOCK. THIS BLOCK CONTAINS THE
2790 FOLLOWING INFORMATION:
2791 WORD 1:
2792         BITS 0-17 0
2793         BITS 18-21  44
2794         BITS 22-35 THE HEAD NUMBER OF THIS FIXUP
2795
2796 WORD 2:
2797         BITS 0-17 A COUNT OF THE NUMBER OF UNDEFINED
2798                 GLOBALS REMAINING IN THIS FIXUP
2799         BITS 18-35 A HALF WORD POINTER OF THE
2800                 SAME TYPE FOUND IN OTHER ELEMENTS POINTING
2801                 TO THE FIRST ELEMENT OF POLISH
2802                 WHICH WILL BE THE STORE OPERATOR
2803
2804 THE REQUESTS FOR THE GLOBAL SYMBOLS NEEDED BY THE FIXUP ARE
2805 ENTERED AS FOLLOWS:
2806
2807 WORD 1:
2808         BITS 0-4  04
2809         BITS 5-35  RADIX 50 FOR THE NAME OF THE SYMBOL
2810
2811
2812 (NOTE THIS IS JUST A STANDARD GLOBAL REQUEST)
2813
2814 WORD 2:
2815         BITS 0-4 44 (THIS IDENTIFIES IT AS "ADITIVE TYPE"
2816                 AND BIT 4 INDICATES POLISH)
2817         BITS 5-17 THE HEAD NUMBER OF THE FIXUP
2818                 (THIS GIVES ENOUGH INFORMATION TO FIND THE HEADER
2819                 BLOCK AND UPDATE THE COUNT WHEN THE REQUEST IS
2820
2821
2822                 SATISFIED)
2823         BITS 18-35  A HALF WORD POINTER TO THE ELEMENT OF THE
2824                 FIXUP INTO WHICH THE VALUE OF
2825
2826
2827                 THE SYMBOL SHOULD BE STORED
2828 >
2829
2830
2831 IFN FAILSW,<
2832 ;POLISH FIXUPS <BLOCK TYPE 11>
2833
2834 PDLOV:  SKIPE POLSW     ;PDL OV ARE WE DOING POLISH?
2835         JRST COMPOL     ;YES
2836         ERROR ,</PUSHDOWN OVERFLOW#/>
2837         JRST LD2
2838 COMPOL: ERROR ,</POLISH TOO COMPLEX#/>
2839         JRST LD2
2840
2841
2842 ;READ A HALF WORD AT A TIME
2843
2844 RDHLF:  TLON N,HSW      ;WHICH HALF
2845         JRST NORD
2846         PUSHJ P,RWORD   ;GET A NEW ONE
2847         TLZ N,HSW       ;SET TO READ OTEHR HALF
2848         MOVEM W,SVHWD   ;SAVE IT
2849         HLRZS W         ;GET LEFT HALF
2850         POPJ P,         ;AND RETURN
2851 NORD:   HRRZ W,SVHWD    ;GET RIGHT HALF
2852         POPJ P,         ;AND RETURN
2853
2854
2855 POLFIX: MOVE D,[IOWD PPDL,PPDB] ;SET UP THE POLISH PUSHDOWN LIST
2856         MOVEI V,100     ;IN CASE OF ON OPERATORS
2857         MOVEM V,SVSAT
2858         SETOM POLSW     ;WE ARE DOING POLISH
2859         TLO N,HSW       ;FIX TO READ A WORD THE FIRST TIME
2860         SETOM GLBCNT    ;NUMBER OF GLOBALS IN THIS FIXUP
2861         SETOM OPNUM     ;NUMBER OF OPERANDS AND OPERATORS THIS FIXUP
2862         PUSH D,[15]     ;FAKE OPERATOR SO STORE WILL NOT HACK
2863
2864 RPOL:   PUSHJ P,RDHLF   ;GET A HLAF WORD
2865         TRNE W,400000   ;IS IT A STORE OP?
2866         JRST STOROP     ;YES, DO IT
2867 IFN WFWSW,<CAIN W,15
2868         JRST    [PUSHJ P,RDHLF  ;THIS TRICK FOR VARIABLES
2869                 ADD W,VARREL    ;HOPE SOMEONE HAS DONE
2870                 HRRZ C,W        ;A BLOCK TYPE 13
2871                 JRST HLFOP]>
2872         CAIGE W,3       ;0,1,2 ARE OPERANDS
2873         JRST OPND
2874         CAILE W,14      ;14 IS HIGHEST OPERATOR
2875         JRST LOAD4A     ;ILL FORMAT
2876         PUSH D,W        ;SAVE OPERATOR IN STACK
2877         MOVE V,DESTB-3(W)       ;GET NUMBER OF OPERANDS NEEDED
2878         MNVEM V,SVSAT   ;ALSO SAVE IT
2879         JRST RPOL       ;BACK FOR MORE
2880
2881
2882
2883 ;HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
2884 ;GLOBAL REQUESTS
2885
2886 OPND:   MOVE A,W        ;GET THE OPERAND TYPE HERE
2887         PUSHJ P,RDHLF   ;THIS IS AT LEAST PART OF THE OPERAND
2888         MOVE C,W        ;GET IT INTO C
2889         JUMPE A,HLFOP   ;0 IS HALF-WORD OPERAND
2890         PUSHJ P,RDHLF   ;NEED FULL WORD, GET SECOND HALF
2891         HRL C,W ;GET HALF IN RIGHT PLACE
2892         MOVSS C         ;WELL ALMOST RIGHT
2893         SOJE A,HLFOP    ;1 IS FULL WORD, 2 IS GLOBAL REQUEST
2894         PUSHJ P,SDEF    ;SEE IF IT IS ALREADY DEFINED
2895         JRST    [MOVE C,2(A)    ;YES, WE WIN
2896                 JRST HLFOP]
2897         AOSN GLBCNT     ;NO, INCREMENT NUMBER OF GLOBALS THIS FIXUP
2898         AOS HEADNM      ;INCREMENT FIXUP NUMBER IF FIRST GLOBAL
2899         AOS W,OPNUM     ;GET AN OPERAND NUMBER
2900         LSH W,5         ;SPACE FOR TYPE
2901         IORI W,2        ;TYPE 2 IS GLOBAL
2902         HRL W,HEADNM    ;GET FIXUP NUMBER
2903         PUSHJ P,SYM3X2  ;AND PUT INTO UDEFINED AREA ALONG WITH NAME
2904         MOVE C,W        ;ALSO PUT THAT PART OF THE FIXUP IN
2905         PUSHJ P,SYM3X2
2906         SKIPA A,[400000]        ;SET UP GLOBAL FLAG
2907 HLFOP:  MOVEI A,0       ;VALUE OPERAND FLAG
2908 HLFOP1: SOJL V,CSAT     ;ENOUGH OPERANDS SEEN?
2909         PUSH D,C        ;NO, SAVE VALUE(OR GLOBAL NAME)
2910         HRLI A,400000   ;PUT IN A VALUE MARKER
2911         PUSH D,A        ;TO THE STACK
2912         JRST RPOL       ;GET MORE POLISH
2913
2914
2915
2916 ;HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR
2917
2918 CSAT:   HRRZS A         ;KEEP ONLY THE GLOBAL-VALUE HALF
2919         SKIPN SVSAT     ;IS IT UNARY
2920         JRST UNOP       ;YES, NO NEED TO GET 2ND OPERAND
2921         HRL A,(D)       ;GET GLOBAL VALUE MARKER FOR 2ND OP
2922         POP D,W
2923         POP D,W         ;VALUE OR GLOBAL NAME
2924 UNOP:   POP D,V         ;OPERATOR
2925         JUMPN A,GLOB    ;IF EITHER IS A GLOBAL HANDLE SPECIALLY
2926         XCT OPTAB-3(V)  ;IF BOTH VALUES JUST XCT
2927         MOVE C,W        ;GET THE CURRENT VALUE
2928 SETSAT: SKIPG V,(D)     ;IS THERE A VALUE IN THE STACK
2929         MOVE V,-2(D)    ;YES, THIS MUST BE THE OPERATOR
2930         MOVE V,DESTB-3(V)       ;GET NUMBER OF OPERANDS NEEDED
2931         MOVEM V,SVSAT   ;SAVE IT HERE
2932         SKIPG (D)       ;WAS THERE AN OPERAND
2933         SUBI V,1        ;HAVE 1 OPERAND ALREADY
2934         JRST HLFOP1     ;GO SEE WHAT WE SHOULD DO NOW
2935
2936 ;HANDLE GLOBALS
2937 GLOB:   TRNE A,-1       ;IS IT IN RIGHT HALF
2938         JRST TLHG       ;NO, NEED TO PUT THIS VALUE INTO THE FIXUP LIST
2939         PUSH P,W        ;SAVE FOR A WHILE
2940         MOVE W,C        ;THE VALUE
2941         AOS C,OPNUM     ;GET AN OPERAND NUMBER
2942         LSH C,5         ;AND PUT IN TYPE
2943         IORI C,2        ;VALUE TYPE
2944         HRL C,HEADNM    ;THE FIXUP NUMBER
2945         PUSHJ P,SYM3X2
2946         POP P,W         ;RETRIEVE THE OTHER VALUE
2947 TLHG:   SKIPE SVSAT     ;WAS THIS A UNARY OPERATOR
2948         TLNE A,-1       ;WAS THERE A GLOBAL IN LEFT HALF
2949         JRST GLSET
2950         PUSH P,C        ;SAVE THE FIRST OPERAND
2951         AOS C,OPNUM     ;SEE ABOVE
2952         LSH C,5
2953         IORI C,2
2954         HRL C,HEADNM
2955         PUSHJ P,SYM3X2
2956         MOVE W,C
2957         POP P,C
2958
2959 GLSET:  EXCH C,W        ;GET THEM IN THE OTHER ORDER
2960         HRL W,C         ;SET UP THE OPERATOR LINK
2961         AOS C,OPNUM
2962         LSH C,5 ;SPACE FOR THYPE
2963         IOR C,V         ;THE OPERATOR
2964         HRL C,HEADNM
2965         PUSHJ P,SYM3X2  ;INTO THE UNDEF LIST
2966                 MOVEI A,400000  ;SET UP AS A GLOBAL VALUE
2967         JRST SETSAT     ;AND SET UP FOR NEXT OPERATOR
2968
2969
2970 ;FINALLY WE GET TO STORE THIS MESS
2971
2972 STOROP: MOVE T,-2(D)    ;THIS SHOULD BE THE FAKE OPERATOR
2973         CAIE T,15       ;IS IT
2974         JRST LOAD4A     ;NO, ILL FORMAT
2975         HRRZ T,(D)      ;GET THE VALUE TYPE
2976         JUMPN T,GLSTR   ;AND TREAT GLOBALS SPECIAL
2977         MOVE A,W        ;THE TYPE OF STORE OPERATOR
2978         CAIGE A,-3
2979         PUSHJ P,FSYMT
2980         PUSHJ P,RDHLF   ;GET THE ADDRESS
2981         MOVE V,W        ;SET UP FOR FIXUPS
2982         POP D,W         ;GET THE VALUE
2983         POP D,W         ;AFTER IGNORING THE FLAG
2984         PUSHJ P,@STRTAB+6(A)    ;CALL THE CORRECT FIXUP ROUTINE
2985 COMSTR: SETZM POLSW     ;ALL DONE WITH POLISH
2986 IFN REENT,<PUSHJ P,RESTRX>
2987         MOVE T,OPNUM    ;CHECK ON SIZES
2988         MOVE V,HEADNM
2989         CAIG V,477777
2990         CAILE T,17777
2991         JRST COMPOL     ;TOO BIG, GIVE ERROR
2992         PUSHJ P,RWORD   ;THIS SHOULD GET US OUT (I.E RUN OUT COUNT)
2993         JRST LOAD4A     ;IF NOT, SOMETHING IS WRONG
2994
2995 STRTAB: EXP ALSYM,LFSYM,RHSYM,ALSTR,LOCDLF,SYM4A,FAKESY
2996
2997 GLSTR:  MOVE A,W
2998         CAIGE A,-3
2999         PUSHJ P,FSYMT
3000         PUSHJ P,RDHLF   ;GET THE STORE LOCATION
3001         MOVEI A,23(A)
3002         POP D,V         ;GET VALUE
3003         POP D,V
3004         HRLM V,W        ;SET UP STORAGE ELEMENT
3005         AOS C,OPNUM
3006         LSH C,5
3007         IOR C,A
3008         HRL C,HEADNM
3009         PUSHJ P,SYM3X2
3010         MOVE W,C        ;NOW SET UP THE HEADER
3011         AOS V,GLBCNT    ;WHICH HAS NUMBER OF GLOBALS
3012         HRLM V,W
3013         HRRZ C,HEADNM
3014         PUSHJ P,SYM3X2
3015         JRST COMSTR     ;AND FINISH
3016
3017
3018
3019 ALSTR1: IFN L,<CAMGE V,RINITL
3020         POPJ P,>
3021 IFN REENT,<CAMGE V,HVAL1
3022                 SKIPA X,LOWX
3023         MOVE X,HIGHX>
3024         HRRZ T,@X
3025         MOVEM W,@X      ;FULL WORD FIXUPS
3026         MOVE V,T
3027 ALSTR:  JUMPN V,ALSTR1
3028         POPJ P,
3029 DESTB:  EXP 1,1,1,1,1,1,1,1,0,0,100
3030
3031 OPTAB:  ADD W,C
3032         SUB W,C
3033         IMUL W,C
3034         IDIV W,C
3035         AND W,C
3036         IOR W,C
3037         LSH W,(C)
3038         XOR W,C
3039         SETCM W,C
3040         MOVN W,C
3041         REPEAT 7,<JRST STRSAT>
3042
3043
3044 FSYMT:  PUSHJ P,RDHLF   ;FIRST HALF OF SYMBOL
3045         HRL V,W
3046         PUSHJ P,RDHLF
3047         HRR V,W
3048         PUSH D,A        ;SAVE STORE TYPE
3049         PUSHJ P,RDHLF   ;GET BLOCK NAME
3050         HRL C,W
3051         PUSHJ P,RDHLF
3052         HRR C,W
3053         TLO C,140000    ;MAKE BLOCK NAME
3054         PUSHJ P,SDEF    ;FIND IT
3055         CAMN A,B
3056         JRST FNOLOC     ;MUST NOT BE LOADING LOCALS
3057 FSLP:   LDB C,[POINT 32,-1(A),35]       ;GET NAME
3058         CAMN C,V
3059         JRST FNDSYM
3060         SUB A,SE3
3061         CAME A,B        ;ALL DONE?
3062         JRST FSLP       ;NO
3063 FNOLOC: POP D,A
3064         MOVEI A,0       ;SET FOR A FAKE FIXUP
3065         AOS (P)
3066         POPJ P,
3067 FNDSYM: MOVEI W,(A)     ;LOC OF SYMBOL
3068         SUB W,HISTRT
3069         POP D,A
3070         AOS (P)
3071         POPJ P,
3072
3073 LFSYM:  ADD V,HISTRT
3074         HRLM W,(V)
3075         MOVSI D,400000  ;LEFT HALF
3076         JRST COMSFX
3077 RHSYM:  ADD V,HISTRT
3078         HRRM W,(V)
3079         MOVSI D,200000
3080         JRST COMSFX
3081 FAKESY: POPJ P,         ;IGNORE
3082
3083
3084 POLSAT: PUSH P,C        ;SAVE SYMBOL
3085         MOVE C,V        ;POINTER
3086         PUSHJ P,SREQ    ;GO FIND IT
3087         SKIPA
3088         JRST LOAD4A     ;SOMETHING IS ROTTEN IN DENMARK
3089         MOVEM W,2(A)    ;STORE VALUE
3090         HLRZS C         ;NOW FIND HEADER
3091         PUSHJ P,SREQ
3092         SKIPA
3093         JRST LOAD4A
3094         HRLZI V,-1      ;AND DECREMENT COUNT
3095         ADDB V,2(A)
3096         TLNN V,-1       ;IS IT NOW 0
3097         JRST PALSAT     ;YES, GO DO POLISH
3098         POP P,C         ;RESTORE SYMBOL
3099         JRST SYM2W1     ;AND RETURN
3100
3101 PALSAT: PUSH P,W        ;SAVE VALUE
3102         MOVEM C,HDSAV   ;SAVE THE HEADER NUMBER
3103         MOVE D,[IOWD PPDL,PPDB] ;SET UP A PDL
3104         MOVE C,V        ;GET THE POINTER
3105                 HRL C,HDSAV     ;AND THE FIXUP NUMBER
3106         PUSHJ P,REMSYM  ;REMOVE THE HEADER FORM EXISTANCE
3107         PUSHJ P,SREQ    ;GO FINE THE NEXT LINK
3108         SKIPA
3109         JRST LOAD4A     ;LOSE
3110         ANDI C,37       ;GET OPERATOR TYPE
3111         HRRZ V,2(A)     ;PLACE TO STORE
3112         PUSH D,V
3113         PUSH D,[XWD 400000,0]
3114         PUSH D,C        ;THIS HAD BETTER BE A STORE OR WE ARE IN TROUBLE
3115         HLRZ C,2(A)     ;GET POINTER TO POLISH CHAIN
3116 PSAT1:  PUSHJ P,REMSYM  ;REMOVE SYMBOL
3117
3118
3119
3120 PSAT2:  HRL C,HDSAV     ;GET FIXUP NUMBER
3121         PUSHJ P,SREQ    ;LOOK FOR IT
3122         SKIPA
3123         JRST LOAD4A
3124         ANDI C,37       ;THE OPERATOR NUMBER
3125         CAIN C,2        ;IS IT AN OPERAND?
3126         JRST PSOPD      ;YES, GO PROCESS
3127         PUSH D,C        ;YES STORE IT
3128         SKIPN DESTB-3(C)        ;IS IT UNARY
3129         JRST PSUNOP     ;YES
3130         HLRZ C,2(A)     ;GET FIRST OPERAND
3131         HRLI C,600000   ;AND MARK AS VALUE
3132         PUSH D,C
3133 PSUNOP: HRRZ C,2(A)     ;OTHER OPERAND
3134         JRST PSAT1      ;AND AWAY WE GO
3135
3136 PSOPD:  MOVE C,2(A)     ;THIS IS A VALUE
3137         PUSHJ P,REMSYM  ;GET RID OF THAT PART OF THE CHAIN
3138 PSOPD1: SKIPG V,(D)     ;IS THERE A VALUE IN THE STACK
3139         JRST PSOPD2     ;YES, TAKE GOOD CARE OF IT
3140 COMOP:  POP D,V         ;NO, GET THAT OPERATOR OUT OF THERE
3141         XCT OPTAB-3(V)  ;AND DO IT
3142         MOVE C,W        ;GET RESULT IN RIGHT PLACE
3143         JRST PSOPD1     ;AND TRY FOR MORE
3144 PSOPD2: TLNE V,200000   ;IS IT A POINTER
3145         JRST DBLOP      ;YES, NEEDS MORE WORK
3146         MOVE W,C        ;NO, ONE WE HAVE IS FIRST OPND, GET IT INTO W
3147         POP D,C         ;VALUE POINTER
3148         POP D,C         ;2ND OPERAND INTO C
3149         JRST COMOP      ;GO PROCESS OPERATOR
3150
3151 DBLOP:  EXCH C,(D)      ;PUT VALUE IN STACK AND RETRIEV POINTER
3152         PUSH D,[XWD 400000,0]   ;MARK AS VALUE
3153         JRST PSAT2      ;AND GO LOOK FOR MORE TROUBLE
3154
3155 LINK:   PUSHJ P,PRWORD  ;GET TWO WORDS
3156         JUMPLE C,ENDLNK ;THIS IS AN END OF LINK WORD
3157         CAILE C,20      ;IS IT IN RANGE?
3158         JRST LOAD4A
3159         HRRZ V,W        ;GET THE ADDRESS
3160         HRRZ W,LINKTB(C)        ;GET CURRENT LINK
3161 IFN L,< CAML V,RINITL   ;LOSE>
3162         HRRM W,@X       ;PUT INTO CORE
3163         HRRM V,LINKTB(C)        ;SAVE LINK FOR NEXT ONE
3164         JRST LINK       ;GO BACK FOR MORE
3165 ENDLNK: MOVNS C         ;GET ENTRY NUMBER
3166         JUMPE C,LOAD4A  ;0 IS A LOSER
3167         CAILE C,20      ;CHECK RANGE
3168         JRST LOAD4A
3169                 HRLM W,LINKTB(C)        ;SAVE END OF LINK INFO
3170         JRST LINK       ;MORE
3171
3172
3173 STRSAT: MOVE W,C        ;GET VALUE TO STORE IN W
3174         MOVE C,V        ;GET OPERATOR HERE
3175         POP D,V
3176         POP D,V         ;GET ADDRESS TO STORE
3177         PUSHJ P,@STRTAB-15(C)
3178 IFN REENT,<PUSHJ P,RESTRX>
3179         POP P,W ;RESTORE THINGS
3180         POP P,C
3181         JRST SYM2W1
3182
3183 ALSYM:  ADD V,HISTRT
3184         MOVEM W,(V)
3185         MOVSI D,600000
3186 >
3187         LIST            ;END OF FAILSW CODE
3188 IFN FAILSW!WFWSW,<
3189 COMSFX: IFE REENT,<PUSHJ P,SYMFX1
3190         JRST RESTRX>
3191 IFN REENT,<JRST SYMFX1>>
3192
3193 REMSYM: MOVE T,1(S)
3194         MOVEM T,1(A)
3195         MOVE T,2(S)
3196         MOVEM T,2(A)
3197         ADD S,SE3
3198         MOVEM A,SVA
3199         POPJ P,
3200
3201
3202
3203 SUBTTL LIBRARY INDEX (BLOCK TYPE 14)
3204
3205         COMMENT *       DIRECT ACCESS LIBRARY SEARCH MODE
3206         INDEX WRITTEN BY FUDGE2.SEE DIDAL DOC (100-540-001-00)
3207         DESIGN AND CODING BY D.M.NIXON  JUL-AUG 1970
3208         *
3209
3210 IFN DIDAL,<
3211
3212 INDEX8: POP     P,LSTBLK        ;SET UP LSTBLK FOR NEXT PROG
3213         PUSHJ   P,WORD          ;READ FIRST WORD
3214         HLRZ    A,W             ;BLOCK TYPE ONLY
3215         CAIE    A,14            ;IS IT AN INDEX?
3216         JRST    INDEXE          ;NO, ERROR
3217         JRST    INDEX9          ;DON'T SET FLAG AGAIN
3218
3219 INDEX0: TRO     F,XFLG          ;SIGNAL INDEX IN CORE
3220         MOVEI   A,1             ;START ON BLOCK 1 (DSK)
3221         HRROM   A,LSTBLK        ;BUT INDICATE AN INDEX
3222         MOVE    A,ILD1          ;INPUT DEVICE
3223         DEVCHR  A,
3224         TLNE    A,100           ;IS IT A DTA?
3225         TRO     F,DTAFLG        ;YES
3226 INDEX9: MOVEI   A,AUX+2         ;AUX BUFFER
3227         HRLI    A,4400          ;MAKE BYTE POINTER
3228         MOVEM   A,ABUF1         ;AND SAVE IT
3229         HRL     A,BUFR1         ;INPUT BUFFER
3230         BLT     A,AUX+201       ;STORE BLOCK
3231         TRO     F,LSTLOD        ;AND FAKE LAST PROG READ
3232 INDEX1: ILDB    T,ABUF1
3233         HLRE    A,T             ;GET WORD COUNT
3234         JUMPL   A,INDEX3        ;END OF BLOCK IF NEGATIVE
3235         CAIE    A,4             ;IS IT ENTRY
3236         JRST    INDEX
3237         HRRZS   T               ;WORD COUNT ONLY
3238 INDEX2: ILDB    C,ABUF1         ;GET NEXT SYMBOL
3239         TLO     C,040000        ;
3240         PUSHJ   P,SREQ          ;SEARCH FOR IT
3241         SOJA    T,INDEX4        ;REQUEST MATCHES
3242         SOJG    T,INDEX2        ;KEEP TRYING
3243         ILDB    T,ABUF1         ;GET POINTER WORD
3244         TRZN    F,LSTLOD        ;WAS LAST PROG LOADED?
3245         JRST    INDEX1          ;NO
3246         TRNN    F,DTAFLG        ;ALWAYS SAVE IF DTA???
3247         SKIPL   LSTBLK          ;SKIP IF LAST BLOCK WAS AN INDEX
3248         MOVEM   T,LSTBLK        ;SAVE POINTER FOR CALCULATIONS
3249         JRST    INDEX1          ;GET NEXT PROG
3250
3251
3252 INDEX4: ADDM    T,ABUF1
3253         ILDB    A,ABUF1
3254         PUSH    P,A             ;SAVE THIS BLOCK
3255         TROE    F,LSTLOD        ;DID WE LOAD LAST  PROG?
3256         JRST    [SKIPGE LSTBLK  ;WAS LAST BLOCK AN INDEX?
3257                 JRST    NXTBLK  ;YES, SO GET NEXT ONE
3258                 MOVEM   A,LSTBLK
3259                 JRST    LOAD1]  ;NEXT PROG IS ADJACENT
3260         HRRZ    T,LSTBLK        ;GET LAST BLOCK NUMBER
3261         CAIN    T,(A)           ;IN THIS BLOCK?
3262         JRST    THSBLK          ;YES
3263 NXTNDX: TRNE    F,DTAFLG        ;DIFFERENT TEST FOR DTA
3264         JRST    NXTDTA          ;CHECK IF NEXT BUFFER IN CORE
3265         CAIN    T,-1(A)         ;NEXT BLOCK?
3266         JRST    NXTBLK          ;YES,JUST DO INPUT
3267 INDEX5: USETI   1,(A)           ;SET ON BLOCK
3268         WAIT    1,              ;LET I/O FINISH
3269         MOVSI   C,(1B0)         ;CLEAR RING USE BIT IF ON
3270  ; ****** THE DEC BASTARDS DON'T READ THEIR OWN MANUALS *****
3271         HLLM    C,BUFR          ;INDICATE VIRGIN BUFFER
3272 ; ****** END OF THE CURRENT DEC IDIOCY **********:
3273         HRRZ    T,BUFR
3274         SKIPL   (T)
3275         JRST    NXTBLK          ;ALL DONE NOW
3276         ANDCAM  C,(T)           ;CLEAR USE BIT
3277         HRRZ    T,(T)           ;GET NEXT BUFFER
3278         JRST    .-4             ;LOOP
3279
3280 NXTDTA: WAIT    1,              ;LET I/O RUN TO COMPLETION
3281         HRRZ    T,BUFR          ;GET POINTER TO CURRENT BUFFER
3282         HLRZ    T,1(T)          ;FIRST DATA WORD IS LINK
3283         CAIE    T,(A)           ;IS IT BLOCK WE WANT?
3284         JRST    INDEX5          ;NO
3285 NXTBLK: IN      1,
3286         JRST    NEWBLK          ;IT IS NOW
3287         JRST    WORD3           ;EOF OR ERROR
3288
3289 NEWBLK: MOVE    A,(P)           ;GET CURRENT BLOCK
3290         JUMPL   A,INDEX8        ;JUST READ AN INDEX
3291         HLRZS   A               ;GET WORD COUNT
3292         JUMPE   A,[TRNN F,DTAFLG        ;WORD COUNT OK IF ON DTA
3293                 SOS     BUFR2
3294                 JRST    INDEX7]
3295         SKIPL   LSTBLK          ;WAS LAST BLOCK AN INDEX?
3296         AOJA    A,INDEX6        ;NO, ALWAYS ONE WORD OUT THEN
3297         HRRZ    T,AUX+3         ;GET FIRST ENTRY BLOCK TYPE COUNT
3298         HRRZ    T,AUX+4(T)      ;GET FIRST POINTER WORD
3299         MOVEM   T,LSTBLK        ;SOME WHERE TO STORE IT
3300         HRRZ    T,(P)           ;GET CURRENT BLOCK NUMBER
3301         CAME    T,LSTBLK        ;SAME BLOCK?
3302         AOJA    A,INDEX6        ;NO
3303         TRNN    F,DTAFLG        ;BUFR2 OK IF DTA???
3304         SOS     BUFR2           ;ONE WORD TO MANY THOUGH
3305         JRST    INDEX6          ;YES, WORD COUNT WILL BE CORRECT
3306
3307
3308
3309 THSBLK: SUB     A,LSTBLK        ;GET WORD DIFFERENCE
3310         MOVSS   A               ;INTO RIGHT HALF
3311 INDEX6: ADDM    A,BUFR1
3312         MOVNS   A
3313         ADDM    A,BUFR2
3314 INDEX7: POP     P,LSTBLK        ;STORE THIS AS LAST BLOCK READ
3315         JRST    LOAD1
3316
3317 INDEX3: HRRE    A,T             ;GET BLOCK # OF NEXT INDEX
3318         JUMPL   A,EOF           ;FINISHED IF -1
3319         PUSH    P,T             ;STACK THIS BLOCK
3320         HRRZ    T,LSTBLK        ;GET LAST BLOCK
3321         JRST    NXTNDX          ;CHECK IF NEXT BUFFER IN CORE
3322
3323 INDEX:  IN      1,              ;GET NEXT BUFFER
3324         SOSA    BUFR2           ;O.K. RETURN, BUT 1 WORD TOO MANY
3325         JRST    WORD3           ;ERROR OR EOF
3326         PUSHJ   P,WORD          ;READ FIRST WORD
3327 INDEXE: TRZE    F,XFLG          ;INDEX IN CORE?
3328         TTCALL  3,[ASCIZ /LIBRARY INDEX INCONSISTENT - CONTINUING
3329 /]                              ;WARNING MESSAGE
3330         JRST    LOAD1A+1        ;AND CONTINUE
3331 >
3332
3333
3334
3335 SUBTTL  ALGOL OWN BLOCK (TYPE 15)
3336
3337 IFN ALGSW,<
3338 ALGBLK:
3339 IFN SAILSW,<TRNN F,ALGFL        ;IF NOT ALGOL
3340         JRST    LDPRG           ;MUST BE SAIL BLOCK TYPE 15>
3341         PUSHJ P,RWORD           ;READ 3RD WORD
3342         HLRZ    V,W             ;GET START OF OWN BLOCK
3343         MOVEI   C,(W)           ;GET LENGTH OF OWN BLOCK
3344         MOVEM   C,OWNLNG        ;SAVE IT TO FIX RELOC AT END
3345         PUSHJ   P,ALGB2         ;FIX AND CHECK PROG BREAK
3346         ADDI    V,(R)           ;RELOCATE
3347         MOVEI   W,(V)           ;GET CURRENT OWN ADDRESS
3348         EXCH    W,%OWN          ;SAVE FOR NEXT TIME
3349         MOVEM   W,@X            ;STORE LAST OWN ADDRESS IN LEFT HALF
3350 ALGB1:  PUSHJ   P,RWORD         ;GET DATA WORD
3351         HLRZ    V,W             ;GET ADDRESS TO FIX UP
3352         HRRZS   W               ;RIGHT HALF ONLY
3353         ADD     W,%OWN          ;ADD IN ADDRESS OF OWN BLOCK
3354         ADDM    W,@X            ;FIX UP RIGHT HALF
3355         JRST    ALGB1           ;LOOP TIL DONE
3356
3357 ALGNAM: JUMPE   W,CPOPJ         ;NOT ALGOL MAIN PROG
3358         TROE    F,ALGFL         ;SET ALGOL SEEN FLAG
3359         JRST    ALGER1          ;ONLY ONE ALGOL MAIN PROG ALLOWED
3360 IFN REENT,<TRNN F,SEENHI        ;ANYTHING IN HIGH SEGMENT?>
3361         CAME    R,[XWD W,JOBDA] ;ANYTHING LOADED IN LOW SEGMENT?
3362         JRST    ALGER2          ;YES, ERROR ALSO
3363         SETZM   %OWN            ;INITIALISE OWN AREA POINTER
3364 IFN REENT,<TRO  F,VFLG          ;DEFAULT RE-ENTRANT OP-SYSTEM>
3365 ALGB2:  ADDI    H,(W)           ;FIX PROG BREAK
3366 IFN REENT,<CAML H,HILOW
3367         MOVEM   H,HILOW         ;HIGHEST LOW CODE LOADED>
3368         CAILE   H,1(S)          ;SKIP IF SUFFICIENT CORE AVAILABLE
3369 IFN EXPAND,<JRST [PUSHJ P,XPAND>
3370                 JRST    FULLC
3371 IFN EXPAND,<    JRST    .+1]>
3372         POPJ    P,
3373
3374 ALGER1: ERROR   ,</ONLY ONE ALGOL MAIN PROGRAM ALLOWED#/>
3375         JRST    LD2
3376
3377 ALGER2: ERROR   ,</ALGOL MAIN PROGRAM MUST BE LOADED FIRST#/>
3378         JRST    LD2
3379
3380 >
3381
3382
3383 SUBTTL  SAIL BLOCK TYPE 15
3384
3385 COMMENT * BLOCK TYPE 15 AND 16. SIXBIT FOR  FIL,PPN,DEV
3386 IN THE BLOCK. SEARCH TABLE FOR ALREADY REQUESTED. IF NOT
3387 ENTER REQUEST. ORIGINAL CODE BY DCS REWRITTEN BY WFW*
3388
3389 IFN SAILSW,<
3390 IFE ALGSW<ALGBLK:>
3391 LDPRG:  MOVEI D,PRGFLS-1        ;SET UP SOMETHING WE CAN SEARCH WITH
3392         MOVE W,PRGPNT   ;AND CURRENT POINTER
3393         PUSHJ P,LDSAV   ;GO ENTER (WILL NOT RETURN IF RUNS OUT)
3394         MOVEM D,PRGPNT
3395         JRST LDPRG      ;BACK FOR MORE
3396 LDLIB:  MOVEI D,LIBFLS-1
3397         MOVE W,LIBPNT
3398         PUSHJ P,LDSAV
3399         MOVEM D,LIBPNT
3400         JRST LDLIB      ;LOOKS JUST LIKE THE LAST ONE, DOESN'T IT
3401
3402 LDSAV:  HRLI D,-RELLEN-1        ;GET AOBJN SET UP
3403         MOVEM W,LODPN2# ;SAV IT
3404         PUSHJ P,PRWORD  ;GET FILE,PPN
3405         MOVE A,W        ;SAVE ONE
3406         PUSHJ P,RWORD   ;AND DEVICE
3407 FILSR:  CAMN D,LODPN2
3408         JRST FENT       ;HAVE GOTTEN THERE, ENTER FILE
3409         CAME C,PRGFIL(D)        ;CHECK FOR MATCH
3410         JRST NOMT       ;NOT FILE
3411         CAME A,PRGPPN(D)
3412         JRST NOMT       ;NO PPN
3413         CAME W,PRGDEV(D)
3414 NOMT:   AOBJN D,FILSR   ;AND NOT DEVICE SHOULD ALWAYS JUMP
3415         MOVE D,LODPN2
3416         POPJ P,         ;JUST RETURN CURRENT POINTER
3417 FENT:   MOVE D,LODPN2   ;ENTER IT
3418         AOBJP D,WRONG   ;THAT IS IF NOT TOO MANY
3419         MOVEM C,PRGFIL-1(D)     ;HAVE ALREADY INDEXED
3420         MOVEM A,PRGPPN-1(D)     ;HENCE THE -1
3421         MOVEM W,PRGDEV-1(D)
3422         POPJ P,
3423 WRONG:  ERROR ,</TOO MANY DEMANDED FILES#/>
3424         JRST LD2
3425 >
3426
3427
3428 SUBTTL  SYMBOL TABLE SEARCH SUBROUTINES
3429
3430 ;       ENTERED WITH SYMBOL IN C
3431 ;       RETURN IS WITH POINTER IN A IF MATCHING SYMBOL FOUND
3432 ;       OTHERWISE, A SKIP ON RETURN OCCURS
3433
3434 SREQ:   JUMPGE  S,CPOPJ1        ;JUMP IF NO UNDEF. SYMBOLS
3435         SKIPA   A,S             ;LOAD REQUEST SEARCH POINTER
3436 SDEF:   MOVE    A,B             ;LOAD DEF. SYMBOL SEARCH POINTER
3437 SDEF1:  CAMN    C,1(A)
3438         POPJ    P,              ;SYMBOLS MATCH, RETURN
3439 IFE K,< TLNE    N,F4SW          ;ARE WE IN FORTRAN?
3440         JRST    SDEF2           ;YES,JUST TRY NEXT SYMBOL>
3441         TLC     C,400000        ;MIGHT BE SUPPRESSED  INTERNAL
3442         CAMN    C,1(A)          ;WAS IT?
3443         JRST    [TLO C,400000   ;YES, SO ENSURE IT'S SUPPRESSED
3444                 MOVEM C,1(A)    ;STORE SUPPRESSED DEFINITION
3445                 POPJ    P,]     ;YES
3446         TLC     C,400000        ;NO,TRY NEXT SYMBOL
3447 SDEF2:  ADD     A,SE3
3448         JUMPL   A,SDEF1
3449 IFE K,< JRST    CPOPJ1          ;SYMBOL NOT FOUND SKIPS ON RETURN>
3450 IFN K,<
3451 CPOPJ1: AOS     (P)
3452         POPJ    P,>
3453
3454
3455 SUBTTL  RELOCATION AND BLOCK INPUT
3456
3457 PRWORD: PUSHJ   P,RWORD         ;READ A WORD PAIR
3458         MOVE    C,W             ;LOAD C WITH FIRST DATA WORD
3459         TRNE    E,377777                ;TEST FOR END OF BLOCK
3460         JRST    RWORD1          ;INPUT SECOND WORD OF PAIR
3461         MOVEI   W,0             ;NO SECOND WORD, ASSUME ZERO
3462         POPJ    P,
3463
3464 RWORD:  TRNN    E,377777        ;TEST FOR END OF BLOCK
3465         JRST    LOAD1           ;RETURN TO LOAD THE NEXT BLOCK
3466 RWORD1: AOBJN   E,RWORD2        ;JUMP IF DATA WORD NEXT
3467         PUSHJ   P,WORD          ;READ CONTROL WORD
3468         MOVE    Q,W             ;DON'T COUNT RELOCATION WORDS
3469         HRLI    E,-22           ;SET RELOCATION WORD BYTE COUNT
3470 RWORD2: PUSHJ   P,WORD          ;READ INPUT WORD
3471         JUMPGE  Q,RWORD3        ;TEST LH RELOCATION BIT
3472         TRNN    F,TWOFL         ;POSSIBLE TWO SEGMENTS?
3473         JRST    RWORD5          ;NO
3474         MOVSS   W
3475         PUSHJ   P,CHECK         ;USE CORRECT RELOCATION
3476         HRRI    W,@R
3477         MOVSS   W
3478         JRST    RWORD3          ;AND TEST RIGHT HALF
3479 RWORD5: HRLZ    T,R
3480         ADD     W,T             ;LH RELOCATION
3481 RWORD3: TLNN    Q,200000        ;TEST RH RELOCATION BIT
3482         JRST    RWORD4          ;NOT RELOCATABLE
3483         TRNE    F,TWOFL         ;POSSIBLE TWO SEGMENTS?
3484         PUSHJ   P,CHECK         ;USE CORRECT RELOCATION
3485         HRRI    W,@R            ;RH RELOCATION
3486 RWORD4: LSH     Q,2
3487         POPJ    P,
3488
3489 CHECK:  MOVE    T,HVAL1         ;START OF HISEGMENT
3490         CAIG    T,NEGOFF(W)     ;IN HISEG?
3491         JRST    [SUBI   W,(T)   ;YES REMOVE OFSET
3492                 POPJ    P,]
3493         HRRI    W,@LOWR         ;USE LOW SEG RELOC
3494         JRST    CPOPJ1          ;SKIP RETURN
3495
3496
3497 SUBTTL  PRINT STORAGE MAP SUBROUTINE
3498
3499 PRMAP:  CAIN    D,1             ;IF /1M PRINT LOCAL SYMBOLS
3500         TROA    F,LOCAFL        ;YES,TURN ON FLAG
3501         TRZ     F,LOCAFL        ;CLEAR JUST IN CASE
3502         PUSHJ   P,FSCN1         ;LOAD OTHER FILES FIRST
3503         PUSHJ   P,CRLFLF        ;START NEW PAGE
3504         HRRZ    W,R
3505 IFN REENT,<CAIG W,JOBDA ;LOADED INTO LOW SEGMENT
3506         JRST    NOLOW           ;DON'T PRINT IF NOTHING THERE>
3507         PUSHJ     P,PRNUM0
3508 IFE REENT,<ERROR 7,<?IS THE PROGRAM BREAK@?>>
3509 IFN REENT,<ERROR 7,<?IS THE LOW  SEGMENT BREAK@?>
3510         PUSHJ   P,CRLF          ;CR-LF ON ALL BUT TTY
3511 NOLOW:  MOVE    W,HVAL          ;HISEG BREAK
3512         CAMG    W,HVAL1         ;HAS IT CHANGED
3513         JRST    NOHIGH          ;NO HI-SEGMENT
3514         TLO     F,FCONSW        ;FORCE OUT HI-SEG BREAK ALSO
3515         PUSHJ   P,PRNUM0
3516         ERROR   7,<?IS THE HIGH SEGMENT BREAK@?>
3517         PUSHJ   P,CRLF
3518 NOHIGH:>
3519 IFE NAMESW,<    MOVE    W,DTOUT ;OUTPUT NAME >
3520 IFN NAMESW,<    SKIPN   W,DTOUT
3521         MOVE    W,CURNAM        ;USE PROGRAM NAME>
3522         JUMPE   W,.+3           ;DON'T PRINT IF NOT THERE
3523         PUSHJ   P,PWORD
3524         PUSHJ   P,SPACES        ;SOME SPACES
3525         ERROR   0,<?STORAGE MAP!?>
3526         PUSHJ   P,SPACES                ;SOME SPACES
3527         PUSH    P,N
3528         PUSH    P,E
3529         MOVE    N,[POINT 6,DBUF] ;INITIALIZE DATE POINTER
3530         MSTIME  Q,              ;GET THE TIME
3531         IDIVI   Q,↑D60*↑D1000
3532         IDIVI   Q,↑D60
3533         PUSH    P,A             ;SAVE MINUTES
3534         PUSHJ   P,OTOD1         ;STORE HOURS
3535         POP     P,Q             ;GET MINUTES
3536         PUSHJ   P,OTOD          ;STORE MINUTES
3537         DATE    E,              ;GET DATE
3538         IDIVI   E,↑D31                ;GET DAY
3539         ADDI    Q,1
3540         PUSHJ   P,OTOD          ;STORE DAY
3541         IDIVI   E,↑D12                ;GET MONTH
3542         ROT     Q,-1            ;DIV BY 2
3543         HRR     A,DTAB(Q)       ;GET MNEMONIC
3544         TLNN    Q,400000
3545         HLR     A,DTAB(Q)       ;OTHER SIDE
3546         HRRM    A,DBUF+1        ;STORE IT
3547         MOVEI   Q,↑D64(E)     ;GET YEAR
3548         MOVE    N,[POINT 6,DBUF+2]
3549         PUSHJ   P,OTOD          ;STORE IT
3550         POP     P,E
3551         POP     P,N
3552         PUSHJ   P,DBUF1
3553         PUSHJ   P,CRLF
3554         SKIPN   STADDR          ;PRINT STARTING ADDRESS
3555         JRST    NOADDR          ;NO ADDRESS SEEN
3556         ERROR   0,</STARTING ADDRESS !/>
3557         PUSHJ   P,SP1
3558         MOVE    W,STADDR                ;GET ST. ADDR.
3559         PUSHJ   P,PRNUM0                ;PRINT IT
3560 IFN NAMESW,<
3561         PUSHJ   P,SP1
3562         MOVE    W,[SIXBIT / PROG /]
3563         PUSHJ   P,PWORD
3564         MOVE    W,CURNAM                ;PROG NAME
3565         PUSHJ   P,PWORD
3566         PUSHJ   P,SP1
3567         MOVE    W,ERRPT6                ;SIXBIT / FILE /
3568         PUSHJ   P,PWORD
3569         MOVE    W,PRGNAM                ;FILE NAME
3570         PUSHJ   P,PWORD>
3571 NOADDR: IFN REENT,<
3572         HRRZ    A,HVAL1         ;GET INITIAL HIGH START
3573         ADDI    A,JOBHDA        ;ADD IN OFFSET
3574         HRLI    A,JOBDA         ;LOW START
3575         MOVSM   A,SVBRKS        ;INITIAL BREAKS>
3576         HLRE    A,B
3577         MOVNS     A
3578         ADDI    A,(B)
3579 PRMAP1: SUBI    A,2
3580 IFN REENT,<SKIPN C,1(A)         ;LOAD SYMBOL SKIP IF REAL SYMBOL
3581         JRST    PRMAP4          ;IGNORE ZERO NAME(TWOSEG BREAKS)>
3582 IFE REENT,<MOVE C,1(A)          ;LOAD SYMBOL>
3583         TLNN    C,300000        ;TEST FOR LOCAL SYMBOL
3584         JRST    .+4             ;GLOBAL  (NOT LOCAL ANYWAY)
3585         TRNN    F,LOCAFL        ;PRINT LOCAL SYMBOLS?
3586         JRST    PRMAP4          ;IGNORE LOCAL SYMBOLS
3587         TLC     C,140000        ;MAKE IT LOOK LIKE INTERN
3588         TLNE    C,040000
3589         JRST    PRMP1A
3590         PUSHJ   P,CRLF
3591         PUSHJ   P,CRLF
3592         SETZM   TABCNT
3593         JRST    PRMP1B
3594
3595
3596 PRMP1A: PUSHJ   P,TAB
3597 PRMP1B: PUSHJ   P,PRNAM1        ;PRINT SYMBOL AND VALUE
3598         TLNE    C,040000
3599         JRST    PRMAP4          ;GLOBAL SYMBOL
3600         HLRE    C,W             ;POINTER TO NEXT PROG. NAME
3601         HRRZS W         ;SO WE ONLY HAVE THE HALF WE WANT
3602 PRMAP7: JUMPL C,PRMP7A
3603 IFN REENT,<SKIPN 1(B)           ;IS IT A ZERO SYMBOL
3604         JRST    [MOVE   C,B     ;SET UP C
3605                 JRST    PRMAP2] ;AND GO
3606         HRRZ    T,HVAL  ;GET TO OF HI PART
3607         CAML    W,HVAL1 ;IS PROGRAM START UP THERE??
3608         JRST    PRMAP6  ;YES
3609         HRRZ    T,HILOW ;GET HIGHEST LOCATION LOADED IN LOW
3610         SUBI    T,(X)   ;REMOVE OFFSET
3611         CAIE    T,(W)   ;EQUAL IF ZERO LENGTH PROG>
3612         HRRZ T,R        ;GET LOW, HERE ON LAST PROG
3613         JRST PRMAP6     ;GO
3614
3615 PRMP7A: ADDI C,2(A)     ;POINTER TO NEXT PROGRAM NAME
3616 PRMAP2: IFN REENT,<
3617         SKIPE   1(C)    ;THIS IS A TWO SEG  FILE
3618         JRST    PRMP2A  ;NO
3619         MOVE    T,2(C)  ;GET PROG BREAKS
3620         TLNN    T,-1            ;IF NO HIGH STUFF YET
3621         HLL     T,SVBRKS        ;FAKE IT
3622         SUB     T,SVBRKS        ;SUBTRACT LAST  BREAKS
3623         HRRZ    W,T     ;LOW BREAK
3624         PUSH    P,W     ;SAVE IT
3625         JUMPGE  T,.+2   ;IF NEGATIVE
3626         TDZA    W,W     ;MAKE ZERO (FIRST TIME THRU)
3627         HLRZ    W,T     ;GET HIGH BREAK
3628         PUSHJ   P,PRNUM ;PRINT IT
3629         PUSHJ   P,TAB   ;AND TAB
3630         POP     P,W     ;LOW BREAK
3631         PUSHJ   P,PRNUM
3632         MOVE    T,2(C)
3633         CAMN    C,B             ;EQUAL IF LAST PROG
3634         SETZ    C,              ;SIGNAL END
3635         TLNN    T,-1
3636         HLL     T,SVBRKS
3637         CAMN    T,SVBRKS        ;ZERO LENGTT IF EQUAL
3638         JRST    PRMP6A          ;SEE IF LIST ALL ON
3639         MOVEM   T,SVBRKS        ;SAVE FOR NEXT TIME
3640         JRST    PRMAP3  ;AND CONTINUE
3641 PRMP2A:>
3642         HRRZ T,(C)      ;GET ITS STARTING ADRESS
3643 IFN REENT,<CAMGE W,HVAL1        ;MAKE SURE BOTH IN SAME SEGMENT
3644         CAMGE T,HVAL1
3645         CAMGE T,W
3646         JRST    [HLRE T,(C)     ;NO TRY NEXT ONE DOWN
3647                 JUMPE T,@PRMAP7 ;END GO USE PROG BREAK
3648                 ADDI C,(T)
3649                 JRST PRMAP2]    ;CHECK THIS ONE>
3650 PRMAP6: SUBM    T,W             ;SUBTRACT ORIGIN TO GET LENGTH
3651         PUSHJ     P,PRNUM               ;PRINT PROGRAM LENGTH
3652         PUSHJ     P,CRLF
3653 PRMP6A: TLNN    N,ALLFLG                ;SKIP IF LIST ALL MODE IS ON
3654         TRNE    W,777777                ;SKIP IF ZERO LENGTH PROGRAM
3655         JRST    PRMAP3
3656         HLRE    C,2(A)          ;GET BACK CORRECT LOCATION IF 0 LENGTH
3657         JUMPE   C,PRMAP5        ;JUMP IF LAST PROGRAM
3658         ADDI    C,2(A)          ;IN CASE WE SKIPPED SOME PROGRAMS
3659         SKIPA   A,C             ;SKIP GLOBALS, ZERO LENGTH PROG.
3660 PRMAP3:   PUSHJ     P,CRLF
3661 PRMAP4:   CAILE     A,(B)               ;TEST FOR END OF SYMBOL TABLE
3662         JRST    PRMAP1
3663 PRMAP5: PUSHJ   P,CRLF  ;GIVE AN XTRA CR-LF
3664
3665
3666
3667 SUBTTL  LIST UNDEFINED AND MULTIPLY DEFINED GLOBALS
3668
3669         PUSHJ   P,PMS1          ;PRINT UNDEFINED SYMBOLS
3670
3671 ;LIST NUMBER OF MULTIPLY DEFINED GLOBALS
3672
3673 PMS3:   SKIPN   W,MDG           ;ANY MULTIPLY DEFINED GLOBALS
3674         JRST    PMS4            ;NO, EXCELSIOR
3675         PUSHJ   P,FCRLF         ;ROOM AT THE TOP
3676         PUSHJ   P,PRQ           ;PRINT ?
3677         PUSHJ   P,PRNUM0        ;NUMBER OF MULTIPLES
3678         ERROR   7,<?MULTIPLY DEFINED GLOBALS@?>
3679 PMS4:   TLNE    N,AUXSWE        ;AUXILIARY OUTPUT DEVICE?
3680         OUTPUT  2,              ;INSURE A COMPLETE BUFFER
3681         POPJ    P,              ;RETURN
3682
3683 ;LIST UNDEFINED GLOBALS
3684
3685 PMS1:   PUSHJ   P,FSCN1         ;LOAD FILES FIRST
3686         JUMPGE  S,CPOPJ         ;JUMP IF NO UNDEFINED GLOBALS
3687         PUSHJ   P,FCRLF         ;START THE MESSAGE
3688         HLRE    W,S             ;COMPUTE NO. OF UNDEF. GLOBALS
3689         MOVMS     W
3690         LSH     W,-1            ;<LENGTH OF LIST>/2
3691         PUSHJ     P,PRNUM0
3692         ERROR   7,</UNDEFINED GLOBALS@/>
3693         MOVE    A,S             ;LOAD UNDEF. POINTER
3694 PMS2:   SKIPL W,1(A)
3695         TLNN W,40000
3696         JRST PMS2A
3697         PUSHJ     P,FCRLF
3698         PUSHJ     P,PRNAM0              ;PRINT SYMBOL AND POINTER
3699 PMS2A:  ADD     A,SE3
3700         JUMPL   A,PMS2
3701 CPOPJ:  POPJ    P,
3702
3703 PMS:    PUSHJ   P,PMS1  ;PRINT UNDEFINED SYMBOLS
3704         JUMPGE  S,CPOPJ         ;NO UNDEFINED SYMBOLS
3705         PUSHJ   P,CRLF          ;NEW LINE,MAKE ? VISIBLE
3706         PUSHJ   P,PRQ           ;FIX FOR BATCH TO PRINT ALL SYMBOLS
3707         JRST    CRLF            ;SPACE AFTER LISTING
3708
3709
3710 SUBTTL  ENTER FILE ON AUXILIARY OUTPUT DEVICE
3711
3712 IAD2:   PUSH    P,A             ;SAVE A FOR RETURN
3713         MOVE    A,LD5C1         ;GET AUX. DEV.
3714         DEVCHR  A,              ;GET DEVCHR
3715         TLNN    A,4             ;DOES IT HAVE A DIRECTORY
3716         JRST    IAD2A           ;NO SO JUST RETURN
3717         MOVE    A,DTOUT         ;GET OUTPUT NAME
3718         CAME    A,[SIXBIT /JOBDAT/] ;DON'T USE JOBDAT
3719         JUMPN   A,IAD2A         ;USE ANYTHING NON-ZERO
3720         MOVSI   A,(SIXBIT /DSK/) ;DEFAULT DEVICE
3721         CAMN    A,LD5C1         ;IS IT AUX. DEV.
3722         JRST    .+5             ;YES LEAVE WELL ALONE
3723         CLOSE   2,              ;CLOSE OLD AUX. DEV.
3724         MOVEM   A,LD5C1         ;SET IT TO DSK
3725         OPEN    2,OPEN2         ;OPEN IT FOR DSK
3726         JRST    IMD4            ;FAILED
3727 IFN NAMESW,<    SKIPN   A,CURNAM        ;USE PROG NAME>
3728         MOVSI   A,(SIXBIT /MAP/)        ;AN UNLIKELY NAME
3729         MOVEM   A,DTOUT         ;SO ENTER WILL NOT FAIL
3730 IAD2A:  POP     P,A             ;RECOVER A
3731         SETZM   DTOUT+2         ;CLEAR PROTECTION (LEVEL D)
3732         ENTER   2,DTOUT         ;WRITE FILE NAME IN DIRECTORY
3733         JRST    IMD3            ;NO MORE DIRECTORY SPACE
3734         POPJ    P,
3735
3736 IMD3:   ERROR   ,</DIR. FULL@/>
3737         JRST    LD2
3738
3739 IMD4:   MOVE    P,[XWD -40,PDLST]       ;RESTORE STACK
3740         TLZ     N,AUXSWE!AUXSWI ;NO AUX.DEV.NOW
3741         ERROR   ,</NO MAP DEVICE@/>
3742         JRST    PRMAP5          ;CONTINUE TO LOAD
3743
3744
3745
3746 SUBTTL  PRINT SUBROUTINES
3747
3748 ;PRINT THE 6 DIGIT OCTAL ADDRESS IN W
3749
3750 ;       ACCUMULATORS USED: D,T,V
3751
3752 PRNAM0:   MOVE  C,1(A)          ;LOAD SYMBOL
3753 PRNAM1:   MOVE  W,2(A)          ;LOAD VALUE
3754 PRNAM:  PUSHJ     P,PRNAME
3755 PRNUM:
3756         TRNN    F,TTYFL
3757         PUSHJ   P,SP1
3758         PUSHJ   P,SP1
3759 PRNUM0:   MOVE  V,PRNUM2                ;LOAD BYTE POINTER TO RH. OF W
3760         MOVNI     D,6           ;LOAD CHAR. COUNT
3761 PRNUM1:   ILDB  T,V             ;LOAD DIGIT TO BE OUTPUT
3762         ADDI    T,60            ;CONVERT FROM BINARY TO ASCII
3763         PUSHJ     P,TYPE2
3764         AOJL    D,PRNUM1                ;JUMP IF MORE DIGITS REMAIN
3765         POPJ    P,
3766
3767 PRNUM2:   XWD   220300,W
3768
3769
3770
3771
3772 IFN NAMESW,<
3773 LDNAM:  MOVE T,[POINT 6,CURNAM] ;POINTER
3774         MOVNI D,6       ;SET COUNT
3775         TLZ W,740000    ;REMOVE CODE BITS
3776 SETNAM: IDIVI W,50      ;CONVERT FROM RAD 50
3777         HRLM C,(P)
3778         AOJGE D,.+2
3779         PUSHJ P,SETNAM
3780         HLRZ C,(P)
3781         JUMPE C,INAM
3782         ADDI C,17
3783         CAILE C,31
3784         ADDI C,7
3785         CAIG C,72       ;REMOVE SPECIAL  CHARS. (. $ %)
3786         IDPB C,T
3787 INAM:   POPJ P, >
3788
3789
3790 ;YE OLDE RECURSIVE NUMBER PRINTER
3791 ;PRINTS Q, WITH LEADING ZEROES SUPPRESSED; USES A AND T
3792
3793 RCNUM:  IDIVI Q,12              ;RADIX DECIMAL
3794         ADDI A,"0"
3795         HRLM A,(P)
3796         JUMPE Q,.+2
3797         PUSHJ P,RCNUM
3798         HLRZ T,(P)
3799         JRST TYPE2
3800
3801
3802 SPACES: PUSHJ   P,SP1
3803 SP1:    PUSHJ   P,SPACE
3804 SPACE:  MOVEI   T,40
3805         JRST    TYPE2
3806
3807
3808 ;       ACCUMULATORS USED: Q,T,D
3809
3810 PWORD:  MOVNI   Q,6             ;SET CHARACTER COUNT TO SIX
3811 PWORD1: MOVE    D,LSTPT         ;ENTER HERE WITH Q PRESET
3812 PWORD2: ILDB    T,D             ;LOAD NEXT CHAR. TO BE OUTPUT
3813         PUSHJ     P,TYPE                ;OUTPUT CHARACTER
3814         AOJL    Q,PWORD2
3815         POPJ    P,
3816
3817
3818 ;TYPEOUT SUBROUTINE - THE CHARACTER SUPPLIED IN T IS CONVERTED TO ASCII
3819 ;AND IS OUTPUT ON THE CONSOLE AND/OR THE SPECIFIED LOADER MAP OUTPUT
3820 ;DEVICE
3821
3822 CRLFLF: PUSHJ   P,CRLF
3823 FCRLF:  TLO     F,FCONSW        ;INSURE TTY OUTPUT
3824 CRLF:   MOVEI   T,15            ;CARRIAGE RETURN LINE FEED
3825         PUSHJ   P,TYPE2
3826         TRCA    T,7             ;CR.XOR.7=LF
3827 TYPE:   MOVEI   T,40(T)         ;CONVERT SIXBIT TO ASCII
3828 TYPE2:  TLNN    N,AUXSWI        ;IS THER AN AUXILIARY DEVICE?
3829         JRST    TYPE3           ;NO, DONT OUTPUT TO IT
3830         TLON    N,AUXSWE        ;IS AUX. DEV. ENTERED?
3831         PUSHJ   P,IAD2          ;NOPE, DO SO!
3832         SOSG    ABUF2           ;SPACE LEFT IN BUFFER?
3833         OUTPUT  2,              ;CREATE A NEW BUFFER
3834         IDPB    T,ABUF1         ;DEPOSIT CHARACTER
3835         TLNN    F,FCONSW        ;FORCE OUTPUT TO CONSOLE TOO?
3836         POPJ    P,              ;NOPE
3837 TYPE3:  IFN RPGSW,<
3838         TRNE    F,NOTTTY        ;IF TTY IS ANOTHER DEVICE
3839         POPJ    P,              ;DON'T OUTPUT TO IT>
3840         SKIPN   BUFO2           ;END OF BUFFER
3841         OUTPUT  3,              ;FORCE OUTPUT NOW
3842         IDPB    T,BUFO1         ;DEPOSIT CHARACTER
3843         CAIN    T,12            ;END OF LINE
3844         OUTPUT  3,              ;FORCE AN OUTPUT
3845         POPJ    P,
3846
3847
3848 SUBTTL  SYMBOL PRINT - RADIX 50
3849
3850 ;       ACCUMULATORS USED: D,T
3851
3852 PRNAME: MOVE    T,C             ;LOAD SYMBOL
3853         TLZ     T,740000        ;ZERO CODE BITS
3854         PUSH    P,T
3855         PUSH    P,C
3856         MOVEI   C,6
3857         MOVEI   D,1
3858         IDIVI   T,50
3859         JUMPN   V,.+2
3860         IMULI   D,50
3861         SOJN    C,.-3
3862         POP     P,C
3863         POP     P,T
3864         IMUL    T,D
3865         MOVNI   D,6             ;LOAD CHAR. COUNT
3866 SPT:    IDIVI   T,50            ;THE REMAINDER IS THE NEXT CHAR.
3867         HRLM    V,(P)           ;STORE IN LH. OF PUSHDOWN LIST
3868         AOJGE   D,.+2           ;SKIP IF NO CHARS. REMAIN
3869         PUSHJ   P,SPT           ;RECURSIVE CALL FOR NEXT CHAR.
3870         HLRZ    T,(P)           ;LOAD FROM LH. OF PUSHDOWN LIST
3871         JUMPE   T,TYPE          ;BLANK
3872         ADDI    T,60-1
3873         CAILE   T,71
3874         ADDI    T,101-72
3875         CAILE   T,132
3876         SUBI    T,134-44
3877         CAIN    T,43
3878         MOVEI   T,56
3879         JRST    TYPE2
3880
3881 TAB1:   SETZM   TABCNT
3882         PUSHJ   P,CRLF
3883 TAB:    AOS     T,TABCNT
3884         CAIN    T,5
3885         JRST    TAB1
3886         TRNE    F,TTYFL
3887         JRST    SP1
3888         MOVEI   T,11
3889         JRST    TYPE2
3890
3891
3892
3893
3894 OTOD:   IBP     N
3895 OTOD1:  IDIVI   Q,↑D10
3896         ADDI    Q,20            ;FORM SIXBIT
3897         IDPB    Q,N
3898         ADDI    A,20
3899         IDPB    A,N
3900         POPJ    P,
3901
3902 DTAB:   SIXBIT  /JANFEB/
3903         SIXBIT  /MARAPR/
3904         SIXBIT  /MAYJUN/
3905         SIXBIT  /JULAUG/
3906         SIXBIT  /SEPOCT/
3907         SIXBIT  /NOVDEC/
3908
3909
3910
3911 SUBTTL  ERROR MESSAGE PRINT SUBROUTINE
3912
3913 ;       FORM OF CALL:
3914
3915 ;       JSP     A,ERRPT
3916 ;       SIXBIT    /<MESSAGE>/
3917
3918 ;       ACCUMULATORS USED: T,V,C,W
3919
3920 ERRPT:  TLO     F,FCONSW        ;INSURE TTY OUTPUT
3921         PUSHJ   P,CRLF          ;ROOM AT THE TOP
3922         PUSHJ   P,PRQ           ;START OFF WITH ?
3923 ERRPT0: PUSH    P,Q             ;SAVE Q
3924         SKIPA   V,ERRPT5
3925 ERRPT1: PUSHJ   P,TYPE
3926         ILDB    T,V
3927         CAIN    T,"@"-40
3928         JRST    ERRPT4
3929         CAIN    T,"%"-40
3930         JRST    ERRPT9
3931         CAIN    T,"!"-40
3932         JRST    ERRP42          ;JUST RETURN,LEAVE FCONSW ON
3933         CAIE    T,"#"-40
3934         JRST    ERRPT1
3935         SKIPN   C,DTIN
3936         JRST    ERRPT4
3937         MOVNI   Q,14
3938         MOVEI   W,77
3939 ERRPT2: TDNE    C,W
3940         JRST    ERRPT3
3941         LSH     W,6
3942         AOJL    Q,ERRPT2
3943 ERRPT3: MOVE    W,ERRPT6
3944         PUSHJ   P,PWORD1
3945         SKIPN   W,DTIN1
3946         JRST    ERRPT4
3947         LSH     W,-6
3948         TLO     W,160000
3949         MOVNI   Q,4
3950         PUSHJ   P,PWORD1
3951 ERRPT4: PUSHJ   P,CRLF
3952 ERRP41: TLZ     F,FCONSW        ;ONE ERROR PER CONSOLE
3953 ERRP42: POP     P,Q             ;***DMN*** FIX FOR ILC MESSAGE
3954         AOJ     V,              ;PROGRAM BUMMERS BEWARE:
3955         JRST    @V              ;V HAS AN INDEX OF A
3956
3957 ERRPT5: POINT     6,0(A)
3958 ERRPT6: SIXBIT    / FILE /
3959
3960
3961 ERRPT8: TLO     F,FCONSW        ;INSURE TTY OUTPUT
3962         PUSHJ   P,PRQ           ;START WITH ?
3963         CAIGE   T,140           ;IS IT A NON-PRINTING CHAR?
3964         CAIL    T,40
3965         JRST    ERRP8
3966         PUSH    P,T
3967         MOVEI     T,136         ;UP ARROW
3968         PUSHJ     P,TYPE2
3969         POP     P,T
3970         TRC     T,100           ;CONVERT TO PRINTING CHAR.
3971 ERRP8:  PUSHJ     P,TYPE2
3972 ERRPT7:   PUSHJ     P,SPACE
3973         JRST    ERRPT0
3974
3975 ERRPT9: MOVEI   V,@V
3976         PUSH    P,V
3977         ERROR   7,<?ILLEGAL -LOADER@?>
3978         POP     P,V
3979         JRST    ERRP41
3980
3981 ;PRINT QUESTION MARK
3982
3983 PRQ:    PUSH    P,T             ;SAVE
3984         MOVEI   T,"?"           ;PRINT ?
3985         PUSHJ   P,TYPE2         ;...
3986         POP     P,T             ;RESTORE
3987         POPJ    P,              ;RETURN
3988
3989
3990 SUBTTL  INPUT - OUTPUT INTERFACE
3991
3992 ;BINARY INPUT SUBROUTINE - RETURNS A WORD IN W
3993 IFE K,<
3994 WORDPR: PUSHJ   P,WORD          ;GET FIRST WORD OF PAIR
3995         MOVE    C,W             ;KEEP IT HANDY>
3996 WORD:   SOSGE   BUFR2           ;SKIP IF BUFFER NOT EMPTY
3997         JRST    WORD2
3998 WORD1:  ILDB    W,BUFR1         ;PICK UP 36 BIT WORD
3999         POPJ    P,
4000
4001 WORD2:  IN      1,              ;GET NEXT BUFFER LOAD
4002         JRST    WORD            ;DATA OK - CONTINUE LOADING
4003 WORD3:  STATZ   1,IODEND        ;TEST FOR EOF
4004         JRST    EOF             ;END OF FILE EXIT
4005         ERROR   ,< /INPUT ERROR#/>
4006         JRST    LD2             ;GO TO ERROR RETURN
4007
4008
4009 SE3:    XWD     2,2             ;SYMBOL POINTER INCREMENT
4010 PDLPT:  XWD     -41,PDLST-1;    INITIAL PUSHDOWN POINTER
4011 COMM:   SQUOZE    0,.COMM.
4012 LSTPT:  POINT   6,W             ;CHARACTER POINTER TO W
4013
4014 IOBKTL==40000
4015 IOIMPM==400000
4016 IODERR==200000
4017 IODTER==100000
4018 IODEND==20000
4019
4020 IOBAD==IODERR!IODTER!IOBKTL!IOIMPM
4021
4022
4023
4024 SUBTTL  IMPURE CODE
4025 IFN SEG2SW,<    RELOC
4026 LOWCOD: RELOC>
4027 IFN PURESW,<HICODE:
4028 IFN SEG2SW,<    PHASE LOWCOD>
4029 IFE SEG2SW,<    PHASE   140>>
4030
4031
4032 DBUF1:  JSP     A,ERRPT7
4033 DBUF:   SIXBIT  /TI:ME DY-MON-YR @/
4034         POPJ    P,
4035
4036 ;DATA FOR PURE OPEN UUO'S
4037
4038 IFN SPCHN,<
4039 CHNENT: 0
4040         SIXBIT .CHN.
4041         0
4042         0
4043 CHNOUT: 17
4044         SIXBIT /DSK/
4045         0
4046 >
4047 IFN RPGSW,<
4048 OPEN1:  EXP     1
4049 RPG1:   Z
4050         XWD     0,CTLIN
4051 >
4052
4053 OPEN2:  EXP     1
4054 LD5C1:  Z
4055         XWD     ABUF,0
4056
4057 OPEN3:  EXP     14
4058 ILD1:   Z
4059         XWD     0,BUFR
4060
4061 IFN PURESW,<DEPHASE
4062 CODLN=.-HICODE>
4063
4064
4065 SUBTTL  DATA STORAGE
4066
4067 IFN PURESW,<
4068 IFE SEG2SW,<LOC 140>
4069 IFN SEG2SW,<RELOC>
4070 LOWCOD: BLOCK CODLN>
4071
4072 PDSAV:  BLOCK 1                 ;SAVED PUSHDOWN POINTER
4073 COMSAV: BLOCK 1                 ;LENGTH OF COMMON
4074 MDG:    BLOCK 1                 ;COUNTER FOR MUL DEF GLOBALS
4075 PDLST:  BLOCK   40
4076
4077 F.C:    BLOCK 1
4078         BLOCK 1 ;STORE N HERE
4079         BLOCK 1 ;STORE X HERE
4080         BLOCK 1 ;STORE H HERE
4081         BLOCK 1 ;STORE S HERE
4082         BLOCK 1 ;STORE R HERE
4083 B.C:    BLOCK 1
4084
4085 STADDR: BLOCK 1 ;HOLDS STARTING ADDRESS
4086
4087 IFN NAMESW,<
4088 PRGNAM: BLOCK 1 ;STORE BINARY FILE NAME-USED TO MAKE SYSTAT MORE MEANINGFUL
4089 >
4090 IFN REENT,<
4091 HIGHX:  BLOCK 1
4092 HIGHR:  BLOCK 1 ;HOLD X AND R WHILE LOADING LOW SEG PIECES
4093 LOWX:   BLOCK 1
4094 HILOW:  BLOCK 1 ;HIGHEST NON-BLOCK STMT IN LOW SEG
4095 HVAL:   BLOCK 1 ;ORG OF HIGH SEG>
4096 HVAL1:  BLOCK 1 ;ACTUAL ORG OF HIGH SEG
4097 LOWR:   BLOCK 1 ;HOLD X AND R WHILE LOADING HISEG PIECES
4098 IFN KUTSW,<CORSZ:       BLOCK 1>
4099 IFN DMNSW,<KORSP:       BLOCK 1>
4100 IFN LDAC,<BOTACS:       BLOCK 1>
4101 IFN WFWSW,<VARLNG:      BLOCK 1
4102 VARREL: BLOCK 1>
4103 IFN SAILSW,<LIBFLS:     BLOCK   RELLEN*3
4104 PRGFLS: BLOCK   RELLEN*3>
4105
4106
4107 PT1:    BLOCK 1
4108 SVA:    BLOCK 1
4109 IFN RPGSW,<
4110 NONLOD: BLOCK 1
4111 SVRPG:  BLOCK 1
4112 IFN TEMP,<
4113 TMPFIL: BLOCK 2
4114 TMPFLG: BLOCK 1>
4115 >
4116 IFN  NAMESW,<
4117 CURNAM: BLOCK 1
4118 >
4119 IFN PP,<
4120 OLDDEV: BLOCK 1
4121 PPN:    BLOCK 1
4122 PPNE:   BLOCK 1
4123 PPNV:   BLOCK 1
4124 PPNW:   BLOCK 1
4125         >
4126 IFN FAILSW,<
4127 GLBCNT: BLOCK 1
4128 HDSAV:  BLOCK 1
4129 HEADNM: BLOCK 1
4130 LFTHSW: BLOCK 1
4131 OPNUM:  BLOCK 1
4132 POLSW:  BLOCK 1
4133 SVHWD:  BLOCK 1
4134 SVSAT:  BLOCK 1
4135 PPDB:   BLOCK PPDL+1
4136 LINKTB: BLOCK 21
4137 >
4138 HISTRT: BLOCK 1 ;JOBREL AT START OF LOADING
4139 IFN L,<
4140 LSPXIT: BLOCK 1
4141 RINITL: BLOCK 1
4142 OLDJR:  BLOCK 1>
4143 IFN SPCHN,<
4144 CHNTAB: BLOCK 1
4145 BEGOV:  BLOCK 1
4146 CHNACN: BLOCK 1
4147 CHNACB: BLOCK 1>
4148 TABCNT: BLOCK 1
4149 LIMBO:  BLOCK   1       ;WHERE OLD CHARS. ARE STORED
4150 IFN DIDAL,<LSTBLK:      BLOCK   1       ;POINTER TO LAST PROG LOADED>
4151 IFN EXPAND,<ALWCOR:     BLOCK   1       ;CORE AVAILABLE TO USER>
4152 IFN ALGSW,<%OWN: BLOCK  1       ;ADDRESS OF ALGOL OWN AREA
4153         OWNLNG: BLOCK   1       ;LENGTH OF OWN BLOCK>
4154 IFN REENT,<SVBRKS:      BLOCK   1       ;XWD HIGH,LOW (PROG BREAKS)>
4155
4156
4157 SUBTTL  BUFFER HEADERS AND HEADER HEADERS
4158
4159 BUFO:   BLOCK 1                 ;CONSOLE INPUT HEADER HEADER
4160 BUFO1:  BLOCK 1
4161 BUFO2:  BLOCK 1
4162
4163 BUFI:   BLOCK 1                 ;CONSOLE OUTPUT HEADER HEADER
4164 BUFI1:  BLOCK 1
4165 BUFI2:  BLOCK 1
4166
4167 ABUF:   BLOCK 1                 ;AUXILIARY OUTPUT HEADER HEADER
4168 ABUF1:  BLOCK 1
4169 ABUF2:  BLOCK 1
4170
4171 BUFR:   BLOCK 1                 ;BINARY INPUT HEADER HEADER
4172 BUFR1:  BLOCK 1
4173 BUFR2:  BLOCK 1
4174
4175 DTIN:   BLOCK 1                 ;DECTAPE INPUT BLOCK
4176 DTIN1:  BLOCK 3
4177
4178 DTOUT:  BLOCK 1                 ;DECTAPE OUTPUT BLOCK
4179 DTOUT1: BLOCK 3
4180
4181         TTYL==52                        ;TWO TTY BUFFERS
4182 IFE LNSSW,<
4183 IFE K,< BUFL==406               ;TWO DTA BUFFERS FOR LOAD>
4184 IFN K,< BUFL==203               ;ONE DTA BUFFER FOR LOAD>
4185         ABUFL==203              ;ONE DTA BUFFER FOR AUX DEV>
4186 IFN LNSSW,<
4187 IFE K,<BUFL==4*203+1>
4188 IFN K,<BUFL==203+1>
4189 ABUFL==2*203+1>
4190
4191 TTY1:   BLOCK   TTYL            ;TTY BUFFER AREA
4192 BUF1:   BLOCK   BUFL            ;LOAD BUFFER AREA
4193 AUX:    BLOCK   ABUFL           ;AUX BUFFER AREA
4194
4195
4196 IFN RPGSW,<
4197 CTLIN:  BLOCK 3
4198 CTLNAM: BLOCK 3
4199 CTLBUF: BLOCK 203+1
4200 >
4201
4202
4203 SUBTTL  FORTRAN DATA STORAGE
4204
4205 IFN STANSW,<PATCH:      BLOCK   20              ;STANFORD HAS SEMI-INFINITE CORE>
4206
4207 IFE K,<
4208 TOPTAB: BLOCK 1 ;TOP OF TABLES
4209 CTAB:   BLOCK 1;        COMMON
4210 ATAB:   BLOCK 1;        ARRAYS
4211 STAB:   BLOCK 1;        SCALARS
4212 GSTAB:  BLOCK 1;        GLOBAL SUBPROGS
4213 AOTAB:  BLOCK 1;        OFFSET ARRAYS
4214 CCON:   BLOCK 1;        CONSTANTS
4215 PTEMP:  BLOCK 1;        PERMANENT TEMPS
4216 TTEMP:  BLOCK 1;        TEMPORARY TEMPS
4217 COMBAS: BLOCK 1;        BASE OF COMMON
4218 LLC:    BLOCK 1;        PROGRAM ORIGIN
4219 BITP:   BLOCK 1;        BIT POINTER
4220 BITC:   BLOCK 1;        BIT COUNT
4221 PLTP:   BLOCK 1;        PROGRAMMER LABEL TABLE
4222 MLTP:   BLOCK 1;        MADE LABEL TABLE
4223 SDS:    BLOCK 1 ;START OF DATA STATEMENTS
4224 SDSTP:  BLOCK 1 ;START OF DATA STATEMENTS POINTER
4225 BLKSIZ: BLOCK 1;        BLOCK SIZE
4226 MODIF:  BLOCK 1;        ADDRESS MODIFICATION +1
4227 SVFORH: BLOCK 1 ;SAVE H WHILE LOADING F4 PROGRAMS
4228
4229 IOWDPP: BLOCK 2>
4230 SBRNAM: BLOCK 1
4231
4232 IFE K,<
4233 CT1:    BLOCK 1         ;TEMP FOR C
4234 LTC:    BLOCK 1
4235 ITC:    BLOCK 1
4236 ENC:    BLOCK 1
4237 WCNT:   BLOCK 1         ;DATA WORD COUNT
4238 RCNT:   BLOCK 1         ;DATA REPEAT COUNT
4239
4240 LTCTEM: BLOCK 1         ;TEMP FOR LTC
4241 DWCT:   BLOCK 1         ;DATA WORD COUNT>
4242
4243         VAR     ;DUMP VARIABLES
4244 IFN PURESW,<RELOC>
4245
4246
4247
4248 SUBTTL  REMAP UUO
4249 IFN REENT,<
4250 IFN PURESW,<HHIGO:      PHASE   BUF1    ;DON'T NEED BUF1 NOW>
4251
4252 HIGO:   CORE    V,              ;CORE UUO
4253         JFCL                    ;NEVER FAILS
4254 HINOGO: MOVE    D,HVAL
4255         CAMG    D,HVAL1         ;ANYTHING IN HI-SEG
4256         JRST    0               ;NO
4257         MOVE    V,HISTRT        ;NOW REMAP THE HISEG.
4258         REMAP   V,              ;REMAP UUO.
4259         JRST    HIGET           ;FATAL ERROR.
4260 HIRET:  JRST    0               ;EXECUTE CODE IN ACC'S
4261
4262 HIGET:  HRRZI   V,SEGBLK        ;DATA FOR
4263         GETSEG  V,              ;GETSEG UUO
4264         SKIPA                   ;CANNOT CONTINUE NO HISEG
4265         JRST    REMPFL          ;REGAINED LOADER HISEG
4266                                 ;GO PRINT MESSAGE
4267         TTCALL  3,SEGMES        ;PRINT SEGMES
4268         EXIT                    ;AND DIE
4269
4270 SEGBLK: SIXBIT  /SYS/
4271         SIXBIT  /LOADER/
4272         EXP     0,0,0,0
4273
4274
4275 SEGMES: ASCIZ   /?CANNOT FIND LOADER.SHR
4276 /
4277
4278 IFN PURESW,<HIGONE:     DEPHASE>>
4279
4280
4281 SUBTTL  LISP LOADER
4282
4283 ;END HERE IF 1K LOADER REQUESTED.
4284 IFN K,<IFE L,<END BEG>
4285 IFE L,< XLIST   >
4286
4287 IFN L,<LODMAK:  MOVEI A,LODMAK
4288         MOVEM A,137     ;SET UP TO SAVE THE LISP LOADER
4289         INIT 17
4290         SIXBIT /DSK/
4291         0
4292         HALT
4293         ENTER LMFILE
4294         HALT
4295         MOVNI A,LD
4296         HRLZS A
4297         ADDM A,LMLST    ;BECAUSE MACRO WON'T TAKE POLISH FIXUPS
4298         OUTPUT LMLST
4299         STATZ 740000
4300         HALT
4301         RELEASE
4302         EXIT
4303 LMFILE: SIXBIT /LISP/
4304         SIXBIT /LOD/
4305         0
4306         0
4307 LMLST:  IOWD LODMAK+1,137
4308         0
4309         END LODMAK>>
4310
4311         LIST
4312
4313
4314 SUBTTL   FORTRAN FOUR LOADER
4315
4316 F4LD:   TLNE    F,SKIPSW!FULLSW ;ARE WE IN SKIP MODE
4317         JRST    REJECT          ;YES,DON'T LOAD ANY OF THIS
4318         MOVEI   W,-2(S);        GENERATE TABLES
4319         CAIG    W,(H)           ;NEED TO EXPAND?
4320 IFN EXPAND,<PUSHJ P,[PUSHJ P,XPAND
4321                 TLOA    F,FULLSW
4322                 JRST    POPJM3
4323                 POPJ    P,]>
4324 IFE EXPAND,<    TLO     F,FULLSW>
4325 ;IFN REENT,<TRO F,F4FL!VFLG     ;RE-ENTRANT LIB40>
4326         TLO     N,F4SW;         SET FORTRAN FOUR FLAG
4327         HRRZ    V,R;            SET PROG BREAK INTO V
4328         MOVEM   V,LLC;          SAVE FIRST WORD ADDRESS
4329         HRRZM   W,MLTP;         MADE LABELS
4330         HRRZM   W,PLTP;         PROGRAMMER LABELS
4331         ADD     W,[POINT 1,1];  GENERATE BIT-BYTE POINTER
4332         MOVEM   W,BITP
4333         MOVEM   W,SDSTP;        FIRST DATA STATEMENT
4334         AOS     SDSTP;
4335         HRREI   W,-↑D36;      BITS PER WORDUM
4336         MOVEM   W,BITC;         BIT COUNT
4337         PUSHJ   P,BITWX         ;MAKE SURE OF ENOUGH SPACE
4338         MOVE    W,[JRST ALLOVE] ;LAST DATA STATEMENT
4339         MOVEM   W,(S)
4340
4341 TEXTR:  PUSHJ   P,WORD;         TEXT BY DEFAULT
4342         HLRZ    C,W
4343         CAIN    C,-1
4344         JRST    HEADER;         HEADER
4345         MOVEI   C,1;            RELOCATABLE
4346         TLNN    F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
4347         PUSHJ   P,BITW;         SHOVE AND STORE
4348         JRST    TEXTR;          LOOP FOR NEXT WORD
4349
4350 ABS:    SOSG    BLKSIZ; MORE TO GET
4351         JRST    TEXTR;          NOPE
4352 ABSI:   PUSHJ   P,WORD;
4353         MOVEI   C,0;            NON-RELOCATABLE
4354         TLNN    F,FULLSW!SKIPSW ;DON'T LOAD IF EITHER SET
4355         PUSHJ   P,BITW;         TYPE 0
4356         JRST    ABS
4357
4358
4359 SUBTTL  PROCESS TABLE ENTRIES
4360
4361 MDLB:   TLNE    F,FULLSW+SKIPSW;        MADE LABEL PROC
4362         JRST    GLOBDF;         NO ROOM AT THE IN
4363         HLRZ    C,MLTP;         GET PRESENT SIZE
4364         CAMGE   C,BLKSIZ;       IF NEW SIZE BIGGER, STR-R-RETCH
4365         PUSHJ   P,SMLT
4366         HRRZ    C,MLTP;         GET BASE
4367 MLPLC:  ADD     C,BLKSIZ;       MAKE INDEX
4368         TLNN    F,FULLSW+SKIPSW;        DONT LOAD
4369         HRRZM   V,(C);          PUT AWAY DEFINITION
4370 GLOBDF: PUSHJ   P,WORD
4371         TLNE    F,FULLSW+SKIPSW ;SKIPPING THIS PROG?
4372         JRST    TEXTR           ;YES, DON'T DEFINE
4373         MOVEI   C,(V);          AND LOC
4374         EXCH    W,C
4375         PUSHJ   P,SYMXX;        PUT IN DDT-SYMBOL TABLE
4376         PUSHJ   P,BITWX
4377         JRST    TEXTR
4378
4379 PLB:    TLNE    F,FULLSW+SKIPSW
4380         JRST    GLOBDF
4381         HLRZ    C,PLTP;         PRESENT SIZE
4382         CAMGE   C,BLKSIZ
4383         PUSHJ   P,SPLT
4384         HRRZ    C,PLTP
4385         JRST    MLPLC
4386
4387
4388 SUBTTL  STORE WORD AND SET BIT TABLE
4389
4390 BITW:   MOVEM   W,@X;           STORE AWAY OFFSET
4391         IDPB    C,BITP;         STORE BIT
4392         AOSGE   BITC;           STEP BIT COUNT
4393         AOJA    V,BITWX;        SOME MORE ROOM LEFT
4394         HRREI   C,-↑D36;      RESET COUNT
4395         MOVEM   C,BITC
4396         SOS     PLTP
4397         SOS     BITP;           ALL UPDATED
4398 IFE EXPAND,<HRL C,MLTP
4399         SOS     MLTP
4400         HRR     C,MLTP>
4401 IFN EXPAND,<HRRZ        C,MLTP;         TO ADDRESS
4402         SUBI    C,1
4403         CAIG C,(H)
4404         PUSHJ P,[PUSHJ P,XPAND
4405                 POPJ P,
4406                 ADDI C,2000
4407                 JRST POPJM2]
4408         SOS     MLTP
4409         HRLI C,1(C)>
4410         HRRZ    T,SDSTP;        GET DATA POINTER
4411         BLT     C,-1(T);        MOVE DOWN LISTS
4412         AOJ     V,;             STEP LOADER LOCATION
4413 BITWX:  IFN REENT,<
4414         TLNE    F,HIPROG
4415         JRST    FORTHI>
4416         CAIGE H,@X
4417         MOVEI H,@X      ;KEEP H SET RIGHT FOR HISEG STUFF
4418 BITWX2: HRRZ    T,MLTP
4419         CAIG    T,(H);          OVERFLOW CHECK
4420 IFE EXPAND,<TLO F,FULLSW>
4421 IFN EXPAND,<PUSHJ P,    [PUSHJ P,XPAND
4422                         TLOA F,FULLSW
4423                         JRST POPJM3
4424                         POPJ P,]>
4425         POPJ    P,;
4426
4427 SMLT:   SUB     C,BLKSIZ;       STRETCH
4428         MOVS    W,MLTP          ;LEFT HALF HAS OLD BASE
4429         ADD     C,MLTP          ;RIGHT HALF HAS NEW BASE
4430 IFN EXPAND,<    HRRZS C ;GET RID OF COUNT
4431                 CAIG C,(H)
4432                 PUSHJ P,[PUSHJ P,XPAND
4433                         POPJ P,
4434                         ADD W,[XWD 2000,0]
4435                         ADDI C,2000
4436                         JRST POPJM2]>
4437         HRRM C,MLTP             ;PUT IN NEW MLTP
4438         HLL     C,W             ;FORM BLT POINTER
4439         ADDI    W,(C)           ;LAST ENTRY OF MLTP
4440         HRL     W,BLKSIZ        ;NEW SIZE OF MLTP
4441         HLLM    W,MLTP          ;...
4442 SLTC:   BLT     C,0(W);         MOVE DOWN (UP?)
4443         POPJ    P,;
4444
4445 SPLT:   SUB     C,BLKSIZ
4446         MOVS    W,MLTP;
4447         ADDM    C,PLTP
4448         ADD     C,MLTP
4449 IFN EXPAND,<    HRRZS C
4450                 CAIG C,(H)
4451                 PUSHJ P,[PUSHJ P,XPAND
4452                         POPJ P,
4453                         ADD W,[XWD 2000,0]
4454                         ADDI C,2000
4455                         JRST POPJM2]>
4456         HRRM C,MLTP             ;PUT IN NEW MLTP
4457         HLL     C,W
4458         HLRZ    W,PLTP          ;OLD SIZE OF PL TABLE
4459         ADD     W,PLTP          ;NEW BASE OF PL TABLE
4460         HRL     W,BLKSIZ        ;NEW SIZE OF PL TABLE
4461         HLLM    W,PLTP          ;INTO POINTER
4462         JRST    SLTC
4463
4464
4465 IFN REENT,<
4466 FORTHI: HRRZ T,JOBREL   ;CHECK FOR CORE OVERFLOW
4467         CAIGE T,@X
4468         PUSHJ   P,[PUSHJ P,HIEXP
4469                 TLOA F,FULLSW
4470                 JRST POPJM3     ;CHECK AGAIN
4471                 POPJ P,]
4472         JRST BITWX2>
4473
4474
4475 SUBTTL  PROCESS END CODE WORD
4476
4477 ENDS:   PUSHJ   P,WORD;         GET STARTING ADDRESS
4478         JUMPE   W,ENDS1;        NOT MAIN
4479         ADDI    W,(R);          RELOCATION OFFSET
4480         TLNE    N,ISAFLG;       IGNORE STARTING ADDRESS
4481         JRST ENDS1
4482         HRRZM   W,STADDR        ;STORE STARTING ADDRESS
4483 IFN NAMESW,<MOVE W,1(N) ;SET UP NAME
4484         PUSHJ   P,LDNAM
4485         MOVE W,DTIN
4486         MOVEM W,PRGNAM>
4487 ENDS1:  PUSHJ   P,WORDPR        ;DATA STORE SIZE
4488         HRRZM   C,PTEMP         ;NUMBER OF PERMANENT TEMPS
4489         MOVEM   V,CCON;         START OF CONSTANTS AREA
4490         JUMPE   W,E1;           NULL
4491         MOVEM   W,BLKSIZ        ;SAVE COUNT
4492         MOVEI   W,0(V)          ;DEFINE CONST.
4493         MOVE    C,CNR50         ;...
4494         TLNN    F,SKIPSW!FULLSW
4495         PUSHJ   P,SYMPT         ;...
4496         PUSHJ   P,GSWD          ;STORE CONSTANT TABLE
4497 E1:     MOVEI   W,0(V);         GET LOADER LOC
4498         EXCH    W,PTEMP;        STORE INTO PERM TEMP POINTER
4499         ADD     W,PTEMP;        FORM TEMP TEMP ADDRESS
4500         MOVEM   W,TTEMP;        POINTER
4501         MOVEM   V,GSTAB;        STORE LOADER LOC IN GLOBSUB
4502         MOVEM H,SVFORH
4503         MOVE    C,TTR50         ;DEFINE %TEMP.
4504         TLNE    F,SKIPSW!FULLSW
4505         JRST    E1A
4506         PUSHJ   P,SYMPT         ;...
4507         MOVE    C,PTR50         ;DEFINE (IF EXTANT) TEMP.
4508         MOVEI   W,0(V)          ;...
4509         CAME    W,TTEMP         ;ANY PERM TEMPS?
4510         PUSHJ   P,SYMPT         ;YES, DEFINE
4511 E1A:    PUSHJ   P,WORD;         NUMBER OF GLOBSUBS
4512         JUMPE   W,E11
4513         MOVEM   W,BLKSIZ        ;SIZE OF GLOBSUB
4514         PUSHJ   P,GSWD          ;STORE GLOBSUB TABLE
4515 E11:    MOVEM   V,STAB;         SCALARS
4516         PUSHJ   P,WORD;         HOW MANY?
4517         JUMPE   W,E21;          NONE
4518         PUSHJ   P,GSWDPR        ;STORE SCALAR TABLE
4519 E21:    MOVEM   V,ATAB;         ARRAY POINTER
4520         PUSHJ   P,WORD;         COMMENTS FOR SCALARS APPLY
4521         JUMPE   W,E31
4522         PUSHJ   P,GSWDPR        ;STORE ARRAY TABLE
4523 E31:    MOVEM   V,AOTAB;        ARRAYS OFFSET
4524         PUSHJ   P,WORD;         SAME COMMENTS AS ABOVE
4525         JUMPE   W,E41
4526         PUSHJ   P,GSWDPR        ;STORE ARRAY OFFSET TABLE
4527 E41:    PUSHJ   P,WORD;         TEMP, SCALAR, ARRAY SIZE
4528         TLNE    F,FULLSW!SKIPSW ;SKIPPING THIS PROG?
4529         MOVEI   W,0             ;DON'T ACCEPT GLOB SUBPROG REQUESTS
4530         MOVEM   V,CTAB;         SETUP COMMON TABLE POINTER
4531         ADD     W,GSTAB;        GLOBAL SUBPROG BASE
4532         MOVEM   W,COMBAS;       START OF COMMON
4533         PUSHJ   P,WORD;         COMMON BLOCK SIZE
4534         HRRZM   W,BLKSIZ
4535         JUMPE   W,PASS2;        NO COMMON
4536 COMTOP: PUSHJ   P,WORDPR        ;GET A COMMON PAIR
4537         TLNE    F,SKIPSW!FULLSW ;IF SKIPPING
4538         JRST    COMCO1          ;DON'T USE
4539         PUSHJ   P,SDEF;         SEARCH
4540         JRST    COMYES;         ALREADY THERE
4541         HRLS    W
4542         HRR     W,COMBAS;       PICK UP THIS COMMON LOC
4543         TLNN    F,SKIPSW!FULLSW
4544         PUSHJ   P,SYMXX;        DEFINE IT
4545         MOVS    W,W;            SWAP HALFS
4546         ADD     W,COMBAS;       UPDATE COMMON LOC
4547         HRRM    W,COMBAS;       OLD BASE PLUS NEW SIZE
4548         HLRZS   W;              RETURN ADDRESS
4549         TLZ     C,400000
4550         TLNN F,SKIPSW!FULLSW
4551         PUSHJ   P,SYMXX
4552 COMCOM: PUSHJ   P,CWSTWX        ;STORE A WORD PAIR
4553 COMCO1: SOS     BLKSIZ
4554         SOSLE   BLKSIZ
4555         JRST    COMTOP
4556         JRST    PASS2
4557
4558 COMYES: HLRZ    C,2(A);         PICK UP DEFINITION
4559         CAMLE   W,C;            CHECK SIZE
4560         JRST    ILC;            ILLEGAL COMMON
4561         MOVE    C,1(A);         NAME
4562         HRRZ    W,2(A); BASE
4563         JRST    COMCOM
4564
4565
4566
4567 PRSTWX: PUSHJ   P,WORDPR        ;GET A WORD PAIR
4568 CWSTWX: EXCH    C,W             ;SPACE TO STORE FIRST WORD OF PAIR?
4569         PUSHJ   P,WSTWX         ;...
4570         EXCH    C,W             ;THERE WAS; IT'S STORED
4571 WSTWX:  TLNE    F,FULLSW!SKIPSW ;SPACE FOR ANOTHER WORD?
4572         POPJ    P,              ;NOPE, RETURN
4573         MOVEM   W,@X            ;YES, STORE IT.
4574         AOJA    V,BITWX         ;TELL THE TABLES ABOUT IT; THEN RETURN
4575
4576
4577 GSWD:   PUSHJ   P,WORD          ;GET WORD FROM TABLE
4578         PUSHJ   P,WSTWX         ;STASH IT
4579         SOSE    BLKSIZ          ;FINISHED?
4580         JRST    GSWD            ;NOPE, LOOP
4581         POPJ    P,              ;TRA 1,4
4582
4583 GSWDPR: MOVEM   W,BLKSIZ        ;KEEP COUNT
4584 GSWDP1: PUSHJ   P,PRSTWX        ;GET AND STASH A PAIR
4585         SOS     BLKSIZ          ;FINISHED?
4586         SOSLE   BLKSIZ          ;...
4587         JRST    GSWDP1          ;NOPE, LOOP
4588         POPJ    P,              ;TRA 1,4
4589
4590
4591 SUBTTL  BEGIN HERE PASS2 TEXT PROCESSING
4592
4593 PASS2:  ADDI V,(X)
4594 IFN REENT,<TLNE F,HIPROG
4595         HRRZ V,H>
4596         MOVEM V,TOPTAB  ;SAVE FOR OVERLAP CHECKING
4597         TLNE    F,FULLSW+SKIPSW;        ABORT?
4598         JRST    ALLOVE;         YES
4599         MOVE    V,LLC           ;PICK UP PROGRAM ORIGIN
4600         CAML    V,CCON          ;IS THIS A PROGRAM?
4601         JRST    FBLKD           ;NO, GO LOOK FOR FIRST BLK DATA
4602         TLOE    N,PGM1          ;YES, IS THIS FIRST F4 PROG?
4603         JRST    NOPRG           ;NO
4604         HRR     W,COMBAS        ;YES, PLACE PROG BREAK IN LH
4605 IFE L,<IFN REENT,<TLNN F,HIPROG ;DON'T BOTHER IF IN HISEG, CHAIN NOT SMART ENOUGH>
4606         HRLM    W,JOBCHN(X)     ;FOR CHAIN>
4607 NOPRG:  HRRZ    W,PLTP;         GET PROG TABLE BASE
4608         HLRZ    C,PLTP;         AND SIZE
4609         ADD     W,C;            COMPUTE END OF PROG TABLE
4610         ADD     W,[POINT 1,1];  AND BEGINNING OF BIT TABLE
4611         EXCH    W,BITP;         SWAP POINTERS
4612 PASS2B: ILDB    C,BITP;         GET A BIT
4613         JUMPE   C,PASS2C;       NO PASS2 PROCESSING
4614         PUSHJ   P,PROC;         PROCESS A TAG
4615         JRST    PASS2B;         MORE TO COME
4616         JRST    ENDTP;
4617
4618 PROC:   LDB     C,[POINT 6,@X,23];      TAG
4619         SETZM   MODIF;          ZERO TO ADDRESS MODIFIER
4620         TRZE    C,40
4621         AOS     MODIF
4622         MOVEI   W,TABDIS;       HEAD OF TABLE
4623         HRLI W,-TABLNG  ;SET UP FOR AOBJN
4624         HLRZ    T,(W);          GET ENTRY
4625         CAME    T,C;            CHECK
4626         AOBJN W,.-2
4627         JUMPGE W,LOAD4A ;RAN OUT OF ENTRIES
4628         HRRZ    W,(W);          GET DISPATCH
4629         LDB     C,[POINT 12,@X,35]
4630         JRST    (W);            DISPATCH
4631
4632
4633 PASS2C: PUSHJ   P,PASS2A
4634         JRST    PASS2B
4635         JRST    ENDTP
4636
4637
4638
4639 TABDIS: XWD 11,PCONS;           CONSTANTS
4640         XWD 06,PGS;             GLOBAL SUBPROGRAMS
4641         XWD 20,PST;             SCALARS
4642         XWD 22,PAT;             ARRAYS
4643         XWD 01,PATO;            ARRAYS OFFSET
4644         XWD 00,PPLT;            PROGRAMMER LABELS
4645         XWD 31,PMLT;            MADE LABESL
4646         XWD 26,PPT;             PERMANENT TEMPORARYS
4647         XWD 27,PTT;             TEMPORARY TEMPORARYS
4648 TABLNG==.-TABDIS
4649 ;DISPATCH ON A HEADER
4650
4651 HEADER: CAMN    W,[EXP -2];     END OF PASS ONE
4652         JRST    ENDS
4653         LDB     C,[POINT 12,W,35];      GET SIZE
4654         MOVEM   C,BLKSIZ
4655         ANDI    W,770000
4656         JUMPE   W,PLB;  PROGRAMMER LABEL
4657         CAIN    W,500000;       ABSOLUTE BLOCK
4658         JRST    ABSI;
4659         CAIN    W,310000;       MADE LABEL
4660         JRST    MDLB;           MADE LABEL
4661         CAIN    W,600000
4662         JRST    GLOBDF
4663         CAIN    W,700000;       DATA STATEMENT
4664         JRST    DATAS
4665         JRST    LOAD4A;         DATA STATEMENTS WILL GO HERE
4666
4667 TTR50:  RADIX50 10,%TEMP.
4668 PTR50:  RADIX50 10,TEMP.
4669 CNR50:  RADIX50 10,CONST.
4670
4671
4672 SUBTTL  ROUTINES TO PROCESS POINTERS
4673
4674 PCONS:  ADD     C,CCON;         GENERATE CONSTANT ADDRESS
4675         SOJA    C,PCOMX         ;ADJUST FOR 1 AS FIRST ENTRY
4676
4677 PSTA:   PUSHJ   P,SWAPSY        ;NON-COMMON SCALARS AND ARRAYS
4678         ADDI    C,(R);          RELOCATE
4679 PCOM1:  PUSHJ   P,SYDEF         ;...
4680 PCOMX:  ADD     C,MODIF         ;ADDR RELOC FOR DP
4681         HRRM    C,@X;           REPLACE ADDRESS
4682 PASS2A: AOJ     V,;             STEP READOUT POINTER
4683         CAML    V,CCON          ;END OF PROCESSABLES?
4684 CPOPJ1: AOS     (P);            SKIP
4685         POPJ    P,;
4686
4687 PAT:    SKIPA   W,ATAB          ;ARRAY TABLE BASE
4688 PST:    MOVE    W,STAB          ;SCALAR TABLE  BASE
4689         ROT     C,1             ;SCALE BY 2
4690         ADD     C,W             ;ADD IN TABLE BASE
4691         ADDI    C,-2(X);        TABLE ENTRY
4692         HLRZ    W,(C);          CHECK FOR COMMON
4693         JUMPE   W,PSTA;         NO COMMON
4694         PUSHJ   P,COMDID        ;PROCESS COMMON
4695         JRST    PCOM1
4696
4697 COMDID: LSH     W,1             ;PROCESS COMMON TABLE ENTRIES
4698         ADD     W,CTAB;         COMMON TAG
4699         ADDI    W,-2(X);        OFFSET
4700         PUSHJ   P,SWAPSY;       GET SYMBOL AND SET TO DEFINED
4701         ADD     C,1(W);         BASE OF COMMON
4702         POPJ    P,              ;RETURN
4703
4704 PATO:   ROT     C,1
4705         ADD     C,AOTAB;        ARRAY OFFSET
4706         ADDI    C,-2(X);        LOADER OFFSET
4707         MOVEM   C,CT1;          SAVE CURRENT POINTER
4708         HRRZ    C,1(C);         PICK UP REFERENCE POINTER
4709         ANDI    C,7777; MASK TO ADDRESS
4710         ROT     C,1;            ALWAYS A ARRAY
4711         ADDI    C,-2(X)
4712         ADD     C,ATAB
4713         HLRZ    W,(C);          COMMON CHECK
4714         JUMPE   W,NCO
4715         PUSHJ   P,COMDID        ;PROCESS COMMON
4716         PUSHJ   P,SYDEF
4717         MOVE    C,CT1
4718         HRRE    C,(C)
4719         ADD     C,1(W)
4720         JRST    PCOMX
4721
4722
4723 NCO:    PUSHJ   P,SWAPSY;
4724         ADDI    C,(R)           ;DEFINE SYMBOL IN TRUE LOC
4725         PUSHJ   P,SYDEF         ;...
4726         MOVE    C,CT1
4727         HRRZ    C,(C)           ;OFFSET ADDRESS PICKUP
4728         ADDI    C,(R)           ;WHERE IT WILL BE
4729         JRST    PCOMX           ;STASH ADDR AWAY
4730
4731 PTT:    ADD     C,TTEMP;        TEMPORARY TEMPS
4732         SOJA    C,PCOMX         ;ADJUST FOR 1 AS FIRST ENTRY
4733
4734 PPT:    ADD     C,PTEMP;        PERMANENT TEMPS
4735         SOJA    C,PCOMX         ;ADJUST FOR 1 AS FIRST ENTRY
4736
4737 PGS:    ADD     C,GSTAB;        GLOBSUBS
4738         ADDI    C,-1(X);        OFFSET
4739         MOVE    C,(C)
4740         TLC     C,640000;       MAKE A REQUEST
4741         PUSHJ P,TBLCHK          ;CHECK FOR OVERLAP
4742         MOVEI   W,(V);          THIS LOC
4743         HLRM    W,@X;           ZERO RIGHT HALF
4744         PUSHJ   P,SYMXX
4745         JRST    PASS2A
4746
4747 SYDEF:  TLNE    N,SYDAT         ;SYMBOL WANTS DEFININITION?
4748         POPJ    P,              ;NO, GO AWAY
4749         PUSH    P,C             ;SAVE THE WORLD
4750         PUSH    P,W
4751         PUSHJ P,TBLCHK  ;CHECK FOR OVERLAP
4752         MOVE    W,C
4753         SKIPE   C,T     ;PICKUP VALUE
4754         PUSHJ   P,SYMXX
4755         POP     P,W
4756         POP     P,C
4757         POPJ    P,;
4758
4759 PMLT:   ADD     C,MLTP
4760         JRST    .+2
4761 PPLT:   ADD     C,PLTP
4762         HRRZ    C,(C)
4763         JRST    PCOMX
4764
4765 SYMXX:  PUSH    P,V
4766         PUSHJ   P,SYMPT
4767         POP     P,V
4768 IFE REENT,<POPJ P,>
4769 IFN REENT,<JRST RESTRX>
4770
4771
4772
4773 SWAPSY: MOVEI   T,0;            SET TO EXCHANGE DEFS
4774         EXCH    T,1(C);         GET NAME
4775         HRRZ    C,(C)           ;GET VALUE
4776         POPJ    P,
4777 TBLCHK: HRRZ W,MLTP     ;GETT TOP OV TABLES
4778         SUBI W,2
4779         CAMG W,TOPTAB   ;WILL IT OVERLAP
4780 IFE EXPAND,<TLO F,FULLSW>
4781 IFN EXPAND,<JRST [PUSHJ P,XPAND
4782                 TLOA F,FULLSW
4783                 JRST TBLCHK
4784                 POPJ P,]>
4785         POPJ P,
4786
4787
4788 SUBTTL  END OF PASS2
4789
4790 ALLOVE: TLZ     N,F4SW          ;END OF F4 PROG
4791         HRRZ V,SDSTP    ;GET READY TO ZERO OUT DATA STMTS
4792         SETZM (V)       ;AT LEAST ONE THERE
4793         CAIL V,(S)      ;IS THERE MORE THAN ONE??
4794         JRST NOMODS     ;NO
4795         HRLS V
4796         ADDI V,1        ;SET UP BLT
4797         BLT V,(S)       ;ZERO OUT ALL OF IT
4798 NOMODS: MOVE H,SVFORH
4799         TLNE    F,FULLSW!SKIPSW
4800         JRST    HIGH3A
4801         HRR     R,COMBAS        ;TOP OF THE DATA
4802         CAMG    H,SDS           ;HIGHEST LOC GREATER THAN DATA STATEMENTS?
4803         JRST    HIGH3A          ;NO, RETURN
4804         ADDI    H,1(S)          ;YES, SET UP MEANINGFUL ERROR COMMENT
4805         SUB     H,SDS           ;...
4806         TLO     F,FULLSW        ;INDICATE OVERFLO
4807 HIGH3A: IFN REENT,<SETZ W,      ;CAUSES TROUBLE OTHERWISE
4808         TLZE F,HIPROG
4809         JRST HIGHN1
4810         HRRZ V,GSTAB
4811         MOVEI V,@X
4812         CAMLE V,HILOW
4813         MOVEM V,HILOW>
4814         HRRZ C,R
4815         JRST    HIGH31          ;RETURN
4816
4817 DATAS:  TLNE    F,FULLSW+SKIPSW
4818         JRST    DAX
4819         MOVEI   C,(S)           ;ADDR OF WORD UNDER SYMBOL TABLE
4820         MOVN    W,BLKSIZ        ;HOW FAR DOWN TO BLT
4821         ADDM    W,PLTP          ;UPDATE TABLE POINTERS
4822         ADDM    W,BITP          ;...
4823         ADDM    W,SDSTP         ;...
4824         ADD     C,W             ;RH(C):= WHEN TO STOP BLT
4825         HRL     C,MLTP          ;SOURCE OF BLTED DATA
4826         ADD     W,MLTP          ;UPDATE, GET DESTINATION OF BLT DATA
4827 IFN EXPAND,<    HRRZS W ;GET RID OF LEFT HALF
4828                 CAIG W,(H)
4829                 PUSHJ P,[PUSHJ P,XPAND
4830                         POPJ P,
4831                         ADDI W,2000
4832                         ADD C,[XWD 2000,2000]
4833                         JRST POPJM2]>
4834         HRRM    W,MLTP  ;NO SET THIS SO EXTRA CORE NOT ZEROED
4835         HLL     W,C             ;FORM BLT POINTER
4836         BLT     W,-1(C)         ;MOVE TABLES DOWN (BUT NOT JRST ALLOVE)
4837         PUSHJ   P,BITWX
4838 DAX:    PUSHJ   P,WORD;         READ ONE WORD
4839         TLNN    F,FULLSW+SKIPSW
4840         MOVEM   W,(C)
4841         SOSLE   BLKSIZ          ;COUNT OF DATA SEQUENCE SIZE
4842         AOJA    C,DAX           ;INCREMENT DATA SEQUENCE DEPOSIT LOC
4843         JRST    TEXTR;          DONE
4844
4845
4846 FBLKD:  TLOE    N,BLKD1         ;IS THIS FIRST BLOCK DATA?
4847         JRST    ENDTP           ;NO
4848         HRR     V,COMBAS        ;PLACE PROG BREAK IN RH FOR
4849 IFE L,<IFN REENT,<      TLNN F,HIPROG>
4850         HRRM    V,JOBCHN(X)     ;CHAIN>
4851 ENDTP:  TLNE    F,FULLSW+SKIPSW
4852         JRST    ALLOVE
4853         HRR     V,GSTAB
4854 ENDTP0: CAML    V,STAB;         ANY MORE GLOBSUBS
4855         JRST    ENDTP2;         NO
4856         MOVE    C,@X;           GET SUBPROG NAME
4857         PUSHJ   P,SREQ;         IS IT ALLREADY REQUESTED
4858         AOJA    V,ENDTP0;       YES
4859         PUSHJ   P,SDEF;         OR DEFINED
4860         AOJA    V,ENDTP0;       YES
4861         PUSHJ   P,TBLCHK
4862         MOVEI   W,0             ;PREPARE DUMMY LINK
4863         TLNN    F,FULLSW+SKIPSW ;ABORT
4864         PUSHJ   P,SYM3X;        PUT IN DUMMY REQUEST
4865         PUSHJ   P,BITWX;        OVERLAP CHECK
4866         AOJA    V,ENDTP0
4867 ENDTP2: SETZM   PT1
4868 ENDTPW: HRRZ    V,SDSTP
4869 IFN EXPAND,<IFN REENT,<TLNE F,HIPROG
4870                 JRST ENDTPI>
4871                 SUBI V,(X)
4872                 CAMG V,COMBAS
4873                 JRST    [SUB V,COMBAS
4874                         MOVNS   V
4875                         PUSHJ P,XPAND9
4876                         TLO F,FULLSW
4877                         JRST .+1]
4878 ENDTPH:         HRR V,SDSTP>
4879         HRRZM   V,SDS           ;DATA STATEMENT LOC
4880 ENDTP1: SUBI    V,(X);          COMPENSATE FOR OFFSET
4881         MOVE    W,@X;   GET WORD
4882         TLNE    W,-1;           NO LEFT HALF IMPLIES COUNT
4883         JRST    DODON;          DATA DONE
4884         ADD     W,[MOVEI W,3]
4885         ADDI    W,@X
4886         EXCH    W,@X
4887         AOJ     V,
4888         ADD     W,@X;           ITEMS COUNT
4889         MOVEM   W,ITC
4890         MOVE    W,[MOVEM W,LTC]
4891         MOVEM   W,@X;           SETUP FOR DATA EXECUTION
4892         AOJ     V,
4893         MOVSI   W,(MOVEI W,0)
4894         EXCH    W,@X
4895         MOVEM   W,ENC;          END COUNT
4896         AOJ     V,
4897         MOVEI   W,@X
4898         ADDM    W,ITC
4899 LOOP:   MOVE    W,@X
4900         HLRZ    T,W;            LEFT HALF INST.
4901         ANDI    T,777000
4902         CAIN    T,254000        ;JRST?
4903         JRST    WRAP            ;END OF DATA
4904         CAIN    T,260000        ;PUSHJ?
4905         JRST    PJTABL(W)       ;DISPATCH VIA TABLE
4906         CAIN    T,200000;       MOVE?
4907         AOJA    V,INNER
4908         CAIN    T,270000;       ADD?
4909         JRST    ADDOP
4910         CAIN    T,221000;       IMULI?
4911         AOJA    V,LOOP
4912         CAIE    T,220000;       IMUL?
4913         JRST    LOAD4A;         NOTA
4914 INNER:  HRRZ    T,@X;           GET ADDRESS
4915         TRZE    T,770000;       ZERO TAG?
4916         SOJA    T,CONPOL;       NO, CONSTANT POOL
4917         JUMPE T,FORCNF
4918         SUB     T,PT1;          SUBTRACT INDUCTION NUMBER
4919         ASH     T,1
4920         SUBI T,1
4921         HRRM    T,@X
4922         HLRZ    T,@X
4923         ADDI    T,P
4924         HRLM    T,@X
4925         AOJA    V,LOOP
4926 IFN EXPAND,<IFN REENT,<ENDTPI:  HRRZ V,COMBAS
4927         MOVEI V,@X
4928         CAMLE V,JOBREL
4929         JRST    [PUSHJ P,HIEXP
4930                 TLOA F,FULLSW
4931                 JRST ENDTPI
4932                 JRST ENDTPH]
4933         JRST ENDTPH>>
4934 FORCNF: ERROR   ,</FORTRAN CONFUSED ABOUT DATA STATEMENTS#/>
4935         JRST LD2
4936
4937
4938 CONPOL: ADD     T,ITC;  CONSTANT BASE
4939         HRRM    T,@X
4940         AOJA    V,LOOP
4941
4942 ADDOP:  HRRZ    T,@X
4943         TRZE    T,770000
4944         SOJA    T,CONPOL
4945 SKIPIN: AOJA    V,LOOP
4946
4947 PJTABL: JRST    DWFS            ;PUSHJ 17,0
4948         AOSA    PT1             ;INCREMENT DO COUNT
4949         SOSA    PT1;            DECREMENT DO COUNT
4950         SKIPA   W,[EXP DOINT.]
4951         MOVEI   W,DOEND.
4952         HRRM    W,@X
4953         AOJA    V,SKIPIN        ;SKIP A WORD
4954
4955 DWFS:   MOVEI   W,DWFS.
4956         HRRM    W,@X
4957         AOJ     V,
4958         TLO     N,SYDAT
4959         PUSHJ   P,PROC;         PROCESS THE TAG
4960         JRST    LOAD4A          ;DATA STATEMENT BELOW CODE TOP
4961         JRST    LOOP            ;PROPER RETURN
4962
4963 DOINT.: POP     P,V;            GET ADDRESS OF INITIAL VALUE
4964         PUSH    P,(V);          STORE INDUCTION VARIABLE
4965         AOJ     V,
4966         PUSH    P,V;            INITIAL ADDRESS
4967         JRST    (V)
4968
4969 DOEND.: HLRE    T,@(P)          ;RETAIN SIGN OF INCREMENT
4970         ADDM    T,-2(P);        INCREMENT
4971         HRRZ    T,@(P);         GET FINAL VALUE
4972         SUB     T,-2(P)         ;FINAL - CURRENT
4973         IMUL    T,@(P)          ;INCLUDE SIGN OF INCREMENT
4974         JUMPL   T,DODONE        ;SIGN IS ONLY IMPORTANT THING
4975         POP     P,(P);          BACK UP POINTER
4976         JRST    @(P)
4977
4978
4979 DODONE: POP     P,-1(P);        BACK UP ADDRESS
4980         POP     P,-1(P)
4981         JRST    CPOPJ1          ;RETURN
4982
4983 WRAP:   MOVE    W,ENC;          NUMBER OF CONSTANTS
4984         ADD     W,ITC;          CONSTANT BASE
4985         MOVEI   C,(W);          CHAIN
4986         HRRM    C,@X
4987         MOVEI   V,(W);          READY TO GO
4988         JRST    ENDTP1
4989
4990 DODON:  TLZ     N,RCF!SYDAT!DZER        ;DATA STATEMENT FLAGS
4991         MOVE    W,PTEMP         ;TOP OF PROG
4992         ADDI    W,(X)           ;+OFFSET
4993         HRRZ C,SDS
4994 IFE EXPAND,<SUBI C,(X)  ;CHECK FOR ROOM
4995         CAMGE C,COMBAS  ;IS IT THERE
4996         TLO F,FULLSW    ;NO (DONE EARLIER IF EXPAND)
4997         HRRZ C,SDS>
4998         SUBI C,1        ;GET ONE LESS (TOP LOCATION TO ZERO)
4999 IFN REENT,<TLNE F,HIPROG
5000         MOVE C,JOBREL>
5001 SECZER: CAMLE   W,C             ;ANY DATA TO ZERO?
5002         JRST    @SDS            ;NO, DO DATA STATEMENTS
5003                                 ;FULLSW IS ON IF COMBAS GT. SDS
5004         TLNN    F,FULLSW+SKIPSW ;SHOULD WE ZERO?
5005         SETZM   (W)             ;YES, DO SO
5006         TLON    N,DZER          ;GO BACK FOR MORE?
5007         AOJA    W,SECZER        ;YES, PLEASE
5008         HRLI    W,-1(W)         ;SET UP BLT POINTER TO ZERO DATA
5009         TLNN    F,FULLSW+SKIPSW ;SHOULD WE ZERO?
5010         BLT     W,(C)           ;YES, DO SO
5011         JRST    @SDS            ;GO DO DATA STATEMENTS
5012
5013 DATAOV: ERROR   0,</DATA STATEMENT OVERFLOW#/>
5014         JRST    LD2
5015
5016
5017 DREAD:  TLNE    N,RCF;          NEW REPEAT COUNT NEEDED
5018         JRST    FETCH;          NO
5019         MOVE    W,LTC
5020         MOVEM   W,LTCTEM
5021         MOVE    W,@LTC;         GET A WORD
5022         HLRZM   W,RCNT;         SET REPEAT COUNT
5023         HRRZM   W,WCNT;         SET WORD COUNT
5024         POP     W,(W);          SUBTRACT ONE FROM BOTH HALFS
5025         HLLM    W,@LTC;         DECREMENT REPEAT COUNT
5026         AOS     W,LTC;          STEP READOUT
5027         TLO     N,RCF
5028 FETCH:  MOVE    W,@LTC
5029         AOS     LTC
5030         SOSE    WCNT
5031         POPJ    P,;
5032         SOSN    RCNT
5033         JRST    DOFF.
5034         MOVE    V,LTCTEM;       RESTORE READOUT
5035         MOVEM   V,LTC
5036 DOFF.:  TLZ     N,RCF;          RESET DATA REPEAT FLAG
5037         POPJ    P,;
5038
5039 DWFS.:  MOVE    T,(P)
5040         AOS     (P)
5041         MOVE    T,(T);          GET ADDRESS
5042         HLRZM   T,DWCT;         DATA WORD COUNT
5043         HRRZS   T
5044         ADDI    T,(W);          OFFSET
5045 IFN REENT,<HRRZS T              ;CLEAR LEFT HALF INCASE OF CARRY
5046         CAML T,HVAL1
5047         JRST    [ADD T,HIGHX
5048                 HRRZS T ;MUST GET RID OF LEFT HALF
5049                 CAMLE T,JOBREL
5050                 JRST DATAOV     ;IN CASE FORTRAN GOOFS ON LIMITS
5051                 JRST DWFS.1]
5052         ADD T,LOWX
5053         HRRZS T>
5054 IFE REENT,<ADDI T,(X)>
5055         CAML T,SDS
5056         JRST DATAOV
5057 DWFS.1: PUSHJ   P,DREAD         ;GET A DATA WORD
5058         HRRZS T
5059 IFN REENT,<CAMG T,JOBREL        ;JUST TO MAKE SURE>
5060         CAMN T,SDS
5061         JRST DATAOV
5062         TLNN    F,FULLSW+SKIPSW ;LOAD THE NEXT DATA ITEM?
5063         MOVEM   W,(T)           ;YES, STORE IT
5064         SOSE    W,DWCT;         STEP DOWN AND TEST
5065         AOJA T,DWFS.1           ;ONE MORE TIME, MOZART BABY!
5066         POPJ    P,
5067
5068
5069 SUBTTL  ROUTINE TO SKIP FORTRAN OUTPUT
5070
5071 ;SUBSECTION OF THE ROUTINE TO HANDLE OUTPUT FROM THE
5072 ;FORTRAN IV COMPILER. THE MAIN OBJECT OF THE ROUTINE IS TO
5073 ;LOOK FOR THE END BLOCK. CODE TAKEN FROM FUDGE2.
5074
5075 MACHCD: HRRZ    C,W             ;GET THE WORD COUNT
5076         PUSHJ   P,WORD          ;INPUT A WORD
5077         SOJG    C,MACHCD        ;LOOP BACK FOR REST OF THE BLOCK
5078                                 ;GO LOOK FOR NEXT BLOCK
5079
5080 REJECT: PUSHJ   P,WORD          ;READ A FORTRAN BLOCK HEADER
5081         TLC     W,-1            ;TURN ONES TO ZEROES IN LEFT HALF
5082         TLNE    W,-1            ;WAS LEFT HALF ALL ONES?
5083         JRST    REJECT          ;NO, IT WAS CALCULATED MACHINE CODE
5084         CAIN    W,-2            ;YES, IS RIGHT HALF = 777776?
5085         JRST    ENDST           ;YES, PROCESS F4 END BLOCK
5086         LDB     C,[POINT 6,W,23];GET CODE BITS FROM BITS 18-23
5087         TRZ     W,770000        ;THEN WIPE THEM OUT
5088         CAIE    C,70            ;IS IT A DATA STATEMENT?
5089         CAIN    C,50            ;IS IT ABSOLUTE MACHINE CODE?
5090         JRST    MACHCD          ;YES, TREAT IT LIKE DATA STATEMENTS
5091         PUSHJ   P,WORD          ;NO, ITS A LABEL OF SOME SORT
5092         JRST    REJECT          ;WHICH CONSISTS OF ONE WORD
5093                                 ;LOOK FOR NEXT BLOCK HEADER
5094
5095 ENDST:  MOVEI   C,1             ;TWO WORDS, FIVE TABLES, ONE WORD, ONE TABLE
5096         MOVEI   T,6             ;TO GO
5097 F4LUP1: PUSHJ   P,WORD          ;GET TABLE MEMBER
5098 F4LUP3: SOJGE   C,F4LUP1        ;LOOP WITHIN A TABLE
5099         JUMPL   T,LOAD1         ;LAST TABLE - RETURN
5100         SOJG    T,F4LUP2        ;FIRST TWO WORDS AND FIVE TABLES
5101         JUMPE   T,F4LUP1        ;COMMON LENGTH WORD
5102 F4LUP2: PUSHJ   P,WORD          ;READ HEADER WORD
5103         MOVE    C,W             ;COUNT TO COUNTER
5104         JRST    F4LUP3          ;STASH
5105
5106
5107 SUBTTL  LISP LOADER
5108
5109 IFE L,< END     BEG>
5110
5111 IFN L,<LODMAK:  MOVEI A,LODMAK
5112         MOVEM A,137     ;SET UP TO SAVE THE LISP LOADER
5113         INIT 17
5114         SIXBIT /DSK/
5115         0
5116         HALT
5117         ENTER LMFILE
5118         HALT
5119         MOVNI A,LD
5120         HRLZS A
5121         ADDM A,LMLST    ;BECAUSE MACRO WON'T TAKE POLISH FIXUPS
5122         OUTPUT LMLST
5123         STATZ 740000
5124         HALT
5125         RELEASE
5126         EXIT
5127 LMFILE: SIXBIT /LISP/
5128         SIXBIT /LOD/
5129         0
5130         0
5131 LMLST:  IOWD LODMAK+1,137
5132         0
5133         END LODMAK>
5134
5135
5136 \f