ASMB,Q,C
      HED ** 16K FTN4 COMPILER (SEG: F4.0) SPECIFICATION STATEMENTS **
      NAM F4.0,5 92060-16094 REV.2026 800423
* 
***************************************** 
*     FORTRAN-4 COMPILER OVERLAY 0
***************************************** 
* 
*     THIS OVERLAY PROCESSES COMMON, DIMENSION, AND 
*  EQUIVALENCE STATEMENTS, PROGRAM AND DATA STATEMENTS, 
*  AND TYPE DECLARATIONS. 
* 
*************************************************************** 
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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:   F4.0, PART OF FTN4 COMPILER.                    * 
*     SOURCE: 92060-18094                                     * 
*     RELOC:  92060-16094                                     * 
*     PGMR:   BILL GIBBONS.                                   * 
*************************************************************** 
* 
*     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..DP    BASE OF SYMBOL TABLE
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE EXTRY 
   EXT     F.AF     ADDRESS FIELD CURREXT F.A 
       EXT F.ARF    NO. OF SUB. FUN. ARGUMEXTS
   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.CIN    CURREXT CI BUFFER LINE NUMBER 
     EXT   F.CLN    INPUT ITEM CURREXT LINE # 
       EXT F.CSZ    COMMON SIZE 
       EXT F.D      DO TABLE POINTER
   EXT     F.D0     ARRAY ELEMEXT SIZE
   EXT     F.D1     DIMENSION 1 
   EXT     F.D2     DIMENSION 2 
   EXT     F.DCF    DIM, COM FLAG 
       EXT F.DEF    DATA EXISTS FLAG
      EXT  F.DID    ADDRESS OF F.IDI
       EXT F.DNB    DEF OF NBUF (NAM RECORD)
   EXT     F.DNI    ADDRESS OF NID
       EXT F.DO     LWAM - END OF DO TABLE
   EXT     F.DP     BASE OF USER SYMBOL TABLE 
      EXT  F.DTY    IMPLICIT TYPE TABLE 
      EXT  F.E      EQUIVALENCE TABLE POINTER 
   EXT     F.EFG    E - FLAG - SET IF SUBSCRIPT IS DUMMY
       EXT F.EMA    F.A OF EMA EXT ENTRY, WINDOW SIZE 
       EXT F.EMS    EMA SIZE  DOUBLE WORD, (INTERNAL FORMAT)
     EXT   F.EQE    EQUVALENCE ERROR FLAG 
       EXT F.EQF    EQUIVALENCE FLAG
   EXT     F.EXF    EXTERNAL STATEMEXT FLAG 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
       EXT F.INT    TEMP VARIABLE ARRAY 
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.L      # WORDS ON STACK 2
      EXT  F.LLT    ADDRESS OF LINE LOCATION TABLE (SET BY INIT)
       EXT F.LO     END OF ASSIGNMEXT TABLE+1 
     EXT   F.LPR    ( LOC OF EQUIVALENCE GROUP
       EXT F.LSF    EXPECT FIRST STATEMEXT FLAG 
       EXT F.MFL    TYPE STMT. MODE FLAG
   EXT     F.ND     NUMBER OF DIMENSIONS
       EXT F.NEQ    # OF EQUIVALENCE GROUPS 
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
   EXT     F.NW     NO. WORDS THIS TABLE F.A EXTRY. 
     EXT   F.OFE    DATA POOL OVERFLOW ERROR EXTRY. 
       EXT F.OPF    OUTPUT PACK FLAG
      EXT  F.PAK    PACK BUFFER WORD
       EXT F.RPL    PROGRAM LOCATION COUNTER
     EXT   F.RPR    ) LOC OF EQUIVALENCE GROUP
       EXT F.S02    RETURN FORM RCOM  F.1 
       EXT F.S03    LOAD F.1 AND PASS CONTROL 
       EXT F.S1T    TOP    OF STACK 1 
   EXT     F.S2B    BOTTOM OF STACK 2 
       EXT F.S2T    TOP    OF STACK 2 
       EXT F.SBF    0= MAIN, ELSE SUBROUTINE
       EXT F.SCC    SAVE F.CC 
       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'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
       EXT AA.F     ASSIGN ADDRESS SUB. 
   EXT     AI.F     ASSIGN ITEM 
   EXT     BNI.F    CLEAR NID TO BLANKS 
     EXT   CRP.F    CROSS REF PAIR SUB. 
       EXT CRT.F    TEST FOR CARRAGE RETURN 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DAT.F    DEFINE (AT) 
   EXT     DIM.F    DEFIND (F.IM) 
   EXT     DIU.F    DEFINE (F.IU) 
     EXT   ER.F     ERROR PRINT SUBROUTINE
   EXT     ESC.F    ESTABLISH CONSTANT SUBROUTINE 
     EXT   EXN.F    EXAMINE NEXT CHARACTER
   EXT     FA.F     FETCH ASSIGNS 
    EXT    FXC.F    CHECK IF SUB. IN FIX-EXT TABLE
   EXT     GNA.F    GET NEXT SYMBOL TABLE EXTRY 
     EXT   IC.F     GET NEXT CHARACTER
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
      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   MPN.F    MOVE PROGRAM NAME (TO NAM RECORD ECT.)
   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       OAI.F    OUTPUT ABS. INSTRUCTION 
 EXT       OC.F     OUTPUT CONSTANT 
 EXT       OLR.F    OUTPUT LOAD ADDRESS 
 EXT       OW.F     OUTPUT WORD 
      EXT  PAK.F    PACK SUBROUTINE 
      EXT  RP.F     INPUT ')' 
       EXT SCC.F    SAVE F.CC SUBROUTINE
   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) 
