ASMB,Q,C
      HED ** 16K FTN4 COMPILER (FTN4:PASS1) **
      NAM FTN4,3 92060-16092 REV.2026 800423
* 
*************************************************************** 
* (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:   FTN4, PART OF FTN4, PART OF FTN4 COMPILER.      * 
*     SOURCE: PART OF 92060-18092                             * 
*     RELOC:  PART OF 92060-16092                             * 
*     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)
       ENT F..DP    BASE OF SYMBOL TABLE
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
    EXT    F.ASS    ASSIGNMEXT STATEMEXT PROCESSOR
     EXT   F.ABT    ABORT COMPILE EXTRY 
       ENT F.ACC    TEMP ACCUMULATOR FLAG 
       ENT F.ARF    NO. OF SUB. FUN. ARGUMEXTS
  EXT      F.ASP    ASSIGN STMT. PROCESSOR
   EXT     F.AT     ADDRESS TYPE OF CURREXT F.A 
       ENT F.AT.    SUBSCRIPT INFO FLAG 
       ENT F.BGN    RETURN FROM F4.0
  EXT      F.BSP    BACKSPACE STMT. PROCESSOR 
       ENT F.BUF    A BUFFER
    EXT    F.CAL    CALL STATEMEXT PROCESSOR
     EXT   F.CC     CHARACTER COUNT 
       ENT F.CCW    FTN OPTION WORD 
  EXT      F.CON    CONTINUE STMT. PROCESSOR
       ENT F.CSZ    COMMON SIZE 
       ENT F.D      DO TABLE POINTER
       ENT F.D.T    ADDRESS OF '.' FUN. TABLE 
   EXT     F.D0     ARRAY ELEMEXT SIZE
   EXT     F.DCF    DIM, COM FLAG 
       ENT F.DEF    DATA EXISTS FLAG
       ENT F.DNB    DEF OF NBUF (NAM RECORD)
       ENT F.DO     LWAM - END OF DO TABLE
    EXT    F.DOP    DO STATEMEXT PROCESSOR
  EXT      F.EFP    ENDFILE STMT. PROCESSOR 
       ENT F.EMA    F.A OF EMA EXT ENTRY, WINDOW SIZE 
       ENT F.EMS    EMA SIZE  DOUBLE WORD, (INTERNAL FORMAT)
       ENT F.END    END FLAG
       ENT F.EQF    EQUIVALENCE FLAG
       ENT F.ER0    'RX' OF ERRX  LIB ERROR ROUTINE 
  EXT      F.FMT    FORMAT STMT. PROCESSOR
    EXT    F.GOP    GO TO STATEMEXT PROCESSOR 
      EXT  F.IDI    INPUT ARRAY NON-NUMERIC 
       ENT F.IFF    IF FLAG 
    EXT    F.IFP    IF STATEMEXT PROCESSOR
       ENT F.INT    TEMP VARIABLE ARRAY 
       ENT F.IOF    INDICATOR FOR I/O INDEX EVALUATOR 
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       ENT F.L      # WORDS ON STACK 2
     EXT   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.MFL    TYPE STMT. MODE FLAG
     EXT   F.NCR    NO CROSS REF FLAG 
       ENT F.NEQ    # OF EQUIVALENCE GROUPS 
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
     EXT   F.NXN    NO INPUT FLAG 
       ENT F.OPF    OUTPUT PACK FLAG
      EXT  F.PAK    PACK BUFFER WORD
  EXT      F.PAP    PAUSE STMT. PROCESSOR 
    EXT    F.RDP    READ STATEMEXT PROCESSOR
       ENT F.RPL    PROGRAM LOCATION COUNTER
  EXT      F.RTN    RETURN STMT. PROCESSOR
  EXT      F.RWP    REWIND STMT. PROCESSOR
       ENT F.S02    RETURN FORM RCOM  F.1 
       ENT F.S03    LOAD F.1 AND PASS CONTROL 
       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.SCC    SAVE F.CC 
       ENT F.SEE    RETURN FROM F4.1
       ENT F.SEG    LOAD A NEW SEGMENT
       ENT F.SFF    SUBROUTINE/FUNCTION FLAG 0/1
    EXT    F.SFP    STATEMEXT FUNCTION PROCESSOR
       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    STATEMEXT PROCESSOR SWITCH
       ENT F.STA    FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ 
       ENT F.STB    STRING BACK JUMP FLAG 
  EXT      F.STP    STOP STMT. PROCESSOR
       ENT F.STS    TO STATEMEXT SCAN 
       ENT F.SXF    COMPLEX CONSTANT FLAG 
       ENT F.T      # WORDS ON STACK 1
       ENT F.TAC    ? 
     EXT   F.TC     NEXT CHARACTER
     EXT   F.TRM    TERMINATE COMPILE 
       ENT F.TYP    TYPE STMT FLAG
    EXT    F.WRP    WRITE STATEMEXT PROCESSOR 
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
       ENT AA.F     ASSIGN ADDRESS SUB. 
       ENT CRT.F    TEST FOR CARRAGE RETURN 
   EXT     CSN.F    CHECK STATEMENT # TYPE. 
   EXT     DL.F     DEFINE LOCATION SUBROUTINE
     EXT   ER.F     ERROR PRINT SUBROUTINE
     EXT   EXN.F    EXAMINE NEXT CHARACTER
       ENT FNS.F    FIRST NOT SPEC. STMEXT CHECK
     EXT   IA.F     INPUT (A) CHARACTERS SUBROUTINE 
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
      EXT  IDN.F    INPUT DO NOT ASSIGN (GET NEXT OPERAND)
    EXT    IFT.F    IF GOTO COMPLETION
     EXT   ISN.F    INPUT STATEMEXT NUMBER
     EXT   ISY.F    INPUT SYMBOL
     EXT   MCC.F    RESET TO FIRST COLUMN OF STATEMEXT
       ENT NEW.F    SUB TO CLEAR TEMPS FOR A NEW MODULE 
       ENT SCC.F    SAVE F.CC SUBROUTINE
     EXT   SNC.F    START NEXT CARD SUBROUTINE
    EXT    TDO.F    DO TERMINATION CODE GENERATOR 
   EXT     TCT.F    TEST (A) = F.TC ELSE ER 28
     EXT   UC.F     UNINPUT COLUMN
     EXT   WAR.F    ERROR COMMEXT SUBROUTINE (WARNINGS) 
      SPC 1 
