ASMB,Q,C
      HED HEADER FOR FILES &F4X1 AND %F4X1 .
      NAM F4X1,8 92834-16002 REV.2030 800714
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
      END 
ASMB,Q,C
      HED FTN4X COMPILER (FTN4X:MAIN) 
      NAM FTN4X,3,90 92834-16002 REV.2030 800812
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   EXT     F.A      ADDRESS OF CURRENT A.T. ENTRY.
      EXT  F.ABT    ABORT COMPILER POINT. 
   EXT     F.AT     ADDRESS TYPE OF CURRENT ITEM. 
       ENT F.AT.    SUBSCRIPT INFO FLAG 
     EXT   F.CC     CHARACTER COUNT 
       ENT F.CCW    FTN OPTION WORD 
       ENT F.CSN    CURRENT SEGMENT NUMBER. 
       ENT F.CSZ    COMMON SIZE 
       ENT F.D      DO TABLE POINTER
   EXT     F.D0     ARRAY (ELEMENT) SIZE. 
       ENT F.D.T    ADDRESS OF '.' FUN. TABLE 
       ENT F.DID    ADDR OF F.IDI 
       ENT F.DNB    DEF OF NBUF (NAM RECORD)
   EXT     F.DNI    DEF TO NAME BUFFER (NID). 
       ENT F.DO     LWAM - END OF DO TABLE
       ENT F.DPJ    DEF TO CURRENT PROC. JUMP TABLE.
       ENT F.DTY    DEFAULT TYPE TABLE. 
       ENT F.E      EQUIVALENCE TABLE ADDR. 
       ENT F.EMA    F.A OF EMA MASTER.
       ENT F.EMS    EMA SIZE  DOUBLE WORD, (INTERNAL FORMAT)
       ENT F.END    END FLAG
       ENT F.ER0    'RX' OF ERRX  LIB ERROR ROUTINE 
       ENT F.FES    TWPE FOR FIRST EXECUTABLE STMT. 
       ENT F.FNS    FIRST NON-SPECIFICATION CHECK.
       ENT F.FRF    FUNCTION RESULT F.A (NON-STMT FCT). 
       ENT F.IDI    GENERAL DATA BUFFER.
   EXT     F.IM     CURRENT ITEM MODE.
   EXT     F.IU     CURRENT ITEM USAGE. 
       ENT F.IMF    IMPLICIT FLAG.
       ENT F.L      # WORDS ON STACK 2
       ENT F.LCF    LABELLED COMMON FLAG. 
       ENT F.LFF    LOCICAL IF FLAG 
       ENT F.LO     END OF ASSIGNMEXT TABLE+1 
       ENT F.LSF    EXPECT FIRST STATEMEXT FLAG 
       ENT F.LSN    F.A OF LAST STATEMEXT NUMBER
       ENT F.LSP    LAST OPERATION FLAG 
       ENT F.MSG    MSEG SIZE ON $EMA(...)
       ENT F.NAR    NUMBER OF ALTERNATE RETURNS.
   EXT     F.NT     CURRENT NAME TAG. 
     EXT   F.NXN    NO INPUT FLAG 
       ENT F.PCT    F.A OF TEMP FOR PCOUNT(). 
       ENT F.PTF    PERMENENT TEMP FLAG.
       ENT F.PTY    PROGRAM TYPE. 
       ENT F.REL    F.RPL OF ENTRY POINT. 
       ENT F.RES    F.A OF CURRENT RESULT.
       ENT F.RPL    PROGRAM LOCATION COUNTER
       ENT F.S1B    BOTTOM OF STACK 1 
       ENT F.S1T    TOP    OF STACK 1 
       ENT F.S2T    TOP    OF STACK 2 
       ENT F.SBF    0= MAIN, ELSE SUBROUTINE
       ENT F.SEE    RETURN POINT FROM SEGMENT 1.
       ENT F.SEG    LOAD A NEW SEGMENT
       ENT F.SEQ    CODE-GENERATING STATEMENT COUNTER.
       ENT F.SFF    SUBROUTINE/FUNCTION FLAG 0/1
       ENT F.SID    STATEMEXT ID PHASE FLAG 
       ENT F.SLF    STATEMEXT LEVEL FLAG
       ENT F.SPF    SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL 
       ENT F.SPS    ADDRESS OF CURRENT STATEMENT PROCESSOR. 
       ENT F.STA    FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ 
       ENT F.STB    STRING BACK FLAG (LOGICAL IF) 
       ENT F.SVL    SAVE # WDS ON OPER STACK (F.L)
       ENT F.SXF    COMPLEX CONSTANT FLAG 
       ENT F.T      # WORDS ON STACK 1
       ENT F.TYP    TYPE STMT FLAG
       ENT F.XID    EXTERNAL ID COUNTER.
       ENT F.UFM    ADDR OF UNIT-FILE MAP.
       ENT F.#M     # NON-DISC I/O CONNECTIONS. 
       ENT F.#N     # DISC I/O CONNECTIONS. 
       ENT F.#S     BUFFER SIZE MULTIPLE. 
       ENT F.#B     # OF BUFFER BLOCKS. 
       ENT F.$CC    SAVED F.CC AT $ STATEMENT BREAK.
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
       ENT AA.F     ASSIGN ADDRESS SUB. 
   EXT     AI.F     ASSIGN ITEM.
       ENT APT.F    ALLOCATE 'PERMANENT' TEMP CELL. 
   EXT     BNI.F    CLEAR NAME BUFFER TO BLANKS.
       ENT CAT.F    COMMON CODE FOR ALLOCATING TEMPS. 
   EXT     DAT.F    DEFINE F.AT . 
   EXT     DL.F     DEFINE LOCATION OF CURRENT A.T. ENTRY.
     EXT   ER.F     ERROR PRINT SUBROUTINE. 
   EXT     FA.F     FETCH ASSIGNS.
       ENT MVW.F    MOVE WORDS, FTN-STYLE.
       ENT NEW.F    SUB TO CLEAR TEMPS FOR A NEW MODULE 
     EXT   WAR.F    WARNING PRINT SUBROUTINE. 
       EXT WS1.F    WRITE TO FIRST PASS FILE. 
* 
*                   EXTERNAL IN THE SEGMENTS. 
* 
      EXT F.GRX     TO SECOND LEVEL OF GRD.F
      EXT F.RCO     ACCESS TO RCO.F: RELATE COMMON. 
      EXT FER.F     DO PROGRAM ENTRANCE STUFF.
* 
*                   ENTRIES TO KEEP THE GENERATOR HAPPY.
* 
      ENT F.GRD     GET REGISTER DATA.
* 
*         THIS FORTRAN IV COMPILER RUNS UNDER VARIOUS OP
*         SYSTEMS THROUGH SUITABLE INTERFACE ROUTINES.
* 
*     OPSYSTEM INTERFACE: 
* 
* 
      EXT .MVW      MOVE WORDS INSTRUCTION. 
      EXT SEG.F     SEGMENT TRANSLATOR
      EXT WRT.C 
      EXT C.TTY 
      EXT C.BIN     BINARY FCB  (MUST BE IN MAIN) 
      EXT C.SAU     SOURCE FCB  (MUST BE IN MAIN) 
      EXT C.SC0     CARD FILE FCB (MUST BE IN MAIN).
      EXT C.TRN     COMPILER LIB. DATA STORE
      EXT OLY.C     SEGMENT LOAD
      SPC 1 
      SUP 
A     EQU 0              A-REGISTER 
B     EQU 1              B-REGISTER 
      SKP 
*         ******************************
*         * MAIN ENTRY TO THE COMPILER *
*         ******************************
      SPC 1 
FTN4  BSS 0 
      DST F.IDI     SAVE THE RUN REGS.
      LDB K4        GO TO SEGMENT 4 
      JMP F.SEG 
      SPC 2 
*        *************************
*        * COMPILE A NEW PROGRAM *
*        *************************
      SPC 1 
NEW.F NOP 
      CLA 
      STA F.NXN     RESET NO INPUT FLAG 
      STA F.SID     CLEAR THE SCAN SWITCH 
      LDA K73 
      STA F.LSP     SET PATH TO THIS STATMENT TRUE
      STA F.CC      SET F.CC=73 
      JMP NEW.F,I   RETURN
      SPC 2 
F.STA NOP           FTN READ YET FLAG 
F.CCW DEC 1         COMPILE OPTION CONTROL WORD (PRINT CON REC.)
F.DNB DEF NBUF
K4    DEC 4 
F.ER0 ASC 1,R0
F.DO  NOP           LWAM; END OF F.DO TABLE 
F.D.T DEF ..TBL 
* 
F.LO  NOP           END OF ASSIGNMENT TABLE + 1.
F.S1B NOP           BEGIN OPERAND STACK 
F.S1T NOP           END OPERAND STACK 
F.S2T NOP           END OPERATOR STACK
K73   DEC 73
F.D   NOP           DO-TABLE POINTER
F.LSF NOP 
F.LSN NOP           LAST STATEMENT NUMBER FLAG
F.STB NOP           ADDRESS OF STRING-BACK ENTRY. 
* 
NBUF  EQU *         START OF NAM RECORD 
      DEF C.TRN     DUMMY REF. TO FOURCE LOAD WITH MAIN 
      DEF C.BIN     ALSO A DUMMY
      DEF C.SAU     DITTO.
      DEF C.SC0     DITTO.
F.PTY EQU NBUF+9    PROGRAM TYPE. 
      BSS 60-*+NBUF RESERVE ROOM OF NAM RECORD
      SKP 
*         ******************
*         * SEGMENT LOADER *
*         ******************
      SPC 1 
*     ENTRY (B) = SEGMENT NUMBER. 
* 
F.SEG STB F.CSN     SET THE SEGMENT NUMBER
      JSB SEG.F     GET SEGMENT ID
      DEF F.CSN      FOR SEGMENT
      STB SEG       SET FOR CALL
      JSB OLY.C     LOAD SEGMENT (NO RETURN)
SEG   NOP 
* 
      JSB WRT.C     SEGMENT LOAD FAILED 
      DEF C.TTY     TELL HIM
      DEF NOSEG 
      DEF L.NOS 
      NOP           (IN CASE ERROR) 
      HLT 0         FOURCE MP (OR HLT IF SUCH A SYSTEM) 
* 
NOSEG ASC 12,/FTN4X: SEGMENT MISSING!,
L.NOS DEC 12
F.CSN NOP           CURRENT SEGMENT NUMBER. 
F.SEQ NOP           SEQUENCE COUNTER FOR CODE-GEN STMTS.
F.SLF NOP           STATEMENT LEVEL FLAG
F.SID NOP           STID FLAG 
F.END NOP 
      SPC 2 
*         **********************
*         * MOVE WORDS ROUTINE *
*         **********************
      SPC 1 
*     CALL:   JSB MVW.F 
*             DEF <DEST>
*             DEF <SOURCE>
*             DEC <# WDS> 
* 
MVW.F NOP 
      LDB MVW.F     (B) = ADDR ADDR DEST. 
      ISZ MVW.F 
      LDA MVW.F     (A) = ADDR ADDR SOURCE. 
      ISZ MVW.F 
      LDA A,I       RESOLVE ADDRESSES.
      RAL,CLE,SLA,ERA 
      JMP *-2 
      LDB B,I 
      RBL,CLE,SLB,ERB 
      JMP *-2 
      JSB .MVW      MOVE THE BLOCK. 
      DEF MVW.F,I 
      NOP 
      ISZ MVW.F     BUMP PAST WORD COUNT, 
      JMP MVW.F,I   AND EXIT. 
      SKP 
*         ********************************* 
*         * FIRST NON-SPECIFICATION CHECK * 
*         ********************************* 
      SPC 1 
*     INPUT: (A)=STATEMENT TYPE HIERARCHY.
*            (B)=STATEMENT KEYWORD ORDINAL. 
      SPC 1 
F.FNS STB T2FNS     SAVE ORDINAL. 
      CLB 
      STB F.END     RESET '$'-END FLAG
      STA F.SLF     LEVEL OF THIS STMT
      LDB F.SEQ     SAVE SEQUENCE DATA. 
      STB T1FNS 
      CPA K8        FORMAT ?
      JMP FNS16     YES. SKIP ALL THIS JUNK.
      CPA K4        IS IT EXECUTABLE ?
      ISZ F.SEQ     YES. BUMP COUNTER.
      CPA K5        IF END STMT.
      JMP FNS07     CHECK FOR RELAT COMMON YET
      ADA KM3 
      SSA 
      JMP F.SEE 
* 
      LDA F.SPF     EXECUTABLE. 
      SZA           IF NOT ZERO OR
      CPA K1        ONE 
      JMP F.SEE     THEN
* 
FNS02 CLB,INB       IT IS AN EXECUTABLE 
      CPB F.CSN     EVALUATOR IN MEMORY?
      JMP F.SEE     YES. GO TO ITS RETURN POINT.
      JMP F.SEG     NO. LOAD IT. RETURN TO F.SEE (B=1)
* 
K1    DEC 1 
K5    DEC 5 
K8    DEC 8 
KM3   DEC -3
KM2   DEC -2
T1FNS NOP 
* 
FNS07 LDB F.SPF     COMMON RELATED YET??
      ADB KM2       ZERO  OR ONE IF NOT 
      SSB,RSS       WELL? 
      JMP FNS02     YES. NOW (CONDITIONALLY) LOAD F4.1
* 
      JSB F.RCO,I   NO. GO DO IT. 
FNS06 LDA K2        AND SET PGM LEVEL TO 2. 
      STA F.SPF 
      JMP FNS02     NOW GO TO F4.1
      SKP 
*     WHEN LOADED, F4.1 DOES NOTHING EXCEPT RETURN HERE.
* 
F.SEE LDB F.SLF 
      CPB F.SPF     SPECIFICATION FLAG
      JMP FNS12     F.SLF EQUALS CURRENT STMNT LEVEL
* 
      CMB,INB 
      ADB F.SPF     F.SPF-F.SLF 
      LDA K34 
      SSB,RSS 
      JMP FNS17     F.SPF .GT. F.SLF, STMNT OUT OF ORDER
* 
      CLA,INA       TEST IF JUST A SPEC STMT. 
      CPA F.SLF     WELL? 
      JMP FNS05     YES SKIP TEST FOR RELATE COM
* 
      CMA           A=-2
      ADA F.SPF     IF CURRENT LEVEL IS LESS THAN TWO 
      SSA,RSS       THEN
      JMP FNS05     (NO)
* 
      JSB F.RCO,I   RELATE COMMON ITEMS 
      LDA F.SLF     PROCESSING FIRST DATA STATEMENT ? 
      CPA K2
      JMP FNS05     YES. LEAVE SEGMENT 0 IN MEMORY. 
      JMP FNS06     NO. GO ADVANCE PGM LVL & LOAD SEGMNT 1. 
* 
FNS05 LDA F.SLF 
      LDB F.SPF     GET CURRENT STMT. LEVEL 
      CPB K4        IF AT 4 ALREADY THEN
      JMP FNS08     WE HAVE ALREADY DONE THE ENTRY
* 
      CPA K5        IF END
      RSS           DO NOT ADVANCE
      STA F.SPF     ADVANCE PROGRAM STMT LEVEL
      ADA KM3       AT 1ST STMT FCT OR 1ST EXECUTABLE,
      SSA,RSS       INCL END ? (I.E., NEW LEVEL = 3,4,5 ?)
      JSB FER.F     YES, PRODUCE ENTRANCE CODE. 
FNS08 LDA F.LSN     LAST STATEMENT NUMBER 
      STA F.A 
      SZA,RSS 
      JMP FNS20     NONE; GO TO PROCESSOR.
* 
      LDA F.SLF     FORMAT STATEMENT
      LDB F.LFF     OR TRUE BRANCH OF LOGICAL IF ?
      SZB,RSS 
      CPA K8
      JMP FNS20     YES. DON'T DEFINE STATEMENT #.
* 
      LDA K77 
      LDB F.SPF     STATEMENT LEVEL FLAG
      ADB KM3 
      SSB           EXECUTABLE? 
      JMP FNS15     NO. GRIPE ABOUT STMT NO.
* 
      JSB FA.F      YES. ALREADY DEFINED ? (FOR FORMAT)?
      LDB F.AT      I.E., IS F.AT=REL ? 
      LDA K27       (ERROR #) 
      CPB REL 
      JMP FNS15     YES. GO ISSUE WARNING 27. 
* 
      LDA REL       NO. SET F.AT=REL SO KNOW HAS BEEN SEEN. 
      JSB DAT.F 
      LDA KK37      OUTPUT OPCODE TO DEFINE IT. 
      JSB WS1.F 
      LDA F.A       AND THE F.A 
      JSB WS1.F 
      LDA F.A       SAVE THE SEQUENCE # SO WE CAN OPTIMIZE
      INA           OUT 'GOTO NEXTLINE' 
      LDB T1FNS 
      CMB           DON'T CONFUSE WITH DEFAULT VALUE. 
      STB A,I 
      JMP FNS20     EXIT. 
      SPC 1 
FNS12 LDA F.LSP     LAST OPERATION FLAG 
      ADA F.LSN     LAST STATEMENT NUMBER FLAG
      CLB,INB 
      STB F.LSP 
FNS14 SZA 
      JMP FNS08 
      LDA K35 
FNS15 JSB WAR.F     NO PATH TO THIS STATEMENT 
      CLA           IN CASE IT'S DECLARATION WITH 
      STA F.LSN     STMT #, ZAP IT. 
      JMP FNS20 
      SPC 1 
FNS16 LDA F.LSN     LAST STATEMENT # FLAG 
      JMP FNS14 
* 
FNS17 LDB F.SLF     GET THE LEVEL FLAG
      CPB K2        DATA STATEMENT? 
      CLB,RSS       YES  IT CAN BE OUT OF ORDER 
      JSB ER.F      NO  BAIL OUT
* 
      CPB F.CSN     IF SPEC. SEGMENT IN MEMORY
      JMP FNS08     GO FINISH UP
* 
      LDA K77       (IN CASE ERROR) 
      CPB F.LSN     STATEMENT NUMBER??
      RSS           NO. 
      JSB WAR.F     YES. ERROR. 
* 
      CLB           NOW LOAD SEGMENT 0. 
      JMP F.SEG 
* 
K2    DEC 2 
K27   DEC 27
K34   DEC 34
K35   DEC 35
K77   DEC 77
KK37  BYT 1,45      DEFINE STMT # OPERATOR. 
REL   OCT 1000      F.AT = REL. 
      SKP 
*                   GO TO PROCESSOR.  THE LOOK-UP OF THE PROCESSOR
*                   ADDRESS MUST BE DELAYED SO THAT IF A SEGMENT
*                   IS LOADED, IT CAN UPDATE 'F.DPJ'. 
* 
FNS20 LDB T2FNS     KEYWORD ORDINAL.
      ADB F.DPJ     GET ADDR PROCESSOR. 
      LDB B,I 
      STB F.SPS     SET IT FOR USE BY THE PROCESSOR,
      JMP B,I       AND GO THERE. 
* 
T2FNS NOP           KEYWORD ORDINAL.
      SKP 
*         ******************
*         * ASSIGN ADDRESS *
*         ******************
      SPC 1 
*     TO ASSIGN STORAGE TO A SINGLE VARIABLE OR ARRAY 
*     INPUT: F.A=POINTS AT THE CANDIDATE FOR STORAGE ASSIGNMENT 
*     OUTPUT: STORAGE IS ASSIGNED FOR THE ELEMENT(IF NOT YET
*             ASSIGNED) POINTED AT BY F.A 
*             EACH ELEMENT HAS ITS AT SET TO REL AND ITS AF SET 
*             TO THE ELEMENTS RELATIVE LOCATION WITHIN THE OBJECT 
*             OUTPUT & RPL BUMPED BY SIZE OF THE ELEMENT OR ARRAY.
      SPC 1 
AA.F  NOP 
      LDA F.NT      A NAME? 
      SZA 
      JMP AA.F,I    NO. RETURN. 
      LDA F.AT
      CPA B2000     STRAB 
      RSS           NOT YET ASSIGNED
      JMP AA.F,I    ALREADY ASSIGNED
      LDA F.IU
      CPA VAR 
      JMP AA02      F.IU=VAR
      CPA ARR 
      RSS           F.IU=ARR
      JMP AA.F,I    NEITHER VAR NOR ARRAY 
AA02  JSB DL.F      DEFINE LOCATION 
      DLD F.D0      CHECK THAT SIZE < 32768.
      SZA,RSS       I.E., UPPER WORD = 0, 
      SSB           AND LOWER WORD >= 0.
      JMP AA03      NO. MEM OFL.
      ADB F.RPL     O.K., ADD TO LOC. 
      STB F.RPL     RPL=RPL+F.D0
      SSB,RSS 
      JMP AA.F,I
* 
AA03  LDA K84       RPL OVER FLOW 
      JMP F.ABT     ABORT 
* 
VAR   OCT 400       F.IU=VAR. 
ARR   OCT 600       F.IU=ARR. 
K84   DEC 84
B2000 OCT 2000
      SKP 
*         ***************************** 
*         * ALLOCATE 'PERMANENT' TEMP * 
*         ***************************** 
      SPC 1 
APT.F NOP 
      STA F.IM      SAVE THE TYPE.
      ALF           INDEX INTO THE TEMP TABLE.
      LDB DFINT 
      ADA B 
      ISZ A,I       BUMP TO THE NEXT ONE. 
      LDA A,I       AND GET IT. 
      ADA B2000     USE 2ND HALF OF RANGE ALLOCATED.
      JSB CAT.F     COMMON CODE TO DO IT. 
      JMP APT.F,I   DONE. 
      SPC 2 
*                   COMMON CODE FOR ATC.F & APT.F 
* 
CAT.F NOP           ENTER WITH (A)=TEMP #, F.IM=TYPE. 
      RAL           PUT THE TYPE IN BITS 14:11, 
      IOR F.IM      BY SHIFTING TWICE.
      INA           SET BIT 15 WHILE WE'RE AT IT. 
      RAR           DONE. <15>=1, <14:11>=TYPE, <10:0>=NUMBER.
      STA T0CAT     SAVE TEMP CELL NAME 
      CLA 
      STA F.NT      NAME TAG = 0 (VARIABLE) 
      STA F.PTF     (ALSO CLEAR PERMANENT TEMP FLAG)
      LDA VAR 
      STA F.IU      ITEM USAGE = VARIABLE 
      JSB BNI.F     CLEAR NAME TO BLANKS
      LDA T0CAT     SET UP THE FIRST TWO CHARACTERS 
      AND B377      AS THE IDENT HIGH AND LOW BYTES.
      LDB A         (B) = LOW BYTE. 
      XOR T0CAT     (A) = HIGH BYTE.
      ALF,ALF       (RIGHT-JUSTIFY) 
      DST F.DNI,I   THERE THEY GO.
      JSB AI.F      ASSIGN NAME TO A.T. 
      LDA F.A       RETURN ASSIGN TAB PTR TO TEMP CELL
      LDB F.A 
      JMP CAT.F,I 
      SPC 1 
T0CAT BSS 1 
DFINT DEF F.INT-1 
B377  OCT 377 
*              ****************************************** 
*              * GLOBAL VARIABLES,BUFFERS,AND CONSTANTS * 
*              ****************************************** 
      SPC 1 
F.LSP NOP           LAST OPERATION FLAG.
F.SPS NOP           ADDR OF CURRENT STMT PROCESSOR. 
F.LFF NOP           LOGICAL IFF FLAG. 
F.GRD DEF F.GRX,I   POINTER TO GRD.F
F.DID DEF F.IDI     ADDR OF F.IDI 
F.DTY DEF TYPET     ADDR OF DEFAULT TYPE TABLE. 
F.DPJ NOP           ADDR OF CURRENT PROC. JUMP TABLE. 
F.RES NOP           F.A OF CURRENT RESULT.
      SPC 2 
*         **********************
*         * DEFAULT TYPE TABLE *
*         **********************
* 
*     THIS TABLE CONTAINS THE DEFAULT OR IMPLICIT TYPE FOR EACH OF THE
*     LETTERS (WHICH MAY START AN IDENTIFIER).  IT IS INITIALIZED BY THE
*     INITIALIZATION SEGMENT BEFORE EACH MODULE, AND IS MODIFIED BY ANY 
*     'IMPLICIT' STATEMENT ENCOUNTERED.  EACH BYTE IS THE LEFT BYTE OF
*     THE CORRESPONDING F.IM, E.G. F.IM=REA=020000, LEFT BYTE = 40. 
* 
TYPET BYT 40,40,40,40,40,40,40,40              A-H, REAL. 
      BYT 20,20,20,20,20,20                    I-N, INTEGER.
      BYT 40,40,40,40,40,40,40,40,40,40,40,40  O-Z, REAL. 
      SKP 
*         ******************* 
*         * INITIALIZE TO 0 * 
*         ******************* 
      SPC 1 
      ABS COMEN-F.AT.-1 LENGTH OF AREA TO ZAP 
F.AT.  OCT 0         SUBSCRIPT INFORMATION FLAG 
F.REL BSS 1         ENTRY POINT.
F.RPL BSS 1         RELATIVE PROGRAM LOCATION 
F.SFF BSS 1         SUBROUTINE/FUNCTION FLAG (SET IF
*                                  A FUNCTION)
F.SPF OCT 0         SPECIFICATION FLAG (SET TO
*                          CURRENT STATEMENT LEVEL) 
F.SBF NOP           SUBPR FLAG(0=MAIN,ELSE SUBPROG.)
F.L   NOP           NUMBER OF WORDS ON STACK 2
F.SVL NOP           SAVED COPY OF F.L 
F.SXF NOP           COMPLEX CONSTANT FLAG 
F.T   NOP           NO. WORDS ON STACK 1
F.TYP NOP           TYPE STATEMENT FLAG 
F.CSZ NOP           COMMON SIZE 
F.MSG NOP           MSEG SIZE.
F.EMS OCT 0,0       DOUBLE WORD EMA SIZE
F.EMA NOP           F.A OF EMA MASTER.
F.INT BSS 13        TEMP CELL NUMBERS.
F.IDI BSS 14        GENERAL DATA BUFFER.
F.E   NOP           EQUIVALENCE TABLE POINTER.
F.XID NOP           EXTERNAL ID COUNTER.
F.IMF NOP           IMPLICIT FLAG.
F.NAR NOP           NUMBER OF ALTERNATE RETURNS.
F.LCF NOP           LABELLED COMMON FLAG. 
F.#M  NOP           # NON-DISC. 
F.#N  NOP           # DISC. 
F.#S  NOP           BUFFER SIZE.
F.#B  NOP           NUMBER OF BUFFER BLOCKS.
F.UFM NOP           ADDR OF UNIT-FILE MAP.
F.PTF NOP           PERMANENT TEMP FLAG.
F.FES NOP           TWPE OF 1ST EXECUTABLE. 
F.$CC NOP           SAVED F.CC AT $ STATEMENT BREAK.
F.PCT NOP           F.A OF TEMP USED BY PCOUNT(). 
F.FRF NOP           FUNCTION RESULT F.A (NON-STMT FCT). 
      SPC 1 
*         ********************
*         *  .EXTERNAL TABLE *
*         ********************
      SPC 1 
*     THIS TABLE OF EXTERNAL ORDINALS FOR DOT-FUNCTION
*   SUBROUTINES IS CLEARED TO ZERO AT THE BEGINNING OF
*   COMPILATION.
* 
..TBL BSS 348 
      SPC 1 
COMEN EQU *         LOCATION OF END OF COMMON AREA
      ORG * 
      END FTN4
ASMB,Q,C
      HED ASSIGNMEXT TABLE ROUTINES 
      NAM FA.F,8 92834-16002 REV.2030 800707
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE OF THE HP FTN4X COMPILER CONTAINS THE 
*     ASSIGNMEXT TABLE ROUTINES.
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   ENT     F..E     DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE
   ENT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE EXTRY 
   ENT     F.AF     ADDRESS FIELD CURREXT F.A 
   ENT     F.AT     ADDRESS TYPE OF CURREXT F.A 
       EXT F.AT.    SUBSCRIPT INFO FLAG 
   ENT     F.CSL    CHARACTER STRING LENGTH.
   ENT     F.D0     ARRAY ELEMEXT SIZE
   ENT     F.DCF    DIM, COM FLAG 
      EXT  F.DID    ADDRESS OF F.IDI
   ENT     F.DIS    DOUBLE INTEGER SUBSCRIPT FLAG.
   ENT     F.DNI    ADDRESS OF NID
   ENT     F.DP     BASE OF USER SYMBOL TABLE 
      EXT  F.E      EQUIVALENCE TABLE POINTER 
   ENT     F.EM     EMA FLAG BIT IN A.T.
   ENT     F.EXF    EXTERNAL STATEMEXT FLAG 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
   ENT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   ENT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.LCF    LABELLED COMMON FLAG. 
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
   ENT     F.LUB    ADDRESS OF LOWER/UPPER BOUNDS TABLE.
   ENT     F.NC     NAME CHANGE FLAG. 
   ENT     F.ND     NUMBER OF DIMENSIONS
   ENT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
   ENT     F.NTF    NAME TAG FLAG 
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
   ENT     F.R      MISC A.T. FLAG
       EXT F.RPL    PROGRAM LOCATION COUNTER
   ENT     F.S      SUBROUTINE FLAG.
       EXT F.S1T    TOP    OF STACK 1 
   ENT     F.S2B    BOTTOM OF STACK 2 
       EXT F.S2T    TOP    OF STACK 2 
   ENT     F.SFA    F.A OF STMT FCT IF CURRENTLY IN ONE.
       EXT F.SPF    SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL 
     EXT   F.TC     NEXT CHARACTER
   ENT     F.VDM    VARIABLE DIMENSIONS FLAG. 
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   ENT     AI.F     ASSIGN ITEM 
   ENT     AST.F    ALLOCATE SPACE IN SYMBOL TABLE. 
   ENT     BNI.F    CLEAR NID TO BLANKS 
   ENT     CFC.F    CHECK FOR CONSTANT. 
   ENT     CDI.F    CLEAR IDI ROUTINE 
   ENT     CSN.F    CHECK STATEMENT NUMBER TYPE 
   ENT     DAD.F    DOUBLE INTEGER ADD. 
   ENT     DAF.F    DEFINE (F.AF) 
   ENT     DAT.F    DEFINE (AT) 
   ENT     DEM.F    DEFINE (F.EM)=1 
   ENT     DIM.F    DEFINE (F.IM) 
   ENT     DIU.F    DEFINE (F.IU) 
   ENT     DL.F     DEFINE LOCATION SUBROUTINE
   ENT     DMP.F    DOUBLE INTEGER MULTIPLY.
   ENT     DS.F     DEFINE (F.S)=1
   ENT     DSB.F    DOUBLE INTEGER SUBTRACT.
   ENT     EDO.F    ESTABLISH DATA WITH OFFSET. 
   ENT     EIC.F    ESTABLISH INTEGER CONSTANT. 
   ENT     EJC.F    ESTABLISH DOUBLE INTEGER CONSTANT.  
     EXT   ER.F     ERROR PRINT SUBROUTINE
   ENT     ESC.F    ESTABLISH CONSTANT SUBROUTINE 
   ENT     ESD.F    ESTABLISH DEF SUBROUTINE
   ENT     FA.F     FETCH ASSIGNS 
   ENT     FC.F     FETCH VALUE OF CONSTANT.
   ENT     FID.F    FETCH (ID) TO NID (UNPACK)
   ENT     GCD.F    GET CONSTANT DIMENSION AS DOUBLE INT. 
   ENT     GFA.F    GET FIRST (NAMED) SYMBOL TABLE ENTRY. 
   ENT     GFC.F    GET FIRST (CONSTANT) SYMBOL TABLE ENTRY.
   ENT     GFD.F    GET FIRST (DEF) SYMBOL TABLE ENTRY. 
   ENT     GNA.F    GET NEXT SYMBOL TABLE EXTRY 
   ENT     IN4.F    INIT FOR FA.F MODULE
   ENT     ITS.F    INTEGER TEST
   ENT     NAM.F    COPY SYMBOL NAME. 
   ENT     NCT.F    TEST FOR NOT A CONSTANT 
   ENT     NET.F    TEST FOR NOT EMA. 
   ENT     NST.F    TEST FOR NOT A SUBROUTINE NAME
   ENT     NTI.F    MOVE NID TO F.IDI (PACKS) 
   ENT     NWE.F    RETURN (B) = # WORDS IN ITEM TYPE F.IM
   ENT     NWI.F    SET F.D0 TO # WORDS IN ARRAY
   ENT     TCT.F    TEST (A) = F.TC ELSE ER 28
   ENT     TS.F     TAG SUBPROGRAM SUB. 
   ENT     TV.F     TAG VARIABLE
     EXT   WAR.F    ERROR COMMEXT SUBROUTINE (WARNINGS) 
* 
*     GENERAL LIB EXT 
* 
      EXT .MVW      MOVE WORDS
* 
A     EQU 0 
B     EQU 1 
      SUP 
* 
* 
IN4.F NOP           INITILIZE CODE
      CLA           ZERO OUT THE
      STA DSTH+1    SYMBOL TABLE
      STA DSTH+2    LIST HEADS. 
      STA DSTH+3
      STA DSTH+4
      JMP IN4.F,I   RETURN
* 
K1    OCT 1 
      SKP 
*                    THE ASSIGNMENT TABLE 
* 
*      WORD -1 IS ALWAYS PRESENT AND GIVES THE ADDRESS OF THE NEXT ENTRY. 
*      WORD 0 IDENTIFIES THE ENTRY AND IS SPLIT UP INTO FIELDS: 
* 
*     !---------------!-----------!-------!-------!---!---!---!---!---! 
*     !      IM       !    AT     !  IU   !  NC   ! R ! E ! S !EM !NT ! 
*     !---------------!-----------!-------!-------!---!---!---!---!---! 
*     !15  14  13  12 ! 11  10  9 ! 8  7  ! 6  5  ! 4 ! 3 ! 2 ! 1 ! 0 ! 
*     !---------------!-----------!-------!-------!---!---!---!---!---! 
*         (170000)       (7000)     (600)   (140)  20  10  (4) (2) (1)
* 
* 
*   IM = ITEM MODE: 
* 
*       0: ---  STMT NUMBER            6: DBL: DOUBLE PRECISION*6 
*       1: INT: INTEGER*2              7: ADDR: TEMPORARY ADDRESS 
*       2: REA: REAL*4                 8: DBI: INTEGER*4
*       3: LOG: LOGICAL*2              9: LO4: LOGICAL*4
*       4: TWPE: OBJECT CODE          10: RE8: DOUBLE PRECISION*8 
*       5: CPX: COMPLEX*8             11: STR: CHARACTER
*                                     12: ZPX: COMPLEX*16 
* 
* 
*   AT = ADDRESS TYPE.                MEANING OF WORD 1 (F.AF)
* 
*       0: ---  ABSOLUTE (NOT USED) 
*       1: REL: RELATIVE               RELATIVE ADDRESS 
*       2: STR-ABS: UNDEFINED OR NOT   DEF *
*                     REFERENCED YET
*                   HOLLERITH CONST    - # WORDS. 
*       3: BCOM: LABELLED COMMON       PTR TO BCOMI OR DIM ENTRY
*       4: COM: BLANK COMMON           OFFSET INTO COMMON 
*       5: DUM: DUMMY PARAMETER        RELATIVE ADDR OF DEF TO IT 
*       6: DIM: DIMENSION ENTRY        RELATIVE ADDRESS OF ARRAY
*                                      (OR POINTER TO BCOM ENTRY) 
*       7: BCOMI: LBL COMMON OFFSET    OFFSET FROM START OF BLOCK 
*                 LBL COMMON MASTER    0 OR - EXT ID #
* 
* 
*   IU = ITEM USAGE: HOW USED 
* 
*       0: ---  NOT YET USED
*       1: SUB: SUBROUTINE
*       2: VAR/CON: VARIABLE OR CONSTANT
*       3: ARR: ARRAY 
* 
* 
*   NC = MISC FLAGS 
* 
*       STATEMENT #'S:  TYPE (FORMAT/EXECUTABLE). 
*       SUBROUTINES:    EXTERNAL/INTRINSIC/GENERIC FLAGS. 
*       DIMENSION:      F.VDM = VARIABLE DIMENSION FLAG.
*                       F.DIS = DOUBLE INTEGER SUBSCRIPT FLAG.
      SKP 
*    R = MISC FLAG
* 
*       BCOMI ENTRY:   WHETHER EMA OFFSET REFORMATTED YET.
*       DEF ENTRY:     FLAGS WHETHER GENERATED YET. 
*       SUBPRG ENTRY:  INDICATES HAS BEEN USED AS FUNCTION. 
* 
* 
*    S = SUBROUTINE FLAG. 
* 
*       SUBPRG ENTRY:  INDICATED HAS BEEN USED AS SUBROUTINE. 
* 
* 
*    E = MISC FLAG. 
* 
*       PASS 1:   EXPLICIT TYPING FLAG. 
*       PASS 2,3: REFERENCE FLAG. 
* 
* 
*   EM = EMA FLAG.                     NT = NAME TAG
* 
*       0: IN LOCAL MEMORY                 0: NAMED ITEM
*       1: IN EMA                          1: UNNAMED ITEM
      SPC 4 
*     SPECIAL NOTE ON ADDRESS TEMPS:
* 
*    NOTE: FOR ADDRESS TEMPS (F.IM=ADDR), IF A 'DEF' IS DONE TO THE 
*    TEMP, THE TEMP REPLACES THE DEF:  ITS F.AF IS SET TO THE ADDR
*    OF THE DEF.  IF WE ARE IN AN IMPLIED DO, THO, F.RPL IS RELATIVE
*    TO A TWPE ENTRY; IN THIS CASE, AN OFFSET MECHANISM IS USED:
*    F.AF IS SET TO THE F.A OF THE TWPE ENTRY + 100000B, AND WORD 2 IS
*    SET TO THE OFFSET.  WE MAY DESTROY WORD 2 AT WILL SINCE ADDRESS
*    TEMPS ARE RENAMED IN END.F ANYWAY.  NO ONE WILL FIND AT THE ENTRY
*    UNTIL END.F NOW, SINCE IT LOOKS LIKE A VARIABLE, AND ALL SEARCHING 
*    FOR THEM IS COMPLETED IN PASS ONE. 
* 
************************************************************************
* 
*   OBJECT CODE OR LOAD ADDRESS ENTRIES 
* 
*    0) IM: TWPE
*       AT: STR-ABS / REL 
*       IU: 0 
*       NT: 0 
* 
*    1) AF: REL ADDR IN PROGRAM  (0 IF UNDEF) 
* 
*    USED AS INTERNAL ADDRESS CONSTANTS OR HOLLERITH ADDRESSES. 
*    THE SPECIAL CASE OF HOLLERITH VS. END-OF-LOOP ADDRESS, WITHIN
*    A PARAM LIST, CAN BE DISTINGUISHED BY F.AT, WHICH IS REL FOR 
*    HOLLERITH (ALREADY DEFINED) OR STR-ABS FOR ADDRESSES.
      SKP 
************************************************************************
* 
*  VARIABLE NAMES:
* 
*    0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX 
*       AT: ABS,REL,STR-ABS,COM,BCOM,DUM
*       IU: VAR/CON,ARR   (ZERO IF NAME OF CURRENT PROGRAM) 
*        E: 1 IFF EXPLICITLY TYPED. 
*       EM: 0/1 FOR LOCAL/EMA 
*       NT: 0 
* 
*    1) AF: ADDRESS (AT=REL OR DUM),COMMON OFFSET (AT=COM)
*           POINTER TO DIM ENTRY (IU=ARR) (THIS BEFORE BCOM)
*           POINTER TO BCOMI ENTRY (AT=BCOM,IU#ARR) 
* 
*    2) WORDS 2-N: SYMBOL, 2 CHARS/WORD, PADDED WITH A BLANK IF REQ'D.
*       THE LAST CHARACTER (POSSIBLY BLANK) HAS BIT 7 = 1.
* 
************************************************************************
* 
*  MASTER OR LABEL ENTRY FOR LABELED COMMON 
*  OR SUBPROGRAM NAME ENTRY 
* 
*    0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX 
*       AT: BCOMI(COM), STR-ABS(EXT SUB), REL(STMT FCT), DUM(DUMMY SUB) 
*       IU: SUB 
*       EM: 0/1 AS LOCAL/EMA. 
*       NT: 0 
* 
*   1) AF: 0 OR - EXT ID NUMBER (BCOM MASTER OR EXT SUB). 
*          ADDRESS OF A TWO-WORD BLOCK CONTAINING THE ADDRESS OF THE
*            FUNCTION AND THE F.A OF THE FIRST FORMAL PARAM (IF ANY). 
*          REL ADDRESS OF DEF FOR DUMMY SUB.
* 
*   2) WORDS 2-N HAVE SYMBOL (SEE VARIABLES). 
* 
************************************************************************
* 
*   TEMPORARY VARABLES
* 
*    0) IM: INT,LOG,REA,DBL,CPX,ADDR,DBI,LO4,RE8,STR,ZPX
*       AT: REL 
*       IU: VAR/CON 
*       NT: 0 
* 
*    1) AF: REL ADDR OF TEMP
*           ( IF IM=ADDR, IS IM OF REFERENCED ITEM) 
* 
*    2) TEMP I.D.: <1> <IM> <SEQ#>, WHERE SEQ# IS IN [1,2047] 
* 
*    NOTE: SEE ABOVE FOR SPECIAL CONSIDERATIONS FOR ADDRESS TEMPS.
      SKP 
************************************************************************
* 
*  STATEMENT NUMBERS
* 
*    0) IM: 0 
*       AT: REL,STR-ABS 
*       IU: 0 
*       NC: TYPE: 0/2/3 = UNKNOWN/NON-FORMAT/FORMAT 
*       NT: 0 
* 
*    1) AF: PROGRAM ADDRESS OF STATEMENT (AT=REL) 
*           POINTER TO THIS ENTRY IF UNDEFINED  (AT=STR-ABS)
* 
*  2-N) ASCII STATEMENT #, PREFIXED BY '@', AS A SYMBOL.
* 
************************************************************************
* 
*  DIMENSION ENTRY
* 
*    0) IM: # OF DIMENSIONS, 1-7. 
*       AT: DIM 
*       IU: 0 
*       NC: F.VDM: 1 IFF VARIABLE DIMENSION(S). 
*           F.DIS: 1 IFF DOUBLE INTEGER DIMENSION(S).  (EMA ONLY) 
*       NT: 1 
* 
*    1) AF: ARRAYS ADDRESS (AT=REL,DUM) OR COMMON OFFSET (AT=COM) 
*           OR POINTER TO BCOMI ENTRY (AT=BCOM) 
*           (NOTE THESE AT'S ARE OF THE VARIABLE ENTRY, THIS AT IS DIM) 
* 
*    2) WORD 2:  F.A OF:  NON-FORMAL: CONSTANT OFFSET TO ELEMENT (0...0)
*                             FORMAL: DEF TO ELEMENT (0...0)
* 
*    3) WORDS 3 to 2*N+2:  LB1,UB1,...,LB7,UB7, LOWER & UPPER BOUNDS. 
*                          WHEN ENTRY CODE GENERATED, UPPER BOUNDS
*                          REPLACED BY DIMENSION SIZES. 
* 
************************************************************************
* 
*  BLOCK COMMON INFO. ENTRY 
* 
*    0) IM: 0 
*       AT: BCOMI 
*       IU: 0 
*       EM: 0/1 FOR LOCAL/EMA 
*       NT: 1 
* 
*    1) OFFSET FROM START OF BLOCK. 
*       EMA: LOWER BITS.
*       EMA FORMAL: F.A OF TEMP FOR BASE ADDR.  (REVERSED)
* 
*    2) F.A OF BLOCK NAME.
* 
*    3) EMA: UPPER BITS.
*       EMA FORMAL: F.A OF TEMP FOR ADDR OF (0,..,0). (DBL INT SUB ONLY)
      SKP 
************************************************************************
* 
*   CONSTANTS 
* 
*    0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX 
*       AT: REL,STR-ABS 
*       IU: VAR/CON 
*       NT: 1 
* 
************************************************************************
* 
*  DATA WITH OFFSET 
* 
*    0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX 
*       AT: REL,COM,BCOM
*       IU: ARR 
*       NT: 1 
* 
*    1) AF: F.A OF ITEM OFFSET IS FROM
* 
*    2) THE OFFSET
* 
************************************************************************
* 
*  DEF POINTERS 
* 
*    0) IM: 0 
*       AT: REL,COM,STR-ABS 
*       IU: VAR 
*        R: 1 IFF DEFINED 
*       NT: 1 
* 
*    1) AF: REL ADDR OF DEF  (* IF UNDEF) 
* 
*    2) + REL ADDR, CONTENTS OF DEF 
*       100000B + F.A OF ITEM DEF POINTS TO 
* 
************************************************************************
* 
*   DEF POINTERS (EXTERNAL WITH OFFSET) 
* 
*    0) IM: 0 
*       AT: BCOMI 
*       IU: VAR 
*        R: 1 IFF DEFINED 
*       NT: 1 
* 
*    1) AF: REL ADDR OF DEF  (* IF UNDEF) 
* 
*    2) OFFSET
* 
*    3) F.A OF ITEM WITH EXT I.D. 
      SKP 
************************************************************************
* 
*  CHARACTER ITEM EXTENSION.
* 
*    0) # CHARACTERS; 0 = DESCRIPTOR ONLY.
* 
*    1) REL ADDR OF DESCRIPTOR. 
* 
*    2) BYTE ADDR OF DATA, IF KNOWN.
      SKP 
*         ***************** 
*         * FETCH ASSIGNS * 
*         ***************** 
      SPC 1 
FA.F  NOP 
      LDB F.A 
      LDA B,I 
      AND B170K     170000B 
      STA F.IM      F.IM=IM(F.A)
      LDA B,I 
      AND B7000 
      STA F.AT      F.AT=AT(F.A)
      LDA B,I 
      AND B600
      STA F.IU      F.IU=IU(F.A)
      LDA B,I 
      AND B140
      STA F.NC      F.NC=NC(F.A)
      LDA B,I 
      AND B20 
      STA F.R       F.R=R(F.A)
      LDA B,I 
      AND B10 
      STA F..E      F..E=E(F.A) 
      LDA B,I 
      AND K4
      STA F.S       F.S=S(F.A)
      LDA B,I 
      AND K2
      STA F.EM      F.EM=EM(F.A)
      LDA B,I 
      AND K1
      STA F.NT      F.NT=NT(F.A)
      INB 
      LDA B,I       (A)=GF(F.A) 
      STA X5
      STA F.AF
      JSB NWE.F     # WDS PER ELEMENT.
      STB F.D0+1    F.D0=NO. OF WDS FOR THIS ITEM MODE
      CLA           CLEAR THE UPPER 
      STA F.D0      HALF OF THE DOUBLE WORD 
      LDA F.IU
      CPA ARR       ARRAY OR DATA WITH OFFSET ? 
      RSS 
      JMP FA02      NO. 
      LDA F.NT      YES. WHICH ?
      SZA 
      JMP FA03      DATA WITH OFFSET. 
      SKP 
*                   ARRAY. SET UP DIM ENTRY FIELDS. 
* 
      LDB X5        (B)=ADDR OF SUBSCRIPT INFO ENTRY
      LDA B,I 
      AND B20 
      STA F.R       F.R=R(X5) 
      LDA B,I 
      AND B100
      STA F.VDM     F.VDM=NC(X5), UPPER BIT.
      LDA B,I 
      AND B40 
      STA F.DIS     F.DIS=NC(X5), LOWER BIT.
      LDA B,I 
      AND B170K 
      ALF 
      STA F.ND      F.ND=IM(X5), (# OF DIMENSIONS)
      ADB K3
      STB F.LUB     F.LUB=ADDR BOUNDS LIST. 
* 
*                   SET UP F.AF = 2ND WD OF 1ST LINKED ENTRY, EXIT. 
* 
FA03  LDB X5
      INB 
      LDA B,I       (A)=GF(X5)
      STA F.AF
FA02  LDA F.A,I     IF STATEMENT FUNCTION,
      AND KK10      I.E. F.AT=REL AND F.IU=SUB, 
      LDB A         (WANT F.AF IN A-REG)
      LDA F.AF      (A)=F.AF FOR RETURN.
      CPB KK11      WELL ?
      LDA A,I       THEN SET F.AF TO THE REAL VALUE.
      STA F.AF      (NOP/CHANGE)
      LDB F.IM      CHARACTER STRING ?
      CPB CHAR
      RSS           (YES) 
      JMP FA.F,I    NO. EXIT. 
* 
      DLD A,I       YES. GET TRUE F.AF & LENGTH.
      STA F.AF      SET ADDR DESCRIPTOR,
      STB F.CSL     AND THE CHAR LENGTH.
      JMP FA.F,I    EXIT. 
* 
F..E  BSS 1 
F.EM  BSS 1         THE EMA FLAG. 
F.S   BSS 1         SUBROUTINE FLAG.
F.VDM BSS 1         VARIABLE DIMENSIONS FLAG. 
F.DIS BSS 1         DOUBLE INTEGER SUBSCRIPT FLAG.
F.LUB BSS 1         ADDRESS OF LUWER/UPPER BOUNDS TABLE.
F.CSL BSS 1         CHARACTER STRING LENGTH.
DUM   OCT 5000      AT=5
TWPE  OCT 40000 
CHAR  OCT 130000    F.IM=CHAR.
B100  OCT 100 
B200  OCT 200 
SUB   EQU B200      IU=1
REL   OCT 1000      AT=1
X5    BSS 1         ASSIGN TABLE POINTER FOR ARRAY .
B7000 OCT 7000      TO ENTRACT  AT  FIELD 
BCOMI EQU B7000 
B20   OCT 20
B140  OCT 140 
K8    DEC 8 
B10   EQU K8
KM2   DEC -2
KK10  OCT 007600    MASK OVER F.AT & F.IU 
KK11  OCT 001200    F.AT=REL & F.IU=SUB, STMT FCT.
F.IM  NOP           ITEM MODE: REAL, CPX, INT, ETC. 
F.IU  NOP           ITEM USAGE: DUMMY, RELATIVE, ETC. 
F.NC  NOP           NAME CHANGE FLAG
F.ND  NOP           # OF DIMENSIONS 
F.NT  NOP           NAME TAG: 0 IF VAR, 1 IF CONST
F.AT  NOP           ADDRESS TYPE
F.AF  NOP           ADDRESS FIELD 
F.R   NOP           MISC FLAG.
F.D0  NOP           WORDS/ARRAY ELEMENT 
      NOP           F.D0 IS A DOUBLE WORD 
      SPC 4 
*         ***************************** 
*         * DETERMINE S.T. ENTRY TYPE * 
*         ***************************** 
* 
*     ENTRY: F.IM, F.AT, F.IU, F.NT  SET UP.
*     EXIT:  (A)=F.STY = TYPE, IN RANGE [-2,3].   (B DESTROYED) 
* 
*     THE TYPES ARE:
* 
*        -2  DIMENSION OR BCOM OFFSET 
*        -1  TWPE 
*         0  ANY NAMED ITEM.
*         1  DATA WITH OFFSET.
*         2  CONSTANT.
*         3  DEF. 
* 
STY.F NOP 
      LDA KM2       (A=-2)
      LDB F.AT. 
      SZB 
      JMP STY01     F.AT. # 0:  -2
      CCA           (A=-1)
      LDB F.IM
      CPB TWPE
      JMP STY01     F.IM=TWPE:  -1
      LDA F.NT
      SZA,RSS 
      JMP STY01     F.NT=0:  0
      LDB F.IU      (A=1) 
      CPB ARR 
      JMP STY01     F.NT=1, F.IU=ARR:  1
      INA           (A=2) 
      LDB F.IM
      SZB,RSS       F.NT=1, F.IU#ARR, F.IM#0:  2
      INA           F.NT=1, F.IU#ARR, F.IM=0:  3
STY01 STA F.STY 
      JMP STY.F,I 
* 
F.STY NOP 
      SKP 
*         ********************* 
*         * MOVE NID TO F.IDI * 
*         ********************* 
      SPC 1 
*     ALSO SETS F.NWN = # WORDS IN SYMBOL.
      SPC 1 
NTI.F NOP 
      LDA NID+4     PACK 3RD WORD 
      ALF,ALF 
      IOR NID+5 
      STA F.IDI+2 
      LDB K3        ASSUME 3 WORDS. 
      CPA TWOBS     BLANKS ?
      LDB K2        YES, ONLY 2.
      STB F.NWN     TENTATIVE WORD COUNT. 
      LDA NID+2     PACK 2ND WORD 
      ALF,ALF 
      IOR NID+3 
      STA F.IDI+1 
      CLB,INB       B=1 
      CPA TWOBS     BLANKS ?
      STB F.NWN     YES, ONLY ONE WORD. 
      LDA NID       PACK 1ST WORD 
      ALF,ALF 
      IOR NID+1 
      STA F.IDI 
      JMP NTI.F,I 
      SPC 2 
NID   BSS 6 
F.DNI DEF NID 
F.NWN NOP           # WORDS IN PACKED NAME. 
TWOBS ASC 1,
      SKP 
*         ********************* 
*         * SET F.IDI TO ZERO * 
*         ********************* 
      SPC 1 
CDI.F NOP           SET F.IDI TO ZERO.
      CLA 
      STA F.IDI 
      STA F.IDI+1 
      STA F.IDI+3 
      STA F.IDI+2 
      STA F.IDI+4 
      JMP CDI.F,I 
      SPC 2 
*         *********************** 
*         * CLEAR NID TO BLANKS * 
*         *********************** 
      SPC 1 
BNI.F NOP 
      LDA B40 
      STA NID 
      STA NID+1 
      STA NID+2 
      STA NID+3 
      STA NID+4 
      STA NID+5 
      JMP BNI.F,I 
      SKP 
*         *************** 
*         * ASSIGN ITEM * 
*         *************** 
* 
*     SPECIAL ALGORITHM:  IN ORDER TO IMPLEMENT LOCAL SCOPE OF STATEMENT
*     FUNCTION FORMAL PARAMETERS, THEY ARE ATTACHED ONLY TO THE FUNCTION
*     ENTRY, THRU ITS F.AF .  WE ARE IN A STATEMENT FUNCTION WHEN F.SLF 
*     IS 2; IN THIS CASE, F.SFA IS THE F.A OF THE FUNCTION, WITH THE
*     SIGN BIT SET IF WE ARE DEFINING FORMAL PARAMETERS.  IF F.SLF#2, 
*     FA.F SETS F.SFA=0 TO SIMPLIFY TESTING.
*     NOW IF SEARCHING FOR A NAMED ITEM (TYPE 0), AND F.SFA#0:
* 
*     FIRST, SET T3AI=-1. 
* 
*     F.SFA<0: SEARCH NORMAL LIST, THEN:
* 
*              NO MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) 
*                            =0 : O.K.
*                 MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) 
*                                   (USE F.IM OF MATCHED ITEM)
*                            =0 : O.K. (ERROR, CAUGHT LATER.) 
* 
* 
*     F.SFA>0: SET LIST HEAD TO F.SFA+2, THEN:
* 
*              NO MATCH: T3AI=-1: T3AI_0; GO SEARCH NORMAL LIST.
*                            =0 : O.K.
*                 MATCH: T3AI=-1: O.K.
*                            =0 : O.K.
* 
*     STATEMENT FUNCTION FORMAL PARAMETERS ARE NEVER MOVED, 
*     ALWAYS INSERTED AT END OF LIST (INSTEAD OF AT START). 
* 
*     FOR NAMED ITEMS, IF F.IM=0, F.AT MUST BE BCOMI. (COMMON LABELS) 
      SPC 2 
*                   TEST FOR CASES WE DON'T SEARCH FOR. 
* 
AI.F  NOP 
      CLA           IF NOT STATEMENT FUNCTION,
      LDB F.SPF 
      CPB K3        (3=STMT FCT)
      RSS           (YES, LEAVE IT) 
      STA F.SFA     THEN CLEAR OUT THE FLAG.
      STA F.SFD     CLEAR THE STMT FCT DUMMY FLAG.
      LDA F.NT      IS ITEM A NAME? 
      IOR F.AT.     (DIM/BCOMI DON'T SET F.NT)
      SZA           I.E., F.NT=F.AT.=0 ?
      JMP AI03      NO. 
* 
      JSB NTI.F     YES, F.IDI=NID
      CCB           FIND LAST WORD OF NAME. 
      ADB F.NWN 
      ADB F.DID 
      LDA B,I       AND MARK IT.
      SSA,RSS       (UNLESS IT'S A CONSTANT ORDINAL)
      IOR B200      BY SETTING BIT 7. 
      STA B,I 
AI03  JSB STY.F     DETERMINE TYPE. 
      SSA           IS IT A SEARCHABLE TYPE ? 
      JMP AI50      NO. JUST GO ADD IT. 
* 
      LDA F.STY     YES. SET UP COMPARE ROUTINE ADDRESS.
      ADA DSTC
      LDA A,I 
      STA STC 
      JSB NWE.F     COMPUTE # WORDS (IN CASE CONSTANT). 
      STB F.D0+1    & SAVE.  (GARBAGE IS O.K.)
* 
*                   SET UP & PERFORM SEARCH.
*                   AT FIRST CUT, JUST COMPARE WORD 2 OF EACH.
* 
      CCA           SET T3AI=-1 IN CASE STMT FCT. 
      STA T3AI
      LDA F.STY     TYPE. 
      LDB F.SFA     STATEMENT FUNCTION INFO.
      CMB,SSB,INB,SZB  IF F.SFA>0,
      SZA           AND TYPE=0 (NAMED), 
      JMP AI04      (NO - NORMAL) 
* 
AI4A  LDA F.SFA     YES, STATEMENT FUNCTION EXPRESSION PART,
      RAL,CLE,ERA   (CLEAR POSSIBLE SIGN BIT) 
      INA           THE F.AF OF THE STMT FCT POINTS TO 2-WORD 
      LDA A,I       BLOCK, WITH 1ST WD = REL ADDR,
      ADA K2        2ND=LINK.  (A)=ADDR+1 OF LINK.
      RSS 
AI04  ADA DSTH      (A) = (ADDRESS OF PTR TO FIRST ENTRY)+1 
      STA F.A       USED TO EASILY INSERT FIRST ELEMENT.
      STA T4AI      (REMEMBER FOR LATER)
AI02  LDB F.IDI     (B) = FIRST WORD OF I.D. PART 
      LDA F.A       (A) = F.A+2 
      ADA K2
* 
AI022 ADA KM3       REMEMBER WHERE LINK OF LAST ONE WAS.
      STA T0AI      (MUCHO TIME SPENT IN THIS LOOP!)
      LDA A,I       LINK TO NEXT ENTRY. 
      SZA,RSS       END OF TABLE? 
      JMP AI120     YES, GO SET UP NEW SYMBOL.
* 
      ADA K2        NO, EASY CHECK, FIRST ID WORD.
      CPB A,I       & IF IT MATCHES THEN
      RSS           WORRY ABOUT MORE. 
      JMP AI022     ELSE IT WAS QUICK!
* 
      ADA KM2       SET UP CORRECT F.A
      STA F.A 
      JMP STC,I     GO TO TAILORED COMPARE ROUTINE. 
* 
*                   NEW ENTRY!!!
* 
AI120 LDA F.STY     GO TO UNIQUE INSERT CODE. 
      ADA DSTI
      LDA A,I 
      JMP A,I 
      SKP 
F.DP  NOP           ADDRESS OF USER A.T.
KM3   DEC -3
KK01  DEF 0,I 
K2    DEC 2 
F.S2B NOP           END OF A.T. 
F.A   NOP           A.T. CURRENT ADDRESS
F.SFA NOP           F.A OF STMT FCT, IF CURRENTLY IN ONE. 
STC   NOP 
T0AI  NOP 
T2AI  NOP 
T3AI  NOP 
T4AI  NOP 
* 
*                   LINKED LIST HEADS, COMPARE/INSERT ROUTINE ADDRESSES.
* 
DSTH  DEF *+2       LINKED LIST HEADS.
      NOP           NAMED ITEMS.
      NOP           DATA WITH OFFSET. 
      NOP           CONSTANTS.
      NOP           DEFS. 
* 
DSTC  DEF *+1       COMPARE ROUTINES. 
      DEF AI000     NAMED.
      DEF AI100     DATA WITH OFFSET. 
      DEF AI200     CONSTANTS.
      DEF AI300     DEFS. 
* 
DSTI  DEF *+1       INSERT ROUTINES.
      DEF AI050     NAMED.
      DEF AI150     DATA WITH OFFSET. 
      DEF AI250     CONSTANTS.
      DEF AI350     DEFS. 
      SPC 4 
*                   NAMED ITEM COMPARE. 
* 
AI000 LDA F.DID     GET THE ADDRESS OF WHAT WE WANT 
      STA T1AI      SET FOR LOOP
      LDB F.A       INDEX TO THE
      ADB K2        FIRST I.D. WORD.
* 
AI05  LDA B,I 
      CPA T1AI,I    MATCH??  (ALWAYS, FIRST TIME) 
      INB,RSS       YEP, STEP B TO NEXT WORD OF TABLE 
      JMP AI02      ID FIELD NOT MATCHED  REJECT THE ENTRY
      ISZ T1AI
      AND B15.7     IS THIS THE LAST WORD ? 
      SZA,RSS 
      JMP AI05      NO, TRY THE NEXT WORD.
* 
      LDA F.A,I     MATCH.  IS IT A COMMON LABEL ?
      AND B7000     I.E., IS F.AT=BCOMI ? 
      LDB F.LCF     AND LOOKING FOR ONE ? 
      CPA BCOMI     IF LOOKING & GOT IT,
      SZB,RSS 
      RSS           (NO)
      JMP AI06      THEN ACCEPT.
* 
      SZB,RSS       IF NOT LOOKING, 
      CPA BCOMI     AND DIDN'T GET IT,
      JMP AI02      (NO. REJECT)
* 
      LDA F.SFA     MATCH. IN STMT FCT FORMALS DEF ?
      SSA 
      JMP AI5A      YES.
* 
      SZA,RSS       NO. STMT FCT EXPRESSION PART ?
      JMP AI06      NO. 
* 
      LDA T4AI      YES. DID WE MATCH A STMT FCT FORMAL ? 
      CPA DSTH
      RSS           NO. 
      ISZ F.SFD     YES. SET FLAG.
      JMP AI06      DONE. 
* 
AI5A  LDA F.A,I     STMT FCT FORMALS DEF; 
      AND B170K     EXTRACT F.IM OF MATCHED ITEM. 
      STA F.IM
      LDA T4AI      WHICH LIST WERE WE SEARCHING ?
      CPA DSTH      WAS IT THE NAMED ITEM LIST ?
      JMP AI4A      YES. GO SEARCH THE FORMALS LIST NOW.
* 
      LDA K76       DOUBLE DEFINED FORMAL...
      JSB ER.F      DOWN THE TUBES... 
* 
K76   DEC 76
      SKP 
*                   NAMED ITEM MATCH.  TAG AS VARIABLE OR SUBROUTINE. 
* 
AI06  JSB FA.F      FETCH ASSIGN
      LDA F.NTF     NO TAG FLAG SET?
      SZA 
      JMP AI08      YES, DO NOT TAG ITEM
      LDA F.IU      F.IU FLAGGED? 
      SZA 
      JMP AI09      YES. CHECK FOR DUMMY ITEM 
      LDA F.SPF     CURRENT STATEMENT LEVEL 
      CPA K4
      RSS           EXECUTABLE STATEMENT
      JMP AI01      NO
* 
      LDA F.AT      YES 
      CPA DUM 
      JMP AI07      F.AT=DUM
* 
AI01  LDA F.SPF     SPEC STATEMENT? 
      SZA           (YES IF LEVEL 0 OR 1) 
      CPA K1        SPECIFICATION STATEMENT?
      JMP AI08      YES 
* 
AI07  LDA F.TC      F.TC=( ?
      CPA B50 
      JMP AI13      YES, SUBPROGRAM 
      JSB TV.F      NO, TAG VARIABLE
      JMP AI08      GO CLEAN UP & EXIT. 
AI09  CPA ARR 
      JMP AI08      DO NOT RE-TYPE DUMMY ARRAY
      CPA SUB 
      JMP AI08      DO NOT RE-TYPE DUMMY SUBPROG
      LDA F.AT
      CPA REL       F.AT=REL? 
      JMP AI08      YES 
      LDA F.IDI 
      SSA 
      JMP AI08      TEMP CELL 
      JMP AI01      TAG ITEM AS 'SUB' IF F.TC=( 
      SPC 1 
AI13  LDA F.DCF     DIM,COM,EQV FLAG SET? 
      SZA,RSS 
      JSB TS.F      NO. TAG SUBPROGRAM
      JMP AI08
      SKP 
*                   DATA WITH OFFSET COMPARE. 
* 
AI100 DLD F.A,I     (B) = F.AF
      LDA F.A,I 
      AND B170K     (A) = F.IM
      CPB F.AF      BOTH MUST MATCH.
      RSS 
      JMP AI02      NO. 
      CPA F.IM
      JMP AI10      YES. THAT'S IT. GO FA.F & EXIT. 
      JMP AI02      NO. 
* 
*                   CONSTANTS COMPARE.
* 
AI200 LDA F.A,I     F.IM MUST MATCH.
      AND B170K 
      CPA F.IM
      RSS 
      JMP AI02      NO. 
* 
      LDB F.D0+1    (# WDS, IN CASE NOT CHAR) 
      CPA CHAR      CHARACTER ? 
      RSS           (YES) 
      JMP AI202     NO. NORMAL. 
* 
      DLD F.A,I     (B) = EXTENSION ADDR. 
      DLD B,I       (B) = LENGTH. 
      CPB F.CSL     SAME AS WE'RE LOOKING FOR ? 
      RSS           (YES) 
      JMP AI02      NO. MISMATCH. 
* 
      INB           YES. ROUND UP TO WORD COUNT.
      CLE,ERB       (B) = # WORDS TO MATCH. 
AI202 CMB,INB       NEGATE LENGTH.
      STB T1AI      LOOP COUNTER. 
      LDA F.A       T2AI = S.T. ADDRESS.
      ADA K2
      STA T2AI
      LDB F.DID     (B) = F.IDI ADDRESS.
* 
AI201 LDA T2AI,I    S.T. WORD.
      CPA B,I       MATCH ?  (ALWAYS, FIRST TIME) 
      INB,RSS       YES. BUMP F.IDI PTR.
      JMP AI02      NO. 
      ISZ T2AI      BUMP S.T. PTR 
      ISZ T1AI      COUNT. DONE ? 
      JMP AI201     NO. 
      JMP AI10      YES. GO FA.F & EXIT.
* 
*                   'DEF' COMPARE.
* 
AI300 LDB F.AT      NORMAL OR EXT+OFFSET ?
      CPB BCOMI 
      JMP AI310     E+O, GO DO THAT.
* 
      LDA F.A,I     NORMAL. F.AT MUST MATCH.
      AND B7000 
      CPA F.AT
      JMP AI10      YES, GO FA.F & EXIT.
      JMP AI02      NO. 
* 
AI310 LDA F.A       E+O, OFFSET MUST MATCH. GET OFFSET BASE.
      ADA K3
      LDA A,I 
      CPA F.IDI+1   MATCH ? 
      JMP AI10      YES, GO FA.F & EXIT.
      JMP AI02      NO. 
      SKP 
*                   BUILD A BCOMI OR DIM ENTRY, UNLINKED. 
* 
AI50  INA,SZA,RSS   OR MAYBE TWPE ? 
      JMP AI52      YES.
* 
      CLA           DIM/BCOMI.  F.IU = 0. 
      STA F.IU
      CLA,INA       F.NT=1
      STA F.NT
      LDB F.AT.     WHICH IS IT ? 
      CPB BCOMI 
      JMP AI51      BCOMI.
* 
      LDA F.ND      DIM.  SET F.IM = # DIM. 
      RAR,RAR 
      RAR,RAR 
      IOR F.VDM     ALSO F.VDM, WHILE WE'RE AT IT.
      IOR F.DIS     AND  F.DIS
      STA F.IM
      LDB F.ND      NOW SET UP TOTAL # BOUNDS,
      BLS           TWO PER DIMENSION.
      STB T1AI      T1AI = NUMBER OF WORDS TO COPY. 
      ADB K3        ALLOW 3 MORE. 
      JSB AST.F     ALLOCATE THE SPACE. 
      STB F.A       F.A = TABLE ADDR. 
      STB F.AF      SET F.AF = F.A
      ADB K3        (B) = FWA DIMENSIONS. 
      LDA F.DID     (A) = SOURCE. 
      JSB .MVW
      DEF T1AI
      NOP 
      JMP AI53      GO SET F.AT=DIM, PACK & EXIT. 
* 
AI51  LDA F.EM      BCOMI. F.IM=0, BUT SET F.EM 
      STA F.IM
      LDB K3        NORMALLY USE 3 WORDS, 
      SZA           BUT IF EMA, 
      INB           USE 4.
      JSB AST.F 
      STB F.A       F.A = A.T. ADDR,
      STB F.AF      SET F.AF = F.A, 
AI53  LDA F.AT.     SET F.AT TO DIM/BCOMI,
      JMP AI14      PACK FIELDS & EXIT. 
* 
*                   BUILD A TWPE ENTRY, UNLINKED. 
* 
AI52  LDB K2        ALLOCATE TWO WORDS. 
      JSB AST.F 
      STB F.A       SET F.A = TABLE ADDR. 
      STB F.AF      SET F.AF=F.A
      JMP AI15      GO FINISH UP. 
* 
*                   NAMED SYMBOL INSERT.
* 
AI050 LDA F.SFA     NOT IN A STATEMENT FUNCTION 
      SZA           OR, 
      ISZ T3AI      ON SECOND PART OF STMT FCT SEARCH ? 
      JMP AI052     YES. INSERT NORMALLY. 
* 
      SSA           DEFINING THE FORMALS ?
      JMP AI4A      YES. GO LOOK IN FORMALS LIST NOW. 
* 
      CLA           NO. WASN'T FORMAL, MUST BE NORMAL VAR,
      JMP AI04      SO GO SEARCH THEM.
* 
AI052 LDB F.NWN     COMPUTE SYMBOL LENGTH IN WORDS + 3
      ADB K3
      JMP AI12      GO ALLOCATE, LINK, COPY SYMBOL & PACK FIELDS. 
* 
*                   INSERT CONSTANT.
* 
AI250 LDB F.D0+1    # WDS IN CONSTANT.
      LDA F.IM      CHARACTER ? 
      CPA CHAR
      RSS           (YES) 
      JMP AI252     NO. (B) = LENGTH. 
* 
      LDB F.CSL     YES. COMPUTE WORD LENGTH. 
      INB 
      CLE,ERB 
      LDA B         IS IT MORE THAT 10 WORDS ?
      ADA KM11
      SSA,RSS 
      CLB           YES. NOT KEPT WITH TABLE ENTRY. 
AI252 ADB K3        + 3 MORE. 
      JMP AI12      STANDARD STUFF. 
* 
*                   INSERT DEF OR DATA WITH OFFSET. 
* 
AI150 EQU * 
AI350 LDB K4        JUST STANDARD WITH 4 WORDS. 
      LDA F.AT      EXCEPT: DEF TO EXTERNAL WITH OFFSET.
      CPA BCOMI 
      INB           WHICH IS 5 WORDS. 
      SKP 
*                   ALLOCATE SPACE AND INSERT AT END OF LIST. 
*                   (MOVED TO BEGINNING LATER.) 
* 
AI12  STB T1AI      T1AI = # WORDS ALLOCATED. 
      JSB AST.F     ALLOCATE (B) WORDS. 
      STB F.A       SET LINK OF LAST ENTRY TO POINT HERE. 
      INB           (HASN'T BEEN BUMPED YET)
      STB T0AI,I    SET PREVIOUS LINK.
      CLB           SET NEW LINK TO ZERO. 
      STB F.A,I 
      ISZ F.A       (MOVE PAST LINK)
* 
*                   SET UP F.AF & COPY F.IDI INTO NEW ENTRY.
* 
      LDA F.IU      IF F.IU = SUB,
      LDB F.A 
      CPA SUB 
      CLB           SET F.AF=0
      STB F.AF      ELSE SET F.AF = F.A 
* 
      LDA T1AI      LENGTH IS T1AI-3
      ADA KM3 
      STA T1AI
      LDB K2        TO WORD 2 OF A.T. ENTRY.
      ADB F.A 
      LDA F.DID     FROM F.IDI
      JSB .MVW      DO IT.
      DEF T1AI
      NOP 
* 
*                   IF CHARACTER STRING, BUILD EXTENSION. 
* 
      LDA F.IM      WELL ?
      CPA CHAR
      RSS           (YES) 
      JMP AI15      NO. 
* 
      LDB K3        YES. 3-WORD EXTENSION.
      JSB AST.F 
      STB F.AF      LINKED THRU F.AF
      CLA           1ST WD = 0 (ADDR DESCRIPTOR). 
      STA B,I 
      INB 
      LDA F.CSL     2ND WD = F.CSL, LENGTH. 
      STA B,I 
      INB 
      CLA           3RD WD = 0 (BYTE ADDR OF DATA). 
      STA B,I 
* 
*                   SET UP F.AT, PACK FIELDS, AND EXIT. 
* 
AI15  LDA STRAB     (NORMAL F.AT=STRAB) 
* 
AI14  STA F.AT      ADDRESS TYPE
      IOR F.IM      ITEM MODE 
      IOR F.IU      ITEM USAGE
      IOR F.NT      NAME TAG
      LDB F.AF      (A,B) = WORDS 0,1 
      DST F.A,I     PUT 'EM AWAY. 
* 
      LDA F.NT      NAMED ? 
      SZA,RSS 
      JMP AI06      YES, MUST DETERMINE USAGE.
      JMP AI08      NO. ALL DONE. 
      SKP 
*                   DONE WITH SYMBOL.  IF IT'S A SEARCHABLE TYPE AND
*                   NOT A STATEMENT FUNCTION FORMAL, MOVE TO START. 
* 
AI10  JSB FA.F      FETCH ASSIGNS IF NOT ALREADY. 
AI08  LDA F.STY     TYPE. (B<0 IF NOT SEARCHABLE) 
      LDB T4AI      HEAD OF LAST LIST SEARCHED. 
      SZA,RSS       IF SYMBOL WAS NAMED,
      CPB DSTH      BUT NOT SEARCHING NAMED LIST, 
      SSA           OR NOT A SEARCHABLE TYPE, 
      JMP AI11      THEN DON'T MOVE TO START. 
* 
      CCB           NOW GET CURRENT ITEM'S LINK.
      ADB F.A 
      STB T1AI      (SAVE IT'S ADDR)
      LDB B,I       SET PREV LINK TO CURRENT, 
      STB T0AI,I    WHICH DELETES CURRENT ITEM. 
      CCB           COMPUTE ADDR OF LIST HEAD.
      ADB T4AI      IN B. 
      LDA B,I       GET HEAD OF THIS LIST.
      STA T1AI,I    SET INTO CURRENT LINK.
      LDA F.A       SET HEAD TO POINT TO THIS ITEM. 
      STA B,I 
* 
AI11  CLB           ZAP:
      STB F.NTF       NO TAG FLAG.
      STB F.AT.       SPECIAL DIM/BCOMI FLAG. 
      STB F.LCF       LABELLED COMMON FLAG. 
      LDA F.IM      (A) = F.IM
      JMP AI.F,I    EXIT. 
* 
F.NTF NOP           NON ZERO IF NOT TO BE TAGGED AS NAME
K4    DEC 4 
B50   OCT 50
K3    DEC 3 
B40   OCT 40
K32   EQU B40 
KM11  DEC -11 
T1AI  BSS 1         TEMP CELL 
F.EXF NOP           ENT FLAG
F.DCF NOP           DIM,COM FLAG
B15.7 OCT 100200    BITS 15 & 7 
      SKP 
*                   ALLOCATE SYMBOL TABLE SPACE.
*                   ALLOCATE (B) WORDS, RETURN (B)=START. 
* 
AST.F NOP 
      STB T1AST     SAVE SIZE.
      CMB           ALSO -1-SIZE. 
      STB T2AST 
      LDA F.LO      SET UP ADDR OF BLOCK. 
      STA T0AST 
      ADA T1AST     MOVE END OF A.T. OUT. 
      STA F.LO      NEW END OF A.T. = 
      STA F.S2B     NEW FWA OF STACK 2. 
      LDA F.S2T     OLD LWA OF STACK 2
      ADA T1AST     + SIZE OF BLOCK = 
      STA F.S2T     NEW LWA OF STACK 2. 
* 
*                   CHECK FOR MEM OFL.
* 
      LDA F.S1T     LWA FREE SPACE = FWA OF STACK 1,
      LDB F.SPF     UNLESS: SPECIFICATION LEVEL ? 
      SZB           I.E., F.SPF=0 
      CPB K1        OR 1 ?
      LDA F.E       YES, LWA FREE SPACE = FWA EQUIV TBL.
      CMA,INA 
      ADA F.S2T     (LWA STACK 2) - (LWA FREE SPACE)
      SSA,RSS       COLLISION ? 
      JMP F.OFE     YES, DATA POOL OVERFLOW.
* 
*                   MOVE STACK 2 UP IN MEMORY.
* 
      LDA F.S2T     START WITH NEW LWA+1 OF STACK 2.
      INA           (AS IF JUST STORED THERE) 
AST01 ADA T2AST     -1-SIZE BACKS UP TO NEXT ITEM.
      LDB A,I       GET DATA FROM OLD ADDR. 
      ADA T1AST     + SIZE = NEW ADDR IN STACK 2. 
      STB A,I       PUT IT THERE. 
      CPA F.S2B     DID WE JUST MOVE 1ST WD OF STACK 2 ?
      RSS           YES. THEN WE'RE DONE. 
      JMP AST01     NO. GO MOVE ANOTHER.
* 
      LDB T0AST     (B)=FWA OF ALLOCATED SPACE. 
      JMP AST.F,I   EXIT. 
* 
T0AST NOP           FWA OF ALLOCATED BLOCK. 
T1AST NOP           SIZE OF BLOCK.
T2AST NOP           -SIZE-1 OF BLOCK. 
      SKP 
*         ********************************
*         * (B)=NO. OF WORDS PER ELEMENT *
*         ********************************
      SPC 1 
NWE.F NOP 
      LDB F.IM      ITEM MODE.
      BLF           ALIGN.
      ADB DNWPE     GET FROM TABLE. 
      LDB B,I 
      JMP NWE.F,I 
* 
DNWPE DEF *+1       WORDS/ELEMENT TABLE, BY ITEM MODE.
      DEC 0         NONE:      0
      DEC 1         INTEGER:   1
      DEC 2         REAL:      2
      DEC 1         LOGICAL:   1
      DEC 1         TWPE:      1
      DEC 4         COMPLEX:   4
      DEC 3         EXTENDED:  3
      DEC 1         ADDRESS:   1
      DEC 2         DOUBLE INTEGER:   2 
      DEC 2         DOUBLE LOGICAL:   2 
      DEC 4         DOUBLE PRECISION: 4 
      DEC -1        CHARACTER:        SPECIAL 
      DEC 8         DOUBLE COMPLEX:   8 
      SKP 
*         ****************************************
*         * GET FIRST ASSIGNMENT POINTER (NAMES) *
*         ****************************************
      SPC 1 
*     EXIT: AFTER THE NEXT GNA.F CALL, (F.A) WILL POINT TO THE
*           FIRST A.T. NAME ENTRY (OR ZERO IF NONE).
      SPC 1 
GFA.F NOP 
      LDA DSTH      JUST SET F.A = DUMMY HEAD OF LIST.
      STA F.A 
      JMP GFA.F,I   EXIT
      SPC 3 
*         ********************************************
*         * GET FIRST ASSIGNMENT POINTER (CONSTANTS) *
*         ********************************************
      SPC 1 
GFC.F NOP 
      LDA DSTH      JUST SET F.A = DUMMY HEAD OF LIST.
      ADA K2
      STA F.A 
      JMP GFC.F,I   EXIT
      SPC 3 
*         ****************************************
*         * GET FIRST ASSIGNMENT POINTER (DEF'S) *
*         ****************************************
      SPC 1 
GFD.F NOP 
      LDA DSTH      JUST SET F.A = DUMMY HEAD OF LIST.
      ADA K3
      STA F.A 
      JMP GFD.F,I   EXIT
      SPC 3 
*         ******************************* 
*         * GET NEXT ASSIGNMEXT POINTER * 
*         ******************************* 
      SPC 1 
*     ENTRY: F.A=CURRENT POINTER TO ASSIGNMENT TABLE ENTRY
*     EXIT : (A)=F.A=POINTER TO NEXT ENTRY IN THE ASSIGNMENT TABLE
*            (A)=0 MEANS END REACHED. 
      SPC 1 
GNA.F NOP 
      CCA           BACK UP TO POINTER. 
      ADA F.A 
      LDA A,I 
      STA F.A       AND SET IT'S ADDRESS
      JMP GNA.F,I 
      SKP 
*         ******************* 
*         * DEFINE LOCATION * 
*         ******************* 
      SPC 1 
*     DEFINE:  AF(F.A)=RPL (PRESENT LOCATION COUNTER) 
*              F.AT(F.A)=REL
      SPC 1 
DL.F  NOP 
      LDA REL 
      JSB DAT.F     DEFINE AT 
      LDA F.RPL 
      JSB DAF.F     DEFINE F.AF 
      JMP DL.F,I
      SPC 1 
*         **************
*         * FETCH F.ID *
*         **************
      SPC 1 
*     COPY NAME FROM TABLE ENTRY TO NID IN A1 FORMAT. 
* 
FID.F NOP 
      JSB BNI.F     CLEAR NID TO BLANKS 
      LDA F.A,I     NAMED ? 
      SLA 
      JMP FID.F,I   NO. NO ID FIELD.
      LDA F.DNI     LOC. OF 1ST WD OF NID BUFFER
      STA T1FID 
      LDB F.A 
      ADB K2
FID02 LDA B,I 
      ALF,ALF 
      AND B177
      STA T1FID,I   STORE 1ST CHAR INTO NID BUFFER
      ISZ T1FID     BUMP NID BUFFER LOC BY 1
      LDA B,I 
      AND B177
      STA T1FID,I   STORE 2ND CHAR INTO NID BUFFER
      ISZ T1FID     BUMP NID BUFFER LOC 
      LDA B,I       END BIT SET ? 
      INB           BUMP ID FIELD LOC 
      AND B15.7     (IF ZERO, QUIT) 
      SZA,RSS       WELL ?
      JMP FID02     MORE TO DO. 
      JMP FID.F,I   DONE. 
* 
T1FID BSS 1         NID BUFFER POINTER
      SPC 1 
B177  OCT 177 
VAR   OCT 400       IU=2
      SKP 
*         ********************
*         * COPY SYMBOL NAME *
*         ********************
      SPC 1 
*     ENTRY:  JSB NAM.F   (F.A SET UP)
*             DEF <DEST>
*     EXIT:   3 WORDS COPIED. 
      SPC 1 
NAM.F NOP 
      JSB FID.F     COPY FROM A.T. ENTRY TO NID BUFFER. 
      JSB NTI.F     PACK IT.
      LDB NAM.F     GET & RESOLVE ADDRESS.
      ISZ NAM.F 
      LDB B,I 
      RBL,CLE,SLB,ERB 
      JMP *-2 
      LDA F.DID     SOURCE ADDR.
      JSB .MVW      MOVE 3 WORDS. 
      DEF K3
      NOP 
      JMP NAM.F,I   EXIT. 
      SKP 
*         ******************
*         * TAG SUBPROGRAM *
*         ******************
      SPC 1 
TS.F  NOP 
      LDA F.IU      ALREADY TAGGED 'VAR' ?
      CPA VAR 
      RSS           (YES) 
      JMP TS01      NO. 
* 
      LDB F.AT      YES. IS IT A FORMAL PARAM ? 
      CPB DUM 
      JMP TS03      YES. LEAVE ALONE. (ELSE ERROR)
* 
TS01  CPA SUB       OTHERWISE, MUST BE UNUSED OR SUB. 
      RSS 
      JSB NUTST     NO USAGE TEST 
* 
TS03  LDA SUB 
      JSB DIU.F     DEFINE F.IU AS SUBPROG
      LDA F.AT
      CPA DUM 
      JMP TS02      IT IS DUMMY 
* 
      JSB FA.F      FETCH ASSIGN
      LDA F.AT
      CPA REL 
      JMP TS.F,I    EXIT, SUB ALREADY DEFINED 
* 
      CLA           ELSE CLEAR THE F.AF FIELD SO THAT 
      LDB F.A       CAN TELL IT'S EXTERNAL SUB, NOT REF'D.
      INB 
      STA B,I       AF(F.A)=0 
      JMP TS.F,I
* 
TS02  LDA K22       FORMAL PARAM USED AS SUB: 
      LDB F.SFD     IS IT A STMT FCT FORMAL ? 
      SZB 
      JSB WAR.F     YES, DUMMY ARG SUBSCRIPTED IN ASF 
      JMP TS.F,I
* 
TSE22 LDA K22 
      JSB ER.F      VARIABLE RENAMED AS SUBROUTINE
      SPC 2 
K22   DEC 22
K47   DEC 47
B600  OCT 600 
ARR   EQU B600
B170K OCT 170000    (FOR F.IM)
F.SFD NOP           #0 IFF CURRENT ITEM IS STMT FCT FORMAL. 
      SKP 
      SPC 2 
*         *********** 
*         * F.TC TEST * 
*         *********** 
      SPC 1 
*     ENTRY: (A)=CORRECT TERMINATING CHAR.
      SPC 1 
TCT.F NOP 
      CPA F.TC
      JMP TCT.F,I   F.TC=(A),EXIT 
      LDA K28 
      JSB ER.F      IMPROPER TERMINATING CHARACTER
      SPC 2 
*         ********************* 
*         * NON-CONSTANT TEST * 
*         ********************* 
      SPC 1 
NCT.F NOP 
      LDA F.NT
      SZA,RSS 
      JMP NCT.F,I   EXIT, ITEM NOT A CONSTANT 
      LDA K24 
      JSB ER.F      CONSTANT MUST NOT BE PRESENT
      SPC 2 
*         **********************
*         * CHECK FOR CONSTANT *
*         **********************
      SPC 1 
*     INPUT:  (B)=F.A TO BE CHECKED.
*     OUTPUT: SKIP IF CONSTANT, AND: (B)=ADDR CONSTANT
*                                    (A)=FIRST WORD 
      SPC 1 
CFC.F NOP 
      SZB           IN REGISTER ? 
      CPB K1
      JMP CFC.F,I   YES, NOT CONSTANT.
      LDA B,I       F.NT & F.IM 
      SLA,RSS       NAMED ? 
      JMP CFC.F,I   YES, NOT CONSTANT.
      AND B170K     F.IM
      SZA,RSS       TYPED ? 
      JMP CFC.F,I   NO, NOT CONSTANT. 
      LDA B,I       GET F.IU
      AND B600
      CPA ARR       ARRAY ? 
      JMP CFC.F,I   YES, NOT CONSTANT. (DATA WITH OFFSET) 
      ISZ CFC.F     ELSE CONSTANT.
      ADB K2        IF CONST, ITS ADDR. 
      LDA B,I       IF CONST, ITS FIRST WORD. 
      JMP CFC.F,I 
      SKP 
*         *********************** 
*         * NON-SUBROUTINE TEST * 
*         *********************** 
      SPC 1 
NST.F NOP 
      LDA K25 
      LDB F.IU
      CPB SUB 
      JSB ER.F      SUBPROGRAM NAME NOT ALLOWED 
      JMP NST.F,I   EXIT
      SPC 2 
*         ****************
*         * NON-EMA TEST *
*         ****************
      SPC 1 
NET.F NOP 
      LDB F.EM
      LDA K47 
      SZB           WELL ?
      JSB ER.F      EMA: ERROR 47.
      JMP NET.F,I   ELSE DONE.
      SPC 2 
*         ****************
*         * INTEGER TEST *
*         ****************
      SPC 1 
ITS.F NOP 
      LDA F.IM      F.IM=INTEGER? 
      CPA INT 
      RSS           YES, O.K. 
      CPA DBI       OR DOUBLE INTEGER ? 
      JMP ITS.F,I   YES, ALSO O.K.  EXIT. 
* 
      LDA K26       NO
      JSB ER.F      ITEM NOT AN INTEGER 
* 
DBI   OCT 100000
      SPC 2 
*         ***************** 
*         * NO USAGE TEST * 
*         ***************** 
      SPC 1 
NUTST NOP 
      LDA F.IU      IS ITEM NAME ALREADY USED?
      SZA,RSS 
      JMP NUTST,I   NO, EXIT
      LDA K22       YES, NAME ALREADY BEING USED
      JSB ER.F
      SPC 2 
INT   OCT 10000     IM=1 INTEGER
K24   DEC 24
K25   DEC 25
K26   DEC 26
K28   DEC 28
      SPC 2 
*         ****************
*         * TAG VARIABLE *
*         ****************
      SPC 1 
TV.F  NOP 
      LDA F.IU
      CPA VAR 
      RSS 
      JSB NUTST     NO USAGE TEST 
      LDA VAR 
      JSB DIU.F     DEFINE F.IU 
      JMP TV.F,I
      SPC 2 
*         ************* 
*         * DEFINE F.IM * 
*         ************* 
      SPC 1 
*     ENTRY: (A)=NEW ITEM MODE
      SPC 1 
DIM.F NOP 
      STA F.IM      F.IM=(A)
      LDA F.A,I 
      AND KK15      =B007777
      IOR F.IM
      STA F.A,I      IM(F.A)=F.IM 
      JMP DIM.F,I 
      SPC 2 
*         **********************
*         * ESTABLISH CONSTANT *
*         **********************
      SPC 1 
*     INPUT: (A)=MODE OF ITEM 
      SPC 1 
ESC.F NOP 
      STA F.IM
      CLA,INA 
      STA F.NT      F.NT=1 FOR CONSTANT 
      LDA VAR 
      STA F.IU      SET F.IU=VAR
      JMP ESC.F,I   EXIT
      SPC 2 
*         ******************************
*         * ESTABLISH INTEGER CONSTANT *
*         ******************************
      SPC 1 
*     INPUT:  (A)=CONSTANT. 
*     OUTPUT: (A)=F.A OF CONSTANT.
      SPC 1 
EIC.F NOP 
      STA F.IDI     VALUE.
      LDA INT       ESTABLISH IT. 
      JSB ESC.F 
      JSB AI.F      ENTER IN A.T. 
      LDA F.A       RETURN (A)=F.A
      JMP EIC.F,I 
      SPC 2 
*         ************************************* 
*         * ESTABLISH DOUBLE INTEGER CONSTANT * 
*         ************************************* 
      SPC 1 
*     INPUT:  (A,B)=CONSTANT. 
*     OUTPUT: (A)=F.A OF CONSTANT.
      SPC 1 
EJC.F NOP 
      DST F.IDI     VALUE.
      LDA DBI       ESTABLISH IT. 
      JSB ESC.F 
      JSB AI.F      ENTER IN A.T. 
      LDA F.A       RETURN (A)=F.A
      JMP EJC.F,I 
      SKP 
*                   ****************
*                   ESTABLISH DEF  *
*                   ****************
* 
*     THIS ROUTINE ESTABLISHES A 3 OR 4 WORD ASSIGNMENT TABEL ENTRY 
*     WHICH IF REFERENCED WILL CAUSE A DEF TO BE GENERATED -- 
*     EITHER ALONG THE WAY OR AT THE END OF THE CODE GENERATION.
* 
*     CALLING SEQUENCE: 
* 
*     LDA OFFSET    (ONLY ZERO ALLOWED IF ENTRY IS UNDEFINED) 
*     LDB F.A       POINTER TO ASSIGNMENT TABEL ENTRY TO BE DEFED 
*     JSB ESD.F 
*     RETURN  A=0 
* 
ESD.F NOP 
      STA T1ESD     SAVE THE OFFSET 
      STB F.A       AND THE A.T. ADDR.
      JSB FA.F      FETCH THE ASSIGNS.
      LDA F.AT      GET LOCATION INFO 
      LDB F.AF      ADDRESS TO B
      CPA BCOM      LABELED COMMON REFERENCE? 
      JMP ESD02     YES DO SPECIAL
* 
      ADB T1ESD     ADD THE OFFSET
      CPB F.AF      IF OFFSET IS ZERO 
      JMP ESD03     THEN USE A POINTER INSTEAD. 
* 
      ADB K8        SEE IF TOO NEGATIVE FOR SIMPLE. 
      SSB,RSS 
      JMP ESD04     NO. USE SIMPLE DEF. 
* 
      LDA T1ESD     YES. DATA WITH OFFSET: (A)=OFFSET,
      LDB F.A       (B)=BASE F.A
      JSB EDO.F     WHICH CAN TAKE A FULL-WORD OFFSET.
ESD03 LDB F.A       AT THIS POINT, OFFSET = 0.
      ADB KK01      SO GENERATE A S.T. REF. 
      RSS 
ESD04 ADB KM8       DIRECT REF, RESTORE ADDRESS.
      LDA F.AT      CHECK ADDR TYPE:
      CPA COM       IF IN COMMON
      RSS 
      LDA STRAB     USE COM ELSE USE STR-ABS FOR AT 
      STB F.IDI     SET VALUE NEEDED
* 
ESD01 STA F.AT      SET UP F.AT FOR SEARCH, 
      STA T1ESD     AND SAVE FOR LATER (AI.F CHANGES IT)
      CLA           ESTABLISH CONSTANT
      JSB ESC.F     NT=0  IM=0  IU=VAR
      JSB AI.F      ASSIGN ITEM 
      LDA T1ESD     RESTORE F.AT
      JSB DAT.F 
      CLA           CLEAR A AND 
      JMP ESD.F,I   RETURN
* 
ESD02 LDB F.A       IN LABELLED COMMON, 
      LDA T1ESD     CAN TRY TO REMOVE DATA WITH OFFSET. 
      JSB CDO.F 
      STA T1ESD     OLD OR REVISED OFFSET.
      LDB F.AF      F.A OF BCOMI ENTRY. 
      INB 
      DLD B,I       GET THE OFFSET AND F.A OF 
      ADA T1ESD     THE MASTER  ADD THE OFFSET
      DST F.IDI     STOR FOR THE NEW ID 
      LDA BCOMI     SET REQUIRED F.AT 
      JMP ESD01     GO FINISH 
* 
T1ESD NOP 
COM   OCT 4000      F.AT=COM
BCOM  OCT 3000
STRAB OCT 2000
KM8   DEC -8
      SKP 
*         ******************************
*         * ESTABLISH DATA WITH OFFSET *
*         ******************************
      SPC 1 
*     ENTRY: AS ESD.F, AND F.IM = TYPE OF NEW ITEM. 
* 
EDO.F NOP 
      STA T1EDO     SAVE OFFSET, WHILE
      LDA F.IM      SAVE TYPE OF RESULT.
      STA T2EDO 
      LDA T1EDO     RESTORE OFFSET, 
      JSB CDO.F     AND RESOLVE DATA WITH OFFSET. 
      STB T1EDO     T1EDO=F.A=F.A OF MASTER.
* 
      LDB T2EDO     F.IM OF NEW. IF TYPES MATCH,
      CPB F.IM
      SZA           AND THE OFFSET IS ZERO, 
      RSS           (NO)
      JMP EDO.F,I   THEN USE THE MASTER ITSELF. 
* 
      STA F.IDI     ELSE CREATE NEW.   F.IDI=OFFSET,
      STB F.IM      F.IM=TYPE,
      CLA,INA       F.NT=1
      STA F.NT
      LDA ARR       F.IU=ARR
      STA F.IU
      CLA           SET F.AT=0 (JUST IN CASE) 
      STA F.AT
      LDA T1EDO     F.AF = F.A OF MASTER. (FOR COMPARE) 
      STA F.AF
      JSB AI.F      ENTER.
      LDA T1EDO,I   EXTRACT F.AT OF MASTER. 
      AND B7000 
      JSB DAT.F     AND SET THAT FOR NEW ENTRY. 
      LDB F.A       SET F.AF TO F.A OF MASTER.
      INB 
      LDA T1EDO 
      STA B,I 
      JMP EDO.F,I   EXIT. 
      SPC 1 
T1EDO NOP 
T2EDO NOP 
      SKP 
*         ****************************
*         * RESOLVE DATA WITH OFFSET *
*         ****************************
      SPC 1 
*     ENTRY: (A) = ADDITIONAL OFFSET. 
*            (B) = F.A, POSSIBLY DATA WITH OFFSET.
* 
*     EXIT:  (A) = TOTAL OFFSET.
*            (B) = F.A = NON-OFFSET F.A 
*     AND ASSIGNS OF (B) FETCHED. 
* 
CDO.F NOP 
      STB F.A       SET UP F.A, 
      STA T1CDO     AND REMEMBER OFFSET.
      JSB FA.F      FETCH ASSIGNS.
      JSB STY.F     IS THE MASTER A DATA WITH OFFSET ?
      CPA K1
      RSS 
      JMP CDO01     NO. 
* 
      ISZ F.A       YES. FETCH: 
      DLD F.A,I     THE F.A OF THE MASTER & THE OFFSET. 
      STA F.A       REPLACE ITEM WITH THE MASTER. 
      ADB T1CDO     ADD OFFSET TO INPUT OFFSET. 
      STB T1CDO 
      JSB FA.F      FETCH ITS ASSIGNS FOR BELOW.
CDO01 LDA T1CDO     RETURN (A) = TOTAL OFFSET,
      LDB F.A       (B) = F.A 
      JMP CDO.F,I   EXIT. 
* 
T1CDO NOP           OFFSET. 
      SKP 
*         ************* 
*         * DEFINE F.IU * 
*         ************* 
      SPC 1 
*     ENTRY: (A)=NEW F.IU (SUBR, VAR, OR 0) 
      SPC 1 
DIU.F NOP 
      STA F.IU      F.IU=(A)
      LDA F.A,I 
      AND KK16      =B177177
      IOR F.IU
      STA F.A,I      IU(F.A)=F.IU 
      JMP DIU.F,I 
* 
KK15  OCT 007777
KK16  OCT 177177
KK17  OCT 170777
      SPC 2 
*         ************* 
*         * DEFINE F.AT * 
*         ************* 
      SPC 1 
*     ENTRY: (A)=NEW AT(F.A)
      SPC 1 
DAT.F NOP 
      STA F.AT      F.AT=(A)
      LDA F.A,I 
      AND KK17      =B170777
      IOR F.AT
      STA F.A,I 
      JMP DAT.F,I 
      SPC 2 
*         ***************** 
*         * DEFINE F.EM=1 * 
*         ***************** 
      SPC 1 
DEM.F NOP 
      LDA K2        JUST SET IT.
      STA F.EM
      IOR F.A,I 
      STA F.A,I 
      JMP DEM.F,I   EXIT. 
      SPC 2 
*         ****************
*         * DEFINE F.S=1 *
*         ****************
      SPC 1 
DS.F  NOP 
      LDA K4        JUST SET IT.
      STA F.S 
      IOR F.A,I 
      STA F.A,I 
      JMP DS.F,I    EXIT. 
      SKP 
*         ************* 
*         * DEFINE AF * 
*         ************* 
      SPC 1 
*     ENTRY: (A)=NEW F.AF 
      SPC 1 
DAF.F NOP 
      STA F.AF      F.AF=(A)
      LDB F.A 
      LDA B,I 
      AND B600      GET F.IU FIELD
      CPA ARR 
      JSB DAF.G     IU(F.A)=ARR 
      LDA F.A,I     TEST IF LABELED COMMON
      AND B7000 
      CPA BCOM      WELL? 
      JSB DAF.G     YES INDEX TO THE INFO ENTRY 
      LDA F.IM      IF CHARACTER, 
      CPA CHAR
      JSB DAF.G     ALSO GO TO NEXT ENTRY,
      CPA CHAR
      RSS           BUT USE FIRST WORD. 
      INB           POINT TO 2ND WD OF THIS ENTRY.
      LDA F.AF      GET THE VALUE 
      STA B,I       STORE IT
      JMP DAF.F,I   RETURN
      SPC 1 
DAF.G NOP 
      INB 
      LDB B,I       (B)=GF(F.A) 
      JMP DAF.G,I 
      SPC 2 
*         **************************
*         * CHECK STATEMENT NUMBER *
*         **************************
      SPC 1 
CSN.F NOP 
      AND B40       BIT 5 = TYPE BIT. 
      XOR B,I       SET TYPE BIT OR CHECK IT. 
      ALF,ALF       CHECK DEFINED FLAG. 
      CCE           (SET DEFINE BIT)
      RAL,ELA       E = DEFINE BIT. 
      ALF,RAL       RESTORE POSITION. 
      RAL 
      SEZ,RSS       WAS IT DEFINED ?
      STA B,I       NO. SET TYPE & DEFINE BIT.
      AND B40       GET TYPE DIFFERENCE (IF WAS DEF)
      SEZ           IF NEW DEFINITION 
      SZA,RSS       OR OLD BUT SAME TYPE
      JMP CSN.F,I   THEN O.K., SO EXIT. 
      LDA K32       ELSE ERROR 32.
      JSB ER.F
      SKP 
*         ******************
*         * FETCH CONSTANT *
*         ******************
      SPC 1 
FC.F  NOP 
      JSB CDI.F     CLEAR F.IDI BUFFER TO 0 
      JSB NWE.F     (B) = # WDS IN CONSTANT.
      STB T1FC
      LDA F.A       FROM A.T. ENTRY WORD 2
      ADA K2
      LDB F.DID     TO F.IDI
      JSB .MVW
      DEF T1FC
      NOP 
      JMP FC.F,I    EXIT. 
* 
T1FC  NOP           # WORDS TO MOVE.
      SKP 
*     ************************************
*     * F.D0 := NUMBER OF WORDS FOR ITEM *
*     ************************************
      SPC 1 
*     AT THIS POINT, RCO.F MUST HAVE BEEN CALLED.  IT HAS CHANGED 
*     THE UPPER BOUNDS INTO THE DIMENSION SIZES (FOR NON-FORMAL ARRAYS).
* 
NWI.F NOP 
      LDA F.IU
      CPA ARR 
      RSS 
      JMP NWI.F,I 
* 
      LDA F.ND      SET UP COUNTER. 
      CMA,INA 
      STA T1NWI 
      LDA F.LUB     SET UP POINTER INTO BOUNDS TABLE. 
      STA T2NWI 
* 
*                   LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, 
*                   MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). 
* 
NWI01 ISZ T2NWI     SKIP LOWER BOUND. 
      LDB T2NWI,I   GET UPPER BOUND.
      ISZ T2NWI     (SKIP IT) 
      JSB GCD.F 
      JMP RPLOV     SOMEONE GOOFED! 
* 
      SSA           DID SOMETHING GO WRONG ?
      JMP RPLOV     YES.
* 
      JSB DMP.F     MULTIPLY & REPLACE RUNNING PRODUCT. 
      DEF F.D0
      JMP RPLOV     OFL.
* 
      DST F.D0
      ISZ T1NWI     INCR LOOP COUNTER. MORE ? 
      JMP NWI01     YES. DO IT. 
      JMP NWI.F,I   NO. ALL DONE. (A,B) = PRODUCT.
      SKP 
RPLOV LDA K84       OFL IN SIZE CALC.  CATASTROPHE! 
      JMP F.ABT 
* 
T1NWI NOP           LOOP COUNTER. 
T2NWI NOP           BOUNDS TABLE POINTER. 
K84   DEC 84
      SKP 
*         **************************
*         * GET CONSTANT DIMENSION *
*         **************************
      SPC 1 
*     ENTRY: (B) = F.A OF CONSTANT. (MUST BE INT*2 OR INT*4)
*     EXIT:  (A,B) = DOUBLE INTEGER VALUE OF CONSTANT.
*            RETURNS TO (P+1) IF NOT CONSTANT. (A,B) GARBAGE. 
*                       (P+2) IF CONSTANT.
* 
GCD.F NOP 
      STB T1GCD     SAVE F.A IN QUESTION. 
      JSB CFC.F     CONSTANT ?
      JMP GCD.F,I   NO. FORGET IT.
* 
      ISZ GCD.F     YES. BUMP RETURN. 
      LDB T1GCD     RESTORE F.A 
      LDA B,I       (A) = 1ST WD A.T. ENTRY:
      ELA           E=1 IFF INT*4 . 
      ADB K2        GET CONSTANT. 
      DLD B,I       IF INT*4, THAT'S ALL. 
      SEZ           WELL ?
      JMP GCD.F,I   YES. DONE.
* 
      LDB A         INT*2. CONVERT IT.
      ASR 16
      SWP 
      JMP GCD.F,I   DONE. 
* 
T1GCD NOP 
      SKP 
*         ********************************* 
*         * DOUBLE INTEGER ADD (INTERNAL) * 
*         ********************************* 
      SPC 1 
*     CALLING SEQUENCE:  DLD <ARG1> 
*                        JSB DAD.F
*                        DEF <ARG2> 
*                        --> OVERFLOW OCCURED. (A,B)=LEAST 32 BITS. 
*                        --> NO OVERFLOW. (A,B)=SUM.
* 
DAD.F NOP 
      DST T1DAD     SAVE ARG1.
      LDA DAD.F,I   GET ARG2. 
      ISZ DAD.F 
      DLD A,I 
      CLE           ADD LOWERS. 
      ADB T1DAD+1 
      CLO           PROPOGATE CARRY.  DON'T WORRY ABOUT 
      SEZ           THE CASE: ARG2U=32767, CARRY, AND 
      INA           ARG1U<0, EVEN THOUGH IT'S A SPURIOUS
      ADA T1DAD     (ADD UPPERS)    OVERFLOW. 
      SOS           OVERFLOW ?
      ISZ DAD.F     NO. NORMAL RETURN.
      JMP DAD.F,I   EXIT. 
* 
T0DAD BSS 1 
T1DAD BSS 2         ARG1. 
T2DAD BSS 2         ARG2. 
      SPC 2 
*         **************************************
*         * DOUBLE INTEGER SUBTRACT (INTERNAL) *
*         **************************************
      SPC 1 
DSB.F NOP 
      STA T1DAD     SAVE (A) WHILE... 
      LDA DSB.F,I   GET ARG2 ADDR.
      ISZ DSB.F 
      STA DSB01     & PUT IN DAD.F CALL.
      LDA T1DAD     RESTORE (A),
      CMA           COMPLEMENT (A,B), 
      CMB 
      JSB DAD.F     SUBTRACT ARG2,
DSB01 DEF *-* 
      JMP DSB.F,I   (IF OFL)
* 
      CMA           AND COMPLEMENT AGAIN. 
      CMB 
      ISZ DSB.F     TAKE GOOD RETURN. 
      JMP DSB.F,I 
      SKP 
*         **************************************
*         * DOUBLE INTEGER MULTIPLY (INTERNAL) *
*         **************************************
      SPC 1 
*     CALLING SEQUENCE:  DLD <ARG1> 
*                        JSB DMP.F
*                        DEF <ARG2> 
*                        --> OVERFLOW.  (A,B)=LEAST 32 BITS.
*                        --> NO OVERFLOW.  (A,B)=RESULT.
* 
*     NOTE: IF EITHER ARGUMENT IS NEGATIVE, OVERFLOW WILL BE
*           SET, BUT THE RESULT WILL BE THE CORRECT LEAST 32 BITS.
* 
*     ALGORITHMIC NOTE:  SINCE OVERFLOW IS EXPLICITLY SET WHEN EITHER 
*     OF THE ARGUMENTS IS NEGATIVE, THE CROSS-PRODUCTS CAN BE TAKEN 
*     WITHOUT SIGN CORRECTION:  IN XU*YL: 
*           XU<0: OFL ALREADY SET.
*           XU=0: RESULT ZERO ANYWAY. 
*           XU>0, YL<0: SIGNIFICANT BITS OCCUR IN THE UPPER WORD OF THE 
*                       CROSS-PRODUCT, BUT WILL BE CAUGHT BY THE FACT 
*                       THAT THE CROSS-PRODUCT IS NEGATIVE. 
*     OF COURSE, THE UPPER WORD OF THE CROSS-PRODUCT IS ONLY NEEDED 
*     TO DETECT OVERFLOW ANYWAY, AND SIGN CORRECTION AFFECT ONLY THE
*     UPPER WORD. 
* 
DMP.F NOP 
      DST T1DAD     SAVE ARG1.
      CLB           INITIALIZE OVERFLOW FLAG: 
      RRL 1         (B) = 1 IF ARG1<0, ELSE 0.
      STB T0DAD 
      LDA DMP.F,I   GET ARG2. 
      ISZ DMP.F 
      DLD A,I 
      STB T2DAD+1   (DON'T NEED ARG2U AGAIN)
      SSA           IF ARG2<0,
      ISZ T0DAD     SET THE OVERFLOW FLAG.
      LDB T1DAD     ARE BOTH UPPER WORDS NONZERO ?
      SZA 
      SZB,RSS 
      RSS           NO. THEIR PRODUCT IS ZERO.
      ISZ T0DAD     YES.  RESULT UNCHANGED, BUT OFL.
* 
      MPY T1DAD+1   YU*XL 
      SZB,RSS       TOO BIG ? 
      SSA 
      ISZ T0DAD     YES. SET OFL. 
      STA T2DAD     SAVE LSB (FIRST CROSS-PRODUCT)
* 
      LDA T2DAD+1   DO YL*XU
      MPY T1DAD 
      SZB,RSS       TOO BIG ? 
      SSA 
      ISZ T0DAD     YES, SET OFL. 
      ADA T2DAD     ADD FIRST CROSS-PRODUCT.
      SSA           IF TOO BIG, 
      ISZ T0DAD     SET OFL.
      STA T2DAD     SAVE SUM OF CROSS-PRODUCTS. 
* 
      LDA T2DAD+1   DO YL*XL. 
      MPY T1DAD+1 
      STA T1DAD     SAVE LOWER PART.
      LDA T2DAD+1   CORRECT FOR XL<15>. 
      SSA 
      ADB T1DAD+1 
      LDA T1DAD+1   CORRECT FOR YL<15>. 
      SSA 
      ADB T2DAD+1 
      SSB           TOO BIG ? 
      ISZ T0DAD     IF SO, SET OFL. 
* 
      ADB T2DAD     ADD CROSS-PRODUCTS. 
      SSB           IF TOO BIG, 
      ISZ T0DAD     SET OFL.
      LDA T0DAD     IF OFL NEVER OCCURED, 
      SZA,RSS 
      ISZ DMP.F     SKIP ERROR RETURN.
      LDA B         (A) = UPPER RESULT. 
      LDB T1DAD     (B) = LOWER RESULT. 
      JMP DMP.F,I   EXIT. 
      END 
ASMB,Q,C
      HED GLOBALS & INITIALIZATION FOR IC.F 
      NAM IN6.F,8 92834-16002 REV.2030 800226 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE CONTAINS THOSE DATA ITEMS REFERENCED IN IC.F WHICH
*     MUST BE PRESERVED THROUGHOUT PASS ONE, EVEN THOUGH SEGMENT LOADS
*     OCCUR.  THEY ARE REFERENCED BY OFFSET FROM THE SYMBOL: F.$IC
* 
*     SINCE THEY MUST BE INITIALIZED ONLY ONCE PER MODULE, THE
*     INITIALIZATION ROUTINE IS ALSO LOCATED HERE: IN6.F
* 
      ENT F.$IC     BASE OF GLOBALS.
      ENT F.NXN     NO INPUT FLAG.
      ENT F.TC      LAST CHARACTER READ.
      ENT F.NCR     NO-CROSS-REFERENCE FLAG.
* 
      ENT IN6.F     IC.F INITIALIZATION.
* 
* 
* 
A     EQU 0 
B     EQU 1 
      SUP 
      SPC 2 
*     THE FORMAT OF A CARD BUFFER IS: 
* 
*     WORDS   0-2: ROOM FOR LINE # FOR LISTING. 
*            3-43: UP TO 82 CHARACTERS (ROOM TO ADD BLANK AFTER 72) 
*              44: LENGTH, IN WORDS.
*              45: CLIB LINE #. 
*           46-48: LEFT OVER, NOT CURRENTLY USED. 
*          -------- 
*       TOTAL: 49 WORDS.
      SKP 
*                   INITIALIZE IC.F 
* 
IN6.F NOP 
      STB CRD#1     SET CARD BUFFER POINTER 
      ADB K49       FOR BOTH BUFFERS
      STB CRD#2 
      SSA           IF CALL JUST TO MOVE THE CARD BUFFERS 
      JMP IN6.1     SKIP UNRELATED GARBAGE
* 
      CLB,SEZ,INB,RSS IF A NEW COMPILE
      JMP NOTNW     NO
* 
      STB FTNF      SET THE FTN FLAG
      CLA           ALSO ITS
      STA CD#F      LENGTH, 
      STA CD#P      AND SIZE. 
      STA CD#1      AND CLEAR THE LOCAL CARD BUFFERS
      STA CD#2      ALSO SET
NOTNW CLA           CLEAR THE NO. CARDS IN
      STA FIRST     SET FIRST FLAG
IN6.1 CLA           ENTRY FOR BUFFER MOVE ONLY
      STA CD#       TO ZERO 
      LDB DCD#1     SET UP BUFFER 
      JSB SETCA     NO. ONE INCASE SNC.F CALLED FIRST 
      CLA,INA 
      STA LIFCC     INITIAL COLUMN COUNTER
      JMP IN6.F,I   RETURN
* 
DCD#1 DEF CRD#1     DEF TO CARD BUFFER ADDRESSES
K49   DEC 49
      SKP 
*                   GLOBALS.
* 
F.$IC EQU *         BASE ADDR. GLOBALS REF'D BY OFFSET. 
* 
EOSF  NOP           END-OF-STATEMENT FLAG.
FIRST NOP           FIRST-CARD FLAG.
LINOL NOP           ADDR OF (ASCII) LINE # IN CURRENT BUFFER. 
CBA   NOP           ADDR OF CARD TEXT IN CURRENT BUFFER.
CRD#1 DEF *-*       ADDR BUFFER # 1.
CD#1  NOP           CARD NUMBER (WITHIN STMT) FOR BFR #1. 
CRD#2 DEF *-*       ADDR BUFFER # 2.
CD#2  NOP           CARD NUMBER (WITHIN STMT) FOR BFR #2. 
CD#   NOP           CURRENT CARD NUMBER.
DCD#  NOP           PTR TO CURRENT CARD BUFFER CARD NUMBER. 
CD#F  NOP           # CARDS IN CARD FILE. 
CD#P  NOP           CURRENT POSITION IN CARD FILE.
CICNT NOP           ADDR WORD COUNT IN CURRENT BUFFER.
MLIN  NOP           ADDR CLIB LINE NUMBER IN CURRENT BUFFER.
LIFCC NOP           COL # OF START OF 1ST CARD CURRENT STMT.
FTNF  NOP           FLAG INDICATING FTN DIRECTIVE IN PROCESS. 
* 
*                   GLOBALS REF'D DIRECTLY. 
* 
F.NXN NOP           NO INPUT FLAG.
F.TC  NOP           LAST CHARACTER READ.
F.NCR NOP           NO-CROSS-REFERENCE FLAG.
      SPC 2 
*                   CARD BUFFER SETUP ROUTINE.
* 
SETCA NOP           SET UP BUFFER POINTER ROUTINE 
      STB DCD#      SET LOCAL POINTER TO CARD #.
      ISZ DCD#
      LDB B,I       GET POINTED TO ADDRESS. 
      STB LINOL     SAVE THE LINE NUMBER LOCATION IN BUFF.
      ADB K3        SKIP OVER LINE NUMBER.
      STB CBA       SET CURRENT BUFFER ADDRESS. 
      ADB K41       INDEX TO CARD LENGTH AREA.
      STB CICNT     SET POINT TO IT.
      INB           AND TO THE LINE COUNT.
      STB MLIN
      JMP SETCA,I   RETURN
* 
K3    DEC 3 
K41   DEC 41
* 
      END 
ASMB,Q,C
      HED FTN4X - SCRATCH FILE 1 ACCESS.
      NAM WS1.F,8 92834-16002 REV.2030 800613 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
* 
*     ENTRIES IN THIS MODULE. 
* 
      ENT CRP.F     WRITE A CROSS-REFERENCE PAIR. 
      ENT ES1.F     WRITE EOF ON SCRATCH FILE 1.
      ENT IN3.F     INITIALIZE MODULE WS1.F 
      ENT RS1.F     READ WORD FROM SCRATCH FILE 1.
      ENT WS1.F     WRITE WORD TO SCRATCH FILE 1. 
* 
*     EXTERNALS IN OTHER MODULES. 
* 
      EXT F.A       A.T. PTR
      EXT F.ABT     FTN4 ABORT JUMP TARGET. 
      EXT F.CCW     FTN OPTION WORD.
      EXT F.DP      FWA ASSIGNMENT TABLE. 
      EXT F.LNN     CURRENT LINE NUMBER.
      EXT F.LO      LWA+1 A.T.
* 
      EXT EJP.F     NEW PAGE ON LISTING.
      EXT PSL.F     WRITE LISING LINE.
      EXT SKL.F     SKIP LINE(S) ON LISING. 
* 
*     OP SYSTEM INTERFACE.
* 
      EXT C.SC1     FCB FOR 1ST PASS FILE.
* 
      EXT RED.C     CLIB READ PROCESSOR.
      IFZ 
      EXT RWN.C     CLIB REWIND PROCESSOR. (ON IFZ) 
      XIF 
      EXT WRT.C     CLIB WRITE PROCESSOR. 
      SPC 2 
A     EQU 0 
B     EQU 1 
      SUP 
      SPC 2 
IN3.F NOP           INITIALIZATION: 
      CLA           JUST SET BUFFER EMPTY,
      STA COUNT 
      JMP IN3.F,I 
      SKP 
*         ****************
*         * WRITE A WORD *
*         ****************
      SPC 1 
WS1.F NOP 
      LDB DBUFR     COMPUTE ADDR FOR THIS WORD: 
      ADB COUNT     (FWA) + (# WDS BEFORE)
      STA B,I       PUT IT THERE. 
      ISZ COUNT     BUMP COUNT. 
      CPB DBUFE     FULL ?
      RSS           YES.
      JMP WS1.F,I   NO. DONE. 
* 
      JSB WRT.C     YES. WRITE IT OUT.
      DEF C.SC1 
      DEF BUFFR 
      DEF COUNT 
      JMP ERROR     (IF ERROR)
* 
      CLA           NOW SET IT EMPTY. 
      STA COUNT 
      JMP WS1.F,I   ALL DONE. 
      SPC 2 
*         *************** 
*         * READ A WORD * 
*         *************** 
      SPC 1 
RS1.F NOP 
RS1.0 CCB           DECREMENT COUNT.
      ADB COUNT 
      STB COUNT 
      SSB,RSS       WAS IT EMPTY ?
      JMP RS1.1     NO. 
* 
      JSB RED.C     YES. READ ANOTHER RECORD. 
      DEF C.SC1 
      DEF BUFFR 
      DEF BFSIZ 
      JMP ERROR     IF ERROR. 
* 
      SSB           EOF ? (-1)
      JMP RS1.2     YES. RETURN A=B=-1. 
* 
      STB COUNT     NO. SET UP COUNT, 
      LDA DBUFR     AND POINTER.
      STA T1RS1 
      JMP RS1.0     GO SEE IF ANY DATA IN RECORD. 
* 
RS1.1 LDB T1RS1,I   (A)=(B)=DATA. 
      ISZ T1RS1     (BUMP POINTER TO NEXT WORD.)
RS1.2 LDA B 
      JMP RS1.F,I   DONE. 
      SKP 
*         *************** 
*         * WRITE E-O-F * 
*         *************** 
      SPC 1 
*                   WRITE E-O-F, REWIND, CHECK FOR 'E' OPTION.
* 
ES1.F NOP 
      JSB WS1.F     WRITE EXTRA JUNK WORD: 2 LOOK-AHEADS. 
      LDA COUNT     ANYTHING IN BUFFER ?
      SZA,RSS 
      JMP ES1.0     NO. 
* 
      JSB WRT.C     YES. WRITE THE RECORD.
      DEF C.SC1 
      DEF BUFFR 
      DEF COUNT     (NOTE: F4.2 REWINDS THE FILE) 
      JMP ERROR 
* 
*                   SET BUFFER EMPTY. CHECK FOR 'E' OPTION. 
* 
ES1.0 CLA           SET BUFFER EMPTY. 
      STA COUNT 
      LDA F.CCW     'E' OPTION ?
      ALF,ALF 
      SLA,RSS 
      JMP ES1.F,I   NO. EXIT. 
      JMP ES1.5     YES. GO DUMP PASS FILE, SYMBOL TABLE. 
      SPC 2 
T1RS1 NOP           POINTER FOR READING.
COUNT NOP           # WDS IN BUFFER.
DBUFR DEF BUFFR     FWA BUFFER. 
BUFFR BSS 60        BUFFER. 
DBUFE DEF *-1       LWA BUFFER (MUST FOLLOW 'BUFFR')
BFSIZ ABS DBUFE-BUFFR+1  BUFFER SIZE, IN WORDS. 
      SKP 
*                   'E' OPTION. DUMP THE PASS FILE CONTENTS.
* 
ES1.5 EQU *         CODE DEPENDS ON AN 'IFZ' .
      IFZ 
      JSB RWN.C     YES. REWIND PASS FILE NOW.
      DEF C.SC1 
      JMP ERROR 
* 
      JSB EJP.F     DO THE TITLE. 
      LDA K12 
      LDB DTTL1 
      JSB PSL.F 
      CLA           LEAVE BLANK LINE. 
      JSB SKL.F 
* 
ES1.1 JSB RS1.F     START A RECORD. 
      CPA KM1       IF END, 
      JMP ES1.3     SKIP OUT. 
* 
      LDB A         COMPUTE ADDITIONAL LENGTH.
      BRS,BRS       WAS IN UPPER 8 BITS.
      BRS,BRS 
      BRS,BRS 
      BRS,BRS 
      CMB,SSB,RSS   (B) = -(TOTAL LENGTH), UNLESS 
      CCB           IT WAS OPERAND. THEN TOT LEN = 1. 
      STB T2ES1     SAVE AS COUNTER.
      RSS           SKIP READ FIRST TIME: (A)=DATA. 
ES1.2 JSB RS1.F     READ ANOTHER WORD.
      STA T1ES1     SAVE IT.
      LDB KM6       6 DIGITS. 
      JSB COD.F     CONVERT.
      DEF LINE1+5 
      LDA T1ES1     ASCII TOO.
      JSB ALM.F 
      STA LINE1+9 
      LDA K11       WRITE LINE. 
      LDB DLIN1 
      JSB PSL.F 
      ISZ T2ES1     MORE IN THIS RECORD ? 
      JMP ES1.2     YES. DO THEM. 
      JMP ES1.1     NO. GO FOR ANOTHER RECORD.
* 
ES1.3 JSB RWN.C     REWIND PASS FILE. 
      DEF C.SC1 
      JMP ERROR 
* 
      CLA           SET BUFFER EMPTY. 
      STA COUNT 
      SKP 
*                   DUMP THE SYMBOL TABLE.
* 
      JSB EJP.F     TITLE FOR SYMBOL TABLE. 
      LDA K11 
      LDB DTTL2 
      JSB PSL.F 
      CLA 
      JSB SKL.F 
      LDA F.DP      SET UP LOOP.
      STA T1ES1 
* 
ES1.4 LDA T1ES1     CONVERT ADDRESS.
      LDB KM5       5 DIGITS. 
      JSB COD.F     CONVERT.
      DEF LINE2+5 
      LDA T1ES1,I   CONVERT CONTENTS. 
      LDB KM6       6 DIGITS. 
      JSB COD.F     CONVERT.
      DEF LINE2+9 
      LDA T1ES1,I   OUTPUT ASCII: 
      AND KK02      REMOVE SYMBOL END BIT.
      JSB ALM.F     IF NOT PRINTABLE, CHANGE TO BLANK.
      STA LINE2+13
      LDA K15       OUTPUT THE LINE.
      LDB DLIN2 
      JSB PSL.F 
      ISZ T1ES1     ADVANCE IN MEMORY.
      LDA T1ES1     DONE ?
      CPA F.LO
      JMP ES1.F,I   YES. EXIT.
      JMP ES1.4     NO. LOOP. 
* 
T1ES1 NOP 
T2ES1 NOP 
KM1   DEC -1
KM5   DEC -5
KM6   DEC -6
K11   DEC 11
K12   DEC 12
K15   DEC 15
KK02  OCT 177577    MASK TO REMOVE SYMBOL END MARK. 
DTTL1 DEF TTL1      TITLE # 1.
TTL1  ASC 12,        FIRST PASS FILE. 
DTTL2 DEF TTL2      TITLE # 2.
TTL2  ASC 11,        SYMBOL TABLE.
DLIN1 DEF LINE1 
LINE1 ASC 11,          777777 'ZZ'
DLIN2 DEF LINE2 
LINE2 ASC 15,          77777:  777777 'ZZ'
      SKP 
*         ************************************
*         * MAP NON-PRINTING CHARS TO BLANKS *
*         ************************************
* 
*     ALM.F :    (A) => (A), TWO CHARACTERS. (B LOST) 
* 
ALM.F NOP 
      CLB           DO FIRST CHAR.
      RRR 8         (A)=1ST CHAR, (B)=2ND CHAR, IN UPPER. 
      JSB AM.F
      SWP           SAVE & DO 2ND CHAR. 
      ALF,ALF       (A) = 2ND CHAR. 
      BLF,BLF       (B) = 1ST CHAR, IN UPPER. 
      JSB AM.F
      IOR B         MERGE 
      JMP ALM.F,I   EXIT
* 
*     AM.F :     (A) => (A), ONE CHARACTER. (B PRESERVED) 
* 
AM.F  NOP 
      ADA BM177     (A)=CHAR-177
      SSA,RSS       RUBOUT OR 8-BIT ? 
      CLA,RSS       YES. CHANGE TO BLANK. 
      ADA B137      (A)=CHAR-40 
      SSA           CONTROL CHAR ?
      CLA           YES. CHANGE TO BLANK. 
      ADA B40       (A)=CHAR. 
      JMP AM.F,I    EXIT. 
* 
B40   OCT 40
B137  OCT 137 
BM177 OCT -177
      SKP 
*         **************************
*         * CONVERT OCTAL TO ASCII *
*         **************************
* 
*     CALL:  LDA <DATA> 
*            LDB <- # DIGITS> 
*            JSB COD.F
*            DEF <DEST>   WORD ADDRESS, MUST BE DIRECT. 
* 
COD.F NOP           SUBR TO CONVERT TO OCTAL DIGITS.
      STB T2COD     T2COD = - # DIGITS TO DO. 
      CMB           (B) = (# DIGITS) - 1
      ADB COD.F,I   FORM BYTE ADDRESS OF
      ADB COD.F,I   THE LAST BYTE.
      ISZ COD.F 
      CLE,ERB       (B) = ADDR,   (E) = ODD/ EVEN BIT.
* 
COD01 STA T1COD     SAVE DATA.
      AND K7        (A) = NEXT DIGIT. 
      IOR "0"       MAKE ASCII. 
      SEZ,RSS       WHICH BYTE ?
      ALF,ALF       FIRST, POSITION IT. 
      STA T0COD     SAVE NEW BYTE.
      LDA B,I       DATA WORD.
      AND B377      CLEAR UPPER BYTE. 
      SEZ           WAS THAT RIGHT ?
      XOR B,I       NO RESTORE & CLEAR OTHER. 
      IOR T0COD     INSERT NEW CHAR.
      STA B,I 
      CMB           (NEEDED TO SUBTRACT 1 & PRESERVE E) 
      SEZ,CME,RSS   BACK UP. WAS FIRST BYTE ? 
      INB           YES. PREVIOUS WORD. 
      CMB 
      LDA T1COD     CLEAR & SHIFT PAST DIGIT. 
      AND KM8 
      RAR,RAR 
      RAR 
      ISZ T2COD     COUNT. DONE ? 
      JMP COD01     NO. LOOP. 
      JMP COD.F,I   YES. EXIT.
* 
T0COD NOP 
T1COD NOP 
T2COD NOP 
KM8   DEC -8
K7    DEC 7 
B377  OCT 377 
"0"   OCT 60
      XIF 
      JMP ES1.F,I   (IF CODE NOT ASSEMBLED: EXIT) 
      SKP 
*         ************************
*         * WRITE CROSS-REF PAIR *
*         ************************
      SPC 1 
*                   WRITE TO THE PASS FILE THE CROSS-REF OPERATOR AND 
*                   A CROSS-REF PAIR OF THE FORM: 
* 
*                      WORD 1: SYMBOL TABLE ADDR OF IDENTIFIER. (F.A) 
*                      WORD 2: SOURCE LINE NUMBER OF OCCURANCE. (F.LNN) 
      SPC 1 
CRP.F NOP 
      LDA F.CCW     'C' OPTION ?
      AND K16 
      SZA,RSS 
      JMP CRP.F,I   NO. IGNORE IT.
      LDA KK30      COUNT & OPERATOR. 
      JSB WS1.F 
      LDA F.A 
      JSB WS1.F 
      LDA F.LNN 
      JSB WS1.F 
      JMP CRP.F,I   DONE. 
* 
K16   DEC 16
KK30  BYT 2,36
K99   DEC 99
      SPC 2 
ERROR LDA K99       ERROR. ABORT, DISASTR 99. 
      JMP F.ABT 
* 
      END 
ASMB,Q,C
      HED LISTING ROUTINES. 
      NAM PSL.F,8 92834-16002 REV.2030 800812 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE CONTAINS ROUTINES TO PRINT LINES ON THE LISTING.
*     THIS INCLUDES: SOURCE LINES.
*                    ERROR MESSAGES.
*                    MISCELANEOUS COMMENTS. 
*                    MIXED LISTING. 
*                    CROSS-REF. 
*                    SYMBOL TABLE.
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
     ENT   F.ABT    ABORT COMPILE ENTRY 
     ENT   F.CC     CURRENT COL 
       EXT F.CCW    FTN OPTION WORD 
       EXT F.CSN    CURRENT SEGMENT NUMBER. 
       EXT F.D      LOW ADDR OF DO STACK. 
       ENT F.DEB    DEF TO ERROR BIT TABLE. 
       EXT F.DNB    DEF OF NBUF (NAM RECORD)
       EXT F.DO     HIGH ADDR + 1 DO STACK. 
       EXT F.END    END SWITCH (0: EOF NOT ALLOWED) 
     ENT   F.EQE    EQUIVALENCE ERROR FLAG
     ENT   F.ERF    ERROR FLAG (# OF ER.F CALLS)
     ENT   F.ERX    ERROR EXIT ADDRESS
     ENT   F.ERN    ERROR ARRAY 
     ENT   F.FLN    FIRST LINE NUMBER OF MODULE.
     ENT   F.LNA    ADDRESS OF CURRENT LINE 
     ENT   F.LNL    LENGTH OF CURRENT LINE
     ENT   F.LNN    LINE # OF CURRENT LINE
     ENT   F.LOP    NO. LINES LEFT ON THIS PAGE.
       EXT F.LSP    LAST OPERATION FLAG 
     ENT   F.OFE    DATA POOL OVERFLOW ERROR ENTRY. 
     ENT   F.OPT    ADDR OF OPTIONS IN TITLE. 
     ENT   F.PAS    PASS NUMBER.
       EXT F.SEG    LOAD A NEW SEGMENT
       EXT F.STA    FLAG THAT IS 0 UNTIL FTN STMT 
     ENT   F.TIM    TIME ARRAY ADDRESS IN HEAD
     ENT   F.TL     LENGTH OF TITLE, INCL 2 WDS BLANKS. 
     ENT   F.TTL    START OF TITLE (AFTER 4 BLANKS) 
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
     ENT   ASC.F    CONVERT TO 4 ASCII DIGITS 
     ENT   CER.F    COMPILER ERROR. 
     ENT   EJP.F    PAGE EJECT SUBROUTINE 
     ENT   ER.F     ERROR PRINT SUBROUTINE
     ENT   IN1.F    INITIALIZATION FOR PSL.F
     ENT   MPN.F    MOVE PROGRAM NAME (TO NAM REC, ETC) 
     ENT   PCC.F    PRINT COMPILER COMMENT. 
     ENT   PSL.F    PRINT LINE ON PRINTER 
     ENT   SKL.F    SKIP LINES ON LIST
     ENT   WAR.F    ERROR COMMENT SUBROUTINE (WARNINGS) 
       EXT WS1.F    WRITE WORD TO PASS FILE 1.
* 
*     COMPILER LIBRARY ROUTINES USED
* 
      EXT C.LST     LIST FCB
      EXT SPC.C     SPACE ROUTINE 
      EXT WRT.C     WRITE FILE ROUTINE
* 
*     LIBRARY ROUTINES
* 
      EXT .MVW
* 
      SUP 
* 
A     EQU 0 
B     EQU 1 
      SPC 2 
*         ************************* 
*         * MODULE INITIALIZATION * 
*         ************************* 
      SPC 1 
IN1.F NOP 
      SZA           IF NEW # LINES PER PAGE,
      STA LINEP     SET IT. 
      CLB,SEZ,RSS   NEW COMPILE ? 
      JMP IN1.F,I   NO, DONE. 
      STB PGNUM     SET PAGE # BACK TO ZERO.
      CCB           FORCE A PAGE EJECT. 
      STB F.LOP 
      JMP IN1.F,I   EXIT. 
      SKP 
*         ********************* 
*         * PRINT SOURCE LINE * 
*         ********************* 
      SPC 1 
*     ENTRY: (B)=BUFFER LOCATION
*            (A)=NO. OF WORDS TO BE PRINTED 
*     PRINTS LINE, PRECEDED BY PAGE HEADER AND TWO BLANK LINES IF AT
*     TOP OF PAGE.
* 
PSL.F NOP 
      STA PBFL      SAVE NO. OF WORDS TO BE PRINTED 
      STB PBFP      SAVE TEXT ADDR
      LDA F.LOP 
      INA,SZA,RSS   AT BOTTOM OF PAGE?
      JSB EJP.F     YES. FORMFEED 
      LDA F.LOP 
      SZA,RSS       AT TOP OF FORM? 
      JSB PHEDR     YES. PRINT HEADER 
      ISZ F.LOP 
      JSB WRT.C     WRITE THE LINE
      DEF C.LST     THE FCB 
PBFP  DEF PBFP      THE BUFFER
      DEF PBFL      IT'S LENGTH 
      JMP EXIT      NOTHING TO DO BUT EXIT IF ERROR ON LIST 
      JMP PSL.F,I   OK RETURN 
* 
*                   ROUTINE TO CAUSE PAGE EJECT IN LISTING. 
* 
EJP.F NOP 
      CLB 
      CPB F.LOP     AT TOP OF PAGE? 
      JMP EJP.F,I   YES. IGNORE 
      LDA F.LOP     GET NUMBER LEFT ON THE PAGE 
      STB F.LOP     SET NUMBER LEFT TO ZERO 
      ADA KM6       SET TO SKIP 6 EXTRA ON TTY'S
      LDB F.CCW     GET THE OPTION WORD 
      BLF,BLF       TEST IF TTY FORMAT DESIRED
      SSB,RSS       IF NOT
      LDA KM2       REPLACE FORM FEED WITH SPC TWO LINES FOR CRT'S. 
      JSB SKPCL     CALL COMP. LIB. SKIP ROUTINE
      JMP EJP.F,I   RETURN
      SKP 
*                   ROUTINE TO SKIP (A)+1 LINES IN LISTING. 
* 
SKL.F NOP 
      LDB F.LOP 
      SZB,RSS       AT TOP OF PAGE? 
      JMP SKL.F,I   YES. IGNORE. (SHOULDN'T GET HERE) 
* 
      INA 
      ADB A 
      SSB           TEST IF NEAR BOTTOM 
      JMP SKPBN     NOT NEAR BOTTOM.
      JSB EJP.F     AT BOTTOM; DO FORMFEED INSTEAD
      JMP SKL.F,I 
SKPBN STB F.LOP 
      JSB SKPCL     SKIP ROUTINE
      JMP SKL.F,I 
* 
*                   INTERNAL ROUTINE TO SKIP (A) LINES. 
* 
SKPCL NOP 
      SSA           COUNT NEGATIVE ?
      JMP SKP02     YES. GO CALL SPC.C
* 
      CMA,INA,SZA,RSS  NEGATE COUNT. ZERO ? 
      JMP SKPCL,I   YES. DO NOTHING.
* 
      STA T1PSL     COUNTER.
SKP01 JSB WRT.C     WRITE A BLANK LINE. 
      DEF C.LST 
      DEF BLNKS 
      DEF K1
      JMP EXIT      ERROR. EXIT.
* 
      ISZ T1PSL     COUNT. DONE ? 
      JMP SKP01     NO. MORE. 
      JMP SKPCL,I   YES. EXIT.
* 
SKP02 STA T1PSL     NEGATIVE COUNT. CALL SPC.C
      JSB SPC.C     FOR A PAGE EJECT ?
      DEF C.LST 
      DEF T1PSL 
      NOP           IGNORE SKIPPING ERRORS, FOR SOME REASON.
      JMP SKPCL,I   EXIT. 
      SKP 
*                   ROUTINE TO PRINT HEADER AT TOP OF PAGE. 
* 
PHEDR NOP           AT TOP OF PAGE; PRINT HEADER
      ISZ PGNUM 
      LDA PGNUM 
      CLE           SUPPRESS LEADING ZEROES.
      JSB ASC.F 
      SWP           (A,B) = 1234
      AND B377      CHANGE FIRST DIGIT TO BLANK.
      IOR B20K
      RRL 8         (A,B) = 234-
      DST PAGE      SET PAGE. ASSUME < 1000.
      JSB WRT.C     WRITE HEADER. 
      DEF C.LST     LIST FCB
      DEF HEADR     ADDRESS OF HEAD 
      DEF F.HDL     LENGTH OF HEAD
      JMP EXIT      EXIT IF LIST ERROR
      LDA F.TL      SET UP TRUE TITLE LENGTH, 
      ADA K2        WITH 4 BLANKS ACCOUNTED FOR.
      STA TTLEN 
      JSB WRT.C     THEN TITLE, IF ANY. 
      DEF C.LST 
      DEF TITLE 
      DEF TTLEN     LENGTH. 
      JMP EXIT      IF LIST ERROR.
      CLA,INA       THEN ONE BLANK LINE.
      JSB SKPCL 
      LDA LINEP     SET # LINES LEFT. 
      CMA,INA       AS NEGATIVE IN F.LOP
      STA F.LOP 
      JMP PHEDR,I 
      SPC 2 
PBFL  NOP           # WDS TO BE PRINTED.
LINEP DEC 55        (IN CASE DISASTER)  
F.LOP NOP 
PGNUM NOP 
T1PSL NOP 
BLNKS ASC 1,
K1    DEC 1 
KM6   DEC -6
KM2   DEC -2
K2    DEC 2 
B20K  BYT 40,0      BLANK IN UPPER BYTE.
* 
F.HDL DEC 35   LENGTH OF HEADER.
HEADR ASC 03, PAGE ,
PAGE  ASC 03,001   ,                         PAGE #.
HEADN ASC 03,FTN.  ,                         PROGRAM NAME.
      ASC 05,  OPTS:   ,
F.OPT ASC 06,<ERROR>         ,               OPTIONS. 
F.TIM ASC 15,HH:MM AM  DAY., XX  MON., 19XX, CLIB TIME MSG. 
* 
F.TL  DEC 1         TITLE LENGTH, WITHOUT EXTRA BLANKS. 
TTLEN NOP           COMPUTED TRUE LENGTH. 
TITLE ASC 2,    ,   2 BLANKS COLUMNS BEFORE TITLE.
F.TTL BSS 33        TITLE. MAX 66 CHARS.
      SKP 
*         **************************
*         * PRINT COMPILER COMMENT *
*         **************************
      SPC 1 
*     PCC.F PRINTS A LINE JUST LIKE PSL.F, BUT IF THE LISTING HAS BEEN
*     DELAYED UNTIL PASS TWO, AND WE ARE CURRENTLY IN PASS ONE, THE 
*     LINE IS NOT PRINTED IMMEDIATELY, BUT IS WRITTEN TO THE PASS FILE. 
* 
*     CALLING SEQUENCE:  SEE PSL.F
* 
*                   ENTRY. SEE WHAT PASS WE'RE ON.
* 
PCC.F NOP 
      STA T1PCC     SAVE THE LINE LENGTH. 
      CLA,INA       PASS 1 ?
      CPA F.PAS 
      JMP PCC02     YES.
* 
PCC01 LDA T1PCC     RESTORE (A),
      JSB PSL.F     PRINT LINE IMMEDIATELY, 
      JMP PCC.F,I   AND EXIT. 
* 
PCC02 LDA F.CCW     PASS ONE. 'M' OR 'Q' OPTIONS ?
      AND B4002 
      SZA,RSS 
      JMP PCC01     NO. PRINT IMMEDIATELY.
* 
*                   DELAYED LIST. SEND TO PASS FILE.
* 
      STB T2PCC     SAVE BUFFER ADDR. 
      LDA T1PCC     COMBINE LINE LENGTH 
      ALF,ALF 
      IOR K56       AND OPCODE. 
      JSB WS1.F     WRITE THAT. 
      LDA T1PCC     SET UP COUNT. 
      CMA,INA,SZA,RSS  NEGATE. ZERO ? 
      JMP PCC.F,I   YES. DONE.
* 
      STA T1PCC     NO. T1PCC = COUNTER.
PCC03 LDA T2PCC,I   WRITE A WORD AT A TIME. 
      JSB WS1.F 
      ISZ T2PCC     BUMP BUFFER POINTER.
      ISZ T1PCC     BUMP COUNTER. DONE ?
      JMP PCC03     NO. LOOP. 
      JMP PCC.F,I   YES. EXIT.
* 
T1PCC NOP           LINE LENGTH / COUNTER.
T2PCC NOP           BUFFER POINTER. 
K56   DEC 56        DELAYED PRINT OPCODE. 
B4002 OCT 4002      Q & M OPTIONS.
      SKP 
*         ***************** 
*         * ERROR COMMENT * 
*         ***************** 
      SPC 1 
*     TO PRINT ERROR COMMENT. INPUT: (A) = ERROR NUMBER.
*            ERROR CLASS DETERMINED BY ER.F & F.ERN 
*            CURRENT LINE DESCRIBED BY  F.LNA  F.LNL  F.LNN  F.CC 
      SPC 1 
WAR.F NOP 
      STA ERTYP     SAVE ERROR NUMBER.
      CLE           (SUPPRESS LEADING ZERO) 
      JSB PD.F      CONVERT TYPE TO ASCII.
      STA ERBFX 
      STA F.LSP     SET LAST OPERATION FLAG.
* 
*                   SET THE BIT IN THE ERROR BIT VECTOR.
* 
      LDA ERTYP     GET WORD OFFSET.
      ARS,ARS 
      ARS,ARS 
      ADA F.DEB     WORD IN VECTOR. 
      STA T1WAR 
      LDA ERTYP     GET BIT OFFSET. 
      AND B17 
      CMA           -(BIT #)-1, LEFT TO RIGHT.
      CLB,INB 
WAR06 RBR           SHIFT UNTIL BIT IS POSITIONED.
      INA,SZA 
      JMP WAR06 
* 
      LDA T1WAR,I   SET THE BIT.
      IOR B 
      STA T1WAR,I 
* 
*                   SEE IF LISTING DELAYED TILL PASS 2. 
* 
      CLA,INA       IF [Q OR (M&L)] AND PASS 1, DELAY IT. 
      LDB F.ERN     UNLESS DISASTER.
      CPA F.PAS     PASS 1 ?
      SZB           AND NOT DISASTER ?
      JMP WAR01     NO. 
* 
      LDA F.END     END SWITCH SET ?
      SZA 
      JMP WAR01     YES. DON'T DELAY. 
* 
      LDA F.CCW     OPTIONS.
      AND B4003     Q,M,L.
      CPA K3        -Q,+M,+L ?
      JMP WAR04     YES. DELAY. 
      ALF           +Q ?
      SSA 
      JMP WAR04     YES. DELAY. 
      SKP 
*                   SKIP A LINE, CONVERT LINE #.
* 
WAR01 ISZ WARNF     (COUNT THE ERROR) 
      CLA           SKIP A LINE.
      JSB SKL.F 
      LDA F.LNN     CONVERT LINE #. 
      CLE           SUPPRESS LEADING ZEROES.
      JSB ASC.F 
      SWP 
      DST ERBFY 
* 
*                   LIMIT COL TO LINE LENGTH. IF < 2, IGNORE. 
* 
      LDA F.CC      (A) = COL #.
      ADA KM2       COL - 2 
      SSA,INA       WELL ?   (COL - 1)
      JMP WAR03     YUP. JUST MESSAGE.
      LDB F.LNL     GET CURRENT CARD LENGTH 
      BLS           IN CHARACTERS 
      STB T1WAR     SAVE IT 
      CMB,INB       IF ERROR IS OFF 
      ADB A         THE CARD
      CLE,SSB,RSS   THEN    (E=0: ZERO SUPPR IN PD.F) 
      LDA T1WAR     USE LAST CHAR. ON THE CARD
      STA T1WAR     SAVE THE COLUMN NUMBER
      JSB PD.F      MAKE TWO ASCII DIGITS 
      STA ERBFZ     ERROR COLUMN
* 
*                   INSERT '?', WRITE LINE, RESTORE.
* 
      LDB F.LNA     GET THE BUFFER ADDRESS
      CLE,ELB       CONVERT TO CHAR ADDRESS 
      ADB T1WAR     ADD THE COLUMN NUMBER 
      CLE,ERB       ADDRESS TO B, UPPER, LOWER TO E 
      STB T0WAR     SAVE THE ADDRESS
      LDA B,I       AND ITS CONTENTS
      STA T2WAR     FOR TO RESTORE IT 
      LDA "?B"      ASSUME EVEN COLUMN. 
      SEZ,RSS       TRUE ?
      JMP WAR02     YES.
      LDA B,I       NO. GET WORD. 
      XOR "?"       CNANGE LOWER CHAR TO "?"
      AND B377      ISOLATE THE UPPER CHARACTER 
      XOR B,I 
WAR02 STA B,I       IN THE BUFFER AFTER THE BAD GUY 
      LDB F.LNA     GET THE ADDRESS 
      LDA T1WAR     AND THE CHARACTER COUNT 
      ADA K2        ADJUST FOR BLANKS AND ODD 
      ARS           CONVERT TO WORDS
      JSB PSL.F     PRINT IT
      LDA T2WAR     RESTORE THE BUFFER
      STA T0WAR,I   JUST IN CASE
      SKP 
*                   SET UP AND PRINT THE ERROR MESSAGE. 
* 
WAR03 LDA DWARN     ASSUME "WARNING"
      LDB ER.F      CALLED FROM ER.F ?
      SZB 
      LDA DERRO     YES.   " ERROR "
      LDB F.ERN     CALLED FROM BOM.F ? 
      SZB 
      LDA DDISA     YES.   "DISASTR"
      LDB DERBW 
      JSB .MVW
      DEF K4
      NOP 
      LDA K27       (LENGTH IF COL COUNTER) 
      LDB F.CC      IF COL < 01 
      ADB KM2 
      SSB           THEN
      LDA K22       SKIP THE 'COLUMN ZZ'. 
      LDB F.LNN     IF NO LINE #, 
      SZB,RSS       THEN
      LDA K16       SKIP THE 'AT LINE XXXX'.
      LDB ERCK1     "ERR N DETECTED ..."
      JSB PSL.F     PRINT ERROR MESSAGE 
      CLA           SKIP A LINE.
      JSB SKL.F 
      JMP WAR05     CLEAR ER.F & EXIT.
* 
*                   DELAY TILL PASS 2. JUST 'PASS' IT ALONG.... 
* 
WAR04 LDA K25       SEND ERROR OPERATOR.
      JSB WS1.F 
      LDA ER.F      ERROR CLASS.
      JSB WS1.F 
      LDA F.LNN     LINE # (DIFFERENT FOR EQUIV)
      JSB WS1.F 
      LDA F.CC      COLUMN #. 
      JSB WS1.F 
      LDA ERTYP     ERROR CLASS.
      JSB WS1.F 
WAR05 CLA           CLEAR ER.F FLAG.
      STA ER.F
      JMP WAR.F,I   EXIT. 
      SKP 
*                   GLOBALS DESCRIBING THE CURRENT LINE.
* 
F.PAS NOP           PASS NUMBER.
F.LNA NOP           ADDRESS 
F.LNL NOP           LENGTH (WORDS)
F.LNN NOP           LINE #
F.FLN NOP           FIRST LINE # OF MODULE. 
F.CC  NOP           CURRENT COLUMN
* 
*                   THE ERROR LINE. 
* 
ERCK1 DEF *+1       ADDRESS OF ERROR MESSAGE. 
      ASC 02,  ** 
ERBFV ASC 04,FTN.  ** 
ERBFW ASC 04,WWWWWWW
ERBFX ASC 10,XX DETECTED AT LINE
ERBFY ASC 06,0000 COLUMN
ERBFZ ASC 01,ZZ 
K27   DEC 27        FULL LENGTH OF ERROR MESAGE.
K22   DEC 22        LENGTH WITHOUT COLUMN #.
K16   DEC 16        LENGTH WITHOUT LINE # OR COLUMN #.
K25   BYT 4,31      OPERATOR FOR ERROR. 
* 
DERBW DEF ERBFW     ADDRESS OF ERROR/WARNING/DISASTR
DERRO DEF *+1 
      ASC 4, ERROR
DWARN DEF *+1 
      ASC 4,WARNING 
DDISA DEF *+1 
      ASC 4,DISASTR 
      SPC 1 
* 
F.ERN NOP           ERROR ARRAY 
      NOP           CUMULATIVE ERROR COUNT
      NOP           CUMULATIVE WARNING COUNT
F.ERF NOP           NO OF ERRORS
WARNF NOP           NO. OF WARNINGS.
* 
F.DEB DEF *+1       DEF TO ERROR BIT VECTOR.
      OCT 0,0,0,0,0,0,0  ERROR BITS 0-111.
* 
T0WAR NOP 
T1WAR NOP 
T2WAR NOP 
"?"   OCT 77
"?B"  ASC 1,? 
B377  OCT 377 
B4003 OCT 4003
K4    DEC 4 
B17   OCT 17
      SKP 
*         *************** 
*         * FATAL ERROR * 
*         *************** 
      SPC 1 
*     TO PRINT AN ERROR MESSAGE & ABORT CURRENT STATEMENT.
*     INPUT (A) = ERROR TYPE. 
*           F.EQE = SPECIAL PROCESSING FLAG:
*                     =0 NORMAL.  EXIT THRU F.EQX . 
*                     >0 RECOVERY. EXIT THRU F.EQE .
*                     <0 EQUIVALENCE. JSB THRU F.EQE BEFORE WAR.F . 
      SPC 1 
ER.F  NOP 
      CPA K84       DATA / CODE OVERFLOW ?
      JMP F.ABT     YES. PUNT.
      ISZ F.ERF     STEP ERROR COUNT. 
      STA ERTYP     SAVE ERROR NUMBER.
      LDA F.EQE     EQUIVALENCE ? 
      CMA,SSA,RSS 
      JSB A,I       YES, SPECIAL PROCESSING.
      LDA ERTYP     ISSUE MESSAGE.
      JSB WAR.F 
      LDA F.DO      CUT DO STACK. 
      STA F.D 
      LDA F.EQE     RECOVERY ?
      SZA 
      SSA 
      JMP F.ERX,I   NO. EXIT THRU NORMAL (F.ERX) EXIT.
      JMP F.EQE,I   YES. EXIT THRU (F.EQE). 
      SPC 1 
F.ERX DEF 0         ERROR EXIT ADDRESS. 
F.EQE DEF 0         SPECIAL PROCESSING FLAG.
ERTYP NOP           ERROR NUMBER. 
K84   DEC 84
      SPC 2 
*         ***************** 
*         * ABORT COMPILE * 
*         ***************** 
      SPC 1 
F.OFE LDA K3        DATA POOL OVERFLOW. 
F.ABT ISZ F.ERN     BUMP DISASTER COUNT.
      CLB           SET F.CC=0
      STB F.CC      TO SUPPRESS ECHO & COLUMN #.
      JSB WAR.F     ISSUE MESSAGE.
      LDA F.CCW     TURN OFF C,T OPTIONS. 
      AND BM31
      STA F.CCW 
      LDB K3        GO TO SEGMENT 3 
      JMP EXIT2     TO WRITE THE ERROR DIRECTORY. 
* 
EXIT  LDB K4        LOAD SEGMENT 4 TO QUIT. 
EXIT2 STB F.STA 
      JMP F.SEG 
* 
BM31  OCT -31 
      SKP 
*         ******************
*         * COMPILER ERROR *
*         ******************
      SPC 1 
CER.F NOP 
      ISZ F.ERN     BUMP DISASTER COUNT.
      LDA F.CSN     GET CURRENT SEGMENT NUMBER. 
      ALF,ALF       IN HIGH BYTE. 
      ADA CECSN     PUT IN MSG. 
      STA CECSN 
      CCB           GET ADDRESS OF JSB. 
      ADB CER.F 
      JSB COD.F     CONVERT FOR PRINTING. 
      DEF CENUM 
      JSB WRT.C     WRITE MESSAGE.
      DEF C.LST 
      DEF CEMSG 
      DEF CELEN 
      JMP EXIT      IF ERROR ON WRITE.
      JMP EXIT      ALSO IF NO ERROR ON WRITE.
* 
CEMSG ASC 12, *** COMPILER ERROR AT:
CECSN ASC 1,0/
CENUM ASC 3,177777
      ASC 15,B *** PLEASE REPORT TO HP ***
CELEN ABS *-CEMSG 
KM3   DEC -3
B3407 OCT 3407      DIGIT MASK. 
      SPC 2 
*         *************************** 
*         * CONVERT TO OCTAL DIGITS * 
*         *************************** 
      SPC 1 
*     CALL:  LDB <NUMBER> 
*            JSB COD.F
*            DEF <3-WORD ASCII BUFFER>
* 
COD.F NOP 
      LDA COD.F     GET THE RESULT ADDR.
      ISZ COD.F 
      LDA A,I       RESOLVE INDIRECTS.
      RAL,CLE,SLA,ERA 
      JMP *-2 
      STA T2COD 
* 
      LDA KM3       CONVERT 6 DIGITS, 2 AT A TIME.
      STA T1COD 
      LSR 2         SET UP SO ONLY GET 1 BIT FIRST TIME.
CER01 RRL 3         MOVE LEFT DIGIT THIS PAIR TO (A). 
      ALF,RAL       LEAVE 5 BITS. 
      RRL 3         MOVE RIGHT DIGIT IN.
      AND B3407     ISOLATE THE DIGITS. 
      ADA "00"      FORM ASCII, 
      STA T2COD,I   PUT IN BUFFER.
      ISZ T2COD     BUMP BUFFER POINTER.
      ISZ T1COD     BUMP COUNTER. 
      JMP CER01     IF MORE.
      JMP COD.F,I   ELSE DONE.
* 
T1COD NOP           COUNTER FOR 3 LOOPS.
T2COD NOP           RESULT POINTER. 
      SKP 
*        ******************************** 
*        * CONVERT TO FOUR ASCII DIGITS * 
*        ******************************** 
      SPC 1 
*     ENTRY: (A) = VALUE TO CONVERT.
*            (E) = 1 TO PRODUCE LEADING ZEROES, 0 TO SUPPRESS.
*     EXIT:  (B,A) = 4 ASCII CHARACTERS.
* 
*     NOTE: IF VALUE IS NOT IN RANGE (0,9999) THEN THE RESULT 
*     WILL BE "  ??" .
* 
ASC.F NOP 
      ERB           (SAVE E-REG)
      CMA,SSA,RSS   < 0 ?     (A = -N-1)
      JMP ASC01     YES.
*       
      ADA K10K      > 9999 ?  (A = -N+9999) 
      CMA,SSA,RSS             (A = N-10000) 
      JMP ASC01     YES.
* 
      ADA K10K      NO. RESTORE ORIGINAL VALUE. 
      ELB           RESTORE E-REG.
      CLB           CLEAR FOR DIV.
      DIV K100      SEPERATE HIGH AND LOW DIGITS
      STB T1FC      SAVE THE LOW ONES 
      JSB PD.F      CONVERT THE HIGH DIGITS 
      CPA BLNKS     IF DIGITS PRODUCED IN FIRST PART, 
      CLE,RSS       (NO - CONTINUE TO SUPPRESS) 
      CCE           THEN FORCE LEADING ZERO IN SECOND.
      STA T2FC      SAVE FIRST TWO. 
      LDA T1FC      GET THE LOW 
      JSB PD.F      CONVERT 
      LDB T2FC      RESTORE THE HIGH TO B 
      JMP ASC.F,I   RETURN
* 
ASC01 LDB BLNKS     OUT OF RANGE. RETURN "  ??" 
      LDA "??"  
      JMP ASC.F,I     
* 
T1FC  NOP 
T2FC  NOP 
"00"  ASC 1,00
"??"  ASC 1,??
K10   DEC 10
K100  DEC 100 
K10K  DEC 10000 
      SKP 
*         *************** 
*         * PACK DIGITS * 
*         *************** 
      SPC 1 
*     ENTRY: (A)=TWO DIGIT DECIMAL NUMBER BINARIZED 
*            (E)=0 TO SUPPRESS LEADING OR BOTH ZEROES.
*     EXIT:  (A)=ASCII EQUIVALENT OF ENTRY (A)
      SPC 1 
PD.F  NOP 
      CLB 
      DIV K10 
      ALF,ALF 
      SEZ,SZA,RSS   IS ZERO & SUPPRESSED ?
      ADB B170K     YES. MAKE IT BLANK: ' ' - '0' 
      CPB B170K     BOTH ZERO & SUPPRESSED ?
      ADB BM20      YES. MAKE FINAL BLANK: '  ' - '00'
      ADA B 
      ADA "00"      ADD THE ASCII BITS
      JMP PD.F,I
* 
B170K BYT -20,0     ' '  - '0'
BM20  OCT -20       IN LOWER. 
      SPC 2 
*         ****************************************
*         * MOVE PROGRAM NAME TO PBUF,ERBF,HEADN *
*         ****************************************
      SPC 1 
MPN.F NOP 
      STA T1MPN     SAVE MOVE FROM LOC. 
      LDB HDLP7 
      JSB .MVW      MOVE NAME TO F.HDL+7,8,9
      DEF K3
      NOP 
      LDA T1MPN 
      LDB F.DNB 
      ADB K3
      JSB .MVW      MOVE NAME TO NBUF+3,4,5 
      DEF K3
      NOP 
      LDA T1MPN 
      LDB DERBV 
      JSB .MVW      MOVE NAME TO ERBF+1,2,3 
      DEF K3
      NOP 
      JMP MPN.F,I 
      SPC 1 
T1MPN NOP           MOVE FROM LOC.
K3    DEC 3 
      SPC 1 
DERBV DEF ERBFV     ADDRESS LOCATION IN ERROR BUFFER. 
HDLP7 DEF HEADN 
      SPC 1 
      END 
ASMB,L
      HED FTN4X - SEGMENT NAME ADDRESS FETCH
      NAM SEG.F,8 92834-16002 REV.2030 800226 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
      ENT SEG.F 
* 
A     EQU 0 
B     EQU 1 
* 
*  THIS ROUTINE FORMS A SEGMENT NAME, F4X.N, WHERE N IS THE 
*  SEGMENT NUMBER PASSED AS AN INPUT PARAMETER.  UPON RETURN, 
*  THE B-REGISTER CONTAINS THE ADDRESS OF THE SEGMENT NAME. 
* 
*       CALLING SEQUENCE:  JSB SEG.F
*                          DEF SEG#      SEGMENT NUMBER 
* 
*                RETURNS:  B = ADDRESS OF THE SEGMENT'S NAME
*                                (5 CHARACTERS) 
* 
* 
SEG.F NOP           ENTRY 
      LDB SEG.F,I   GET ADDRESS OF SEGMENT #
      LDB B,I       GET THE SEGMENT NUMBER
      BLF,BLF       PUT IN UPPER BYTE.
      ADB "0"       ADD TO FORM "N "
      STB NAM       SAVE IN NAME ARRAY
      LDB NAMA      GET ADDRESS 
      ISZ SEG.F     STEP RETURN 
      JMP SEG.F,I   RETURN
* 
"0"   ASC 1,0 
NAMA  DEF *+1 
      ASC 2,F4X.    NAME = F4X.N
NAM   NOP 
* 
      END 
ASMB,Q,C
      HED FTN4X COMPILER (SEG: F4X.0) SPECIFICATION STATEMENTS ** 
      NAM F4X.0,5 92834-16002 REV.2030 800812 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
***************************************** 
*     FORTRAN-4 COMPILER OVERLAY 0
***************************************** 
* 
*     THIS OVERLAY PROCESSES COMMON, DIMENSION, AND 
*  EQUIVALENCE STATEMENTS, PROGRAM AND DATA STATEMENTS, 
*  AND TYPE DECLARATIONS. 
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   EXT     F..E     EXPLICIT TYPING FLAG. 
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE ENTRY.
   EXT     F.AF     ADDRES FIELD OF CURRENT F.A 
   EXT     F.AT     ADDRESS TYPE OF CURREXT F.A 
       EXT F.AT.    SUBSCRIPT INFO FLAG 
       EXT F.BGN    RETURN FROM F4.0
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CCW    FTN OPTION WORD.
       EXT F.CRT    TEST FOR C/R & GO ON TO NEXT STMT.
       EXT F.D      DO TABLE POINTER
   EXT     F.D0     ARRAY ELEMEXT SIZE
   EXT     F.DCF    DIM, COM FLAG 
      EXT  F.DID    ADDRESS OF F.IDI
   EXT     F.DIS    DOUBLE INTEGER SUBSCRIPTING FLAG. 
       EXT F.DNB    DEF OF NBUF (NAM RECORD)
       EXT F.DO     LWAM - END OF DO TABLE
       EXT F.DPJ    DEF TO CURRENT PROC. JUMP TABLE.
       EXT F.DPK    DEF TO F.PAK BUFFER.
      EXT  F.DTY    IMPLICIT TYPE TABLE 
      EXT  F.E      EQUIVALENCE TABLE POINTER 
      EXT  F.EIM    EXPECTED ITEM MODE. 
   EXT     F.EM     EMA FLAG BIT IN A.T.
     EXT   F.ERX    GLOBAL ERROR RECOVERY ADDRESS.
   EXT     F.EXF    EXTERNAL STATEMEXT FLAG 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
       EXT F.IMF    IMPLICIT FLAG.
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.LCF    LABELLED COMMON FLAG. 
     EXT   F.LNN    CURRENT LINE NUMBER.
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
       EXT F.LSF    EXPECT FIRST STATEMEXT FLAG 
   EXT     F.LUB    ADDR OF LOWER/UPPER BOUNDS TABLE. 
   EXT     F.ND     NUMBER OF DIMENSIONS
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
       EXT F.P1E    PASS 1 ERROR RECOVERY POINT.
       EXT F.PTY    PROGRAM TYPE IN NAM RECORD. 
       EXT F.SBF    0= MAIN, ELSE SUBROUTINE
       EXT F.SFF    SUBROUTINE/FUNCTION FLAG 0/1
       EXT F.SLF    STATEMEXT LEVEL FLAG
       EXT F.SPF    SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL 
       EXT F.SPS    STATEMEXT PROCESSOR SWITCH
       EXT F.SXF    COMPLEX CONSTANT FLAG 
     EXT   F.TC     NEXT CHARACTER
       EXT F.TYP    TYPE STATEMEXT FLAG 
   EXT     F.VDM    VARIABLE DIMENSIONS FLAG. 
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
       EXT AA.F     ASSIGN ADDRESS SUB. 
   EXT     AI.F     ASSIGN ITEM 
   EXT     CFC.F    CHECK FOR & FETCH CONSTANT. 
     EXT   CRP.F    CROSS REF PAIR SUB. 
   EXT     DAD.F    DOUBLE INTEGER ADD. 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DAT.F    DEFINE (AT) 
   EXT     DEM.F    DEFINE (F.EM) TRUE. 
   EXT     DIM.F    DEFINE (F.IM) 
   EXT     DEM.F    SET THE F.EM BIT. 
   EXT     DIU.F    DEFINE (F.IU) 
   EXT     DMP.F    DOUBLE INTEGER MULTIPLY.
   EXT     DSB.F    DOUBLE INTEGER SUBTRACT.
   EXT     EIC.F    ESTABLISH INTEGER CONSTANT. 
       EXT EL.F     EXCHANGE LINKS OF (F.A) & (B).
     EXT   ER.F     ERROR PRINT SUBROUTINE
     EXT   EXN.F    EXAMINE NEXT CHARACTER
   EXT     FA.F     FETCH ASSIGNS 
       EXT FL.F     FETCH LINK OF (B).
   EXT     GCD.F    GET CONSTANT DIMENSION (AS DBL INT) 
   EXT     GFA.F    GET FIRST NAMED S.T. ENTRY. 
   EXT     GNA.F    GET NEXT S.T. ENTRY.
     EXT   IC.F     GET NEXT CHARACTER
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
       EXT IDL.F    INPUT DUMMY LIST. 
      EXT  IDN.F    INPUT DO NOT ASSIGN (GET NEXT OPERAND)
     EXT   IN6.F    INIT FOR IC.F MODULE
     EXT   INM.F    INPUT NAME
     EXT   IOP.F    INPUT OPERATOR
     EXT   ISY.F    INPUT SYMBOL
   EXT     ITS.F    INTEGER TEST
       EXT KWS.F    KEYWORD SEARCH. 
     EXT   MPN.F    MOVE PROGRAM NAME (TO NAM RECORD ECT.)
       EXT MVW.F    FTN MOVE WORDS. 
   EXT     NCT.F    TEST FOR NOT A CONSTANT 
   EXT     NST.F    TEST FOR NOT A SUBROUTINE NAME
   EXT     NTI.F    MOVE NID TO F.IDI (PACKS) 
   EXT     NWI.F    SET F.D0 TO # WORDS IN ARRAY
      EXT  PAK.F    PACK & OUTPUT ASCII DATA. 
      EXT  RP.F     INPUT ')' 
   EXT     TCT.F    TEST (A) = F.TC ELSE ER 28
   EXT     TS.F     TAG SUBPROGRAM SUB. 
   EXT     TV.F     TAG VARIABLE
     EXT   WAR.F    ERROR COMMEXT SUBROUTINE (WARNINGS) 
       EXT WS1.F    WRITE WORD TO PASS FILE # 1.
* 
*     OTHER ENTRY POINTS THIS SEGMENT.
* 
      ENT F.BCM     BLANK COMMON HEADER.
      ENT F.CIO     ITEM OFFSET (2-WORD INTEGER)
* 
      ENT CIO.F     COMPUTE ITEM OFFSET.
      ENT NDS.F     NON-DUMMY/SUBROUTINE TEST.
* 
*     SPECIAL ACCESS FOR 'RCO.F'
* 
      ENT F.RCO     JUST POINTS TO RCO.F
      EXT RCO.F     MAIN CAN'T ACCESS IT DIRECTLY.
* 
*     FORMAT PROCESSOR IN 'DSP.F'.
* 
      EXT F.FMT     STMT PROC FOR FORMAT. 
* 
*     OTHER LIB ROUTINES
* 
      EXT .MVW
* 
A     EQU 0         A-REGISTER
B     EQU 1         B-REGISTER
      SUP 
      SPC 1 
      DEC 0         OVERLAY # 
      SKP 
*         *-----------------------* 
*         *     START HERE.       * 
*         *-----------------------* 
* 
F4.0  LDA DFP1E     SET THE ERROR RECOVERY ADDRESS. 
      STA F.ERX 
      LDA DFPJT     AND THE PROC. JUMP TABLE ADDR.
      STA F.DPJ 
      LDA F.SLF     IF BACK IN TO DO
      CPA K2        A DATA STATEMENT
      JMP F.DAT     JUST GO DO IT 
* 
      JSB MVW.F     MOVE THE CARD BUFFER, 
      DEF F.IDI+1,I TO HERE,
      DEF F.IDI,I   FROM HERE.
      DEC 98        98 WORDS. 
      LDB F.IDI+1   NOW PASS THE ADDRESS OF CARD BUFFER 
      CCA,CLE       TO
      JSB IN6.F     THE ONE WHO MUST KNOW 
* 
      JMP F.BGN     BACK TO READ THE FIRST CARD 
      SPC 1 
DFP1E DEF F.P1E     PASS 1 ERROR RECOVERY ADDRESS.
DFPJT DEF F.PJT     DEF TO PROC. JUMP TABLE FOR SEG 0.
F.RCO DEF RCO.F     SPECIAL ACCESS TO RCO.F 
K9    DEC 9 
      SKP 
*         ************************
*         * PROCESSOR JUMP TABLE *
*         ************************
      SPC 1 
*     THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY
*     THE DISPATCHER.  THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS
*     0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE
*     MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS.
*     THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . 
*     THE ORDINALS FOR THE FIRST 3 ENTRIES ARE SPECIAL-CASED IN THE 
*     DISPATCHER, AND ARE NOT TRUE ORDINALS.
* 
      DEF 0         DO              (-2)
      DEF 0         ASSIGNMENT STMT (-1)
F.PJT DEF 0         STMT FCT.       (0) 
      DEF 0         IF              (1) 
      DEF F.EMP     EMA 
      DEF 0         END 
      DEF 0         CALL
      DEF 0         GO TO 
      DEF 0         READ
      DEF 0         STOP
      DEF F.REA     REAL
      DEF F.DAT     DATA
      DEF 0         THEN
      DEF 0         ELSE
      DEF 0         OPEN
      DEF 0         WRITE 
      DEF 0         PRINT 
      DEF 0         PAUSE 
      DEF 0         ENDIF 
      DEF 0         CLOSE 
      DEF 0         RETURN
      DEF F.FMT     FORMAT
      DEF 0         REWIND
      DEF F.COM     COMMON
      DEF 0         ASSIGN
      DEF 0         ENCODE
      DEF 0         DECODE
      DEF 0         END FILE
      DEF F.INP     INTEGER 
      DEF F.CPX     COMPLEX 
      DEF F.LOG     LOGICAL 
      DEF F.PRO     PROGRAM 
      DEF 0         INQUIRE 
      DEF F.FUN     FUNCTION
      DEF 0         CONTINUE
      DEF F.EXT     EXTERNAL
      DEF F.IMP     IMPLICIT
      DEF F.DIM     DIMENSION 
      DEF 0         BACKSPACE 
      DEF F.BLK     BLOCK DATA
      DEF F.SUB     SUBROUTINE
      DEF F.EQU     EQUIVALENCE 
      DEF F.DBL     DOUBLE PRECISION
      SKP 
*         ************
*         * EXTERNAL *
*         ************
      SPC 1 
F.EXT CLA,INA 
      STA F.EXF     SET EXT FLAG
      JSB INM.F     INPUT NAME
      JSB TS.F      TAG SUBPROGRAM
      SPC 1 
*         ***************** 
*         * , OR C/R TEST * 
*         ***************** 
      SPC 1 
CCRT  CLB 
      STB F.LSF     CLEAR THE EXPECT FIRST STMT. FLAG 
      LDA F.TC
      CPA B54       ',' ? 
      JMP F.SPS,I   YES. MORE TO PROCESS
* 
      STB F.EXF     NO. CLEAR EXTERNAL FLAG 
      JMP F.CRT     C/R TEST
* 
TYPES ASC 13,NONE REAL INTEGER COMPLEX ,
      ASC 13,LOGICAL DOUBLEPRECISION   ,
DIMPT DEF IMPT-1    ORDINAL TO TYPE TRANSLATION.
IMPT  OCT 20000,10000,50000,30000,60000 
REA   EQU IMPT
B10K  EQU IMPT+1
INT   EQU IMPT+1
CPX   EQU IMPT+2
LOG   EQU IMPT+3
DBL   EQU IMPT+4
T1IMP NOP 
T2IMP NOP 
T3IMP NOP 
BM101 OCT -101
K5    DEC 5 
B51   OCT 51
B54   OCT 54
B55   OCT 55
B377  OCT 377 
B170K OCT 170000
      SKP 
*     ************
*     * IMPLICIT *
*     ************
      SPC 1 
*                   GET TYPE, HANDLE 'IMPLICIT NONE'. 
* 
F.IMP LDB F.IMF     HAVE WE SEEN AN 'IMPLICIT NONE' ? 
      LDA K5        IF SO,
      SSB 
      JSB ER.F      ERROR 5.
* 
      JSB KWS.F     NO. LOOK FOR TYPE.
      DEF TYPES 
      LDB A         (B) = ORDINAL.
      LDA K28       (ERROR NUMBER)
      CMB,INB,SZB,RSS  GOT ONE ? (B=-ORD) 
      JSB ER.F      NO. ERROR.
* 
      CMB,SZB       'NONE' ?   (B=ORD-1)
      JMP IMP01     NO. NORMAL TYPE.
* 
      LDB F.IMF     YES. IS IT THE FIRST IMPLICIT ? 
      LDA K5
      SZB 
      JSB ER.F      NO. ERROR 5.
* 
      CCA           YES. SET THE FLAG: -1 = NONE. 
      STA F.IMF 
      JSB ICH.F     READ THE C/R. 
      JMP F.CRT     THAT'S ALL. 
* 
IMP01 CLA,INA       NORMAL IMPLICIT. SET FLAG = 1.
      STA F.IMF 
      ADB DIMPT     GET TYPE. 
      LDA B,I 
      JSB MTY.F     MODIFY IT IF APPROPRIATE. 
      JSB ICH.F     REQUIRE '(' HERE. 
      CPA B50 
      JMP IMP03     O.K.
      LDA K9        NO. UNEXPECTED CHAR.
      JSB ER.F
      SKP 
*                   GET THE RANGE, IN FORM  X OR X-Y. 
* 
IMP03 JSB ICH.F     GET FIRST CHAR OF SET 
      STA T1IMP     SET IT
      SZB           IF IT IS NOT
      SEZ           ALF 
      JMP TYP11     GO REPORT THE ERROR 
* 
      CCA           IN CASE SINGLE LETTER,
      STA T2IMP     SET COUNT TO 1. 
      JSB ICH.F     GET THE NEXT CHAR 
      CPA B55       '-'  IF '-' THEN PART OF RANGE
      RSS           YES.
      JMP IMP04     NO. ALREADY SET UP. 
* 
      JSB ICH.F     GET THE FINAL CHAR OF A  RANGE
      SZB           TEST FOR
      SEZ           ALF 
      JMP TYP11     NOPE  BITCH 
* 
      CMA           COMPUTE NEG. NO TO DO 
      ADA T1IMP     AND 
      STA T2IMP     SET FOR THE LOOP
      SSA,RSS       IF LETTERS BACKWARD 
      JMP TYP11     REPORT ERROR
* 
      JSB ICH.F     GET NEXT CHAR.
* 
*                   SET DEFAULTS FOR ALL IN RANGE TO SPECIFIED TYPE.
* 
IMP04 LDB T1IMP     GET THE CHARACTER 
      ADB BM101     SUBTRACT 'A'
      CLE,ERB       COMPUITE TYPE ADDRESS IN THE TABLE
      ADB F.DTY     AND GET CURRENT 
      LDA B,I       TYPE
      SEZ           ROTATE
      ALF,ALF       IF NEEDED 
      STA T3IMP     SAVE RESULT FOR DUP IMPLICIT TEST 
      XOR F.MFL     GET THE NEW TYPE
      AND B377      KEEP THE OLD LOW ORDER BYTE 
      XOR F.MFL     RULES OF WOO  CHAR REPLACE
      IOR B400      SET LEAST BIT IN BYTE AS FLAG.
      SEZ           IS CHAR IS TO BE IN LOW WORD
      ALF,ALF       PUT IT THERE
      STA B,I       RESTORE WORD TO THE TABLE 
      LDA K5        WARNING 5 
      LDB T3IMP     IF SECOND REF TO SAME 
      BLF,BLF       CHAR
      SLB 
      JSB WAR.F 
* 
      ISZ T1IMP     STEP TO THE NEXT CHAR 
      ISZ T2IMP     STEP THE COUNT (DONE?)
      JMP IMP04     N0 - DO NEXT CHAR 
      SKP 
*                   APPLY IMPLICIT TYPING TO ALL SYMBOLS SO FAR.
* 
      JSB GFA.F     SET UP TO SCAN NAMED SYMBOLS. 
IMP05 JSB GNA.F     NEXT. 
      SZA,RSS       SEE IF DONE.
      JMP IMP06     YES.
* 
      JSB FA.F      NO. SET ADDR & FETCH ASSIGNS. 
      LDA F..E      EXPLICITLY TYPED ?
      SZA           IF SET
      JMP IMP05     YES. IGNORE IT. 
* 
      LDA F.A       GET THE FIRST 
      ADA K2        CHAR OF THE NAME
      LDA A,I       TO A
      ALF,ALF       ROTATE AND
      AND B377      ISOLATE 
      ADA BM101     SUBTRACT 'A'
      CLE,ERA       CONVERT TO CHAR ADDRESS 
      ADA F.DTY     ADD THE ADDRESS OF THE TYPE TABLE 
      LDA A,I       GET THE TYPE FROM THE TABLE 
      SEZ           USE RIGHT END 
      ALF,ALF 
      AND B170K     ISOLATE THE MODE
      JSB DIM.F     DEFINE NEW IM 
      JMP IMP05     GO GET NEXT SYMBOL. 
* 
*                   CHECK DELIMITER AFTER RANGE.
* 
IMP06 LDA F.TC      YES - GET DELIMITER 
      CPA B54       ',' IF COMMA
      JMP IMP03     GO DO NEXT CHAR 
* 
      CPA B51       ')' IF CLOSE THEN 
      RSS           OK  ELSE
      JMP TYP11     UNEXPECTED CHAR 
* 
      JSB ICH.F     GET THE NEXT CHAR 
      JMP CCRT      GO TEST FOR COMMA 
      SKP 
*         ******* 
*         * EMA * 
*         ******* 
      SPC 1 
F.EMP CLA,INA       SET DIMENSION FLAG. 
      STA F.DCF 
      JSB INM.F     INPUT NAME. 
      LDA F.IU      ALREADY DECLARED AS AN ARRAY ?
      CPA ARR 
      RSS           YES. LEAVE IT ALONE.
      JSB TV.F      NO. TAG VARIABLE. 
      LDA F.AT      VERIFY A DUMMY
      CPA DUM 
      RSS 
      JMP EMP2      NO, ERROR 
      JSB DEM.F     MAKE IT TYPE EMA. 
      JSB IDC.F     PROCESS ANY DIMENSION INFO. 
      JMP CCRT      CHECK FOR "," OR "C/R"
* 
EMP2  LDA K94       ERROR 94: NOT DUMMY OR MENTIONED TWICE. 
      JSB ER.F
* 
K94   DEC 94
      SPC 3 
*         *********************************** 
*         * NON-DUMMY & NON-SUBPROGRAM TEST * 
*         *********************************** 
      SPC 1 
NDS.F NOP 
      JSB NST.F     NON-SUBPROGRAM TEST 
      LDB F.A       MUST NOT
      CPB F.SBF     SUBPROGRAM NAME 
      JSB ER.F      A SET BY NST.F TO 25
      LDA K37 
      LDB F.AT
      CPB DUM       DUMMY?
      JSB ER.F      ILLEGAL USE OF DUMMY VARIABLE 
      JMP NDS.F,I 
      SPC 1 
K37   DEC 37
      SKP 
*         ********************* 
*         * TYPE MODIFICATION * 
*         ********************* 
      SPC 1 
*     ENTRY: (A) = TENTATIVE TYPE.
*            F.TC = LAST CHAR OF TYPE.
*     EXIT:  F.MFL = TYPE MODIFIED BY 'J', 'Y' AND *N.
      SPC 1 
MTY.F NOP 
      LDB A         (B) = TENTATIVE TYPE. 
      LDA F.CCW     CHECK FOR 'Y' OPTION
      AND B1000 
      SZA,RSS 
      JMP MTY01     NO. 
      CPB DBL       YES. TYPE = DOUBLE ?
      LDB RE8       YES, CHANGE TO REAL*8.
MTY01 LDA F.CCW     GET 'J' OPTION. 
      AND B10K
      SZA,RSS 
      JMP MTY02     NO. 
      CPB INT       TYPE = INTEGER ?
      LDB DBI       YES, CHANGE TO INTEGER*4. 
      CPB LOG       TYPE = LOGICAL ?
      LDB LO4       YES, CHANGE TO LOGICAL*4. 
* 
MTY02 STB F.MFL     SAVE TYPE (SO FAR)
      JSB EXN.F     FOLLOWED BY '*N' ?
      CPA B52 
      RSS 
      JMP MTY.F,I   NO. 
* 
      JSB ICH.F     YES. SWALLOW IT.
      JSB ICH.F     NEXT.  DIGIT ?
      SZB 
      JMP TYP11     NO. ERROR.
* 
      ADA BM60      YES. (A) = ITS VALUE. 
      STA F.IDI     SAVE. 
      JSB EXN.F     LOOK AT NEXT ONE. 
      SZB           DIGIT ? 
      JMP MTY05     NO. THAT'S O.K. 
* 
      JSB ICH.F     YES, READ IT OFFICIALLY.
      ADA BM60      YES. (A) = ITS VALUE. 
      LDB F.IDI     (B) = FIRST DIGIT.
      BLS,BLS       4*FIRST 
      ADB F.IDI     5*FIRST 
      BLS           10*FIRST
      ADB A         WHOLE #.
      STB F.IDI     SAVE IT.
MTY05 LDB F.IDI 
      BLF           B<11:4> = LENGTH. 
      ADB F.MFL     B<15:12> = DEFAULT TYPE.
      LDA DFTLT     SET UP TO SCAN TYPE-LENGTH TABLE. 
      STA T1MTY 
      SKP 
*                   SCAN TYPE-LENGTH TABLE FOR MATCH. 
* 
MTY03 LDA T1MTY,I   NEXT ENTRY. 
      AND BM20      TYPE & LENGTH PART. 
      CPB A         MATCH ? 
      JMP MTY04     YES. GOT IT.
      ISZ T1MTY     BUMP TO NEXT ENTRY. 
      SZA           MORE ?
      JMP MTY03     YES.
      JMP TYP11     NO. ILLEGAL STATEMENT.
* 
MTY04 XOR T1MTY,I   MATCH. FETCH NEW TYPE.
      RAR,RAR       ALIGN.
      RAR,RAR 
      STA F.MFL     SAVE FINAL TYPE.
      JMP MTY.F,I   EXIT. 
* 
T1MTY NOP 
F.MFL NOP           CURRENT F.IM OF TYPE SPECIFICATION. 
BM60  OCT -60 
      SPC 2 
*                   TYPE-LENGTH TABLE. FORMAT IS: 
*                      BITS 15:12 - UNMODIFIED TYPE.
*                            11:4 - LENGTH. 
*                             3:0 - MODIFIED TYPE.
* 
DFTLT DEF *+1       TYPE-LENGTH TABLE.
      ABS 10040B+1    INTEGER*2    = INT
      ABS 10100B+8    INTEGER*4    = DBI
      ABS 20100B+2    REAL*4       = REA
      ABS 20140B+6    REAL*6       = DBL
      ABS 20200B+10   REAL*8       = RE8
      ABS 30040B+3    LOGICAL*2    = LOG
      ABS 30100B+9    LOGICAL*4    = LO4
      ABS 50200B+5    COMPLEX*8    = CPX
      ABS 50400B+12   COMPLEX*16   = ZPX
      ABS 60140B+6    DOUBLE*6     = DBL
      ABS 60200B+10   DOUBLE*8     = RE8
      OCT 100041      INTEGER*2(J) = INT
      OCT 100110      INTEGER*4(J) = DBI
      OCT 110043      LOGICAL*2(J) = LOG
      OCT 110111      LOGICAL*4(J) = LO4
      OCT 120146      DOUBLE*6(Y)  = DBL
      OCT 120212      DOUBLE*8(Y)  = RE8
      ABS 0         (END-OF-TABLE)
      SKP 
*         *********** 
*         * INTEGER * 
*         *********** 
      SPC 1 
F.INP LDA INT 
      JMP TYP02 
      SPC 1 
*         ********
*         * REAL *
*         ********
      SPC 1 
F.REA LDA REA 
      JMP TYP02 
      SPC 1 
*         ********************
*         * DOUBLE PRECISION *
*         ********************
      SPC 1 
F.DBL LDA DBL 
      JMP TYP02 
      SPC 1 
*         *********** 
*         * COMPLEX * 
*         *********** 
      SPC 1 
F.CPX LDA CPX 
      JMP TYP02 
      SPC 1 
*         *********** 
*         * LOGICAL * 
*         *********** 
      SPC 1 
F.LOG LDA LOG 
TYP02 JSB MTY.F     MODIFY TYPE BY 'Y', 'J' & *N. 
      SKP 
*                   PROCESS ITEMS IN TYPE DECLARATIONS. 
* 
      LDA DTP17     SUBSEQUENT ITEMS SKIP PREV JUNK.
      STA F.SPS 
TYP17 LDA F.LSF     LAST STATEMENT FLAG 
      SZA 
      JMP TYP06     1ST STATEMENT OF PROGRAM
      CLA,INA 
      STA F.TYP     SET TYPE FLAG 
      JSB INM.F     INPUT NAME
TYP03 LDA F.A,I     GET OLD EXPLICIT TYPE FLAG
      AND K8        (CAN'T USE F..E INCASE IT IS DUM,ARR ALREADY) 
      SZA,RSS       IF NOT SET THEN 
      JMP TYP05     PROCEED ALL OK
* 
      LDA F.IM      GET OLD MODE
      CPA F.MFL     SAME AS NEW ONE?? 
      JMP TYP05     RETYPE IM THE SAME
* 
      LDA K83 
      JSB WAR.F     RETYPE DIFFERENTLY
      JMP TYP08 
      SPC 1 
TYP05 LDA F.MFL 
      IOR K8        SET EXPLICID TYPE FLAG
      JSB DIM.F     DEFINE F.IM 
      JSB FA.F      FETCH ASSIGN
      LDB F.IU
      LDA VAR 
      SZB 
      JMP TYP08 
      LDB F.AT
      CPB STRAB 
      JMP TYP08 
      JSB DIU.F     SET F.IU=VAR/CON
TYP08 CLA 
      STA F.TYP     RESET TYPE FLAG TO INPUT DIMENSION. 
      JSB IDC.F     INPUT DIMENSION IF THERE. 
      JMP CCRT
      SKP 
*                   FIRST LINE OF PROG. MAY BE FUNCTION STATEMENT.
* 
TYP06 JSB EXN.F     STRIP OFF PRECEDING BLANKS AND
      JSB IDN.F     INPUT DNA: EAT SIX CHARS. 
      LDA F.TC
      CPA B117      IS NEXT CHAR "O"? 
      JMP TYP0F     YES. "O" IN "FUNCTION". 
      CLA,INA 
      STA F.TYP     SET TYPE FLAG 
      LDA F.IM
      SZA 
      JSB AI.F      ASSIGN ITEM 
      SZA 
      JMP TYP01 
      LDA K17       NO MODE:
      JSB ER.F      ILLEGAL OPERAND 
      SPC 1 
TYP0F JSB NTI.F     PACK NAME TO F.IDI
      LDB F.DID     GET DEF TO IT 
      LDA B,I       TEST FOR 'FUNCTION' 
      CPA "FU"
      INB,RSS       SO FAR SO GOOD
      JMP TYP11     BAD NEWS
* 
      LDA B,I       NOW 
      CPA "NC"      "NC"
      INB,RSS       OK
      JMP TYP11     BAD 
* 
      LDA B,I       LAST ONE HERE 
      CPA "TI"      OK? 
      JSB ICH.F     GET THE "N" 
      CPA "N"       IF NOT "N"
      JMP FUN01 
* 
TYP11 LDA K28       ILLEGAL STATEMENT 
      JSB ER.F      TERMINATE STATEMENT  (NO RETURN)
      SPC 1 
TYP01 LDA F.A 
      STA TYP.A     SAVE F.A
      LDA K24 
      LDB F.NT
      SZB,RSS 
      JMP TYP10 
      JSB WAR.F     OPERAND NOT A NAME. 
      RSS 
TYP10 JSB CRP.F     OUTPUT CROSS REF. PAIR. 
      LDA TYP.A 
      STA F.A       RESTORE F.A 
      JMP TYP03 
      SPC 1 
DTP17 DEF TYP17 
B400  OCT 400 
VAR   EQU B400      F.IU=2, VARIABLE OR CONSTANT
STRAB OCT 2000      F.AT=2, STR-ABS - UNDEFINED 
TYP.A NOP           SAVE F.A
B1000 OCT 1000
B100K OCT 100000
DBI   EQU B100K 
LO4   OCT 110000
RE8   OCT 120000
K83   DEC 83
BM20  OCT 177760
K17   DEC 17
K24   DEC 24
B117  OCT 117       'O' 
"N"   OCT 116 
"FU"  ASC 1,FU
"NC"  ASC 1,NC
"TI"  ASC 1,TI
K28   DEC 28
      SPC 2 
*                   SHORTEN DOUBLE INTEGER
* 
SDI.F NOP 
      LDA F.IM      IS IT DOUBLE ?
      CPA DBI 
      JMP SDI01     YES.
* 
      CPA LO4       DOUBLE LOGICAL ?
      LDA LOG       YES, JUST CHANGE F.IM 
      JMP SDI02 
* 
* 
SDI01 DLD F.IDI     TRY TO SHORTEN. 
      SWP 
      ASL 16
      SOC           FITS ?
      JMP SDI.F,I   NO. LEAVE IT. 
* 
      STB F.IDI     YES. CHANGE TO SINGLE.
      LDA INT 
SDI02 STA F.IM
      JMP SDI.F,I   EXIT. 
      SKP 
*         *********************************** 
*         * INPUT DIMENSION (CONDITIONALLY) * 
*         *********************************** 
      SPC 1 
IDC.F NOP 
      LDA F.TC      NEXT CHAR '(' ? 
      CPA B50 
      JSB IND.F     YES, INPUT DIMENSION. 
      JMP IDC.F,I   EXIT. 
      SPC 1 
ARR   OCT 600       F.IU=3, ARRAY 
      SPC 1 
*         ************* 
*         * DIMENSION * 
*         ************* 
      SPC 1 
F.DIM CLA,INA 
      STA F.DCF     SET DIM FLAG
      JSB INM.F     INPUT NAME
      JSB IND.F     INPUT DIMENSION.
      JMP CCRT      CHECK FOR ',' OR 'C/R' .
* 
IND.F NOP 
      LDA F.AT      DUMMY CHECK 
      CCB 
      CPA DUM 
      CLB 
      STB T0DIM     T0=0 IF DUMMY, ELSE =-1 
      LDA F.A 
      STA T2DIM     T2=F, SAVE F
      JSB NST.F     NON-SUBPROGRAM TEST 
      LDB F.A       CHECK IF NAME OF CURRENT MODULE 
      CPB F.SBF     IF SO SEND
      JSB ER.F      ERROR 25  (A SET BY NST.F)
* 
      LDA K54 
      LDB F.IU
      CPB ARR 
      JSB ER.F      ARRAY NAME DEFINED TWICE
      LDA B52 
      LDB F.TC
      CPB B50       '(' 
      RSS 
      JSB ER.F      ERR 42: ARRAY WITHOUT DECLARATOR
      LDA T0DIM 
      JSB ISP.F     INPUT SUBSCRIPT 
      JSB MVW.F     COPY BOUNDS INFO TO F.IDI:
      DEF F.IDI 
      DEF DSTBL,I 
      DEC 14        14 WORDS: UP TO 7 DIM, UPPER/LOWER. 
      LDA NS        NO. OF SUBSCRIPTS 
      STA F.ND      FOR AI.F (ALSO NEEDS F.VDM) 
      LDA DIM       SET F.AT. = DIM AS SPECIAL FLAG 
      STA F.AT. 
      JSB AI.F      TO AI.F, TO BUILD A DIM ENTRY.
      LDB F.A       SET LOWER BOUND CORRECTION TO ZERO. 
      ADB K2        (FLAG TO AEA.F THAT IT IS DOING 
      CLA            PROLOGUE CODE, IF PROCESSING FORMAL.)
      STA B,I 
      ISZ T2DIM     EXCHANGE LINKS
      LDA F.A       (USE LOCAL BECAUSE
      LDB T2DIM,I   FETCH LINK IS FOLLED BY 
      STA T2DIM,I   POSSIBLE BCOM 
      INA           FLAG
      STB A,I 
      CCB           RECOVER ORGIONAL
      ADB T2DIM     F.A 
      STB F.A       F.A=ORIGONAL F.A
      LDA ARR 
      JSB DIU.F     DEFINE F.IU=ARR 
      JMP IND.F,I 
      SPC 1 
K3    DEC 3 
K14   DEC 14
T0DIM BSS 1         SET T0 0(DUMMY) OR -1 
T2DIM BSS 1         SAVE F
K54   DEC 54
B50   OCT 50
NS    BSS 1         NUMBER OF SUBSCRIPTS
DIM   OCT 6000      F.AT = DIM
      SKP 
*         **********************
*         * INPUT LIST ELEMENT *
*         **********************
      SPC 1 
*     TO INPUT AN ITEM THAT CAN BE CONTAINED WITHIN A LIST AND INSURE 
*     THAT THE ITEM HAS NOT BEEN TYPED AS DUMMY OR SUBPROGRAM, AND
*     COMPUTE THE WORD OFFSET INTO THE ITEM (USING SUBSCRIPTS). 
*     CALLED ONLY BY THE DATA STATEMENT PROCESSOR.
* 
*     EXIT: F.A = A.T. ADDR OF ITEM.
*           (A) = WORD OFFSET FROM START OF ITEM. 
      SPC 1 
ILE.F NOP 
      JSB NDS.F     NON-DUMMY & NON-SUBPROGRAM TEST 
      LDA F.IU
      CPA ARR 
      JMP ILE01     F.IU=ARR
* 
      JSB TV.F      TAG VARIABLE
      CLA           SIMPLE VARIABLE, OFFSET = 0.
      JMP ILE.F,I   DONE. 
* 
ILE01 JSB ISP.F     INPUT SUBS. A>0: CONST, NO LOWER BOUNDS.
      JSB FA.F      FETCH ASSIGNS  (F.ND) 
      LDB NS        NO. OF SUBSCRIPTS 
      CMB,INB 
      ADB F.ND      (# DIM) - (# SUBS)
      LDA K38       (ERROR #) 
      SSB           MORE SUBS THAN DIMS ? 
      JSB ER.F      YES. ERROR. 
* 
      LDA F.D0+1    SAVE # WORDS/ELEMENT ACROSS CIO.F CALL. 
      STA T1ILE 
      LDA NS        (A) = # SUBS. 
      CCB           COMPUTE ADDR LAST SUBSCRIPT.
      ADB A         (# SUBS) - 1
      BLS           *2
      ADB DSTBL     (B) = ADDR LAST SUBSCR. 
      JSB CIO.F     COMPUTE ITEM OFFSET.
      LDA T1ILE     RESTORE F.DO (2ND WD ONLY)
      STA F.D0+1
      LDA F.CIO+1   (A) = OFFSET, ALWAYS ONE WORD (NON-EMA).
      JMP ILE.F,I   EXIT. 
* 
*                   THE SUBSCRIPT TABLE.
* 
DSTBL DEF *+1 
      BSS 14        MUST FOLLOW DSTBL.
* 
T1ILE NOP           TO SAVE F.D0 ACROSS CIO.F CALL. 
K38   DEC 38
      SKP 
*         *********************** 
*         * COMPUTE ITEM OFFSET * 
*         *********************** 
      SPC 1 
*     CIO.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE 
*     BASE OF THE ARRAY.  THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F .
* 
*     ENTRY: F.A = A.T. ADDR OF ITEM. 
*            (A) = # SUBSCRIPTS (MAY BE ZERO).
*            (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST)
*                  IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO.
*     EXIT:  F.CIO = TWO-WORD OFFSET IN INTERNAL FORM.
      SPC 1 
CIO.F NOP 
      STB T1CIO     SAVE ADDR LAST SUBSCR.
      CLB           INITIALIZE F.CIO = 0
      STB F.CIO 
      STB F.CIO+1 
      STB T0CIO     CLEAR OVERFLOW FLAG.
      CMA,INA,SZA,RSS  NEGATE # SUBS. 
      JMP CIO03     IF NONE, DONE. (CLEAR OFL & EXIT) 
* 
      STA T2CIO     ELSE SAVE AS LOOP COUNTER.
      JSB FA.F      SET UP:  F.D0 = # WDS PER ELEMENT.
      DLD F.D0      SAVE THAT.
      DST T5CIO 
      LDA T2CIO     -(#SUBS)
      CMA           (#SUBS)-1 
      ALS           *2
      ADA F.LUB     ADDR LOWER BOUND LAST SUBSCR. 
      STA T4CIO 
* 
*                   LOOP THRU SUBS & DIMS COMPUTING OFFSET. 
* 
CIO01 LDB T4CIO,I   F.A OF (NEGATED) LOWER BOUND. 
      JSB GCD.F     (A,B) = LOWER BOUND.
      ISZ T0CIO     NOT CONSTANT: SOMEONE GOOFED! 
      DST T6CIO     SAVE. 
      CLA           (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. 
      CLB 
      DLD T1CIO,I   SUBSCRIPT.
      JSB DAD.F     SUBTRACT LOWER BOUND. 
      DEF T6CIO 
      ISZ T0CIO     IF TOO BIG. 
      SSA           ALSO BAD IF NEGATIVE. 
      ISZ T0CIO 
      SKP 
      JSB DAD.F     ADD RUNNING SUM.
      DEF F.CIO 
      ISZ T0CIO     IF TOO BIG. 
      ISZ T2CIO     WAS THAT FIRST SUBSCR ? 
      RSS           NO. 
      JMP CIO02     YES. DONE.
* 
      DST F.CIO     SAVE CURRENT VALUE. 
      LDA T4CIO     BACK UP TO PREVIOUS DIMENSION.
      ADA KM2 
      STA T4CIO 
      DLD A,I       (B) = F.A OF ITS SIZE.
      JSB GCD.F     GET VALUE.
      ISZ T0CIO     IF NOT CONSTANT.
      JSB DMP.F     MULTIPLY PREV DIM SIZE BY 
      DEF F.CIO     CURRENT VALUE.
      ISZ T0CIO     IF TOO BIG. 
      DST F.CIO     SAVE. 
      LDA T1CIO     BACK UP TO PREVIOUS SUBSCR. 
      SZA           IF FORCED ZERO SUBSCR, DON'T CHANGE.
      ADA KM2 
      STA T1CIO 
      JMP CIO01     ARROUND WE GO 
* 
CIO02 JSB DMP.F     * # WORDS PER ELEMENT.
      DEF T5CIO 
      ISZ T0CIO     IF TOO BIG. 
      DST F.CIO     SAVE OFFSET.
      JSB NWI.F     COMPUTE F.D0 = TOTAL SIZE.
      DLD F.CIO     COMPUTE OFFSET - SIZE.
      JSB DSB.F 
      DEF F.D0
      ISZ T0CIO     IF OFL. 
      SSA,RSS       IF OFFSET >= SIZE,
      ISZ T0CIO     ALSO SET OVERFLOW.
      LDA T0CIO     OVERFLOW INDICATOR. 
CIO03 CLO 
      SZA           IF OVERFLOW OCCURED,
      STO           RETURN OVERFLOW=1.
      JMP CIO.F,I   DONE. F.CIO = OFFSET. 
* 
F.CIO OCT 0,0       COMPUTED ITEM OFFSET VALUE. 
T0CIO NOP           OVERFLOW FLAG.
T1CIO NOP           ADDR CURRENT SUBSCRIPT. 
T2CIO NOP           LOOP COUNTER. 
T4CIO NOP           ADDR F.A ENTRY CURRENT LOWER BOUND. 
T5CIO BSS 2         # WORDS PER ELEMENT.
T6CIO BSS 2         TEMP. 
* 
KM2   DEC -2
K39   DEC 39
DUM   OCT 5000      F.AT=5, RELATIVE WITHIN DUMMY LOC 
K8    DEC 8 
K19   DEC 19
K11   DEC 11
B72   OCT 72
B100  OCT 100 
      SKP 
*         ******************* 
*         * INPUT SUBSCRIPT * 
*         ******************* 
      SPC 1 
*     TO INPUT THE SUBSCRIPT LIST.
*     ENTRY: (A)=0  DIMENSIONS OF FORMAL PARAMETER. 
*               >0  SUBSCRIPTS, MUST BE CONSTANT. 
*               <0  DIMENSIONS OF NON-FORMAL, MUST BE CONSTANT. 
* 
*     EXIT:  NS=NO. OF SUBSCRIPTS 
*            S-TABLE: DIMENSIONS:  F.A'S OF LOWER & UPPER BOUNDS, 
*                       AS IN A.T.
*                     SUBSCRIPTS:  2-WORD VALUES OF SUBSCRIPTS. 
*              F.VDM: 100B IF ANY VARIABLE DIMENSIONS.
*              F.DIS:  40B IF ANY DOUBLE INTEGER BOUNDS.
* 
ISP.F NOP 
      STA T0ISP     T0ISP = INDICATOR OF ALLOWABLE SUBSCRIPTS.
      CLB 
      STB F.VDM     CLEAR VARIABLE DIMENSIONS FLAG. 
      STB F.DIS     AND DOUBLE INTEGER SUBSCRIPTING FLAG. 
      STB NS        NO. OF SUBSCRIPTS =0
      LDB DSTBL     T4ISP = S-TABLE POINTER.
      STB T4ISP 
      LDA B50       MUST BE FOLLOWED BY '('.
      JSB TCT.F 
* 
*                   START OF SUBSCRIPT INPUT LOOP.
* 
ISP01 CCA           SET T3ISP TO -1 TO INDICATE THAT
      STA T3ISP     LOWER BOUND MAY BE ALLOWED HERE.
ISP02 LDA T0ISP     RESTORE (A) 
      SZA 
      JMP ISP06     DIMENSIONS NOT DUMMY. 
* 
      JSB EXN.F     EXAMINE NEXT CHARACTER
      SOC           LETTER ?
      JMP ISP06     NO. CHARACTER IS A DIGIT OR DELIMITER.
      SKP 
*                   INPUT VARIABLE DIMENSION. 
* 
      JSB IOP.F     INPUT THE 
      JSB TV.F      DIMENSION 
      JSB NCT.F     MUST NOT BE A CONSTANT
      LDA F.VDM     SET THE VARIABLE DIMENSIONS FLAG. 
      IOR B100
      STA F.VDM 
      LDA F.AT      MUST BE FORMAL PARAMETER, 
      CPA DUM 
      RSS 
      CPA COM       OR IN COMMON, 
      RSS 
      CPA BCOM      OR IN LABELLED COMMON.
      JMP ISP10 
* 
      LDA K39       NON-DUMMY DIMENSION VARIABLE
      JSB ER.F      NAME USED WITH DUMMY ARRAY NAME 
* 
*                   INPUT A CONSTANT DIMENSION OR SUBSCRIPT.
* 
ISP06 JSB IDN.F     INPUT DNA 
      JSB SDI.F     SHORTEN IF DOUBLE.
      JSB ITS.F     INTEGER TEST
      LDA K19 
      LDB F.NT      IS IT A CONSTANT? 
      SZB,RSS 
      JSB ER.F      NO. LOSE. 
      LDA T0ISP     ARE WE DOING SUBSCRIPT OR DIMENSION ? 
      CMA,SSA,INA,SZA  SUBSCRIPT OR DIMENSION ? (SKIP IF <=0) 
      RSS           SUBSCRIPT. SKIP.
      JMP ISP09     DIMENSION. GO CHECK OUT LOWER BOUNDS. 
* 
*                   SUBSCRIPT.  PUT CONSTANT VALUE IN S-TABLE.
* 
      LDA F.IM      CONSTANTS ONLY.  1/2 WORD INT ? 
      ELA           E=1 IFF INT*4 
      DLD F.IDI     (A,B) = CONST IF INT*4 (ELSE IS (A) ONLY) 
      SEZ           WHICH ? 
      JMP ISP08     INT*4, GOT IT.
* 
      LDB A         INT*2, EXTEND IT. 
      ASR 16
      SWP 
ISP08 DST T4ISP,I   PUT IN S-TABLE. 
      ISZ T4ISP 
      ISZ T4ISP 
      JMP ISP20     GO LOOK FOR ',' OR ')'. 
      SKP 
*                   DIMENSION, LOWER BOUNDS ALLOWED.
* 
ISP09 JSB AI.F      ENTER CONSTANT IN A.T.
      LDB F.A       GET ITS VALUE.
      JSB CFC.F 
      NOP           (CAN'T HAPPEN)
      LDB F.IM      AND ITS TYPE. 
      CPA B100K     IF (UPPER) BITS = 100000, 
      LDB DBI       THEN ALWAYS TREAT AS DBI, 
      LDA F.CCW     UNLESS 'S' OPTION.
      RAL 
      SSA 
      LDB F.IM
      LDA B40       F.DIS BIT      (CAN'T BE EMAP L.B.) 
      CPB DBI       CONSTANT DOUBLE INT BOUND OR -32768 ? 
      STA F.DIS     YES. SET THE F.DIS BIT. 
ISP10 LDA F.A       (A) = F.A OF BOUND. 
      ISZ T3ISP     DO WE ALREADY HAVE A LOWER BOUND ?
      JMP ISP12     YES. CAN'T HAVE ANOTHER.
* 
      LDB F.TC      NO. IS THIS A LOWER BOUND ? 
      CPB B72       I.E., FOLLOWED BY ':' ? 
      RSS 
      JMP ISP11     NO. GO SET LOWER BOUND = 1. 
* 
      STA T4ISP,I   YES. SET LOWER BOUND IN PLACE,
      ISZ T4ISP     ADVANCE TO UPPER BOUND, 
      JMP ISP02     AND GO GET THAT.
* 
ISP11 STA T5ISP     NO LOWER BOUND. SAVE F.A OF UPPER WHILE.. 
      CLA,INA       WE INVENT A LOWER BOUND = 1,
      JSB EIC.F 
      STA T4ISP,I   PUT IN S-TABLE, 
      ISZ T4ISP     AND BUMP TO PLACE FOR UPPER BOUND.
      LDA T5ISP     NOW (A) = F.A OF UPPER BOUND. 
ISP12 STA T4ISP,I   PUT UPPER BOUND IN S-TABLE. 
      ISZ T4ISP 
* 
*                   VERIFY THAT UPPER BOUND >= LOWER BOUND. 
* 
      LDB T4ISP     FETCH LOWER BOUND IF CONSTANT.
      ADB KM2 
      LDB B,I       (B)=F.A OF LOWER BOUND. 
      JSB GCD.F     WELL ?
      JMP ISP20     NOT CONST.
* 
      DST T6ISP     CONSTANT. SAVE IT.
      CCB           FETCH UPPER BOUND IF CONSTANT.
      ADB T4ISP 
      LDB B,I       (B)=F.A OF UPPER BOUND. 
      JSB GCD.F     WELL ?
      JMP ISP20     NOT CONST.
* 
      JSB DSB.F     CONST.  TAKE:  (UPPER)-(LOWER)
      DEF T6ISP 
      JMP ISP99     OVERFLOW.  TOO BIG. 
* 
      SSA           LOWER > UPPER ? 
      JMP ISP90     YES. CAN'T HAVE THAT EITHER.
* 
      SZA           SIZE > 65536 ?
      JMP ISP15     YES. ALWAYS DOUBLE INTEGER. 
* 
      LDA F.CCW     NO. IS 'S' OPTION SET ? 
      RAL 
      SSA,RSS       IF SO, <= 65536 IS SINGLE.
      SSB,RSS       ELSE   <= 32768 IS SINGLE.
      JMP ISP20     SINGLE. 
* 
ISP15 LDA B40       DOUBLE INTEGER DIM, SET THE BIT.
      STA F.DIS     SET F.DIS 
* 
*                   BUMP # SUBSCRIPTS, CHECK FOR END. 
* 
ISP20 ISZ NS
      LDA NS        AT LIMIT
      CPA K7        OF 7 DIMENSION ?
      JMP ISP22     YES.
* 
      LDA F.TC      NO. MORE ?
      CPA B54       I.E., DELIMETER IS ',' ?
      JMP ISP01     YES. GET ANOTHER. 
* 
ISP22 JSB RP.F      NO. MUST END WITH ')' . 
      JMP ISP.F,I   DONE. 
* 
ISP90 LDA K11       LOWER BOUND > UPPER BOUND.
      JSB ER.F
* 
ISP99 LDA K84        DIMENSION OVERFLOW.
      JMP F.ABT 
      SPC 2 
K84   DEC 84
T0ISP NOP           SAVE ENTRY (A) VALUE
T3ISP NOP           LOWER BOUND FLAG. 
T4ISP NOP           S-TABLE POINTER.
T5ISP NOP           TEMP FOR F.A OF UPPER.
T6ISP BSS 2         TEMP FOR VALUE OF UPPER.
      SKP 
*         ********************
*         * COMMON PROCESSOR *
*         ********************
      SPC 1 
*                   IF UNLABELLED, GO FIND LAST ELEMENT.
* 
F.COM CLA,INA 
      STA F.DCF     SET COMMON FLAG 
      CLA           CLEAR THE EMA FLAG. 
      STA T1COM 
      JSB EXN.F     EXAMINE NEXT CHAR.
      CPA B57       '/' ? 
      RSS           YES, PROBABLY LABELLED. 
      JMP COM07     NO, BLANK.
* 
COM03 JSB ICH.F     READ THE '/'. 
COM04 JSB EXN.F     LOOK FOR ANOTHER. 
      CPA B57       IS IT '//' ?
      JMP COM06     YES, BLANK. 
* 
*                   LABELLED.  PROCESS LABEL. 
* 
      JSB IDN.F     INPUT COMMON LABEL. 
      LDB F.NT      MAKE SURE IT'S A NAME.
      SZB,RSS         I.E., F.NT=0
      SZA,RSS         AND F.IM#0. 
      JMP COM09     IF NOT. 
      STB F.IM      YES. SET F.IM=0,
      ISZ F.LCF     AND SET FLAG FOR AI.F . 
      JSB AI.F      ENTER IN ASSIGNMENT TABLE.
      LDA F.AT      GET ITS TYPE
      CPA BCOMI     IF ALREADY BCOMI THEN 
      JMP COM08     ADDING TO EXISTING LABEL
* 
      LDA BCOMI     DEFINE F.AT 
      JSB DAT.F     TO BCOM 
      JSB TS.F      FLAG AS A SUBROUTINE (IT IS EXTERNAL) 
      LDA F.A       NOW REDEFINE F.AF 
      JSB DAF.F     (TS.F SETS IT TO ZERO)
COM08 LDA F.EM      SAVE EMA FLAG.
      STA T1COM 
      LDB F.A       SET FOR TRACK DOWN
      LDA F.TC      DO WE HAVE THE PROPER DELIMITER?
      CPA B57       WELL  '/' 
      JMP COM10     GOOD  GO TRACK DOWN THE END OF TH LIST
* 
COM09 LDA K4        ERROR WRONG DELIMITER, CONSTANT 
      JSB ER.F      OR MORE THAN 6 CHAR. ABANDON THE STMT.
      SKP 
*                   CHAIN THRU COMMON LIST TO FIND END. 
* 
COM06 JSB ICH.F     READ THE SECOND / IN // 
COM07 LDB F.BCM     SET UP BLANK COMMON HEADER. 
COM10 STB CT01      SET HEAD
COM11 STB CT02      SET CURRENT ADDRESS 
      JSB FL.F      FETCH LINK
      CPA CT01      POINT AT HEAD?
      JMP COM12     YES  THIS IS IT 
      STA B         NO  AROUND
      JMP COM11       WE GO.
* 
*                   GET AND CHECK OUT VARIABLE NAME.
* 
COM12 JSB INM.F     GET THE VARABLE NAME
      JSB NDS.F     NON-DUMMY & NON-SUBPROGRAM TEST.
      LDA F.A       UP DATE 
      STA LCOM      LAST COMMON 
      LDA K36       SEE IF ALREADY IN COMMON. 
      LDB F.AT
      CPB COM 
      JSB ER.F      ILLEGAL USE OF COMMON NAME
      CPB BCOM      IF ALREAD IN COMMON 
      JSB ER.F      ILLEGAL TO RE-ENTER IT. 
      LDA F.IU      IF NOT YET TAGED
      SZA,RSS       TAG 
      JSB TV.F      TAG AS VARIABLE 
      LDA T1COM     IF EMA COMMON,
      SZA 
      JSB DEM.F     SET EMA.
* 
*                   IF LABELLED, BUILD & LINK-IN A BCOMI ENTRY. 
* 
      LDB CT01      LABELLED ?
      LDA COM       (A=F.AT FOR BLANK)
      CPB F.BCM 
      JMP COM13     BLANK. SKIP THIS. 
* 
      LDA BCOMI     SET F.AT. = BCOMI FOR AI.F
      STA F.AT. 
      JSB AI.F      BUILD BCOMI ENTRY. (USES F.EM)
      LDA CT01      TO DESCRIBE IT
      LDB F.A       SET POINTER 
      ADB K2        TO
      STA B,I       THE MASTER ENTRY
      LDB LCOM      EXCHANGE LINKS
      JSB EL.F        OF (F.A)=BCOMI, (B)=ITEM. 
      LDA BCOMI     SET F.AT TO 
      JSB DAT.F     BCOMI 
      LDA LCOM      RESTORE 
      STA F.A       F.A OF THE VARABLE
      LDA BCOM      (A) = F.AT FOR BCOM.
      SKP 
*                   DEF F.AT, INPUT ANY DIM'S, LINK INTO LIST & GO ON.
* 
COM13 JSB DAT.F     DEFINE F.AT=COM OR BCOM 
      JSB FA.F      RESTORE ASSIGNS FOR DIM PROCESSOR 
      JSB IDC.F     INPUT DIMENSION (IF THERE)
      LDB CT02      EXCHANGE LINKS. 
      JSB EL.F        OF (F.A)=ITEM, (B)=PREV. ITEM.
      LDA F.TC      DELIMITER:
      CPA B57       IF "/", 
      JMP COM04     THEN START OF NEW BLOCK.
* 
      CPA B54       ELSE MUST BE COMMA, 
      RSS           (YES) 
      JMP F.CRT     OR END OF STATEMENT.
* 
      JSB EXN.F     COMMA.  FOLLOWED BY "/" ? 
      CPA B57 
      JMP COM03     YES. START OF NEW BLOCK.
* 
      LDA LCOM      NO. SET UP CT02 FOR NEXT ITEM.
      STA CT02
      JMP COM12     AND GO GET IT.
      SPC 1 
LCOM  BSS 1         LAST COMMON ASSIGNMENT POINTER
K36   DEC 36
COM   OCT 4000      F.AT=4 (COMMON) 
BCOM  OCT 3000      F.AT=BCOM 
BCOMI OCT 7000      F.AT=BCOMI
CT01  NOP 
CT02  NOP 
T1COM NOP           F.EM OF MASTER. 
K2    DEC 2 
K4    DEC 4 
B15   OCT 15
B57   OCT 57
      NOP           1ST COMMON ASSIGN PTR.
      DEF *-1       DUMMY LINK TO SELF
F.BCM DEF *-2       LINK TO DUMMY 
B40   OCT 40
      SKP 
*         ************************* 
*         * EQUIVALENCE PROCESSOR * 
*         ************************* 
      SPC 1 
*     ADDS EQUIVALENCE GROUPS TO THE EQUIVALENCE TABLE IN THE FORM: 
*         (-1)  (LINE#)  (ITEM#1),,,,,(ITEM#N)
*     WHERE THE ITEMS HAVE THE FORM:
*         (F.A) (#SUBS)  (LAST SUB),,,,(FIRST SUB)
*     (WHICH, SINCE THE EQUIVALENCE TABLE GROWS DOWNWARDS, PUTS 
*     THE SUBSCRIPTS IN FOREWARDS ORDER FOR CIO.F PROCESSING.)
*     AND ITEMS WITHOUT SUBSCRIPTS ARE PADDED WITH ONE EXTRA
*     WORD (LEAVING ROOM FOR 2-WORD OFFSET LATER).
      SPC 1 
F.EQU LDA F.E       COPY F.E
      STA T2GRE     (WILL UPDATE AFTER A GOOD GROUP)
EQU01 JSB ICH.F     REQUIRE '(' 
      CPA B50 
      CCA,RSS       (A=-1)
      JMP EQU90     NO. ERROR.
* 
      JSB GREW2     WRITE (-1). 
      LDA F.LNN     WRITE (LINE #)
      JSB GREW2 
* 
EQU02 JSB ISY.F     GET SYMBOL. 
      LDA F.A       WRITE (F.A) 
      JSB GREW2 
      JSB NDS.F     MUST NOT BE DUMMY OR SUBROUTINE.
      CLA           DEFAULT IS ZERO-DIM.
      STA NS
      LDB F.TC      ANY SUBSCRIPTS ?
      CLA,INA       (MUST BE CONSTANT)
      CPB B50       WELL ?
      JSB ISP.F     YES. GET THEM.
      LDA NS        (A) = # OF SUBSCR.
      JSB GREW2     WRITE (# SUBS)
      SZA,RSS       ANY SUBSCRIPTS ?
      JMP EQU04     IF NONE.
* 
      ALS           2*(# SUBS)
      ADA DSTBL     LWA+1 SUBSCRIPT LIST. 
EQU03 ADA KM2       GO BACK TO PREV. SUBSCR.
      STA T1EQU 
      INA           WRITE 2ND WORD FIRST. 
      LDA A,I 
      JSB GREW2     2ND WORD. 
      LDA T1EQU,I   FIRST WORD. 
      JSB GREW2 
      LDA T1EQU     WAS THAT THE FIRST ONE ?
      CPA DSTBL 
      JMP EQU05     YES. DONE.
      JMP EQU03     NO. KEEP GOING. 
* 
EQU04 JSB GREW2     NO SUBSCR. LEAVE EXTRA WORD.
* 
EQU05 LDA F.TC      MORE IN THIS GROUP ?
      CPA B54       (IE COMMA)
      JMP EQU02     YES. DO THEM. 
* 
      JSB RP.F      REQUIRE ')' 
      LDB T2GRE     MAKE THE GROUP PERMANENT. 
      STB F.E 
      CPA B54       ANOTHER GROUP ? 
      JMP EQU01     YES. DO IT. 
* 
      CPA B15       END ? 
      JMP F.CRT     YES. ALL DONE.
* 
EQU90 LDA K28       SYNTAX ERROR IN EQUIVALENCE.
      JSB ER.F      DOWN THE TUBES. 
* 
T1EQU NOP 
* 
*                   SUBROUTINES TO READ & WRITE 'DO' STACK. 
* 
GRER2 NOP           READ EQUIV TABLE INTO (A) USING (T2GRE) 
      CCB           BACK UP T2GRE.
      ADB T2GRE 
      STB T2GRE 
      LDA B,I       (A) = DATA. 
      JMP GRER2,I   EXIT. 
* 
GREW2 NOP           WRITE (A) INTO EQUIV TABLE USING (T2GRE)
      LDB F.LO      TOP OF A.T. + 1 
      CMB           -F.LO-1   (F.LO: MIN ALLOWABLE F.E) 
      ADB T2GRE     (T2GRE-1)-F.LO
      SSB           NEW T2GRE < F.LO ?
      JMP F.OFE     YES, MEM OVERFLOW.
* 
      ADB F.LO      NEW T2GRE = T2GRE-1 
      STB T2GRE 
      STA B,I       STORE DATA. 
      JMP GREW2,I   EXIT. 
* 
T2GRE NOP           POINTER INTO DO STACK.
      SKP 
*         **********************
*         * FUNCTION PROCESSOR *
*         **********************
      SPC 1 
F.FUN CLA           CLEAR EXPLICIT TYPING FLAG. 
      STA F.MFL 
FUN01 CLA,INA       SET FUNCTION FLAG.
      STA F.SFF 
      JMP SUBP0     START IT UP.
      SPC 1 
*         ************************
*         * SUBROUTINE PROCESSOR *
*         ************************
      SPC 1 
F.SUB CLA           CLEAR EXPLICIT TYPING FLAG. 
      STA F.MFL 
SUBP0 LDB F.LSF     1ST STATEMENT?
      SZB 
      JMP SUBP1     YES 
* 
NFSTM LDA K34 
      JSB ER.F      PROG/SUBR/FUNCTION NOT 1ST STATM
      SPC 1 
K7    DEC 7 
K34   DEC 34
      SPC 1 
SUBP1 CLA           SET STMT. LEVEL BACK TO ZERO
      STA F.SPF     INCASE IT IS A TYPED FUNCTION 
      LDA K7        SUBR/FUNC = TYPE 7
      STA F.PTY 
      ISZ F.DCF     SET DIM,COM FLAG TO FOOL AI.F IN CASE OF '('
      JSB INM.F     INPUT NAME
      JSB SPN.F     SET THE PROGRAM NAME. 
      LDB F.A 
      STB F.SBF     SET SUBPROGRAM FLAG 
      CLA           SET F.AF=0
      JSB DAF.F     TO TERMINATE FORMALS LINKED LIST. 
      LDA F.MFL     MODE FLAG SET?
      LDB A 
      IOR K8        SET EXPLICIT TYPE FLAG
      SZB           TYPE BEING SET? 
      JSB DIM.F     YES. DEFINE F.IM
      LDA F.TC
      CPA B54       STRING AFTER? 
      JMP SUBP6     YES GO HANDLE 
* 
      CPA B15 
      JMP SUBP6     F.TC=C/R: NO ARGUMENTS. 
* 
      JSB IDL.F     INPUT DUMMY LIST. 
      LDB F.SBF     RESTORE F.A OF SUBR/FUCT, 
      STB F.A 
      JSB DAF.F     SO CAN SET F.AF = F.A OF 1ST FORMAL.
SUBP4 LDA F.DO      INITIALIZE ?????????????????????
      STA F.D         F.D=F.DO
      JMP PROG9     C/R TEST
      SPC 1 
SUBP6 LDB F.SFF     FUNCTION? 
      LDA B52 
      SZB 
      JSB WAR.F     YES. WARNING 42: NO ARGUMENT LIST 
      JMP SUBP4 
      SKP 
*                   **********************************
*                   * BLOCK DATA STATEMENT PROCESSOR *
*                   **********************************
* 
F.BLK LDA K2        SET PROGRAM TYPE SWITCH 
      STA F.SFF     TO 2
      LDA F.LSF     TEST IF FIRST STATEMENT 
      SZA,RSS       WELL? 
      JMP NFSTM     NO GO BITCH 
* 
      LDA K7        SET UP TO INPUT 
      STA F.PTY     PROGRAM NAME
      JSB IDN.F     INPUT POSSIBLE BLOCK DATA NAME
      LDA F.NT      GET ONE?
      SZA 
      JMP PROG1     NO  BITCH 
* 
      JMP PROG9     GO TEST FOR PRAM STRING.
      SPC 3 
*        ******************** 
*        * SET PROGRAM NAME * 
*        ******************** 
      SPC 1 
SPN.F NOP 
      JSB NTI.F     MOVE NID TO F.IDI 
      LDA F.DID 
      JSB MPN.F     MOVE PROG NAME TO PBUF,ERBF,HEAD
      JMP SPN.F,I   EXIT. 
      SPC 1 
T1PRO BSS 1         TO SAVE PBUF POINTER. 
T2PRO BSS 1 
T3PRO BSS 1 
K35   DEC 35
K93   DEC 93
BL2B  ASC 1,
      SKP 
*         ******************************* 
*         * PROGRAM STATEMENT PROCESSOR * 
*         ******************************* 
* 
*     READ "PROGRAM PNAME,(TYPE,PRIOR,RES,EMULT,HR,MIN,SEC,MS)" 
*     TEXT FOLLOWING ")" TO EXTEND NAM RECORD 
      SPC 1 
F.PRO LDA F.LSF     1ST STATEMENT?
      SZA,RSS 
      JMP NFSTM     NO, ERROR 
      LDA K4
      STA F.PTY     DEFAULT LG BKGND DISK RESIDENT
      JSB EXN.F     EXAMINE NEXT CHAR.
      SZB,RSS       DIGIT?
      JMP PROG1     YES. LOSE.
      CPA B15       'C/R' 
      CLA,INA,RSS 
      JMP PROG4 
      STA F.CC    F.CC=1
      JMP PROG6 
      SPC 1 
PROG1 LDA K24 
      JSB ER.F      ILLEGAL CONSTANT. 
      SPC 1 
PROG4 JSB IDN.F     INPUT PROGRAM NAME
      SZA           IF NO NAME F.IM=0 
      JSB SPN.F     NAMED. SET THE PROGRAM NAME.
      LDA F.TC
      CPA B50       '(' 
      JMP PROG7 
      CPA B54       ',' 
      JMP PROG7 
PROG6 JMP F.CRT     C/R TEST
      SPC 1 
PROG7 LDA F.DNB     ADDR OF PBUF+9
      ADA K9
      STA T1PRO     PARAM POINTER 
      ADA K8        SET UP THE NAM BUFFER STOP
      STA T2PRO     POINTER 
PROG8 JSB EXN.F     EXAMINE NEXT CHARACTER
      SZB,RSS       DIGIT?
      JMP PROG2     YES.
      JSB ICH.F     NO. READ IT FOR REAL. 
      CPA B54       F.TC = ',' ?
      RSS 
      JMP PROG3 
      ISZ T1PRO     NO. NULL PARAM. 
PROGA LDB T2PRO     LOC OF PBUF+17
      CPB T1PRO     ALL PARAMS READ?
      JMP PROG3     YES.
      JMP PROG8 
      SPC 1 
PROG2 JSB IDN.F     INPUT DO NOT ASSIGN 
      JSB SDI.F     SHORTEN IF DOUBLE INTEGER.
      LDB F.IM      MUST BE SINGLE INTEGER NOW. 
      LDA K14       ELSE ERROR 14.
      CPB INT 
      RSS           O.K.
      JSB ER.F
* 
      LDA F.IDI     DIGIT STRING JUST INPUT 
      STA T1PRO,I   STORE INTO PBUF 
      ISZ T1PRO     BUMP PBUF POINTER 
      LDA F.TC
      CPA B54       ',' 
      JMP PROGA 
PROG3 CPA B51       ")" ? 
      JSB ICH.F     GET THE NEXT CHARACTER
PROG9 LDA F.TC      DELIMETER ? 
      CPA B54       IF COMMA THEN 
      RSS           SET UP NAM RECORD COMMENT 
      JMP PRO12     NOT COMMA  MUST BE CARRAGE RETURN 
* 
      LDA F.DNB     SET UP TO ACCESS THE NAM BUFFER 
      ADA K17 
      STA T2PRO     ADDRESS OF WORD 17
      LDA K35 
      STA T3PRO     CHARACTER COUNT 
PRO10 JSB IC.F
      CPA B15 
      JMP PRO12     END OF STMT.
* 
      LDB T3PRO 
      CPB K121      IF NO MORE ROOM,
      JMP PRO11     TEST FOR ALL BLANKS.
* 
      SLB,INB 
      ALF,SLA,ALF 
      XOR T2PRO,I 
      XOR B40       INSERT/REMOVE BLANK 
      STA T2PRO,I   STUFF CHAR IN NAM REC 
      STB T3PRO 
      SLB,BRS 
      ISZ T2PRO     BUMP POINTER
      CPA BL2B      IF TRAILING BLANKS, 
      JMP PRO10     DON'T UPDATE WORD COUNT.
* 
      STB F.DNB,I   ELSE UPDATE WORD COUNT, 
      JMP PRO10     AND GO FOR MORE.
* 
PRO11 CPA B40       87TH CHAR: IF BLANK,
      JSB ICH.F     LOCATE NEXT NON-BLANK (ERROR IF ANY)
PRO12 LDB F.PTY     NOW CHECK PROG TYPE.
      LDA K61 
      CPB K5        IF TYPE = 5,
      JSB WS1.F     ISSUE A SEGMENT START OPCODE. 
      JMP F.CRT     MUST NOW BE END OF STMT.
* 
K26   DEC 26
K121  DEC 121 
K61   DEC 61
K72   DEC 72
      SKP 
*         ******************
*         * DATA PROCESSOR *
*         ******************
      SPC 1 
*                   CAUTION: F.SPS IS NOT ALWAYS SET. 
*                   INITIALIZE DO TABLE FOR LIST ITEMS. 
* 
F.DAT LDA F.DO      SET TO WRITE INTO DO TABLE. 
      STA T2GRE 
* 
*                   NEXT LIST ITEM: GET SYMBOL & DO ERROR CHECKING. 
* 
DATA0 JSB ISY.F     INPUT SYMBOL
      JSB NDS.F     CAN'T BE DUMMY OR SUBROUTINE. 
      LDA F.IU      IF NOT ARRAY, 
      CPA ARR 
      RSS 
      JSB TV.F      MUST BE VARIABLE. (REQ'D FOR AA.F)
      LDA K93 
      LDB F.EM      EMA ? 
      CLE,SZB       (E=0) 
      JSB ER.F      YES. CAN'T DO EMA.
      LDB F.SFF     BLOCK DATA ?
      CPB K2
      CME           YES. MUST BE LABELLED COMMON. 
      LDA K72       (ERROR NUMBER FOR COMMON) 
      LDB F.AT      HOW 'BOUT BLANK COMMON ?
      CPB COM 
      JSB ER.F      YUP. IT NEITHER.
      CPB BCOM      LABELLED COMMON ? 
      CME           YES. MUST BE BLOCK DATA.
      SEZ           EITHER OF ABOVE VIOLATED ?
      JSB ER.F      YES. ERROR 72.
      CPB BCOM      IF NOT BLOCK COMMON,
      RSS 
      JSB AA.F      ASSIGN VARIABLES NOW. 
* 
*                   IF ARRAY NAME ONLY, USE WHOLE ARRAY,
*                   OTHERWISE USE SIMPLE ITEM OR ARRAY ELEMENT. 
* 
      LDA F.IU      ITEM USAGE. 
      LDB F.TC      NEXT CHAR.
      CPA ARR       IF NOT ARRAY, 
      CPB B50       OR ARRAY AND FOLLOWED BY '(', 
      JMP DATA1     THEN JUST DO SIMPLE ITEM. 
* 
      JSB NWI.F     ELSE WHOLE ARRAY. SET F.D0 = # WORDS. 
      CLA,RSS       (A) = OFFSET = 0. 
DATA1 JSB ILE.F     INPUT LIST ELEMENT: (A) = OFFSET. 
      SKP 
*                   SAVE THE OFFSET, F.A & # WORDS IN DO TABLE. 
* 
      JSB GREW2     OFFSET. 
      LDA F.A       F.A 
      JSB GREW2 
      LDA F.D0+1    NUMBER OF WORDS PER ITEM
      JSB GREW2 
* 
*                   IF ',' THEN READ MORE ITEMS, ELSE READ '/' & DATA.
* 
      LDA F.TC
      CPA B54       , ? 
      JMP DATA0     YES. GET MORE VARIABLES.
* 
      LDA B57       ELSE MUST BE '/'
      JSB TCT.F     F.TC-TEST 
      LDA T2GRE     REMEMBER END OF DO TABLE. 
      STA T3DAT 
      CLA           START READING VALUES: 
      STA KBAR      REPEAT COUNT = 0  (NONE)
      STA T2DAT     # WDS LEFT CURRENT ITEM = 0.
      LDA F.DO      SET UP TO READ LIST BACK. 
      STA T2GRE 
* 
*                   READ ANOTHER LIST ITEM. 
* 
DATA6 LDA T2DAT     ANY LEFT IN CURRENT ITEM ?
      SZA 
      JMP DATA4     YES, DO THAT FIRST. 
* 
      JSB GRER2     T4DAT = OFFSET. 
      STA T4DAT 
      JSB GRER2     F.A = ITEM. 
      STA F.A 
      JSB GRER2     T2DAT = # WORDS IN ITEM.
      STA T2DAT 
      JSB FA.F      FETCH ITEM ASSIGNS. 
      LDA F.IM      T0DAT = LIST ITEM MODE. 
      STA F.EIM     (SET UP FOR IDN.F: DBL VS RE8)
      STA T0DAT 
      LDA KBAR      UNFINISHED REPEAT COUNT ? 
      SZA 
      JMP DAT13     YES. USE THAT CONSTANT. 
      SKP 
*                   READ ANOTHER DATA VALUE.
* 
DATA4 JSB EXN.F     IS IT A QUOTED STRING ? 
      CPA B47 
      JMP DAT30     YES. DONE ELSEWHERE...
* 
      JSB IDN.F     INPUT DO NOT ASSIGN 
      SZA 
      JMP DATA5     F.IM .NE. 0, GOT ONE. 
* 
      LDA B50       '('  OTHERWISE, MUST BE COMPLEX CONSTANT. 
      JSB TCT.F     F.TC-TEST 
      ISZ F.SXF     SET COMPLEX FLAG. 
      JSB IDN.F     TRY AGAIN.
      CPA CPX       COMPLEX ? 
      RSS 
      CPA ZPX       OR DOUBLE COMPLEX ? 
      RSS           YES. (IF NAME, CAUGHT LATER)
      JMP ERDAT     NO. GENERAL TYPE MISMATCH ERROR.
* 
*                   MAKE SURE IT'S A CONSTANT.  IF FOLLOWED BY '*', 
*                   PROCESS THE REPEAT COUNT. 
* 
DATA5 LDA B54 
      LDB F.NT
      SZB,RSS 
      JSB ER.F      ERR 44: NAME IN CONSTANT LIST.
      JSB SDI.F     ALWAYS USE SHORT INTEGERS IF POSSIBLE.
      LDB F.TC      B=NEXT CHAR 
      LDA KBAR      ALREADY HAVE REPEAT ? 
      SZA 
      JMP DAT04     YES. DON'T CHECK FOR ANOTHER. 
* 
      ISZ KBAR      NO. SET KBAR=1 IN CASE NO REPEAT. 
      CPB B52       WELL ?
      RSS           YES. PROCESS IT.
      JMP DAT04     NO. USE REPEAT = 1. 
* 
      LDB F.IM      REPEAT MUST BE SINGLE INTEGER.
      LDA K26       ELSE ERROR 26.
      CPB INT 
      RSS 
      JSB ER.F      NO, ERROR.
* 
      LDB F.IDI     SET KBAR = REPEAT COUNT.
      STB KBAR
      SSB,RSS       MAKE SURE REPEAT > 0. 
      SZB,RSS       WELL ?
      JMP ERD71     NEGATIVE OR ZERO, ERROR.
      JMP DATA4     YES. GO GET REPEATED DATA.
* 
B47   OCT 47        SINGLE QUOTE. 
ZPX   OCT 140000    F.IM = ZPX
      SKP 
*                   CHECK FOR HOLLERITH DATA. IF SO, SET T5DAT = -COUNT.
* 
DAT04 LDA F.IM      SAVE F.IM OF CONSTANT.
      STA T1DAT 
      CLA           SET T5DAT=0,
      STA T5DAT     THE HOLLERITH DATA LENGTH.
      CPB B110      F.TC = 'H' ?
      RSS           YES.
      JMP DAT13     NO. NOT HOLLERITH.
* 
      LDB F.IM      YES. MUST BE SINGLE INTEGER.
      CPB INT 
      RSS           YES, O.K. 
      JMP ERDAT     ELSE ERROR. 
* 
      LDB F.IDI     AND > 0.
      LDA K20 
      CMB,SSB,INB,SZB  (NEGATE, SKIP IF WAS <= 0) 
      RSS           O.K.   (E=1)
      JSB ER.F      BAD HOLLERITH COUNT.  (ERR 20)
* 
      STB T7DAT     SAVE FOR LOOP COUNTER.
      BRS           - # WORDS HOLLERITH.
      STB T5DAT     SAVE AS FLAG. 
      ADB F.D0+1    MORE THAN ONE ELEMENT ? 
      SSB 
      JMP DAT15     YES. LONG HOLLERITH.
* 
*                   COPY SHORT HOLLERITH DATA TO F.IDI
* 
      LDA F.DID     NO. JUST COPY TO F.IDI
      RAL           (BYTE ADDR) 
      STA T6DAT 
      LDA BL2B      SET F.IDI TO BLANKS.
      STA F.IDI 
      STA F.IDI+1 
      STA F.IDI+2 
      STA F.IDI+3 
DAT14 JSB IC.F      COPY THE CHARACTERS.
      XOR B40       (CHANGES BLANK TO THE CHAR) 
      LDB T6DAT     (B) = CHAR ADDR TO PUT IT.
      CLE,SLB,ERB   (B) = WORD ADDR. HIGH OR LOW BYTE ? 
      RSS           LOW. LEAVE CHAR LOW.
      ALF,ALF       HIGH. MOVE IT UP. 
      XOR B,I       CHANGE BLANK TO THE CHAR. 
      STA B,I 
      ISZ T6DAT     BUMP ADDRESS. 
      ISZ T7DAT     BUMP COUNTER. 
      JMP DAT14     LOOP. 
* 
      JSB ICH.F     READ THE DELIMETER. 
      SKP 
*                   CHECK ITEM SIZE, MODE  VS.  DATA. 
* 
DAT13 LDA F.D0+1    ITEM SIZE.
      ADA T5DAT     - HOLLERITH SIZE. 
      SSA           IF HOLLERITH BIGGER,
      JMP ERDAT     SEND ERROR
* 
      LDA T5DAT     IF HOLLERITH, 
      SZA 
      JMP DATA9     THEN O.K. 
* 
      LDA T1DAT     ELSE MUST CHANGE
      STA F.IM      DOUBLE INTEGER
      JSB SDI.F     BACK TO SINGLE IF POSSIBLE, 
      LDA F.IM      SO THAT 
      STA T1DAT     AFTER REPEAT, DON'T FAIL. 
      CPA T0DAT     DOES TYPE MATCH ? 
      JMP DATA9     YES. O.K. 
* 
      ALF           IS MIXED SINGLE/DOUBLE INT ?
      IOR T0DAT     (A) = 4/ITEM TYPE, 8/0, 4/CONST TYPE. 
      CPA KK02      DBLINT / INT ?
      RSS           YES.
      JMP DAT11     NO. GO CHECK LOGICAL. 
* 
      LDB F.IDI     CHANGE CONST TO DOUBLE INT. 
      ASR 16
      SWP 
      DST F.IDI 
      LDA DBI       REMEMBER WE DID IT. 
      STA T1DAT 
      JMP DATA9     VOILA ! 
* 
DAT11 CPA KK05      LOG / DBLLOG ?
      RSS           YES. O.K. AS IS.
      JMP ERDAT     ALL ELSE IS BAD.
      SKP 
*                   START OUTPUT OF REGULAR DATA ITEM WITH REPEAT.
* 
DATA9 LDA F.D0+1    SEND OPERATOR.
      ADA K3        HAS F.A, OFFSET, REPEAT.
      ALF,ALF 
      IOR K51 
      JSB WS1.F 
      LDA F.A       F.A 
      JSB WS1.F 
      LDA T4DAT     OFFSET. 
      JSB WS1.F 
      CLB           COMPUTE # ITEMS LEFT IN ARRAY.
      LDA T2DAT 
      DIV F.D0+1    (A) = # ITEMS LEFT. 
      LDB KBAR      B = REPEAT LEFT 
      CMB,INB 
      ADB A         (#ITEMS) - (#CONST) 
      SSB,RSS       TAKE THE SMALLER OF THE TWO.
      LDA KBAR
      STA T6DAT     CAN SEND REPEAT OF THAT MANY. 
      LDB T5DAT     IF HOLLERITH, 
      SZB 
      IOR B100K     SET SIGN TO FLAG THAT.
      JSB WS1.F 
* 
*                   SEND THE DATA TO THE PASS FILE. 
* 
      LDA F.D0+1    THIS MANY WORDS.
      CMA,INA 
      STA T7DAT 
      LDA F.DID     FROM HERE.
      STA T8DAT 
DAT17 LDA T8DAT,I   COPY THEM.
      JSB WS1.F 
      ISZ T8DAT 
      ISZ T7DAT 
      JMP DAT17 
      JMP DAT08     DONE. GO UPDATE STATE.
      SKP 
*                   LONG HOLLERITH. MUST FILL PART OF AN ARRAY. 
* 
DAT15 CLB           SEE IF EXACT # OF ITEMS.
      LDA F.IDI 
      DIV F.D0+1
      SZB           I.E., REMAINDER = 0 ?  (OR QUOTIENT ODD)
      JMP ERD71     NO. ILLEGAL PARTIAL ITEM. 
* 
      LDB KBAR      REPEAT > 1 ?
      CPB K1
      CLE,SLA,ERA   (REST OF EXACT-MULTIPLE CHECK)
      JMP ERD71     YES. ERROR. 
* 
      LDA T2DAT     EXCEEDS SPACE LEFT IN ARRAY ? 
      ADA T5DAT 
      SSA 
      JMP ERD71     YES, ERROR. 
* 
*                   INITIALIZE, SEND DATA TO PAK.F
* 
      CCA           INITIALIZE PAK.F :
      LDB T4DAT     OFFSET. 
      JSB PAK.F 
* 
DAT16 JSB IC.F      COPY THE DATA TO THE BUFFER.
      JSB PAK.F 
      ISZ T7DAT     COUNT. DONE ? 
      JMP DAT16     NO. LOOP. 
* 
*                   FINISH UP & UPDATE OFFSET, AMT REMAINING. 
* 
      LDA KM2       FLUSH THE BUFFER. 
      JSB PAK.F     (B) SET TO (F.AF + T4DAT + #WDS OUTPUT) 
      CMB,INB       COMPUTE # WDS OUTPUT. 
      ADB T4DAT     (B) = -(# WDS OUTPUT) 
      LDA B         UPDATE OFFSET.
      CMA,INA       + # WDS.
      ADA T4DAT     T4DAT _ T4DAT + # WDS.
      STA T4DAT 
      ADB T2DAT     T2DAT = T2DAT - # WDS.
      STB T2DAT 
* 
      JSB ICH.F     GET DELIM.
      CLB           SET REPEAT = 0 & CHECK STATE. 
      JMP DAT09 
* 
K1    DEC 1 
K20   DEC 20
      SKP 
*                   QUOTED HOLLERITH CONSTANT.
* 
DAT30 JSB IC.F      READ THE QUOTE. 
      CLA           IF REPEAT = 0,
      CPA KBAR      (SKIPPED REGULAR CHECK) 
      ISZ KBAR      SET IT TO ONE.
      LDA KBAR      SET MAMIMUM SIZE: IF KBAR > 1,
      LDB F.D0+1    MAX SIZE IS SIMPLE ITEM SIZE, 
      CPA K1        ELSE
      LDB T2DAT     MAX SIZE IS SPACE REMAINING IN ITEM.
      BLS           CHANGE TO # CHARS,
      CMB           AND SET UP AS COUNTER.
      STB T7DAT     T7DAT = -(MAX # CHARS)-1
      CCA           SET UP PAK.F
      LDB T4DAT     OFFSET. 
      JSB PAK.F 
* 
*                   COPY STRING.
* 
DAT32 JSB IC.F      NEXT CHAR, INCL BLANKS. 
      CPA B47       QUOTE ? 
      RSS           (YES) 
      JMP DAT34     NO. 
* 
      JSB IC.F      YES. TWO IN A ROW ? 
      CPA B47 
      RSS           YES: TREAT AS ONE.
      JMP DAT36     NO. DONE. 
* 
DAT34 ISZ T7DAT     IS THAT ONE TOO MANY ?
      RSS 
      JMP ERD71 
* 
      JSB PAK.F     NO. SEND IT.
      JMP DAT32     AND GO FOR MORE.
* 
*                   END. BLANK FILL SINGLE ITEM (ALL IF AT /).
* 
DAT36 CPA B40       HAVE CHAR AFTER END; IF BLANK,
      JSB ICH.F     SKIP IT & READ NEXT NON-BLANK.
      LDA F.D0+1    COMPUTE # CHARS LEFT IN ITEM: 
      CLE,ELA 
      STA T5DAT     T5DAT = TOTAL # IN AN ITEM. 
      LDB T7DAT     (B) = -(# LEFT)-1 
      INB           -(# LEFT TOTAL) 
      LDA F.TC      AT END OF CURRENT DATA LIST (/) ? 
      CPA B57 
      JMP DAT40     YES. FILL WHOLE ITEM. 
* 
      ASR 16
      DIV T5DAT     (B) = REM = # TILL BOUNDARY.
DAT40 SZB,RSS       IF NONE,
      JMP DAT38     DON'T BOTHER. 
* 
      STB T5DAT     ELSE BLANK FILL.
DAT37 LDA B40 
      JSB PAK.F 
      ISZ T7DAT     THIS SHOULD NEVER SKIP (MAX = -1) 
      ISZ T5DAT 
      JMP DAT37 
* 
*                   FINISH UP REPEATED (SHORT) ITEM.
* 
DAT38 CLA,INA       IS IT REPEATED ?
      CPA KBAR
      JMP DAT39     NO. GO DO LONG VERSION. 
* 
      LDA F.DPK     SHORT. JUST COPY TO F.IDI 
      LDB F.DID 
      JSB .MVW
      DEF F.D0+1
      NOP 
      LDA F.D0+1    SET UP T5DAT AS HOLLERITH FLAG. 
      STA T5DAT 
      JMP DATA9     GO SEND IT WITH REPEAT COUNT. 
* 
*                   FINISH UP NON-REPEATED (POSSIBLY LONG) ITEM.
* 
DAT39 LDA KM2       NO. TERMINATE PAK.F 
      JSB PAK.F 
      CMB,INB       COMPUTE # WDS SENT. 
      ADB T4DAT     (B) = -(# WDS SENT) 
      LDA B         UPDATE OFFSET & # WDS LEFT. 
      CMA,INA 
      ADA T4DAT     T4DAT _ T4DAT + # WDS.
      STA T4DAT 
      ADB T2DAT     T2DAT _ T2DAT - # WDS.
      STB T2DAT 
      CLB           REPEAT = 0 NOW. 
      JMP DAT09     DONE. 
      SKP 
*                   UPDATE OFFSET, # WDS LEFT, REPEAT COUNT.
* 
DAT08 LDA T6DAT     THIS MAY ITEMS. 
      MPY F.D0+1    OF THIS SIZE. 
      LDB T4DAT     ADD TO OFFSET.
      ADB A 
      STB T4DAT 
      CMA,INA       SUBTRACT FROM # WDS LEFT IN ITEM. 
      ADA T2DAT 
      STA T2DAT 
      LDB T6DAT     UPDATE REPEAT COUNT.
      CMB,INB 
      ADB KBAR
DAT09 STB KBAR
      LDA F.TC      MORE DATA ITEMS ? 
      CPA B54       I.E., COMMA NEXT OR 
      INB           REPEAT WASN'T ZERO. 
      SZB,RSS       WELL ?
      JMP DAT20     OUT OF DATA. MUST BE OUT OF LIST. 
* 
      LDA T2DAT     MORE DATA. MUST BE MORE LIST. 
      LDB T2GRE 
      CPB T3DAT     IS LIST EXHAUSTED ? 
      SZA 
      JMP DATA6     NO. GO GET NEW LIST ITEM. 
      JMP ERD71     YES. MORE DATA THAN VARIABLES.
* 
DAT20 LDA T2DAT     OUT OF DATA. HOW 'BOUT LIST ? 
      LDB T2GRE 
      CPB T3DAT     ANY LEFT IN TABLE ? 
      SZA           OR IN ARRAY ? 
      RSS           YES. MORE VARIABLES THAN DATA.
      JMP DAT21     NO. O.K.
* 
      LDA K71       YES. WARNING, BUT NOT ERROR.
      JSB WAR.F 
* 
DAT21 LDA B57       MUST END WITH '/' 
      JSB TCT.F     TEST F.TC 
      JSB EXN.F     AT END OF STATEMENT ? 
      CPA B15         
      JMP DAT22     YES.
* 
      CPA B54       NO. IF OPTIONAL COMMA,
      JSB ICH.F     SKIP IT.
      JMP F.DAT     AND PROCESS NEXT LIST.
* 
DAT22 JSB ICH.F     READ C/R. 
      JMP F.CRT     AND FINISH STATEMENT. 
      SPC 2 
KK02  OCT 100001    DBLINT / INT
KK05  OCT 110003    DBLLOG / LOG
K51   DEC 51        DATA OPERATOR.
B110  OCT 110       "H" 
T0DAT NOP           SAVE F.IM OF LIST ELEMENT 
T1DAT NOP           SAVE F.IM OF DATA ELEMENT 
T2DAT NOP           SAVED END OF DO TABLE.
T3DAT NOP           SAVE # WORDS IN ARRAY 
T4DAT NOP           OFFSET INTO ARRAY.
T5DAT NOP           HOLLERITH COUNT.
T6DAT NOP           SCRATCH.
T7DAT NOP           SCRATCH.
T8DAT NOP           SCRATCH.
KBAR  NOP           REPEAT INDICATOR IN DATA PROCESSOR
* 
*                   ERROR IN DATA STATEMENT.
* 
ERD71 LDA K71       COUNT MISMATCH / BAD REPEAT COUNT.
      JSB ER.F
ERDAT LDA K73       ERROR 73. 
      JSB ER.F
* 
K71   DEC 71
B52   OCT 52
K73   DEC 73
* 
* 
      END F4.0
ASMB,Q,C
      HED RELATE COMMON, EQUIVALENCE, AND ASSIGN ARRAY PHASE. 
      NAM RCO.F,8 92834-16002 REV.2030 800727 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE:
* 
*       1) (RCO.F) COMPUTES OFFSETS OF ITEMS EXPLICITLY DECLARED TO 
*                  TO BE IN COMMON. 
*       2) (GREQU) RESOLVES THE EQUIVALENCE CLASSES AND ASSIGNS 
*                  ADDRESSES TO THEIR MEMBERS.
*       3) (APSEC) FOR NON-FORMAL ARRAYS, ASSIGNS ADDRESSES (IF NOT IN
*                  COMMON OR EQUIV GROUP) & COMPUTES OFFSET TO (0,0,0). 
* 
*     IT IS CALLED WHEN THE FIRST 'DATA' OR EXECUTABLE STATEMENT IS 
*     ENCOUNTERED.
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE.
   EXT     F.AF     ADDRESS FIELD CURREXT F.A 
   EXT     F.AT     ADDRESS TYPE OF CURREXT F.A 
   EXT     F.AT.    FLAG TO AI.F TO BUILD BCOMI OR DIM ENTRY. 
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CSZ    COMMON SIZE 
   EXT     F.D0     ARRAY ELEMEXT SIZE
   EXT     F.DIS    DOUBLE INTEGER SUBSCRIPT FLAG.
       EXT F.DO     LWAM - END OF DO TABLE
      EXT  F.E      EQUIVALENCE TABLE POINTER 
   EXT     F.EM     EMA FLAG BIT IN A.T.
       EXT F.EMS    EMA SIZE  DOUBLE WORD.
     EXT   F.EQE    EQUVALENCE ERROR FLAG 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
     EXT   F.LNN    LINE # OF CURRENT LINE. 
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
   EXT     F.LUB    ADDR OF LOWER/UPPER BOUNDS TABLE. 
   EXT     F.ND     NUMBER OF DIMENSIONS
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
       EXT F.RPL    PROGRAM LOCATION COUNTER
       EXT F.SBF    F.A OF PROG NAME IF SUBPROG.
       EXT F.SFF    SUBROUTINE/FUNCTION FLAG 0/1
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
       EXT AA.F     ASSIGN ADDRESS SUB. 
   EXT     AI.F     ASSIGN ITEM 
   EXT     CFC.F    CHECK FOR CONSTANT VALUE. 
   EXT     DAD.F    DOUBLE INTEGER ADD. 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DAT.F    DEFINE (AT) 
   EXT     DEM.F    DEFINE (F.EM) = 1.
   EXT     DMP.F    DOUBLE INTEGER MULTIPLY.
   EXT     DSB.F    DOUBLE INTEGER SUBTRACT.
   EXT     EIC.F    ESTABLISH INTEGER CONSTANT. 
   EXT     EJC.F    ESTABLISH DOUBLE INTEGER CONSTANT.  
     EXT   ER.F     ERROR PRINT SUBROUTINE
   EXT     ESC.F    ESTABLISH CONSTANT SUBROUTINE 
   EXT     FA.F     FETCH ASSIGNS 
       EXT FL.F     FETCH LINK OF (B).
   EXT     GCD.F    CHECK FOR & GET INT CONST, 2 WORDS. 
   EXT     GFA.F    GET FIRST (NAMED) SYMBOL TABLE ENTRY. 
   EXT     GNA.F    GET NEXT SYMBOL TABLE EXTRY 
   EXT     NAM.F    COPY SYMBOL NAME. 
     EXT   PCC.F    PRINT COMPILER COMMENT. 
     EXT   PSL.F    PRINT SOURCE LINE (IMMEDIATELY).
   EXT     TV.F     TAG VARIABLE. 
     EXT   WAR.F    ISSUE WARNING.
* 
*     EXTERNALS IN THE SEGMENT. 
* 
      EXT F.BCM     BLANK COMMON HEADER.
      EXT F.CIO     ITEM OFFSET (DOUBLE INTEGER)
* 
      EXT CIO.F     COMPUTE ITEM OFFSET.
* 
*     ENTRY IN THIS MODULE. 
* 
      ENT RCO.F 
      SPC 2 
A     EQU 0 
B     EQU 1 
      SUP 
      SKP 
*         ***************** 
*         * RELATE COMMON * 
*         ***************** 
RCO03 LDB F.BCM     END OF LABELED COMMON 
      CLA           CLEAR THE FLAG
      STA F.LCM 
      JMP RCO02     GO DO BLANK COMMON
* 
RCO04 LDA T1RCO     GET CURRENT MASTER ENTRY ADDRESS
      STA F.A       RESTORE IT FOR GNA.F
      CLA           SET UP TO ZAP THE F.AF OF THE MASTER
      LDB F.SFF     AND IF BLOCK DATA SUBPROGRAM
      CPB K2
      LDA T0RCO+1   SET F.AF OF MASTER TO SIZE
      JSB DAF.F     SET MASTER ENTRY F.A
      JSB CCS.F     CHECK SIZE. 
      LDA F.EM      GET EMA FLAG
      SZA,RSS       THIS THE EMA ENTRY? 
      JMP RCO01     NO, LOOK FOR NEXT BLOCK 
* 
      DLD T0RCO     YES, SAVE SIZE. 
      DST F.EMS 
      JMP RCO01     LOOK FOR NEXT BLOCK 
* 
RCO.F NOP 
      ISZ F.LCM     DO LABELED COMMON FIRST 
      JSB GFA.F     SEARCH A.T. FOR COMMON LABELS.
RCO01 JSB GNA.F 
      SZA,RSS       END OF TABLE??
      JMP RCO03     YES GO DO BLANK COMMON
* 
      LDA F.A,I     CHECK IF LABELED COMMON MASTER
      AND B7601     ISOLATE NT,AT,IU FIELDS 
      CPA B7200     IF NT=0 & AT=BCOMI & IU=SUB 
      RSS           THIS IS A MASTER ENTRY
      JMP RCO01     NOT SO  TRY NEXT ENTRY
* 
      LDB F.A       SAVE THE ADDRESS OF MASTER
RCO02 STB T1RCO     ENTRY 
      JSB FL.F      FETCH LINK
      STA T2RCO     T2RCO = LINK. 
      CLB           SET COMMON SIZE 
      STB T0RCO     TO ZERO 
      STB T0RCO+1 
RCO05 LDA T2RCO     GO TO NEXT ONE. 
      STA F.A       F.A=NEXT LINK 
      CPA T1RCO     END OF LIST?
      CLB,INB,RSS   YES SKIP OUT
      JMP RCOM2     NO DO NEXT ENTRY
* 
      CPB F.LCM     DOING LABELED COMMON??
      JMP RCO04     YES SET FOR NEXT ENTRY
* 
      LDB T0RCO+1   SET COMMON SIZE.
      STB F.CSZ 
      JSB CCS.F     CHECK IT FOR OFL. 
      JMP GREQU     DO EQUIV. GROUPS
* 
RCOM2 JSB FA.F      FETCH ASSIGN
      JSB NW2.F     F.D0: # WDS FOR ITEM
      LDB F.A 
      JSB FL.F      FETCH LINK
      STA T2RCO     T2RCO = LINK. 
      LDA T0RCO+1 
      JSB DAF.F     DEFINE F.AF=T0
      LDA F.EM      IS IT IN EMA ?
      SZA,RSS       THEN
      JMP RCO06     NOT IN EMA SKIP IT
* 
      LDA T0RCO     GET THE HIGH ORDER BITS 
      ADB K2        INDEX TO PLACE FOR THEM.
      STA B,I       SET IN THE SYMBOL TABLE 
RCO06 DLD T0RCO     GET COMMON SIZE.
      JSB DAD.F     ADD ELEMENT SIZE. 
      DEF F.D0
      CCA           (IF OFL, MAKE SURE IS CAUGHT) 
      DST T0RCO 
      JSB CCS.F     CHECK FOR OFL.
      JMP RCO05     DO NEXT ONE IN THE LIST 
* 
T0RCO DEC 0,0       SIZE. 
T1RCO NOP           F.A OF MASTER.
T2RCO NOP           LINK TO NEXT ITEM.
F.LCM NOP           LABELLED COMMON FLAG. 
K84   DEC 84
K2    DEC 2 
B7200 OCT 7200      NT=0, AT=BCOMI, IU=SUB. 
B7601 OCT 7601      F.NT & F.AT & F.IU
* 
*                   SUBROUTINE TO CHECK T0RCO FOR OVERFLOW. 
* 
CCS.F NOP 
      DLD T0RCO 
      SZA,RSS       MUST HAVE UPPER BITS=0, 
      SSB           AND LOWER POSITIVE. 
      RSS           NO. ERROR.
      JMP CCS.F,I   YES. EXIT.
* 
      LDB F.EM      WELL, MAYBE. IS IT EMA ?
      SZB 
      SSA           YES. IS BIT 31 CLEAR ?
      RSS           NO. TRUE OVERFLOW.
      JMP CCS.F,I   YES ON BOTH. IT FITS. 
* 
      LDA K84       OVERFLOW. 
      JMP F.ABT 
      SKP 
*         ********************* 
*         * GROUP EQUIVALENCE * 
*         ********************* 
      SPC 1 
*     THIS SECTION RESOLVES THE EQUIVALENCE DECLARATIONS SAVED IN THE 
*     EQUIVALENCE TABLE, (F.DO-1) TO (F.E).  THE INITIAL FORM OF THE
*     TABLE IS DESCRIBED IN F.EQU .  AT THIS POINT ALL OTHER
*     DECLARATIONS HAVE BEEN PROCESSESED SO THE SUBSCRIPTS GIVEN IN 
*     THE EQUIVALENCE ITEMS CAN NOW BE RESOLVED INTO WORD OFFSETS FROM
*     THE START OF THE ITEM.  THIS IS THE INITIAL "PACK" PHASE.  AT THE 
*     END OF THE PACK PHASE, EACH ITEM IN THE EQUIVALENCE TABLE IS
*     A 3-WORD FRAME CONTAINING THE F.A OF THE ITEM AND THE 2-WORD
*     OFFSET FROM ITS START TO THE SUBSCRIPTED ADDRESS. 
* 
*     EQUIVALENCE PROCESSING IS DONE BY EXTRACTING EQUIVALENCE CLASSES. 
*     (ONE OR MORE EQUIVALENCE GROUPS EACH CONTAINING AT LEAST ONE
*     ITEM IN ANOTHER GROUP IN THE CLASS, SUCH THAT NO ITEM IS IN 
*     A GROUP OUTSIDE THE CLASS.  THE CLASS DESCRIBES A SET OF ITEMS
*     IN LOCK-STEP WITH EACH OTHER.)  THE FOLLOWING ALGORITHM IS USED 
*     TO EXTRACT A CLASS FROM THE REMAINING EQUIVALENCE DATA: 
*        1) THE FIRST GROUP IS IN THE CLASS.  AS EACH GROUP IS PUT IN 
*             THE CLASS, IT IS MARKED 'KNOWN'.
*        2) FOR EACH KNOWN ITEM, SEARCH FOR A MATCHING ONE: 
*             IF NONE FOUND, GO ON TO NEXT KNOWN ITEM.
*             IF FOUND & KNOWN, OFFSETS MUST MATCH. GO ON.
*             IF FOUND & UNKNOWN, ADD GROUP CONTAINING ITEM 
*               TO THE CLASS & RESTART STEP (2).
*           IF NO NEW GROUPS ADDED TO CLASS, THE CLASS IS COMPLETE. 
*     THE ADDRESS OF A (HYPOTHETICAL) SIMPLE ITEM IN THE FIRST GROUP
*     OF THE CLASS IS CONSIDERED TO BE THE REFERENCE ADDRESS.  THE
*     REFERENCE OFFSET IS THE OFFSET FROM THIS ADDRESS TO THE ADDRESS 
*     OF A SIMPLE ITEM IN THE CURRENT GROUP.  (FOR THE FIRST GROUP, 
*     ZERO.)  THE LOCATIONS 'ULIM' AND 'LLIM' ARE THE OFFSETS TO THE
*     LWA+1 OF THE ITEM AT THE HIGH END OF THE CLASS AND THE LWA OF THE 
*     ITEM AT THE LOW END, BASED ON THE REFERENCE ADDRESS.  THE SIZE
*     OF A CLASS IS (ULIM-LLIM).
* 
*     AS EACH CLASS IS COMPLETED, IT IS ALLOCATED TO LOCAL SPACE, COMMON
*     OR LABELLED COMMON (INCLUDING EMA) AND THE ADDRESSES OF THE ITEMS 
*     IN THE CLASS ARE DEFINED.  THE CLASS IS THEN REMOVED FROM THE 
*     EQUIVALENCE TABLE AND A SCAN FOR THE NEXT CLASS IS STARTED. 
      SPC 3 
*                   START. PACK EQUIVALENCE TABLE.
* 
GREQU LDA F.DO      ANY ITEMS IN TABLE ?
      CPA F.E 
      JMP ASPEC     NO. SKIP EQUIVALENCE PROCESSING.
* 
      STA T1GRE     YES. T1GRE = ADDRESS OF LAST WORD READ. 
      STA T2GRE     T2GRE = ADDRESS OF LAST WORD WRITTEN. 
      JMP GRE01     GO START. 
      SKP 
GRE00 STA T4GRE     T4GRE = LINE # FOR ERRORS.
      JSB GREW2     LEAVE IN TABLE. 
GRE01 JSB GRER1     COPY F.A OR GROUP START MARK. 
      STA F.A 
      JSB GREW2 
      JSB GRER1     READ # SUBS OR LINE #.
      LDB F.A       (B) = F.A OR -1 
      SSB           WHICH ? 
      JMP GRE00     NEW GROUP. SAVE LINE #. 
* 
      STA T3GRE     T3GRE = # SUBS. 
      JSB FA.F      FETCH ASSIGNS (F.IU, F.ND, F.D0)
      LDB F.A       MUST NOT BE DUMMY OR SUBROUTINE.
      LDA K22       (ELSE ERROR 22.)
      CPB F.SBF     CHECK FOR PROGRAM NAME, 
      JMP GRE99 
* 
      LDB F.AT      FORMAL PARAM, 
      CPB DUM 
      JMP GRE99 
* 
      LDB F.IU      OR SUBROUTINE.  
      CPB SUB       
      JMP GRE99 
* 
      CPB ARR       ARRAY ? 
      RSS           YES.
      JSB TV.F      NO. MAKE IT VAR.
      LDA F.ND      (A) = DECLARED # DIM (GARBAGE IF VAR) 
      LDB F.IU      SIMPLE VARIABLE ? 
      CPB VAR 
      CLA           YES, # DIM = 0. 
      LDB T3GRE     # SUBSCRIPTS. 
      CMB,INB       -(#SUBS)
      ADB A         (#DIM)-(#SUBS)
      SSB           MORE SUBS THAN DIMS ? 
      JMP GRE02     YES, ERROR. 
* 
      LDA T3GRE     (A) = # SUBS. 
      LDB T1GRE     SET (B) TO ADDR OF LAST SUBSCR
      ADB KM2       WHICH IS NEXT THING FROM # SUBS.
      JSB CI2.F     COMPUTE ITEM OFFSET.
      SOC           OUT OF BOUNDS ? 
      JMP GRE17     YES, CALL IT IMPOSSIBLE.
* 
      LDA F.CIO+1   WRITE IT OUT. 
      JSB GREW2 
      LDA F.CIO 
      JSB GREW2 
      LDA T3GRE     ADVANCE PAST SUBSCRIPTS IN TABLE. 
      ALS           TWO WORDS EACH. 
      SZA,RSS       (IF NONE, SKIP A WORD ANYWAY) 
      INA 
      CMA,INA       JUST SET SUBTRACT FROM T1GRE. 
      ADA T1GRE 
      STA T1GRE 
      CPA F.E       END ? 
      RSS           YES. DONE.
      JMP GRE01     NO. GET NEXT ITEM.
* 
      LDA T2GRE     SHORTEN TABLE TO CURRENT SIZE.
      STA F.E 
      JMP GRE04     GO START THE CLASS DETERMINATION. 
* 
GRE02 LDA K38       MORE SUBSCRIPTS THAN DIMENSIONS.
      JMP GRE99     REPORT IT, DELETE TABLE & EXIT. 
      SKP 
*                   START NEW EQUIVALENCE CLASS.
* 
GRE04 LDA F.DO      ANYTHING LEFT ? 
      CPA F.E 
      JMP ASPEC     NO. DONE WITH EQUIV.
* 
      STA T1GRE     T1GRE = PTR TO START OF 1ST GROUP.
      CLA           T0GRE = REFERENCE OFFSET (INITIALLY ZERO).
      STA T0GRE 
      STA T0GRE+1 
      STA LLIM      LLIM = OFFSET OF FWA CLASS. 
      STA LLIM+1
      STA ULIM      ULIM = OFFSET OF LWA+1 CLASS. 
      STA ULIM+1
      STA T6GRE     T6GRE = ADDRESS LEVEL.
      STA T7GRE     T7GRE = COMMON BLOCK NAME.
      LDA STRAB     T5GRE = ADDRESS TYPE. 
      STA T5GRE 
      JSB GRER1     SKIP (-1) GROUP START.
* 
*                   START NEW GROUP.  T1GRE = ADDR OF GROUP.
*                                     T0GRE = REFERENCE OFFSET. 
* 
GRE06 JSB GRER1     SAVE LINE #.
      STA T4GRE 
GRE08 LDA T1GRE     IF THIS WAS LAST GROUP, 
      CPA F.E       THEN NO GROUP MARK. 
      JMP GRE10     YES. DONE WITH GROUP. 
* 
      JSB GRER1     READ F.A OR GROUP MARK. 
      CPA KM1       WHICH ? 
      JMP GRE10     GROUP MARK. 
* 
      STA F.A       ITEM. SAVE F.A
      IOR B100K     SET SIGN ON ITEM F.A TO MARK IT.
      STA T1GRE,I 
      JSB FA.F      FETCH ASSIGNS.
* 
*                   CHECK OUT ADDRESS TYPES, SAVE BLOCKNAME.
* 
      LDB F.AT      DEFINED ? 
      CPB STRAB 
      JMP GRE9B     NO. ALL'S FAIR. 
* 
      LDA T5GRE     COMMON. FIRST ONE ? 
      CPA STRAB 
      RSS           YES.
      JMP GRE9A     NO. GO CHECK FOR CONSISTENT BLOCK.
* 
      STB T5GRE     YES. SET TYPE OF COMMON.
      LDA F.AF      SET BLOCKNAME.
      ADA K2        INDEX TO THE F.A
      LDA A,I       (A) = F.A OF MASTER.
      STA T7GRE 
      LDA T1GRE     SAVE ADDR OF FRAME
      STA TAGRE     FOR BCOM OFFSET RESOLUTION LATER. 
GRE9A LDA F.AT      COMMON. MUST BE SAME TYPE.
      CPA T5GRE 
      RSS           YES. O.K. 
      JMP GRE17     NO. ERROR.
* 
      CPA COM       BLANK OR LABELLED ? 
      JMP GRE9B     BLANK. O.K. 
* 
      LDA F.AF      LABELLED. BLOCKNAME MUST MATCH. 
      ADA K2        GET F.A OF MASTER.
      LDA A,I 
      CPA T7GRE 
      RSS           SAME. O.K.
      JMP GRE17     NO. ERROR.
* 
GRE9B LDA T6GRE     SET ADDRES LEVEL TO MAX.
      IOR F.EM
      STA T6GRE 
* 
      JSB NW2.F     COMPUTE # WORDS.
      JSB GRER1     ADVANCE T1GRE TO OFFSET (LOWER) 
      JSB GRER1     (UPPER).
      DLD T0GRE     REFERENCE OFFSET. 
      JSB DSB.F     - OFFSET. 
      DEF T1GRE,I   = CLASS OFFSET. 
      JMP GRE98     IF OFL. 
* 
      DST T1GRE,I   REPLACE ARRAY OFFSET WITH CLASS OFFSET. 
      JSB DSB.F     (CLASS OFFSET) - LLIM 
      DEF LLIM
      JMP GRE98     IF OFL. 
* 
      SSA,RSS       NEW OFFSET SMALLER ? (OR MORE NEGATIVE) 
      JMP GRE9D     NO. 
* 
      DLD T1GRE,I   YES. UPDATE LLIM. 
      DST LLIM
GRE9D DLD F.D0      SIZE
      JSB DAD.F     + CLASS OFFSET. 
      DEF T1GRE,I 
      JMP GRE98     IF OFL
* 
      DST T8GRE     SAVE IT.
      JSB DSB.F     (OFFSET+SIZE) - ULIM
      DEF ULIM
      JMP GRE98     IF OFL. 
* 
      SSA           WHICH IS BIGGER ? 
      JMP GRE08     ULIM. LEAVE IT. 
* 
      DLD T8GRE     OFFSET+SIZE. NEW ULIM.
      DST ULIM
      JMP GRE08     GO FOR NEXT ITEM IN GROUP.
      SKP 
*                   GROUP HAS BEEN ADDED TO CLASS.
*                   SEARCH FOR CONFLICTS AND OTHER GROUPS IN CLASS. 
* 
GRE10 LDA F.DO      SET UP SCANS. 
      STA T1GRE     T1GRE = OUTER LOOP POINTER. 
* 
GRE11 STA T4GRE     T4GRE = LINE # (GARBAGE 1ST TIME) 
GRE12 LDA T1GRE     END OF OUTER LOOP ? 
      CPA F.E 
      JMP GRE24     YES. NO NEW GROUPS, CLASS COMPLETE. 
      JSB GRER1     GET F.A OR GROUP START. 
      STA F.A 
* 
      JSB GRER1     ADVANCE T1GRE TO OFFSET OR LINE #.
      LDB F.A       RECALL F.A
      CPB KM1       GROUP START ? 
      JMP GRE11     YES. SAVE LINE # & GO ON. 
* 
      JSB GRER1     ADVANCE TO 2ND WD OF OFFSET.
      LDA F.A       (A) = F.A 
      SSA,RSS       UNKNOWN ITEM ?
      JMP GRE12     YES. INGORE IN OUTER LOOP.
* 
*                   INNER LOOP. 
* 
      LDA F.DO      SET UP INNER LOOP.
      STA T2GRE     T2GRE = POINTER.
* 
GRE13 LDA T2GRE     T8GRE = LOCATION OF CURRENT GROUP.
      INA           (A = ADDR OF GROUP MARK)
      STA T8GRE     (GARBAGE FIRST TIME)
GRE14 LDA T2GRE     END ? 
      CPA F.E 
      JMP GRE12     YES, ADVANCE OUTER LOOP.
* 
      JSB GRER2     NO. GET F.A OR GROUP START (INNER LOOP) 
      STA T3GRE     SAVE. 
      JSB GRER2     ADVANCE T2GRE TO OFFSET (OR LINE #) 
      LDA T3GRE     IS IT GROUP START ? 
      CPA KM1 
      JMP GRE13     YES, SAVE LOCATION. 
* 
      JSB GRER2     ADVANCE TO 2ND WORD OF OFFSET.
      LDA T3GRE 
      CPA F.A       DUPLICATE MARKED ITEMS ?
      JMP GRE16     YES.  OFFSETS MUST MATCH. 
* 
      IOR B100K     SAME NAME IN NEW GROUP ?
      CPA F.A 
      JMP GRE18     YES.
      JMP GRE14     NO. GO ON TO NEXT ONE.
      SKP 
GRE16 DLD T1GRE,I   T0GRE = ORIGINAL OFFSET.
      DST T0GRE 
      DLD T2GRE,I   (A,B) = DUPLCATE ITEM'S OFFSET. 
      CPA T0GRE     MATCH ? 
      RSS 
      JMP GRE17     NO. ERROR.
      CPB T0GRE+1   UPPERS TOO. 
      JMP GRE14     YES. JUST REDUNDANT EQUIVALENCE.
* 
GRE17 LDA K40       NO. IMPOSSIBLE EQUIVALENCE GROUP. 
      JMP GRE99     GO TELL LINE # & NAME.
* 
*                   ADD NEW GROUP TO CLASS. 
* 
GRE18 DLD T1GRE,I   T0GRE = BASE OF ITEM IN BOTH GROUPS.
      JSB DAD.F     + OFFSET IN NEW GROUP.
      DEF T2GRE,I 
      JMP GRE98     IF OFL. 
* 
      DST T0GRE     = NEW REFERENCE OFFSET. 
      LDA T8GRE     T1GRE = ADDRESS OF NEW GROUP. 
      STA T1GRE 
      JMP GRE06     GO ADD THE GROUP TO THE CLASS.
* 
LLIM  OCT 0,0       LOWER LIMIT OF CLASS. 
ULIM  OCT 0,0       UPPER LIMIT OF CLASS + 1
T0GRE OCT 0,0       REFERENCE ADDRESS.
T1GRE NOP           POINTER INTO EQUIV TABLE. 
T2GRE NOP           POINTER INTO EQUIV TABLE. 
T3GRE NOP           TEMP
T4GRE NOP           LINE # OF CURRENT GROUP.
T5GRE NOP           F.AT OF CLASS.
T6GRE NOP           F.EM OF CLASS.
T7GRE NOP           F.A OF BCOM MASTER FOR CLASS. 
T8GRE OCT 0,0       ADDR START OF CURRENT GROUP (INNER LOOP)
TAGRE NOP           ADDR OF FRAME OF A BCOM ITEM THIS CLASS.
ARR   OCT 600       F.IU=ARR
VAR   OCT 400       F.IU=VAR
STRAB OCT 2000      F.AT=STRAB
COM   OCT 4000      F.AT=COM
BCOM  OCT 3000      F.AT=BCOM 
BCOMI OCT 7000      F.AT=BCOMI
KM1   DEC -1
KM2   DEC -2
K10   DEC 10
K22   DEC 22
K38   DEC 38
B100K OCT 100000
K40   DEC 40
      SKP 
*                   MISCELLANEOUS SUBROUTINES FOR EQUIVALENCE.
* 
GRER1 NOP           READ EQUIV TABLE INTO (A) USING (T1GRE) 
      CCB           BACK UP T1GRE.
      ADB T1GRE 
      STB T1GRE 
      LDA B,I       (A) = DATA. 
      JMP GRER1,I   EXIT. 
* 
GRER2 NOP           READ EQUIV TABLE INTO (A) USING (T2GRE) 
      CCB           BACK UP T2GRE.
      ADB T2GRE 
      STB T2GRE 
      LDA B,I       (A) = DATA. 
      JMP GRER2,I   EXIT. 
* 
GREW2 NOP           WRITE (A) INTO EQUIV TABLE USING (T2GRE)
      LDB F.LO      TOP OF A.T. + 1 
      CMB           -F.LO-1   (F.LO: MIN ALLOWABLE F.E) 
      ADB T2GRE     (T2GRE-1)-F.LO
      SSB           NEW T2GRE < F.LO ?
      JMP F.OFE     YES, MEM OVERFLOW.
* 
      ADB F.LO      NEW T2GRE = T2GRE-1 
      STB T2GRE 
      STA B,I       STORE DATA. 
      JMP GREW2,I   EXIT. 
      SKP 
*                   COMPLETE EQUIV CLASS. ASSIGN ADDRESSES OR OFFSETS.
* 
GRE24 DLD ULIM      COMPUTE SIZE = (ULIM-LLIM)
      JSB DSB.F 
      DEF LLIM
      JMP GRE98     IF OFL. 
* 
      SZA,RSS       > 32767 ? 
      SSB 
      RSS           YES.
      JMP GRE25     NO. ALWAYS O.K. 
* 
      LDA T6GRE     > 32767. EMA ?
      SZA,RSS 
      JMP GRE98     NO. TOO BIG.
* 
GRE25 LDA T5GRE     WHAT KIND ? 
      CPA STRAB 
      RSS           NORMAL. 
      JMP GRE27     COMMON OR BCOM. 
* 
      CLA           SET T0GRE = F.RPL - LLIM
      LDB F.RPL     (THIS IS THE VALUE WHICH, WHEN ADDED
      JSB DSB.F      TO THE ITEM OFFSET, GIVES THE PROPER 
      DEF LLIM       RELOCATABLE ADDRESS FOR THE ITEM.) 
      JMP GRE98     IF OFL. 
* 
      DST T0GRE 
      JSB DAD.F     + BIGGEST OFFSET GIVES NEW F.RPL
      DEF ULIM
      JMP GRE98 
* 
      STB F.RPL 
      SZA,RSS       ROOM ?
      SSB 
      JMP F.OFE     NO. YOU LOOSE...
* 
      LDA REL       YES. WILL MARK F.AT = REL.
      STA T5GRE 
      JMP GRE50     GO ON.
* 
GRE27 LDA TAGRE     COMMON. GET ADDR OF ITEM OFFSET 
      ADA KM2       OF THE ITEM KNOWN TO BE IN COMMON.
      STA GRE28     SET UP FOR LATER. 
      LDA TAGRE,I   (A) = KNOWN ITEM F.A + SIGN.
      RAL,CLE,ERA   CLEAR SIGN. 
      STA F.A       SAVE & FETCH ASSIGNS. 
      JSB FA.F
      LDB T5GRE     WHICH COMMON ?
      CPB BCOM
      JMP GRE40     LABELLED. 
* 
      LDB A         (F.AF)
      CLA           (A,B) = COMMON OFFSET.
      JSB DSB.F     - ITEM'S EQUIV OFFSET 
GRE28 DEF *-* 
      JMP GRE98     IF OFL. 
* 
      DST T0GRE     GIVES THE DISPLACEMENT. 
      JSB DAD.F     + MAX OFFSET = SIZE.
      DEF ULIM      (IGNORE UPPER WORD) 
      JMP GRE98     IF OFL. 
* 
      LDA DCSZ      (A) = ADDR OF SIZE. (POSSIBLY INDIRECT) 
      JMP GRE42     GO UPDATE SIZE IF BIGGER. 
      SKP 
GRE40 LDB T6GRE     EMA ? 
      SZB 
      JMP GRE44     YES.
* 
      DLD A,I       (B) = ITEM'S OFFSET.
      CLA           (A,B) 
      JSB DSB.F     - ITEM EQUIV OFFSET.
      DEF GRE28,I 
      JMP GRE98     IF OFL. 
* 
      DST T0GRE     GIVES DISPLACEMENT. 
      JSB DAD.F     + MAX OFFSET = SIZE.
      DEF ULIM      (IGNORE UPPER WORD) 
      JMP GRE98     IF OFL. 
* 
      LDA F.SFF     BLOCK DATA ?
      CPA K2
      CLA,INA,RSS   YES. (A=1)
      JMP GRE43     NO. DONE HERE.
* 
      ADA T7GRE     (A) = ADDR OF SIZE. 
GRE42 STA T3GRE     SAVE ADDR SIZE. 
      LDA B         (A) = NEW SIZE. 
      CMA,INA 
      ADA T3GRE,I   OLD - NEW 
      SSA           NEW BIGGER ?
      STB T3GRE,I   YES. UPDATE.
GRE43 SSB           TOO BIG ? 
      JMP F.OFE     YES. PUNT.
      JMP GRE50     NO. START THE SCAN. 
* 
GRE44 INA           GET EMA OFFSET. 
      LDB A,I       LOWER IS AT F.A+1 
      ADA K2
      LDA A,I       UPPER IS AT F.A+3 
      JSB DSB.F     (EMA OFFSET) - (ITEM OFFSET)
      DEF GRE28,I 
      JMP GRE98     IF OFL. 
* 
      DST T0GRE     GIVES DISPLACEMENT. 
      JSB DAD.F     + MAX OFFSET GIVES SIZE.
      DEF ULIM
      JMP GRE98     IF OFL. 
* 
      DST T8GRE     SAVE SIZE.
      DLD F.EMS     OLD SIZE
      JSB DSB.F     (OLD SIZE) - (NEW SIZE) 
      DEF T8GRE 
      JMP GRE98     IF OFL. 
* 
      SSA,RSS       WHICH IS BIGGER ? 
      JMP GRE50     OLD.
* 
      DLD T8GRE     NEW. SET IT AS SIZE.
      DST F.EMS 
      SKP 
*                   LOOP THRU ITEMS IN CLASS, DEFINING THEIR ADDRESSES. 
* 
GRE50 LDA F.DO      SET T1GRE AS READ POINTER.
      STA T1GRE 
      STA T2GRE     AND T2GRE AS WRITE POINTER. 
      JSB GRER1     SKIP INITIAL GROUP HEAD.
* 
*                   JUST COPY GROUPS NOT IN CLASS.
* 
GRE52 JSB GRER1     SEE IF IN CLASS.  COPY LINE #.
      STA T4GRE     T4GRE = LINE #. 
      JSB GRER1     GET F.A FIRST ITEM. 
      SSA           MARKED ?
      JMP GRE55     YES. PROCESS IT.
* 
      STA F.A       NO. SAVE F.A, THEN
      CCA           'COPY' THE DISCARDED GROUP HEAD,
      JSB GREW2 
      LDA T4GRE     AND THE LINE #, 
      JSB GREW2 
      LDA F.A       AND GO FINISH COPYING 1ST ITEM. 
      JMP GRE51 
* 
GRE53 LDA T1GRE     AT END ?
      CPA F.E 
      JMP GRE65     YES.
* 
      JSB GRER1     COPY UNTIL NEW GROUP. 
      CPA KM1       WELL ?
      JMP GRE52     YES. GO CHECK IT. 
* 
GRE51 JSB GREW2     NO. COPY F.A
      JSB GRER1     OFFSET LOWER. 
      JSB GREW2 
      JSB GRER1     OFFSET UPPER. 
      JSB GREW2 
      JMP GRE53     UNTIL GROUP HEAD. 
* 
*                   GROUP IS IN CLASS.  PROCESS EACH ITEM.
* 
GRE54 LDA T1GRE     AT END ?
      CPA F.E 
      JMP GRE65     YES.
* 
      JSB GRER1     NEXT F.A OR GROUP HEAD. 
      CPA KM1       WHICH ? 
      JMP GRE52     NEW GROUP. GO SEE IF IN CLASS.
* 
GRE55 RAL,CLE,ERA   CLEAR SIGN. 
      STA F.A       SET F.A (SIGN HAS BEEN CLEARED) 
      STA TAGRE     (ALSO FOR EMA LATER)
      JSB FA.F      FETCH ASSIGNS.
      JSB GRER1     ADVANCE TO 1ST WD OFFSET. 
      JSB GRER1 
      DLD T1GRE,I   (A,B) = ITEM OFFSET.
      JSB DAD.F     (A,B) = ITEM ADDRESS OR COMMON OFFSET.
      DEF T0GRE 
      JMP GRE98     IF OFL. 
* 
      DST T1GRE,I   SAVE IT.
      SSA           IF NEGATIVE,
      JMP GRE97     MUST BE NEG EXTENSION OF COMMON.
      SKP 
*                   IF NOT BLOCK COMMON, JUST DEFINE F.AT & F.AT .
*                   BLOCK COMMON: IF DEFINED, MUST ALREADY MATCH. 
*                                 IF NOT, MUST DEFINE IT. 
* 
      LDB T5GRE     LABELLED COMMON ? 
      CPB BCOM
      RSS           YES.
      JMP GRE62     NO, GO DEFINE F.AT & F.AF 
* 
      CPB F.AT      DEFINED ? 
      JMP GRE63     YES. ADDRESSES MUST MATCH.
* 
      LDA T6GRE     SET F.EM FOR AI.F 
      STA F.EM
      LDA BCOMI     SET F.AT. = BCOMI FOR AI.F
      STA F.AT. 
      JSB AI.F      CREATE THE TABLE ENTRY. 
      LDB T7GRE     (B) = ADDR OF MASTER. 
      LDA F.A       (A) = ADDR NEW BCOMI ENTRY. 
      ADA K2        INDEX TO PLACE FOR MASTER ADDR. 
      STB A,I       & PUT IT THERE. 
      INA           ADDR OF UPPER WORD EMA ADDR.
      STA T3GRE     SAVE. 
      LDA T6GRE     EMA FLAG. 
      LDB T1GRE,I   (B) = UPPER WORD. 
      SZA           EMA ? 
      STB T3GRE,I   YES. SET UPPER WORD.
      LDA BCOMI     DEFINE THE F.AT 
      JSB DAT.F 
      LDA F.A       (A) = ADDR BCOMI ENTRY. 
      LDB TAGRE     (B) = ADDR ORIGINAL ENTRY.
      STB F.A       RESTORE F.A TO THERE. 
      JSB DAF.F     LINK IN THE BCOMI ENTRY.
      LDA T6GRE     IF EMA, 
      SZA 
      JSB DEM.F     SET THE EMA BIT.
      JSB FA.F      & FETCH ASSIGNS AGAIN.
      JMP GRE64     NOW GO DEFINE F.AT & F.AF 
      SKP 
*                   VERIFY ALREADY IN LABELLED COMMON,  VERIFY ADDR.
* 
GRE63 DLD T1GRE,I   (B) = CORRECT (LOWER) OFFSET. 
      LDA F.AF      ADDR OF BCOMI ENTRY.
      INA           ADDR OF DEFINED OFFSET. 
      CPB A,I       SAME ?
      RSS 
      JMP GRE17     NO. IMPOSSIBLE. 
* 
      LDB T6GRE     YES. EMA ?
      SZB,RSS 
      JMP GRE54     NO. DONE. 
* 
      LDB T1GRE,I   CORRECT UPPER OFFSET. 
      ADA K2        ADDR OF DEFINED VALUE.
      CPB A,I       SAME ?
      JMP GRE54     YES.
      JMP GRE17     NO. IMPOSSIBLE. 
* 
*                   REL/COM: IF COM & ALREADY DEF, SEE IF SAME. 
* 
GRE62 LDA F.AT      WELL ?
      CPA COM 
      RSS 
      JMP GRE64     NO. 
* 
      DLD T1GRE,I   YES. (B) = CORRECT OFFSET.
      CPB F.AF      SAME ?
      JMP GRE54     YES.
      JMP GRE17     NO. IMPOSSIBLE. 
* 
*                   DEFINE (LOWER) ADDRESS/OFFET. 
* 
GRE64 LDA T5GRE     SET F.AT OF NEW ITEM. 
      JSB DAT.F 
      DLD T1GRE,I   SET (LOWER) WORD OFFSET.
      LDA B 
      JSB DAF.F 
      JMP GRE54     ALL DONE! 
* 
*                   DONE WITH THIS CLASS.  CUT THE TABLE BACK TO
*                   REFLECT THE NEW (GREW2) LENGTH & TRY FOR ANOTHER. 
* 
GRE65 LDA T2GRE     NEW LWA 
      STA F.E 
      JMP GRE04     MAY BE EMPTY NOW. 
      SKP 
DEQMS DEF EQMSG 
EQMSG ASC 7,   INVOLVING: 
EQNAM ASC 3,XXXXXX
DCSZ  DEF F.CSZ     DEF TO BLANK COMMON SIZE IN MAIN. 
REL   OCT 1000
K41   DEC 41
DGR95 DEF GRE95     ERROR RETURN POINT. 
      SPC 2 
*                   IMPOSSIBLE EQUIVALENCE CLASS. 
*                   OUTPUT ERROR MSG WITH GROUP LINE # AND ITEM NAME. 
* 
GRE97 LDA K41       NEGATIVE EXTENSION OF COMMON. 
      JMP GRE99 
GRE98 LDA K84       ADDRESS SPACE OVERFLOW. 
GRE99 LDB F.LNN     DUMMY UP LINE #.
      STB T5GRE 
      LDB T4GRE 
      STB F.LNN 
      LDB F.CC      ALSO COLOUMN. 
      STB T6GRE 
      CLB 
      STB F.CC
      LDB DGR95     SET ERROR RETURN POINT. 
      STB F.EQE 
      JSB ER.F      ISSUE MSG & RETURN. 
GRE95 CLA           RESET ERROR RETURN POINT. 
      STA F.EQE 
      LDA T5GRE     RESTORE LINE #. 
      STA F.LNN 
      LDA T6GRE     & F.CC
      STA F.CC
      LDA F.A       CLEAR SIGN OF F.A 
      RAL,CLE,ERA 
      STA F.A 
      JSB NAM.F     COPY NAME TO MESSAGE. 
      DEF EQNAM 
      LDA K10       TEN WORDS.
      LDB DEQMS     FROM HERE.
      JSB PCC.F     TO OUTPUT.
      SKP 
*         ************************
*         * ASSIGN SPECIFICATION *
*         ************************
      SPC 1 
*     TO ASSIGN STORAGE TO ARRAYS NOT ALREADY ASSIGNED (BY EQUIV).
* 
*                   TOP OF LOOP. GET ANOTHER ARRAY. 
* 
ASPEC JSB GFA.F     SET UP TO SCAN A.T. 
      LDA F.A       KEEP THE F.A IN T1ASP.
      STA T1ASP 
ASP01 LDA T1ASP     RESTORE F.A 
      STA F.A 
      JSB GNA.F     GET NEXT F.A
      STA T1ASP     KEEP IT IN T1ASP. 
      SZA,RSS 
      JMP CAI00     END OF ASSIGNMENT TABLE 
* 
      JSB FA.F      FETCH ASSIGNS 
      LDA F.IU      IF NOT AN ARRAY,
      CPA ARR 
      RSS 
      JMP ASP01     THEN SKIP IT (ASSIGN AT 'END'). 
* 
*                   ASSIGN SPACE IF NOT DONE ALREADY AND NOT FORMAL.
* 
      LDA F.AT      IF A DUMMY, 
      CPA DUM 
      JMP ASP01     DON'T ASSIGN SPACE. 
* 
      JSB NW2.F     F.D0=# OF WDS FOR ITEM
      JSB AA.F      ASSIGN ADDRESS
      JMP ASP01 
* 
* 
B40   OCT 40
INT   OCT 010000    F.IU=INT
DBI   OCT 100000    F.IU=DBI
DUM   OCT 5000      F.AT=DUM
SUB   OCT 200       F.IU=SUB
T1ASP NOP           F.A OF CURRENT ARRAY. 
      SKP 
*         **********************
*         * COMPUTE ARRAY INFO *
*         **********************
      SPC 1 
*     IN THIS SECTION, FOR EACH ARRAY:
*       1) IF IN EMA, CHECKED FOR DOUBLE INTEGER SUBSCRIPTS.
*       2) IF NON-FORMAL: 
*            A) OFFSET TO ELEMENT (0,0,0) COMPUTED. 
*            B) EACH LOWER BOUND NEGATED. 
*            C) EACH UPPER BOUND REPLACED BY DIMENSION SIZE.
* 
*     THIS SECTION MUST BE EXECUTED BEFORE THE ROUTINES 
*     'NWI.F' AND 'CIO.F' ARE CALLED, AS THEY USE THE MODIFIED
*     ARRAY INFORMATION.
* 
CAI00 JSB GFA.F     SET UP SCAN OF NAMED ITEMS. 
      LDA F.A       KEEP F.A IN T1ASP 
      STA T1CAI 
CAI01 LDA T1CAI     RESTORE F.A 
      STA F.A 
      JSB GNA.F     GET NEXT ITEM.
      STA T1CAI 
      SZA,RSS       DONE ?
      JMP RCO.F,I   YES. ALL DONE WITH SPECS. 
* 
      JSB FA.F      NO. FETCH ASSIGNS.
      LDA F.IU      ARRAY ? 
      CPA ARR 
      RSS           (YES) 
      JMP CAI01     NO. SKIP IT.
      SKP 
*                   CHECK WHETHER ANY DIMENSIONS ARE DOUBLE INTEGER.
*                   IF CONSTANT DBL INT DIM FOR NON-EMA, PUNT.
* 
      LDA F.EM      EMA ? 
      SZA 
      JMP CAI02     YES.
* 
      LDB F.DIS     NO. CONSTANT DOUBLE INT SUBSCR ?
      SZB 
      JMP CAI10     YES. ERROR. 
      JMP CAI05     NO. ALL'S O.K.
* 
CAI02 LDA F.LUB     SET UP BOUNDS POINTER.
      STA T2CAI 
      LDA F.ND      SET UP LOOP COUNTER.
      ALS           *2 FOR LOWER & UPPER BOTH.
      CMA,INA 
      STA T3CAI 
CAI03 LDA T2CAI,I   NEXT BOUND. 
      ISZ T2CAI 
      STA F.A       GET ITS F.IM
      JSB FA.F
      LDA F.IM
      CPA DBI       IS IT INTEGER*4 ? 
      JMP CAI04     YES. DOUBLE INT SUBSCR. 
* 
      ISZ T3CAI     COUNT 'EM UP. 
      JMP CAI03     MORE. 
      JMP CAI05     DONE. SINGLE INT SUBSCR.
* 
CAI04 DLD T1CAI,I   FOUND ONE. SET THE F.DIS BIT, 
      LDA B,I       IN FIRST WORD OF DIM ENTRY. 
      IOR B40       MEANING 'DOUBLE INTEGER SUBSCRIPT'
      STA B,I 
      SKP 
*                   IF NOT FORMAL PARAM, LOOP THRU THE BOUNDS 
*                   AND:  1) NEGATE THE LOWER BOUNDS. 
*                         2) REPLACE UPPER BOUNDS BY DIMENSION SIZE.
* 
* 
CAI05 LDA T1CAI     RESTORE F.A & ASSIGNS.
      STA F.A 
      JSB FA.F
      LDA F.AT      F.AT = DUM ?
      CPA DUM 
      JMP CAI01     YES. FORMAL, SKIP IT. 
* 
      LDA F.LUB     SET UP BOUNDS LOOP. 
      STA T2CAI     T2CAI = BOUNDS POINTER. 
      LDA F.ND      # DIMENSIONS. 
      CMA,INA 
      STA T3CAI     T3CAI = LOOP COUNTER. 
      LDA F.DIS     SINGLE OR DOUBLE ?
      SZA 
      JMP CAI07     DOUBLE. 
* 
CAI06 LDB T2CAI,I   SINGLE.  GET LOWER BOUND VALUE. 
      JSB CFC.F 
      NOP 
      CMA,INA       NEGATE. 
      STA T4CAI     & SAVE FOR COMPUTING SIZE.
      CPA B100K     -32768 ?
      JMP CAI6A     YES. USE DOUBLE INTEGER.
* 
      JSB EIC.F     NO. SET UP AS SINGLE INTEGER. 
      JMP CAI6B 
* 
CAI6A LSL 16        (A,B) = 000000 100000 
      JSB EJC.F     SET UP DOUBLE INTEGER LOWER BOUND.
CAI6B STA T2CAI,I   & REPLACE LOWER BOUND.
      ISZ T2CAI 
      LDB T2CAI,I   GET UPPER BOUND VALUE.
      JSB CFC.F 
      NOP 
      ADA T4CAI     UPPER - LOWER.
      INA,SZA       DIMENSION SIZE = UPPER-LOWER+1
      SSA           > 32767 ?    (0 = 65536)
      JMP CAI6C     YES. USE DOUBLE INTEGER.
* 
      JSB EIC.F     NO. USE SINGLE INTEGER. 
      JMP CAI6D       
* 
CAI6C LDB A         USE DOUBLE. 
      CLA 
      SZB,RSS       (IF ZERO, REALLY 65536) 
      CLA,INA 
      JSB EJC.F 
* 
CAI6D STA T2CAI,I   REPLACE UPPER BOUND WITH DIM SIZE.
      ISZ T2CAI     ADVANCE TO NEXT DIMENSION.
      ISZ T3CAI     COUNT. DONE ? 
      JMP CAI06     NO. LOOP. 
      JMP CAI08     YES. GO COMPUTE OFFSET. 
      SKP 
*                   ADJUST BOUNDS FOR DOUBLE INTEGER DIMENSIONS.
* 
CAI07 LDB T2CAI,I   DOUBLE SUBSCR. LOOP.
      JSB GCD.F     GET VALUE OF LOWER. 
      NOP 
      STA T4CAI     & SAVE. 
      STB T5CAI 
      CMA           NEGATE. 
      CMB,INB,SZB,RSS 
      INA 
      DST F.IDI     SET UP NEW CONSTANT.
      LDA DBI 
      JSB ESC.F 
      JSB AI.F
      LDA F.A       REPLACE LOWER BOUND.
      STA T2CAI,I 
      ISZ T2CAI 
      LDB T2CAI,I   GET VALUE OF UPPER. 
      JSB GCD.F 
      NOP 
      JSB DSB.F     UPPER - LOWER.
      DEF T4CAI 
      NOP 
      INB,SZB,RSS   ADD ONE.
      INA 
      DST F.IDI     BUILD THE NEW CONSTANT. 
      LDA DBI 
      JSB ESC.F 
      JSB AI.F
      LDA F.A 
      STA T2CAI,I   REPLACE UPPER WITH SIZE.
      ISZ T2CAI     BUMP BOUNDS POINTER.
      ISZ T3CAI     COUNT. DONE ? 
      JMP CAI07     NO. LOOP. 
      SKP 
*                   COMPUTE THE OFFSET FROM THE 
*                   START OF THE ARRAY TO ELEMENT (0,0,0).
* 
CAI08 LDA T1CAI     RESTORE F.A 
      STA F.A 
      JSB FA.F      & ASSIGNS.
      LDA F.ND      COMPUTE OFFSET. 
      CLB           B=0 FORCES ALL SUBSCRIPTS = 0.
      JSB CIO.F 
      LDA F.CIO+1   (A)=OFFSET IF NON-EMA.
      STA F.IDI     SET THAT UP,
      LDA INT       AND THE TYPE. 
      LDB F.EM      WHICH IS IT ? 
      SZB,RSS       IF NON-EMA, 
      JMP CAI09     WE'RE READY.
* 
      DLD F.CIO     ELSE SET TWO-WORD VALUE.
      DST F.IDI     (DIDN'T NEGATE LOWER BOUNDS HERE) 
      LDA DBI 
CAI09 JSB ESC.F     SET IT UP.
      JSB AI.F
      DLD T1CAI,I   (B) = F.A OF DIM ENTRY THIS ARRAY.
      ADB K2            = PLACE TO PUT OFFSET F.A 
      LDA F.A       PUT IT THERE. 
      STA B,I 
      JMP CAI01     GO GET NEXT SYMBOL. 
* 
*                   DOUBLE INTEGER BOUNDS ON NON-EMA, PUNT. 
* 
CAI10 LDA T1CAI     RESTORE F.A & GET NAME. 
      STA F.A 
      JSB NAM.F 
      DEF CAIMS+1 
      LDB DCAIM     ISSUE MESSAGE FIRST.
      LDA K15 
      JSB PSL.F     PRINT IMMEDIATELY.
      LDA K84       THEN DISASTER.
      JMP F.ABT 
* 
T1CAI NOP           SAVED F.A 
T2CAI NOP           BOUNDS TABLE POINTER. 
T3CAI NOP           BOUNDS LOOP COUNTER.
T4CAI NOP           TEMP FOR CALCULATION. 
T5CAI NOP           DITTO.
DCAIM DEF CAIMS 
CAIMS ASC 15, (      ) HAS ILLEGAL BOUNDS.
K15   DEC 15
      SKP 
*     ************************************
*     * F.D0 := NUMBER OF WORDS FOR ITEM *
*     ************************************
      SPC 1 
*     AT THIS POINT, RCO.F MUST NOT HAVE BEEN CALLED.  THE LOWER AND
*     UPPER BOUNDS MUST BE INTACT.
* 
NW2.F NOP 
      LDA F.IU
      CPA ARR 
      RSS 
      JMP NW2.F,I 
* 
      LDA F.ND      SET UP COUNTER. 
      CMA,INA 
      STA T1NWI 
      LDA F.LUB     SET UP POINTER INTO BOUNDS TABLE. 
      STA T2NWI 
* 
*                   LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, 
*                   MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). 
* 
NWI01 LDB T2NWI,I   GET LOWER BOUND.
      ISZ T2NWI     (& GO PAST) 
      JSB GCD.F 
      JMP RPLOV     NOT CONSTANT! 
* 
      DST T3NWI     SAVE, WHILE WE... 
      LDB T2NWI,I   GET UPPER BOUND.
      ISZ T2NWI     (SKIP IT) 
      JSB GCD.F 
      JMP RPLOV     SOMEONE GOOFED! 
* 
      JSB DSB.F     UPPER - LOWER.
      DEF T3NWI 
      JMP RPLOV     IF OFL. 
* 
      INB,SZB,RSS   + 1.
      INA 
      SSA           DID SOMETHING GO WRONG ?
      JMP RPLOV     YES.
* 
      JSB DMP.F     MULTIPLY & REPLACE RUNNING PRODUCT. 
      DEF F.D0
      JMP RPLOV     OFL.
* 
      DST F.D0
      ISZ T1NWI     INCR LOOP COUNTER. MORE ? 
      JMP NWI01     YES. DO IT. 
      JMP NW2.F,I   NO. ALL DONE. (A,B) = PRODUCT.
      SKP 
RPLOV LDA K84       OFL IN SIZE CALC.  CATASTROPHE! 
      JMP F.ABT 
* 
T1NWI NOP           LOOP COUNTER. 
T2NWI NOP           BOUNDS TABLE POINTER. 
T3NWI DEC 0,0       TEMP FOR DIM SIZE CALC. 
      SKP 
*         *********************** 
*         * COMPUTE ITEM OFFSET * 
*         *********************** 
      SPC 1 
*     CI2.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE 
*     BASE OF THE ARRAY.  THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F .
* 
*     NOTE: THE BOUNDS REFORMATTING MUST NOT HAVE BEEN DONE YET. IF IT
*     HAS, THEN CIO.F SHOULD BE USED. 
* 
*     ENTRY: F.A = A.T. ADDR OF ITEM. 
*            (A) = # SUBSCRIPTS (MAY BE ZERO).
*            (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST)
*                  IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO.
*     EXIT:  F.CIO = TWO-WORD OFFSET IN INTERNAL FORM.
      SPC 1 
CI2.F NOP 
      STB T1CIO     SAVE ADDR LAST SUBSCR.
      CLB           INITIALIZE F.CIO = 0
      STB F.CIO 
      STB F.CIO+1 
      STB T0CIO     CLEAR OVERFLOW FLAG.
      CMA,INA,SZA,RSS  NEGATE # SUBS. 
      JMP CIO03     IF NONE, DONE. (CLEAR OFL & EXIT) 
* 
      STA T2CIO     ELSE SAVE AS LOOP COUNTER.
      JSB FA.F      SET UP:  F.D0 = # WDS PER ELEMENT.
      DLD F.D0      SAVE THAT.
      DST T5CIO 
      LDA T2CIO     -(#SUBS)
      CMA           (#SUBS)-1 
      ALS           *2
      ADA F.LUB     ADDR LOWER BOUND LAST SUBSCR. 
      STA T4CIO 
* 
*                   LOOP THRU SUBS & DIMS COMPUTING OFFSET. 
* 
CIO01 LDB T4CIO,I   F.A OF LOWER BOUND. 
      JSB GCD.F     (A,B) = LOWER BOUND.
      ISZ T0CIO     NOT CONSTANT: SOMEONE GOOFED! 
      DST T6CIO     SAVE. 
      CLA           (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. 
      CLB 
      DLD T1CIO,I   SUBSCRIPT.
      JSB DSB.F     SUBTRACT LOWER BOUND. 
      DEF T6CIO 
      ISZ T0CIO     IF TOO BIG. 
      SSA           ALSO BAD IF NEGATIVE. 
      ISZ T0CIO 
      JSB DAD.F     ADD RUNNING SUM.
      DEF F.CIO 
      ISZ T0CIO     IF TOO BIG. 
      ISZ T2CIO     WAS THAT FIRST SUBSCR ? 
      RSS           NO. 
      JMP CIO02     YES. DONE.
* 
      DST F.CIO     SAVE CURRENT VALUE. 
      LDA T4CIO     BACK UP TO PREVIOUS DIMENSION.
      ADA KM2 
      STA T4CIO 
      LDB A,I       GET LOWER BOUND OF PREVIOUS.
      JSB GCD.F 
      ISZ T0CIO     IF NOT CONSTANT.
      DST T6CIO     SAVE, WHILE WE
      DLD T4CIO,I   GET THE UPPER BOUND.
      JSB GCD.F 
      ISZ T0CIO     (IF NOT CONSTANT) 
      JSB DSB.F     UPPER - LOWER.
      DEF T6CIO 
      ISZ T0CIO     (IF OFL)
      INB,SZB,RSS   + 1 = PREV DIM SIZE.
      INA 
      JSB DMP.F     MULTIPLY PREV DIM SIZE BY 
      DEF F.CIO     CURRENT VALUE.
      ISZ T0CIO     IF TOO BIG. 
      DST F.CIO     SAVE. 
      LDA T1CIO     BACK UP TO PREVIOUS SUBSCR. 
      SZA           IF FORCED ZERO SUBSCR, DON'T CHANGE.
      ADA KM2 
      STA T1CIO 
      JMP CIO01     ARROUND WE GO 
* 
CIO02 JSB DMP.F     * # WORDS PER ELEMENT.
      DEF T5CIO 
      ISZ T0CIO     IF TOO BIG. 
      DST F.CIO     SAVE OFFSET.
      JSB NW2.F     COMPUTE F.D0 = TOTAL SIZE.
      DLD F.CIO     COMPUTE OFFSET - SIZE.
      JSB DSB.F 
      DEF F.D0
      ISZ T0CIO     IF OFL. 
      SSA,RSS       IF OFFSET >= SIZE,
      ISZ T0CIO     ALSO SET OVERFLOW.
      LDA T0CIO     OVERFLOW INDICATOR. 
CIO03 CLO 
      SZA           IF OVERFLOW OCCURED,
      STO           RETURN OVERFLOW=1.
      JMP CI2.F,I   DONE. F.CIO = OFFSET. 
* 
T0CIO NOP           OVERFLOW FLAG.
T1CIO NOP           ADDR CURRENT SUBSCRIPT. 
T2CIO NOP           LOOP COUNTER. 
T4CIO NOP           ADDR F.A ENTRY CURRENT LOWER BOUND. 
T5CIO BSS 2         # WORDS PER ELEMENT.
T6CIO BSS 2         TEMP. 
* 
      END 
ASMB,Q,C
      HED FTN4X COMPILER (F4X.1:EXPRESSION --> POSTFIX) **
      NAM F4X.1,5 92834-16002 REV.2030 800613 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*************************************** 
*     FORTRAN-4 COMPILER OVERLAY 1
*************************************** 
* 
*     THIS OVERLAY IS THE EXPRESSION EVALUATOR. 
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   EXT     F..E     DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
   EXT     F.AF     ADDRESS FIELD CURREXT F.A 
       EXT F.DPJ    DEF TO CURRENT PROCESSOR JUMP TABLE.
   EXT     F.EM     EMA FLAG BIT IN A.T.
     EXT   F.ERX    GLOBAL ERROR RECOVERY ADDRESS.
       EXT F.FES    TWPE ENTRY FOR 1ST EXECUTABLE.
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.L      # WORDS ON STACK 2
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
       EXT F.P1E    PASS 1 ERROR RECOVERY POINT.
       EXT F.S1T    TOP    OF STACK 1  *** OBSOLETE ? *** 
   EXT     F.S2B    BOTTOM OF STACK 2 
       EXT F.S2T    TOP    OF STACK 2 
       EXT F.SBF    0= MAIN, ELSE SUBROUTINE
       EXT F.SEE    RETURN FROM F4.1
   EXT     F.SFA    F.A OF CURRENT STATEMENT FUNCTION.
       EXT F.SIM    SAVED ITEM MODE (NEG CONSTS)
       EXT F.SFF    SUBROUTINE/FUNCTION FLAG 0/1
       EXT F.SLF    LEVEL OF CURRENT STATEMENT. 
      EXT  F.STC    SAVE F.TC (NEG CONSTS)
     EXT   F.SVL    SAVE # WORDS ON OPER STACK (F.L)
       EXT F.SXF    COMPLEX CONSTANT FLAG 
     EXT   F.TC     NEXT CHARACTER
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     AI.F     ASSIGN ITEM TO A.T. 
   EXT     DAT.F    DEFINE (AT) 
     EXT   ER.F     ERROR PRINT SUBROUTINE
   EXT     ESC.F    ESTABLISH CONSTANT. 
     EXT   EXN.F    EXAMINE NEXT CHARACTER
   EXT     FA.F     FETCH ASSIGNS 
     EXT   ICH.F    INPUT A CHARACTER.
     EXT   II.F     INPUT ITEM
       EXT WS1.F    OUTPUT WORD TO SCRATCH FILE # 1.
* 
*     ENTRY POINTS FOR ROUTINES IN THIS SEGMENT 
* 
      ENT EE.F      EXPRESSION ANALIZER (THE WHOLE REASON FOR EXISTANCE)
      ENT PU2.F     PUSH ONTO OPERATOR STACK
      ENT FER.F     FORM PROGRAM ENTRANCE 
* 
*                   STATEMENT PROCESSORS IN THIS SEGMENT. 
* 
      EXT F.ASS     ASSIGNMEXT STATEMENT PROCESSOR
      EXT F.ASP     ASSIGN STMT. PROCESSOR
      EXT F.BSP     BACKSPACE STMT. PROCESSOR 
      EXT F.CAL     CALL STATEMENT PROCESSOR
      EXT F.CLP     CLOSE STATEMENT PROCESSOR.
      EXT F.CON     CONTINUE STMT. PROCESSOR
      EXT F.DCP     DECODE PROCESSOR. 
      EXT F.DOP     DO STATEMENT PROCESSOR
      EXT F.ECP     ENCODE PROCESSOR. 
      EXT F.EDP     END IF STATEMENT PROCESSOR. 
      EXT F.EFP     ENDFILE STMT. PROCESSOR 
      EXT F.ELP     ELSE STATEMENT PROCESSOR. 
      EXT F.ENP     END STATEMENT PROCESSOR.
      EXT F.GOP     GO TO STATEMENT PROCESSOR 
      EXT F.IFP     IF STATEMENT PROCESSOR
      EXT F.IQP     INQUIRE STATEMENT PROCESSOR.
      EXT F.OPP     OPEN STATEMENT PROCESSOR. 
      EXT F.PAP     PAUSE STMT. PROCESSOR 
      EXT F.PNT     PRINT STMT. PROCESSOR.
      EXT F.RDP     READ STATEMENT PROCESSOR
      EXT F.RTN     RETURN STMT. PROCESSOR
      EXT F.RWP     REWIND STMT. PROCESSOR
      EXT F.SFP     STATEMEXT FUNCTION PROCESSOR
      EXT F.STP     STOP STMT. PROCESSOR
      EXT F.THP     THEN STATEMENT PROCESSOR. 
      EXT F.WRP     WRITE STATEMEXT PROCESSOR 
* 
*                   THE FORMAT PROCESSOR IN 'DSP.F' 
*                   THE MODIFIED STMT # FETCHER.
* 
      EXT F.FMT     FORMATS.
      EXT ISD.F     INPUT STMT #, MODIFY IF 'DO' TERM.
      SPC 2 
A     EQU 0         A-REGISTER
B     EQU 1         B-REGISTER
      SUP 
      SPC 1 
      DEC 1         OVERLAY NUMBER
      SKP 
*         ************************
*         * PROCESSOR JUMP TABLE *
*         ************************
      SPC 1 
*     THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY
*     THE DISPATCHER.  THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS
*     0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE
*     MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS.
*     THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . 
*     THE ORDINALS FOR THE FIRST 3 ENTRIES ARE SPECIAL-CASED IN THE 
*     DISPATCHER, AND ARE NOT TRUE ORDINALS.
* 
      DEF F.DOP     DO              (-2)
      DEF F.ASS     ASSIGNMENT STMT (-1)
F.PJT DEF F.SFP     STMT FCT.       (0) 
      DEF F.IFP     IF              (1) 
      DEF 0         EMA 
      DEF F.ENP     END 
      DEF F.CAL     CALL
      DEF F.GOP     GO TO 
      DEF F.RDP     READ
      DEF F.STP     STOP
      DEF 0         REAL
      DEF 0         DATA
      DEF F.THP     THEN
      DEF F.ELP     ELSE
      DEF F.OPP     OPEN
      DEF F.WRP     WRITE 
      DEF F.PNT     PRINT 
      DEF F.PAP     PAUSE 
      DEF F.EDP     ENDIF 
      DEF F.CLP     CLOSE 
      DEF F.RTN     RETURN
      DEF F.FMT     FORMAT
      DEF F.RWP     REWIND
      DEF 0         COMMON
      DEF F.ASP     ASSIGN
      DEF F.ECP     ENCODE
      DEF F.DCP     DECODE
      DEF F.EFP     END FILE
      DEF 0         INTEGER 
      DEF 0         COMPLEX 
      DEF 0         LOGICAL 
      DEF 0         PROGRAM 
      DEF F.IQP     INQUIRE 
      DEF 0         FUNCTION
      DEF F.CON     CONTINUE
      DEF 0         EXTERNAL
      DEF 0         IMPLICIT
      DEF 0         DIMENSION 
      DEF F.BSP     BACKSPACE 
      DEF 0         BLOCK DATA
      DEF 0         SUBROUTINE
      DEF 0         EQUIVALENCE 
      DEF 0         DOUBLE PRECISION
      SKP 
*                   *************************** 
*                   * HANDLE PROGRAM ENTRANCE * 
*                   *************************** 
* 
*     CALLED AT FIRST STATEMENT FUNCTION AND AT FIRST EXECUTABLE. 
* 
FER.F NOP 
      LDA F.FES     ALREADY GENERATED ENTRY SEQUENCE ?
      SZA,RSS 
      JMP FER02     NO. GO DO IT. 
* 
      SSA           YES. WAS IT DUE TO STATEMENT FUNCTION ? 
      JMP FER.F,I   NO. JUST EXIT.
* 
      LDA KK37      YES. DEFINE THE TWPE ENTRY. 
      JSB WR2.F 
      LDA F.FES 
      JSB WR2.F 
      JMP FER.F,I   THAT'S ALL. 
* 
*                   IF BLOCK DATA OR MAIN, NO PARAMS. 
* 
FER02 LDA F.SFF     IF BLOCK DATA 
      LDB F.SBF     OR MAIN PROG
      SZB 
      CPA K2
      JMP FER03     THERE IS NO ENTRY 
* 
*                   SET F.AT=DUM FOR ALL FORMALS. 
* 
      STB F.A 
      JSB FA.F      SET UP F.AF FOR LOOPING.  
* 
FER00 LDA F.AF      GET THE LINK TO THE NEXT DUMMY
      STA F.A       SET AS CURRENT. 
      SZA,RSS       IF END OF LIST
      JMP FER03     GO OUTPUT THE OPERATOR. 
* 
      JSB FA.F      SET UP ASSIGNS (INCL F.AF)
      LDA DUM       TYPE IT "DUM" 
      JSB DAT.F 
      JMP FER00     GO FOR MORE.
      SKP 
*                   WRITE PROGRAM ENTRY OPERATOR TO PASS FILE & EXIT. 
* 
FER03 LDA KK31      OPCODE=31, ONE ARGUMENT.
      JSB WR2.F 
      LDA F.SBF     ALSO F.A OF SUB/FCT.
      JSB WR2.F 
      LDA F.SLF     IF DUE TO STATEMENT FUNCTION, 
      CCB           (B=-1 TO FLAG NOT STMT FCT) 
      CPA K3
      RSS           (YES) 
      JMP FER04     NO. SET FLAG TO -1. 
* 
      LDA TWPE      YES. SET UP THE JUMP AROUND.
      JSB ESC.F 
      JSB AI.F
      LDB F.A       F.FES = F.A OF A TWPE ENTRY.
FER04 STB F.FES 
      JMP FER.F,I 
* 
DUM   OCT 5000
TWPE  OCT 40000     F.IM=TWPE.
CPX   OCT 50000 
ZPX   OCT 140000
K2    DEC 2 
KK31  BYT 1,37
KK37  BYT 1,45
B377  OCT 377 
      SKP 
*     *------------------*
*     *   START HERE     *
*     *------------------*
* 
F4.1  LDA DFP1E     JUST SET UP ERROR RECOVERY; 
      STA F.ERX 
      LDA DFPJT     AND ADDRESS OF PROC. JUMP TABLE.
      STA F.DPJ 
      JMP F.SEE     NOTHING ELSE TO DO HERE.
* 
DFP1E DEF F.P1E     PASS 1 ERROR RECOVERY ADDRESS.
DFPJT DEF F.PJT     DEF TO PROCESSOR JUMP TABLE.
EQFLG NOP           EQUALS FLAG 
      SKP 
*         *********************** 
*         * EXPRESSION ANALYZER * 
*         *********************** 
      SPC 1 
*     CALLING SEQUENCE: 
* 
*                   (POSSIBLY SET F.IM &/OR F.SIM)
*                   (POSSIBLE SET (A)=#SOFT LEFT PARENS)
*                   JSB EE.F
*                   BYT FLAGS,TYPE
*                -->(A) = # SOFT LEFT PARENS UNUSED.
* 
*     WHERE THE FLAGS ARE:
* 
*                   BIT 15: SOFT PAREN & F.SIM BIT.  IF SET,
*                           (A) MUST CONTAIN # OF SOFT PARENS,
*                           AND F.SIM MUST BE SET BY AN IDN.F 
*                           CALL. 
*                   BIT 8:  TEMP FLAG FOR PASS 2. 
* 
*     THE TYPES ARE:
* 
*          0, STATEMENT FUNCTION. 
*          1, SUBROUTINE CALL STATEMENT.
*       *  2, DO INITIAL PARAMETER. 
*          3, ARRAY ELEMENT IN I/O LIST.
*          4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. 
*          5, COMPUTED GO TO INDEX EXPRESSION.
*       *  6, ASSIGNMENT STATEMENT. 
*          7, IF EXPRESSION.
*       *  8, INPUT LIST-STYLE EXPRESSION.
*       *  9, OUTPUT LIST-STYLE EXPRESSION. 
* 
*     AND THE STARRED (*) TYPES REQUIRE THAT F.IM AND F.TC BE 
*     SET UP AS IF AN II.F CALL HAD BEEN MADE, AND THE OTHER
*     TYPES REQUIRE THAT THE NEXT ICH.F CALL GETS THE FIRST 
*     CHARACTER OF THE EXPRESSION.
* 
*                   INITIALIZE F.SIM & SOFT PAREN COUNT.
* 
EE.F  NOP 
      LDB EE.F,I    SET UP SOFT LEFT PAREN COUNT. 
      SSB,RSS       IF FLAG NOT SET,
      CLA           THEN COUNT IS ZERO. 
      STA T1EE
      CLA           ALSO ZERO OUT F.SIM 
      SSB,RSS       IF THE FLAG ISN'T SET.
      STA F.SIM 
      SKP 
*                   SEND START OP TO PASS FILE & INIT LOCALS. 
* 
      LDA KK32      SEND COUNT & OPERATOR TO PASS FILE. 
      JSB WS1.F 
      LDA EE.F,I    (A) = TYPE & FLAGS. 
      JSB WS1.F     SEND THRU PASS FILE.
      LDA EE.F,I    GET IT BACK,
      ISZ EE.F
      AND B377      EXTRACT TYPE IN LOW 4 BITS, 
      STA TYPEX     AND SAVE IT.
      LDA F.L       SAVE NO.OF WORDS ON OPERATOR
      STA F.SVL     STACK ON ENTRY (USUALLY 0)
      CLA 
      STA EQFLG     EQFEG =0  (NO '=' OP. ALLOWED)
      STA EMAFL     CLEAR EMA ASSIGNMENT FLAG.
      STA INAFL     CLEAR INVERSE ASSIGN FLAG.
      CCA 
      STA OPCOD     INITIALIZE OPCOD TO -1. 
      STA PRIOR     INITIALIZE PRIORITY TO -1.
      STA LASTC     SET PREVIOUS F.TC TO -1 AS A FLAG.
* 
*                   TYPE-DEPENDENT INITIALIZATION.
* 
      LDA F.IM      (IN CASE ALREADY UNDER WAY.)
      LDB EEJT1     SELECT NEXT OP BY JUMP TABLE. 
      ADB TYPEX 
      LDB B,I 
      JMP B,I 
EEJT1 DEF *+1 
      DEF EE030     STMT FCT. 
      DEF EE003     SUBR CALL.
      DEF EE007     DO INITIAL; ITEM ALREADY SCANNED. 
      DEF EE030     UNIT # ?
      DEF EE030     DO TERMINAL / STEP-SIZE.
      DEF EE030     COMPUTED GOTO.
      DEF EE009     ASSIGNMENT: ITEM ALREADY SCANNED. 
      DEF EE11      IF: STACK '('.
      DEF EE035     INPUT ITEM: ITEM ALREADY SCANNED. 
      DEF EE005     OUTPUT ITEM: DITTO, BUT CHECK UNARY OP. 
      SKP 
*                   SUBR CALL: IF SIMPLE, DO IT NOW.
* 
EE003 LDB F.TC
      CPB B50       IS F.TC A LEFT PARENTHESIS? 
      JMP EE035     YES; PROCESS ARG LIST.
* 
      LDA F.A       SUBROUTINE CALL (NO ARGS) 
      JSB WR1.F     OPND = SUB NAME,
      LDA K33       THEN OPERATOR.
      JSB WR2.F 
      JMP EXIT
* 
*                   FOR OUTPUT LIST, IF NO ITEM, ALLOW FOR UNARY OP.
* 
EE005 LDB F.TC      FOR +/- CHECK.
      CPB B53       IF +, 
      RSS 
      CPB B55       OR -, 
      SZA           AND NO ITEM YET,
      JMP EE035     (NO. REGULAR START) 
      JMP EE038     THEN JOIN UNARY +/- IN PROGRESS.
* 
*                   DO INITIAL. EXPECT '='. 
* 
EE007 CCA           JUST SET EQFLG = -1.
      STA EQFLG 
      JMP EE035     AND START WITH ITEM ALREADY SCANNED.
* 
*                   ASSIGNMENT. EXPECT '=', SET EMA FLAG. 
* 
EE009 CCA 
      STA EQFLG 
      JMP EE036 
      SPC 2 
T1EE  NOP           SOFT LEFT PAREN COUNT.
KM1   DEC -1
KK32  BYT 1,40      COUNT & OPERATOR. 
K33   DEC 33
      SKP 
*         **********************************
*         * EXPRESSION EVALUATOR MAIN BODY *
*         **********************************
      SPC 1 
*                   IF + OR -, DECIDE IF UNARY OR BINARY. 
* 
EE03  LDB F.TC      SAVE CURRENT F.TC AS
EE01  STB LASTC     PREVIOUS F.TC.
EE030 JSB EXN.F     EXAMINE NEXT CHARACTER. 
      CPA B53       IF '+'
      JMP EE031 
      CPA B55       OR '-', 
      RSS           SEE IF IT IS UNARY
      JMP EE034     NEITHER; INPUT ITEM AND CONT. 
EE031 LDA LASTC     A '+' OR '-' IS THE NEXT CHAR.
      CPA B75       IF LAST F.TC WAS AN '=' 
      JMP EE032 
      CPA B50       OR '(', 
      JMP EE032 
      CPA B54       OR COMMA, 
      JMP EE032     THEN '+' OR '-' IS UNARY. 
      SSA           IF NEGATIVE, BEGINNING OF EXPR.,
      JMP EE032     THEN '+' OR '-' IS UNARY. 
      LDA KM11
      STA TKM9      COUNTER FOR 11 LOG. & REL. OPS. 
      LDB RELOP 
EE131 LDA B,I       (A)=RELATIONAL OPERATOR 
      CPA LASTC     IF LASTC IS REL OP
      JMP EE032     THEN '+' OR '-' IS UNARY
      ADB K2
      ISZ TKM9      LOOKED AT ALL OF THEM?
      JMP EE131     NO. 
      JSB ICH.F     NONE OF ABOVE; IT IS A BINARY 
      CLA           '+' OR '-'. INCREMENT F.CC PAST IT
      STA F.IM      F.IM=0 FOR BINARY + OR -
      JMP EE035     SET F.IM IN A TO 0 AND PROCESS IT.
      SPC 1 
EE032 JSB II.F      INPUT OPERATOR OR SIGNED CONSTANT 
      SZA           IF F.IM#0, THEN IT IS A SIGNED
      JMP EE035     CONSTANT. GO PROCESS IT.
EE038 LDB F.TC      MUST BE + OR - A VARIABLE.
      CPB B53       IF A '+', IGNORE IT 
      JMP EE01      SAVE IT AS LAST F.TC
EE033 LDA B40       CHANGE F.TC = UNARY - TO BLANK. 
      JMP EE14A     PROCESS UNARY '-' DIRECTLY. 
      SPC 1 
B40   OCT 40
LASTC NOP 
KM11  DEC -11 
TKM9  NOP           COUNTER 
RELOP DEF OR. 
      SKP 
*          *****************
*          * GET NEXT ITEM *
*          *****************
* 
*                   OPERATORS & DELIMS DONE ELSEWHERE.
* 
EE034 LDA F.SIM     DELAYED CONSTANT ?
      SZA,RSS 
      JMP EE037     NO. 
* 
      STA F.IM      YES. SET IT UP. 
      LDB F.STC 
      STB F.TC
      CLB 
      STB F.SIM     CLEAR THE FLAG. 
      JSB AI.F      ENTER INTO A.T. 
      JMP EE035     ALREADY WAS INPUT!
* 
EE037 JSB II.F      ELSE INPUT AN ITEM. 
EE035 LDB F.TC
      CCE,SZA,RSS   IS F.IM=0?
      JMP EE08      YES, NO OPERAND TO STACK
* 
*                   CHECK FOR MISSING OPERATOR. 
*                   CHECK ITEM USAGE. 
*                   OUTPUT OPERAND TO PASS FILE.
* 
      CLB,RSS       CLEAR THE EMA ASSIGNMENT FLAG,
EE036 LDB F.EM      (SET IT PROPERLY FOR FIRST ITEM)
      STB EMAFL     SINCE ONLY APPLIES TO FIRST ITEM. 
      LDB LASTC     IF CHARACTER PRECEDING
      CPB B51       NAME OR CONSTANT IS ')',
      JMP EE16      ERROR 53 - MISSING OPERATOR 
      LDA F.TC      IF CURRENT F.TC IS .NOT., 
      CPA NO
      JMP EE16      MISSING OPERATOR. 
      LDB F.IU      ITEM USAGE ZERO ? 
      SZB,RSS 
      JMP EE045     YES, ILG USE OF NAME. 
      LDA F.A       WRITE F.A TO PASS FILE. 
      JSB WR1.F 
      LDB F.TC      IS F.TC A '(' ? 
      CPB B50 
      JMP EE04      YES, MAKE SURE F.IU=SUB OR ARR
      JMP EE09      FIND OUT WHAT OP OR DELIM IS. 
      SKP 
*                   ITEM FOLLOWED BY '('. MUST BE SUB OR ARRAY. 
* 
EE04  LDB F.A       IS IT THE CURRENT FUNCTION/SUB ?
      LDA K75 
      CPB F.SBF 
      JSB ER.F      YES. RECURSION ILLEGAL. 
      LDB F.IU      ELSE WHAT IS IT ? 
      CPB ARR       F.IU = ARRAY? 
      JMP EE05      YES, '(' IS VALID. STACK. 
* 
      CPB SUB       F.IU=SUBPROGRAM?
      RSS           YES, '(' IS VALID.
      JMP EE045     NO. ILLEGAL USE.
* 
      LDA TYPEX     IF SUBROUTINE CALL, (TYPE=1), 
      CMA,INA       (-1 IFF SUB CALL) 
      AND LASTC     AND PROCESSING THE SUBROUTINE NAME, 
      INA,SZA,RSS   WELL ?
      JMP EE043     YES. GO STACK IT. 
* 
      LDA F.A,I     NO. FUNCTION REF, FLAG IT.
      IOR B20 
      STA F.A,I 
EE043 LDA KK26      ('[' IS CODE=26, PRIOR=1.)
      JSB PU2.F     STACK OPERATOR. 
      LDA OPCOD     SEND TO PASS FILE TOO.
      JSB WR2.F 
      JMP EE48      GO CHECK FOR ALT RTNS.
* 
EE045 LDA K22       ILLEGAL USAGE OF NAME 
      JSB ER.F
* 
*                   ARRAY REFERENCE.
* 
EE05  LDA KK27      STACK '<' AS CODE=27, PRIOR=1.
      LDB EMAFL     IF THIS IS A TARGET EMA VARIABLE
      CCE,SZB,RSS   THEN  (E=1) 
      JMP EE06      (NO)
* 
      RAL,ERA       SET THE SIGN BIT TO REMEMBER THAT.
      STB INAFL     ALSO SET INVERSE ASSIGN FLAG. 
EE06  JSB PU2.F     STACK OPERATOR
      LDA OPCOD     ALSO SEND TO PASS FILE. 
      JSB WR2.F 
      JMP EE03      INPUT NEXT ELEMENT
      SPC 1 
B20   OCT 20
B50   OCT 50
B53   OCT 53
B54   OCT 54
B55   OCT 55
K22   DEC 22
K75   DEC 75
KK26  BYT 32,1      CODE=26, PRIORITY=1 (LEFT BRAKT)
KK27  BYT 33,1      CODE=27, PRIORITY=1 (LEFT BRACE)
SUB   OCT 200 
ARR   OCT 600       F.IU=3 (ARRAY)
NO    ASC 1,NO
INAFL NOP           INV ASS FLAG: CHANGES = TO INVERSE =. 
EMAFL NOP           EMA FLAG: CURRENT ITEM IS FIRST & EMA.
      SKP 
*          *************************
*          * OPERATOR OR DELIMITER *
*          *************************
      SPC 1 
*                   CHECK FOR '('.
*                   CHECK FOR ADJACENT OPERATORS. 
* 
EE08  CPB B50       IS F.TC = '('?
      JMP EE11      YES, IT MUST START A SUB EXPRES.
EE09  LDA F.IM      F.IM OF PRESENT ITEM IS 0?
      SZA 
      JMP EE095     NO - PROCESS OPERAND-TC COMBINATION.
      LDA LASTC      YES - PREVIOUS CHARACTER IN THIS 
      CPB NO        IF PRESENT OPERATOR IS .NOT.
      JMP EE096 
      CPA B51       2 ADJACENT SPECIAL CHARACTER
      JMP EE095     COMBINATION MUST BE A ')' OR
* 
      CPB B51       MAYBE AN EMPTY PARAM LIST ? 
      RSS           MUST END WITH RIGHT PAREN.
      JMP EE16      (NO. ERROR 53)
* 
      LDA OPCOD     YUP. HOW ABOUT BEFORE IT... 
      CPA SOP[      WAS LAST A FUNCT/SUB LEFT PAREN ? 
      JMP EE095     YES. EMPTY PARAM LIST.
      JMP EE16      ERROR 53 - MISSING OPERAND. 
* 
EE096 CPA NO        IF PREVIOUS OPERATOR IS .NOT.,
      JMP EE16      ERROR 53 - ADJACENT OPERATORS 
      JMP EE14      PROCESS DIRECTLY
* 
*                   CHECK FOR ')'  ','  'C/R' 
* 
EE095 CLA           (A=0) 
      CPB B51       F.TC = ) ?
      JMP EE12      YES 
      CPB B54       NO, IS F.TC = ',' 
      JMP EE12      YES 
      CPB B15       NO, IS F.TC =  'C/R' ?
      RSS 
      CPB B47       OR SINGLE QUOTE,
      RSS 
      CPB B72       OR COLON ?
      JMP EE115     YES. (A)=0. 
      JMP EE14      GO SEARCH FOR THE OPERATOR. 
* 
EE12  LDB OPCOD     ')' OR ','; CHECK FOR:
      CPB SOP[      TOS IS START OF SUBR CALL, THEN IT
      LDA K59       MIGHT BE EMA CALL-BY-REF; GET OP. 
      CPB SOPPR     TOS IS LEFT PAREN, THEN IT MIGHT
      LDA K60       BE EMA CALL-BY-VALUE; GET OP. 
      CPB SOP<      TOS IS START OF ARRAY REF, THEN FORCE 
      LDA K60       SUBSCRIPT MAPPING BEFORE ARRAY MAPPING. 
      STA VREFF     SAVE THAT AS THE VALUE/REFERENCE FLAG.
* 
      LDA K3        SET CURRENT PRIORITY OF DELIMITER 
EE115 STA CPRIO     TO 3 AND CURRENT OPCOD=0, THEN
      CLA           GENERATE CODE USING F.TC LATER
      STA CCODE     TO 'REMEMBER' WHAT DELIMITER
      JMP EE40      WAS SCANNED.
      SPC 1 
B52   OCT 52
B75   OCT 75
KK25  BYT 31,1      CODE=25, PRIORITY=1 (LEFT PAREN)
K59   DEC 59        OPCODE FOR CALL-BY-REF SIGNAL.
K60   DEC 60        OPCODE FOR CALL-BY-VALUE SIGNAL.
      SPC 1 
*                   LEFT PAREN.  TAKE CARE WITH COMPLEX CONSTANTS.
* 
EE11  STB F.SXF     SET TO NON-ZERO AS A FLAG 
      LDA KK25      STACK '(' AS CODE=25,PRIOR=1. 
      JSB PU2.F     STACK THE '(' 
      JSB II.F      INPUT NEXT ITEM 
      LDB F.NT      (B)= ITS NAME TAG 
      CPA CPX       IF ITS ITEM MODE IS COMPLEX AND 
      RSS 
      CPA ZPX 
      SZB,RSS       IT IS A CONSTANT, 
      JMP EE110     NOT A COMPLEX CONSTANT  STACK WAS RIGHT 
      JSB PO2.F     SHOULD NOT HAVE STACKED THE '(' SO FIX IT 
      JMP EE035     A COMPLEX CONSTANT WAS INPUT. 
* 
EE110 LDA LASTC     IF PREVIOUS F.TC IS A ')' 
      CPA B51 
      JMP EE16      ERROR 53 - MISSING OPERATOR.
      LDA B50 
      STA LASTC     SET PREVIOUS F.TC TO '('. 
      LDA F.IM      GET F.IM OF ITEM JUST INPUT.
      SZA 
      JMP EE035 
      LDB F.TC      IF CHAR INPUT IS
      CPB B53       UNARY +, THEN 
      JMP EE01      IGNORE IT AND INPUT NEXT ITEM.
      CPB B55       UNARY -, THEN 
      JMP EE033     PROCESS AS UNARY MINUS
      JMP EE035     OTHERWISE PROCESS CURRENT ITEM
      SKP 
*          *****************************
*          * SEARCH TABLE FOR OPERATOR *
*          *****************************
      SPC 1 
*                   THE SEARCH PROPER.
* 
EE02  JSB ICH.F     SHOVE F.CC PAST SECOND '*'
      LDA DSTAR     CHANGE F.TC TO '**' 
EE14A STA F.TC
EE14  CLA           (A) WILL BE CODE FOR OPERATOR 
      LDB OPTBL 
      INB 
EE15  STB T0EE      SEARCH OP. TABLE FOR
      INA           MATCH WITH F.TC.
      LDB B,I       (B) = THIS OP IN TABLE. 
      CPB F.TC      IS THIS IT ?
      JMP EE17      YUP ! 
      LDB T0EE      NO. ADVANCE IN TABLE. 
      ADB K2
      CPB EOPTB     END OF TABLE ?
      JMP EE16      YES. ERROR. 
      JMP EE15      NO. GO ON.
* 
*                   GOT IT. CHECK FOR '**'. 
* 
EE17  STA CCODE     FIRST, SAVE CODE. 
      CPB B52       IS IT '*' SO FAR ?
      RSS           YES.
      JMP EE19      NO. 
      JSB EXN.F     YES. LOOK AT NEXT CHAR. 
      LDB B52 
      CPB F.TC      IS IT '*' ? 
      JMP EE02      YES. SET UP '**'. 
      STB F.TC      NO. RESTORE F.TC .
* 
*                   DON'T ALLOW A SECOND '='. 
* 
EE19  CPB B75       IS OPERATOR AN '='? 
      RSS           YES, MAKE SURE IT IS LEGAL. 
      JMP EE18      NO, PROCESS OPR 
* 
      LDA INAFL     YES. IS INVERSE ASSIGN SET ?
      LDB K19 
      SZA           IF SO,
      STB CCODE     CHANGE OPCODE. (PRIORITY IS SAME) 
      ISZ EQFLG     IS '=' ALLOWED AND NONE SEEN YET? 
      JMP EE16      NO,'=' IS ILLEGAL IN PRESENT EXP
      SKP 
*                   SET UP CODE & PRIORITY. 
*                   IF PRIOR > TOP-OF-STACK, STACK IT, ELSE USE IT. 
* 
EE18  ISZ T0EE      YES, OPERATOR IS LEGAL, PROCESS.
      LDB T0EE,I    CPRIO _ PRIORITY OF OPERATOR
      STB CPRIO 
      LDA CCODE     (A) _ CODE (ORDINAL) OF OPERATOR. 
      ALF,ALF 
      IOR B         (A) _ CODE, PRIORITY
      CMB,INB       CHECK OP PRIORITY AGAINST TOP OP
      ADB PRIOR 
      CPA KK07      IF OPERATOR IS **,
      ADB KM1       EVALUATE RIGHT-TO-LEFT. 
      SSB,RSS       IS PRIORITY > TOP OP. PRIORITY? 
      JMP EE20      NO, GENERATE CODE 
      JSB PU2.F     YES, STACK OP, INPUT NEXT ITEM
      JMP EE03
      SPC 1 
K3    DEC 3 
B15   OCT 15
EOPTB DEF EOPT
B47   OCT 47        ' 
B72   OCT 72        : 
B51   OCT 51
DSTAR ASC 1,**
KK07  BYT 7,13      CODE=7, PRIORITY=11 (**). 
CCODE NOP           CURRENT OPERATOR CODE 
CPRIO NOP           CURRENT OPERATOR PRIORITY 
OPTBL DEF TABLE-1   OPERATOR TABLE
T0EE  NOP 
      SPC 5 
*          ***********************
*          * HANDLE THE OPERATOR *
*          ***********************
      SPC 1 
*                   CHECK FOR END & MISMATCHED PARENS.
* 
EE42  SSA           IF OPCOD < 0, 
      JMP EXIT      END OF INPUT EXPRESSION.
EE20  LDA OPCOD     NEXT OPERATOR CODE
      CPA SOP<      IF '<'  '(' OF ARRAY
      JMP EE44      ERROR - MISMATCHED PARENS.
      CPA SOPPR     IF '('
      JMP EE44      ERROR - MISMATCHED PARENS.
      CPA SOP[      IF '['
      JMP EE44      ERROR - MISMATCHED PARENS.
* 
*                   WRITE OPERATOR TO PASS FILE.
* 
      JSB WR2.F 
      JSB PO2.F     POP OPERATOR OFF STACK 2. 
      SKP 
*                   CONTINUE POPPING OPERATORS OF SAME OR GREATER PRIOR.
* 
EE40  LDA CPRIO 
      CMA,INA 
      ADA PRIOR     COMPARE OPERATOR PRIORITIES 
      SSA,RSS       IF PRIOR<CPRIO, STOP CODE GENERATION. 
      JMP EE20      IF (A) >=0, CONTINUE GEN. CODE
* 
*                   NOW HANDLE THIS OPERATOR. 
* 
      LDA CCODE 
      SZA,RSS       IF CCODE = 0
      JMP EE41      THEN CURRENT OP IS ')',',' OR C/R 
      ALF,ALF       NO, STACK OPERATOR
      IOR CPRIO     (A) = CCODE,CPRIO 
      JSB PU2.F     STACK OPERATOR
      JMP EE03
* 
SOPPR OCT 31
SOP[  OCT 32
SOP<  OCT 33
K34   DEC 34
TYPEX NOP           TYPE OF EXPRESSION. 
OPCOD NOP           TOP OPERATOR CODE.
PRIOR NOP           TOP OPERATOR PRIORITY.
VREFF NOP           EMA CALL-BY-(VALUE/REFERENCE) FLAG. 
      SKP 
*          ************************** 
*          * HANDLE ')'  ','  'C/R' * 
*          ************************** 
      SPC 1 
*                   C/R:   END OF EXPR. 
*                   COMMA: IF TOP IS SUB OR ARR ([,<), KEEP GOING.
*                          ELSE IF DO PARAMETER, EMPTY OP STACK.
*                          ELSE ERROR.
* 
EE41  LDA F.TC
      CPA B15       IF DELIMITER IS CARRIAGE RETURN,
      RSS 
      CPA B47       OR SINGLE QUOTE,
      RSS 
      CPA B72       OR COLON, 
      JMP EXIT      GO TO END OF EXPRESSION EVAL. 
* 
      LDA VREFF     ')' OR ','; SEE WHETHER 
      SZA           CALL-BY-VALUE/REF SET.
      JSB WS1.F     YES, OUTPUT THAT INFO.
      LDA F.TC      (RESTORE CHAR)
      CPA B51       IF DELIMITER IS ')',
      JMP EE43      GO HANDLE IT. 
* 
*                   COMMA.
* 
      LDA OPCOD     NO, MUST BE ',' 
      CPA SOP[      IF TOP OPERATOR IS '['. 
      JMP EE48      GO CHECK FOR ALTERNATE RETURNS. 
* 
      CPA SOP<      IF TOP OPERATOR IS '<'
      JMP EE03      CONTINUE SCAN OF EXPRESSION.
* 
      LDB EEJT2     CHECK TYPE OF INPUT EXPR. 
      ADB TYPEX 
      LDB B,I 
      JMP B,I 
EEJT2 DEF *+1 
      DEF EE16      STMT FCT - ERROR. 
      DEF EE16      SUBR CALL - ERROR.
      DEF EE42      DO INITIAL - O.K. 
      DEF EE42      UNIT # - O.K. 
      DEF EE42      DO TERM / STEP-SIZE - O.K.
      DEF EE16      COMPUTED GOTO - ERROR.
      DEF EE16      ASSIGNMENT - ERROR. 
      DEF EE16      IF - ERROR. 
      DEF EE42      INPUT ITEM - O.K. 
      DEF EE42      OUTPUT ITEM - O.K.
* 
EE16  LDA K17       ERROR, ILLEGAL OP OR DELIMITER. 
      JSB ER.F
      SKP 
*                   RIGHT PAREN.  MATCH WITH TOP OF STACK.
* 
EE43  LDA OPCOD 
      CPA SOPPR     IS TOP OPERATOR '('?
      JMP EE45      YES 
* 
      CPA SOP<      IS IT AND ARRAY?
      JMP EE46      YES. MAY BE EMA ASSIGNMENT. 
* 
      CPA SOP[      HOW ABOUT END OF FUNCTION SUB ? 
      JMP EE47      YES.
* 
      SSA,RSS       WAS STACK EMPTY ? 
      JMP EE49      NO. 
* 
      ADA T1EE      YES. DECREMENT # LEFT PARENS AVAIL. 
      SSA           WAS THERE ONE ? 
      JMP EE49      NO. 
* 
      STA T1EE      YES. UPDATE # LEFT. 
      JMP EE50      AND CONTINUE WITH MATCHED PARENS. 
* 
EE49  LDA TYPEX     INPUT LIST ITEM ? 
      CPA K8
      RSS           YES.
      CPA K9        OUTPUT LIST ITEM ?
      RSS           YES.
      CPA K4        DO TERM OR STEP-SIZE ?
      RSS           YES.
      CPA K3        UNIT # ?
      JMP EXIT      YES.
* 
*                   TRUE LEFT PAREN. MAKE SURE END OF 'IF' CAUGHT.
* 
EE44  LDA K9
      JSB ER.F      ERROR - MISMATCHED PARENTHESIS. 
EE45  JSB PO2.F     POP OFF '(' 
EE50  LDA OPCOD 
      SSA,RSS       IF (A) <0, OPERATOR STACK EMPTY 
      JMP EE03      NO, CONTINUE EXPRESSION SCAN
      LDA TYPEX     YES,
      CPA K7        IF INPUT EXPRESSION IS AN 'IF'
      JMP EXIT      END OF IF STATEMENT EXPRESSION
      CPA K8        LIKEWISE FOR INPUT LIST ITEM. 
      JMP EXIT
      JMP EE03      NO, CONTINUE STATEMENT SCAN.
      SKP 
*                   COMMA IN SUBROUTINE/FCT REF. CHECK FOR ALT RTNS.
* 
EE48  JSB EXN.F     WELL ?
      LDB B54       (RESTORE F.TC FOR LASTC)
      STB F.TC
      CPA B52       * ? 
      RSS 
      CPA B46       OR & ?
      RSS 
      JMP EE03      NO. 
* 
      JSB ICH.F     YES. READ THE * OR &. 
      CLA,INA       (A=1: STMT # IS NON-FORMAT) 
      JSB ISD.F     AND THE STATEMENT #.
      LDA F.A       SEND AS OPERAND.
      JSB WR1.F 
      LDA F.TC      MUST END WITH:
      CPA B54       ',' 
      RSS 
      CPA B51       OR ')'
      JMP EE41      YES. BACK WHERE WE STARTED. 
      JMP EE16      NO. ERROR.
      SKP 
*                   ARRAY.  CHECK FOR EMA ASSIGNMENT. 
* 
EE46  LDA F.S2T,I   WELL ? (SIGN BIT ON STACK ENTRY)
      SSA,RSS 
      JMP EE47      NO. 
* 
      JSB PO2.F     YES. POP THE '<', AND 
      JMP EE03      GO GET NEXT OPERATOR. 
* 
*                   SUBROUTINE OR NORMAL ARRAY. 
* 
EE47  LDA K34       WRITE OPERATOR TO PASS FILE.
      JSB WR2.F 
      JSB PO2.F     POP THE OPERATOR. 
      LDA PRIOR     IS TOP OPERATOR PRIORITY
      SSA,RSS       -1? (THEN OPERATOR STK IS EMPTY)
      JMP EE03      NO. 
* 
      CLA,INA       YES 
      CPA TYPEX     CALL STATEMENT? 
      RSS           (YES) 
      JMP EE03      NO. 
* 
      JSB ICH.F     YES. INPUT C/R. F.CAL CHECKS FOR IT.
* 
K19   DEC 19        INVERSE ASSIGN OPCODE.
      SKP 
*          ****************** 
*          * EXPRESSION END * 
*          ****************** 
      SPC 1 
EXIT  LDB TYPEX     IF STATEMENT FUNCTION, (0), 
      SZB 
      JMP EXIT1     (NO)
* 
      LDA F.SFA     GET ITS TYPE. 
      STA F.A 
      JSB FA.F
      LDA F.IM      IS IT...
      CPA DBL       REAL*6, 
      RSS 
      CPA RE8       REAL*8, 
      RSS 
      CPA CPX       OR COMPLEX ?
      RSS 
      CPA ZPX       OR DOUBLE COMPLEX ? 
      CLA,INA,RSS   (A=1) 
      JMP EXIT1     NO. RESULT FITS IN REGISTER.
* 
      JSB WR2.F     YES. ISSUE ASSIGNMENT.
EXIT1 LDA K35       WRITE OPERATOR TO TERMINATE.
      JSB WR2.F 
      LDA T1EE      RETURN (A) = # SOFT PARENS LEFT.
      JMP EE.F,I
      SPC 1 
DBL   OCT 60000 
RE8   OCT 120000
B46   OCT 46        & 
K9    DEC 9 
K35   DEC 35
K17   DEC 17
K4    DEC 4 
K7    DEC 7 
K8    DEC 8 
      SKP 
*         ****************
*         * PUSH STACK 2 *
*         ****************
      SPC 1 
*         STACK 2 IS THE OPERATOR STACK. IT IS IN LOWER CORE THAN 
*         IS STACK 1, JUST ABOVE THE ASSIGNMENT TABLE, AND GROWS
*         TOWARD HIGH CORE. THIS ROUTINE IS ENTERED WITH (A) =
*         WORD TO BE STACKED. 
      SPC 1 
PU2.F NOP           PUSH STACK 2 TO STACK OPERATORS 
      ISZ F.L       F.L=F.L+1 
      LDB F.S2B 
      ADB F.L 
      STB F.S2T 
      CPB F.S1T     IF TOP TWO POINTERS SAME, 
      JMP F.OFE     DATA POOL OVERFLOW. 
      STA F.S2T,I   STACK OPERATOR
      JSB SPC.F     UPDATE OPCOD, PRIOR OF TOP OP.
      JMP PU2.F,I 
      SPC 2 
*         *************** 
*         * POP STACK 2 * 
*         *************** 
      SPC 1 
PO2.F NOP           UNSTACK AND DISCARD OPERATORS 
      CCB 
      STB PRIOR     REINITIALIZE OPCODE AND PRIOR TO 0. 
      STB OPCOD 
      ADB F.L 
      STB F.L       F.L=F.L-1 
      ADB F.S2B 
      STB F.S2T     NEW PTR TO TOP OPERATOR 
      LDB F.L 
      CPB F.SVL     IS OPERATOR STACK EMPTY?
      RSS           YES, EXIT 
      JSB SPC.F     NO, UPDATE OPCOD, PRIOR OF TOP OP.
      JMP PO2.F,I 
      SPC 2 
*         ******************************
*         * SEPARATE CODE AND PRIORITY *
*         ******************************
      SPC 1 
SPC.F NOP 
      LDA F.S2T,I   (A) _ TOP WORD IN OPERATOR STACK
      AND B377
      STA PRIOR     PRIOR _ PRIORITY OF TOP OPERATOR
      XOR F.S2T,I 
      RAL,CLE,ERA   CLEAR POSSIBLE SIGN BIT 
      ALF,ALF 
      STA OPCOD     OPCOD _ CODE OF TOP OPERATOR
      JMP SPC.F,I 
      SKP 
*          ********************** 
*          * WRITE TO PASS FILE * 
*          ********************** 
      SPC 1 
WR1.F NOP           OPERAND.
      IOR KK01      SET SIGN BIT. 
      JSB WS1.F     WRITE TO PASS FILE. 
      JMP WR1.F,I   EXIT. 
      SPC 2 
WR2.F NOP 
      RAL,CLE,ERA   CLEAR SIGN BIT. 
      JSB WS1.F     WRITE IT TO PASS FILE.
      JMP WR2.F,I   EXIT. 
      SPC 1 
KK01  OCT 100000
      SKP 
*         OPERATOR TABLE    WORD 1: THE OPERATOR. 
*         2-WORD ENTRIES    WORD 2: ITS PRIORITY. 
      SPC 1 
TABLE OCT 75        =,
      OCT 1         PRIORITY=1, CODE=1
      SPC 1 
      OCT 53        +,
      DEC 8         PRIORITY=8, CODE=2
      SPC 1 
      OCT 55        -,
      DEC 8         PRIORITY=8, CODE=3
      SPC 1 
      OCT 40        UNARY - (BLANK) 
      DEC 9         PRIORITY=9, CODE=4
      SPC 1 
      OCT 52        *,
      DEC 10        PRIORITY=10, CODE=5 
      SPC 1 
      OCT 57        /,
      DEC 10        PRIORITY=10, CODE=6 
      SPC 1 
      ASC 1,**      **, 
      DEC 11        PRIORITY=11, CODE=7 
      SPC 1 
OR.   ASC 1,OR      LOGICAL OR, 
      OCT 4         PRIORITY=4, CODE=8
      SPC 1 
      ASC 1,AN      LOGICAL AND 
      OCT 5         PRIORITY=5, CODE=9
      SPC 1 
      ASC 1,NO      LOGICAL NOT,
      OCT 6         PRIORITY=6, CODE=10 
      SPC 1 
      ASC 1,LT      RELATIONAL LESS THAN, 
      OCT 7         PRIORITY=7, CODE=11 
      SPC 1 
      ASC 1,LE      RELATIONAL LESS OR EQUAL TO,
      OCT 7         PRIORITY=7, CODE=12 
      SPC 1 
      ASC 1,EQ      RELATIONAL EQUAL, 
      OCT 7         PRIORITY=7, CODE=13 
      SPC 1 
      ASC 1,NE      RELATIONAL NOT EQUAL, 
      OCT 7         PRIORITY=7, CODE=14 
      SPC 1 
      ASC 1,GE      RELATIONAL GREATER OR EQUAL TO, 
      OCT 7         PRIORITY=7, CODE=15 
      SPC 1 
      ASC 1,GT      RELATIONAL GREATER THAN,
      OCT 7         PRIORITY=7, CODE=16 
      SPC 1 
      ASC 1,EV      LOGICAL EQUIVALENCE,
      OCT 3         PRIORITY=3, CODE=17 
      SPC 1 
      ASC 1,XO      EXCLUSIVE OR,  (ALSO .NEQV. & .EOR.)
      OCT 3         PRIORITY=3, CODE=18 
      SPC 1 
      ASC 1,==      INVERSE ASSIGN, 
      OCT 0         PRIORITY=0, CODE=19 
* 
EOPT  EQU * 
* 
      UNS 
      END F4.1
ASMB,Q,C
      HED EXECUTABLE STATEMENT PARSING FOR FTN4X. 
      NAM EX.F,8 92834-16002 REV.2030 800814
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE PARSES ALL EXECUTABLE STATEMENTS. 
* 
*     EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS 
* 
*     THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS 
*     DEFINED IN AS FOLLOWS 
*                2 -- OA.F  (WRITE PASS FILE ROUTINES)
*                 3 -- NEX.F  (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) 
*                  4  -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) 
*                   5  -- EX.F  (STATEMEXTS USING THE EXPRESSION EVALUATOR) 
*                    6  -- IC.F  (THE CHARACTER INPUT ROUTINES) 
*                     7  -- IDN.F   (THE TOKEN INPUT ROUTINES)
*                      8  -- FTN4    ( THE MAIN)
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
   EXT     F.AT     ADDRESS TYPE OF CURRENT F.A 
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CRT    TEST FOR C/R & GO ON TO NEXT STMT.
   EXT     F.CSL    CHARACTER STRING LENGTH.
       EXT F.D      DO TABLE POINTER
   EXT     F.D0     ITEM SIZE.
       EXT F.DID    ADDRESS OF F.IDI
       EXT F.DO     LWAM - END OF DO TABLE
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.L      # WORDS ON STACK 2
     EXT   F.LFF    LOCICAL IF FLAG 
       EXT F.LNN    CURRENT LINE #. 
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
       EXT F.LSF    EXPECT FIRST STATEMEXT FLAG 
       EXT F.LSN    STMT # OF CURRENT STATEMENT.
       EXT F.LSP    LAST OPERATION FLAG 
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
   EXT     F.NTF    NO-TAG FLAG.
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
   EXT     F.S2B    BOTTOM OF STACK 2 
       EXT F.S2T    TOP    OF STACK 2 
       EXT F.SBF    0= MAIN, ELSE SUBROUTINE
       EXT F.SEG    SEGMENT LOADER. 
       EXT F.SEQ    SEQUENCE COUNTER, CODE-GENERATING STMTS.
   EXT     F.SFA    STATEMENT FUNCTION F.A
       EXT F.SFF    SUBROUTINE/FUNCTION FLAG. (SUB=0) 
       EXT F.STB    STRING BACK JUMP FLAG 
       EXT F.STS    TO STATEMEXT SCAN 
     EXT   F.TC     NEXT CHARACTER
   EXT     F.VDM    CURRENT ITEM'S VARIABLE DIMENSION BIT.
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     AI.F     ASSIGN ITEM 
      EXT  CDI.F    CLEAR IDI.
     EXT   CRP.F    ISSUE CROSS-REF PAIR. 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DAT.F    DEFINE (F.AT) 
   EXT     DS.F     DEFINE (F.S)=1
   EXT     EIC.F    ESTABLISH INTEGER CONSTANT. 
   EXT     ESC.F    ESTABLISH CONSTANT. 
     EXT   ER.F     ERROR PRINT SUBROUTINE
   EXT     ESC.F    ESTABLISH CONSTANT SUBROUTINE 
     EXT   EXN.F    EXAMINE NEXT CHARACTER
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
     EXT   IDL.F    INPUT DUMMY LIST. 
      EXT  IDN.F    INPUT ITEM, DO NOT ASSIGN.
     EXT   II.F     INPUT ITEM
     EXT   IIV.F    INPUT INTEGER VARABLE 
      EXT  ISC.F    INPUT STRING CONSTANT.
     EXT   ISN.F    INPUT STATEMEXT NUMBER
     EXT   ISY.F    INPUT SYMBOL
   EXT     ITS.F    INTEGER TEST
     EXT   IVN.F    INPUT VARIABLE/ARRAY NAME.
       EXT KWP.F    KEYWORD SEARCH, IN PROGRESS.
       EXT KWS.F    KEYWORD SEARCH ROUTINE. 
       EXT MVW.F    INTERNAL MOVE WORDS.
   EXT     NCT.F    TEST FOR NOT A CONSTANT 
   EXT     NET.F    TEST FOR NOT EMA. 
   EXT     NST.F    TEST FOR NOT A SUBROUTINE NAME
   EXT     NWI.F    COMPUTE # WORDS IN ITEM.
      EXT  RP.F     INPUT ')' 
     EXT   SCP.F    SAVE CURREXT STATPMEXT POSITION.
   EXT     TCT.F    TEST (A) = F.TC ELSE ER 28
   EXT     TS.F     TAG SUBPROGRAM SUB. 
   EXT     TV.F     TAG VARIABLE
     EXT   UC.F     UNINPUT COLUMN
     EXT   WAR.F    ERROR COMMEXT SUBROUTINE (WARNINGS) 
     EXT   WS1.F    WRITE WORD ON SCRATCH FILE 1. 
* 
*                   EXTERNALS IN EX.F . 
* 
      ENT F.ASP     ASSIGN STATEMENT PROCESSOR. 
      ENT F.ASS     ASSIGNMENT STATEMENT PROCESSOR. 
      ENT F.BSP     BACKSPACE STATEMENT PROCESSOR.
      ENT F.CAL     CALL STATEMENT PROCESSOR. 
      ENT F.CLP     CLOSE STATEMENT PROCESSOR.
      ENT F.CON     CONTINUE STATEMENT PROCESSOR. 
      ENT F.DCP     DECODE STATEMENT PROCESSOR. 
      ENT F.DOP     DO STATEMEXT PROCESSOR
      ENT F.ECP     ENCODE STATEMENT PROCESSOR. 
      ENT F.EDP     END IF STATEMENT PROCESSOR. 
      ENT F.EFP     ENDFILE STATEMENT PROCESSOR.
      ENT F.ELP     ELSE STATEMENT PROCESSOR. 
      ENT F.ENP     END STATEMENT PROCESSOR.
      ENT F.GOP     GO TO STATEMENT PROCESSOR 
      ENT F.IFP     IF STATEMEXT PROCESSOR
      ENT F.IQP     INQUIRE STATEMENT PROCESSOR.
      ENT F.OPP     OPEN STATEMENT PROCESSOR. 
      ENT F.PAP     PAUSE STATEMENT PROCESSOR.
      ENT F.PNT     PRINT STATEMENT PROCESSOR.
      ENT F.RDP     READ STATEMEXT PROCESSOR
      ENT F.RTN     RETURN STATEMENT PROCESSOR. 
      ENT F.RWP     REWIND STATEMENT PROCESSOR. 
      ENT F.SFP     STATEMEXT FUNCTION PROCESSOR
      ENT F.STP     STOP STATEMENT PROCESSOR. 
      ENT F.THP     THEN STATEMENT PROCESSOR. 
      ENT F.WRP     WRITE STATEMEXT PROCESSOR 
* 
      ENT ISD.F     INPUT STMT #, MODIFY FOR DO TERM. 
* 
* 
*     EXTERNALS IN THE SEGMENT
* 
      EXT APT.F     ALLOCATE PERMANENT TEMP.
      EXT EE.F      EXPRESSION EVALUATOR
      EXT PU2.F     PUSH ONTO STACK 2 SUB 
* 
*                   SYSTEM ROUTINES.
* 
      EXT .MVW
* 
A     EQU 0 
B     EQU 1 
      SUP 
      SKP 
*         ******************* 
*         * IF (  PROCESSOR * 
*         ******************* 
      SPC 1 
*                   ANALYZE EXPRESSION. CHECK WHAT FOLLOWS. 
* 
F.IFP JSB ICH.F     MAKE SURE IS 'IF('
      LDA B50 
      JSB TCT.F     TEST F.TC=(A) ? 
      JSB EE.F      EXPRESSION EVALUATOR
      BYT 0,7 
      LDA B51       ')' 
      JSB TCT.F     F.TC-TEST 
      JSB EXN.F     EXAMINE NEXT CHARACTER
      SZB           DIGIT?
      JMP IFLP6     NO. STATEMENT TO FOLLOW 
* 
*                   2-WAY OR 3-WAY. GET STMT #'S & OUTPUT.
* 
      STB T3IFL     SET DEFAULT OF 2-WAY. 
      CLA,INA       INPUT FIRST STMT # (NON-FORMAT) 
      JSB ISD.F 
      LDA F.A       T1IFL = 1ST STMT #. 
      STA T1IFL 
      LDA B54       , 
      JSB TCT.F 
      CLA,INA       INPUT SECOND STMT # (NON-FORMAT). 
      JSB ISD.F 
      LDA F.A       T2IFL = 2ND STMT #. 
      STA T2IFL 
      LDB F.TC
      LDA KK39A     (A=OP FOR 2-WAY)
      CPB B54       ',' ? 
      CLA,INA,RSS   YES. THIRD STMT # FOLLOWS 
      JMP IFLP2     NO. 2-WAY. A=OP.
      JSB ISD.F     INPUT THIRD STATEMENT #.
      LDA F.A       T3IFL = 3RD STMT #. 
      STA T3IFL 
      LDA KK39B     SEND 3-WAY OPCODE.
IFLP2 JSB WS1.F     OPCODE. 
      LDA F.SEQ     SEQUENCE COUNTER. 
      JSB WS1.F 
      LDA T1IFL     1ST STMT #
      JSB WS1.F 
      LDA T2IFL     2ND STMT #
      JSB WS1.F 
      LDA T3IFL     3RD STMT #
      SZA           (IF THERE)
      JSB WS1.F 
      JMP RTNP1 
      SKP 
*                   CLEAN UP & EXIT.
* 
RTNP1 LDA F.LFF     IF LOGICAL IF FLAG
      SZA,RSS       NOT SET 
      STA F.LSP     RESET LAST OPERATION FLAG 
CILDT LDA F.LFF     ILLEGAL DO TERM 
      SZA           ONLY IF NOT IN LOGICAL IF.
      JMP F.CRT     ELSE IT'S O.K.
* 
ILTRM CLA,INA       SET LAST STATEMENT
      STA F.LSF     FLAG  ILLEGAL TERMINATION 
      JMP F.CRT     GO TEST FOR END OF STATEMENT
      SPC 2 
*                   LOGICAL IF FOLLOWED BY STATEMENT. 
* 
IFLP6 LDB F.LFF     LOGICAL IF FLAG SET ? 
      LDA K52 
      SZB 
      JSB ER.F      YES. LOGICAL IF WITHIN LOGICAL IF 
      LDB F.TC      LOAD THE NEXT CHARACTER.
      CPB B15       END OF CARD?
      JMP IFLP1     YES. BITCH. 
      LDA KK40      SEND THE LOGICAL IF OPCODE. 
      JSB WS1.F 
      LDA F.SEQ     AND THE SEQUENCE COUNTER. 
      JSB WS1.F 
      LDA TWPE      FORM TWPE ENTRY.
      JSB ESC.F 
      JSB AI.F
      LDA F.A       SAVE THE F.A AS STRING-BACK ENTRY.
      STA F.STB 
      STA F.LFF     SET THE LOGICAL IF FLAG 
      JSB WS1.F     SEND F.A OF IT TO PASS 2. 
      JSB EXN.F     EXAMINE NEXT CHARACTER
      JSB SCP.F     SAVE CURRENT CARD POSITION FOR RESCAN 
      JMP F.STS     TO STATEMENT SCAN 
* 
IFLP1 ISZ F.CC      SET "F.CC" TO 1.
      LDA K89.      ERROR 89. 
      JSB ER.F
      SPC 2 
B15   OCT 15        C/R 
B51   OCT 51        ')' 
B54   OCT 54        ',' 
K52   DEC 52
K89.  DEC 89
KK39A BYT 3,47      2-WAY OPCODE. 
KK39B BYT 4,47      3-WAY OPCODE. 
KK40  BYT 2,50      LOGICAL IF OPCODE.
KK41  BYT 2,51      SIMPLE GOTO OPCODE. 
T1IFL NOP 
T2IFL NOP 
T3IFL NOP 
      SKP 
*         ******************
*         * THEN PROCESSOR *
*         ******************
      SPC 1 
F.THP LDB F.LFF     IN LOGICAL IF ? 
      LDA K10 
      SZB,RSS 
      JSB ER.F      NO. ERROR 10. 
* 
      LDA KM3       YES. ALLOCATE THREE WORDS ON DO STACK.
      JSB DPO.F 
      LDA B100K     TOS = 100000 (ENDIF TARGET) 
      LDB F.STB     TOS+1 = ELSE TARGET = FALSE BRANCH F.A
      ADB B100K     (SET SIGN TO FLAG THAT IT'S BLOCK IF) 
      DST F.D,I     PUT ON STACK. 
THP01 JSB ICH.F     ADVANCE TO THE C/R. 
      JMP ILTRM     ALWAYS ILLEGAL DO TERMINATOR. 
* 
K10   DEC 10
K50   DEC 50
KM2   DEC -2
KK55  BYT 2,67      ENDIF OPERATOR. 
      SPC 2 
*         ******************* 
*         * ENDIF PROCESSOR * 
*         ******************* 
      SPC 1 
F.EDP JSB EET.F     DO SOME ERROR CHECKING. 
      LDA KK55      OUTPUT ENDIF OPCODE.
      JSB WS1.F 
      LDA F.D,I     AND ENDIF TARGET. 
      ISZ F.D 
      JSB WS1.F 
      LDA F.D,I     AND ELSE TARGET.
      ISZ F.D 
      JSB WS1.F 
      ISZ F.D       (SKIP UNUSED THIRD WORD ON STACK) 
      JMP THP01     DONE. 
      SPC 2 
*                   SUBR TO CHECK IF VALID ELSE, ELSEIF, ENDIF. 
* 
EET.F NOP 
      LDA K50       IF TRUE BRANCH OF LOGICAL IF, 
      LDB F.LFF 
      SZB 
      JSB ER.F      THEN ERROR 50.
      LDB F.LSN     STATEMENT NUMBER ?? 
      LDA K77       IF SO, WARNING. 
      SZB 
      JSB WAR.F 
      LDA K30       IF DO STACK EMPTY,
      LDB F.D 
      CPB F.DO
      JSB ER.F      THEN NO MATCHING 'THEN'.
      INB           IF TOP ENTRY IN DO STACK
      LDB B,I       IS FOR A DO LOOP, 
      SSB,RSS 
      JSB ER.F      THEN NESTING ERROR. 
* 
      JMP EET.F,I   ELSE O.K. 
* 
K30   DEC 30
K77   DEC 77
      SKP 
*         ******************
*         * ELSE PROCESSOR *
*         ******************
      SPC 1 
F.ELP JSB EXN.F     CHECK NEXT CHARACTER AFTER 'ELSE'.
      CPA B15       END OF LINE ? 
      JMP ELP00     YES. JUST AN ELSE.
* 
      JSB ICH.F     ELSE MUST BE 'ELSE IF'
      LDA "I" 
      JSB TCT.F 
      JSB ICH.F 
      LDA "F" 
      JSB TCT.F 
      CCA,RSS       ELSEIF. FLAG=-1.
ELP00 CLA           ELSE. FLAG=0. 
      STA T1ELP     SAVE ELSE/ELSEIF FLAG.
      JSB EET.F     DO SOME ERROR CHECKING. 
      DLD F.D,I     ARE WE CURRENTLY IN AN ELSE PART ?
      LDA K30 
      CPB B100K 
      JSB ER.F      YES. TWO ELSE'S IN A ROW. 
* 
      LDB F.D,I     ENDIF TARGET. 
      CPB B100K     DOES IT EXIST ? 
      RSS 
      JMP ELP01     YES. (DUE TO ELSEIF)
* 
      LDA TWPE      NO. CREATE ONE. 
      JSB ESC.F 
      JSB AI.F
      LDA F.A       AND PUT IT ON STACK.
      STA F.D,I 
ELP01 LDA KK54      OUTPUT OPERATOR FOR ELSE. 
      JSB WS1.F 
      LDA F.D,I     WITH: ENDIF TARGET. 
      JSB WS1.F 
      DLD F.D,I 
      LDA B         AND ELSE TARGET.
      JSB WS1.F 
      LDB F.D       ZAP THE ELSE TARGET,
      LDA B100K     TO SHOW THAT WE'RE IN THE 
      INB           ELSE PART NOW, AND ONLY 
      STA B,I       ENDIF IS LEGAL FROM NOW ON. 
      ISZ T1ELP     IS IT ELSE OR ELSEIF ?
      JMP THP01     ELSE. DONE. 
      SKP 
*                   ELSEIF PROCESSING.
* 
      JSB ICH.F     VERIFY '('
      LDA B50 
      JSB TCT.F 
      JSB EE.F      GET LOGICAL EXPRESSION. 
      BYT 0,7 
      LDA B51       VERIFY ')'
      JSB TCT.F 
      JSB KWS.F     VERITY 'THEN' 
      DEF "THEN 
      ADA K30 
      CPA K30       FOUND ? 
      JSB ER.F      NO. 
* 
      LDA KK40      LOGICAL IF OPCODE.
      JSB WS1.F 
      LDA F.SEQ     SEQUENCE COUNTER (NOT USED HERE)
      JSB WS1.F 
      LDA TWPE      FORM THE TWPE ENTRY.
      JSB ESC.F 
      JSB AI.F
      LDA F.A       AND SEND IT.
      JSB WS1.F 
      LDA F.A       ALSO USE IT AS THE ELSE TARGET. 
      IOR B100K 
      LDB F.D 
      INB 
      STA B,I 
      JMP THP01     DONE. 
* 
KK54  BYT 2,66      ELSE OPERATOR.
T1ELP NOP           ELSE/ELSEIF FLAG. 
"I"   BYT 0,111 
"F"   BYT 0,106 
"THEN ASC 3,THEN
      SKP 
*         ******************* 
*         * GO TO PROCESSOR * 
*         ******************* 
      SPC 1 
F.GOP JSB EXN.F     EXAMINE NEXT CHARACTER
      SZB           CHAR. A DIGIT?
      JMP GOTO2     NO
* 
      CLA,INA       INPUT (NON-FORMAT) STMT #.
      JSB ISD.F 
      LDA F.LFF     ON TRUE SIDE OF LOGICAL IF ?
      SZA 
      JMP GOTO1     YES. SPECIAL CASE.
* 
      STA F.LSP     NO. RESET LAST OP FLAG. 
      LDA KK41      OUTPUT SIMPLE 'GOTO'. 
      JSB WS1.F 
      LDA F.SEQ     WITH SEQUENCE COUNTER.
      JSB WS1.F 
      LDA F.A       AND STMT #. 
      JSB WS1.F 
      JMP RTNP1     DONE. ILLEGAL DO TERMINATOR.
* 
GOTO1 LDA F.A       LOGICAL IF. SET F.AF OF THE 
      CMA           STRINGBACK ENTRY TO THE 
      ISZ F.STB     COMPLEMENT OF THE F.A OF
      STA F.STB,I   THE TARGET STATEMENT #. 
      CLA           CLEAR THE STRINGBACK FLAG.
      STA F.STB 
      JMP RTNP1     THAT'S ALL. 
      SPC 2 
*         ***************** 
*         * ASSIGNED GOTO * 
*         ***************** 
      SPC 1 
GOTO2 SEZ           CHAR A LETTER ? 
      JMP GOTO4     NO. DELIMITER.
* 
      ISZ F.NTF     ASSIGNED; INPUT INTEGER VARIABLE
      JSB IIV.F     (NO-TAG FLAG IN CASE LEFT PAREN AFTER)
      LDA F.A       SAVE ITS F.A FOR LATER. 
      STA T1GOT 
      CLA           SET DEFAULT COUNT = 0.
      STA T1IBL 
      LDA F.TC      BRANCH LIST ? 
      CPA B15           
      JMP GOTO3     NO. END OF STMT.
* 
      CPA B54       YES. OPTIONAL COMMA ? 
      RSS           YES. HAVE ALREADY READ IT.
      JSB UC.F      NO. BACK UP SO CAN RE-READ LEFT PAREN.
      JSB IBL.F     INPUT BRANCH LIST 
GOTO3 LDA KK42      OUTPUT ASSIGNED GOTO OPERATOR.
      JSB WS1.F 
      LDA T1GOT     AND VARIABLE. 
      JSB WS1.F 
      LDA T1IBL     AND LENGTH OF BRANCH LIST.
      JSB WS1.F 
      LDA F.LFF     UNLESS IN TRUE PART OF LOGICAL IF,
      SZA,RSS 
      STA F.LSP     RESET LAST OP FLAG. 
      JMP RTNP1     DONE. MAKE SURE NOT END OF 'DO'.
      SKP 
*         ***************** 
*         * COMPUTED GOTO * 
*         ***************** 
      SPC 1 
GOTO4 JSB IBL.F     COMPUTED; INPUT BRANCH LIST 
      CPA B54       NEXT CHAR = , ? 
      RSS           (IT'S OPTIONAL) 
      JSB UC.F      NO. UNINPUT COLUMN
      JSB EE.F      EVALUATE GOTO INDEX EXPR. 
      BYT 0,5 
      LDA KK43      OUTPUT COMPUTED GOTO OPERATOR.
      JSB WS1.F 
      LDA F.SEQ     AND SEQUENCE COUNTER. 
      JSB WS1.F 
      LDA T1IBL     AND LENGTH OF BRANCH LIST.
      JSB WS1.F 
      LDA F.LFF     UNLESS IN TRUE PART OF LOGICAL IF,
      SZA,RSS 
      STA F.LSP     RESET LAST OP FLAG. 
      JMP RTNP1     DONE. MAKE SURE ISN'T 'DO' END. 
      SPC 2 
B50   OCT 50        '(' 
B100K OCT 100000
T1IBL NOP           NO. OF STMT NUMBERS 
T1GOT NOP 
KK42  BYT 2,52      ASSIGNED GOTO OPERATOR. 
KK43  BYT 2,53      COMPUTED GOTO OPERATOR. 
      SPC 2 
*         ********************* 
*         * INPUT BRANCH LIST * 
*         ********************* 
      SPC 1 
IBL.F NOP 
      CLA 
      STA T1IBL     LENGTH = 0. 
      JSB ICH.F     MUST START WITH '('.
      LDA B50       '(' 
      JSB TCT.F 
IBL02 CLA,INA       INPUT (NON-FORMAT) STMT #.
      JSB ISD.F 
      LDA F.A       SEND OUT AS AN OPERAND. 
      IOR B100K 
      JSB WS1.F 
      ISZ T1IBL     INCREMENT NUMBER OF STMNT NOS.
      LDA F.TC
      CPA B54       ',' ? 
      JMP IBL02     YES. GET ANOTHER STMT NO. 
      JSB RP.F      )-INPUT OPERATOR
      JMP IBL.F,I   DONE. 
      SKP 
*         ****************
*         * DO PROCESSOR *
*         ****************
      SPC 1 
*                   INPUT STMT #. 
* 
F.DOP LDA K50 
      LDB F.LFF     IN LOGICAL IF ? 
      SZB 
      JSB WAR.F     DO IN LOG IF STATEMENT
      CLA,INA       INPUT STMT # (NON-FORMAT) 
      JSB ISN.F 
      LDA F.TC      IF COMMA, 
      CPA B54 
      RSS           LEAVE IT THERE, 
      JSB UC.F      ELSE BACK UP TO LAST DIGIT. 
      LDA F.A       T1DOP = F.A OF STMT #.
      STA T1DOP 
* 
*                   INPUT INDEX, PROCESS REST OF LINE.
* 
      JSB IIV.F     INPUT INTEGER VARIABLE
      LDA B75       MUST BE FOLLOWED BY '='.
      JSB TCT.F     F.TC TEST.
      LDA F.A       T2DOP = ITS F.A 
      STA T2DOP 
      CLB           MUST END WITH 'C/R'.
      JSB DCM.F     COMMON 'DO' PROCESSING. 
      LDA KK44      END OF DO STATEMENT.
      JSB WS1.F 
      LDA T2DOP     ALSO INDEX F.A
      JSB WS1.F 
* 
*                   PUT STMT #, CONTROL VAR, & TWPE ON STACK. 
* 
      LDA KM3       ALLOCATE 3 WORDS. 
      JSB DPO.F 
      LDA T1DOP     (D) = STMT #. 
      LDB T2DOP     (D+1) = CONTROL VARIABLE. 
      DST F.D,I 
      LDA TWPE      FORM TWPE ENTRY.
      JSB ESC.F 
      JSB AI.F
      LDA F.A 
      LDB F.D       (D+2) = F.A OF TWPE ENTRY.
      ADB K2
      STA B,I 
      JMP ILTRM     EXIT. 
* 
T1DOP NOP           F.A OF STMT # IN DO STMT. 
T2DOP NOP           F.A OF INDEX IN DO STMT.
B75   OCT 75        = 
KK44  BYT 1,54      OPCODE FOR 'DO', STEP=1.
      SKP 
*         ************************
*         * COMMON DO PROCESSING *
*         ************************
      SPC 1 
*                   INPUT: (A) = F.A OF LOOP INDEX. 
*                          (B) = END REQUIREMENT: 0=C/R, -1=).
* 
*                   VERIFY THAT THE INDEX IS UNIQUE.
* 
DCM.F NOP 
      STB T1DCM     (SAVE END FLAG) 
      LDB F.D       VERIFY UNIQUE: SEARCH DO TABLE. 
DCM01 CPB F.DO      END ? 
      JMP DCM03     ALL CHECKED: OK.
      INB 
      CPA B,I       THIS ONE ?
      JMP ERR51     YES, ERROR. 
      ADB K2
      JMP DCM01     NEXT !
ERR51 LDA K51       ERROR 51
      JSB ER.F      NESTED DO WITH SAME CONTR VAR 
* 
*                   EVALUATE INITIAL,FINAL,STEP.
* 
DCM03 JSB EE.F      EVALUATE INITIAL INDEX
      BYT 0,2 
      LDA B54       , 
      JSB TCT.F 
      JSB EE.F      EVALUATE FINAL VALUE. 
      BYT 0,4 
      LDB F.TC
      CPB B54       F.TC = ',' ?
      RSS 
      JMP DCM04     NO. NO STEP SIZE. 
      JSB EE.F      YES. EVALUATE STEP SIZE 
      BYT 0,4 
* 
*                   CHECK NEXT CHARACTER. 
* 
DCM04 LDB B15       NORMAL DO: WANT 'C/R'.
      LDA K9        (ELSE ERROR 9)
      ISZ T1DCM     WHICH ? 
      JMP DCM05     NORMAL. 
      LDB B51       IMPLIED DO: WANT ')'. 
      LDA K28       (ELSE ERROR 28) 
DCM05 CPB F.TC      IS IT RIGHT ? 
      JMP DCM.F,I   YES, EXIT.
      JSB ER.F      NO, ERROR.
      SPC 1 
T1DCM NOP 
K28   DEC 28
K51   DEC 51
      SKP 
*         ******************************
*         * INPUT STMT #'S IN DO LOOPS *
*         ******************************
      SPC 1 
*     INPUTS A STATEMENT NUMBER, USING ISN.F, AND CHECKS
*     WHETHER THE STMT # ENDS A DO LOOP; IN THAT CASE, THE TWPE FOR 
*     THE END OF THE INNERMOST LOOP (WITH THAT LABEL) WHICH CONTAINS
*     THE CURRENT STATEMENT IS RETURNED IN F.A INSTEAD OF THE ACTUAL
*     STMT # F.A .
* 
*     ENTRY: (A) = -1/0/+1 AS IN ISN.F
* 
ISD.F NOP 
      JSB ISN.F     INPUT STATEMENT #.
      LDA F.A       (A) = STMT # F.A
      LDB F.D       TOP OF DO STACK.
ISD01 CPB F.DO      ALL CHECKED ? 
      JMP ISD.F,I   YES. NOT FOUND, EXIT WITH (F.A) INTACT. 
* 
      CPA B,I       NO. CHECK NEXT ENTRY. 
      JMP ISD02     GOT ONE.
* 
      ADB K3        NOT THIS ONE. GO ON TO NEXT.
      JMP ISD01 
* 
ISD02 ADB K2        GOT ONE. GET IT'S TWPE ENTRY. 
      LDB B,I 
      STB F.A       AND RTN IN F.A
      LDA B,I       SET THE F..E FLAG IN THE TWPE,
      IOR K8        TO INDICATE THAT IT WAS USED. 
      STA B,I 
      JMP ISD.F,I   EXIT. 
      SPC 2 
*         *************************** 
*         * DATA POOL OVERFLOW TEST * 
*         *************************** 
      SPC 1 
*     INPUT: (A) = DELTA-D. RETURN NEW D IN B 
      SPC 1 
DPO.F NOP 
      ADA F.D 
      STA F.D       F.D=(A) 
      LDB A 
      CMA,INA 
      ADA F.LO
      ADA F.L       (A)=LO+F.L-D
      SSA 
      JMP DPO.F,I   EXIT
* 
      JMP F.OFE     DATA POOL OVERFLOW  BAIL OUT!@*?##@@'** 
      SKP 
*         ****************
*         * READ & WRITE *
*         ****************
      SPC 1 
*                   STANDARD-UNIT VERSIONS. 
* 
F.RDP JSB EXN.F     NEXT IS '(' ? 
      CPA B50 
      JMP RDP01     YES. KEYWORD FORM.
* 
      CLA,RSS       READ: 0.
F.PNT CLA,INA       PRINT: 1. 
      STA T0IOK 
      LDA KK64      OPCODE 64,
      JSB WS1.F 
      LDA T0IOK     WITH STATEMENT TYPE.
      JSB WS1.F 
      CLA           SET F.IM=0 FOR RFM.F
      STA F.IM
      JSB RFM.F     READ THE FORMAT; SEND THRU PASS FILE. 
      LDA K66       OPCODE 66, TO FINISH IT.
      JSB WS1.F 
      LDA F.TC      CHECK DELIMETER:
      CPA B54       IF COMMA, 
      JSB IOL.F     GO PROCESS LIST.
      JMP IOK52     TERMINATE STATEMENT. (REQUIRE C/R)
      SPC 2 
*                   KEYWORD VERSIONS. 
* 
F.WRP CLA,INA,RSS   STATEMENT TYPE = 1. 
RDP01 CLA           READ; TYPE = 0. 
      JMP IOK01     GO PROCESS KEYWORDS.
      SKP 
*         ****************************************************
*         * OPEN, CLOSE, INQUIRE, BACKSPACE, ENDFILE, REWIND *
*         ****************************************************
      SPC 1 
F.OPP LDA K2        OPEN.  TYPE = 2. (4)
      JMP IOK01 
* 
F.CLP LDA K3        CLOSE. TYPE = 3. (10B)
      JMP IOK01 
* 
F.IQP LDA K4        INQUIRE. TYPE = 4. (20B)
      JMP IOK01 
* 
F.BSP CCA,RSS       BACKSPACE. CODE = -1. 
F.EFP CLA           ENDFILE.   CODE =  0. 
      RSS 
F.RWP CLA,INA       REWIND.    CODE = +1. 
      STA T1IOK     SAVE TYPE.
      LDA KK22      SEND SPECIAL OPCODE WITH CODE.
      JSB WS1.F 
      LDA T1IOK 
      JSB WS1.F 
      JSB EXN.F     IS IT A KEYWORD LIST ?
      LDB A         (B) = FIRST CHAR. 
      LDA K5        (A) = STATEMENT TYPE, IN CASE KEYWORDS. 
      CPB B50       STARTING WITH '('.
      JMP IOK01     YES. GO PROCESS THAT. 
* 
      JSB EE.F      NO. GET UNIT # NOW. 
      BYT 0,3 
      LDA KK64      DO SPECIAL SEQUENCE:
      JSB WS1.F     OPCODE 64,
      LDA K5        WITH STATEMENT TYPE.
      JSB WS1.F 
      LDA KK65      OPCODE 65,
      JSB WS1.F 
      LDA K.UNT     ONLY VALUE IS UNIT #. 
      JSB WS1.F 
      LDA K66       OPCODE 66 TO END IT.
      JSB WS1.F 
      JMP F.CRT     THAT'S ALL. 
* 
K3    DEC 3 
K5    DEC 5 
KK22  BYT 1,26
      SKP 
*                   INITIALIZE KEYWORD FETCH LOOP.
* 
IOK01 STA T0IOK     SAVE TYPE.
      ADA DBTBL     GET CORRESPONDING BIT.
      LDA A,I 
      STA T1IOK     AND SAVE THAT TOO.
      LDA KK64      SEND OPCODE TO START STATEMENT. 
      JSB WS1.F 
      LDA T0IOK     WITH STATEMENT TYPE.
      JSB WS1.F 
      JSB ICH.F     READ &
      LDA B50       REQUIRE '(' 
      JSB TCT.F 
IOK02 LDA NKWRD     CLEAR OUT THE 'USED' BITS.
      CMA,INA 
      STA T2IOK 
      LDA KWIT      FWA-1 OF TABLE. 
IOK03 INA           CLEAR ANOTHER.
      LDB A,I 
      RBL,CLE,ERB 
      STB A,I 
      ISZ T2IOK 
      JMP IOK03 
* 
      CLA           CLEAR OUT FLAGS.
      STA T2IOK     UNIT FMT POSITIONAL FLAG. 
      STA T4IOK     FMT=* FLAG. 
      STA T5IOK     SEC/TER FLAG. 
* 
*                   GET ANOTHER KEYWORD.
* 
IOK04 CLA           FLAG F.IM: IDN.F NOT CALLED.
      STA F.IM
      JSB EXN.F     BECAUSE: ONLY CALLED FOR NAMES (HERE).
      SEZ,RSS       (E=0: LETTER/DIGIT) 
      SZB,RSS       (B#0: NON-DIGIT)
      JMP IOK05     NOT LETTER; NOT KEYWORD.
* 
      JSB IDN.F     LETTER. GET KEYWORD OR NAME.
      JSB UC.F      REREAD THE DELIMETER. 
      JSB ICH.F 
      SEZ           IF LONG NAME, 
      CPA B75       OR ENDS WITH '=', 
      JMP IOK07     THEN NORMAL KEYWORD.
      SKP 
*                   VALUE, NOT KEYWORD. CHECK THAT THAT'S O.K.
* 
IOK05 LDB T2IOK     MAKE SURE THAT VALUE ALLOWED HERE:
      ISZ T2IOK     (UNIT->FMT, FMT->ILLEGAL) 
      CLA 
      CPB K1        FORMAT ?
      LDA K.FMT     YES.
      SZB,RSS       UNIT # ?
      LDA K.UNT     YES.
      STA T3IOK     SAVE (MISSING) KEYWORD ORDINAL. 
      SZA           EITHER OF THE ABOVE ? 
      JMP IOK11     YES.
      JMP IOK99     NO. ERROR 15. 
* 
*                   TRUE KEYWORD. SEARCH FOR IT.
* 
IOK07 LDA K2        BUT FIRST, DISALLOW ANY MORE POSITIONAL.
      STA T2IOK 
      JSB UC.F      AND BACK UP SO CAN REREAD THE '='.
      JSB KWP.F     START MATCH IN PROGRESS.
      DEF IOKWL 
      SZA,RSS       FOUND ? 
      JMP IOK99     NO. ERROR.
* 
IOK09 STA T3IOK     YES. SAVE ORDINAL.
      CLA           SET F.IM TO INDICATE THAT 
      STA F.IM      NO ATTEMPT MADE TO READ VALUE.
* 
*                   CHECK IF DUPLICATE OR ALLOWED;
*                   SPECIAL-CASE 'FMT', 'ERR', AND 'END'. 
* 
IOK11 LDB KWIT      GET TABLE ENTRY.
      ADB T3IOK 
      LDA B,I 
      SSA           DUPLICATE KEYWORD ? 
      JMP IOK99     YES.
* 
      IOR B100K     NO. SET 'USED' BIT. 
      STA B,I 
      AND T1IOK     ALLOWED ? 
      SZA,RSS 
      JMP IOK99     NO. 
      SKP 
*                   CHECK FOR ILLEGAL COMBINATION. THIS IS DONE ON THE
*                   FLY SO THAT THE CURSOR IS POSITIONED PROPERLY.
* 
      LDA T4IOK     NOT ALLOWED WITH 'REC':  'FMT=*', 
      IOR T5IOK     SEC/TER,
      IOR T.END     END,
      IOR T.ZBF     ZBUF, 
      IOR T.ZLN     ZLEN. 
      AND T.REC     ONE OF ABOVE WITH 'REC' ? 
      SSA 
      JMP IOK98     YES. ILLEGAL. 
* 
      LDA T.ZBF     ZBUF .OR. ZLEN, 
      IOR T.ZLN 
      AND T5IOK     AND SEC/TER ? 
      SSA 
      JMP IOK98     YES. ILLEGAL. 
* 
      LDA T.FIL     FILE .AND. UNIT,
      AND T.UNT 
      LDB T0IOK     ON INQUIRE ?
      CPB K4        (INQUIRE=4) 
      SSA,RSS 
      RSS           (NO)
      JMP IOK98     YES. ILLEGAL. 
* 
*                   IS ALLOWED & LEGAL. SPECIAL-CASE FMT,ERR,END,UNIT.
* 
      LDA T3IOK     'FMT' ? 
      CPA K.FMT 
      JMP IOK30     YES.
* 
      CPA K.ERR     'ERR' 
      RSS           OR
      CPA K.END     'END' ? 
      JMP IOK40     YES.
* 
      LDB F.IM      'UNIT', 
      CPA K.UNT     AND NO VALUE YET ?
      SZB           (YES) 
      JMP IOK17     NO. 
* 
      JSB EXN.F     YES. IS IT 'UNIT=*' ? 
      CPA B52 
      RSS           (YES) 
      JMP IOK15     NO. (UNIT ALWAYS R-VALUED)
* 
      JSB ICH.F     YES. READ THE '*',
      STA T4IOK     DISALLOW 'REC' IN THE FUTURE. 
      LDA T.REC     ALSO IN THE PAST. 
      SSA 
      JMP IOK98 
* 
      LDA T0IOK     CHECK THAT READ OR WRITE. 
      SZA 
      CPA K1
      RSS           (YES) 
      JMP IOK98     NO. ILLEGAL IN ANY OTHER. 
* 
      JSB ICH.F     AND THE DELIMITER.
      LDA KK65B     WRITE TO THE PASS FILE: 
      JSB WS1.F     OP FOR ALTERNATE FORM,
      LDA K.UNT     KEYWORD NUMBER, 
      IOR B100K     WITH WHOLE ITEM BIT,
      JSB WS1.F 
      CLA           THEN VALUE = 0. 
      JSB WS1.F 
      JMP IOK28     CHECK DELIMITER.
* 
*                   DETERMINE WHETHER R-VALUED OR L-VALUED. 
* 
IOK17 CPA K.FIL     IF FILE,
      JMP IOK15     THEN ALWAYS R-VALUED. 
* 
      CPA K.IOS     IF IOSTAT,
      JMP IOK13     THEN ALWAYS L-VALUED. 
* 
      LDA T0IOK     ELSE SEE IF INQUIRE:
      CPA K4        IF SO, THEN L-VALUED; 
IOK13 CCB,RSS       L-VALUED: LIKE INPUT, NO EXPRESSIONS. 
IOK15 CLB           R-VALUED: LIKE OUTPUT, EXPRESSIONS O.K. 
      ADB KK09      SET UP EXPRESSION TYPE. 
      STB IOK24 
      SKP 
*                   PARSE THE EXPRESSION. 
* 
      LDA KWIT      FIRST, SEE IF CHARACTER DATA. 
      ADA T3IOK 
      LDA A,I 
      ALF,ALF 
      SLA           WELL ? (BIT 8)
      JMP IOK35     YES. GO DO THAT.
* 
      LDA F.IM      NO. CALLED IDN.F YET ?
      SZA,RSS 
      JMP IOK22     NO. GO CALL II.F
* 
      JSB AI.F      YES. ENTER NAME IN A.T.,
      JSB CRP.F     AND CROSS-REF IT. 
      RSS           (SKIP II.F) 
IOK22 JSB II.F      GET FIRST ITEM IN EXPRESSION. 
      LDA IOK24     INPUT-TYPE OR OUTPUT-TYPE.
      CPA KK09
      JMP IOK26     OUTPUT-TYPE.
* 
      JSB NCT.F     INPUT-TYPE. NO CONSTANTS/DELIMETERS,
      JSB NST.F     OR FUNCTIONS, 
      JSB NET.F     AND MUST NOT BE EMA.
      LDB F.TC      AND REQUIRE NEXT CHAR TO BE:
      CPB B50       '(' 
      RSS 
      CPB B51       ')' 
      RSS 
      CPB B54       OR COMMA. 
      RSS 
      JMP IOL53     ELSE ERROR 17.
* 
IOK26 LDA F.IU      ARRAY ? 
      CPA ARR 
      RSS           (YES) 
      JMP IOK23     NO. GO DO IT, FINALLY.
* 
      LDA F.TC      YES. ALL BY ITSELF ?
      CPA B54       I.E., FOLLOWED BY COMMA,
      RSS 
      CPA B51       OR RIGHT PAREN ?
      JMP IOK42     YES. SEND WITH "WHOLE ITEM" BIT.
* 
IOK23 JSB EE.F      GET KEYWORD EXPRESSION. 
IOK24 ABS *-*       LOOKS LIKE I/O LIST ITEM. 
IOK25 LDA KK65      SEND GENERAL KEYWORD OPCODE.
      JSB WS1.F 
      LDA T3IOK     AND KEYWORD ORDINAL.
      JSB WS1.F 
      SKP 
*                   IF R/W UNIT, PROCESS OPTIONAL 'REC OR :SEC:TER .
* 
      LDA T0IOK     READ OR WRITE ? 
      SZA 
      CPA K1
      RSS           (YES) 
      JMP IOK28     NO. DON'T CHECK FURTHER.
* 
      LDA T3IOK     UNIT ?
      RAL,CLE,ERA 
      CPA K.UNT 
      RSS           (YES) 
      JMP IOK28     NO. NO OTHERS HAVE SPECIAL SYNTAX.
* 
      LDB F.TC      YES. RECORD NUMBER ?
      LDA K.REC     (JUST IN CASE)
      CPB B47       I.E. LU'REC ? 
      JMP IOK09     YES. TREAT QUOTE AS: ",REC=" .
* 
      CPB B72       NO. HOW 'BOUT COLON ? 
      RSS           (YES) 
      JMP IOK28     NO. 
* 
      LDA T.ZBF     YES. DON'T ALLOW:  ZBUF,
      IOR T.ZLN     ZLEN, 
      IOR T.REC     REC.
      CMA,SSA,RSS   WELL ?
      JMP IOK98     YES. ILLEGAL WITH SECONDARIES.
* 
      STA T5IOK     NO. SET T5IOK<15> AS FLAG.
      JSB EE.F      GET 'SEC' VALUE.
      BYT 1,3 
      LDA KK65      SEND KEYWORD OPCODE,
      JSB WS1.F 
      LDA K.SEC     WITH 'SEC' ORDINAL. 
      JSB WS1.F 
      LDA F.TC      IS 'TER' PRESENT ?
      CPA B72 
      JMP IOK32     YES. GET IT.
* 
      CLA           NO. CREATE ZERO,
      JSB EIC.F 
      IOR B100K     AND SEND THRU TO APPEAR ON STACK. 
      JSB WS1.F 
      JMP IOK33 
* 
IOK32 JSB EE.F      GET 'TER' VALUE.
      BYT 1,3 
IOK33 LDA KK65      AND SEND THAT VALUE, TOO. 
      JSB WS1.F 
      LDA K.TER 
      JSB WS1.F 
      SKP 
*                   CHECK SYNTAX AFTER VALUE. 
*                   IF END, CHECK KEYWORD COMBINATIONS AGAIN. 
* 
IOK28 LDA F.TC      HOW DOES IT END ? 
      CPA B54       ',' ? 
      JMP IOK04     YES. GET NEXT ONE.
* 
      LDA B51       REQUIRE ')'.
      JSB TCT.F 
      LDA T.ZBF     IF EITHER OF ZBUF/ZLEN, 
      XOR T.ZLN     THEN MUST BE BOTH.
      SSA 
      JMP IOK98     NO. ERROR.
* 
      LDA T.UNT     UNIT PRESENT ?
      SSA 
      JMP IOK49     YES. THEN ALL'S O.K.
* 
      LDA T1IOK     NO. ENCODE OR DECODE ?
      AND B300
      SZA 
      JMP IOK49     YES. THAT'S RIGHT.
* 
      LDA T0IOK     INQUIRE & 'FILE' PRESENT ?
      LDB T.FIL 
      CPA K4        INQUIRE=4,
      SSB,RSS       INQUIRE. 'FILE' ? 
      JMP IOK98     NOT INQUIRE OR NO FILE. ERROR.
      JMP IOK49     YES. INQUIRE BY FILE, O.K.
* 
KK09  BYT 1,11      EE.F PARAM: OUTPUT ITEM, NO TEMP INIT.
KM1   DEC -1
* 
*                   GET FORMAT SPECIFIER. 
* 
IOK30 JSB RFM.F     COMMON WITH STD UNIT & DECODE/ENCODE. 
      JMP IOK28 
      SKP 
*                   READ CHARACTER DATA ITEM. 
* 
IOK35 LDA IOK24     L-VALUE OR R-VALUE ?
      CPA KK09
      RSS           R-VALUE.
      JMP IOK36     L-VALUE. CAN'T BE CONSTANT. 
* 
      JSB EXN.F     R-VALUE. CONSTANT STRING ?
      CPA B47 
      RSS           YES.
      JMP IOK36     NO. THEN SAME AS L-VALUE. 
* 
      JSB ICH.F     YES. READ THE QUOTE.
      JSB ISC.F     INPUT THE CONSTANT STRING.
      JMP IOK42     AND GO SEND IT. 
* 
IOK36 JSB IVN.F     GET ITEM. (DIDN'T CALL IDN.F YET) 
      JSB FSD.F     FAKE A STRING DESCRIPTOR. 
      JMP IOK42     GO SEND THE TEMP AS THE VALUE.
* 
*                   READ STATEMENT NUMBER FOR END= AND ERR=.
* 
IOK40 LDA F.IM      MUST NOT BE NAMED.
      SZA 
      JMP IOK99     NAMED.
* 
      CLA,INA       GET NON-FORMAT STMT #.
      JSB ISN.F 
IOK42 LDA F.A       PASS THRU FOR STACK.
      IOR B100K 
      JSB WS1.F 
      LDA T3IOK     SET THE "WHOLE ITEM" BIT. 
      IOR B100K 
      STA T3IOK 
      JMP IOK25     SKIP THE EXPRESSION STUFF.
      SKP 
*                   COMMON FORMAT READER. 
*                   SENDS FORMAT THRU PASS FILE WITH OPCODE 65. 
*                   FORMAT '*' HAS VALUE 0.  'WHOLE ITEM' BIT SET.
* 
RFM.F NOP 
      LDA F.IM      ALREADY HAVE NAME ? 
      SZA 
      JMP RFM06     YES. GO ANALYZE.
* 
      JSB EXN.F     NO. CHECK FIRST CHAR. 
      SZB           DIGIT ? 
      JMP RFM02     NO. NOT STMT #. 
* 
      CCA           YES. GET (FORMAT) STATEMENT #.
      JSB ISN.F 
      JMP RFM08     GO WRITE TO PASS FILE.
* 
RFM02 CPA B52       '*' ? 
      RSS           (YES) 
      JMP RFM03     NO. 
* 
      LDA T.REC     YES. LIST-DIRECTED; 
      CMA,SSA,RSS   ILLEGAL WITH 'REC'. 
      JMP IOK98     'REC', ERROR. 
* 
      STA T4IOK     NO. SET T4IOK<15> AS FMT=* FLAG.
      JSB ICH.F     READ THE '*', 
      JSB ICH.F      & DELIMETER. 
      CLA           AND SET F.A = 0.
      STA F.A 
      JMP RFM08     GO WRITE TO PASS FILE.
* 
RFM03 CPA B47       CONSTANT STRING ? (SINGLE QUOTE)
      RSS           (YES) 
      JMP RFM04     NO. 
* 
      JSB ICH.F     YES. READ THE QUOTE,
      JSB ISC.F     AND GET THE STRING. 
      JMP RFM08     AND GO WRITE. 
* 
RFM04 LDA K17       (ERROR #) 
      SEZ           LETTER ?  (NOT DIGIT HERE)
      JSB ER.F      NO. ERROR 17. 
* 
      JSB IDN.F     YES. GET NAME.
RFM06 JSB AI.F      VARIABLE/ARRAY NAME.
      JSB CRP.F 
      LDA F.IU      IF NOT ARRAY, 
      CPA ARR 
      RSS 
      JSB TV.F      THEN MUST BE VARIABLE,
* 
RFM08 LDA KK65B     WRITE TO PASS FILE, USING 
      JSB WS1.F     ALTERNATE FORM OF OPCODE 65:
      LDA K.FMT     FIRST IS AS ALWAYS, 
      IOR B100K     WHOLE ITEM BIT. 
      JSB WS1.F 
      LDA F.A       SECOND IS F.A 
      JSB WS1.F 
      JMP RFM.F,I   DONE. 
      SPC 2 
*                   SET UP A FAKE STRING DESCRIPTOR.
* 
FSD.F NOP 
      LDB F.IM      IF STATEMENT NUMBER,
      LDA MAX       (SIZE IS MAX IF SO) 
      SZB,RSS 
      JMP FSD01     THEN SKIP CHECKS. 
* 
      JSB ITS.F     ELSE MUST BE INTEGER. 
      JSB NET.F     MUST NOT BE EMA.
      LDA F.IU      IF ARRAY, 
      LDB F.VDM     AND VARIABLE DIMENSIONS,
      CPA ARR 
      SZB,RSS       THEN COMPUTE SIZE LATER,
      JSB NWI.F     ELSE COMPUTE SIZE NOW.
      LDA F.D0+1    (A) = SIZE. 
FSD01 STA T7IOK     SAVE ITS SIZE.
      LDA F.A       AND ITS F.A . 
      STA T6IOK 
      LDA CHAR      AND SET UP CHAR TEMP. 
      CLB           (F.CSL=0, DESCRIPTOR ONLY)
      STB F.CSL 
      JSB APT.F 
      DLD F.A,I     (B)=EXTENSION ADDR. 
      LDA T6IOK     1ST WD WOULD NORMALLY BE
      IOR B100K     THE DESCRIPTOR ADDR, BUT
      STA B,I       HERE IT'S F.A,I OF ITEM.
      INB 
      LDA T7IOK     2ND WD = BYTE LENGTH. 
      CLE,ELA 
      STA B,I 
      JMP FSD.F,I   EXIT. F.A = THE DESCRIPTOR. 
* 
MAX   DEC 32767 
      SKP 
*                   END OF I/O STATEMENT. 
* 
IOK49 JSB ICH.F     READ CHAR AFTER ')'.
IOK50 LDA K66       SEND END OPERATOR.
      JSB WS1.F 
      LDA T0IOK     IS IT READ OR WRITE ? 
      SZA 
      CPA K1
      RSS           IF SO, PROCESS LIST.
      JMP F.CRT     ELSE TEST FOR C/R.
* 
*                   FOR READ/WRITE/DECODE/ENCODE, GET LIST. 
* 
      JSB UC.F      UNINPUT COLUMN
      JSB IOL.F     I/O LIST PROCESSOR. 
IOK52 LDA K47       TERMINATE I/O STATEMENT.
      JSB WS1.F 
      JMP F.CRT     WRAP IT UP. (C/R TEST)
* 
IOK98 LDA K18       ERR 18, ILLEGAL COMBINATION OF KEYWORDS.
      JSB ER.F
IOK99 LDA K15       ERR 15, UNRECOGNIZED OR ILLEGAL KEYWORD.
      JSB ER.F
      SKP 
T0IOK NOP           STATEMENT TYPE; 0-5.
T1IOK NOP           2**(T0IOK)
T2IOK NOP           UNIT, FMT AS POSITIONAL FLAG. 
T3IOK NOP           ORDINAL OR CURRENT KEYWORD. 
T4IOK NOP           FMT=* FLAG. 
T5IOK NOP           SEC/TER FLAG. 
T6IOK NOP           GENERAL TEMP. 
T7IOK NOP           GENERAL TEMP. 
KK64  BYT 1,100     OPCODE 64, ONE ARG. 
KK65  BYT 1,101     OPCODE 65, ONE ARG. 
KK65B BYT 2,101     OPCODE 65, TWO VALUES.
K66   DEC 66
K15   DEC 15
K18   DEC 18
K47   DEC 47
B47   OCT 47        SINGLE QUOTE. 
B72   OCT 72        COLON.
B300  OCT 300 
CHAR  OCT 130000    F.IM=CHAR.
      SPC 2 
*     BIT TABLE. EACH WORD CONTAINS 2**(WORD ORDINAL). MAX = 5. 
* 
DBTBL DEF *+1       INDEXED THRU HERE.
K1    OCT 1         0 
K2    OCT 2         1 
K4    OCT 4         2 
K8    OCT 10        3 
      OCT 20        4 
      OCT 40        5 
B100  OCT 100       (6,7: DECODE, ENCODE USE 0,1 & 100,200) 
      SPC 2 
*                   SOME KEYWORD ORDINALS.
* 
K.END EQU K1
K.ERR EQU K2
K.FMT DEC 3 
K.REC EQU K4
K.FIL DEC 6 
K.RCL DEC 10
K.UNT DEC 11
K.IOS DEC 19
K.SEC DEC 31
K.TER DEC 32  
K.SDS DEC 33
      SKP 
*                   I/O STATEMENT KEYWORD LIST. 
* 
IOKWL ASC 21,END= ERR= FMT= REC= USE= FILE= FORM= NAME=,
      ASC 21, NODE= RECL= UNIT= ZBUF= ZLEN= BLANK= EXIS,
      ASC 21,T= NAMED= ACCESS= DIRECT= IOSTAT= NUMBER= ,
      ASC 21,OPENED= STATUS= BUFSIZ= MAXREC= NEXTREC= F,                      
      ASC 18,ORMATTED= SEQUENTIAL= UNFORMATTED=  ,      
* 
*     KEYWORD INFO TABLE. ONE-WORD ENTRIES;  BITS 7:0 ARE THE LOGICAL 
*     SUM OF THE BITS FOR EACH STATEMENT TYPE THIS KEYWORD ALLOWED FOR: 
*       READ=1      WRITE=2      OPEN=4      CLOSE=10      INQUIRE=20 
*       BACKSPACE/ENDFILE/REWIND=40  DECODE=100  ENCODE=200 
*     BIT 8:  CHARACTER ITEM. (ELSE INTEGER)
*     BIT 15: SET IFF ALREADY SEEN. 
* 
KWIT  DEF * 
T.END BYT 0,001   01 END         READ 
      BYT 0,377   02 ERR         ALL
      BYT 1,003   03 FMT         READ/WRITE 
T.REC BYT 0,003   04 REC         READ/WRITE 
      BYT 1,024   05 USE         OPEN/INQUIRE 
T.FIL BYT 1,024   06 FILE        OPEN/INQUIRE 
      BYT 1,024   07 FORM        OPEN/INQUIRE 
      BYT 1,020   08 NAME        INQUIRE
      BYT 0,024   09 NODE        OPEN/INQUIRE 
      BYT 0,024   10 RECL        OPEN/INQUIRE 
T.UNT BYT 0,077   11 UNIT        ALL (SPECIAL DECODE/ENCODE)
T.ZBF BYT 0,003   12 ZBUF        READ/WRITE 
T.ZLN BYT 0,003   13 ZLEN        READ/WRITE 
      BYT 1,024   14 BLANK       OPEN/INQUIRE 
      BYT 0,020   15 EXIST       INQUIRE
      BYT 0,020   16 NAMED       INQUIRE
      BYT 1,024   17 ACCESS      OPEN/INQUIRE 
      BYT 1,020   18 DIRECT      INQUIRE
      BYT 0,377   19 IOSTAT      ALL
      BYT 0,020   20 NUMBER      INQUIRE
      BYT 0,020   21 OPENED      INQUIRE
      BYT 1,014   22 STATUS      OPEN/CLOSE 
      BYT 0,004   23 BUFSIZ      OPEN 
      BYT 0,024   24 MAXREC      OPEN/INQUIRE 
      BYT 0,020   25 NEXTREC     INQUIRE
      BYT 1,020   26 FORMATTED   INQUIRE
      BYT 1,020   27 SEQUENTIAL  INQUIRE
      BYT 1,020   28 UNFORMATTED INQUIRE
NKWRD ABS *-KWIT-1  # OF KEYWORDS.
      SKP 
*         *************************** 
*         * ENCODE-DECODE PROCESSOR * 
*         *************************** 
      SPC 1 
*                   SET UP TYPE, KEYWORD MASK; REQUIRE '(', INITIALIZE. 
* 
F.DCP CLB,RSS       DECODE. TYPE=0. 
F.ECP CLB,INB       ENCODE. TYPE=1. 
      STB T0IOK 
      LDA K2        ALSO, SET UP IOK FOR NO POSITIONAL. 
      STA T2IOK 
      LDA B100      KEYWORD CHECK MASK: 
      SZB           DECODE=100B,
      RAL           ENCODE=200B.
      STA T1IOK 
      JSB ICH.F     READ THE '('
      LDA B50       REQUIRE IT. 
      JSB TCT.F 
      LDA KK64      OPCODE 64,
      JSB WS1.F 
      LDA T0IOK     WITH STATEMENT TYPE.
      JSB WS1.F 
* 
*                   GET THE POSITIONAL PARAMETERS: RECL, FMT, SDES. 
* 
      JSB EE.F      GET THE CHARACTER COUNT:
      BYT 1,3       (IT LOOKS LIKE A UNIT NUMBER) 
      LDA KK65      OPCODE 65,
      JSB WS1.F 
      LDA K.RCL     WITH 'RECL' KEYWORD #.
      JSB WS1.F 
      LDA B54       REQUIRE COMMA.
      JSB TCT.F 
      CLA           SET F.IM=0 FOR RFM.F
      STA F.IM
      JSB RFM.F     GET THE FORMAT; SEND THRU PASS FILE.
      LDA B54       REQUIRE COMMA.
      JSB TCT.F 
      JSB IVN.F     INPUT BUFFER NAME.
      JSB NET.F     DON'T ALLOW EMA.
      JSB FSD.F     FAKE A STRING DESCRIPTOR. 
      LDA F.A       FORCE BUFFER F.A THRU ON STACK. 
      IOR B100K 
      JSB WS1.F 
      LDA KK65      OPCODE 65,
      JSB WS1.F 
      LDA K.SDS     WITH 'SDES' KEYWORD ORDINAL.
      JSB WS1.F 
* 
*                   JOIN KEYWORD PROCESSOR TO FINISH IT.
* 
      LDA F.TC      KEYWORDS TO FOLLOW ?
      CPA B54 
      JMP IOK02     YES. GO PROCESS THEM. 
* 
      JSB RP.F      NO. REQUIRE & SKIP ')'. 
      JMP IOK50     WRAP IT UP & GET LIST.
      SKP 
*         ********************************
*         * I/O STATEMENT LIST PROCESSOR *
*         ********************************
      SPC 1 
*                   INITIALIZE. 
* 
IOL.F NOP           READ() OR WRITE() <LIST>
      JSB EXN.F     FIRST, SEE IF LIST EMPTY. 
      CPA B15       WELL ?
      JMP IOL.F,I   YES. NOTHING TO DO. 
* 
      CLA           NO. CLEAR SOME STATE. 
      STA F.L       NUMBER SYNTAX ENTRIES STACKED 
      LDA F.S2B     MAKE SURE STACK CUT BACK. 
      STA F.S2T 
* 
*                   NEW LIST ITEM. COUNT NUMBER OF LEADING LEFT PARENS. 
* 
IOL01 CLA 
      STA T1IOL     T1IOL = # OF '(' BEFORE START OF ITEM.
      STA T2IOL     T2IOL = # OF ')' WITHIN ITEM. 
IOL03 JSB ICH.F     PAREN ? 
      CPA B50 
      RSS           (YES) 
      JMP IOL05     NO. GO GET ITEM.
* 
      JSB NR.F      START NEW GROUP,
      ISZ T1IOL     AND COUNT THE PAREN.
      JMP IOL03     TRY FOR MORE. 
* 
*                   IF INPUT, JUST GET THE ITEM.
* 
IOL05 JSB UC.F      (UNREAD THE CHAR AFTER THE PAREN) 
      LDA T0IOK     INPUT OR OUTPUT ? 
      SZA 
      JMP IOL11     OUTPUT. TRY FOR CONST OR EXPR.
* 
      JSB II.F      INPUT. GET NAME.
      SZA,RSS       DID WE GET NAME ? (OR CONST)
      JMP IOL53     NO. ERROR.
* 
      JSB NCT.F     YES. DON'T ALLOW CONSTANTS, 
      JSB NST.F     OR FUNCTION CALLS.
      LDA F.TC      CHECK FOR IMPLIED DO CONTROL: 
      CPA B75       IS F.TC AN '=' ?
      JMP IOL24     YES.
* 
      CPA B50       '(' 
      RSS 
      CPA B51       OR ')'
      RSS 
      CPA B54       OR ','
      RSS 
      CPA B15       OR 'C/R'
      RSS 
      JMP IOL53     NOPE. ILLEGAL IN INPUT LIST.
      SKP 
*                   IF ARRAY NAME BY ITSELF, DO WHOLE ARRAY.
* 
IOL07 LDB F.IU      ARRAY ? 
      CPB ARR 
      RSS           (YES) 
      JMP IOL55     NO. THEN NOT WHOLE ARRAY. 
* 
      LDA F.TC      YES. SIMPLE LIST ITEM, I.E. 
      CPA B54       FOLLOWED BY COMMA,
      RSS 
      CPA B51       RIGHT PAREN,
      RSS 
      CPA B15       OR C/R ?
      RSS           (YES) 
      JMP IOL55     NO. THEN NOT WHOLE ARRAY. 
* 
      LDA F.A       YES. WHOLE ARRAY. 
      IOR B100K     SEND ITEM THRU FOR STACK. 
      JSB WS1.F 
      LDA K62       THEN THE WHOLE ARRAY OPERATOR.
      JSB WS1.F 
      JMP IOL91     AND DONE. 
* 
*                   GET POSSIBLE SUBSCRIPTS ON INPUT ITEM.
* 
IOL55 JSB EE.F      GET INPUT LIST ELEMENT. 
      BYT 1,10      TEMPS ?  TYPE = 8.
      LDA K63       AND TELL PASS 2 TO PROCESS IT.
      JSB WS1.F 
* 
*                   DELIMETER AFTER LIST ITEM OR SUBLIST. 
* 
IOL91 LDB F.TC      WHAT IS IT ?
      CPB B51       ')' ? 
      JMP IOL22     YES, NEW RECORD AND MATCH PARENS. 
* 
      CPB B54       ',' ? 
      JMP IOL01     YES,SCAN NEXT ITEM OR SUBLIST.
* 
      CPB B15       C/R ? 
      JMP IOL27     YES, FIX UP LOAD ADDRESS POINTERS.
* 
IOL53 LDA K17       ELSE  CONSTRUCTION ERROR: 
      JSB ER.F      ILLEGAL DELIMITER.
      SPC 2 
TWPE  OCT 40000     F.IM=4 DUMMY TWO WORD ENTRY 
CPX   OCT 50000     F.IM=5 COMPLEX. 
ZPX   OCT 140000    F.IM=12 DOUBLE COMPLEX. 
RE8   OCT 120000    F.IM=10 DOUBLE PRECISION. 
ARR   OCT 600       F.IU=ARR
K22   DEC 22
B52   OCT 52        * 
K17   DEC 17
K62   DEC 62
K63   DEC 63
      SKP 
*                   ANALYZE OUTPUT LIST ITEM. 
* 
IOL11 JSB II.F      TRY FOR AN OPERAND. 
      SZA,RSS       DID WE GET ONE ?
      JMP IOL15     NO. TRY FOR EXPRESSION. 
* 
      LDB F.TC      YES. SEE WHAT'S AFTER IT. 
      CPB B75       IF '=', 
      JMP IOL24     THEN DO LOOP CONTROL. 
* 
      CPB B15       IF C/R, 
      JMP IOL07     SIMPLE ITEM. (CHECK FOR ARRAY)
* 
      CPB B54       IF COMMA, 
      RSS           (YES) 
      JMP IOL15     NO. GO TRY FOR EXPRESSION.
* 
*                   COMMA AFTER ITEM. PROBABLY SIMPLE ITEM, BUT 
*                   COULD BE START OF COMPLEX CONSTANT. CHECK IT. 
* 
      LDB F.NT      YES. CHECK FOR COMPLEX CONST: 
      CPA REA       MUST BE TYPE REAL,
      RSS 
      CPA RE8       OR REAL*8,
      SZB,RSS       AND CONSTANT. 
      JMP IOL07     NO. SIMPLE LIST ITEM. (CHECK ARRAY) 
* 
      STA T4IOL     YES. SAVE TYPE FOR CHECK LATER. 
      JSB EXN.F     SEE IF FOLLOWED BY '('. 
      LDB B54       (RESTORE COMMA) 
      STB F.TC
      LDB T1IOL     AND ALSO MUST HAVE A LEFT PAREN.
      SZB           IF NO LEFT PAREN AT START,
      CPA B50       OR LEFT PAREN AFTER COMMA,
      JMP IOL07     THEN STILL SIMPLE LIST ITEM.
* 
      LDA F.A       NO. SAVE F.A OF FIRST CONSTANT. 
      STA T3IOL 
      JSB II.F      GET NEXT THING IN LIST. 
      LDB F.NT      IF CONSTANT,
      CPA T4IOL     AND SAME TYPE AS FIRST CONSTANT,
      SZB,RSS 
      JMP IOL13     NO. NOT COMPLEX CONSTANT. 
* 
      LDB F.TC      YES. ENDS WITH ')' ?
      CPB B51 
      JMP IOL14     YES.
      SKP 
*                   NOT COMPLEX CONSTANT.  OUTPUT THE REAL CONSTANT 
*                   WHICH WAS SAVED, THEN PROCESS THE ITEM AFTER COMMA. 
* 
IOL13 LDA T3IOL     NOT CPX CONST: MUST OUTPUT 1ST CONSTANT.
      IOR B100K 
      JSB WS1.F 
      LDA K63 
      JSB WS1.F 
      CLA           THEN ZAP PAREN COUNT. 
      STA T1IOL 
      JMP IOL15     AND PROCESS SECOND ITEM/EXPRESSION. 
* 
*                   COMPLEX CONSTANT. FORM IT, AND ASSUME START OF EXPR.
* 
IOL14 LDA F.DID     FORM CONSTANT:
      LDB F.DID     FIRST, MOVE SECOND PART UP. 
      ADB F.D0+1    BY 2 OR 4 WORDS.
      JSB .MVW
      DEF F.D0+1
      NOP 
      LDA T3IOL     NOW COMPUTE ADDRESS OF FIRST PART,
      ADA K2
      LDB F.DID     AND MOVE IT TO THE START. 
      JSB .MVW
      DEF F.D0+1
      NOP 
      LDB F.IM      SET UP PROPER TYPE: 
      LDA CPX       IF REAL*4, IS COMPLEX*8.
      CPB RE8 
      LDA ZPX       IF REAL*8, IS COMPLEX*16. 
      JSB ESC.F 
      JSB AI.F
      JSB ICH.F     GET DELIMITER AFTER IT. 
      ISZ T2IOL     COUNT ONE PAREN USED. 
* 
*                   START OF EXPRESSION. CALL EE.F .
* 
IOL15 LDA T2IOL     PASS THE COUNT OF LEADING LEFT PARENS.
      CMA,INA 
      ADA T1IOL 
      JSB EE.F      TO EXPRESSION ANALYZER. 
      BYT 201,11    OUTPUT, TEMPS?, USE F.SIM & PARENS. 
* 
*                   ACCOUNT FOR RIGHT PARENS IN EXPRESSION WHICH
*                   MATCHED LEFT PARENS ALREADY STACKED UP. 
* 
      CMA,INA       - (# LEFT PARENS STILL UNUSED)
      ADA T1IOL     + TOTAL = # USED. 
      CMA,INA,SZA,RSS  ANY ?
      JMP IOL19     NO. GO OUTPUT LIST OPCODE.
* 
      STA T2IOL     YES. ACCOUNT FOR THEM.
IOL17 JSB MPL.F     ONCE FOR EACH RIGHT PAREN USED. 
      ISZ T2IOL 
      JMP IOL17 
* 
IOL19 LDA K63       OUTPUT OPCODE FOR LIST ITEM.
      JSB WS1.F 
      JMP IOL91     DONE. 
      SKP 
*                   PROCESS ')': START NEW RECORD & MAKE SURE MATCHED.
* 
IOL22 JSB MPL.F     START NEW RECORD FOR ')' AND MATCH IT 
      JSB ICH.F     READ DELIMETER. 
      JMP IOL91     PROCESS DELIMETER AFTER SUBLIST.
* 
*                   PROCESS  IMPLIED  DO CONTROL INFO.
* 
IOL24 LDA T1IOL     IF CONTROL VARIABLE FOLLOWS 
      SZA           ONE OR MORE LEFT PARENS,
      JMP IOL53     THEN EMPTY LIST - ERROR.
* 
      JSB ITS.F     CONTR. VAR. MUST BE INTEGER 
      JSB NCT.F     CONTR. VAR. MUST NOT BE CONSTANT
      JSB TV.F      MUST BE VARIABLE
* 
*                   START NEW RECORD, PROCESS 'DO' STUFF. 
* 
      LDA F.A       (SAVE F.A OVER NR.F)
      STA CONTR 
      IOR B100K     (A) = F.A,I 
      JSB NR.F      START NEW RECORD FOR INITIAL. CODE
      LDA CONTR     (RESTORE) 
      STA F.A 
      CCB           REQUIRE THAT IT ENDS ON ')'.
      JSB DCM.F     COMMON DO PROCESSOR.
* 
*                   FIND MATCHING '(', ISSUE OPCODE TO PASS 2.
* 
      JSB MPL.F     START NEW RECORD, FIND MATCHING '(' 
      LDA A,I       GET THE F.A OF THE JUMP  TARGET 
      RAL,ERA       SET INDIRECT (THRU TWPE ENTRY). 
      STA T1DOP     SAVE IT.
      LDA KK48      ISSUE OP. 
      JSB WS1.F 
      LDA CONTR     WITH F.A OF INDEX (CONTROL).
      JSB WS1.F 
      LDA T1DOP     AND F.A OF JUMP TARGET. 
      JSB WS1.F 
      JSB ICH.F     READ THE DELIMITER. 
      JMP IOL91     PROCESS DELIMITER AFTER SUBLIST.
* 
*                   ROUTINE TO START ')' RECORD & FIND MATCHING ')'.
* 
MPL.F NOP           A ')' FOUND  START NEW RECORD AND 
      LDA B51       (A) = ')'.
      JSB NR.F      THEN
      CCA           FIND THE MATCHING '(' 
      LDB KM2       LOOK DOWN THE STACK 
      ADA F.S2T 
      JSB MP.F      MATCH IT
      JMP MPL.F,I   RETURN
      SKP 
*     END. SCAN SKELETON OF LIST TO DETERMINE ORDER THAT THE ENTRIES
*     SHOULD ACTUALLY APPEAR.  OUTPUT OPCODES TO PASS 2 TO DEFINE THE 
*     LOAD ADDRESSES (TWPE'S) SO THAT THE ORDER WILL BE CORRECT.
* 
*     THE SKELETON WILL LOOK LIKE:
* 
*        (A  (B  &C  )D  (E  &F  )G  &H  )I 
* 
*     WHERE THE INTERPRETATION IS:  (  LIST PROPER. 
*                                   &  'DO' INITIALIZE. 
*                                   )  'DO' LOOPING.
* 
*     AND THE DESIRED LOAD ORDER IS:  H,A,C,B,D,F,E,G,I.
* 
*     THIS IS ACCOMPLISHED BY OUTPUTTING THE LOAD REQUESTS IN ORDER 
*     EXCEPT THAT LOOP INITIALIZATION IS OUTPUT JUST BEFORE THE LOOP IT 
*     CONTROLS, BY FINDING THE MATCHING RIGHT PAREN AND BACKING UP ONE. 
* 
*                   START & INCREMENT SCAN OF STACK 2.
* 
IOL27 CCA 
      ADA F.S2B     INITIALIZE STACK POINTER
      STA T0IOL 
* 
IOL28 LDA T0IOL     POINT TO
      ADA K2        NEXT SYNTAX ELEMENT STACKED.
      STA T0IOL 
      LDB F.S2T 
      CMB,INB 
      ADB A         (B) _ STACK POINTER - STACK TOP 
      SSB,RSS       PAST TOP? 
      JMP IOL33     YES, DONE PROCESSING LIST 
* 
*                   ): OUTPUT.   &: IGNORE.   (: FIND MATCHING ')'. 
* 
      LDB A,I       B = TYPE INDICATION.
      CPB B50       '(' ? 
      JMP IOL29     YES, FIND MATCHING ')'. 
      CPB B51       NO.  ')' ?
      JMP IOL31     YES, OUTPUT.
      JMP IOL28     NO, MUST BE & (INDEX VAR), SKIP IT. 
      SKP 
*                   '('. FIND MATCHING ')', OUTPUT THE LOOP INDEX INIT. 
* 
IOL29 LDB K2        SEARCH UP THE STACK FOR MATCHING
      JSB MP.F      RIGHT PARENTHESIS.
      ADA KM3       POINTS TO SYNTAX ELEM. BEFORE ).
      STA T1IOL 
      LDB A,I       IS PREVIOUS SYNTAX ELEMENT AN 
      SSB,RSS       IMPLIED DO CONTROL VARIABLE?
      JMP IOL31     NO, JUST PARENS, DO '(' NOW.
      JSB ILA.F     YES. OUTPUT THE INIT NOW. 
* 
*                   LOOK FOR A DUPLICATE INDEX VAR. 
* 
      LDA T1IOL,I   (A) = F.A,I TO DO CONTROL VAR.
      LDB T1IOL     (B) = STK2 WORD WHICH CONTAINS(A) 
IOL30 ADB KM2       NEXT SYNTAX BELOW(B) IN STK2
      CPB T0IOL     IS NEXT SYNTAX THE ( OF DO BODY?
      JMP IOL31     YES, INSERT LOAD ADDRESS FOR BODY 
      CPA B,I       NO, IS IT IDENTICAL TO CONT. VAR? 
      JMP ERR51     YES, ERROR-REPEATED CONT. VAR.
      JMP IOL30     NO, LOOK AT NEXT SYNTAX IN STK2.
* 
*                   OUTPUT CURRENT ITEM, WHATEVER.
* 
IOL31 LDA T0IOL     ADDRESS-1 OF WORD IN STACK2 CONTAINING
      JSB ILA.F     PTR TO LOAD ADDR.  INSERT IT. 
      JMP IOL28     CONTINUE FIXING UP LOAD ADDRS.
* 
*                   CLEAR STACK & EXIT. 
* 
IOL33 CLA           SET NUMBER OF ELEMENTS STACKED
      STA F.L       ON STACK 2 TO 0.
      LDB F.S2B 
      STB F.S2T 
      JMP IOL.F,I   DONE PROCESSING I/O LIST. 
* 
T0IOL NOP           0=READ, 1=WRITE.
T1IOL NOP           # LEFT PARENS BEFORE EXPRESSION.
T2IOL NOP           # RIGHT PARENS WITHIN EXPRESSION. 
T3IOL NOP           F.A OF FIRST PART SUSPECTED CPX CONST.
T4IOL NOP           F.IM OF FIRST PART. 
CONTR NOP           PTR TO IMPLIED DO CONTR. VAR. 
KK48  BYT 1,60      'DO' OPERATOR.
KM3   DEC -3
REA   OCT 20000     F.IM = REA
      SKP 
*         **************
*         * NEW RECORD *
*         **************
      SPC 1 
*     ENTRY: (A) = '(', ')', OR F.A,I 
* 
NR.F  NOP           COMPLETE INFO FOR PREVIOUS
      JSB PU2.F     STACK SYNTAX OF I/O LIST ON STK2
      LDA TWPE      LOAD F.IM=4 FOR TWO WORD PSEUDO ENT 
      JSB ESC.F     ESTABLISH DUMMY A.T.ENTRY 
      JSB AI.F      AND ASSIGN IT TO TABLE
      LDA F.A       STACK ON TOP OF I/O LIST
      JSB PU2.F     SYNTAX,THE A.T. POINTER TO THIS 
      LDA KK49      SEND 'NR.F' OPERATOR. 
      JSB WS1.F 
      LDA F.A 
      JSB WS1.F 
      JMP NR.F,I
      SPC 2 
*         *********************** 
*         * INSERT LOAD ADDRESS * 
*         *********************** 
      SPC 1 
ILA.F NOP 
      INA           GET 2ND WORD OF STACK FRAME 
      LDA A,I       I.E., THE TWPE ENTRY. 
      STA T1ILA     SAVE IT.
      LDA KK50      OUTPUT 'ILA.F' OPERATOR.
      JSB WS1.F 
      LDA T1ILA     AND F.A OF TWPE TO DEFINE.
      JSB WS1.F 
      JMP ILA.F,I 
      SPC 2 
T1ILA NOP 
KK49  BYT 1,61      'NR.F' OPERATOR.
KK50  BYT 1,62      'ILA.F' OPERATOR. 
      SKP 
*         ********************* 
*         * MATCH PARENTHESES * 
*         ********************* 
      SPC 1 
MP.F  NOP           MATCH PAREN IN STACK 2
      STA T0MP      LOCATION OF PAREN TO BE MATCHED 
      STB T1MP      SEARCH UP STK IS +2, DOWN IS -2 
      CLB           INITIALIZE PAREN COUNTER
MP01  LDA T0MP,I    WORD 1 OF 2 WORD STACK 2 ENTRY
      CPA B50       IS SYNTAX '('?
      INB           YES, BUMP COUNT 
      CPA B51       NO, IS SYNTAX ')'?
      ADB KM1       YES, DECREMENT COUNT
      LDA T0MP
      SZB,RSS       IS COUNT = 0? 
      JMP MP03      YES, FINISH UP
      ADA T1MP      UPDATE POINTER IN STACK TO
      STA T0MP      POINT TO NEXT SYNTAX ELEMENT
      CMA,INA 
      ADA F.S2B     (A) _ F.S2B - POINTER 
      SSA,RSS       PAST BOTTOM OF STACK? 
      JMP MP02      YES. MISMATCH ERROR.
      LDA T0MP
      CMA,INA 
      ADA F.S2T     (A) _ F.S2T - POINTER 
      SSA,RSS       PAST TOP OF STACK?
      JMP MP01      NO, CONTINUE SEARCH 
MP02  LDA K9        YES, MISMATCH ERROR 
      JSB ER.F      NO RETURN 
      SPC 1 
MP03  CCE,INA       RETURN POINTER TO STK WORD +1 
      JMP MP.F,I    FOR LOAD ADDRESS STARTING RECORD
* 
T0MP  BSS 1 
T1MP  BSS 1 
K9    DEC 9 
      SKP 
*         ******************
*         * CALL PROCESSOR *
*         ******************
      SPC 1 
F.CAL JSB ISY.F     INPUT NAME. 
      LDB F.A       CHECK FOR RECURSION:
      LDA K75       (ERROR #) 
      CPB F.SBF     SAME AS THIS PROG UNIT ?
      JSB ER.F      YES. ERROR. 
      LDA F.IU      NO. GET USAGE.
      CPA SUB 
      RSS 
      JSB TS.F      TAG SUBPROGRAM
      JSB DS.F      SET F.S=1 TO INDICATE USED AS SUBR. 
      JSB EE.F      EVALUATE SUBROUTINE CALL
      BYT 0,1 
      JMP F.CRT 
* 
SUB   OCT 200       F.IU=1 SUBPROGRAM 
      SPC 2 
*         **********************************
*         * ASSIGNMENT STATEMENT PROCESSOR *
*         **********************************
      SPC 1 
F.ASS JSB II.F      INPUT ITEM
      JSB NCT.F     NON-CONSTANT TEST 
      JSB NST.F     NON-SUBPROGRAM TEST 
      JSB EE.F      EVALUATE ASSIGNMENT STMT. 
      BYT 0,6 
      JMP F.CRT 
* 
STRAB OCT 2000      STR-ABS  F.AT = UNDEFINED 
      SKP 
*         ********************************
*         * STATEMENT FUNCTION PROCESSOR *
*         ********************************
      SPC 1 
F.SFP JSB ISY.F     INPUT SYMBOL
      LDA K22       IF THIS IS THE SAME NAME AS THE CURRENT 
      LDB F.SBF     SUBROUTINE MODULE 
      CPB F.A       THEN
      JSB ER.F      TOO BAD ! 
* 
      LDA K22       IF ALREADY USED 
      LDB F.AT      AS
      CPB STRAB     ANY THING OTHER THAN TYPE 
      RSS           NO GOOD SKIP THE ERROR
      JSB ER.F      TOO BAD ALSO! 
      JSB TS.F      ELSE TAG AS SUBROUTINE.  (F.AF=0) 
      LDA REL       AND SET F.AT=DUM. 
      JSB DAT.F 
      LDA F.A       SAVE F.A OF FUNCTION. 
      IOR B100K     WITH SIGN SET FOR AI.F
      STA F.SFA 
      LDA TWPE      ALLOCATE TWO-WORD BLOCK.
      JSB ESC.F 
      JSB AI.F
      CLA           INITIALIZE IT TO ZERO.
      CLB 
      DST F.A,I 
      LDA F.A       GET EXTENSION ADDR, 
      LDB F.SFA     RESTORE F.A TO STMT FCT,
      RBL,CLE,ERB   (CLEAR SIGN)
      STB F.A 
      JSB DAF.F     AND SET F.AF TO POINT TO EXT. 
* 
      JSB IDL.F     INPUT THE DUMMY LIST. 
      LDA B75       REQUIRE '='.
      JSB TCT.F 
      LDA KK31      PROG ENTRY OPCODE = 31, 
      JSB WS1.F     ONE ARG.
      LDA F.SFA     WHICH IS F.A OF FCT.
      RAL,CLE,ERA   WITHOUT SIGN BIT, 
      STA F.SFA     LIKEWISE REMOVE SIGN FROM HERE. 
      JSB WS1.F 
      JSB EE.F      INPUT THE EXPRESSION. 
      BYT 0,0       TYPE = 'STATEMENT FUNCTION' 
      JMP F.CRT     ALL DONE !
* 
K75   DEC 75
KK31  BYT 1,37      PROG ENTRY OPERATOR.
REL   OCT 1000      AT=1, REL 
DUM   OCT 5000      AT=5, DUM 
      SKP 
*         ************************
*         * PAUSE-STOP PROCESSOR *
*         ************************
      SPC 1 
*                   SET UP OPCODE.
* 
F.STP LDB KK23      STOP OPCODE = 23. 
      RSS 
F.PAP LDB KK24      PAUSE OPCODE = 24.
      STB T2PAS     T2PAS = OPCODE. 
* 
*                   GET OCTAL NUMBER. 
* 
      LDA KM6       SET LIMIT OF 5 DIGITS.
      STA T3PAS 
      JSB CDI.F     SET TO ZERO.
PAST1 JSB ICH.F     INPUT CHAR. 
      CPA B15       C/R ? 
      JMP PAST4     YES, DONE.
* 
      ISZ T3PAS     TOO MANY ?
      RSS 
      JMP PAST2     YES. ERROR. 
* 
      SZB           DIGIT ? 
      JMP PAST2     NO, ERROR.
* 
      ADA BM70      8 OR 9 ?
      SSA,RSS 
      JMP PAST2     YES, ERROR. 
* 
      ADA K8        (A) = VALUE.
      LDB F.IDI     UPDATE RUNNING VALUE. 
      BLF,RBR 
      IOR B 
      STA F.IDI     F.IDI=F.IDI+F.TC (BINARIZED)
      JMP PAST1     NO, TRY FOR MORE. 
* 
*                   ERRORS. 
* 
PAST2 LDA K16       TOO MANY OR ILLEGAL DIGITS. 
      JSB WAR.F     ONLY A WARNING. 
PAST5 JSB ICH.F     SKIP TO C/R.
      CPA B15 
      RSS 
      JMP PAST5 
* 
      CLA,RSS 
PAST4 LDA F.IDI     (A) = VALUE.
      JSB EIC.F     SET UP AS CONSTANT. 
      STA T3PAS     SAVE FOR A MOMENT.
      LDA T2PAS     ISSUE OPCODE. 
      JSB WS1.F 
      LDA T3PAS     THEN F.A OF CONSTANT. 
      JSB WS1.F 
      LDA T2PAS     WHICH WAS IT ?
      CPA KK23
      JMP RTNP1     STOP. 'NO PATH'.
      JMP CILDT     PAUSE. JUST CHECK DO TERMINATION. 
      SKP 
T2PAS NOP 
T3PAS NOP           # OF OCTAL DIGITS 
KK23  BYT 1,27      'STOP' OPCODE.
KK24  BYT 1,30  'PAUSE' OPCODE. 
K16   DEC 16
BM70  OCT -70 
KM6   DEC -6
K7    DEC 7 
K20   DEC 20
K21   DEC 21
      SKP 
*         **********************
*         * CONTINUE PROCESSOR *
*         **********************
      SPC 1 
F.CON LDA F.LSP     LAST OPERATION FLAG 
      ADA F.LSN     LAST STATEMENT NUMBER FLAG
      STA F.LSP     F.LSP=F.LSP+F.LSN 
      CLA 
      STA F.LSF 
      JSB ICH.F     INPUT THE NEXT CHARACTER. 
      LDB F.LFF 
      LDA K89       89
      SZB           TRUE BRANCH OF LOGICAL "IF"?
      JSB WAR.F     YES, COMMENT ON EFFECTIVE "NOP".
      JMP F.CRT     C/R TEST
      SPC 2 
*         ********************
*         * ASSIGN PROCESSOR *
*         ********************
      SPC 1 
F.ASP CLA           INPUT ANY KIND OF STMT #. 
      JSB ISD.F 
      LDA F.A       SAVE ITS F.A .
      STA T0ASP 
      LDA "T"       'T' 
      JSB TCT.F     F.TC-TEST 
      JSB ICH.F     INPUT CHARACTER 
      LDA "O"       'O' 
      JSB TCT.F     F.TC-TEST 
      JSB IIV.F     INPUT INTEGER VARIABLE
      LDA K37 
      LDB F.AT
      CPB DUM 
      JSB WAR.F     ILLEGAL USAGE OF DUMMY VARIABLE 
      LDA KK36      'ASSIGN' OPCODE.
      JSB WS1.F 
      LDA T0ASP     THE STMT # F.A
      JSB WS1.F 
      LDA F.A       THE VARIABLE F.A
      JSB WS1.F 
      JMP F.CRT     C/R TEST
* 
K89   DEC 89
KK36  BYT 2,44      'ASSIGN' OPERATOR.
K37   DEC 37
"T"   OCT 124 
K79   DEC 79
"O"   EQU K79 
T0ASP NOP           SAVE ASSI PTR OF STMT FUNC NAME 
      SKP 
*         ********************
*         * RETURN PROCESSOR *
*         ********************
      SPC 1 
F.RTN JSB ICH.F     INPUT A CHAR. 
      LDB F.SBF     SUBPROGRAM FLAG SET ? 
      SZB 
      JMP RTN01     YES. O.K. 
* 
      LDA K7        NO. WARNING: RETURN IN MAIN.
      JSB WAR.F 
      LDA K20       A = END OPCODE. 
      JMP RTN04 
* 
RTN01 LDA F.SFF     SUBROUTINE OR FUNCTION ?
      SZA 
      JMP RTN03     FUNCTION. NO ALTERNATE RETURNS. 
* 
      LDA F.TC      SUB. IS THERE AN ALT RTN VALUE ?
      CPA B15 
      JMP RTN02     NO. GO USE ZERO.
* 
      JSB UC.F      BACK UP FOR EE.F'S BENEFIT. 
      JSB EE.F      YES. SAME AS A UNIT NUMBER. 
      BYT 0,3 
      JMP RTN03     GO SEND OPCODE. 
* 
RTN02 CLA           SET UP A CONSTANT ZERO. 
      JSB EIC.F 
      IOR B100K 
      JSB WS1.F     SO IT WILL BE ON STACK. 
RTN03 LDA K21       RETURN OPERATOR.
RTN04 JSB WS1.F     WRITE OP. 
      JMP RTNP1     DONE. 
      SKP 
*         ***************** 
*         * END STATEMENT * 
*         ***************** 
      SPC 1 
F.ENP CLA           SET LINE NUMBER TO ZERO 
      STA F.LNN     TO SUPPRESS IN ERROR MESSAGES.
      LDA K30       IF DO STACK IS NOT EMPTY, 
      LDB F.D       THEN THERE IS AN UNCOMPLETED
      CPB F.DO      DO LOOP OR IF-THEN-ELSE.
      RSS           (EMPTY, O.K.) 
      JSB WAR.F     COMPLAIN. 
* 
      LDA K50       LIKEWISE IF TRUE BRANCH OF LOGICAL IF.
      LDB F.LFF 
      SZB 
      JSB WAR.F 
* 
      CLA           SET F.CC=0 TO SUPPRESS ERRORS.
      STA F.CC
      JSB EIC.F     CREATE ZERO.
      IOR B100K     WRITE TO PASS FILE AS OPERAND,
      JSB WS1.F     JUST IN CASE 'RETURN'.
      LDA K20       'END' OPCODE. 
      LDB F.SBF     SUBPROGRAM FLAG SET ? 
      SZB 
      INA           YES, CHANGE TO 'RETURN' 
      LDB F.LSP     PATH HERE ? 
      ADB F.LSN 
      SZB 
      JSB WS1.F     YES, WRITE THE OPCODE.
      LDB K2        SET SEGMENT 2.
      JMP F.SEG     GO LOAD THE SEGMENT 
* 
      END 
ASMB,Q,C
      HED FTN4X, SEGMENT F4X.2 - INTRINSIC FUNCTIONS PHASE. 
      NAM F4X.2,5 92834-16002 REV.2030 800613 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     * 
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE-  * 
* REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * 
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.   * 
*************************************************************** 
*  NAME:   PART OF FTN4X              * 
*  SOURCE: PART OF 92834-18002        * 
*  RELOC:  PART OF 92834-16002        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
************************************
*     FORTRAN-4 COMPILER SEGMENT 2 *
************************************
* 
*     THIS SEGMENT IS THE INTRINSIC/GENERIC FUNCTION PHASE. 
*     (ALSO DOES 'IMPLICIT NONE' CHECKING.) 
*     IT IS EXECUTED BETWEEN PASS 1 AND PASS 2. 
* 
*                   GENERAL EXTERNALS.
* 
      EXT F.A       ASSIGNMENT TABLE ADDR (CURRENT ENTRY).
      EXT F.ABT     ABORT COMPILE.
      EXT F.CCW     OPTIONS WORD. 
      EXT F..E      EXPLICIT TYPING BIT.
      EXT F.EQE     LOCAL ERROR RECOVERY ADDRESS. 
      EXT F.ERX     GLOBAL ERROR RECOVERY ADDRESS.
      EXT F.IM      CURRENT ITEM MODE.
      EXT F.IMF     IMPLICIT FLAG.
      EXT F.PCT     F.A OF TEMP FOR PCOUNT(). 
      EXT F.S       SUBROUTINE FLAG.
      EXT F.SBF     F.A OF CURRENT MODULE.
      EXT F.SEG     SEGMENT LOADER. 
      EXT F.SFF     SUBROUTINE/FUNCTION/BLOCKDATA FLAG. 
* 
      EXT APT.F     ALLOCATE PERMANENT TEMP.
      EXT AST.F     ALLOCATE SPACE IN SYMBOL TABLE. 
      EXT DAF.F     DEFINE (F.AF) 
      EXT DIM.F     DEFINE (F.IM) 
      EXT ES1.F     WRITE E-O-F ON PASS FILE 1. 
      EXT FA.F      FETCH ASSIGNS.
      EXT GFA.F     GET FIRST (NAMED) SYMBOL TABLE ENTRY. 
      EXT GNA.F     GET NEXT SYMBOL TABLE ENTRY.
      EXT NAM.F     COPY SYMBOL NAME. 
      EXT PCC.F     PRINT COMPILER COMMENT. 
      EXT WAR.F     ISSUE WARNING MESSAGE.
      EXT WS1.F     WRITE WORD ON PASS FILE 1.
* 
*                   LIBRARY.
* 
      EXT .MVW      MOVE WORDS. 
* 
      EXT C.SC0     CARD FILE / 2ND PASS FILE.
      EXT C.SC1     1ST PASS FILE.
* 
      EXT EOF.C     CLIB WRITE EOF. 
      EXT RWN.C     CLIB REWIND.
      SPC 2 
A     EQU 0 
B     EQU 1 
      SUP 
* 
      DEC 2         SEGMENT NUMBER. 
      SKP 
*     ENTRIES IN THE INTRINSICS TABLE USED IN THIS SEGMENT
*     HAVE THE FOLLOWING FORMAT:
* 
* 
*     !-------------------------------!-------------------------------! 
*     !        CHAR 1                 !         CHAR 2                ! 
*     !-------------------------------!-------------------------------! 
*     !        CHAR 3                 !         CHAR 4                ! 
*     !-------------------------------!-------------------------------! 
*     !        CHAR 5                 !         CHAR 6                ! 
*     !---!---!-------!---------------!---------------!---------------! 
*     ! 0 ! S !A=#PRMS!  B=# EXT VER  !  C=# GEN VER  !  D=DEFLT TYPE ! 
*     !---!---!---!---!-----------!---!---------------!---------------! 
*     ! IJXY=OPT. !   E=TYPE      !  DOT FCT ORDINAL IF DCL EXTERNAL  ! 
*     !-----------!---------------!-------------------!---------------! 
*     //        (repeat above 1-word entry B-1 times)                // 
*     !-------------------------------!---------------!---------------! 
*     !               0               !  G=ARG TYPE   !  H=FCT TYPE   ! 
*     !---------------------------!---!---------------!---------------! 
*     !  DOT FUNCTION DESCRIPTION !      DOT FUNCTION ORDINAL         ! 
*     !---------------------------!-----------------------------------! 
*     //        (repeat above 2-word entry C-1 times)                 ! 
*     !---------------------------------------------------------------! 
* 
*     THE TABLE IS JUST A LINEAR LIST OF THESE ENTRIES, TERMINATED
*     BY A ZERO WORD. 
* 
* 
*     THIS SEGMENT SEARCHES FOR MATCHES BETWEEN THE SYMBOL TABLE AND
*     THE INTRINSICS TABLE. WHEN IT FINDS A MATCH, IT BUILDS A SYMBOL 
*     TABLE ENTRY OF THE FOLLOWING FORM:
* 
* 
*     !---!-------!---------------!-----------------------------------! 
*     ! S ! #PRMS !  # ENTRIES    !  DOT FCT ORDINAL IF DCL EXTERNAL  ! 
*     !---!-------!---------------!---!---------------!---------------! 
*     !              0                !   ARG TYPE    !   FCT TYPE    ! 
*     !---------------------------!---!---------------!---------------! 
*     !  DOT FUNCTION DESCRIPTION !         DOT FUNCTION ORDINAL      ! 
*     !---------------------------!-----------------------------------! 
*     //       (repeat above pair as specified in count above)       // 
*     !---------------------------------------------------------------! 
* 
*     THE F.AF FIELD OF THE ORIGINAL A.T. ENTRY GETS THE ADDRESS OF THE 
*     NEW SYMBOL TABLE ENTRY. 
      SKP 
*     THE ALGORITHM FOR CREATION OF THE NEW SYMBOL TABLE ENTRY, GIVEN THE 
*     SYMBOL A.T. ENTRY AND THE INTRINSIC TABLE ENTRY IS: 
* 
*     1) Copy number of parameters verbatim.
* 
*     2) If symbol is not explicitly typed, make its type the default type, 
*        as modified by the 'J' and 'Y' options.
* 
*     3) Search the first section of the intrinsics table for a type which
*        matches the function type.  If the IJXY field is nonzero, the
*        appropriate option must be on. Copy that to the new entry. 
*        If none were found, the function didnt't have a specific name, 
*        or it was retyped to a type for which no specific form existed.
*        If explicitly typed, it is not considered intrinsic, else it is
*        one of those generics with no specific (e.g. LOG), which is O.K. 
*        but it can't be used as an EXTERNAL then (set dot fct value = 0).
* 
*     4) Scan the second section of the intrinsics table.  Copy each entry
*        unless:
*                a) Type was explicitly declared and function type of the 
*                   entry is different. 
*                b) Function type is different from argument type and 
*                   function type is not default for current 'J' or 'Y' 
*                   option. 
* 
*     5) Set the number of entries found into the count field.
      SPC 4 
*     FOR 'ALIAS' FUNCTIONS & SUBROUTINES, A SYMBOL TABLE ENTRY IS SET UP 
*     WITH THE FTN NAME, WITH THE F.AF POINTING TO ANOTHER SYMBOL TABLE 
*     ENTRY, WHICH HAS THE TRUE NAME AND HAS THE DOT FUNCTION INTO IN 
*     ITS F.AF WORD.  ALIAS ENTRIES HAVE F.NC=2.
      SKP 
*     EQUATED SYMBOLS TO AID IN BUILDING INTRINSICS TABLE.
* 
*     SYMBOLS HAVE THE FORM 'X.V' WHERE:  X=FIELD INDICATOR,
*                                         V=VALUE INDICATOR.
* 
*     E.G., 'D.INT' INDICATES THE FIELD 'D' WITH VALUE 'INT'. 
* 
* 
A.0   EQU 00000B    NONE          # PARAMETERS. 
A.1   EQU 10000B    1 
A.2   EQU 20000B    2 
A.VAR EQU 30000B    VARIABLE. 
* 
B.0   EQU 0000B     0             # OF 'EXTERNAL' VERSIONS. 
B.1   EQU 0400B     1 
B.2   EQU 1000B     2 
B.4   EQU 2000B     4 
* 
C.1   EQU 020B      1             # OF 'SPECIFIC' VERSIONS. 
C.2   EQU 040B      2 
C.3   EQU 060B      3 
C.4   EQU 100B      4 
C.5   EQU 120B      5 
C.7   EQU 160B      7 
C.12  EQU 300B      12
* 
D.NON EQU 0         (NONE)        DEFAULT TYPE. 
D.INT EQU 1         INTEGER*2 
D.REA EQU 2         REAL*4
D.CPX EQU 5         COMPLEX*8 
D.DBL EQU 6         REAL*6
D.RE8 EQU 12B       REAL*8
* 
I     EQU 20000B    (HALF-SIZE 'CAUSE CAN'T EQU TO NEG) 
J     EQU 30000B    BITS 15:14 SPECIFY WHICH OPTION TO CHECK: 
X     EQU 40000B    0=NEITHER, 1=I/J, 2=X/Y, 3=UNUSED.
Y     EQU 50000B    OPTION VALUE IN BIT 13: I=X=0, J=Y=1. 
* 
E.INT EQU 01000B    INTEGER*2     EXTERNAL FCT TYPE.
E.REA EQU 02000B    REAL*4
E.CPX EQU 05000B    COMPLEX*8 
E.DBL EQU 06000B    REAL*6
E.DBI EQU 10000B    INTEGER*4 
E.RE8 EQU 12000B    REAL*8
E.ZPX EQU 14000B    COMPLEX*16
* 
G.INT EQU 020B      INTEGER*2     ARGUMENT TYPE.
G.REA EQU 040B      REAL*4
G.CPX EQU 120B      COMPLEX*8 
G.DBL EQU 140B      REAL*6
G.DBI EQU 200B      INTEGER*4 
G.RE8 EQU 240B      REAL*8
G.ZPX EQU 300B      COMPLEX*16
G.SUB EQU 0         SUBROUTINE (NON-GENERIC)
* 
H.INT EQU 1         INTEGER*2     FUNCTION TYPE.
H.REA EQU 2         REAL*4
H.CPX EQU 5         COMPLEX*8 
H.DBL EQU 6         REAL*6
H.DBI EQU 10B       INTEGER*4 
H.RE8 EQU 12B       REAL*8
H.ZPX EQU 14B       COMPLEX*16
* 
R.REG EQU 40000B    REG. PRESERVED.    DOT FCT OPTIONS. 
R.OPM EQU 20000B    OPNDS IN MEM. 
R.RTN EQU 10000B    RTN ADDR. 
R.ER0 EQU 04000B    DO JSB ERR0.
* 
S.1   EQU 40000B    SUBROUTINE CALL ALLOWABLE.
      SKP 
*     THE INTRINSICS TABLE. 
* 
      DEF SQRT2 
IFTBL ASC 3,SQRT                                 SQRT.
      ABS A.1+B.1+C.5+D.REA 
      ABS E.REA+%QRT
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+SQRT
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DSQRT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.SQRT 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+CSQRT 
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+.ZSQR 
* 
      DEF SQRT3 
SQRT2 ASC 3,DSQRT                                DSQRT. 
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$SQRT 
      ABS E.RE8+/SQRT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DSQRT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.SQRT 
* 
      DEF SIN1
SQRT3 ASC 3,CSQRT                                CSQRT. 
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+CSQRT 
      ABS E.ZPX+.ZSQR 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+CSQRT 
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+.ZSQR 
* 
*                   SIN.
* 
      DEF SIN2
SIN1  ASC 3,SIN                                  SIN. 
      ABS A.1+B.1+C.5+D.REA 
      ABS E.REA+%IN 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+SIN 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DSIN
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.SIN
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CSIN
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZSIN 
* 
      DEF SIN3
SIN2  ASC 3,DSIN                                 DSIN.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DSIN
      ABS E.RE8+/SIN
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DSIN
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.SIN
* 
      DEF COS1
SIN3  ASC 3,CSIN                                 CSIN.
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+#SIN
      ABS E.ZPX+%ZSIN 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CSIN
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZSIN 
* 
      DEF COS2
COS1  ASC 3,COS                                  COS. 
      ABS A.1+B.1+C.5+D.REA 
      ABS E.REA+%OS 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+COS 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DCOS
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.COS
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CCOS
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZCOS 
* 
      DEF COS3
COS2  ASC 3,DCOS                                 DCOS.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DCOS
      ABS E.RE8+/COS
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DCOS
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.COS
* 
      DEF TAN1
COS3  ASC 3,CCOS                                 CCOS.
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+#COS
      ABS E.ZPX+%ZCOS 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CCOS
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZCOS 
* 
      DEF TAN2
TAN1  ASC 3,TAN                                  TAN. 
      ABS A.1+B.1+C.5+D.REA 
      ABS E.REA+%AN 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+TAN 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DTAN
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.TAN
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+.CTAN 
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZTAN 
* 
      DEF TAN3
TAN2  ASC 3,DTAN                                 DTAN.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$TAN
      ABS E.RE8+/TAN
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DTAN
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.TAN
* 
      DEF TANH1 
TAN3  ASC 3,CTAN                                 CTAN.
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+%CTAN 
      ABS E.ZPX+%ZTAN 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+.CTAN 
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZTAN 
* 
      DEF TANH2 
TANH1 ASC 3,TANH                                 TANH.
      ABS A.1+B.1+C.3+D.REA 
      ABS E.REA+%ANH
      ABS G.REA+H.REA 
      ABS R.REG+TANH
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DTANH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.TANH 
* 
      DEF ATN.1 
TANH2 ASC 3,DTANH                                DTANH. 
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DTANH 
      ABS E.RE8+.TANH 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DTANH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.TANH 
* 
      DEF ATN.2 
ATN.1 ASC 3,ATAN                                 ATAN.
      ABS A.1+B.1+C.3+D.REA 
      ABS E.RE8+%TAN
      ABS G.REA+H.REA 
      ABS R.REG+ATAN
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DATAN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.ATAN 
* 
      DEF AT2.1 
ATN.2 ASC 3,DATAN                                DATAN. 
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DATAN 
      ABS E.RE8+.ATAN 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DATAN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.ATAN 
* 
      DEF AT2.2 
AT2.1 ASC 3,ATAN2                                ATAN2. 
      ABS A.2+B.1+C.3+D.REA 
      ABS E.REA+ATAN2 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+ATAN2 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DATN2 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.ATN2 
* 
      DEF AT2.3 
AT2.2 ASC 3,DATAN2                               DATAN2.
      ABS A.2+B.2+C.2+D.DBL 
      ABS E.DBL+DATN2 
      ABS E.RE8+/ATN2 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DATN2 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.ATN2 
* 
      DEF LOG1  
AT2.3 ASC 3,DATN2                                DATN2. 
      ABS A.2+B.2+C.2+D.DBL 
      ABS E.DBL+DATN2 
      ABS E.RE8+/ATN2 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DATN2 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.ATN2 
* 
      DEF LOG2
LOG1  ASC 3,LOG                                  LOG. 
      ABS A.1+B.0+C.5+D.NON 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+ALOG
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DLOG
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.LOG
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CLOG
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZLOG 
* 
      DEF LOG3
LOG2  ASC 3,ALOG                                 ALOG.
      ABS A.1+B.1+C.1+D.REA 
      ABS E.REA+%LOG
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+ALOG
* 
      DEF LOG4
LOG3  ASC 3,DLOG                                 DLOG.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$LOG
      ABS E.RE8+/LOG
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DLOG
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.LOG
* 
      DEF L10.1 
LOG4  ASC 3,CLOG                                 CLOG.
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+#LOG
      ABS E.ZPX+%ZLOG 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CLOG
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZLOG 
* 
      DEF L10.2 
L10.1 ASC 3,LOG10                                LOG10. 
      ABS A.1+B.0+C.3+D.NON 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+ALOGT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DLOGT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.LOGT 
* 
      DEF L10.3 
L10.2 ASC 3,ALOG10                               ALOG10.
      ABS A.1+B.1+C.1+D.REA 
      ABS E.REA+%LOGT 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+ALOGT 
* 
      DEF ALGT1 
L10.3 ASC 3,DLOG10                               DLOG10.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$LOGT 
      ABS E.RE8+/LOGT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DLOGT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.LOGT 
* 
      DEF ALGT2 
ALGT1 ASC 3,ALOGT                                ALOGT. 
      ABS A.1+B.1+C.1+D.REA 
      ABS E.REA+%LOGT 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+ALOGT 
* 
      DEF EXP1
ALGT2 ASC 3,DLOGT                                DLOGT. 
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$LOGT 
      ABS E.RE8+/LOGT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DLOGT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.LOGT 
* 
      DEF EXP2
EXP1  ASC 3,EXP                                  EXP. 
      ABS A.1+B.1+C.5+D.REA 
      ABS E.REA+%XP 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+EXP 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DEXP
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.EXP
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CEXP
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZEXP 
* 
      DEF EXP3
EXP2  ASC 3,DEXP                                 DEXP.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+$EXP
      ABS E.RE8+/EXP
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+R.ER0+DEXP
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.EXP
* 
      DEF SINH1 
EXP3  ASC 3,CEXP                                 CEXP.
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+#EXP
      ABS E.ZPX+%ZEXP 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+R.ER0+CEXP
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+R.ER0+.ZEXP 
* 
      DEF SINH2 
SINH1 ASC 3,SINH                                 SINH.
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%SINH 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.SINH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DSNH 
* 
      DEF COSH1 
SINH2 ASC 3,DSINH                                DSINH. 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DSNH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DSNH 
* 
      DEF COSH2 
COSH1 ASC 3,COSH                                 COSH.
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%COSH 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.COSH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DCSH 
* 
      DEF ASIN1 
COSH2 ASC 3,DCOSH                                DCOSH. 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DCSH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DCSH 
* 
      DEF ASIN2 
ASIN1 ASC 3,ASIN                                 ASIN.
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ASIN 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.ASIN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DASN 
* 
      DEF ACOS1 
ASIN2 ASC 3,DASIN                                DASIN. 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DASN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DASN 
* 
      DEF ACOS2 
ACOS1 ASC 3,ACOS                                 ACOS.
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ACOS 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.ACOS 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DACS 
* 
      DEF ASNH1 
ACOS2 ASC 3,DACOS                                DACOS. 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DACS 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DACS 
* 
      DEF ASNH2 
ASNH1 ASC 3,ASINH                                ASINH
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ASNH 
      ABS G.REA+H.REA 
      ABS R.REG+.ASNH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.DASH 
* 
      DEF ACSH1 
ASNH2 ASC 3,DASINH                               DASINH 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+.DASH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.DASH 
* 
      DEF ACSH2 
ACSH1 ASC 3,ACOSH                                ACOSH
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ACSH 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.ACSH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DACH 
* 
      DEF ATNH1 
ACSH2 ASC 3,DACOSH                               DACOSH 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DACH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DACH 
* 
      DEF ATNH2 
ATNH1 ASC 3,ATANH                                ATANH
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ATNH 
      ABS G.REA+H.REA 
      ABS R.REG+R.ER0+.ATNH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DATH 
* 
      DEF ABS1
ATNH2 ASC 3,DATANH                               DATANH 
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%DATH 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+R.ER0+.DATH 
* 
      DEF ABS2
ABS1  ASC 3,ABS                                  ABS. 
      ABS A.1+B.1+C.7+D.REA 
      ABS E.REA+%BS 
      ABS G.INT+H.INT 
      OCT 100001
      ABS G.DBI+H.DBI 
      OCT 100002
      ABS G.REA+H.REA 
      OCT 100003
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DABS
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.ABS
      ABS G.CPX+H.REA 
      ABS R.OPM+R.RTN+CABS
      ABS G.ZPX+H.RE8 
      ABS R.OPM+R.RTN+.ZABS 
* 
      DEF ABS3
ABS2  ASC 3,IABS                                 IABS.
      ABS A.1+B.2+C.2+D.INT 
      ABS E.INT+%ABS
      ABS E.DBI+%JABS 
      ABS G.INT+H.INT 
      OCT 100001
      ABS G.DBI+H.DBI 
      OCT 100002
* 
      DEF ABS4
ABS3  ASC 3,DABS                                 DABS.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DABS
      ABS E.RE8+.ABS
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DABS
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.ABS
* 
      DEF MOD1
ABS4  ASC 3,CABS                                 CABS.
      ABS A.1+B.2+C.2+D.REA 
      ABS E.REA+CABS
      ABS E.RE8+.ZABS 
      ABS G.CPX+H.REA 
      ABS R.OPM+R.RTN+CABS
      ABS G.ZPX+H.RE8 
      ABS R.OPM+R.RTN+.ZABS 
* 
      DEF MOD2
MOD1  ASC 3,MOD                                  MOD. 
      ABS A.2+B.2+C.5+D.INT 
      ABS E.INT+MOD 
      ABS E.DBI+%JMOD 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+MOD 
      ABS G.DBI+H.DBI 
      ABS R.REG+.DMOD 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMOD
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMOD
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MOD
* 
      DEF MOD3
MOD2  ASC 3,AMOD                                 AMOD.
      ABS A.2+B.1+C.1+D.REA 
      ABS E.REA+AMOD
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMOD
* 
      DEF SIGN1 
MOD3  ASC 3,DMOD                                 DMOD.
      ABS A.2+B.2+C.2+D.DBL 
      ABS E.DBL+DMOD
      ABS E.RE8+.MOD
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMOD
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MOD
* 
      DEF SIGN2 
SIGN1 ASC 3,SIGN                                 SIGN.
      ABS A.2+B.1+C.5+D.REA 
      ABS E.REA+%IGN
      ABS G.INT+H.INT 
      ABS R.OPM+ISIGN 
      ABS G.DBI+H.DBI 
      ABS R.OPM+.JSGN 
      ABS G.REA+H.REA 
      ABS R.OPM+SIGN
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DSIGN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.SIGN 
* 
      DEF SIGN3 
SIGN2 ASC 3,ISIGN                                ISIGN. 
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+%IGN
      ABS E.DBI+%JSGN 
      ABS G.INT+H.INT 
      ABS R.OPM+ISIGN 
      ABS G.DBI+H.DBI 
      ABS R.OPM+.JSGN 
* 
      DEF DIM1
SIGN3 ASC 3,DSIGN                                DSIGN. 
      ABS A.2+B.2+C.2+D.DBL 
      ABS E.DBL+DSIGN 
      ABS E.RE8+.SIGN 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DSIGN 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.SIGN 
* 
      DEF DIM2
DIM1  ASC 3,DIM                                  DIM. 
      ABS A.2+B.1+C.5+D.REA 
      ABS E.REA+DIM 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+IDIM
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JDIM 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+DIM 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+.XDIM 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.DDIM 
* 
      DEF DIM3
DIM2  ASC 3,IDIM                                 IDIM.
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+IDIM
      ABS E.DBI+.JDIM 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+IDIM
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JDIM 
* 
      DEF MIN.1 
DIM3  ASC 3,DDIM                                 DDIM.
      ABS A.2+B.2+C.2+D.DBL 
      ABS E.DBL+.XDIM 
      ABS E.RE8+.DDIM 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+.XDIM 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.DDIM 
* 
      DEF MIN.2 
MIN.1 ASC 3,MIN                                  MIN. 
      ABS A.VAR+B.0+C.5+D.NON 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+MIN0
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JMN0 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMIN1 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMIN1 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MIN1 
* 
      DEF MIN.3 
MIN.2 ASC 3,MIN0                                 MIN0.
      ABS A.VAR+B.2+C.2+D.INT 
      ABS E.INT+MIN0
      ABS E.DBI+.JMN0 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+MIN0
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JMN0 
* 
      DEF MIN.4 
MIN.3 ASC 3,AMIN1                                AMIN1. 
      ABS A.VAR+B.1+C.1+D.REA 
      ABS E.REA+AMIN1 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMIN1 
* 
      DEF AMN.0 
MIN.4 ASC 3,DMIN1                                DMIN1. 
      ABS A.VAR+B.2+C.2+D.DBL 
      ABS E.DBL+DMIN1 
      ABS E.RE8+.MIN1 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMIN1 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MIN1 
* 
      DEF MN1.1 
AMN.0 ASC 3,AMIN0                                AMIN0. 
      ABS A.VAR+B.2+C.2+D.REA 
      ABS I+I+E.REA+AMIN0 
      ABS J+J+E.REA+.AMNJ 
      ABS G.INT+H.REA 
      ABS R.OPM+R.RTN+AMIN0 
      ABS G.DBI+H.REA 
      ABS R.OPM+R.RTN+.AMNJ 
* 
      DEF MAX.1 
MN1.1 ASC 3,MIN1                                 MIN1.
      ABS A.VAR+B.2+C.2+D.INT 
      ABS E.INT+MIN1
      ABS E.DBI+.JMN1 
      ABS G.REA+H.INT 
      ABS R.OPM+R.RTN+MIN1
      ABS G.REA+H.DBI 
      ABS R.OPM+R.RTN+.JMN1 
* 
      DEF MAX.2 
MAX.1 ASC 3,MAX                                  MAX. 
      ABS A.VAR+B.0+C.5+D.NON 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+MAX0
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JMX0 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMAX1 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMAX1 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MAX1 
* 
      DEF MAX.3 
MAX.2 ASC 3,MAX0                                 MAX0.
      ABS A.VAR+B.2+C.2+D.INT 
      ABS E.INT+MAX0
      ABS E.DBI+.JMX0 
      ABS G.INT+H.INT 
      ABS R.OPM+R.RTN+MAX0
      ABS G.DBI+H.DBI 
      ABS R.OPM+R.RTN+.JMX0 
* 
      DEF MAX.4 
MAX.3 ASC 3,AMAX1                                AMAX1. 
      ABS A.VAR+B.1+C.1+D.REA 
      ABS E.REA+AMAX1 
      ABS G.REA+H.REA 
      ABS R.OPM+R.RTN+AMAX1 
* 
      DEF AMX.0 
MAX.4 ASC 3,DMAX1                                DMAX1. 
      ABS A.VAR+B.2+C.2+D.DBL 
      ABS E.DBL+DMAX1 
      ABS E.RE8+.MAX1 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DMAX1 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.MAX1 
* 
      DEF MX.1
AMX.0 ASC 3,AMAX0                                AMAX0. 
      ABS A.VAR+B.2+C.2+D.REA 
      ABS I+I+E.REA+AMAX0 
      ABS J+J+E.REA+.AMXJ 
      ABS G.INT+H.REA 
      ABS R.OPM+R.RTN+AMAX0 
      ABS G.DBI+H.REA 
      ABS R.OPM+R.RTN+.AMXJ 
* 
      DEF AIMG1 
MX.1  ASC 3,MAX1                                 MAX1.
      ABS A.VAR+B.2+C.2+D.INT 
      ABS E.INT+MAX1
      ABS E.DBI+.JMX1 
      ABS G.REA+H.INT 
      ABS R.OPM+R.RTN+MAX1
      ABS G.REA+H.DBI 
      ABS R.OPM+R.RTN+.JMX1 
* 
      DEF CNJG1 
AIMG1 ASC 3,AIMAG                                AIMAG. 
      ABS A.1+B.2+C.2+D.REA 
      ABS E.REA+AIMAG 
      ABS E.RE8+.ZAIM 
      ABS G.CPX+H.REA 
      ABS R.OPM+R.RTN+AIMAG 
      ABS G.ZPX+H.RE8 
      ABS R.OPM+R.RTN+.ZAIM 
* 
      DEF AINT1 
CNJG1 ASC 3,CONJG                                CONJG. 
      ABS A.1+B.2+C.2+D.CPX 
      ABS E.CPX+CONJG 
      ABS E.ZPX+.ZCJG 
      ABS G.CPX+H.CPX 
      ABS R.OPM+R.RTN+CONJG 
      ABS G.ZPX+H.ZPX 
      ABS R.OPM+R.RTN+.ZCJG 
* 
      DEF DINT
AINT1 ASC 3,AINT                                 AINT.
      ABS A.1+B.1+C.3+D.REA 
      ABS E.REA+%INT
      ABS G.REA+H.REA 
      ABS R.REG+AINT
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DDINT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.YINT 
* 
      DEF DDNT1 
DINT  ASC 3,DINT                                 DINT.
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DDINT 
      ABS E.RE8+.YINT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DDINT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.YINT 
* 
      DEF INT1
DDNT1 ASC 3,DDINT                                DDINT. 
      ABS A.1+B.2+C.2+D.DBL 
      ABS E.DBL+DDINT 
      ABS E.RE8+.YINT 
      ABS G.DBL+H.DBL 
      ABS R.OPM+R.RTN+DDINT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.YINT 
* 
      DEF INT2
INT1  ASC 3,INT                                  INT. 
      ABS A.1+B.2+C.12+D.INT
      ABS E.INT+%FIX
      ABS E.DBI+%FIXD 
      ABS G.INT+H.INT 
      OCT 100000
      ABS G.DBI+H.DBI 
      OCT 100000
      ABS G.REA+H.INT 
      OCT 100000
      ABS G.REA+H.DBI 
      OCT 100000
      ABS G.DBL+H.INT 
      OCT 100000
      ABS G.DBL+H.DBI 
      OCT 100000
      ABS G.RE8+H.INT 
      OCT 100000
      ABS G.RE8+H.DBI 
      OCT 100000
      ABS G.CPX+H.INT 
      OCT 100000
      ABS G.CPX+H.DBI 
      OCT 100000
      ABS G.ZPX+H.INT 
      OCT 100000
      ABS G.ZPX+H.DBI 
      OCT 100000
* 
      DEF INT3
INT2  ASC 3,IFIX                                 IFIX 
      ABS A.1+B.2+C.2+D.INT 
      ABS E.INT+%FIX
      ABS E.DBI+%FIXD 
      ABS G.REA+H.INT 
      OCT 100000
      ABS G.REA+H.DBI 
      OCT 100000
* 
      DEF ANNT1 
INT3  ASC 3,IDINT                                IDINT. 
      ABS A.1+B.4+C.4+D.INT 
      ABS X+X+E.INT+IDINT 
      ABS X+X+E.DBI+%XFXD 
      ABS Y+Y+E.INT+%TFXS 
      ABS Y+Y+E.DBI+%TFXD 
      ABS G.DBL+H.INT 
      OCT 100000
      ABS G.DBL+H.DBI 
      OCT 100000
      ABS G.RE8+H.INT 
      OCT 100000
      ABS G.RE8+H.DBI 
      OCT 100000
* 
      DEF DNNT1 
ANNT1 ASC 3,ANINT                                ANINT. 
      ABS A.1+B.1+C.2+D.REA 
      ABS E.REA+%ANNT 
      ABS G.REA+H.REA 
      ABS R.REG+.ANNT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.TNNT 
* 
      DEF NINT1 
DNNT1 ASC 3,DNINT                                DNINT
      ABS A.1+B.1+C.1+D.RE8 
      ABS E.RE8+%TNNT 
      ABS G.RE8+H.RE8 
      ABS R.OPM+R.RTN+.TNNT 
* 
      DEF IDNT1 
NINT1 ASC 3,NINT                                 NINT.
      ABS A.1+B.2+C.4+D.INT 
      ABS E.INT+%NINT 
      ABS E.DBI+%NJNT 
      ABS G.REA+H.INT 
      ABS R.REG+.NINT 
      ABS G.REA+H.DBI 
      ABS R.REG+.NJNT 
      ABS G.RE8+H.INT 
      ABS R.OPM+.IDNT 
      ABS G.RE8+H.DBI 
      ABS R.OPM+.JDNT 
* 
      DEF REAL1 
IDNT1 ASC 3,IDNINT                               IDNINT.
      ABS A.1+B.2+C.2+D.INT 
      ABS Y+Y+E.INT+%IDNT 
      ABS Y+Y+E.DBI+%JDNT 
      ABS G.RE8+H.INT 
      ABS R.OPM+.IDNT 
      ABS G.RE8+H.DBI 
      ABS R.OPM+.JDNT 
* 
      DEF FLT1
REAL1 ASC 3,REAL                                 REAL.
      ABS A.1+B.2+C.7+D.REA 
      ABS I+I+E.REA+%LOAT 
      ABS J+J+E.REA+%FLTD 
      ABS G.INT+H.REA 
      OCT 100000
      ABS G.DBI+H.REA 
      OCT 100000
      ABS G.REA+H.REA 
      OCT 100000
      ABS G.DBL+H.REA 
      OCT 100000
      ABS G.RE8+H.REA 
      OCT 100000
      ABS G.CPX+H.REA 
      OCT 100000
      ABS G.ZPX+H.RE8 
      OCT 100000
* 
      DEF SNGL1 
FLT1  ASC 3,FLOAT                                FLOAT. 
      ABS A.1+B.2+C.2+D.REA 
      ABS I+I+E.REA+%LOAT 
      ABS J+J+E.REA+%FLTD 
      ABS G.INT+H.REA 
      OCT 100000
      ABS G.DBI+H.REA 
      OCT 100000
* 
      DEF DBLE1 
SNGL1 ASC 3,SNGL                                 SNGL.
      ABS A.1+B.2+C.2+D.REA 
      ABS X+X+E.REA+SNGL
      ABS Y+Y+E.REA+.NGL
      ABS G.DBL+H.REA 
      OCT 100000
      ABS G.RE8+H.REA 
      OCT 100000
* 
      DEF CMPL1 
DBLE1 ASC 3,DBLE                                 DBLE.
      ABS A.1+B.2+C.12+D.DBL
      ABS E.DBL+DBLE
      ABS E.RE8+.BLE
      ABS G.INT+H.DBL 
      OCT 100000
      ABS G.INT+H.RE8 
      OCT 100000
      ABS G.DBI+H.DBL 
      OCT 100000
      ABS G.DBI+H.RE8 
      OCT 100000
      ABS G.REA+H.DBL 
      OCT 100000
      ABS G.REA+H.RE8 
      OCT 100000
      ABS G.DBL+H.DBL 
      OCT 100000
      ABS G.RE8+H.RE8 
      OCT 100000
      ABS G.CPX+H.DBL 
      OCT 100000
      ABS G.CPX+H.RE8 
      OCT 100000
      ABS G.ZPX+H.DBL 
      OCT 100000
      ABS G.ZPX+H.RE8 
      OCT 100000
* 
      DEF IAND1 
CMPL1 ASC 3,CMPLX                                CMPLX. 
      ABS A.2+B.2+C.2+D.CPX 
      ABS E.CPX+CMPLX 
      ABS E.ZPX+.ZMPX 
      ABS G.REA+H.CPX 
      ABS R.OPM+R.RTN+CMPLX 
      ABS G.RE8+H.ZPX 
      ABS R.OPM+R.RTN+.ZMPX 
* 
      DEF IOR1
IAND1 ASC 3,IAND                                 IAND.
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+%AND
      ABS E.DBI+%DAND 
      ABS G.INT+H.INT 
      OCT 100005
      ABS G.DBI+H.DBI 
      ABS R.REG+.DAND 
* 
      DEF IXOR1 
IOR1  ASC 3,IOR                                  IOR. 
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+%OR 
      ABS E.DBI+%DOR
      ABS G.INT+H.INT 
      OCT 100006
      ABS G.DBI+H.DBI 
      ABS R.REG+.DOR
* 
      DEF IEOR1 
IXOR1 ASC 3,IXOR                                 IXOR.
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+IXOR
      ABS E.DBI+%DXOR 
      ABS G.INT+H.INT 
      OCT 100007
      ABS G.DBI+H.DBI 
      ABS R.REG+.DXOR 
* 
      DEF NOT 
IEOR1 ASC 3,IEOR                                 IEOR.
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+IXOR
      ABS E.DBI+%DXOR 
      ABS G.INT+H.INT 
      OCT 100007
      ABS G.DBI+H.DBI 
      ABS R.REG+.DXOR 
* 
      DEF ISHFT 
NOT   ASC 3,NOT                                  NOT. 
      ABS A.1+B.2+C.2+D.INT 
      ABS E.INT+%OT 
      ABS E.DBI+%DNOT 
      ABS G.INT+H.INT 
      OCT 100010
      ABS G.DBI+H.DBI 
      OCT 100011
* 
      DEF ISSW1 
ISHFT ASC 3,ISHFT                                ISHFT. 
      ABS A.2+B.2+C.2+D.INT 
      ABS E.INT+%ISH
      ABS E.DBI+%JSH
      ABS G.INT+H.INT 
      OCT 100004
      ABS G.DBI+H.DBI 
      OCT 100004
* 
      DEF PCNT1 
ISSW1 ASC 3,ISSW                                 ISSW.
      ABS A.1+B.1+C.1+D.INT 
      ABS E.INT+%SSW
      ABS G.INT+H.INT 
      ABS R.REG+ISSW
* 
      DEF EXEC1 
PCNT1 ASC 3,PCOUNT                               PCOUNT.
.PCNT ABS A.0+B.0+C.2+D.INT 
      ABS H.INT 
      OCT 100012
      ABS H.DBI 
      OCT 100012
* 
      DEF DEXC1 
EXEC1 ASC 3,EXEC                                 EXEC.
      ABS S.1+A.VAR+B.2+C.2+D.REA 
      ABS E.DBI+EXEC
      ABS E.REA+EXEC
      ABS G.SUB+H.DBI 
      ABS R.OPM+R.RTN+EXEC
      ABS G.SUB+H.REA 
      ABS R.OPM+R.RTN+EXEC
* 
      DEF REIO1 
DEXC1 ASC 3,DEXEC                                DEXEC. 
      ABS S.1+A.VAR+B.2+C.2+D.REA 
      ABS E.DBI+DEXEC 
      ABS E.REA+DEXEC 
      ABS G.SUB+H.DBI 
      ABS R.OPM+R.RTN+DEXEC 
      ABS G.SUB+H.REA 
      ABS R.OPM+R.RTN+DEXEC 
* 
      DEF XLUE1 
REIO1 ASC 3,REIO                                 REIO.
      ABS S.1+A.VAR+B.2+C.2+D.REA 
      ABS E.DBI+REIO
      ABS E.REA+REIO
      ABS G.SUB+H.DBI 
      ABS R.OPM+R.RTN+REIO
      ABS G.SUB+H.REA 
      ABS R.OPM+R.RTN+REIO
* 
      DEF 0 
XLUE1 ASC 3,XLUEX                                XLUEX. 
      ABS S.1+A.VAR+B.2+C.2+D.REA 
      ABS E.DBI+XLUEX 
      ABS E.REA+XLUEX 
      ABS G.SUB+H.DBI 
      ABS R.OPM+R.RTN+XLUEX 
      ABS G.SUB+H.REA 
      ABS R.OPM+R.RTN+XLUEX 
* 
* 
*                   END OF INTRINSICS TABLE.
      SKP 
*                   ORDINALS IN DOT-FUNCTION TABLE. 
* 
EXEC  EQU 72
REIO  EQU 90
XLUEX EQU 91
* 
SQRT  EQU 102 
DSQRT EQU 103 
.SQRT EQU 104 
CSQRT EQU 105 
%QRT  EQU 106 
$SQRT EQU 107 
/SQRT EQU 108 
* 
SIN   EQU 109 
DSIN  EQU 110 
.SIN  EQU 111 
CSIN  EQU 112 
%IN   EQU 113 
/SIN  EQU 115 
#SIN  EQU 116 
* 
COS   EQU 117 
DCOS  EQU 118 
.COS  EQU 119 
CCOS  EQU 120 
%OS   EQU 121 
/COS  EQU 123 
#COS  EQU 124 
* 
TAN   EQU 125 
DTAN  EQU 126 
.TAN  EQU 127 
%AN   EQU 128 
$TAN  EQU 129 
/TAN  EQU 130 
* 
TANH  EQU 131 
DTANH EQU 132 
.TANH EQU 133 
%ANH  EQU 134 
* 
ATAN  EQU 135 
DATAN EQU 136 
.ATAN EQU 137 
%TAN  EQU 138 
* 
ATAN2 EQU 139 
DATN2 EQU 140 
.ATN2 EQU 141 
/ATN2 EQU 122 
* 
ALOG  EQU 142 
DLOG  EQU 143 
.LOG  EQU 144 
CLOG  EQU 145 
%LOG  EQU 146 
$LOG  EQU 147 
/LOG  EQU 148 
#LOG  EQU 149 
* 
ALOGT EQU 150 
DLOGT EQU 151 
.LOGT EQU 152 
%LOGT EQU 153 
$LOGT EQU 154 
/LOGT EQU 155 
* 
EXP   EQU 156 
DEXP  EQU 157 
.EXP  EQU 158 
CEXP  EQU 159 
%XP   EQU 160 
$EXP  EQU 161 
/EXP  EQU 162 
#EXP  EQU 163 
* 
DABS  EQU 164 
.ABS  EQU 165 
CABS  EQU 166 
%ABS  EQU 167 
%JABS EQU 168 
%BS   EQU 169 
* 
.DMOD EQU 170 
AMOD  EQU 171 
DMOD  EQU 172 
.MOD  EQU 173 
MOD   EQU 174 
%JMOD EQU 175 
* 
ISIGN EQU 176 
.JSGN EQU 177 
SIGN  EQU 178 
DSIGN EQU 179 
.SIGN EQU 180 
%IGN  EQU 181 
%JSGN EQU 182 
* 
IDIM  EQU 183 
.JDIM EQU 184 
DIM   EQU 185 
.XDIM EQU 186 
.DDIM EQU 187 
* 
MIN0  EQU 188 
.JMN0 EQU 189 
AMIN1 EQU 190 
DMIN1 EQU 191 
.MIN1 EQU 192 
* 
AMIN0 EQU 193 
.AMNJ EQU 194 
* 
MIN1  EQU 195 
.JMN1 EQU 196 
* 
MAX0  EQU 197 
.JMX0 EQU 198 
AMAX1 EQU 199 
DMAX1 EQU 200 
.MAX1 EQU 201 
* 
AMAX0 EQU 202 
.AMXJ EQU 203 
* 
MAX1  EQU 204 
.JMX1 EQU 205 
* 
AIMAG EQU 206 
CONJG EQU 207 
* 
AINT  EQU 208 
DDINT EQU 209 
.YINT EQU 210 
%INT  EQU 211 
* 
%FIX  EQU 220 
%FIXD EQU 221 
IDINT EQU 222 
%XFXD EQU 223 
%TFXS EQU 224 
%TFXD EQU 225 
* 
FLOAT EQU 226 
.FLTD EQU 227 
SNGL  EQU 228 
.NGL  EQU 229 
%LOAT EQU 231 
%FLTD EQU 232 
* 
DBLE  EQU 237 
.BLE  EQU 238 
* 
CMPLX EQU 241 
* 
%AND  EQU 242 
%DAND EQU 243 
.DAND EQU 244 
* 
%OR   EQU 245 
%DOR  EQU 246 
.DOR  EQU 247 
* 
IXOR  EQU 248 
%DXOR EQU 249 
.DXOR EQU 250 
* 
%OT   EQU 251 
%DNOT EQU 252 
* 
%ISH  EQU 256 
%JSH  EQU 257 
* 
%SSW  EQU 258 
ISSW  EQU 259 
* 
.SINH EQU 270 
%SINH EQU 271 
.COSH EQU 272 
%COSH EQU 273 
.ASIN EQU 274 
%ASIN EQU 275 
.ACOS EQU 276 
%ACOS EQU 277 
.ASNH EQU 278 
%ASNH EQU 279 
.ACSH EQU 280 
%ACSH EQU 281 
.ATNH EQU 282 
%ATNH EQU 283 
.CTAN EQU 284 
%CTAN EQU 285 
.DSNH EQU 286 
%DSNH EQU 287 
.DCSH EQU 288 
%DCSH EQU 289 
.DASN EQU 290 
%DASN EQU 291 
.DACS EQU 292 
%DACS EQU 293 
.DASH EQU 294 
.DACH EQU 296 
%DACH EQU 297 
.DATH EQU 298 
%DATH EQU 299 
* 
.ZMPX EQU 307 
.ZSQR EQU 317 
.ZSIN EQU 318 
%ZSIN EQU 319 
.ZCOS EQU 320 
%ZCOS EQU 321 
.ZTAN EQU 322 
%ZTAN EQU 323 
.ZLOG EQU 324 
%ZLOG EQU 325 
.ZEXP EQU 326 
%ZEXP EQU 327 
.ZABS EQU 328 
.ZAIM EQU 329 
.ZCJG EQU 330 
* 
.NINT EQU 331 
%NINT EQU 332 
.NJNT EQU 333 
%NJNT EQU 334 
.IDNT EQU 335 
%IDNT EQU 336 
.JDNT EQU 337 
%JDNT EQU 338 
.ANNT EQU 339 
%ANNT EQU 340 
.TNNT EQU 341 
%TNNT EQU 342 
* 
DEXEC EQU 343 
      SKP 
*         ***************** 
*         * SEGMENT ENTRY * 
*         ***************** 
      SPC 1 
*                   SET UP SOME INFO ABOUT THE 'Y' AND 'I' OPTIONS. 
* 
F4.2  LDA DEXIT     SET UP ERROR RECOVERY ADDRESS.
      STA F.ERX 
      LDB F.CCW     OPTIONS WORD. 
      LDA DBL       MODIFIES DBL=REAL*6 
      BLF,BLF       'Y' OPTION IS IN BIT 9=>1 
      RBR,SLB       =>0, IS IT SET ?
      LDA RE8       YES, DEFAULT IS RE8=REAL*8. 
      STA MDBL      MDBL=MODIFIED DBL.
      XOR DBL       COMPUTE THE OTHER ONE.
      XOR RE8 
      STA ODBL      ODBL=NON-DEFAULT OF THE TWO.
* 
      LDA INT       'J' CHANGES INT=INTEGER*2 
      LDB F.CCW     WELL ?
      BLF,SLB       BIT 12=>0, IS OPTION SET ?
      LDA DBI       YES, DEFAULT TO DBI=INTEGER*4.
      STA MINT      MINT=MODIFIED INT.
      XOR INT       COMPUTE OTHER ONE.
      XOR DBI 
      STA OINT      OINT=NON-DEFAULT OF THE TWO.
* 
      LDA F.CCW     CONSTRUCT IJXY FIELD FOR REQ'D I/J. 
      RRR 12
      AND K1        I=0, J=1. 
      IOR K2        + SELECTION BITS. 
      STA JOPT
* 
      LDA F.CCW     DITTO, X/Y. 
      RRR 9 
      AND K1
      IOR K4
      STA YOPT
* 
*                   SCAN SYMBOL TABLE FOR EXTERNAL SUBROUTINES. 
* 
      LDA DISP1     SET UP LOCAL ERROR RECOVERY.
      STA F.EQE 
      JSB GFA.F     SET UP F.A, DUMMY LIST HEAD.
ISP01 JSB GNA.F     GET NEXT ITEM.
      SZA,RSS       DONE ?
      JMP IMP01     YES. GO DO 'IMPLICIT NONE' CHECKING.
* 
      CPA F.SBF     CURRENT MODULE ?
      JMP ISP01     YES. SKIP.
* 
      LDA F.A,I     GET F.AT & F.IU . 
      AND B7600 
      CPA B2200     IS F.AT=STRAB & F.IU=SUB ?
      JMP ISP04     YES.
      JMP ISP01     NO. NOT AN EXTERNAL SUBROUTINE. 
      SKP 
*                   GOT ONE. SEARCH INTRINSICS TABLE FOR IT.
* 
ISP04 JSB NAM.F     YES. EXTRACT ITS NAME.
      DEF NAME
      LDA DIFTB     SET UP LOOP.
ISP05 STA T1ISP     T1ISP = INTRINSICS TABLE POINTER. 
      LDB A,I       (B) = CHARS 1,2.
      CPB NAME      1&2 SAME ?
      RSS           YES.
      JMP ISP06     NO. WRONG ONE.
* 
      INA 
      DLD A,I       CHARS 3,4,5,6.
      CPA NAME+1    3&4 SAME ?
      RSS           YES.
      JMP ISP06     NO. WRONG ONE.
* 
      CPB NAME+2    5&6 SAME ?
      JMP ISP10     YES. MATCH. 
* 
ISP06 CCA           NO. SKIP THIS ENTRY.
      ADA T1ISP     GET ADDR OF NEXT. 
      LDA A,I 
      SZA,RSS       MORE ?
      JMP ISP01     NO. NOT INTRINSIC.
      JMP ISP05     YES. GO CHECK IT OUT. 
* 
DEXIT DEF EXIT      SEGMENT ERROR RECOVERY ADDR.
DISP1 DEF ISP01     LOCAL ERROR RECOVERY ADDR.
NAME  BSS 3         NAME FROM SYMBOL TABLE. 
DIFTB DEF IFTBL     ADDR OF FIRST ENTRY.
T1ISP NOP           ADDR OF CURRENT ENTRY.
T2ISP NOP           GENERAL COUNTER.ENTRY.
T3ISP NOP           GENERAL POINTER.ENTRY.
T4ISP NOP           POINTER SIZE BUILT TABLE. 
B7600 OCT 7600
B2200 OCT 2200
MDBL  NOP           MODIFIED 'DBL'. 
ODBL  NOP           OTHER ONE.
MINT  NOP           MODIFIED 'INT'. 
OINT  NOP           OTHER ONE.
JOPT  NOP           MATCHING REQ'D 'J' OPTION BITS. 
YOPT  NOP           MATCHING REQ'D 'Y' OPTION BITS. 
B10K  OCT 010000
INT   EQU B10K
DBI   OCT 100000
DBL   OCT 060000
RE8   OCT 120000
K1    DEC 1 
K2    DEC 2 
K4    DEC 4 
K7    DEC 7 
      SKP 
*                   GOT AN INTRINSIC.  PROCESS IT.
*                   FIRST, SET UP ITS TYPE. 
* 
ISP10 ISZ T1ISP     SKIP OVER THE NAME. 
      ISZ T1ISP 
      ISZ T1ISP 
      JSB FA.F      FETCH SYMBOL ASSIGNS. 
      LDA F..E      EXPLICITLY TYPED ?
      SZA 
      JMP ISP11     YES. LEAVE IT.
* 
      LDA T1ISP,I   NO. GET THE TYPE. 
      AND B17 
      ALF,ALF       POSITION IT.
      ALF 
      CPA DBL       IF DBL, 
      LDA MDBL      MAY CHANGE TO RE8.
      CPA INT       IF INT, 
      LDA MINT      MAY CHANGE TO DBI.
      JSB DIM.F     CHANGE F.IM TO DEFAULT TYPE.
* 
*                   IF SUBROUTINE, USE FIRST EXTERNAL NAME. 
* 
ISP11 LDA F.S       USED AS SUB ? 
      SZA,RSS 
      JMP ISP12     NO. 
* 
      STA T4ISP     YES. (TABLE = 1 WORD) 
      DLD T1ISP,I   IS THAT ALLOWED ? 
      RAL 
      SSA,RSS 
      JMP ISP01     NO. THEN NOT AN INTRINSIC.
* 
      LSL 7         YES. GET THE DOT ORDINAL. 
      LSR 7         (B) = DOT ORDINAL.
      JMP ISP27     GO INSERT IN TABLE & PROCEED. 
      SKP 
*                   DETERMINE THE EXTERNAL NAME.  IF CAN'T FIND TYPE, 
*                   AND EXPLICITLY RETYPED, THEN NOT INTRINSIC. 
* 
ISP12 LDA T1ISP,I   GET THE NUMBER OF THEM. 
      AND B7400 
      ALF,ALF 
      STA T4ISP     SAVE THAT.
      CMA,INA       T2ISP = COUNTER.
      STA T2ISP 
      LDA T1ISP     T3ISP = POINTER.
      STA T3ISP 
ISP13 ISZ T3ISP     NEXT CANDIDATE..
      LDA T3ISP,I 
      ALF,RAR       GET ITS TYPE. 
      AND B170K 
      CPA F.IM      MATCH ? 
      RSS           YES.
      JMP ISP14     NO. GO CHECK NEXT.
* 
      LDA T3ISP,I   YES. CHECK OUT I/J & X/Y STUFF. 
      ALF,RAR       TO BITS 2:0 
      AND K7        THE FLAG BITS.
      SZA           IF NO OPTION REQUIRED,
      CPA JOPT      OR IF ITS 'J' & CORRECT ? 
      RSS           YES.
      CPA YOPT      OR 'Y' AND CORRECT ?
      JMP ISP15     YES. MATCH COMPLETE.
* 
ISP14 ISZ T2ISP     NO. BUMP COUNTER. 
      JMP ISP13     IF MORE.
* 
      LDA F..E      NOT FOUND. WAS IT EXPLICITLY TYPED ?
      SZA 
      JMP ISP01     YES. THEN NOT AN INTRINSIC. 
      JMP ISP17     NO. JUST A GENERIC WITH NO SPECIFICS. 
* 
ISP15 LDA T3ISP,I   FOUND. SET INTO TABLE.
      AND B777
ISP17 STA TABLE     BITS <8:0> OF FIRST WORD. 
      SKP 
*                   COPY EACH SPECIFIC NAME INTO TABLE, UNLESS: 
*                     1) EXPLICIT TYPING & DOESN'T MATCH, OR
*                     2) FCT TYPE # ARG TYPE AND FCT TYPE IS
*                        NOT DEFAULT FOR 'Y' OR 'J' OPTIONS.
* 
      LDA T1ISP,I   GET THE NUMBER OF SPECIFIC NAMES. 
      AND B360
      ALF,ALF 
      ALF 
      CMA,INA       T2ISP = COUNTER.
      STA T2ISP 
      LDA T1ISP     COMPUTE ADDR OF FIRST ONE.
      ADA T4ISP     SKIP TO LAST EXTERNAL ENTRY.
      STA T3ISP     T3ISP = POINTER (BUMP ONE FIRST). 
      LDA DTBL1     SET POINTER TO TABLE. 
      STA T4ISP 
ISP20 ISZ T3ISP     ON TO NEXT ENTRY... 
      LDA T3ISP,I   GET THE FUNCTION TYPE.
      AND B17 
      ALF,ALF       ALIGN IT. 
      ALF 
      LDB F..E      FUNCTION IS EXPLICITLY TYPED ?
      SZB,RSS 
      JMP ISP22     NO. 
* 
      CPA F.IM      YES. IS IT RIGHT TYPE ? 
      JMP ISP24     YES.  COPY IT.
      JMP ISP26     NO. SKIP IT.
* 
ISP22 LDB A         NOT EXPL. TYPED.  FCT TYPE = ARG TYPE ? 
      LDA T3ISP,I   GET ARG TYPE. 
      ALF,ALF 
      AND B170K 
      CPA B         WELL ?
      JMP ISP24     SAME. HAVE TO KEEP IT.
* 
      CPB ODBL      DIFFERENT.  IS IT A NON-DEFAULT TYPE ?
      RSS           YES.
      CPB OINT
      JMP ISP26     YES. SKIP IT. 
* 
ISP24 DLD T3ISP,I   COPY ENTRY TO TABLE.
      DST T4ISP,I 
      ISZ T4ISP 
      ISZ T4ISP 
ISP26 ISZ T3ISP     ADVANCE TO NEXT ENTRY. (OTHER ISZ AT TOP) 
      ISZ T2ISP     DONE ?
      JMP ISP20     NO. LOOK FOR MORE.
      SKP 
*                   FINISH BUILDING TABLE.
* 
      LDB DTBL1     COMPUTE NUMBER OF SPECIFIC NAMES. 
      CMB,INB 
      ADB T4ISP     (LWA+1) - FWA = COUNT*2 
      STB T4ISP     T4ISP = (TABLE SIZE)-1. 
      BLF,BLF       PUT IN BITS <12:9>, FIRST WORD. 
      ADB TABLE 
ISP27 LDA T1ISP,I   GET # PARAMS & S-BIT. 
      AND B70K      WERE IN BITS <14:12>, 
      RAL           PUT IN BITS <15:13>, FIRST WORD.
      IOR B 
      STA TABLE 
      ISZ T4ISP     T4ISP = # WORDS IN TABLE. 
* 
*                   ALLOCATE SPACE IN A.T. AREA FOR THE TABLE,
*                   AND COPY IT THERE.  SET F.AF=TABLE ADDR,  F.NC=1. 
* 
      LDB T4ISP     ALLOCATE SPACE. 
      JSB AST.F 
      STB T3ISP     SAVE ITS ADDR.
      LDA DTABL     COPY TABLE. 
      JSB .MVW
      DEF T4ISP 
      NOP 
      LDA T3ISP     SET F.AF OF SYMBOL TO TABLE ADDR. 
      JSB DAF.F 
      LDA F.A,I     SET F.NC=1. 
      IOR B40 
      STA F.A,I 
      LDA T1ISP     IS THIS 'PCOUNT' ?
      CPA DPCNT 
      RSS           (YES) 
      JMP ISP01     NO. DONE WITH THIS SYMBOL.
* 
      LDA F.A       YES. ALLOCATE TEMP FOR ENTRY. 
      STA T1ISP     BUT FIRST, SAVE F.A . 
      LDA INT       ALLOCATE THE TEMP.
      JSB APT.F 
      STA F.PCT 
      LDA T1ISP     RESTORE F.A 
      STA F.A 
      JMP ISP01     NOW DONE. 
* 
B17   OCT 17
B40   OCT 40
B777  OCT 777 
B360  OCT 360 
B7400 OCT 7400
B70K  OCT 70000 
B170K OCT 170000
DPCNT DEF .PCNT     USED TO CHECK FOR PCOUNT. 
DTABL DEF TABLE 
DTBL1 DEF TABLE+1 
TABLE BSS 15        MAX 7 SPECIFIC AT A TIME. 
K6    DEC 6 
B10   OCT 10
      SKP 
*         ***************** 
*         * IMPLICIT NONE * 
*         ***************** 
      SPC 1 
*     THE CHECKING FOR 'IMPLICIT NONE' SCANS THE NAMED PART OF THE
*     SYMBOL TABLE, AND COMPLAINS ABOUT SYMBOLS WHICH:
* 
*       1) ARE NORMAL NAMED VARIABLES, ARRAYS, OR SUBPROGRAMS.
*       2) ARE NOT INTRINSIC. 
*       3) ARE NOT SUBROUTINES. 
*       4) ARE NOT EXPLICITLY TYPED.
* 
*                   START SYMBOL TABLE SCAN.
* 
IMP01 LDA F.IMF     IMPLICIT NONE ? 
      SSA,RSS 
      JMP EXIT      NO. DON'T BOTHER. 
* 
      CCA           YES. CLEAR THE MESSAGE FLAG.
      STA T1IMP 
      JSB GFA.F     SET UP SCAN.
IMP02 JSB GNA.F     GET NEXT ITEM.
      SZA,RSS       DONE ?
      JMP EXIT      YES. GO EXIT. 
* 
      LDA F.A,I     EXPLICITLY TYPED ?
      AND B10       (IF NOT PROPER TYPE OF ENTRY, 
      SZA            THIS CHECK DOESN'T HURT.)
      JMP IMP02     YES. SKIP IT. 
* 
      LDB F.A       NO. SEE IF TEMP OR STMT #.
      ADB K2
      LDA B,I       FIRST WORD OF NAME. 
      SSA           TEMP ?
      JMP IMP02     YES. SKIP IT. 
* 
      AND BM400     NO. GET FIRST CHAR. 
      CPA B40K      IS IT @ ? 
      JMP IMP02     YES. STMT #, SKIP IT. 
* 
      LDA F.A       NO. NAME OF THIS MODULE ? 
      LDB F.SFF     AND IT'S A SUBROUTINE ? 
      CPA F.SBF 
      SZB 
      RSS           (NO. ERROR) 
      JMP IMP02     YES. SKIP IT. 
* 
      LDA F.A,I     NO.  GET USAGE. 
      AND B600
      CPA SUB       IF SUBROUTINE,
      RSS           MUST CHECK FURTHER. 
      JMP IMP10     NO. UNTYPED VARIABLE/ARRAY! 
      SKP 
*                   F.IU=SUB. CHECK COMMON BLOCK, SUBROUTINE, INTRINSIC.
* 
      LDA F.A,I     GET F.AT
      AND B7000 
      CPA BCOMI     COMMON LABEL ?  (F.AT=BCOMI)
      JMP IMP02     YES. SKIP IT. 
* 
      LDA F.A,I     SUBROUTINE OR FUNCTION ?
      AND B20 
      SZA,RSS 
      JMP IMP02     SUBROUTINE (OR EXTERNAL ONLY), SKIP.
* 
      LDA F.A,I     GET F.NC
      AND B140
      CPA B40       INTRINSIC ? 
      JMP IMP02     YES. SKIP IT. 
* 
*                   UNTYPED NAME. COMPLAIN. 
* 
IMP10 LDA K87       WARNING 87. 
      ISZ T1IMP     HAVE WE PUT OUT THE MESSAGE YET ? 
      RSS           YES. NOT AGAIN. 
      JSB WAR.F     NO. PUT IT OUT. 
* 
      JSB NAM.F     COPY THE ITEM NAME. 
      DEF IMMSG+1   TO HERE.
      LDA K4        PRINT MESSAGE: 4 WORDS, 
      LDB DIMSG     FROM HERE.
      JSB PCC.F     DO IT.
      JMP IMP02     GO FOR MORE.
* 
T1IMP NOP           INDICATOR WHETHER MSG DONE YET. 
B20   OCT 20
B140  OCT 140 
SUB   OCT 200       F.IU=SUB
B600  OCT 600       F.IU MASK.
B7000 OCT 7000      F.AT MASK.
BCOMI EQU B7000     F.AT=BCOMI
B40K  BYT 100,0     '@',0 
BM400 OCT 177400
K87   DEC 87
DIMSG DEF IMMSG     ADDR OF MESSAGE.
IMMSG ASC 4,        MESSAGE BUFFER. 
      SPC 2 
*                   SEGMENT EXIT. 
* 
EXIT  CLA           CLEAR OUT THE LOCAL ERROR RECOVERY. 
      STA F.EQE 
      CCA           WRITE (-1) TO END PASS FILE.
      JSB WS1.F 
      JSB ES1.F     FLUSH LAST PASS FILE RECORD.
      JSB EOF.C     WRITE EOF ON 1ST PASS FILE. 
      DEF C.SC1 
      JMP PASER 
* 
      JSB RWN.C     REWIND 1ST PASS FILE. 
      DEF C.SC1 
      JMP PASER 
* 
      JSB RWN.C     REWIND CARD FILE: 
      DEF C.SC0     IT BECOMES 2ND PASS FILE. 
      JMP PASER 
* 
      LDB K6        GO TO SEGMENT 6.
      JMP F.SEG 
* 
PASER LDA K99       ACCESS ERROR ON SCRATCH FILE. 
      JMP F.ABT 
* 
K99   DEC 99
* 
      END F4.2
                                                                                                                                                                    