* 
* 
      ENT F.COM 
      ENT F.CPX 
      ENT F.DAT 
      ENT F.DBL 
      ENT F.DIM 
      ENT F.EMP 
      ENT F.EQU 
      ENT F.EXT 
      ENT F.FUN 
      ENT F.IMP     IMPLICIT PROCESSOR
      ENT F.INP 
      ENT F.LOG 
      ENT F.PRO 
      ENT F.RCO 
      ENT F.REA 
      ENT F.SUB 
      ENT F.BLK 
      SPC 1 
* 
* 
* 
* 
* 
*     COMPILER LIB. ROUTINES
* 
      EXT GMS.C     GET SEGMENT FREE MEMORY BOUNDS
* 
* 
*     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 F.DNB 
      ADA K9
      STA PROK1 
      LDA F.SLF     IF BACK IN TO DO
      CPA K2        A DATA STATEMENT
      JMP F.DAT     JUST GO DO IT 
* 
      LDA F..DP     SET UP TO MOVE THE
      ADA KM98      ADJUST FOR CARD BUFFER
      STA FL.F      SAVE IT FOR A WHILE 
      CMA,INA       SYMBOL TABLE DOWN TO
      ADA F.LO      ITS FINAL RESTING PLACE 
      STA F4.0      SAVE ITS CURRENT SIZE 
      LDA FL.F      CURRENT LOCATION TO A 
      LDB F.IDI     FINAL LOCATION FROM F4.4 TO B 
      ADB KM98      ADJUST FOR CARD BUFFER
      STB FL.F      SAVE IT 
      JSB .MVW      DO MOVE WORDS 
      DEF F4.0      NUMBER OF WORDS 
      NOP 
      LDA F..DP     NOW COMPUTE 
      CMA,INA       THE DISTANCE
      ADA F.IDI     MOVED 
      LDB F..DP     AND ADJUST
      ADB A         THE POINTERS
      STB F..DP     FOR THE NEW LOCATION
      LDB F.LO
      ADB A 
      STB F.LO
      STB F.S2B 
      STB F.S2T     STACK POINTERS TOO
      ADA F.DP      ADJUST USER ORGIN ALSO
      STA F.DP      DONE SO CONTINUE WITH REAL WORD 
      CCA,CLE       NOW TELL
      LDB FL.F      WHERE THE CARD BUFFER IS
      JSB IN6.F     TO THE ONE WHO MUST KNOW