*         THIS FORTRAN IV COMPILER RUNS UNDER VARIOUS OP
*         SYSTEMS THROUGH SUITABLE INTERFACE ROUTINES.
* 
*     OPSYSTEM INTERFACE: 
* 
* 
      EXT SEG.F     SEGMENT TRANSLATOR
      EXT WRT.C 
      EXT C.TTY 
      EXT C.BIN     BINARY FCB  (MUST BE IN MAIN) 
      EXT C.TRN     COMPILER LIB. DATA STORE
      EXT OLY.C     SEGMENT LOAD
*     GENERAL LIBRARY ROUTINES
* 
* 
* 
*     EXTRY POINTS IN THE SEGMENTS
* 
      EXT F.COM     COMMON STATEMENT PROCESSOR
      EXT F.CPX     COMPLEX STATEMENT PROCESSOR 
      EXT F.DAT     DATA STATEMENT PROCESSOR
      EXT F.DBL     DOUBLE STATEMENT PROCESSOR
      EXT F.DIM     DIMENSION STATEMENT PROCESSOR 
      EXT F.EMP     EMA STATEMENT PROCESSOR 
      EXT F.EQU     EQUIVALENCE STATEMENT PROCESSOR 
      EXT F.EXT     EXTERNAL STATEMENT PROCESSOR
      EXT F.FUN     FUNCTION STATEMENT PROCESSOR
      EXT F.IMP     IMPLICIT STATEMENT PROCESSOR
      EXT F.INP     INTEGER STATEMENT PROCESSOR 
      EXT F.LOG     LOGICAL STATEMENT PROCESSOR 
      EXT F.PRO     PROGRAM STATEMENT PROCESSOR 
      EXT F.RCO     RELATE COMMON AND FINISH EQU PROCESSING 
      EXT F.REA     REAL STATEMENT PROCESSOR
      EXT F.SUB     SUBROUTINE STATEMENT PROCESSOR
      EXT F.BLK     BLOCK DATA STATEMENT PROCESSOR
      EXT FER.F     FORM PROGRAM ENTRANCE CODE
      SPC 1 
      SUP 
A     EQU 0              A-REGISTER 
B     EQU 1              B-REGISTER 
      SKP 
* 
PBUF  BSS 0 
F.BUF BSS 0 
NBUF  EQU PBUF+65   LINE #S FOR 21 CARDS IN CRDBF 
* 
* 
      DEF C.TRN     DUMMY REF. TO FOURCE LOAD WITH MAIN 
      DEF C.BIN     ALSO A DUMMY
* 
      BSS 60-*+NBUF RESERVE ROOM OF NAM RECORD
      SPC 1 
FTN4  BSS 0 
      DST F.IDI     SAVE THE RUN REGS.
      LDB K4        GO TO SEGMENT 4 
      JMP F.SEG 
* 
* 
* 
F.STA NOP FTN READ YET FLAG 
F.CCW DEC 1         COMPILE OPTION CONTROL WORD (PRINT CON REC.)
F.DNB DEF NBUF
K2    DEC 2 
K4    DEC 4 
B15   OCT 15
B54   OCT 54
F.ER0 ASC 1,R0
F.DO  NOP           LWAM; END OF F.DO TABLE 
      SKP 
*        *************************
*        * COMPILE A NEW PROGRAM *
*        *************************
      SPC 1 
NEW.F NOP 
      CLA 
      STA STBFL     CLEAR STRING BACK FLAG
      STA F.NEQ     SET # OF EQUIV GP.=0
      STA F.OPF     SET NOT TO OUTPUT 
      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 
      SPC 1 
F.D.T DEF ..TBL 
* 
F..DP NOP           FIX EXTERNAL
F.LO  NOP           END OF ASSIGNMENT TABLE +1
F.EQF NOP           NEG. IF NOT PROC EQUIV
F.S1B NOP           BEGIN OPERAND STACK 
F.S1T NOP           END OPERAND STACK 
F.S2T NOP           END OPERATOR STACK
F.NEQ NOP           # OF EQUIVALENCE GROUPS 
K73   DEC 73
      SPC 2 
*         *********** 
*         * SAVE CC * 
*         *********** 
      SPC 1 
SCC.F NOP 
      LDA F.CC      SAVE COLUMN COUNTER 
      STA F.SCC 
      JMP SCC.F,I 
* 
F.SCC OCT 0         SAVE F.CC 
K27   DEC 27
K29   DEC 29
      SKP 
*         ******************* 
*         * STATEMENT INPUT * 
*         ******************* 
      SPC 1 
F.BGN JSB SCC.F     SAVE THE CHARACTER POSITION 
      CLA 
      STA F.OPF     CLEAR THE PACK FLAG 
      STA F.STB     CLEAR STRING-BACK FLAG
      STA F.A       SET ASSIGNMENT TABLE PTR TO 0 
      STA F.MFL     CLEAR MODE FLAG 
      JSB EXN.F     EXAMINE NEXT CHAR.
      CPA B15       IF BLANK CARD 
      JMP CRT.F     TREAT AS A CONTINUE CARD
* 
      LDA F.CC      BEYOND COL. 6?
      ADA KM6 
      SZA,RSS       IF EXACTLY 6 THEN MUST BE 
      ISZ F.CC      A '0' SO PUSH ON
      SSA,RSS       WELL??
      JMP STIN2     YES, NO NUMBER. 
* 
      CLA           INPUT ANY KIND OF STATEMENT #.
      JSB ISN.F 
STIN2 LDA F.A 
      STA F.LSN     LAST STATEMENT NUMBER FLAG
      SZA,RSS 
      JMP STIN0     CURRENT CARD HAS NO STATEMENT NO. 
      LDA K27       27
      LDB F.AT
      CPB REL 
      JSB WAR.F     ERROR 27: STMT NO. PREVIOUSLY DEFINED 