* 
      JSB GMS.C     GET START OF FREE MEMORY
      STA F.LLT     AND SET FOR EQU X-REF.
      JMP F.BGN     BACK TO READ THE FIRST CARD 
      SPC 1 
K9    DEC 9 
KM98  DEC -98 
PROK1 NOP           PROGRAM TYPE CODE POINTER 
      SPC 2 
*         **************
*         * FETCH LINK *
*         **************
      SPC 1 
FL.F  NOP 
      STB F.A 
      LDA B,I 
      AND KK04
      CPA ARR 
      INB,RSS       IU(F.A)=ARR 
      RSS 
      LDB B,I       (B)=GF(F.A) 
      XOR F.A,I     GET THE 
      AND B7000     AT FIELD
      CPA BCOM      IF A BLOCK COMMON 
      INB,RSS       ELEMENT 
      RSS           INDEX ONE 
      LDB B,I       MORE LEVEL
      INB 
      LDA B,I 
      STA NXL       NXL=GF(B) 
      JMP FL.F,I
      SPC 1 
NXL   BSS 1         NEXT LINK LOCATION
KK04  OCT 600       EXTRACT F.IU FIELD
B7000 OCT 7000      EXTRACT F.AT FIELD. 
      SKP 
*         ************
*         * EXTERNAL *
*         ************
      SPC 1 
F.EXT CLA,INA 
      STA F.EXF     SET EXT FLAG
      JSB INM.F     INPUT NAME
      LDB F.AT      DUMMY ? 
      CPB DUM 
      RSS 
      JMP EXT01     NO. 
      LDA F.AF,I    EMA DUMMY ? 
      AND B7000 
      LDB A 
      LDA K22 
      CPB BCOMI 
      JSB ER.F      YES, ERROR 22.
EXT01 JSB TS.F      TAG SUBPROGRAM
      SPC 1 
*         ***************** 
*         * , OR C/R TEST * 
*         ***************** 
      SPC 1 
CCRT  CLB 
      STB F.LSF     CLEAR THE EXPECT FIRST STMT. FLAG 
      STB F.EFG     CLEAR E FLAG
      LDA F.TC
      CPA B54       ',' ? 
      JMP F.SPS,I   YES. MORE TO PROCESS
* 
      CPA B57       IF A '/'
      JMP CCRT1     GO TEST IF COMMON STMT. 
* 
CCRT0 STB F.EXF     CLEAR EXTERNAL FLAG 
      JMP CRT.F     C/R TEST
      SPC 1 
CCRT1 LDB F.SPS     GET COMMON FLAG 
      CPB COMK1     IF COMMON 
      JMP COM04     GO PROCESS NEW LABEL
* 
      JMP CCRT0     ELSE IT IS AN ERROR 
* 
K22   DEC 22
B54   OCT 54
      SPC 2 
*         ******************
*         * EXCHANGE LINKS *
*         ******************
      SPC 1 
*     EXCHANGE AF(F.A) & AF(F)
      SPC 1 
EL.F  NOP 
      LDA F.A 
      STA T1EL
      LDB F         OLD LINK ADDRESS TO B 
      JSB FL.F      FETCH LINK
      STB T1LF      LINK FIELD
      LDB T1EL      SWAP POINTERS 
      STA T1EL
      JSB FL.F      FETCH LINK
      STA T1LF,I    SET CURRENT IN OLD
      LDA T1EL      AND OLD IN
      STA B,I       CURRENT 
      JMP EL.F,I
      SPC 1 
T1EL  BSS 1 
T1LF  BSS 1 
F     BSS 1         OLD LINK
      SPC 2 
*     ************
*     * IMPLICIT *
*     ************
* 
F.IMP JSB ICH.F      GET THE TYPE FOLLOWING THE 'IMPLICIT'
      LDB KM5       FIVE POSIBILITIES 
      STB T0IMP     SET THE COUNTER 
      LDB DTBL      GET THE TABLE ADDRESS 