STIN0 LDA F.IFF     IF FLAG SET?
      SZA 
      XOR F.LSN     YES 
      JSB IFT.F     F.IFF TEST (RTNS A=0) 
      CPA F.CC      BLANK CARD INPUT? 
      JMP STIN6     YES.
      CPA F.LSN     STATEMENT # ON CARD?
      JMP F.STS     NO. GO SCAN THE STATEMENT 
      LDA F.TC      LOAD THE LAST CHARACTER READ. 
      CPA B15       CARRIAGE-RETURN?
      JMP STIN1     YES, PRINT SOURCE LINE. 
      JSB EXN.F     GET THE NEXT CHARACTER. 
      LDA F.CC      LOAD THE COLUMN POINTER.
      SZA           COLUMNS 7 THRU 72 BLANK?
      JMP F.STS     NO, IDENTIFY THE CARD TYPE. 
      ISZ F.CC      SET F.CC=1
STIN1 LDA K29       BITCH: STATEMENT NO. ON BLANK CARD
      JSB ER.F
      SPC 2 
      SPC 1 
STIN6 JSB SNC.F     BLANK CARD; SET FOR NEXT CARD 
      JMP F.BGN     PROCESS THE CURRENT CARD. 
      SPC 2 
KM3   DEC -3
KM6   DEC -6
B50   OCT 50
DSLH  OCT 42015 
END$. ASC 2,END$
      SKP 
*     THE FOLLOWING IS A FLOW CHART OF THE STATEMENT IDENTIFIER AND 
*     DISPATCHER.  TWO SYMBOLS ARE USED FOR DECISION BLOCKS AS FOLLWOS: 
* 
* 
*     Y=X?    IF Y=X EXIT WILL BE '1' (TRUE), ELSE '0' (FALSE)
*     Y=?     THIS IS REALLY A COMPUTED GO TO OR CASE STATEMENT.
*             EXITS WILL BE LABELED WITH THE VALUE OF Y WHICH 
*             TAKES THAT EXIT.
* 
*     LABELS ARE USED TO COROLATE THE FLOW CHART AND THE LISTING
* 
*     ROUTINES USED   FUNCTION
*     IDN.F    INPUTS 6 ALF/NUM OR TO DELIMITER OR OPERAND TO DELIMITER-
*              INPUTS WHOLE HOLLERITH STRINGS AND EXCEPT FOR > 6
*              CHARACTERS ALF/NUM IDENTIFIER STRINGS INPUTS 
*              THE DELIMITER AND LEAVES IT IN F.TC. 
*     ICH.F    INPUTS ONE NON-BLANK CHARACTER AND SET DELIMITER FLAG. 
*     CLID     CLEARS NUMBER ACCUMULATOR
*     IDS.F    INPUT DIGIT STRING.
*     MCC.F    RESETS TO BEGINNING OF STATEMENT.
*     ISY.F    INPUTS A SYMBOL AND SETS ARRAY IDENTIFIER. 
* 
* 
*     SHORT HAND FOR TEMPS
*     T1 = T1STS
*     T2 = T2STS
*     T4 = T4SID
* 
*     FLOW LINES
* 
*     ! = DOWN
*     ^ = UP FLOW 
*     _ = LEFT FLOW 
*     - = RIGHT FLOW
*     = = EQUALITY TEST 
*     O = TWO OR MORE LINES JOIN (ELSE THEY CROSS)
      SKP 
*                 T1_ -1    WE BEGIN JUST AFTER STSCC 
*              T4,T2_ 0     START BY LOOK FOR A 'DO' STMT.
*           FIRST TWO CHAR = 'DO'?
*           0!               1! 
*  !__________                ! 
*  !                       T3_ 0      LOOK FOR DIGITS 
*  !                          O______           X 
*  !                         ICH.F  ^ 
*  !                       DIGIT?  T3_ #0 
*  !                         0!  1!  ^
*  !                      T3= 0?  ---^
*  !                      1!  0!
*  O________________________  F.TC= ','? IF OPTIONAL COMMA THEN DO
*  !                         0!      1! 
*  !                      UC.F,IDN.F  !  LOOK FOR INT. VAR. 
*  !                         !        ! 
*  !                F.NT=NAMED?       ! 
*  !            0!           1!       ! 
*  O______________         F.TC= '='? !     FOLLOWED BY '='?
*  !                       0!    1!   ! 
*  O________________________!     ----------------O STSC3______________O
*  !                                  !         IDN.F                  ^
*  !                                  !           !                    ^
*  !                                  !          TC=?                  ^
*  !                                  !   !____!__O-------------ELSE---O
*  !                                  !   !    !      !      !         ^
*  !                                  ! 'C/R' ','    ')'    '('        ^
*  !                                  !   !    !STSC5 !      !         ^
*  !-----------------O________________!____   T2=0?  T2_T2+1 !         ^
*                    !                !       1! 0!   !  T2_T2-1       ^
*                    ! STSCB          !        !  !   !      !         ^
*                   MCC.F             !        !  !---O------O---------^
*               F.SID_1               !        !
*                  IDN.F              !----****STIDO****
*              TC='(' OR '='?              *IT IS A DO *
*              0!          1! STID9        *STATEMENT  *
*               !           !              *************
*               !           O_______________________     X
*               !         TC=?                     ^
*               !   ________O-------------------   ^
*               !   !             !    !  !    !   ^
*               !   ! 'C/R',     ')'  '(' E   '='  ^
*               !   ! '"',        !    !  L    !   ^
*               !   ! "'"      T4_T4-1 !  S    !   ^ ^------! 
*               O<<<!       ^     !T4_T4+1E    !   ^ ^     ISY.F,MCC.F
*               !           ^   T4=0?  !  !  T4=0? ^ ^       !
*               !           ^   1!  0! !  !  0! 1! ^ ^    ARRAY?
*               ! STID0     ^ EXN.F  --O__O____  ! ^ ^    1!   0! 
*             MCC.F         ^    !   IDN.F       ! ^ ^     !  *STFPR***** 
*     FIRST 3 CHAR='IF('?   ^ TC='='?  !---------!-^ ^     !  *STATEMENT* 
*      1!           0!      ^ 0!   1!            !   ^     !  *FUNCTION * 
* ****IFPR****  *ONE OF THE*^___    O_____________   ^     !  *********** 
* *IT'S AN IF*  *KEY WORD  *      MCC.F              ^ ***FASS******
* *STATEMENT *  *STATEMENTS*      T1=1? ONLY 1 '('?  ^ *ASSIGNMENT *
* ************  ************      0!  1--------------^ *STATEMENT  *
      SKP 
*         ******************
*         * STATEMENT SCAN *
*         ******************
      SPC 1 
*     SCANS THE FIRST CARD OF ALL STATEMENTS DETERMINING IF THE 
*     STATEMENT TYPE IS A REPLACEMENT STATEMENT, A DO STATEMENT 
*     (= FOLLOWED BY ,),OR ARITHMETIC STATEMENT FUNCTION(= AND
*     THE OPERAND TERMINATED BY '(' AND WAS NOT AN ARRAY).
      SPC 1 
F.STS JSB SCC.F     SAVE F.CC 
      LDA K2
      STA F.NXN     SET NO INPUT FLAG 
************************THIS END$ CHECK PROBABILY BELONGS IN IC.F 
      JSB IA.F      INPUT 2 CHARS 
      LDA F.PAK 
      CPA END$.     "EN"? 
      RSS 
      JMP STSCC 
      LDA K2
      JSB IA.F      INPUT 2 CHARS 
      LDB F.LFF 
      SZB           PART OF LOGICAL "IF"? 
      JMP STSCC     YES, DO A NORMAL SCAN.
      LDA F.PAK 
      CPA END$.+1   "D$"? 
      JMP F.TRM     YES. END OF COMPILATION.
      CPA DSLH      "D/"? 
      JMP STSEN     END STATEMENT.
STSCC LDA F.SCC 
      STA F.CC      RESTORE F.CC
      CLA 
      STA F.NXN     RESET NO INPUT FLAG 
      STA F.END     RESET 'END' OCCURRED FLAG.
      STA T4SID     CLEAR THE TEMPS 
      STA T2STS 
      CCA 
      STA T1STS     SET T1=-1 