IMP01 CPA B,I       THIS THE TYPE?
      JMP IMP02     YOU BETCHA  GO DO IT
* 
      INB           NOPE  STEP THE ADDRESS
      ISZ T0IMP     END OF LIST?
      JMP IMP01     NOPE  TRY NEXT ENTRY
* 
      LDA K10       YES  YOU RUMMY WE DON'T HAVE THIS TYPE
      JSB ER.F      B-Y-E 
* 
KM5   DEC -5
B55   OCT 55
* 
IMP02 ADB K5        INDEX INTO THE DEF TABLE
      LDB B,I       GET ADDRESS OF THE STRING 
      STB T0IMP     AND SAVE IT 
      LDA B,I       GET THE STRING LENGTH 
      AND B377      ISOLATE THE LENGTH
      STB T1IMP     SAVE THE ADDRESS
      CMA,INA       SET COUNT NEGATIVE
      STA T2IMP     AND SAVE IT TOO 
IMP1  JSB ICH.F     BEGIN THE SPELLING TEST 
      ALF,ALF       MOVE TO HIGH END AND SAVE 
      STA T3IMP     IT
      JSB ICH.F     GET THE NEXT CHAR 
      IOR T3IMP     MIRGE WITH THE OTHER
      ISZ T1IMP     STEP THE STRING ADDRESS 
      CPA T1IMP,I   IS THIS THE RIGHT CHAR? 
      JMP IMP2      YES STEP THE POINTERS 
* 
      LDA K10       NO- SEND SPELLING ERROR MESSAGE 
      JSB ER.F      B-Y-E 
* 
IMP2  ISZ T2IMP     STEP THE COUNT
      JMP IMP1      MORE TO DO   AROUND WE GO 
* 
      LDA F.TC      THE TEST IS OK SO FAR 
      CPA B50       "(" IF LAST CHAR WAS '('
      RSS           SKIP READING IT 
      JSB ICH.F     NOPE  READ THE '('
      CPA B50       IS IT?
      JMP IMP03     YES  ALL OK 
* 
      LDA K9        UNEXPECTED CHAR 
      JSB ER.F      TOO BAD 
* 
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 
* 
      JSB ICH.F     GET THE NEXT CHAR 
      CPA B55       '-'  IF '-' THEN PART OF RANGE
      JMP IMP05     SO GO SET UP
* 
      CCA           ELSE ASSUME SIMPLE CHAR 
      STA T2IMP     SET COUNT TO 1
* 
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 T0IMP,I   GET THE NEW TYPE
      AND B377      KEEP THE OLD LOW ORDER BYTE 
      XOR T0IMP,I   RULES OF WOO  CHAR REPLACE
      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 
      SSB           CHAR
      JSB WAR.F 
* 
      ISZ T1IMP     STEP TO THE NEXT CHAR 
      ISZ T2IMP     STEP THE COUNT (DONE?)
      JMP IMP04     N0 - DO NEXT CHAR 
* 
      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 
* 
IMP05 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.
      JMP IMP04     AND GO DO IT. 
* 
* 
DTBL  DEF TYTBL     ADDRES OF THE TYPE SPEC TABLE 
T0IMP NOP 
T1IMP NOP 
T2IMP NOP 
T3IMP NOP 
BM101 OCT -101
K10   DEC  10 
      SPC 2 
*         ******* 
*         * EMA * 
*         ******* 
      SPC 1 