* 
*     WE START BY LOOKING FOR A 'DO' STATEMENT
* 
      LDA K2        SUCK UP 
      JSB IA.F      2 CHARACTERS
      LDA F.PAK     SAVE THEM 
      STA STNM      FOR THE IF/DO TEST LATER
      CPA "DO"      IS IT 'DO'? 
      CLA,RSS       YES CONTINUE
      JMP STSCB     NOT A DO  TRY OTHER 
* 
STS00 STA T3SID     SAVE A DIGIT FLAG 
      JSB ICH.F     SUCK UP A CHAR. 
      SZB,RSS       IF DIGIT
      JMP STS00     KEEP THEM COMMING 
* 
      LDB T3SID     GET THE FLAG
      SZB,RSS       IF NO DIGITS
      JMP STSCB     THEN NOT A 'DO' STMT. 
* 
      CPA B54       ',' IF COMMA (IT IS OPTIONAL) 
      JMP STIDO     THEN IT MUST BE A DO STMT.
      JSB UC.F      BACK UP ONE 
      JSB IDN.F     GET SYMBOL
      LDA F.NT      IF NOT NAMED
      SZA           THEN
      JMP STSCB     NOT A 'DO' STMT.
* 
      LDA F.TC      IF NEXT CHAR IS 
      CPA B75       '=' THEN IT COULD BE A DO 
      JMP STSC3     GO CHECK FOR ','
* 
STSCB JSB MCC.F     SETUP TO RESCAN THE STMT. 
      ISZ F.SID     SET STID FLAG 
      JSB IDN.F     INPUT DNA 
      LDA F.TC      CAN IT BE ASSIGN OR STMT FCT ?
      CPA B75       '=' ? 
      JMP STID9     YES.
      CPA B50       '(' ? 
      JMP STID9     YES.
      JMP STID0     NO, MUST BE KEYWORD.
* 
* 
*     IT LOOKS LIKE A DO UP TO AND INCLUDING THE '='
*     MUST NOW FIND A ',' OUTSIDE OF  '()' PAIRS. 
* 
STSC3 JSB IDN.F     INPUT DNA 
      LDA F.TC
      CPA B54       F.TC=',' ?
      JMP STSC5     YES  GO TEST '(' LEVEL
* 
      CPA B15       F.TC=C/R ?
      JMP STSCB     END OF STMT.  MUST NOT BE A 'DO'
* 
      CPA B50       F.TC='(' ?
      ISZ T2STS     BUMP LEVEL   =X(
      CCB 
      ADB T2STS 
      CPA B51       F.TC= ")"?      =X) 
      STB T2STS     DECREMENT LEVEL 
      JMP STSC3     CHECK NEXT ITEM 
* 
STSC5 LDA T2STS     '(' COUNT =0 ?  =X, 
      SZA 
      JMP STSC3     NO  CONTINUE SCAN 
* 
*     YES IT IS A DO STMT.     !!!!!!!!!!!!!!!!!!!!!! 
* 
      JMP STIDO     GO SET IT UP. 
* 
      SPC 1 
STID5 JSB IDN.F     INPUT DNA 
STID9 LDA F.TC      STMT BEGINS WITH DELIMITER
      CPA B15       'C/R' 
      JMP STID0     MUST BE A KEY WORD STMT.
* 
      CPA B42.      F.TC='"'? 
      JMP STID0     YES.  MUST BE A KEY WORD STMT.
      CPA B47       F.TC="'"? 
      JMP STID0     LIKEWISE. 
* 
      CPA B50       '(' COUNT  THESE (WILL SKIP ON FIRST ONE) 
      ISZ T1STS 
      CPA B50       '(' 
      ISZ T4SID     COUNT '(' LEVEL 
      CPA B75       '=' ? 
      JMP STI01     YES GO CHECK LEVEL
* 
      CPA B51       ')' 
      CCA,RSS       YES DECREMENT THE COUNT 
      JMP STID5     NO GET NEXT TOKEN 
* 
      ADA T4SID 
      STA T4SID 
      SZA           IF COUNT IS ZERO
      JMP STID5