F.EMP CLA,INA       SET DIMENSION FLAG. 
      STA F.DCF 
      JSB INM.F     INPUT NAME. 
      LDA F.IU      USAGE ALREADY ARRAY ? 
      CPA ARR 
      RSS           YES. LEAVE IT.
      JSB TV.F      NO. FORCE TO VARIABLE.
      LDA F.AT      VERIFY A DUMMY
      CPA DUM 
      RSS 
      JMP EMP2      NO, ERROR 
      LDA F.AF,I    LINK TO BCOM OR NEXT DUMMY
      AND B7000 
      CPA BCOMI     PREVIOUSLY DECLARED ? 
      JMP EMP1      YES, ERROR. 
      LDA F.A       SAVE F.A & SET UP FOR EL.F
      STA F 
      LDA K2        BUILD BCOMI ENTRY 
      JSB DDE.F 
      LDA F.EMA     LINK TO EMA MASTER ENTRY
      LDB F.A 
      ADB K2
      STA B,I 
      JSB EL.F      INSERT BCOMI ENTRY
      LDA BCOMI     SET F.AT TO BCOMI 
      JSB DAT.F 
      LDA F         RESTORE F.A 
      STA F.A 
      JSB FA.F      RESTORE A.T. STUFF
EMP1  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
      JMP EMP1      SKIP DIM INFO.
* 
K94   DEC 94
      SKP 
*         *********************************** 
*         * 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
      SPC 1 
*         *********** 
*         * INTEGER * 
*         *********** 
      SPC 1 
F.INP LDA INT 
      JMP TYP02 
      SPC 1 
INT   OCT 10000     F.IM=1, INTEGER 
      SPC 1 
*         ********
*         * REAL *
*         ********
      SPC 1 
F.REA LDA REA 
      JMP TYP02 
      SPC 1 
REA   OCT 20000     F.IM=2, REAL
      SPC 1 
*         ********************
*         * DOUBLE PRECISION *
*         ********************
      SPC 1 
F.DBL LDA DBL 
      JMP TYP02 
      SPC 1 
DBL   OCT 60000     F.IM=6, DOUBLE PRECISION
      SKP 
*         *********** 
*         * COMPLEX * 
*         *********** 
      SPC 1 
F.CPX LDA KKCPX 
      JMP TYP02 
      SPC 1 
KKCPX OCT 50000     F.IM=CPX
LOG   OCT 30000     F.IM=3, LOGICAL 
      SPC 1 
*         *********** 
*         * LOGICAL * 
*         *********** 
      SPC 1 
F.LOG LDA LOG 
TYP02 STA F.MFL     F.MFL SET TO THE MODE TYPED 
      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 LDB F.A       CHECK IF IN FIX.EXT TBL 
      CMB,INB       IF SO 
      ADB F.DP      CAN NOT USE THE E-BIT TEST
      LDA F.MFL     GET TYPE IN CASE IT IS
      SSB,RSS       WELL? 
      JMP TYP04     YES FIX.EXT SYMBOL  DON'T USE E-BIT 
* 
      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
TYP04 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.EFG     CLEAR E FLAG IN CASE
      STA F.TYP     RESET TYPE FLAG TO INPUT DIMENSION. 
      JSB IDC.F     INPUT DIMENSION IF THERE. 
      JMP CCRT
      SPC 1 
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 F.FUN 
* 
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 K18 
      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 
VAR   OCT 400       F.IU=2, VARIABLE OR CONSTANT
STRAB OCT 2000      F.AT=2, STR-ABS - UNDEFINED 
TYP.A NOP           SAVE F.A
K83   DEC 83
K17   DEC 17
K18   DEC 18
B117  OCT 117       'O' 
"N"   OCT 116 
"FU"  ASC 1,FU
"NC"  ASC 1,NC
"TI"  ASC 1,TI
K28   DEC 28
      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.AF
      STA T1DIM     T1=AF 
      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 
      LDA F.DID     COMPUTE ADDRESS OF
      ADA K2        THIRD DIM 
      LDB S3        AND 
      STB A,I       IN F.IDI+2
      LDA S1        NOW 
      LDB S2        STORE THE 
      DST F.IDI     THE OTHER TWO DIMS
      LDA NS        NO. OF SUBSCRIPTS 
      JSB DDE.F     DEFINE THE DIMENSION ENTRY
      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 
T0DIM BSS 1         SET T0 0(DUMMY) OR -1 
T1DIM BSS 1         SAVE F.AF 
T2DIM BSS 1         SAVE F
K54   DEC 54
NS    BSS 1         NUMBER OF SUBSCRIPTS
S3    BSS 1         SUBSCRIPT NUMBER 3 .. 
S2    BSS 1         SUBSCRIPT NUMBER 2  . S TABLE 
S1    BSS 1         SUBSCRIPT NUMBER 1 ..!!DO NOT REARRANGE S1/0
S0    BSS 1         SUBSCRIPT NUMBER 0 .. (EXTEND SIZE FOR EMA) 
B6000 OCT 6000
* 
* 
*                   *********************************************** 
*                   * DEFINE DIMENSION ENTRY (ALSO BCOMI ENTRIES) * 
*                   *********************************************** 
* 
* 
DDE.F NOP 
      RAR,RAR       MOVE NO. DIMENSIONS 
      RAR,RAR       TO THE 'IM' FIELD 
      JSB ESC.F     SET F.IM=NS 
      LDA B6000     (A)=DIM 
      STA F.AT.     SUBSCRIPT INFORMATION FLAG SET
      CLA 
      STA F.IU      F.IU=0
      JSB AI.F      ASSIGN ITEM 
      JMP DDE.F,I   RETURN
      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 
      SPC 1 
ILD.F NOP 
      JSB NDS.F     NON-DUMMY & NON-SUBPROGRAM TEST 
      LDA F.IU
      CPA ARR 
      JMP ILE04     F.IU=ARR
      JSB TV.F      TAG VARIABLE
      CLA 
ILE02 STA S1
      JMP ILD.F,I 
      SPC 1 
K38   DEC 38
      SPC 1 
ILE04 JSB ISP.F     INPUT SUBSCRIPTS
      JSB FA.F      FETCH ASSIGNS 
      LDA K38 
      LDB NS        NO. OF SUBSCRIPTS 
      CMB,INB       (B)=-(B)
      ADB F.ND      # OF DIMENSIONS 
      SSB 
      JSB ER.F      MORE SUBSCRIPTS THAN DIMENSIONS 
* 
      LDA DS3       SET UP DEF OF 'S' LIST
      STA DS        IN LOCAL TEMP 
      LDA DFD2      GET DEF OF DEF LIST 
      STA DFD       AND SET IT FOR LOOP 
      LDA KM3       SET FOR THREE SUBSCRIPTS
      STA DDE.F     SET COUNTER 
      CLA,CLE       INITILIZE 
      STA ILET0     TEMPS 
      STA S0        AND EXTENDED SIZE WORD
ILE01 LDA DS,I      GET SUBSCRIPT 
      ADA ILET0     ADD WHAT WE HAVE ALREADY
      RAL,CLE,SLA,ERA PROP THE SIGN (LOW WORD IS 15 BITS) 
      ISZ S0        STEP IF CARRY 
      MPY DFD,I     MULTIPLY BY THE DIMENSION 
DFD   EQU *-1 
      RAL,CLE,ERA   CLEAR THE SIGN
      STA ILET0     SET LOW PART OF RESULT
      ELB,CLE       EXTEND SIGN OF A INTO B 
      STB ILET2     SET TEMP
      LDA S0        SET CURRENT LOW PART
      MPY DFD,I     MUL TIMES DIMENSION 
      ADA ILET2     ADD THE HIGH BITS FROM BEFORE 
      STA S0        SET THE NEW HIGH ORDER BITS 
      ISZ DS        STEP THE ADDRESSES
      ISZ DFD       AND 
      ISZ DDE.F 
      JMP ILE01     ARROUND WE GO 
* 
      LDA ILET0     GET LOW PART OF RESULT
      JMP ILE02     AND GO STORE IT 
* 
DS3   DEF S3
DFD2  DEF *+1,I 
      DEF F.D2
      DEF F.D1
      DEF F.D0
DS    NOP 
ILET0 NOP 
ILET2 NOP 
                                                                                                                                                                                                                  