ASMB,Q,C
      HED HEADER FOR FILES &F4XCS AND $F4XCS .
      NAM F4XCS,8 92834-12001 REV.2030 800715 
* 
*************************************************************** 
* (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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
      END 
ASMB,L
      HED "Z$INT" - SYSTEM PARAMETERS.
      NAM Z$INT,8 92834-12001 REV.2030 800304 
* 
*************************************************************** 
* (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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
      ENT Z$INT,Z$LPP 
* 
Z$INT RPL 1         1-WORD INTEGERS.
Z$LPP RPL 59        59 LINES/PAGE.
* 
      END 
ASMB,Q,C
      HED STATEMENT DISPATCHER FOR FTN4X. 
      NAM DSP.F,8 92834-12001 REV.2030 800805 
* 
*************************************************************** 
* (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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  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)
*                 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 EXTRY 
   EXT     F.AT     ADDRESS TYPE OF CURRENT ITEM. 
       ENT F.BGN    STARTING POINT AFTER SEGMENT 0 LOADED.
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CCW    FTN OPTION WORD.
       ENT F.CRT    TEST FOR C/R & GO ON TO NEXT STMT.
       EXT F.D      DO TABLE POINTER. 
   EXT     F.DCF    DIM, COM FLAG 
     EXT   F.DNI    ADDR OF (NID) BUFFER. 
       EXT F.DO     LWA MEM & LWA+1 DO TABLE. 
       EXT F.EMA    F.A OF EMA MASTER.
       EXT F.END    END FLAG
       EXT F.FNS    FIRST NON-SPECIFICATION CHECK.
      EXT  F.IDI    CONSTANT BUFFER.
   EXT     F.IM     CURRENT ITEM MODE.
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
       EXT F.L      # WORDS ON STACK 2
       EXT F.LFF    LOCICAL IF FLAG 
       EXT F.LSF    EXPECT FIRST STATEMEXT FLAG 
       EXT F.LSN    F.A OF LAST STATEMEXT NUMBER
       EXT F.LSP    LAST OP FLAG: 0 IF CAN'T FALL THRU. 
       EXT F.MSG    MSEG SIZE.
     EXT   F.NCR    NO CROSS REF FLAG.
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
     EXT   F.NXN    NO INPUT FLAG 
       ENT F.P1E    PASS 1 ERROR EXIT POINT.
       EXT F.RPL    PROGRAM LOCATION COUNTER. 
       EXT F.SEG    LOAD A NEW SEGMENT
       EXT F.SID    STATEMEXT ID PHASE FLAG 
       EXT F.SLF    STATEMEXT LEVEL FLAG
       EXT F.STA    FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ 
       EXT F.STB    STRING BACK FLAG (LOGICAL IF) 
       ENT F.STS    ENTRY TO STATEMENT SCAN (LOGICAL IF). 
       EXT F.SVL    SAVE # WDS ON OPER STACK (F.L)
       EXT F.T      # WORDS ON STACK 1
     EXT   F.TC     NEXT CHARACTER
       EXT F.TL     LENGTH OF TITLE.
       ENT F.TRM    TERMINATE COMPILE. (SOURCE END) 
       EXT F.TTL    TITLE.
       EXT F.#B     # BUFFER BLOCKS.
       EXT F.#M     # NON-DISC CONNECTIONS. 
       EXT F.#N     # DISC CONNECTIONS. 
       EXT F.#S     BUFFER MULTIPLE.
       EXT F.$CC    SAVED F.CC AT $ STATEMENT BREAK.
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     CSN.F    CHECK STATEMENT # TYPE. 
       ENT CTL.F    COPY TITLE TO PASS FILE.
   EXT     DAF.F    DEFINE F.AF 
   EXT     DAT.F    DEFINE F.AT 
   EXT     DEM.F    DEFINE F.EM=1 
    EXT    DL.F     DEFINE LOCATION: F.AF_F.RPL.
       EXT EJP.F    EJECT PAGE. 
     EXT   ER.F     ERROR PRINT SUBROUTINE
     EXT   EXN.F    EXAMINE NEXT CHARACTER
   EXT     FA.F     FETCH ASSIGNS.
     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   INM.F    INPUT NAME. 
     EXT   ISN.F    INPUT STATEMEXT NUMBER
     EXT   ISY.F    INPUT SYMBOL
   EXT     ITS.F    TEST CURRENT ITEM INTEGER.
       ENT KWP.F    KEYWORD SEARCH (JOINED IN PROGRESS).
       ENT KWS.F    KEYWORD SEARCH. 
     EXT   MCC.F    RESET TO FIRST COLUMN OF STATEMEXT
      EXT  PAK.F    PACK & OUTPUT ASCII DATA. 
       EXT PSI.F    PRINT SOURCE IMAGE. 
     EXT   RP.F     REQUIRE RIGHT PAREN & INPUT NEXT. 
     EXT   SCP.F    SAVE CURRENT STMT POS (NEW STMT, SAME LINE).
     EXT   SNC.F    START NEXT CARD SUBROUTINE
    EXT    TCT.F    TEST (A)=F.TC ELSE ERROR 28.
   EXT     TS.F     TAG ITEM AS SUBROUTINE. 
     EXT   UC.F     UNINPUT COLUMN
     EXT   WAR.F    WARNING MESSAGE PRINTER.
       EXT WS1.F    WRITE A WORD TO SCRATCH FILE 1. 
* 
*     FORMAT PROCESSOR. 
* 
      ENT F.FMT 
* 
*                   SYSTEM LIBRARY. 
* 
      EXT .MVW
      SPC 1 
      SUP 
A     EQU 0              A-REGISTER 
B     EQU 1              B-REGISTER 
      SKP 
*         **********************************
*         * SOURCE END. VERIFY PROGRAM END *
*         **********************************
      SPC 1 
F.TRM LDA K98 
      LDB F.END     LAST STATEMENT WAS 'END' ?
      SZB,RSS 
      JMP F.ABT     NO. ERROR 67. 
      LDB K4        YES. LOAD SEGMENT 4.
      STB F.STA     BUT DON'T LOOK FOR 'FTN,...'
      JMP F.SEG 
* 
K4    DEC 4 
K98   DEC 98
      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 
K29   DEC 29
      SKP 
*         ******************* 
*         * STATEMENT INPUT * 
*         ******************* 
      SPC 1 
F.BGN JSB SCC.F     SAVE THE CHARACTER POSITION 
      CLA 
      STA F.A       SET ASSIGNMENT TABLE PTR TO 0 
      STA F.LSN     SET NO STMT #.
      LDA K46       WRITE START-OF-STATEMENT OPERATOR.
      JSB WS1.F 
      JSB IC.F      DIRECTIVE ? 
      CPA "$" 
      JMP DRCTV 
* 
      CPA B40       STRIP BLANKS. 
      JSB ICH.F 
      JSB UC.F      AND POSITION TO LAST BLANK. 
      LDA F.TC
      CPA B15       IF BLANK CARD 
      JMP F.CRT     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 F.STS     YES, NO NUMBER. 
* 
      CLA           INPUT ANY KIND OF STATEMENT #.
      JSB ISN.F 
      LDA F.A 
      STA F.LSN     LAST STATEMENT NUMBER FLAG
      LDA F.TC      LOAD THE LAST CHARACTER READ. 
      CPA B15       CARRIAGE-RETURN?
      RSS           YES. STMT # ON BLANK CARD.
      JMP F.STS     NO, IDENTIFY THE CARD TYPE. 
* 
      LDA K29       BITCH: STATEMENT NO. ON BLANK CARD
      JSB ER.F
      SPC 2 
KM6   DEC -6
K46   DEC 46
B15   OCT 15        C/R 
B50   OCT 50        '(' 
"$"   OCT 44        $ 
"EN"  ASC 1,EN
"D$"  ASC 1,D$
"D/"  BYT 104,15
      SKP 
*         **********************
*         * DIRECTIVE HANDLING *
*         **********************
      SPC 1 
DRCTV CLA,INA       SET DIRECTIVE FLAG. 
      STA F.DF
      STA F.NXN     SET 'NO INPUT': ONLY ONE LINE.
      JSB KWS.F     SEARCH FOR THE KEYWORD. 
      DEF DRTBL 
      SZA,RSS       IF NOT FOUND, 
      JMP DRC01     THEN ALSO ERROR.
* 
      ADA DRJMP     ELSE GET PROCESSOR, 
      LDA A,I 
      JMP A,I       AND DO IT.
* 
DRC01 JSB PSI.F     ERROR. PRINT THE LINE.
      JMP STID2     THEN COMPLAIN.
* 
DRTBL ASC 11,EMA PAGE FILES TITLE  ,
DRJMP DEF *         KEEP IN ORDER: *
      DEF EMA                      *
      DEF PAGE                     *
      DEF FILES                    *
      DEF TITLE                    *
* 
F.DF  NOP           DIRECTIVE FLAG: 1=THIS STMT IS DIRECTIVE. 
      SKP 
*         ******************* 
*         * TITLE DIRECTIVE * 
*         ******************* 
      SPC 1 
*     NOTE: SINCE '$TITLE' TAKES UP 6 CHARACTERS, AND THE NO-INPUT
*     FLAG IS SET, THE MAXIMUM POSSIBLE TITLE IS 66 CHARACTERS. 
* 
TITLE LDA DFTTL     SET UP TITLE POINTER. 
      RAL,CLE,SLA,ERA  REMOVE AT MOST ONE INDIRECT. 
      LDA A,I 
      STA T1TTL 
      STA T2TTL     SAVE FOR COMPUTING # WDS WRITTEN. 
      JSB EXN.F     STRIP BLANKS OFF. 
TTL01 JSB IC.F      GET TWO TITLE CHARACTERS. 
      CPA B15       IF FIRST IS C/R,
      JMP TTL02     THEN DONE.
* 
      ALF,ALF       POSITION & SAVE.
      STA T3TTL 
      JSB IC.F      SECOND. 
      CPA B15       IF SECOND IS C/R, 
      LDA B40       CHANGE TO BLANK FOR NOW.
      IOR T3TTL     MERGE IN FIRST. 
      STA T1TTL,I   STORE IN TITLE BUFFER.
      ISZ T1TTL     BUMP POINTER. 
      JMP TTL01     GET MORE. (MAY RE-READ C/R) 
* 
TTL02 LDB T1TTL     BACK UP POINTER PAST BLANKS.
      LDA BLNKS     (A) = TWO BLANKS. 
TTL03 CPB T2TTL     AT START ?
      JMP TTL04     YES. WE'RE JUST CLEARING THE TITLE. 
* 
      ADB KM1       ELSE BACK UP ONE, 
      CPA B,I       BLANKS ?
      JMP TTL03     YES. KEEP BACKING UP. 
* 
      INB           (B) = (LWA+1) OF TITLE. 
TTL04 STB T1TTL     SAVE THE LWA+1. 
      LDA T2TTL     # WORDS WRITTEN = 
      CMA,INA       -(FWA)
      ADA B         +(LWA+1)
      STA F.TL      SET THAT AS THE TITLE LENGTH. 
      JSB CTL.F     COPY TO PASS 2. 
      JMP PAGE      GO PAGE EJECT & BUMP LINE #.
* 
BLNKS ASC 1,
T1TTL NOP           CURRENT POINTER INTO TITLE BUFFER.
T2TTL NOP           FWA TITLE BUFFER (DIRECT).
T3TTL NOP           TEMP FOR MERGING TWO CHARACTERS.
DFTTL DEF F.TTL     FWA TITLE BUFFER. MAY BE INDIRECT ! 
      SKP 
*         **************
*         * COPY TITLE *
*         **************
      SPC 1 
CTL.F NOP 
      LDA F.TL      TITLE LENGTH. 
      ALF,ALF       SET UP OPCODE.
      IOR K58 
      JSB WS1.F 
      LDA F.TL      AGAIN.
      CMA,INA,SZA,RSS  NEGATE. ZERO ? 
      JMP CTL.F,I   YES. DONE.
* 
      STA T1CTL     NO. SET UP COUNTER. 
      LDA DFTTL     SET UP POINTER. 
      RAL,CLE,SLA,ERA 
      LDA A,I 
      STA T2CTL 
CTL01 LDA T2CTL,I   SEND ANOTHER. 
      JSB WS1.F 
      ISZ T2CTL     BUMP POINTER. 
      ISZ T1CTL     COUNT.
      JMP CTL01     MORE. 
      JMP CTL.F,I   DONE. 
* 
T1CTL NOP           COUNTER.
T2CTL NOP           POINTER.
KM1   DEC -1
K57   DEC 57
K58   DEC 58
B4002 OCT 4002
K34   DEC 34
K31   DEC 31
BCOMI OCT 7000
      SKP 
*         ******************
*         * PAGE DIRECTIVE *
*         ******************
      SPC 1 
PAGE  JSB ICH.F     READ CHAR AFTER DIRECTIVE:
      CPA B15       REQUIRE C/R.
      RSS           O.K.
      JMP DRC01     NO. PRINT LINE & ISSUE ERROR. 
* 
      LDA F.CCW     'L' OPTION ?
      SLA,RSS 
      JMP PAG02     NO. DONE. 
* 
      AND B4002     'Q' OR 'M' ?
      SZA 
      JMP PAG01     YES.
* 
      JSB EJP.F     NO. DO IT NOW.
      JMP PAG02     THEN DONE.
* 
PAG01 LDA K57       SEND OPCODE TO FORCE PAGE EJECT 
      JSB WS1.F     IN PASS 2.
* 
PAG02 LDA K29       SINCE THE DIRECTIVE WASN'T PRINTED, 
      JSB WS1.F     MUST TELL PASS 2 TO BUMP LINE NUMBER. 
      JMP F.CRT     DONE. 
      SKP 
*         ***************** 
*         * EMA DIRECTIVE * 
*         ***************** 
      SPC 1 
EMA   JSB PSI.F     ALWAYS PRINT THIS ONE.
      LDB F.LSF     BEFORE FIRST STATEMENT ?
      LDA K34       (ERROR: OUT OF ORDER) 
      SZB,RSS       WELL ?
      JSB ER.F      NO. ERROR.
* 
      LDB F.EMA     FIRST EMA STATEMENT ? 
      SZB 
      JSB ER.F      NO. ERROR.
* 
      JSB ICH.F     YES. READ THE '('.
      LDA B50       REQUIRE IT. 
      JSB TCT.F 
      JSB INM.F     READ THE COMMON BLOCK NAME. 
      LDA BCOMI     AND 
      JSB DAT.F     SET UP AS COMMON
      JSB TS.F      MASTER - TYPE SUB.
      LDA F.A       SET F.EMA = ADDR OF MASTER. 
      STA F.EMA 
      JSB DAF.F     SET TO POINT AT SELF (0 LENGTH LINKED LIST) 
      JSB DEM.F     SET TO BE TYPE EMA. 
      LDA F.TC      IS DELIMETER: 
      CPA B54       A COMMA ? 
      RSS           YES.
      JMP EMA02     NO. MUST BE ')'.
* 
*                   SET UP MSEG SIZE, CHECK ')'.
* 
      JSB GDC.F     GET VALUE.
      LDB A         A=B=VALUE.
      AND K31       LIMIT TO 31.
      CPA B         (MUST NOT EXCEED 5 BITS)
      RSS 
      JMP GDC02     TOO BIG. ERROR. 
* 
      STA F.MSG     SAVE THE VALUE. 
EMA02 JSB RP.F      REQUIRE ')' NOW, & READ C/R 
      JMP F.CRT     TEST C/R, THEN DONE.
      SKP 
*         ******************* 
*         * FILES DIRECTIVE * 
*         ******************* 
      SPC 1 
FILES JSB PSI.F     ALWAYS PRINT. 
      LDB F.LSF     BEFORE FIRST STATEMENT ?
      LDA K34 
      SZB,RSS 
      JSB ER.F      NO. ERROR 34. 
* 
      LDB F.#S      FIRST FILES ? 
      SZB 
      JSB ER.F      NO. ERROR.
* 
      JSB EXN.F     YES. SKIP OPTIONAL '('
      CPA B50 
      JSB ICH.F 
* 
*                   GET M & N . 
* 
      JSB GDC.F     GET DIRECTIVE CONSTANT (M). 
      STA F.#M      SAVE. 
      CMA,SSA,INA,RSS  NEGATE. WAS IT NEGATIVE ?
      JMP FIL04     YES. ERROR. 
* 
      ADA K64       NO. > 64 ?
      SSA 
      JMP FIL04     YES. ERROR. 
* 
      LDA B54       NO. REQUIRE COMMA.
      JSB TCT.F 
      JSB GDC.F     GET (N).
      STA F.#N
      CMA,SSA,INA,RSS  NEGATE. WAS IT NEGATIVE ?
      JMP FIL04     YES. ERROR. 
* 
      ADA K16       NO. > 16 ?
      SSA 
      JMP FIL04     YES. ERROR. 
* 
      LDA F.#M      M = M + N.
      ADA F.#N
      STA F.#M
* 
*                   GET S OR "DS".
* 
      LDB F.TC      NO. IS S/DS PRESENT ? 
      CPB B54 
      JMP FIL07     (YES) 
* 
      CLA,INA       NO. S=1.  
      STA F.#S
      JMP FIL08     AND DEFAULT F.#B TOO. 
      SKP 
FIL07 JSB EXN.F     YES. IS NEXT PARAM NUMBER ? 
      SZB,RSS         
      JMP FIL01     YES.  GO GET IT.
* 
      JSB KWS.F     NON-DIGIT. REQUIRE "DS".
      DEF FILDS     1-ITEM KEYWORD SEARCH.
      SZA           FOUND IT ?  (I.E., IS IT "DS" ?)
      JMP FIL02     YES. LEAVE S=0. 
      JMP FIL05     NO. ERROR.
* 
FIL01 JSB GDC.F     GET S.  
      STA F.#S
      CMA,SSA,INA,SZA  NEGATE.  .LE. 0 ?. 
      RSS           (NO)
      JMP FIL04     YES. ERROR. 
* 
      ADA K64       NO. > 64 ?. 
      SSA 
      JMP FIL04     YES. ERROR. 
* 
*                   GET B OR "FREESPACE". 
* 
      LDA F.TC      IS IT THERE ? 
      CPA B54         
      RSS           (YES) 
      JMP FIL08     NO. DEFAULT IT. 
* 
      JSB EXN.F     DIGIT ? 
      SZB,RSS 
      JMP FIL09     YES. GET VALUE. 
*       
      JSB KWS.F     NO. MUST BE "FREESPACE".
      DEF FILFR 
      SZA,RSS       WELL ?
      JMP FIL05     NO. ERROR.
* 
      CCA           YES. SET F.#B = -1 AS FLAG. 
      STA F.#B
      JMP FIL02     GO EXIT.
* 
FIL09 JSB GDC.F     YES. GET IT.
      STA F.#B      & SET IT UP.  (CLEARED IF ERROR)
      AND B377      RESTRICT TO [0,255] 
      CPA F.#B
      CMA,RSS       (O.K.; -B-1)
      JMP FIL04     REJECT: OUT OF RANGE. 
* 
      ADA F.#N      N-B-1 
      SSA,RSS       IF B<N, 
      JMP FIL04     ERROR: NOT ENOUGH FOR ONE EACH. 
      JMP FIL02 
      SKP 
FIL08 LDA F.#N      DEFAULT B = N * S (ONE EACH). 
      MPY F.#S
      STA F.#B
      JMP FIL03 
* 
*                   SET FLAG THAT FILES PRESENT & EXIT. 
* 
FIL02 JSB ICH.F     (READ FINAL DELIMITER)
FIL03 LDA F.#S      SET SIGN OF S AS FILES FLAG.
      IOR B100K 
      STA F.#S
      LDA F.TC      SKIP OPTIONAL RIGHT PAREN.
      CPA B51 
      JSB ICH.F 
      JMP F.CRT     DONE. 
      SKP 
*                   ERROR IN 'FILES'. 
* 
FIL04 LDA K21       VALUE OUT OF RANGE. 
      JMP FIL06 
* 
FIL05 LDA K28       3RD PARAM NOT NUMBER OR "DS". 
FIL06 CLB           RESET AS IF NEVER SAW "FILES".
      STB F.#M      
      STB F.#N
      STB F.#S
      STB F.#B
      JSB ER.F      REPORT ERROR. 
* 
FILDS ASC 2,DS  ,         1-ITEM KEYWORD SEARCH TABLES. 
FILFR ASC 6,FREESPACE   ,   
K16   DEC 16
K28   DEC 28
K64   DEC 64
B100K OCT 100000
      SKP 
*         **************************
*         * GET DIRECTIVE CONSTANT *
*         **************************
      SPC 1 
GDC.F NOP 
      JSB IDN.F     FIRST, GET ANYTHING.
      JSB ITS.F     DISALLOW DELIMETERS & NON-INTEGERS. 
      LDA F.NT      REQUIRE CONSTANT. 
      SZA,RSS 
      JMP GDC01     NON-CONSTANT. ERROR.
* 
      LDA F.IDI     VALUE IF INTEGER*2. 
      LDB F.IM      IS THAT IT ?
      CPB INT 
      JMP GDC.F,I   YES. DONE.
* 
      SZA           NO. UPPER OF INTEGER*4. TOO BIG ? 
      JMP GDC02     YES.
* 
      LDA F.IDI+1   NO. RETURN LOWER. 
      JMP GDC.F,I 
* 
GDC01 LDA K19       NON-CONSTANT. 
      JSB ER.F
* 
GDC02 LDA K21       OUT OF RANGE. 
      JSB ER.F
* 
INT   OCT 10000     F.IM=INT
K19   DEC 19
K21   DEC 21
      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 ISZ F.SID     SET ID PHASE FLAG.
      JSB SCC.F     SAVE F.CC 
      CLA,INA 
      STA F.NXN     SET NO INPUT FLAG 
      LDB F.LFF     PART OF LOGICAL 'IF' ?
      SZB 
      JMP STSCC     YES, DO A NORMAL SCAN.
************************THIS END$ CHECK PROBABILY BELONGS IN IC.F 
      JSB RD2.F     INPUT 2 CHARS.
      CPA "EN"      "EN"? 
      RSS 
      JMP STSCC 
      JSB RD2.F     INPUT 2 CHARS 
      CPA "D$"      "D$"? 
      JMP F.TRM     YES. END OF COMPILATION.
      CPA "D/"      D C/R ? 
      JMP STIEN     YES. 'END'. 
* 
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 T2SID     CLEAR THE TEMPS 
      STA T2STS 
      CCA 
      STA T1STS     SET T1=-1 
      SKP 
*     WE START BY LOOKING FOR A 'DO' STATEMENT
* 
      JSB RD2.F     READ 2 CHARS. 
      CPA "DO"      IS IT 'DO'? 
      CLA,RSS       YES CONTINUE
      JMP STSCB     NOT A DO  TRY OTHER 
* 
STS00 STA T1SID     SAVE A DIGIT FLAG 
      JSB ICH.F     SUCK UP A CHAR. 
      SZB,RSS       IF DIGIT
      JMP STS00     KEEP THEM COMMING 
* 
      LDB T1SID     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.
* 
B54   OCT 54
      SKP 
* 
*     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 
* 
      JMP STIDO     GO SET IT UP.  (RE-MATCH KEYWORD) 
      SKP 
*                   NOT 'DO'. DETERMINE WHETHER KEYWORD STATEMENT.
* 
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 T2SID     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 T2SID 
      STA T2SID 
      SZA           IF COUNT IS ZERO
      JMP STID5 
* 
      JSB EXN.F     EXAMINE NEXT CHAR 
      CPA B75       '='?
      JMP STINQ     YES IT IS EITHER ASSIGNMENT OR STMT. FUNCTION 
      SPC 1 
      JMP STID0     NO  MUST BE A KEY WORD STMT.
STI01 LDA T2SID     IF '=' AND '(' LEVEL =0 
* 
      SZA           THEN IT IS ASSIGNMENT OR STMT. FUNCTION 
      JMP STID5     WRONG LEVEL  TRY NEXT TOKEN 
* 
STINQ JSB MCC.F     SET UP TO RESCAN THE STMT.
      LDA T1STS     IT IS AN ASSIGNMENT OR A STMT. FUNCTION 
      SZA           EXACTLY ONE '(' BEFORE THE '='? 
      JMP FASS      NO MUST BE ASSIGNMENT 
* 
      CLB,INB       YES SET NO CROSS REF FLAG 
      STB F.NCR     SO THERE IS NO DUPLICATION. 
      JSB ISY.F     INPUT SYMBOL
      CLB           RESET NO CROSS REF FLAG TO 0. 
      STB F.NCR 
      JSB MCC.F     MOVE 1ST CARD TO CI 
      CLA           ASSUME IT'S A STATEMENT FUNCTION. 
      LDB F.IU
      CPB ARR       IS ITEM AN ARRAY? 
FASS  CCA           YES, IT MUST BE AN ASSIGNMENT STMT. 
      JMP STID1     GO DO THE PRE DISPATCH STUFF
* 
* 
* 
T1STS BSS 1         '(' FLAG  (=0 IF '(' EXISTED )
T2STS BSS 1         '(' COUNT AFTER = 
B42   OCT 42
B51   OCT 51
B75   OCT 75
ARR   OCT 600       F.IU=ARR
"DO"  ASC 1,DO
      SKP 
STID0 JSB MCC.F     RESTART SCAN. 
      JSB KWS.F     SEARCH FOR KEYWORD. 
      DEF KWFSD 
      SZA,RSS       GOT ONE ? 
      JMP STID2     NO. ERROR.
* 
      CLB,INB       CHECK FOR ELSE/ELSEIF/ENDIF:
      CPA ELORD     ELSE/ELSEIF,
      RSS 
      CPA EDORD     ENDIF,
      STB F.LSP     CAN GET HERE EVEN THOUGH NO STMT #. 
* 
STID1 LDB A         (B)=STATEMENT ORDINAL FOR F.FNS 
      STB F.STY     SAVE ORDINAL FOR TDO.F
      ERA           (E)=ODD/EVEN BYTE.
      RAL,ARS       FORM WORD OFFSET (MAY BE NEGATIVE)
      ADA DSHT      ADD ADDR OF STMT HIERARCHY TBL. 
      LDA A,I       (A)=WORD WITH HIERARCY. 
      SEZ,RSS       IF LEFT BYTE, 
      ALF,ALF       MOVE IT DOWN. 
      AND B377      (A)=STATEMENT HIERARCHY.
      JMP F.FNS     1ST. NON-SPECIFICATION CHECK. 
* 
STID2 LDA K10.      DON'T RECOGNIZE. ERROR 10.
      JSB ER.F
* 
STIDO JSB MCC.F     'DO', SPECIAL-CASE. 
      JSB RD2.F     POSITION AT 'O' OF 'DO'.
      LDA DOORD     ORDINAL.
      JMP STID1     TAKE FROM TABLE.
* 
STIEN LDA ENORD     'END', SPECIAL-CASE.
      JMP STID1     ORDINAL.
      SPC 1 
* 
DSHT  DEF SHT       STATEMENT HIERARCHY TABLE.
K10.  DEC 10
B47   OCT 47        ' 
B377  OCT 377 
T1SID NOP           NUMBER OF CHARS REMAINING 
T2SID NOP           PROCESSOR ENTRY POINT 
F.STY NOP           STATEMENT ORDINAL.
      SKP 
*         ********************* 
*         * READ 2 CHARACTERS * 
*         ********************* 
      SPC 1 
RD2.F NOP 
      JSB RD1.F     FIRST CHAR. 
      ALF,ALF       POSITION. 
      STA T1RD2     SAVE. 
      JSB RD1.F     SECOND CHAR.
      IOR T1RD2     MERGE.
      JMP RD2.F,I   EXIT. (A) = TWO CHARS.
* 
RD1.F NOP 
      JSB IC.F      GET CHAR. 
      CPA B40       (STRIP BLANKS, BUT READ $)
      JMP *-2 
      CPA B44       IF $, OR    
      RSS 
      CPA B15       C/R,
      JMP RD1.F,I   DON'T RE-READ.
      JSB UC.F      ELSE RE-READ TO MAP LOWER TO UPPER CASE.
      JSB ICH.F 
      JMP RD1.F,I   (A) = CHAR. 
* 
T1RD2 NOP 
B44   OCT 44        $ 
      SKP 
*         **************************
*         * PASS 1 ERROR EXIT CODE *
*         **************************
      SPC 1 
F.P1E CLA           ZERO STUFF OUT. 
      STA F.LFF     LOGICAL IF FLAG.
      STA F.SVL     SAVED F.L 
      STA F.T       NO. WDS IN STACK 1. 
      STA F.L       NO. WDS IN STACK 2. 
      STA F.DCF     DIM,COM,EQUIV FLAG. 
      JMP CRT00 
      SPC 2 
*         ******************************* 
*         * C/R TEST & STMT TERMINATION * 
*         ******************************* 
      SPC 1 
F.CRT CLA 
      STA F.DCF     RESET DIM,COM,& EQUIV FLAG
      LDA B15       C/R 
      JSB TCT.F     F.TC TEST 
CRT00 CLA           RESET NO-INPUT FLAG.
      STA F.NXN 
      LDA F.STB     WAS LAST STMT TRUE PART 
      SZA,RSS       OF A LOGICAL IF ? 
      JMP CRT01     NO. 
      LDA KK37      YES. DEFINE THE TWPE ENTRY. 
      JSB WS1.F 
      LDA F.STB 
      JSB WS1.F 
      CLA           AND ZAP F.STB.
      STA F.STB 
CRT01 LDA F.LSN     LAST STATEMENT HAD A NUMBER?
      SZA,RSS 
      JMP CRT02     NO. 
* 
      LDB F.SLF     WAS IT A EXECUTABLE ? 
      CPB K4
      JSB TDO.F     YES. CHECK FOR DO TERMINATOR. 
      LDB F.LSN     REMEMBER STMT #.
      CLA           THEN ZAP IT IN CASE ERROR.
      STA F.LSN 
      LDA F.SLF     STATEMENT LEVEL.
      CPA K8       FORMAT ? (A=8) 
      CCA,RSS       YES. A=-1.
      CLA,INA       NO.  A=+1.
      JSB CSN.F     CHECK THAT STMT # IS RIGHT TYPE.
CRT02 CLA 
      STA F.LFF     RESET THE LOGICAL IF FLAG.
      LDB F.DF      (DIRECTIVE FLAG)
      STA F.DF      RESET THE DIRECTIVE FLAG. 
      SZB,RSS       IF LAST WAS NOT A DIRECTIVE,
      STA F.LSF     RESET LAST STATEMENT FLAG 
      LDA F.$CC     DID LAST STATEMENT END DUE TO $ ? 
      SZA 
      JMP CRT03     YES.
* 
      JSB SNC.F     NO. START NEXT CARD.
      JMP F.BGN     INPUT A NEW STATEMENT 
* 
CRT03 STA F.CC      STATEMENT BREAK. RESTORE F.CC . 
      CLA           ZAP THE BREAK FLAG, 
      STA F.$CC 
      JSB SCP.F     SET UP FOR NEW STATEMENT. 
      JMP F.STS     NOW GO PROCESS THE STATEMENT. 
* 
K8    DEC 8 
KK37  BYT 1,45      DEFINE STMT # OPERATOR. 
      SKP 
*                 **********************
*                 * TERMINATE DO RANGE *
*                 **********************
      SPC 1 
*                   CALLED AFTER EACH LABELLED STATEMENT. 
*                   SEARCH DO TABLE FOR MATCHING STATEMENT NUMBERS. 
*                   ON A MATCH: IF AN OUTER 'DO' DIDN'T MATCH, ERROR, 
*                   ELSE GENERATE DO TERMINATION CODE.
* 
TDO.F NOP 
      STA T1DOP     SAVE THE CURRENT STATEMENT NUMBER 
      CCA           SET FLAG THAT IT'S THE INNERMOST. 
      STA T3DOP 
      LDB F.D       LOC OF LAST DO ENTRY IN DO TABLE
TDO01 STB T2DOP     SAVE DO TABLE POINTER 
      CLA 
      CPB F.DO      END OF DO TABLE SEARCH? 
      JMP TDO.F,I   YES  RETURN 
      LDA T1DOP     IS THIS STMNT NO. A DO TERMINAT?
      CPA B,I 
      RSS 
      JMP TDO02     NO. 
      LDB F.LSF     YES. LEGAL ?
      LDA K30       (ERROR #) 
      SZB 
      JSB ER.F      NO. ERROR.
      LDA KK45      YES. OUTPUT 'DO' TERMINATION OPCODE.
      JSB WS1.F 
      ISZ F.D       OUTPUT F.A CONTROL VARIABLE.
      LDA F.D,I 
      ISZ F.D 
      JSB WS1.F 
      LDA F.D,I     AND F.A OF TWPE FOR LOOP END CODE.
      JSB WS1.F 
      LDB T3DOP     AND F.A OF STATMENT IF INNER. 
      LDA F.LSN 
      SSB,RSS 
      CLA           OR ZERO IF NOT INNER. 
      JSB WS1.F     IF NONZERO, F.A OF STMT #, INNER LOOP.
      ISZ T3DOP     INNERMOST ? 
      RSS           (NO)
      JMP TDO03     YES. ANY STMT IS O.K. 
* 
      LDA F.D,I     NO. WAS THE TWPE ENTRY USED ? 
      LDA A,I 
      AND K8        F..E OF TWPE. 
      SZA,RSS 
      JMP TDO03     NOT USED. NO PROBLEM. 
* 
      LDB F.STY     USED. BETTER BE CONTINUE. 
      CPB COORD     WELL ?
      JMP TDO03     CONTINUE. ALL'S WELL. 
* 
      LDA K31       WARNING 31. 
      JSB WAR.F 
TDO03 ISZ F.D       MOVE PAST 3RD WORD OF POPPED FRAME. 
      RSS           ANOTHER IS STILL LEGAL. 
TDO02 STA F.LSF     SET LAST STMNT FLAG (ILL.DO TERM.)
      LDB T2DOP     ADVANCE TO NEXT STACK FRAME.
      ADB K3
      JMP TDO01 
* 
K30   DEC 30
KK45  BYT 3,55      OPCODE FOR 'DO' TERMINATION.
T1DOP NOP 
T2DOP NOP 
T3DOP NOP           -1 IFF IN INNERMOST.
      SKP 
*         ******************
*         * KEYWORD SEARCH *
*         ******************
      SPC 1 
*     SEARCHES FOR A MATCH TO THE KEYWORD STARTING WITH THE NEXT
*     CHARACTER.  KEYWORDS MAY CONTAIN LETTERS, ".", AND "=".  THE
*     TABLE OF KEYWORDS TO SEARCH CONSISTS OF THE ASCII VALUES
*     SEPERATED BY BLANKS AND TERMINATED BY TWO BLANKS.  THEREFORE, 
*     KEYWORDS MUST SOMETIMES START ON ODD BYTE BOUNDARIES.  THE
*     KEYWORDS MUST APPEAR IN ORDER OF LENGTH, SHORTEST FIRST.
*     MAXIMUM SIZE FOR ANY GIVEN KEYWORD IS 15 LETTERS. 
* 
*     ENTRY:  JSB KWS.F 
*             DEF <KEYWORDS>
*     EXIT:   (A) = ORDINAL OF KEYWORD IN TABLE, 1-N. 
*                   0 IF NOT FOUND. 
*             THE CURRENT CHARACTER (LAST READ) IS: 
*               1) LAST CHAR OF THE KEYWORD, IF FOUND.
*               2) CHARACTER WHICH WOULD HAVE MATCHED THE LONGEST 
*                  KEYWORD, IF NOT FOUND BUT ALL LETTERS. 
*               3) THE NON-LETTER WHICH STOPPED THE SCAN. 
      SPC 1 
*                   INITIALIZE. 
* 
KWS.F NOP 
      CLA,CLE       A=E=0.
      STA KWBUF     SET BUFFER EMPTY. 
KWS00 STA T0KWS     T0KWS = ORD OF CURRENT KEYWORD. 
      LDA DKWBF     T2KWS = ADDR BUFFER + LENGTH LAST KEYWORD.
      STA T2KWS 
      LDB KWS.F,I   (B) = WORD ADDRESS OF KEYWORD TABLE.
      ISZ KWS.F     (E=0) 
* 
*                   START COMPARING NEW KEYWORD.
* 
KWS01 ELB           MAKE IT A BYTE ADDRESS. 
      STB T1KWS     T1KWS = BYTE ADDRESS IN KEYWORD TABLE.
      LDA DKWBF     T3KWS = POINTER INTO BUFFER.
      STA T3KWS 
      ISZ T0KWS     BUMP THE ORDINAL. 
      SKP 
*                   LOOP THRU THE KEYWORD, COMPARING BYTES. 
* 
KWS02 LDA T1KWS     BYTE ADDR IN TABLE. 
      ISZ T1KWS 
      CLE,ERA       WORD ADDR & EVEN/ODD FLAG.
      LDA A,I       GET THE BYTE. 
      SEZ,RSS 
      ALF,ALF 
      AND B377
      STA T4KWS     T4KWS = DATA BYTE FROM TABLE. 
      CPA B40       BLANK ? 
      JMP KWS05     YES. DONE.
* 
      LDA T3KWS,I   DATA BYTE FROM BUFFER.
      SZA           AT END ?
      CPA B40       (BLANK OR ZERO) 
      RSS           (YES) 
      JMP KWS03     NO. 
* 
      JSB ICH.F     YES. READ NEW BYTE. 
      SZB           LETTER ?
      CLB,SEZ       (B=0) 
      RSS           NO. 
      JMP KWS07     YES. O.K. 
* 
      CPA "."       NO. ALLOW DOT (FOR .EQ. VS .EQV.) 
      JMP KWS07 
* 
      CPA B75       AND '=' (FOR I/O STATEMENTS)
      RSS 
      JMP KWS06     NEITHER. TRUE FAIL. 
* 
KWS07 DST T3KWS,I   YES. STORE IT & NEW ZERO WORD.
KWS03 ISZ T3KWS     ADVANCE IN BUFFER.
      CPA T4KWS     BYTES MATCH ? 
      JMP KWS02     YES. TRY NEXT BYTE. 
* 
*                   MISMATCH. ADVANCE TO BLANK AFTER KEYWORD IN TABLE.
* 
      LDB T3KWS     LAST KEYWORD HAD (T2KWS-DKWBF) LETTERS
      CMB,INB       WE HAVE EXAMINED (T3KWS-DKWBF) IN THE 
      ADB T2KWS     CURRENT ONE, SO WE CAN SKIP (T2KWS-T3KWS) 
      ADB T1KWS     SINCE CURRENT>LAST.  (B)=NEW BYTE ADDR. 
      CLE,ERB       CHANGE IT TO WORD ADDR, ODD/EVEN FLAG.
KWS04 LDA B,I       (A) = WORD WITH CHARACTER.
      SEZ,CME       ODD OR EVEN ? (NEXT IS OTHER) 
      INB,RSS       ODD.  BUMP WORD ADDR. 
      ALF,ALF       EVEN. RIGHT-JUSTIFY CHARACTER.
      AND B377      ISOLATE.
      CPA B40       BLANK ? 
      JMP KWS01     YES. LOOK FOR NEXT KEYWORD. 
      ISZ T2KWS     NO. NOTE NEW LONGER LENGTH. 
      JMP KWS04     KEEP LOOKING. 
      SKP 
*                   FOUND IT.  RETURN ORDINAL OR ZERO.
* 
KWS05 LDA T0KWS     (A) = ORDINAL.
      LDB T3KWS     WAS IT NULL ? 
      CPB DKWBF 
KWS06 CLA           YES. (A)=0. 
      JMP KWS.F,I   EXIT. 
* 
B40   OCT 40
"."   OCT 56
T0KWS NOP           ORDINAL OF CURRENT KEYWORD: 1,2,... 
T1KWS NOP           BYTE POINTER INTO KEYWORD TABLE.
T2KWS NOP           BUFFER ADDR + LENGTH LAST KEYWORD.
T3KWS NOP           ADDR NEXT WORD IN BUFFER. 
T4KWS NOP           DATA BYTE FROM KEYWORD TABLE. 
DKWBF DEF KWBUF     ADDR OF BUFFER. 
K6    DEC 6 
KWBUF BSS 16        BUFFER. (MAX LENGTH)+1
      SPC 2 
*         ******************************* 
*         * KEYWORD MATCH (IN PROGRESS) * 
*         ******************************* 
      SPC 1 
*     SAME AS KWS.F, BUT THE CONTENTS OF THE (NID) BUFFER ARE USED
*     AS THE FIRST PART OF THE KEYWORD.  THIS IS SO THAT A KEYWORD
*     PROCESSOR CAN DETECT AN OPTIONAL KEYWORD. 
* 
KWP.F NOP 
      LDA F.DNI     ADDR OF (NID) BUFFER. 
      LDB DKWBF     ADDR OF KEYWORD BUFFER. 
      JSB .MVW      COPY IT.
      DEF K6
      NOP 
      CLA,CLE       FOLLOW WITH ZERO. 
      STA KWBUF+6 
      LDB KWP.F     NOW JOIN KWS.F IN PROGRESS, 
      STB KWS.F 
      JMP KWS00     BUT WITH BUFFER ALREADY INIT. (A=E=0) 
      SKP 
*         *********************************** 
*         * KEYWORDS FOR STATEMENT DISPATCH * 
*         *********************************** 
      SPC 1 
KWFSD ASC 06,IF EMA $END ,  (DON'T RECOGNIZE 'END' HERE)
      ASC 23,CALL GOTO READ STOP REAL DATA THEN ELSE OPEN W,
      ASC 23,RITE PRINT PAUSE ENDIF CLOSE RETURN FORMAT REW,
      ASC 23,IND COMMON ASSIGN ENCODE DECODE ENDFILE INTEGE,
      ASC 23,R COMPLEX LOGICAL PROGRAM INQUIRE FUNCTION CON,
      ASC 23,TINUE EXTERNAL IMPLICIT DIMENSION BACKSPACE BL,
      ASC 23,OCKDATA SUBROUTINE EQUIVALENCE DOUBLEPRECISION,
      ASC 01, 
* 
K3    DEC 3 
ENORD EQU K3        END: +3 
DOORD DEC -2        DO:  -2 
ELORD DEC 11        ELSE & ELSEIF: 11 
EDORD DEC 16        ENDIF: 16 
COORD EQU B40       CONTINUE: 32
      SKP 
*         ***************************** 
*         * PROCESSOR HEIRARCHY TABLE * 
*         ***************************** 
      SPC 1 
*     ONE BYTE PER TABLE ENTRY, INDEXED BY KEYWORD ORDINAL, WHERE 
*     'DO' STATEMENTS, ASSIGNMENT STATEMENTS, AND STATEMENT FUNCTIONS 
*     HAVE ORDINALS OF -2, -1 AND ZERO RESPECTIVELY.
* 
*     THE HIERARCHY IS: 
* 
*  PROGRAM, FUNCTION, SUBROUTINE, BLOCK DATA = 0
*  IMPLICIT                             = 0 
*  SPECS: COM, DIMENSION, INTEGER, ETC. = 1 
*  DATA                                 = 2 
*  ARITHMETIC STATEMENT FUNCTIONS       = 3 
*  EXECUTABLE                           = 4 
*  END                                  = 5 
*  FORMAT                               = 8 
* 
*     AND SEGMENT F4.0 PROCESSES 0-1, WHILE F4.1 DOES 2-10. 
*     THE PROCESSORS ARE LOCATED IN THE APPROPRIATE SEGMENT,
*     AND THEIR ADDRESSES ARE CONTAINED IN THE TABLE 'F.PJT'
*     IN THE MAIN, INDEXED BY KEYWORD ORDINAL.
* 
* 
      BYT 4,4       DO, ASSIGNMENT STATEMENT. 
SHT   BYT 3,4       STATEMENT FUNCTION, IF. 
      BYT 1,5       EMA, END. 
      BYT 4,4       CALL, GOTO. 
      BYT 4,4       READ, STOP. 
      BYT 1,2       REAL, DATA. 
      BYT 4,4       THEN, ELSE. 
      BYT 4,4       OPEN, WRITE.
      BYT 4,4       PRINT, PAUSE. 
      BYT 4,4       ENDIF, CLOSE. 
      BYT 4,10      RETURN, FORMAT. 
      BYT 4,1       REWIND, COMMON. 
      BYT 4,4       ASSIGN, ENCODE. 
      BYT 4,4       DECODE, ENDFILE.
      BYT 1,1       INTEGER, COMPLEX. 
      BYT 1,0       LOGICAL, PROGRAM. 
      BYT 4,0       INQUIRE, FUNCTION.
      BYT 4,1       CONTINUE, EXTERNAL. 
      BYT 0,1       IMPLICIT, DIMENSION.
      BYT 4,0       BACKSPACE, BLOCKDATA. 
      BYT 0,1       SUBROUTINE, EQUIVALENCE.
      BYT 1,0       DOUBLEPRECISION.
      SKP 
*         *************** 
*         * PACK DIGITS * 
*         *************** 
      SPC 1 
*     ENTRY: (A)=TWO DIGIT DECIMAL NUMBER BINARIZED 
*     EXIT:  (A)=ASCII EQUIVALENT OF ENTRY (A)
      SPC 1 
PD.F  NOP 
      CLB 
      DIV K10 
      ADA B60 
      ADB B60       (B)=TEN'S DIGIT IN ASCII
      BLF,BLF 
      IOR B 
      JMP PD.F,I
      SPC 1 
K10   DEC 10
B60   OCT 60
      SKP 
*         ********************
*         * FORMAT PROCESSOR *
*         ********************
      SPC 1 
*                   INITIALIZE.  CHECK FOR LOGICAL IF, LEADING '('. 
* 
F.FMT LDB F.LFF     ON TRUE BRANCH OF LOGICAL IF ?
      LDA K50 
      SZB 
      JSB ER.F      YES. BITCH. 
* 
      JSB EXN.F     CHECK FOR '('.
      CPA B50       WELL ?? 
      JMP FMT01     O.K.
      LDA K9        NO. ERROR.
      JSB ER.F
* 
FMT01 CLB           SET PAREN LEVEL TO ZERO.
      STB T2FMT 
      LDA F.LSN     IF STATEMENT NUMBER,
      STA F.A       SET IT FOR PAK.F
      CCA           INITIALIZE PAK.F
      JSB PAK.F     (B=OFFSET=0)
      LDA F.LSN     STATEMENT # ? 
      SZA,RSS 
      JMP FMT02     NO. 
* 
      JSB FA.F      YES. FETCH ASSIGNS, 
      LDA F.AT      AND SEE IF ALREADY DEFINED. 
      CPA REL       WELL ?
      RSS           YES. ERROR. 
      JMP FMT10     NO. GO DEFINE IT. 
* 
      LDA K27       DOUBLE DEFINED, WARNING 27. 
      JSB WAR.F 
      CLA           ZAP STMT # SO NO CODE OUTPUT. 
      STA F.A 
      JMP FMT02     FIRST DEF HOLDS.
* 
FMT10 JSB DL.F      NOTE! PASS 1 USE OF F.RPL ! 
* 
*                   SCAN FORMAT. FIRST: GET NUMBER, IF ANY. 
* 
FMT02 CLA           SET IT TO ZERO. 
      STA T0FMT 
FMT03 JSB ICH.F     NEXT DIGIT. 
      JSB PAC.F     SEND IT TO PASS FILE. 
      LDA F.TC      (A) = CHAR. 
      ADA BM72      > '9' ? 
      SSA,RSS 
      JMP FMT04     YES. END OF DIGITS. 
      ADA K10       < '0' ?  (A=VALUE)
      SSA 
      JMP FMT04     YES. END OF DIGITS. 
      LDB T0FMT     NO. ADD THIS DIGIT IN.
      RBL,RBL 
      ADB T0FMT     5 * OLD #.
      RBL           10. 
      ADB A         ADD DIGIT.
      STB T0FMT 
      ASL 4         > 2047 ?
      SOS 
      JMP FMT03     NO. TRY FOR ANOTHER.
* 
      LDA K14       YES. COMPLAIN.
      JSB ER.F
      SKP 
*                   LOOK AT NON-DIGIT. PROCESS:  (  )  H  "  '
* 
FMT04 LDB F.TC      GET NEXT CHARACTER
      CPB "H"       'H' 
      JMP FMT05     YES 
      CPB B42       '"'?
      JMP FMT07 
      CPB B47       "'" ? 
      JMP FMT07 
* 
      LDA K9        (ERROR #) 
      CPB B15       C/R 
      JSB ER.F      YES. ERROR. 
* 
      CPB B50       THIS A '('? 
      ISZ T2FMT     YES.
      CPB B51       A ')'?
      CCA,RSS       YES. GO DECREMENT COUNT.
      JMP FMT02     NO. GO ON.
      ADA T2FMT 
      STA T2FMT 
      SZA           OUTER RIGHT PAREN ? 
      JMP FMT02     NO. GO ON.
      JSB ICH.F     YES. SHOULD TRANSFER THE C/R
      JMP FMT09     GO WRAP UP.  (F.CRT CATCHES IF NOT C/R.)
* 
*                   HOLLERITH FORMAT. TRANSFER ALL CHARACTERS.
* 
FMT05 LDB T0FMT     SET UP THE COUNT. 
      LDA K20       (ERROR #) 
      CMB,INB,SZB,RSS ZERO ?
      JSB ER.F      YES. ERROR. 
      STB T0FMT     NO. SAVE -(# CHARS) 
FMT06 JSB IC.F      NEXT !
      CPA B15       C/R ? 
      JSB ER.F      YES. ERROR 13.
      JSB PAC.F     NO. SEND IT.
      ISZ T0FMT     COUNT 'EM UP. 
      JMP FMT06     MORE. 
      JMP FMT02     DONE. 
* 
*                   QUOTE FORMATS.
* 
FMT07 STB T0FMT     SAVE TYPE OF QUOTE. 
FMT08 JSB IC.F      SEND ALL. 
      CPA B15       C/R ? 
      JSB ER.F      YES. ERROR. (A=13)
      JSB PAC.F     SEND IT.
      LDA F.TC      WAS IT MATCHING QUOTE ? 
      CPA T0FMT 
      JMP FMT02     YES, DONE.
      JMP FMT08     NO, GET MORE. 
      SKP 
*                   END OF FORMAT. CLEAN UP & EXIT. 
* 
FMT09 LDA KM2       FLUSH PAK.F BUFFER. 
      JSB PAK.F     (MAYBE NOTHING WRITTEN - O.K.)
      ADB F.RPL     UPDATE F.PRL
      STB F.RPL 
      JMP F.CRT     EXIT, CHECK FOR C/R.
* 
*                   SUB TO CALL PAK.F IF FORMAT HAS STMT #. 
* 
PAC.F NOP 
      LDB F.LSN     FORMAT HAS STMT # ? 
      SZB 
      JSB PAK.F     YES. DO IT. 
      JMP PAC.F,I   EXIT. 
      SPC 2 
T0FMT NOP 
T2FMT NOP 
BM72  OCT -72 
"H"   OCT 110       H 
KM2   DEC -2
K14   DEC 14
K20   DEC 20
K9    DEC 9 
K50   DEC 50
K27   DEC 27
REL   OCT 1000      F.AT = REL. 
* 
      END 
ASMB,Q,C
      HED INPUT GROUP FOR FTN4 COMPILER 
      NAM IC.F,8 92834-12001 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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
*     THIS MODULE CONTAINS THE CARD,CHARACTER,AND ITEM INPUT 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)
   EXT     F.A      ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY)
     EXT   F.ABT    ABORT COMPILE EXTRY 
     EXT   F.CC     CHARACTER COUNT 
       EXT F.CCW    FTN OPTION WORD 
   EXT     F.DNI    ADDRESS OF NID
       EXT F.END    END FLAG
       EXT F.FLN    FIRST LINE NUMBER IN MODULE.
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
     EXT   F.LNA    ADDRESS OF CURRENT LINE 
     EXT   F.LNL    LENGTH OF CURRENT LINE
     EXT   F.LNN    LINE # OF CURRENT LINE
     EXT   F.NCR    NO CROSS REF FLAG 
   EXT     F.NT     NAME TAG  0= VAR, 1=CONSTANT. 
   EXT     F.NTF    NAME TAG FLAG 
     EXT   F.NXN    NO INPUT FLAG 
       EXT F.SID    STATEMEXT ID PHASE FLAG 
     EXT   F.TC     NEXT CHARACTER
     EXT   F.TRM    TERMINATE COMPILE 
       EXT F.$CC    SAVED F.CC AT $ STATEMENT BREAK.
      SKP 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     AI.F     ASSIGN ITEM 
     EXT   ASC.F    CONVERT TO 4 ASCII DIGITS 
   EXT     BNI.F    CLEAR NID TO BLANKS 
       EXT CRP.F    OUTPUT CROSS-REFERENCE PAIR.
    EXT    CSN.F    CHECK STATEMENT NUMBER TYPE.
     EXT   ER.F     ERROR PRINT ROUTINE 
     ENT   EXN.F    EXAMINE NEXT CHARACTER
     ENT   IC.F     GET NEXT CHARACTER
     ENT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
      EXT  IDN.F    INPUT DO NOT ASSIGN (GET NEXT OPERAND)
     ENT   II.F     INPUT ITEM
     ENT   IIV.F    INPUT INTEGER VARABLE 
     ENT   INM.F    INPUT NAME
     ENT   IOP.F    INPUT OPERATOR
     ENT   ISN.F    INPUT STATEMEXT NUMBER
     ENT   ISY.F    INPUT SYMBOL
   EXT     ITS.F    INTEGER TEST
     ENT   IVN.F    INPUT VARIABLE/ARRAY NAME.
     ENT   MCC.F    RESET TO FIRST COLUMN OF STATEMEXT
   EXT     NCT.F    TEST FOR NOT A CONSTANT 
     ENT   PSI.F    PRINT SOURCE IMAGE. 
     EXT   PSL.F    PRINT SOURCE LINE.
     ENT   SCP.F    SAVE CURREXT STATPMEXT POSITION.
     ENT   SNC.F    START NEXT CARD SUBROUTINE
   EXT     TV.F     TAG VARIABLE
     ENT   UC.F     UNINPUT COLUMN
     EXT   WAR.F    ERROR COMMENT SUBROUTINE (WARNINGS) 
       EXT WS1.F    WRITE WORD TO PASS FILE #1. 
* 
*     COMPILER LIBRARY ROUTINES USED
* 
      EXT C.SAU     SOURCE FCB
      EXT RED.C     READ ROUTINE
      EXT WRT.C     WRITE FILE ROUTINE
      EXT C.SC0     SCRATCH FILE FCB
      EXT RWN.C     REWIND ROUTINE
* 
*     LIBRARY ROUTINES
* 
      EXT .MVW
      EXT IFBRK 
* 
      SUP 
* 
A     EQU 0 
B     EQU 1 
      SKP 
*                   GLOBALS, REFERENCED BY OFFSET FROM F.$IC
* 
      EXT F.$IC 
$     EQU F.$IC 
* 
EOSF  EQU 0         END-OF-STATEMENT FLAG.
FIRST EQU 1         FIRST-CARD FLAG. 0: CONTINUATION ILLEGAL. 
LINOL EQU 2         ADDR OF (ASCII) LINE # IN CURRENT BUFFER. 
CBA   EQU 3         ADDR OF CARD TEXT IN CURRENT BUFFER.
CRD#1 EQU 4         ADDR BUFFER # 1.
CD#1  EQU 5         CARD NUMBER (WITHIN STMT) FOR BFR #1. 
CRD#2 EQU 6         ADDR BUFFER # 2.
CD#2  EQU 7         CARD NUMBER (WITHIN STMT) FOR BFR #2. 
CD#   EQU 8         CURRENT CARD NUMBER.
DCD#  EQU 9         PTR TO CURRENT CARD BUFFER CARD NUMBER. 
CD#F  EQU 10        # CARDS IN CARD FILE. 
CD#P  EQU 11        CURRENT POSITION IN CARD FILE.
CICNT EQU 12        ADDR WORD COUNT IN CURRENT BUFFER.
MLIN  EQU 13        ADDR CLIB LINE NUMBER IN CURRENT BUFFER.
LIFCC EQU 14        COL # OF START OF 1ST CARD CURRENT STMT.
FTNF  EQU 15        FLAG THAT FTN DIRECTIVE IN PROCESS. 
* 
T0IC  NOP 
K73   DEC 73
DCD#1 DEF $+CRD#1   DEF TO CARD BUFFER ADDRESSES
B15   OCT 15        CARRAGE RETURN (USED AS END OF LINE)
B377  OCT 377 
B40   OCT 40
      SKP 
*         ****************
*         * INPUT COLUMN *
*         ****************
      SPC 1 
IC.F  NOP 
      LDB $+CD#     IF CURRENT CARD IS ZERO 
      SZB,RSS       THEN THERE IS NONE SO 
      JMP IC02      GO FIND ONE 
* 
      LDB F.CC      COLUMN COUNTER. 
      SZB           IF F.CC=0, OR 
      CPB K73       END OF CURRENT CARD,
      JMP IC01      THEN NOT EASY. (FASTEST TEST!)
* 
IC18  ADB KM1       (B) WAS F.CC HERE.
      CLE,ERB       (B)=(F.CC-1)/2 , E=ODD EVEN 
      ADB $+CBA     (B)=LOC. OF WORD CONTAINING CHAR. 
      LDA B,I       (A)=WORD CONTAINING CHAR. 
      SEZ,RSS       F.CC ODD ?
      ALF,ALF       YES, GET LEFT CHAR. 
      AND B377
      ISZ F.CC      F.CC=F.CC+1 
* 
IC06  STA F.TC      C/R, /, OR CHAR. FROM CARD BUFFER 
      JMP IC.F,I    EXIT
* 
IC01  SZB           F.CC=0 OR 73. WHICH ? 
      JMP IC10      73. GET ANOTHER CARD. 
* 
IC00  LDA B15       0. RETURN C/R.
      JMP IC06
* 
IC10  LDB F.NXN     NO INPUT FLAG SET?
      LDA B15 
      SZB 
      JMP IC06      YES  - SEND C/R 
* 
IC02  ISZ $+CD#     BUMP THE CARD NUMBER
      LDA $+CD#     GET THE REQUIRED CARD NUMBER
      LDB K7        SET THE COLUMN COUNTER
      CPA K1        BASED ON THE CARD NUMBER
      LDB $+LIFCC   FIRST CARD OF STMT. MAY START ELSE WHERE
      STB F.CC      SET IT
      LDB DCD#1     PICK A DEF TO BUFFER # 1
      CPA $+CD#1    REQUIRED CARD IN BUFFER 1?
      JMP INC       YES GO SET IT UP
* 
      ADB K2        INDEX TO THE NEXT BUFFER
      CPA $+CD#2    REQUIRED CARD IN BUFFER # 2?
      JMP INC       YES GO SET IT UP
* 
      LDA $+CD#1    CARD IS NOT IN MEMORY SO
      CMA,INA       FIGURE WHICH BUFFER WE WILL USE 
      ADA $+CD#2    USE ONE WITH LOWEST NUMBERED CARD IN IT 
      SSA,RSS       B CURRENTLY POINTS AT BUFFER 2 SO 
      ADB KM2       ADJUST IF IT IS TO BE 1.
      JSB SETCA     SET UP THE BUFFER ADDRESSES ECT.
* 
      LDA $+CD#P    GET THE CURRENT FILE COUNT
      INA           DOES THE BUFFER CONTAIN 
      CPA $+DCD#,I  THE NEXT CARD TO BE PUT IN THE CARD FILE? 
      CLA,INA,RSS   YES MUST WRITE IF ....
      JMP IC07      NO CARD NEED NOT BE WRITTEN 
* 
      CPA $+CD#     ... FIRST CARD  OR ...
      JMP IC03      (IT IS FIRST CARD)
* 
      LDA F.SID     ...  STILL SCANNING.
      SZA,RSS       WELL...?? 
      JMP IC07      NO  CARD NEED NOT BE WRITTEN
* 
IC03  JSB WRT.C     WRITE THE CARD IN THE 
      DEF C.SC0     CARD FILE 
      DEF $+CBA,I   SO WE CAN GET IT BACK 
      DEF K43 
      JMP PASER     IF ERROR ABORT
* 
      ISZ $+CD#F    STEP THE COUNT OF CARDS IN THE FILE 
      ISZ $+CD#P    AND THE CURRENT POSITION
* 
IC07  LDA $+CD#     NOW WE KNOW WHERE TO PUT IT SO FIGURE OUT 
      CMA,INA       WHERE TO GET IT 
      ADA $+CD#F    GET FROM SCRATCH FILE IF IT CONTAINS THE
      SSA,RSS       THE REQUIRED NUMBER   WELL? 
      JMP INF       YES GO READ IT IN 
* 
      JSB RD.F      READ A NEW CARD 
      JMP IC08      GO CHECK FOR EOS ECT. 
* 
* 
INC   JSB SETCA     SET UP THE CURRENT BUFFER 
      JMP IC08      AND GO CHECK FOR EOS ECT. 
* 
* 
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
* 
KM1   DEC -1
KM2   DEC -2
K1    DEC 1 
K3    DEC 3 
      SKP 
*     **********************
*     *  CARD IMAGE INPUT  *
*     **********************
      SPC 1 
RD.F  NOP           READ ROUTINE
RD00  JSB IFBRK     CHECK IF HE HAS HAD ENOUGH
      DEF *+1 
      SSA           WELL
      JMP BREAK     YES GO QUIT 
* 
      JSB RED.C     READ SOURCE FILE
      DEF C.SAU 
      DEF $+CBA,I 
      DEF K40       80 CHARACTERS 
      JMP F.TRM     ERROR ON READ  ERROR 98 
      SSB           EOF ? 
      JMP F.TRM     YES, GO WRAP IT UP. 
* 
      STA $+MLIN,I  SAVE THE LINE COUNT FROM READ 
      ADB K3        ADD SPACE FOR LINE # TO LENGTH AND
      STB $+CICNT,I SAVE WORD COUNT IN WD 41 OF CI
* 
      LDA B         COMPUTE # WDS LEFT IN CARD BUFFER.
      CMB           -(LENGTH+3)-1 
      ADB K43       (40-LENGTH)-1 = (AMT LEFT)-1
      SSB           IF NONE 
      JMP IC134     SKIP FILL 
* 
      STB T0IC      SAVE COUNT   (ZERO IF ONE WD TO FILL) 
      ADA $+LINOL   ADDRESS OF FIRST UNUSED WORD
      LDB LINO      FILL WITH 
      STB A,I       BLANKS
      STA B         SET TO MOVE REST INTO PLACE 
      INB           A= FROM  B= TO
      JSB .MVW      MOVE WORDS
      DEF T0IC
      NOP 
* 
IC134 LDA KM40      CHECK FOR BLANK CARD: 
      STA T0IC      COUNT 40 WORDS, 
      LDB $+CBA     STARTING HERE.
IC136 LDA B,I       CURRENT WORD. 
      CPA LINO      BLANK ? 
      INB,RSS       YES. ADVANCE TO NEXT & SKIP.
      JMP IC138     NO. NON-BLANK CARD. 
* 
      ISZ T0IC      COUNT. 40 YET ? 
      JMP IC136     NO. GO ON.
* 
      LDA F.END     YES. BLANK. BETWEEN MODULES ? 
      SZA,RSS 
      JMP RD06      NO. TREAT AS COMMENT. 
      JMP RD03      YES. IGNORE THE CARD. 
* 
IC138 LDA $+MLIN,I  GET THE LINE # PASSED IN
      SSA           IF NEGATIVE,
      JMP RD06      TREAT CARD AS A COMMENT 
* 
      LDA $+CD#     STUFF THE CURRENT CARD NUMBER 
      STA $+DCD#,I  IN THE BUFFER FLAG
* 
      LDB $+FTNF    FTN FLAG SET? (IT IS 1 IF SO) 
      SZB 
      JMP IC141     YES. CONTROL CARD 
* 
      LDA $+CBA,I 
      CPA KK10      IF CARD STARTS WITH '$ '
      JMP F.TRM     GO WIND IT UP 
* 
      AND KK07.     (A)HI=1ST CHAR. OF CARD BUFFER
      CPA "C"       IS IT A 'C' ? 
      RSS 
      CPA "C"L      OR LOWER CASE ? 
      JMP RD06      YES, A COMMENT CARD 
      CPA KK06      '*' ALSO COMMENT. 
      JMP RD06
* 
      CPA "D"       OPTIONAL CARD?
      RSS 
      CPA "D"L
      JMP RD05      YES GO CHECK IF OPTION ENABLED
* 
      CPA KK09      DOES IT START WITH '$' ?
      JMP RD02      YES. NOT A CONTINUATION.
* 
RD04  LDA $+CBA     COMPUTE ADDRESS 
      ADA K2        OF THE SIXTH COLUMN 
      LDA A,I       AND GET IT
      AND B377      (A)LO=CI(6) 
      LDB K7        7 
      CPA B60 
      RSS           "0".
      CPA B40 
RD02  CLB,INB,RSS 
      CLA,RSS       SET EOSF (END OF STATEMENT FLAG)
      LDA $+CD#     TO ZERO (NOT END) OR CARD # IF END
      STA $+EOSF
      STB F.CC      SET THE COLUMN POINTER
      ISZ $+FIRST   ALLOW CONTINUATIONS AFTER THIS STMT.
      SZA           CONTINUATION ?
      JMP RD.F,I    NO. DON'T PRINT IT. 
* 
      JSB PSI.F     YES. PRINT. 
      CLB,INB       IF CONTINUATION NOT ALLOWED,
      CPB $+FIRST 
      CLA,RSS       (ERROR) 
      JMP RD.F,I    ALLOWED. EXIT.
* 
      STA F.END     THEN ERROR. CLEAR END FLAG, 
      LDA K90       AND SET ERROR NUMBER. 
      JSB ER.F      
*           
IC141 STB F.CC      F.CC=1. 
      CLA 
      STA $+FTNF    CLEAR THE FTN FLAG
      STA $+EOSF    KEEP READING (WELL, START)
      JMP RD.F,I    DONE. DON'T PRINT IT. 
* 
RD05  LDA F.CCW     CHECK THE D BIT 
      AND B100
      SZA           SKIP IF TO BE TREATED AS COMMENT
      JMP RD04      D IS SET  TREAT AS STD. STMT. 
* 
RD06  JSB PSI.F     PRINT COMMENT CARD. 
RD03  JSB ULN.F     UPDATE LINE # FOR PASS 2. 
      JMP RD00      AND READ ANOTHER CARD 
* 
"D"   BYT 104,0 
"D"L  BYT 144,0 
KM40  DEC -40 
      SPC 1 
* 
INF   LDA $+CD#     CHECK IF A REWIND IS NEEDED 
      CMA,INA       IT IS IF REQUESTED CARD IS
      ADA $+CD#P    LESS THAN OR EQUAL TO CURRENT POSITION
      SSA,RSS       WELL? 
      JSB RWCDF     YES  REWIND THE CARD FILE 
      JSB RED.C     READ CARD FROM THE SAVE FILE
      DEF C.SC0 
      DEF $+CBA,I 
      DEF K43 
      JMP PASER     ABORT IF ERROR
* 
      ISZ $+CD#P    STEP THE CURRENT POSITION ON THE SAVE FILE
      LDA $+CD#P    CHECK IF THIS IS THE REQUIRED CARD
      CPA $+CD#     WELL? 
      CLB,RSS       YES SKIP OUT
      JMP INF       NO  READ AGAIN
* 
      STA $+DCD#,I  SET BUFFER FLAG TO SHOW CARD IS HERE
* 
IC08  LDA $+EOSF    CHECK IF THIS IS THE END OF STATEMENT CARD
      CPA $+CD#     WELL? 
      CLA,RSS       YES  SET UP TO SEND A C/R 
      JMP IC09      NO. GO UPDATE XREF LINE & GET CHAR. 
* 
      STA F.CC      END OF STATEMENT SET F.CC TO ZERO AND 
      JMP IC00      GO PICK A C/R. (F.CC STAYS ZERO)
* 
IC09  LDA $+MLIN,I  LINE NUMBER.
      STA F.LNN 
      LDB F.CC      SET UP FOR IC18.
      JMP IC18      NOW GO GET CHAR.
      SPC 1 
BREAK LDA K96       SEND THE BREAK ERROR MESSAGE
      JMP F.ABT     AND EXIT
PASER LDA K99       ERROR ON CARD FILE. 
      JMP F.ABT 
* 
K96   DEC 96
K99   DEC 99
      SPC 1 
K7    OCT 7 
KM7   DEC -7
K2    DEC 2 
K40   DEC 40
K41   DEC 41
K90   DEC 90
KK06  BYT 52,0      '*' IN HIGH BYTE. 
KK07. OCT 177400
"C"   BYT 103,0     'C' IN HIGH BYTE. 
"C"L  BYT 143,0     SAME BUT LOWER CASE.
KK09  BYT 44,0      '$' IN HIGH BYTE. 
KK10  ASC 1,$       '$ '
B100  OCT 100 
      SPC 1 
LINO  ASC 1,        BLANKS FOR FILL ROUTINE 
      SKP 
*        ********************** 
*        * PRINT SOURCE IMAGE * 
*        ********************** 
      SPC 1 
*                   SET UP LINE ADDR, LENGTH, NUMBER. 
* 
PSI.F NOP 
      LDA $+CBA     SET LINE ADDRESS, LENGTH IN PSL.F 
      STA F.LNA 
      LDA $+CICNT,I 
      ADA KM3       (DON'T PASS ASCII LINE #) 
      SZA,RSS       IF ZERO-LENGTH, 
      INA           CHANGE TO ONE WORD. 
      STA F.LNL 
      JSB ULN.F     UPDATE LINE #.
* 
*                   IF Q.OR.(M&L).OR.(M&.NOT.COMMENT),PUT IN PASS FILE. 
* 
      LDA F.CCW 
      AND B4002     'M' OR 'Q' OPTIONS ?
      SZA,RSS 
      JMP PSI03     NO. DON'T WRITE.
* 
      LDA F.CCW     -Q,+M,-L ?
      AND B4003 
      CPA K2
      RSS           YES, CHECK FOR COMMENT. 
      JMP PSI01     NO, PASS COMMENTS THRU TOO. 
* 
      LDA $+CBA,I   GET THE FIRST CHARACTER 
      AND KK07.     IF 'C' BUT NO 'Q' OPTION
      CPA "C"       THEN
      RSS 
      CPA "C"L
      JMP PSI03     DON'T KEEP IT 
* 
PSI01 LDA F.LNL     COMBINE COUNT & OPERATOR. 
      ALF,ALF 
      IOR K28 
      JSB WS1.F     & WRITE.
      LDA F.LNL     # WDS.
      CMA,INA 
      STA T1PSI 
      LDA $+CBA     ADDR. 
      STA T2PSI 
PSI02 LDA T2PSI,I   OUTPUT IT.
      JSB WS1.F 
      ISZ T2PSI 
      ISZ T1PSI 
      JMP PSI02 
      JMP PSI04     DONE. 
      SKP 
PSI03 LDA K29       JUST LINE BREAK.
      JSB WS1.F 
* 
*                   IF 'L', BUT NOT 'Q' OR 'M', PRINT IT. 
* 
PSI04 LDA F.CCW     CHECK IF WE ARE TO LIST IT
      AND B4003     Q,M,L OPTIONS.
      CPA K1        IS IT -Q,-M,+L ?
      CLE,RSS       YES.  (E=0 FOR ASC.F) 
      JMP PSI05     NO.  GO CHECK 'D'.
* 
      LDA T0PSI     LINE NUMBER.
      JSB ASC.F     CONVERT TO ASCII CHARS
      SWP           SWITCH SO WE CAN USE THE DST
      STB T1PSI     SAVE 3RD & 4TH CHARS. 
      RRR 8         CHANGE TO '4123', 
      AND B377      THE REPLACE THE '4' WITH BLANK. 
      IOR B20K
      DST $+LINOL,I SET '-123' IN THE CURRENT BUFFER
      LDA T1PSI     NOW GET THE 4TH DIGIT,
      AND B377
      IOR B20K      AND APPEND A BLANK, 
      ALF,ALF       AFTER IT. 
      LDB $+LINOL   NOW PUT IT AFTER THE FIRST THREE. 
      ADB K2
      STA B,I       TO FORM: -1234-  , THREE WORDS. 
      LDA $+CICNT,I # OF WORDS IN IMAGE 
      LDB $+LINOL   LOC OF LINE # 
      JSB PSL.F     LIST THE CARD 
* 
*                   IF 'D' IN COLUMN 1, CHANGE GO BLANK.
* 
PSI05 LDA $+CBA,I   COLUMNS 1 & 2.
      AND KK07.     UPPER CHAR. 
      CPA "D"       WAS IT "D" ?
      RSS 
      CPA "D"L
      RSS 
      JMP PSI.F,I   NO. EXIT. 
* 
      XOR $+CBA,I   YES. CHANGE TO BLANK. (A)=LOWER.
      IOR B20K      LOWER CHAR .OR. UPPER BLANK.
      STA $+CBA,I 
      JMP PSI.F,I   RETURN
      SPC 2 
KM3   DEC -3
K28   DEC 28
K29   DEC 29
K43   DEC 43
B4002 OCT 4002
B4003 OCT 4003
B20K  OCT 20000     BLANK IN UPPER BYTE.
T0PSI NOP           LINE #. 
T1PSI NOP           COUNTER FOR OUTPUT. 
T2PSI NOP           POINTER FOR OUTPUT. 
      SKP 
*        **************************** 
*        * SET UP TO RESCAN THE STMT *
*        **************************** 
      SPC 1 
MCC.F NOP 
      CLA           SET THE CURRENT CARD TO ZERO
      STA $+CD#     TO FOURCE RESCAN
      STA F.SID     CLEAR THE SCAN SWITCH 
      LDB $+LIFCC   GET START OF CARD COLUMN
      CPB K1        IF IT IS 1 THEN 
      LDB K7        CHANGE TO 7 (STMT. # PICKED ON FIRST SCAN)
      STB $+LIFCC   SET THE INITIAL COLUMN
      JMP MCC.F,I   RETURN
      SPC 2 
*         ********************************************* 
*         * SET CURRENT POSITION AS START OF STATEMENT* 
*         ********************************************* 
      SPC 1 
SCP.F NOP 
      LDA $+CD#     GET THE NUMBER OF THE NEW FIRST CARD
      LDB F.CC      ALSO SAVE THE COLUMN POSITION 
      JSB CCB.F     CLEAR THE CARD BUFFER 
      JMP SCP.F,I   RETURN
      SPC 2 
*         ****************************
*         * SET UP FOR NEW STATEMENT *
*         ****************************
      SPC 1 
SNC.F NOP 
SCN1  LDA $+EOSF    IF LAST CARD OF PRIOR STMT. 
      SZA           NOT READ
      JMP SCN2
      ISZ $+CD#     STEP THE CARD NUMBER AND
      JSB RD.F      READ
      JMP SCN1      UNTIL IT IS READ
* 
SCN2  CLB,INB       SET THE RESET LOCATION
      JSB CCB.F     CLEAR THE CARD BUFFER 
      CLA 
      STA $+EOSF    CLEAR THE END OF STMT. FLAG 
      JSB IC.F      MAKE SURE LINE IS SET UP. 
      JSB UC.F
      LDA F.TC      IF LINE STARTS WITH $,
      CPA "$" 
      JMP SNC3      THEN DIRECTIVE.     
      JSB PSI.F     ELSE PRINT IT NOW.
      JMP SNC.F,I   RETURN
* 
SNC3  CLA           DIRECTIVE. DON'T PRINT, 
      STA $+FIRST   AND DON'T ALLOW CONTINUATIONS.
      JSB ULN.F     UPDATE LINE NUMBER, THOUGH. 
      JMP SNC.F,I 
* 
"$"   OCT 44        $ 
      SKP 
*         ************************
*         * REWIND THE CARD FILE *
*         ************************
      SPC 1 
RWCDF NOP           ROUTINE TO REWIND THE CARD FILE 
      JSB RWN.C     REWIND THE CARD FILE
      DEF C.SC0     AND CLEAR ITS COUNTS
      JMP PASER     ABORT IF ERROR
      CLA 
      STA $+CD#P    RESET THE CURRENT POSITION POINTER
      JMP RWCDF,I   RETURN
      SPC 2 
*         ****************************
*         * CLEAR CARD FILE & BUFFER *
*         ****************************
      SPC 1 
CCB.F NOP           ROUTINE TO CLEAR THE CARD FILE AND BUFFERS
      STB $+LIFCC   SET THE RESET COLUMN
      CLB,CLE       SET THE NO CARD PRESENT FLAG IN B 
      STB $+CD#     SET INITIAL CARD NUMBER 
      CPA $+CD#1    IS THIS CARD IN BUFFER 1 OR 2?
      CCE           IT IS IN 1
      CLA,SEZ,INA,RSS ARRANGE AN INITIAL CARD # FLAG
      SWP           SWAP IF NEEDED
      STA $+CD#1    THE FLAGS 
      STB $+CD#2    AS REQUIRED 
      JSB RWCDF     REWIND THE CARD BUFFER
      STA $+CD#F    CLEAR ITS COUNT 
      JMP CCB.F,I   RETURN
      SPC 2 
*         **********************
*         * UPDATE LINE NUMBER *
*         **********************
      SPC 1 
ULN.F NOP 
      LDA $+MLIN,I  CARD COUNT
      SSA           IF NEGATIVE 
      CMA,INA       SET POSITIVE
      STA T0PSI     SAVE FOR LIST.
      LDB F.FLN     FIRST LINE # ?
      SZB,RSS 
      STA F.FLN     YES. REMEMBER IT FOR PASS 2.
      JMP ULN.F,I   EXIT. 
      SKP 
*         *********************************** 
*         * INPUT CHARACTER, DETERMINE TYPE * 
*         *********************************** 
* 
*     ON RETURN A=F.TC=CHARACTER
*               B=CHAR IF NON-DIGIT, ELSE 0 
*               E=1 IF DELIMITER, ELSE 0 FOR ALF,NUM. 
*               O=1 IF NON-LETTER, ELSE 0 FOR ALPHA.
      SPC 1 
ICH.F NOP 
ICH01 JSB IC.F      INPUT COLUMN
      CPA B40       IS CHARACTER A BLANK? 
      JMP ICH01     YES. GET ANOTHER CHARACTER
* 
      STO           ASSUME NON-LETTER, O=1. 
      CPA "!"       COMMENT ESCAPE ?
      RSS           (YES) 
      JMP ICH05     NO. 
* 
      LDA K73       YES. FORCE END-OF-LINE. 
      STA F.CC
      JMP ICH01     AND GO FETCH THE C/R. 
* 
ICH05 CPA "$"       STATEMENT BREAK ? 
      CLA,RSS       (YES) 
      JMP ICH02     NO. 
* 
      LDB F.CC      YES. SAVE F.CC, 
      STB F.$CC 
      STA F.CC      AND SET IT TO ZERO (END OF STATEMENT).
      JMP ICH01     GO GET C/R TO RETURN. 
* 
ICH02 LDB A         SET B=CHAR. 
      ADA BM60      CHAR-60B
      CCE,SSA       E=1.
      JMP ICH04     F.TC .LT. "0"   [0,57B] 
* 
      ADA BM12      CHAR-72B
      SSA 
      CLB,CLE,RSS   F.TC IS A DIGIT [60B,71B]   (E=0) 
* 
      ADA KM7       CHAR-101B 
      SSA           (IF DIGIT, SKIPS TO HERE, A<0, E=0) 
      JMP ICH04     NON-ALPHANUM.   [72B,100B]
* 
      ADA BM32      CHAR-133B 
      SSA 
      JMP ICH03     UPPER CASE.     [101B,132B] 
* 
      ADA KM6       CHAR-141B 
      SSA 
      JMP ICH04     NON-ALPHANUM.   [133B,140B] 
* 
      ADA BM32      CHAR-173B 
      SSA,RSS 
      JMP ICH04     NON-ALPHANUM.   [173B,177B] 
* 
      ADA B133      LOWER CASE.     [141B,172B] 
      STA F.TC      FOLD TO UPPER:  CHAR-40B
      LDB A         SET NEW (B)=CHAR. 
ICH03 CLE           LETTER.  (E) = 0. 
      CLO           AND      (O) = 0. 
ICH04 LDA F.TC      CHAR. JUST INPUT
      JMP ICH.F,I   EXIT. 
* 
BM60  OCT -60 
BM32  OCT -32 
BM12  OCT -12 
B133  OCT 133 
"!"   BYT 0,41
      SKP 
*         ******************
*         * UNINPUT COLUMN *
*         ******************
      SPC 1 
UC.F  NOP 
      LDA F.CC      F.CC=F.CC-1 
      SZA,RSS       UNLESS F.CC=0,
      JMP UC.F,I    INWHICHCASE LEAVE IT ALONE. 
* 
      CMA,INA       DO IT THIS WAY SO THAT
      CMA           THE 'E' BIT IS PRESERVED. 
      STA F.CC      (SO EXN.F RETURNS PROPER FLAGS.)
      JMP UC.F,I
      SPC 2 
*         **************************
*         * EXAMINE NEXT CHARACTER *
*         **************************
      SPC 1 
EXN.F NOP 
      JSB ICH.F     INPUT CHARACTER 
      JSB UC.F      UNINPUT COLUMN
      LDA F.TC      RETURN NEXT CHAR
      JMP EXN.F,I   RETURN NFL IN B 
      SKP 
*         **************
*         * INPUT ITEM *
*         **************
      SPC 1 
II.F  NOP 
      JSB EXN.F       STRIP OFF BLANKS PRECEDING ITEM 
      JSB IDN.F     INPUT DNA 
      SZA             F.IM=0, POSSIBLE ERROR
      CPA TWPE      ALSO IF PSUDO 
      JMP II.F,I
* 
      JSB AI.F        ASSIGN ITEM 
      STA T2II       SAVE F.IM
      LDA F.NT
      IOR F.NCR 
      SZA,RSS       IS NAME TAG = 0?
      JSB CRP.F     YES, BUILD CROSS REFERENCE PAIR 
      LDA T2II      RETURN F.IM 
      JMP II.F,I
* 
T2II  NOP 
K24   DEC 24
TWPE  OCT 40000 
ARR   OCT 600       F.IU=ARR. 
      SPC 2 
*         ***************************** 
*         * INPUT VARIABLE/ARRAY NAME * 
*         ***************************** 
      SPC 1 
IVN.F NOP 
      JSB INM.F     FIRST, MUST BE A NAME.
      LDA F.IU      THEN: IF NOT ALREADY ARRAY, 
      CPA ARR 
      RSS 
      JSB TV.F      FORCE IT TO BE A VARIABLE.
      JMP IVN.F,I   DONE. 
      SKP 
*         **************
*         * INPUT NAME *
*         **************
      SPC 1 
INM.F NOP 
      JSB IOP.F     INPUT OPERAND 
      LDA K24 
      LDB F.NT      IS OPERAND A NAME?
      SZB 
      JSB ER.F      NO. GRIPE 
      LDA F.IM      YES, (A)=F.IM OF THE OPERAND
      JMP INM.F,I 
      SPC 2 
*         ****************
*         * INPUT SYMBOL *
*         ****************
      SPC 1 
ISY.F NOP 
      CLA,INA 
      STA F.NTF     SET NO-TAG FLAG 
      JSB INM.F     INPUT NAME
      JMP ISY.F,I 
      SPC 2 
*         **************************
*         * INPUT INTEGER VARIABLE *
*         **************************
      SPC 1 
IIV.F NOP 
      JSB IOP.F     INPUT OPERAND 
      JSB TV.F      TAG VARIABLE
      JSB ITS.F     INTEGER TEST
      JSB NCT.F     NON-CONSTANT TEST 
      JMP IIV.F,I 
      SPC 2 
*         ***************** 
*         * INPUT OPERAND * 
*         ***************** 
      SPC 1 
IOP.F NOP 
      JSB II.F      INPUT ITEM
      SZA 
      JMP IOP.F,I   (A)=F.IM OF THE OPERAND 
      LDA K17 
      JSB ER.F      DELIMITER FOUND WHEN OPERAND EXPECTED 
* 
K17   DEC 17
      SKP 
*         **************************
*         * INPUT STATEMENT NUMBER *
*         **************************
* 
*      ENTER WITH A = TYPE: -1 = FORMAT.
*                            0 = DON'T CARE.
*                           +1 = NON-FORMAT.
      SPC 1 
ISN.F NOP 
      STA T3ISN     SAVE TYPE.
      JSB BNI.F     CLEAR NID TO BLANKS 
      LDA K64       '@' 
      LDB F.DNI     SET UP POINTER TO LAST CHAR STORED. 
      STB T2ISN 
      STA B,I       SET FIRST WORD TO '@' 
      LDA KM6 
      STA T1ISN     T1=-6 
      LDA F.CC      ARE WE READING THE DEFINITION,
      ADA KM7       OR A REFERENCE ?
      SSA,RSS 
      JMP ISN04     REFERENCE.  (F.CC > 6)
* 
*                   DEFINITION IN COL 1-5.
* 
ISN01 JSB IC.F      READ ANOTHER CHAR.
      LDA F.CC      IF IT WAS IN COL 6, 
      CPA K7
      JMP ISN06     THEN DONE.
* 
      LDA F.TC      IF BLANK, 
      CPA B40 
      JMP ISN01     THEN SKIP IT. 
* 
      ADA BM60      DIGIT ? 
      SSA           FIRST, < "0" ?
      JMP ISN09     YES. ERROR. 
* 
      ADA BM12      THEN > "9" ?
      SSA,RSS 
      JMP ISN09     YES. ERROR. 
* 
      LDA F.TC      DIGIT. RESTORE F.TC 
      CPA B60       IF A ZERO,
      RSS 
      JMP ISN02     (NO)
* 
      LDB T2ISN     IS IT A LEADING ZERO ?
      CPB F.DNI 
      JMP ISN01     YES. SKIP IT. 
* 
ISN02 ISZ T2ISN     NORMAL DIGIT, SAVE IT.
      STA T2ISN,I 
      JMP ISN01     GO FOR MORE.
* 
*                   ERROR IN STATEMENT #. 
* 
ISN09 LDA B40       ERROR # 32. 
      JSB ER.F
      SKP 
*                   REFERENCE AFTER COL 6.
* 
ISN04 JSB ICH.F     INPUT CHAR. 
      SZB           DIGIT ? 
      JMP ISN07     NO. DONE. 
* 
      CPA B60       ZERO ?
      RSS 
      JMP ISN05     (NO)
* 
      LDB T2ISN     YES. LEADING ?
      CPB F.DNI 
      JMP ISN04     YES. SKIP IT. 
* 
ISN05 ISZ T1ISN     NORMAL DIGIT.  SIXTH ONE ?
      RSS           NO. 
      JMP ISN09     YES. ILLEGAL STMT #.
* 
      ISZ T2ISN     STORE DIGIT INTO NID BUFFER 
      STA T2ISN,I 
      JMP ISN04     AND GO FOR MORE.
* 
*                   GOT THE WHOLE NUMBER. ENTER IN SYMBOL TABLE.
* 
ISN06 JSB EXN.F     FOR DEFINITION, PEEK AT NEXT CHAR.
ISN07 LDB T2ISN     ALL ZEROES ?
      CPB F.DNI 
      JMP ISN09     YES. ERROR. 
* 
      CLA 
      STA F.IU      F.IU=0
      STA F.NT      F.NT=0
      STA F.IM      F.IM=0
      CLA,INA       SET THE NO-TAG FLAG.
      STA F.NTF 
      JSB AI.F      ASSIGN ITEM 
      JSB CRP.F     BUILD CROSS REFERENCE PAIR
      LDA T3ISN     TYPE. 
      LDB F.A 
      SZA           DO WE CARE ?
      JSB CSN.F     YES. CHECK IT OUT.
      LDA F.IM      RETURN F.IM IN (A)
      JMP ISN.F,I 
* 
T1ISN BSS 1         COUNT FOR NO. OF DIGITS 
T2ISN BSS 1         NID BUFFER POINTER
T3ISN BSS 1         TYPE. 
B60   OCT 60
K64   DEC 64        "@" 
KM6   DEC -6
* 
      END 
ASMB,Q,C
      HED SCANNER FOR FTN4X.
      NAM IDN.F,8 92834-12001 REV.2030 800820 
* 
*************************************************************** 
* (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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  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)
*                 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      ASSIGNMENT TABLE ADDR OF CURRENT ENTRY. 
       EXT F.CCW    FTN OPTION WORD 
   EXT     F.CSL    CHARACTER STRING LENGTH, CURRENT F.A
       EXT F.DID    ADDRESS OF F.IDI
   EXT     F.DNI    ADDRESS OF NID
      ENT  F.DPK    DEF TO F.PAK BUFFER.
       EXT F.DTY    IMPLICIT TYPE TABLE 
      ENT  F.EIM    EXPECTED ITEM MODE. 
       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.NT     NAME TAG  0= VAR, 1=CONSTANT. 
       EXT F.RPL    PROGRAM LOCATION COUNTER
       EXT F.S2T    TOP    OF STACK 2 
       EXT F.SID    STATEMEXT ID PHASE FLAG 
      ENT  F.SIM    SAVED ITEM MODE (NEGATIVE CONSTANTS)
       EXT F.SLF    STATEMENT LEVEL FLAG. 
      ENT  F.STC    SAVED F.TC (NEGATIVE CONSTANTS) 
       EXT F.SXF    COMPLEX CONSTANT FLAG 
     EXT   F.TC     NEXT CHARACTER
* 
*     ENT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     AI.F     ASSIGN ITEM 
   EXT     BNI.F    CLEAR NID TO BLANKS 
   EXT     CDI.F    CLEAR IDI ROUTINE 
   EXT     DL.F     DEFINE LOCATION SUBROUTINE
     EXT   ER.F     ERROR PRINT SUBROUTINE
   EXT     ESC.F    ESTABLISH CONSTANT SUBROUTINE 
     EXT   EXN.F    EXAMINE NEXT CHARACTER. 
     EXT   IC.F     GET NEXT CHARACTER
     EXT   ICH.F    GET NEXT NON BLANK CHAR. AND TYPE IT
      ENT  IDN.F    INPUT DO NOT ASSIGN (GET NEXT OPERAND)
      ENT  ISC.F    INPUT STRING CONSTANT.
       EXT KWS.F    KEYWORD SEARCH. 
       EXT MVW.F    INTERNAL MOVE WORDS.
      ENT  PAK.F    PACK & OUTPUT ASCII DATA. 
      ENT  RP.F     INPUT ')' 
   EXT     TCT.F    TEST (A) = F.TC ELSE ER 28
     EXT   UC.F     UNINPUT COLUMN. 
     EXT   WAR.F    ERROR COMMEXT SUBROUTINE (WARNINGS) 
       EXT WS1.F    WRITE ONE WORD TO PASS FILE 1.
* 
* 
      EXT .MVW      LIBRARY MOVE WORDS ROUTINE
* 
* 
* 
A     EQU 0 
B     EQU 1 
      SUP 
      SKP 
*              ***********************
*              * INPUT DO NOT ASSIGN *
*              ***********************
      SPC 1 
*                   START BY CLEARING STATE.  ASSUME IT'S A NUMBER. 
* 
IDN.F NOP 
      CLA 
      STA F.IU      F.IU=0
      STA F.NT      F.NT=0
      STA HFLAG     NOT HOLLERITH.
      STA F.SIM     NOT NEGATIVE CONSTANT.
      JSB EXN.F     PEEK AT NEXT CHARACTER. 
      ADA BM101     LETTER ?
      SSA 
      JMP IDN04     NO. GO TRY NUMBER.
* 
*                   NAME. READ IT.
* 
      JSB ICH.F     READ 1ST CHARACTER. 
      LDB F.TC      GET THE CHARACTER AND 
      ADB BM101     USE IT TO INDEX 
      CLE,ERB       INTO THE
      ADB F.DTY     IMPLICIT TYPE TABLE 
      LDA B,I       GET TYPE FORM THE TABLE 
      SEZ           ROTATE IT 
      ALF,ALF       IF REQUIRED 
      AND B170K     ISOLATE THE TYPE
      STA F.IM      SET THE IMPLICIT TYPE 
      JSB BNI.F     CLEAR NID BUFFER TO BLANKS
      LDA KM6 
      STA T4IDN     SET CHAR. COUNT TO -6 
      LDB F.DNI     LOC. OF 1ST WORD OF NID BUFFER
      STB T5IDN 
      LDA F.TC      STORE CHAR. INTO NID BUFFER 
IDN02 STA T5IDN,I 
      JSB ICH.F     INPUT A CHAR. 
      SEZ           IS IT ALPHANUMERIC??
      JMP IDN11     NO
* 
      ISZ T5IDN     INCREMENT NID BUFFER POINTER
      ISZ T4IDN     6 CHARS INPUT?
      JMP IDN02     NO. GET ANOTHER 
* 
      JMP IDN11     YES  QUIT EVEN IF NOT DONE WITH SYMBOL
      SKP 
T4IDN NOP 
T5IDN NOP 
T7IDN BSS 4         SAVED FIRST PART OF COMPLEX CONSTANT. 
HFLAG NOP 
ZPX   OCT 140000    F.IM=12  DOUBLE COMPLEX 
CPX   OCT 50000     DO NOT REARRANGE THESE  ***** 
DBL   OCT 60000     CONSTANTS               ***** 
REA   OCT 20000     F.IM=2  REAL            ***** 
INT   OCT 10000     F.IM=1  INTEGER         ***** 
TPADD DEF INT+1     USED TO INDEX INTO ABOVE FOR HOLL. CONST. 
B170K OCT 170000
BM101 OCT -101
B60K  EQU DBL 
* 
*                   CONSTANT OR OPERATOR.  LET INC.F DECIDE.
* 
IDN04 JSB INC.F     GET A CONSTANT. 
      SZA,RSS       F.IM=0 ?
      JMP IDN11     YES, NO SUCH LUCK.
* 
      LDB F.SXF     COMPLEX FLAG SET ?
      SZB,RSS 
      JMP IDN10     NO. 
      LDB F.TC      YES. F.TC = ',' ? 
      CPB B54 
      RSS           YES.
      JMP IDN10     NO. 
      LDB F.SID     SCAN MODE ? 
      SZB 
      JMP IDN11     YES, DONE.
* 
*                   COMPLEX CONSTANT. 
* 
      CPA RE8       MUST BE COMPLEX. SINGLE OR DOUBLE ? (B=0) 
      INB,RSS       DOUBLE. B=1.
      CPA REA       NO. SINGLE ?
      BLS,SLB       SINGLE: B=0. DOUBLE: B=2
      JMP IDN15     NO. ERROR.
* 
      ADB K2        B = 2/4 AS SINGLE/DOUBLE COMPLEX. 
      STB T6IDN     T6IDN = # WORDS IN EACH PART. 
      ADB F.DID     T4IDN = ADDR OF SECOND PART.
      STB T4IDN 
      STA T5IDN     T5IDN = TYPE OF FIRST PART. 
      JSB MVW.F     SAVE FIRST PART.
      DEF T7IDN     IN T7IDN (UP TO 4 WORDS)
      DEF F.IDI 
      DEC 4 
      JSB INC.F     GET SECOND PART.
      CPA T5IDN     MUST BE SAME TYPE AS FIRST PART.
      RSS 
      JMP IDN15 
* 
      LDB CPX       SET UP NEW F.IM: SINGLE,
      CPA RE8 
      LDB ZPX       OR DOUBLE COMPLEX.
      STB F.IM
      JSB RP.F      & FOLLOWED BY ')' 
      JSB MVW.F     FORM COMPLEX CONSTANT.
      DEF T4IDN,I   MOVE SECOND PART UP.
      DEF F.IDI 
      DEC 4 
      JSB MVW.F     MOVE SAVED FIRST PART IN. 
      DEF F.IDI 
      DEF T7IDN 
T6IDN ABS *-*       2/4 AS TYPE.
      SKP 
*                   ALL DONE. IF CONSTANT, ESTABLISH IT.
*                   SOAK UP ANY DOT OPERATOR FOLLOWING. 
* 
IDN10 LDA F.IM      SET UP CONSTANT.
      JSB ESC.F 
IDN11 JSB IDO.F     THIS MAY BE REDUNDANT.
      JMP IDN10     IF .TRUE. OR .FALSE., SET UP CONSTANT.
      CLA           CLEAR COMPLEX FLAG. 
      STA F.SXF 
      LDB F.SIM     SPECIAL NEGATIVE CONSTANT ? 
      SZB,RSS 
      JMP IDN13     NO. 
* 
      LDB F.TC      YES. NEG HOLLERITH OR EXPONENTIATION. 
      STB F.STC     REMEMBER THE CONSTANT.
      LDB F.IM
      STB F.SIM 
      STA F.IM      AND SEND '-' BACK FOR NOW.
      LDA B55 
      STA F.TC
* 
IDN13 LDA F.IM      RETURN (A) = F.IM.
      LDB HFLAG          (B) = HOLLERITH FLAG.
      JMP IDN.F,I   EXIT. 
* 
IDN15 LDA K8        COMPLEX CONSTANT ERROR. 
      JSB ER.F
* 
F.SIM NOP           SAVED ITEM MODE & NEG CONST FLAG. 
F.STC NOP           SAVED F.TC WHEN F.SIM#0.
KM2   DEC -2
K4    DEC 4 
B40   OCT 40
TWPE  OCT 40000 
SUBCL BYT 32,1
K20   DEC 20
B15   OCT 15
K8    DEC 8 
B54   OCT 54
      SKP 
*         ****************************
*         * INPUT HOLLERITH CONSTANT *
*         ****************************
      SPC 1 
*                   VERIFY COUNT > 0.  IF SCANNING, JUST SKIP CHARACTERS. 
* 
IDN72 DLD F.IDI+2   (A,B) = COUNT, < 2**31. 
      SZA,RSS       IF >= 2**15 = 32768,
      SSB 
      JMP IHC06     ERROR.
* 
      LDA K20 
      CMB,INB,SZB,RSS SET HOLL. COUNT NEGATIVE
      JSB ER.F      ERROR: EMPTY HOLLERITH STRING 
* 
      STB T4IDN     KEEP THE NEGATIVE COUNT 
      STB HFLAG     SET HOLLERITH FLAG. 
      LDA F.SID     NOT CODE GEN.?
      SZA,RSS       SCANING?
      JMP IHC01     NO. NORMAL CODE GEN.
* 
IHC00 JSB IC.F      SCANNING. SKIP (N) CHARACTERS.
      ISZ T4IDN     COUNT. ALL DONE ? 
      JMP IHC00     NO, GO ON.
* 
      JSB IC.F      READ DELIMITER. 
      JMP IDN11     EXIT. 
* 
*                   SEE WHETHER NORMAL CONSTANT OR HOLLERITH PARAMETER. 
* 
IHC01 LDA SIGN      IF NEG COUNT, SET FLAG (FOR SHORT). 
      SSA 
      ISZ F.SIM 
      ADB K8        NORMAL CONSTANT AT MOST 8 CHARS.
      SSB,RSS 
      JMP IHC02     LESS THAN 9-CHAR.  OK 
* 
      LDB F.S2T,I   GET THE CURRENT TOP OF STACK
      RBL,CLE,ERB   CLEAR POSSIBLE SIGN BIT 
      CPB SUBCL     IF SUBROUTINE PRAM. 
      SSA           AND POS. COUNT, O.K.
      JMP IHC06     ELSE ILLEGAL LONG HOLL. 
* 
      LDA TWPE      SET UP A TWPE ENTRY 
      JSB ESC.F     TO REMEMBER THE ADDRESS.
      JSB AI.F
      JSB DL.F      START IT RIGHT HERE.
      JMP IHC03     SKIP OTHER TYPE.
      SKP 
*                   NORMAL CONSTANT.  SET UP TYPE.
* 
IHC02 LDB T4IDN     GET THE NEGATIVE COUNT
      BRS           DIVIDE BY TWO 
      ADB TPADD     ADD THE BASE ADDRESS
      LDB B,I       GET THE TYPE
      LDA F.CCW     'J' OPTION. 
      AND B10K
      CPB REA       IF 3-4 CHARS
      SZA,RSS       & 'J' OPTION, 
      RSS           (NO)
      LDB DBI       THEN MAKE IT (DBI), NOT (REA).
      STB F.IM      SET THE ITEM MODE 
* 
*                   INPUT THE PROPER NUMBER OF CHARACTERS.
*                   IF NORMAL, WON'T FORCE FLUSH OF PAK.F BUFFER. 
* 
IHC03 CCA           INITIALIZE PAK.F
      CLB           OFFSET = 0. 
      JSB PAK.F 
IHC04 JSB IC.F      READ NEXT CHARACTER.
      CPA B15       C/R ? 
      LDA B40       YES, USE BLANK. 
      JSB PAK.F     PACK IT.
      ISZ T4IDN     MORE ?
      JMP IHC04     YES.
* 
*                   FOR NORMAL CONSTANTS, COPY DATA TO F.IDI
* 
      LDA F.IM      WHICH ? 
      CPA TWPE      SUB PARAM = TWPE. 
      JMP IHC05     SUBROUTINE PARAMETER. 
* 
      LDA F.DPK     NORMAL. COPY FROM F.PAK BUFFER. 
      LDB F.DID 
      JSB .MVW
      DEF K4
      NOP 
      JSB ICH.F     INPUT NEXT CHAR.
      JMP IDN10     GO FINISH UP. 
* 
*                   FOR SUBROUTINE PARAMETERS, FLUSH PAK.F BUFFER 
*                   AND MAKE SURE DELIMETER IS ',' OR ')' . 
* 
IHC05 LDA KM2       FLUSH BUFFER. 
      JSB PAK.F 
      ADB F.RPL     UPDATE F.RPL
      STB F.RPL 
      JSB ICH.F     (A) = NEXT NON-BLANK. 
      CPA B54       MUST BE ',' 
      RSS 
      CPA B51       OR ')'
      JMP IDN11     YES, FINISH UP. 
* 
IHC06 LDA K20       NO, ERROR.
      JSB ER.F
      SKP 
*         **********************************
*         * FINISH INPUT OF OCTAL CONSTANT *
*         **********************************
      SPC 1 
INB01 JSB ICH.F     SKIP PAST THE "B".
      LDA F.SID     SCAN MODE ? 
      SZA 
      JMP INC.F,I   YES, DONE.
* 
      JSB CEX.F     CHECK FOR '**'
* 
      LDB BILGD     8 OR 9 ?
      LDA K16 
      SZB 
      JSB WAR.F     YES, WARNING. 
      LDB BOVFL     OVERFLOW ?
      LDA K16 
      SZB 
      JMP INB02     YES, WARNING & DOUBLE.
* 
      LDB F.SLF     DATA STATEMENT ?
      CPB K2
      RSS           (YES) 
      JMP INB05     NO. 
* 
      LDA F.EIM     YES. EXPECTED TYPE ?
      CPA DBI 
      JMP INB03     DOUBLE. 
* 
      LDB B.IDI     SINGLE. OVERFLOW ?
      LDA K16 
      SZB 
      JSB WAR.F     YES. WARNING. 
      LDB B.IDI+1   THEN FORCE SINGLE ANYWAY. 
      JMP INB06 
* 
INB05 LDA F.CCW     NO. 'J' OPTION ?
      AND B10K
      SZA 
      JMP INB03     YES, DOUBLE.
* 
      DLD B.IDI     SINGLE OR DOUBLE ?
      SZA           (SINGLE IF UPPER WORD = 0)
      JMP INB03     DOUBLE. 
* 
INB06 LDA SIGN      SINGLE. NEGATE ?
      SSA 
      CMB,INB       YES. DO IT. 
* 
      STB F.IDI     SINGLE. SET UP F.IDI & F.IM 
      LDA INT 
      JMP INC16 
* 
INB02 LDA K16       OVERFLOW WARNING. 
      JSB WAR.F 
* 
INB03 LDA SIGN      DOUBLE. NEGATE IF SIGN#0. 
      ELA           COPY SIGN TO (E). 
      DLD B.IDI     VALUE.
      SEZ,RSS       NEGATE ?
      JMP INB04     NO. 
      CMA           YES. DO IT. 
      CMB,INB,SZB,RSS 
      INA 
INB04 DST F.IDI 
      LDA DBI 
      JMP INC16 
* 
K16   DEC 16
      SPC 2 
*         **********************
*         * INPUT DOT OPERATOR *
*         **********************
      SPC 1 
*     ENTRY: F.TC=FIRST CHAR OF CANDIDATE.  IF F.TC#'.', EXIT, ELSE 
*            CHECK IT FOR BEING A DOT OPERATOR.  IF NOT, ERROR 28.
*            IF .FALSE. OR .TRUE. : 
*              IF F.IM#0, ERROR, ELSE SET UP THE CONSTANT.
*     EXIT:  F.TC= FIRST TWO CHARACTERS OF OPERATOR NAME, E.G. 'EQ'.
*            RETURNS TO P+1 IF .FALSE. OR .TRUE.
*                       P+2 IF OTHER OR SCAN MODE.
      SPC 1 
*                   SEARCH FOR MATCHING KEYWORD & VERIFY TRAILING '.' 
* 
IDO.F NOP 
      LDA F.TC      STARTS WITH DOT ? 
      CPA "." 
      CCA,RSS       YES.  (A=-1)
      JMP IDO03     NO. LEAVE IT AS IS. 
* 
      JSB KWS.F     YES. SEARCH FOR KEYWORD.
      DEF DOTOP 
      SZA,RSS       FOUND ONE ? 
      JMP IDO02     NO. ERROR.
* 
*                   IF NOT TRUE/FALSE, SET F.TC = 1ST TWO CHARS & EXIT. 
* 
      ADA TRORD     TRUE=0, FALSE=1, OTHER < 0. 
      SSA,RSS       WELL ?
      JMP IDO01     TRUE/FALSE
* 
      ADA DLGOP     OP. GET FIRST TWO CHARS.
      LDA A,I 
      STA F.TC      F.TC = FIRST TWO CHARS. 
      JMP IDO03     NORMAL EXIT.
      SKP 
*                   TRUE/FALSE:  1) MAKE SURE NO PREVIOUS OPERAND.
*                                2) SET VALUE.
*                                3) PICK SINGLE OR DOUBLE LOGICAL.
* 
IDO01 LDB F.IM      CAN'T HAVE AFTER AN OPERAND.
      SZB           DOES IT ?
      JMP IDO02     YES. ERROR. 
* 
      ADA KM1       TRUE: -1     FALSE: 0 
      AND B100K     TRUE: 100000B     FALSE: 0
      STA F.IDI     SET VALUE (FIRST WORD IF DOUBLE)
      STB F.IDI+1   SECOND WORD = 0 IN CASE DOUBLE. 
      LDA F.SID     SCAN MODE ? 
      SZA 
      JMP IDO03     YES, QUIT NOW.
* 
      LDA F.CCW     'J' OPTION ?
      AND B10K
      LDB LOG       SINGLE LOGICAL IF NOT.
      SZA 
      LDB LO4       DOUBLE LOGICAL IF SO. 
      STB F.IM      SET F.IM
      JSB ICH.F     READ NEXT CHAR. 
      JMP IDO.F,I   RETURN P+1 (TO DO ESC.F)
* 
*                   ERROR. IGNORE IF SCAN MODE. 
* 
IDO02 LDB F.SID     ERROR. SCAN MODE ?
      LDA K28       (ERROR 28)
      SZB,RSS 
      JSB ER.F      28: UNEXPECTED CHARACTER. 
IDO03 ISZ IDO.F     BUMP RETURN POINT & EXIT.TER. 
      JMP IDO.F,I 
      SPC 2 
K2    DEC 2 
K28   DEC 28
LOG   OCT 30000 
LO4   OCT 110000
* 
DOTOP ASC 19,LT. LE. EQ. NE. GE. GT. OR. AND. NOT. ,
      ASC 18,EQV. XOR. EOR. NEQV. TRUE. FALSE.   ,
* 
TRORD DEC -14       -(ORDINAL OF .TRUE., FROM 1)
* 
LOGOP ASC 13,LTLEEQNEGEGTORANNOEVXOXOXO 
DLGOP DEF *         (LAST ABOVE)+1
"EQ"  EQU LOGOP+2 
"EV"  EQU LOGOP+9 
      SKP 
*         ****************************
*         * PACK & OUTPUT ASCII DATA *
*         ****************************
      SPC 1 
*     ENTRY:  A>=0:  PACK THE CHARACTER IN (A). 
*             A=-1:  INITIALIZE. F.A = A.T. ADDR OF ITEM. 
*                                      IF ZERO, IS PROGM-RELATIVE.
*                                (B) = OFFSET WITHIN ITEM.
*             A=-2:  FLUSH THE BUFFER. RTNS (B)=LWA+1. (OFFSET) 
      SPC 1 
*                   FIRST, FLUSH BUFFER IF NEED BE. 
* 
PAK.F NOP 
      STA T2PAK     SAVE VALUE FOR LATER. 
      INA,SZA       INITIALIZE CALL ? 
      JMP PAK03     NO. 
* 
      STB T3PAK     YES. SAVE OFFSET FOR OUTPUT.
      LDA F.A       AND THE F.A VALUE.
      STA T4PAK 
      JMP PAK05     GO INITIALIZE.
* 
PAK03 LDB T0PAK     BUFFER FULL,
      INA,SZA       OR FLUSH CALL ? 
      CPB K20 
      RSS           (YES) 
      JMP PAK06     NO. JUST OUTPUT CHAR. 
* 
      LDA T0PAK     YES, FLUSH. (A) = # CHARS OUTPUT. 
      INA           ROUND UP TO WHOLE WORD. 
      ARS           (A) = # WORDS.
      STA T0PAK 
      SZA,RSS       ANY ? 
      JMP PAK05     NO. GO RE-INIT & EXIT.
* 
      ADA K3        FORM & OUTPUT OPCODE. (3 HEADER WDS)
      ALF,ALF 
      IOR K51       DATA STATEMENT OPERATOR.
      JSB WS1.F 
      LDA T4PAK     ITEM F.A
      JSB WS1.F 
      LDA T3PAK     OFFSET. 
      JSB WS1.F 
      LDA K1PS      1+SIGN BIT: REPEAT, ASCII.
      JSB WS1.F 
      LDA T3PAK     UPDATE OFFSET.
      ADA T0PAK 
      STA T3PAK 
      LDA T0PAK     SET UP LOOP COUNTER.
      CMA,INA 
      STA T0PAK 
      LDA F.DPK     SET UP LOOP TO OUTPUT.
      STA T1PAK 
PAK04 LDA T1PAK,I   ONE WORD. 
      JSB WS1.F 
      ISZ T1PAK     NEXT! 
      ISZ T0PAK     DONE ?
      JMP PAK04     NO. 
* 
PAK05 LDA F.DPK     RESET BUFFER POINTER. 
      STA T1PAK 
      CLA           T0PAK = 0, # CHARS IN BUFFER. 
      STA T0PAK 
* 
*                   IF IT'S A DATA CALL, PACK THE CHARACTER.
* 
PAK06 LDA T2PAK     WELL ?
      LDB T3PAK     (IN CASE NOT, (B)=LWA+1)
      SSA 
      JMP PAK.F,I   NO, INIT OR FLUSH. DONE.
* 
      ISZ T0PAK     CHARACTER. COUNT IT.
      LDB T0PAK     FIRST OR SECOND IN WORD ? 
      SLB 
      JMP PAK07     FIRST. GO STORE.
* 
      XOR B40       SECOND. PACK & OUTPUT.
      XOR T1PAK,I   (REPLACES BLANK WITH CHARACTER) 
      STA T1PAK,I 
      ISZ T1PAK     ADVANCE TO NEXT WORD. 
      JMP PAK.F,I   EXIT. 
* 
PAK07 ALF,ALF       FIRST.  PAD WITH A BLANK. 
      IOR B40 
      STA T1PAK,I   & STORE.
      JMP PAK.F,I   EXIT. 
      SPC 2 
T0PAK NOP           CURRENT # CHARS IN BUFFER (< 21)
T1PAK NOP           ADDR OF WORD WITH LAST CHAR PACKED. 
T2PAK NOP           SAVED INPUT VALUE.
T3PAK NOP           OFFSET TO WRITE NEXT BUFFER TO. 
T4PAK NOP           SAVED ITEM F.A
F.DPK DEF FBUF      ADDR OF BUFFER. 
FBUF  BSS 10        10-WORD ASCII BUFFER. 
K51   BYT 0,63      DATA STATEMENT OPERATOR.
K1PS  OCT 100001    1 + SIGN BIT. 
K3    DEC 3 
      SKP 
*         ************************* 
*         * INPUT STRING CONSTANT * 
*         ************************* 
      SPC 1 
*     ENTRY: F.TC = LEADING SINGLE QUOTE. 
*     EXIT:  F.TC = CHARACTER AFTER TRAILING SINGLE QUOTE.
*            F.A  = A.T. ADDR OF STRING CONSTANT. 
* 
ISC.F NOP 
      CLA           SET CHAR COUNT = 0. 
      STA F.CSL 
      STA F.A       SET F.A=0 FOR PAK.F (PROGM REL) 
      CCA           INITIALIZE PAK.F
      LDB F.RPL 
      JSB PAK.F 
ISC01 JSB IC.F      NEXT CHAR.
      CPA B15       IF C/R, 
      JMP ISC99     THEN ERROR - TERMINATED WITHOUT QUOTE.
* 
      CPA B47       SINGLE QUOTE ?
      RSS           (YES) 
      JMP ISC03     NO. 
* 
      JSB IC.F      YES. GET CHARACTER AFTER IT,
      CPA B47       TO SEE IF PAIR OF QUOTES. 
      RSS           YES; TREAT PAIR AS SINGLE ONE.
      JMP ISC04     NO. AT END. 
* 
ISC03 JSB PAK.F     ELSE PACK THE CHARACTER.
      ISZ F.CSL     AND COUNT IT. 
      JMP ISC01     AND GO ON.
* 
ISC04 CPA B40       HAVE CHAR AFTER END; IF BLANK,
      JSB ICH.F     SKIP BLANKS & READ NEXT NON-BLANK.
      LDB F.CSL     IF ODD # CHARS, 
      LDA B40 
      SLB 
      JSB PAK.F     PACK ANOTHER BUT DON'T COUNT IT.
* 
*                   CREATE SYMBOL TABLE ENTRY FOR IT. 
* 
      LDA CHAR      SET UP FIELDS FOR CONSTANT. 
      JSB ESC.F 
      LDA F.DPK     MOVE 10 WORDS INTO F.IDI, 
      LDB F.DID     EVEN IF THEY'RE JUNK. 
      JSB .MVW
      DEF K10 
      NOP 
      JSB AI.F      FIND OR CREATE A.T. ENTRY.
      LDA F.CSL     LONG OR SHORT STRING ?
      ADA KM21
      SSA 
      JMP ISC.F,I   SHORT. ALL DONE.
      SKP 
*                   LONG STRING. FLUSH BUFFER & SAVE ADDR.
* 
      LDA KM2       LONG. FLUSH PAK.F BUFFER. 
      JSB PAK.F     (NOW (B) HAS UPDATED F.RPL) 
      LDA F.RPL     (A) = OLD F.RPL = FWA CONSTANT. 
      STB F.RPL     UPDATE F.RPL = LWA+1 CONSTANT.
      LDB F.A       GET EXTENSION ADDR. 
      INB 
      LDB B,I 
      ADB K2            = POSITON OF BYTE ADDR FIELD. 
      CLE,RAL       BYTE ADDR.
      STA B,I       STUFF IT. 
      JMP ISC.F,I   DONE. 
* 
ISC99 LDA K13       C/R BEFORE ENDING QUOTE.
      JSB ER.F      DOWN THE TUBES. 
* 
K10   DEC 10
K13   DEC 13
B47   OCT 47        SINGLE QUOTE. 
CHAR  OCT 130000    F.IM=CHAR.
KM21  DEC -21 
      SKP 
*         ********************
*         * )-INPUT OPERATOR *
*         ********************
      SPC 1 
RP.F  NOP 
      LDA B51       F.TC MUST BE ')'
      JSB TCT.F     F.TC-TEST 
      JSB ICH.F     INPUT CHARACTER 
      JMP RP.F,I
* 
B51   OCT 51
      SPC 2 
*                   GLOBALS.
* 
EXP   NOP           EXPONENT
D     NOP           -D-1
EXPON NOP           EXPONENT PART OF NUMBER 
POST  NOP           INPUT CONTROL INDICATOR 
SIGN  NOP           SIGN OF NUMBER. 
MANTL NOP           LWA DITTO 
* 
*                   ADDRESS CONSTANTS & SHIFT INSTRUCTIONS. 
* 
MULTZ DEF MULT
DIVDZ DEF DIVD
MANTE DEF F.IDI+5   LWA+1 MANTISSA
* 
*                   NUMERIC AND CHARACTER CONSTANTS.
* 
KM4   DEC -4
KM1   DEC -1
B53   OCT 53
B55   OCT 55
"."   OCT 56
"D"   OCT 104 
"E"   OCT 105 
      SKP 
*     PTEN - SCALE NUMBER BY A POWER OF TEN.
* 
*     PTEN MULTIPLIES THE VALUE IN (MANT...MANT2) AND (EXP) 
*     BY 10**(A).  NO CHECK IS MADE FOR OVERFLOW/UNDERFLOW. 
* 
*     CALLING SEQUENCE: 
*                   LDA POWER 
*                   JSB PTEN
      SPC 2 
PTEN  NOP 
      SZA,RSS       IF N=0, LEAVE ALONE.
      JMP PTEN,I
      SSA,RSS       N>0 ? 
      JMP PTEN1     YES.
      CMA,INA       NO, TAKE IABS(N)
      STA T1PTN 
      JSB RSN       RIGHT SHIFT MANTISSA TWO BITS.
      JSB RSN 
      LDB DIVDZ     SET "DIVIDE"
      JMP PTEN2 
PTEN1 LDB MULTZ     SET "MULTIPLY"
      STA T1PTN     T1PTN = IABS(N) 
PTEN2 STB T2PTN     T2PTN = ADDR MULT OR DIVD 
PTEN3 LDA T1PTN     A=N 
      ADA KM6       N-6 
      CLE,SSA       N<6 ?   (E=0 FOR MULT)
      JMP PTEN4     YES, GO DO LAST ONE.
      STA T1PTN     NO, MULT/DIV BY 10**6 
      LDA PWR1A+10
      LDB PWR1A+11
      JSB T2PTN,I 
      JMP PTEN3     TRY AGAIN.
PTEN4 ADA K5        A = N-1 
      RAL,CLE,SLA   N=0 ? 
      JMP PTEN5     YES, GO NORMALIZE.
      ADA PWR10     GET POWER OF TEN. (E=0 FOR MULT.) 
      DLD A,I 
      JSB T2PTN,I   GO MPY DIV USING IT.
PTEN5 JSB NORML     NORMALIZE.
      JMP PTEN,I
* 
T1PTN NOP 
T2PTN NOP 
      SKP 
*     INDIG TAKES A DIGIT AND COMBINES IT WITH THE RUNNING MANTISSA.
*     THE RUNNING MANTISSA IS NOT IN A USABLE FORM UNTIL A TERMINATION
*     CALL IS MADE.  IT IS THEN USABLE BUT MAYBE NOT NORMALIZED.
* 
*     CALLING SEQUENCE:    LDA <DIGIT>  (NEG FOR TERMINATION) 
*                          JSB INDIG
* 
*     ANY TRAILING ZEROES OR DIGITS AFTER THE LIMIT (20)
*     AFFECT ONLY THE TRAILING ZERO COUNT IN "T4INP". 
      SPC 1 
*                   CHECK FOR ZERO, EXTRA DIGIT OR TERMINATION. 
* 
INDIG NOP 
      STA T1IND     SAVE DIGIT. 
      SSA           TERMINATION CALL ?
      JMP INDI7     YES.
* 
*                   ACCUMULATE OCTAL. 
* 
      STA T2IND     SAVE DIGIT. 
      CPA K8        IF 8 OR 9,
      RSS 
      CPA K9
      ISZ BILGD     ILLEGAL DIGIT.
      DLD B.IDI     GET TOP 3 BITS. 
      AND B160K 
      SZA           ANY SET ? 
      ISZ BOVFL     YES, OVERFLOW.
      XOR B.IDI     GET TOP WORD WITHOUT BITS.
      RRR 13        SWAP & LEFT SHIFT 3.
      IOR T2IND     INSERT DIGIT. 
      STA B.IDI+1 
      STB B.IDI 
      LDA T2IND     (A) = DIGIT.
* 
*                   CHECK FOR ZERO OR LIMIT.
* 
INDI1 LDB MANTE     NO. AT LIMIT ?
      RBL,CLE,SLB,ERB  (REMOVE POSSIBLE INDIRECT) 
      LDB B,I 
      SZA           OR ZERO DIGIT ? 
      CPB MANTL 
      JMP INDI6     YES, JUST COUNT IT. 
* 
*                   GOOD DIGIT.  ADD IT OR A SKIPPED ZERO.
* 
      LDA T1INP     NO. GOOD DIGIT. MULTIPLY OTHERS BY 10.
      ALS,ALS 
      ADA T1INP 
      ALS 
      LDB T4INP     ANY UNUSED ZEROES ? 
      SZB,RSS       IF SO, ADD THEM FIRST.
      ADA T1IND     IF NOT, ADD THIS DIGIT. 
      STA T1INP 
      ISZ T2INP     COUNT DIGITS.  FULL GROUP OF 4 ?
      JMP INDI5     NO. 
      LDA K5000     YES, ADD THEM.
INDI2 LDB KM16      MAKE ROOM.
      CMB,CCE,INB   B=16, E=1.
      JSB MULT
      LDB MANTL     ADD DIGIT(S)
      ISZ MANTL 
      LDA B,I 
      CLE 
      ADA T1INP 
      STA B,I 
      CCA,SEZ,RSS   CARRY ? 
      JMP INDI4     NO. 
INDI3 ADB A         PROPOGATE IT. 
      ISZ B,I 
      RSS 
      JMP INDI3 
* 
INDI4 LDA KM4       RESET COUNT.
      STA T2INP 
      CLA           RESET DIGITS. 
      STA T1INP 
      LDB T4INP     RELOAD TRAILING ZERO COUNT. 
      SKP 
*                   IF JUST PROCESSED A SKIPPED ZERO, DO ANOTHER DIGIT. 
* 
INDI5 LDA T1IND     WAS IT A TERMINATION CALL ? 
      SSA,RSS 
      SZB,RSS       OR NO TRAILING ZEROES ? 
      JMP INDIG,I   YES, DONE WITH THIS DIGIT.
      ADB KM1       IT WAS A SKIPPED ZERO.  DECREMENT COUNT.
      STB T4INP 
      JMP INDI1     TRY AGAIN.
* 
*                   ZERO, EXTRA DIGIT & TERMINATION PROCESSING. 
* 
INDI6 LDA T1INP     ZERO OR EXTRA DIGIT.  LEADING ZERO ?
      ADA EXP       (IF SO, EXP=-1 AND T1INP=0) 
      SSA,RSS 
      ISZ T4INP     NO, TRAILING DIGIT, COUNT IT. 
      JMP INDIG,I   DONE WITH THIS ONE. 
INDI7 LDA T2INP     ANY UNUSED DIGITS ? 
      CPA KM4 
      JMP INDIG,I   NO, DONE. 
      ADA PWR10     YES. ADD THEM.
      LDA A,I 
      JMP INDI2 
* 
T1IND NOP 
T2IND NOP 
KM16  DEC -16 
K9    DEC 9 
B160K OCT 160000
B.IDI DEC 0,0 
BILGD NOP           OCTAL ILLEGAL DIGIT FLAG. 
BOVFL NOP           OCTAL OVERFLOW FLAG.
      SPC 3 
*     POWER OF TEN TABLE.  FIRST PART IS (10**I)/2, I=1,2,3.  SECOND
*     PART IS IDENTICAL TO 2-WORD FLOATING EXCEPT THE SECOND WORD HAS 
*     BEEN RIGHT SHIFTED ONE BIT.  VALUES ARE 1O**I FOR I=1,6.
      SPC 1 
K5000 DEC 5000
PWR10 DEF PWR1A     BASE ADDRESS. 
K5    DEC 5 
      DEC 50
      DEC 500 
PWR1A DEC 20480     10**1 
      DEC 4 
      DEC 25600     10**2 
      DEC 7 
      DEC 32000,10  10**3 
      DEC 20000,14  10**4 
      DEC 25000,17  10**5 
      DEC 31250,20  10**6 
      SKP 
*     NORML - MANTISSA NORMALIZATION. 
*        THE MANTISSA AND EXPONENT ARE ADJUSTED SO THAT THEY CONTAIN
*        A NORMALIZED VALUE.  THE MANTISSA MUST NOT BE ZERO.
* 
NORML NOP 
NORM1 LDB F.IDI     SEE IF NORMALIZED.
      ASL 1 
      SOC           WELL ?
      JMP NORML,I   YES.
      JSB LSONE     NO. LEFT SHIFT & ADJUST EXP.
      JMP NORM1     TRY AGAIN.
      SPC 2 
*     RSN - LOGICAL RIGHT SHIFT MANTISSA ONE BIT. 
* 
RSN   NOP 
      ISZ EXP       ADJUST EXPONENT.
      NOP 
      DLD F.IDI     JUST SHIFT....
      CLE,ERA 
      ERB 
      DST F.IDI 
      DLD F.IDI+2 
      ERA 
      ERB 
      DST F.IDI+2 
      JMP RSN,I     EXIT
      SPC 2 
*     LSONE - LOGICAL LEFT SHIFT MANTISSA ONE BIT. (5 WORDS)
* 
LSONE NOP 
      CCA           ADJUST EXP
      ADA EXP 
      STA EXP 
      LDA F.IDI+4 
      CLE,ELA 
      STA F.IDI+4 
      DLD F.IDI+2 
      ELB 
      ELA 
      DST F.IDI+2 
      DLD F.IDI 
      ELB 
      ELA 
      DST F.IDI 
      JMP LSONE,I 
* 
B17   OCT 17
LSR16 LSR 16
T1RSN NOP 
      SKP 
*     RSNN - LOGICAL RIGHT SHIFT (A) BITS, IN [0,63], AND UPPER 
*     TWO WORDS ONLY VALID FOR INTEGER OVERFLOW TEST. 
* 
RSNN  NOP 
      STA T1RSN     SAVE SHIFT COUNT. 
      ARS,ARS       DIVIDE BY 16 TO GET WORD COUNT. 
      ARS,ARS 
      ADA RSNN1     SELECT CODE FOR 0-3 WORDS OF SHIFT
      JMP A,I 
* 
RSNN1 DEF *+1       JUMP TABLE FOR WORD SHIFTS
      JMP RSNN7 
      JMP RSNN2 
      JMP RSNN3 
      JMP RSNN4 
* 
RSNN2 DLD F.IDI+1   RIGHT SHIFT ONE WORD. 
      DST F.IDI+2 
      LDA F.IDI     F.IDI+1=F.IDI 
      JMP RSNN6 
* 
RSNN3 DLD F.IDI     RIGHT SHIFT TWO WORDS.
      STB F.IDI+3 
      JMP RSNN5 
* 
RSNN4 LDA F.IDI     RIGHT SHIFT THREE WORDS.
      STA F.IDI+3 
      CLA 
RSNN5 STA F.IDI+2 
      CLA 
RSNN6 STA F.IDI+1 
      CLA 
      STA F.IDI 
* 
*                   NOW RIGHT SHIFT BY PARTIAL WORD 
* 
RSNN7 LDA T1RSN     GET SHIFT COUNT.
      AND B17 
      SZA,RSS 
      JMP RSNN,I    IF ZERO COUNT, DONE SHIFTING
* 
      IOR LSR16     FORM "LSR N"
      STA RSNN8     PLUG CODE 
      STA RSNN9 
      LDB F.IDI+2   DO LOW SHIFT. 
      LDA F.IDI+3 
RSNN8 ABS *-* 
      STA F.IDI+3 
      LDB F.IDI+1   THEN HIGH SHIFT.
      LDA F.IDI+2 
RSNN9 ABS *-* 
      STB F.IDI+1   (UPPER BITS LEFT IN F.IDI+0)
      STA F.IDI+2 
      JMP RSNN,I    DONE. 
      SKP 
*     .XCOM - NEGATE MANTISSA / ROUND RESULT. 
* 
*     IF 'SIGN' IS +, ADD 200B TO LAST WORD & PROPOGATE CARRY.
*     IF -, COMPLEMENT EACH WORD & ADD 201B TO LAST & PROP. 
*     THE RESULT MUST NOT BE ZERO.
      SPC 2 
.XCOM NOP 
      LDA B200      (A) = ROUND CONSTANT FOR +. 
      LDB SIGN      + OR - ?
      SSB 
      INA           (A) = ROUND CONSTANT FOR -. 
      STA T1DIV 
      LDA MANTL     (A) = POINTER.
* 
XCOM1 LDB SIGN      COPY COMPLEMENT STATUS TO (E) 
      ELB 
      LDB A,I       (B) = WORD OF MANTISSA. 
      SEZ           COMPLEMENT ? (E=0)
      CMB,CLE       YES. DO IT.  (E=0)
      ADB T1DIV     ADD CARRY.
      STB A,I       (STORE MANTISSA)
      CLB,SEZ       COPY NEW CARRY BIT TO (A).
      INB 
      STB T1DIV     SAVE CARRY FOR NEXT TIME. 
      CPA F.DID     AT FIRST WORD ? 
      JMP XCOM2     YES.
* 
      ADA KM1       NO. BACK UP POINTER AND 
      JMP XCOM1     KEEP GOING. 
* 
XCOM2 LDA F.IDI     (A) = FIRST WORD. 
      LDB A         (ALSO B)
      XOR SIGN      SIGN RIGHT ?
      SSA 
      JMP XCOM4     NO. OFL.
* 
      ASL 1         YES. IS IT NEG UNNORM ? 
      SOC 
      JMP .XCOM,I   NO, DONE. 
* 
      CCA           YES. (A)=-1 TO DECR EXPONENT, 
      JMP XCOM5     AND (B)=100000, SHIFTED MANTISSA. 
* 
XCOM4 CLA,INA       OFL.  (A)=+1 TO INCR EXPONENT,
      RBR           AND (B)=40000, SHIFTED MANTISSA.
XCOM5 STB F.IDI     SET UP MANTISSA,
      ADA EXP       AND CORRECT EXPONENT. 
      STA EXP 
      JMP .XCOM,I   DONE. 
      SKP 
*     MULT MULTIPLIES THE MANTISSA BY A 15-BIT SCALAR AND ADJUSTS THE 
*     EXPONENT.  THE RESULT IS AS IF AN INTEGER MULTIPLY OF THE MANTISSA
*     AND SCALAR WERE DONE FOLLOWED BY A RIGHT SHIFT 15.  THE RESULT
*     WILL NOT OVERFLOW BUT IT MAY BECOME UNNORMALIZED. 
* 
*     CALLING SEQUENCE:  CLE/CCE      LAST WORD FLAG. 
*                        LDA SCALAR   MULTIPLIER. 
*                        LDB N        EXPONENT ADJUSTMENT.
*                        JSB MULT 
* 
*     WHERE E=1 INDICATES THAT THE LAST WORD OF THE CURRENT MANTISSA IS 
*     ZERO. (INPUT)  FOR THIS CASE, EXP ADJUSTMENT MUST NOT CARRY OUT.
      SPC 1 
MULT  NOP 
      STA T1DIV     SAVE MULTIPLIER.
      RAL           AND 2*MULTIPLIER. 
      STA T4DIV 
      CME           E=0 IFF INPUT 
      ADB EXP       ADJUST EXPONENT 
      STB EXP 
      LDB MANTL     CURRENT WORD ADDR 
      SEZ,RSS       INPUT ? 
      JMP MULT3     YES, SKIP FIRST MPY 
      STB T2DIV 
      RAR           RESTORE MULTIPLIER. 
      MPY B,I 
      ASL 1 
      JMP MULT2 
MULT1 LDA T1DIV     MULTIPLIER. 
      MPY B,I       * CURRENT WORD. 
      CLE,ELA       ALIGN.
      ELB,CLE 
      ADA T3DIV,I   ADD LOWER TO CURRENT + 1
      STA T3DIV,I 
      SEZ           PROPOGATE CARRY.
      INB 
MULT2 LDA T2DIV,I   CORRECT FOR BIT 15. 
      SSA 
      ADB T4DIV 
      STB T2DIV,I 
      LDB T2DIV     SEE IF DONE.
MULT3 CPB F.DID     I.E., IS CURRENT WORD THE START ? 
      JMP MULT,I    YES, DONE.
      STB T3DIV     NO, UPDATE POINTERS.
      ADB KM1 
      STB T2DIV 
      JMP MULT1     AND LOOP. 
      SKP 
*     DIVD DIVIDES THE MANTISSA BY A SCALAR AND ADJUSTS THE EXPONENT
*     ACCORDINGLY.  THE EFFECT IS AS IF THE TWO WERE INTEGERS AND THE 
*     DIVIDE WERE DONE, KEEPING 15 FRACTION BITS, FOLLOWED BY A L.S. 15.
*     OVERFLOW CAN OCCUR ONLY IF THE MANTISSA IS NORMALIZED OR THE
*     DIVISOR IS LESS THAN 2**14. 
* 
*     CALLING SEQUENCE:   LDA SCALAR      15-BIT DIVISOR. 
*                         LDB N           EXPONENT ADJUSTMENT.
*                         JSB DIVD
      SPC 1 
DIVD  NOP 
      STA T1DIV     SAVE DIVISOR. 
      ARS           SAVE DIVISOR/2. 
      STA T4DIV 
      CMB,INB       CORRECT EXPONENT. 
      ADB EXP 
      STB EXP 
      LDA F.DID     SET UP POINTERS.
      STA T2DIV 
      STA T3DIV 
      LDB A,I       B = FIRST WORD. 
      CMA,INA       -F.DID
      ADA MANTL     MANTL-F.DID = # WDS - 1 
      CMA           - # WDS 
      STA T5DIV 
      CLA           BITS 15,14 FIRST WORD = 0 
      JMP DIVD2 
DIVD1 ISZ T2DIV 
      CLA           SAVE BIT 15 (IN E). 
      ELA,ELA 
      CMB           FORM REM - DIVISOR/2
      ADB T4DIV 
      CMB,CLE,SSB   POS ? 
      ADB T4DIV     NO, RESTORE REM & SET E.
      CME           SAVE BIT 14 (IN E). 
      ERA,RAR 
DIVD2 STA T6DIV     SAVE BITS 15,14.
      ISZ T3DIV 
      LDA T3DIV,I   A = NEXT WORD (LOW) 
      DIV T1DIV     DIVIDE. 
      CLE,ERA       SHIFT RIGHT, SAVE BIT 0 AS BIT 15.
      IOR T6DIV     ADD PREV BITS 15,14.
      STA T2DIV,I 
      ISZ T5DIV     DONE ?
      JMP DIVD1     NO, LOOP. 
      JMP DIVD,I    YES, EXIT.
* 
T1DIV NOP 
T2DIV NOP 
T3DIV NOP 
T4DIV NOP 
T5DIV NOP 
T6DIV NOP 
      SKP 
*                   INITIALIZE FOR CONVERTING A NUMBER. 
* 
INC.F NOP 
      LDA F.DID     SET UP (MANTL) FOR INDIG. 
      STA MANTL 
      LDA KM4       FOR INDIG.
      STA T2INP     # DIGITS THIS GROUP - 4.
      CCA 
      STA EXP 
      JSB CDI.F     CLEAR F.IDI, SET A=0. 
      STA B.IDI     CLEAR B.IDI 
      STA B.IDI+1 
      STA T1INP     ACCUMULATED DIGITS THIS GROUP. (UP TO 4)
      STA EXPS      SIGN OF EXPONENT. 
      STA T4INP     # TRAILING ZEROES.
      STA SIGN      SIGN OF MANTISSA. 
      STA BOVFL     OCTAL OVERFLOW FLAG.
      STA BILGD     OCTAL ILLEGAL DIGIT FLAG. 
      STA EXPON     DECIMAL EXPONENT. 
      STA POST      STATE OF CONVERSION.
      STA D         # DIGITS AFTER POINT. 
      LDA REA       DEFAULT F.IM = REA. 
      STA F.IM
      JMP INC02     GO START. 
* 
*                   MAIN LOOP.  READ A CHAR AND DECIDE WHAT TO DO.
* 
INC00 ISZ POST      BUMP POST TWICE.
INC01 ISZ POST      BUMP POST ONCE. 
* 
INC02 JSB ICH.F     GET NEXT (NON-BLANK) CHAR.
      SZB,RSS       DIGIT ? 
      JMP INC04     YES.
* 
      CPA B53       '+' 
      JMP INC07 
      CPA B55       '-' 
      JMP INC07 
      CPA "."       '.' 
      JMP INC09 
      CPA "E"       'E' 
      JMP INC13 
      CPA "D"       'D' 
      JMP INC13 
      JMP INC14     NONE OF ABOVE. STOP THE CONVERSION. 
      SKP 
*     DIGIT. POST=  0 => 2  ADD MANTISSA DIGIT. 
*                   1 => 2  ..
*                   2 => 2  ..
*                   3 => 3  ..                & COUNT FRACTION DIGIT. 
*                   4 => 6  ADD EXPONENT DIGIT. 
*                   5 => 6  ..
*                   6 => 6  ..
* 
INC04 ADA BM60      (A) = VALUE OF DIGIT. 
      JSB JTB.F     JUMP ON B=POST. 
      DEC 6         ALL VALUES LEGAL. 
* 
      ISZ POST      0 => 1
      ISZ POST      1 => 2
      JMP INC06     2, ADD DIGIT. 
      JMP INC05     3, ADD & COUNT DIGIT. 
      ISZ POST      4 => 5
      ISZ POST      5 => 6
* 
      LDB EXPON     6, MULTIPLY EXPON BY 10 
      BLS,BLS 
      ADB EXPON 
      BLS 
      ADB A         ADD DIGIT.
      ASL 4         GUARANTEE LARGE EXPONENTS STAY LARGE. 
      SOC           IF TOO BIG, 
      LDB B60K      SET LARGER THAN MAX ALLOWED.
      ASR 4         (HERE 60000B => 3000B)
      STB EXPON 
      JMP INC02     TRY FOR MORE. 
* 
INC05 ISZ D         3, COUNT DIGIT. 
INC06 JSB INDIG     0-2, ADD MANTISA DIGIT. 
      JMP INC02     NEXT! 
      SPC 2 
BM60  OCT -60 
BM54  OCT -54 
"Q"   OCT 121 
"V"   OCT 26
T1INP NOP 
T2INP NOP 
EXPS  NOP 
T4INP NOP 
      SKP 
*     SIGN.  POST=  0 => 1  SET MANTISSA SIGN.
*                   1 => ERROR. 
*                   2 => FINISH INTEGER.
*                   3 => FINISH REAL. 
*                   4 => 5  SET EXPONENT SIGN.
*                   5 => ERROR
*                   6 => FINISH REAL/DOUBLE 
* 
INC07 ADA BM54      '+': -1    '-': +1
      CMA,INA       +-1 AS SIGN.
      JSB JTB.F     JUMP ON (POST)
      DEC 4         5,6 SAME AS END.
* 
      JMP INC08     0, GO SAVE MANTISSA SIGN. 
      JMP INC26     1, ERROR: TWO SIGNS.
      JMP INC20     2, FINISH INTEGER.
      JMP INC32     3, FINISH REAL. 
* 
      STA EXPS      4, SAVE EXPONENT SIGN.
      JMP INC01     4 => 5. 
* 
INC08 STA SIGN      0, SAVE MANTISSA SIGN.
      JMP INC01     0 => 1. 
* 
INC26 LDA K17       ERROR 17, MISSING OPERAND.
      JSB ER.F
K17   DEC 17
      SPC 4 
*     E OR D. POST= 0 => NAME.
*                   1 => OPERATOR, + OR -.
*                   2 => 4
*                   3 => 4
*                   4 => ERROR
*                   5 => ERROR
*                   6 => FINISH REAL/DOUBLE.
* 
INC13 JSB JTB.F     JUMP ON (POST)
      DEC 3         4,5,6 SAME AS (END).
* 
      JMP INC15     0, NAME.
      JMP INC27     1, + OR -.
      ISZ POST      2 => 4
* 
      STA E/D       3, REMEMBER WHICH KIND. 
      JMP INC01     3 => 4. 
      SKP 
*     POINT. POST=  0 => 3  IF FOLLOWED BY DIGIT, ELSE OPERATOR.
*                   1 => 3  IF FOLLOWED BY DIGIT, ELSE ERROR. 
*                   2 => 3  IF NOT FOLLOWED BY LETTER.
*                        4  IF FOLLOWED BY 'E' BUT NOT 'EQ'.
*                        'EQ', FINISH DOT OPERATOR THEN INTEGER.
*                   3 => FINISH REAL. 
*                   4 => ERROR. 
*                   5 => ERROR. 
*                   6 => FINISH REAL/DOUBLE.
* 
INC09 JSB JTB.F     JUMP ON (POST)
      DEC 2         3,4,5,6 SAME AS (END).
      JMP INC10     0 
      JMP INC12     1 
* 
      JSB EXN.F     2. WHAT'S NEXT ?
      SEZ,RSS       DELIMETER OR
      SZB,RSS       DIGIT ? 
      JMP INC01     YES, 2 => 3.
      CPA "D"       'D' ? 
      JMP INC01     YES, FIGURE IT OUT LATER. 
      CPA "E"       'E' ? 
      RSS 
      JMP INC11     NO. MUST BE RELATIONAL OP.
* 
      JSB ICH.F     READ THE 'E'. 
      STA E/D       AND SAVE FOR LATER. 
      JSB EXN.F     & LOOK AT ONE AFTER.
      CPA "Q"       IS IT '.EQ' ? 
      RSS           YES.
      JMP INC00     NO.  2 => 4.
* 
      JSB ICH.F     READ THE 'Q'. 
      JSB ICH.F     READ NEXT, SHOULD BE '.' OR 'V'.
      LDB "EQ"      (INCASE .EQ.) 
      CPA "V"       IS IT .EQV. ? 
      RSS           MUST BE.
      JMP INC03     NO. GO VERIFY THAT IT'S .EQ.
* 
      JSB ICH.F     .EQV., READ THE DOT.
      LDB "EV"      SET UP RESULT.
INC03 STB F.TC      SET RESULT. 
      CPA "."       ENDS RIGHT ?
      JMP INC20     YES.
      JMP INC18     NO. ERROR.
* 
INC10 JSB EXN.F     0. PEEK AHEAD.
      SZB           DIGIT ? 
      JMP INC11     NO. NOT A NUMBER. RESTORE '.' 
      ISZ POST      YES. DIGIT AFTER POINT. 
      JMP INC00     ADVANCE POST TO 3.
* 
INC11 LDA "."       RESTORE F.TC = "." FOR DOT OPERATOR.
      STA F.TC
      JMP INC14     INTERPRET IT AS A DELIMETER.
* 
INC12 JSB EXN.F     1, REQUIRE NEXT = DIGIT.
      SZB,RSS       DIGIT ? 
      JMP INC00     YES. 1 => 3.
INC18 LDA K17       NO, ERROR.
      JSB ER.F
* 
      SPC 3 
*     UNKNOWN. POST= 0 => NAME. 
*                   1 => + OR -.
*                   2 => FINISH INTEGER.
*                   3 => FINISH REAL. 
*                   4 => ERROR. 
*                   5 => ERROR. 
*                   6 => END REAL/DOUBLE. 
* 
*     JTB.F ALLOWS ACCESS TO AN IMMEDIATELY FOLLOWING JUMP TABLE USING
*     (POST) AS THE INDEX INTO THE TABLE.  THE FIRST RETURN POINT 
*     CORRESPONDS TO POST=0.  IF POST>LIMIT, THE TERMINATION TABLE IS 
*     USED (FOLLOWS JTB.F). 
* 
*     ENTRY:   JSB JTB.F   (POST=INDEX) 
*              DEC LIMIT
*              <RTN IF POST=0>
*              <RTN IF POST=1>
*                ..ETC..
* 
*     EXIT: (B,E,O) DESTROYED, (A) INTACT.
* 
JTB.F NOP 
      LDB POST      (B) = POST. 
      CMB,CLE,INB   -POST.  E=0 UNLESS POST=0.
      ADB JTB.F,I   LIMIT-POST.  E=0 IFF POST>LIMIT AND POST#0. 
      LDB JTB.F     RETURN POINT FOR (-1).
      ADB POST      RETURN POINT FOR (POST-1).
      SEZ,INB       POST>LIMIT ?   (RTN POINT FIXED)
      JMP B,I       NO. RETURN. 
* 
*                   HERE'S THE ACTUAL JUMP TABLE FOR UNKNOWN CHARACTERS.
* 
INC14 JSB JTB.F     (MAY RE-ENTER)
      DEC 6         ALL.
* 
      JMP INC15     0, NAME OR OPERATOR.
      JMP INC27     1, + OR -.
      JMP INC20     2, FINISH INTEGER.
      JMP INC32     3, FINISH REAL. 
      JMP INC19     4, ERROR. 
      JMP INC19     5, ERROR. 
      JMP INC30     6, END OF REAL/DOUBLE.
* 
*                   EXIT CODE FOR INC.F 
* 
INC27 JSB UC.F      SIGN ONLY. BACK UP. 
      LDA SIGN      AND RESTORE F.TC
      CMA,INA 
      ADA B54 
      STA F.TC
INC15 CLA           SET F.IM=0
INC16 STA F.IM      SET F.IM
INC17 LDA F.IM      LOAD F.IM 
      JMP INC.F,I   EXIT. 
* 
*                   ERROR - ILLEGAL EXPONENT. 
* 
INC19 LDA K14 
      LDB F.SID     SCAN MODE ? 
      SZB,RSS 
      JSB ER.F      NO. ERROR.
      JMP INC17     YES. RETURN F.IM
* 
KM6   DEC -6
B1000 OCT 1000
B200  OCT 200 
BM400 OCT -400
BMAX  OCT 77777 
RE8   OCT 120000
K14   DEC 14
E/D   NOP 
KM63  DEC -63 
B10K  OCT 10000 
B100K OCT 100000
DBI   EQU B100K 
B52   OCT 52
      SPC 2 
*                   SUBR TO CHECK FOR '**' AFTER NEGATIVE CONST.
* 
CEX.F NOP 
      LDA F.SID     SCAN MODE 
      LDB SIGN      OR + CONSTANT ? 
      SZA,RSS 
      SSB,RSS 
      JMP CEX.F,I   YES. DOESN'T MATTER.
* 
      LDA F.TC      DELIMETER = '*' ? 
      CPA B52 
      RSS           YES.
      JMP CEX.F,I   NO. ISN'T ** THEN 
* 
      JSB EXN.F     CHECK NEXT ONE. 
      CPA B52       WELL ?
      JMP CEX01     YES. SPECIAL NEGATIVE CONST.
* 
      LDA B52       NO. RESTORE F.TC
      STA F.TC
      JMP CEX.F,I   & EXIT. 
* 
CEX01 CLA           SET SIGN POSITIVE AGAIN.
      STA SIGN
      ISZ F.SIM     SET FLAG TO DELAY CONSTANT. 
      JMP CEX.F,I   (WILL RETURN A '-' INSTEAD) 
      SKP 
*                   FINISH UP AN INTEGER CONSTANT. 
* 
INC20 JSB CEX.F     CHECK FOR '**'
      LDA F.TC      OCTAL CONSTANT ?
      CPA "B" 
      JMP INB01     YES.
* 
      LDA DBI       SET F.IM=DBI IN CASE OVERFLOW.
      STA F.IM
      CCA           ADD ANY REMAINING DIGITS. 
      JSB INDIG 
      LDA F.IDI     RESULT = 0 ?
      IOR F.IDI+1 
      SZA           IF SO, SKIP NORMALIZE.
      JSB NORML     NORMALIZE SO 'PTEN' WORKS.
      LDA T4INP     ADD ANY TRAILING ZEROES.
      JSB PTEN
* 
      LDA EXP       ALLOW 4 WORDS (MAX NEG MUST FIT)
      ADA KM63      (A) = - (R.S. COUNT FOR 4 WORD INTEGER) 
      CLE,SSA,RSS   FITS ?  (E=0) 
      JMP INC35     NO. 
* 
      CMA,INA       YES. (A) = POSITIVE SHIFT COUNT.
      JSB RSNN      RIGHT SHIFT (A) BITS. 
      LDA F.IDI     >= 2**32 ?
      IOR F.IDI+1 
      CLE,SZA       (E=0) 
      JMP INC35     YES, OFL. 
* 
      DLD F.IDI+2   (A,B) = UNSIGNED VALUE. 
      CLE,SSA       >= 2**31 ?  (E=0) 
      JMP INC23     YES. -2**31 IS STILL O.K. 
* 
      LDA F.SLF     IF DATA STATEMENT,
      CPA K2
      JMP INC25     LET THE DATA PROCESSOR DO HOLLERITH.
* 
      LDA F.TC      OTHERWISE, CHECK FOR 'H'
      CPA "H" 
      JMP IDN72     YES, HOLLERITH CONSTANT.
* 
INC25 LDA F.IDI+2 
      ISZ SIGN      NEGATIVE ?
      JMP INC22     NO. (A,B) = NUMBER. 
* 
      CMA           YES. NEGATE.
      CMB,INB,SZB,RSS 
      INA 
      SKP 
*                   (A,B) = INTEGER VALUE.
*                   DECIDE IF SINGLE OR DOUBLE, SET VALUE & F.IM, EXIT. 
* 
INC22 DST F.IDI     RESULT. 
      SWP           DECIDE IF SINGLE OR DOUBLE. 
      ASL 16        OFL=1 IFF MUST BE DOUBLE. 
      LDB F.TC      IF 'J' SUFFIX,
      CPB "J" 
      JMP INC28     THEN ALWAYS TWO-WORD. 
* 
      CPB "I"       'I' SUFFIX ?
      JMP INC29     THEN ALWAYS ONE-WORD. 
* 
      LDA F.CCW     ELSE CHECK 'J' OPTION.
      AND B10K
      SZA,RSS       FOR SINGLE INTEGER: 'J' OPTION OFF
      SOC           AND FITS IN 16 BITS.
      JMP INC24     NO. DOUBLE. 
* 
INC29 LDA K14       'I' SUFFIX & TOO BIG ?
      SOC 
      JSB WAR.F     YES. GIVE WARNING.
* 
      LDB F.TC      NO. IF 'I' SUFFIX,
      CPB "I" 
      JSB ICH.F     SKIP OVER IT. 
      LDA F.IDI+1   SET UP SINGLE INTEGER CONSTANT. 
      STA F.IDI 
      LDA INT       F.IM=INT. 
      JMP INC16     SET F.IM & EXIT.
* 
INC28 JSB ICH.F     'J' SUFFIX, SKIP OVER IT. 
INC24 LDA DBI       F.IM=DBI, DOUBLE INTEGER. 
      JMP INC16 
* 
INC23 ISZ SIGN      NEGATIVE ?
      JMP INC35     NO. CAN'T BE O.K. 
* 
      CPA B100K     (A) = 100000
      CLE,SZB       (B) = 0  ?  (E=0) 
      JMP INC35     NO. OVERFLOW. 
      JMP INC22     YES. GO BACK TO STORE IT. 
* 
"B"   OCT 102 
"H"   OCT 110 
"I"   OCT 111 
"J"   OCT 112 
F.EIM NOP           EXPECTED ITEM MODE (SET BY DATA STMT) 
      SKP 
*                   FINISH UP REAL/DOUBLE WITH EXPONENT.
* 
INC30 LDA E/D       WHICH ? 
      CPA "E"       E ? 
      JMP INC32     YES, LEAVE SINGLE.
* 
      JSB CEX.F     CHECK FOR '**'. 
      CCA           ADD ANY LEFT-OVER DIGITS. 
      JSB INDIG 
      LDA F.SLF     DATA STATEMENT ?
      CPA K2
      RSS           (YES) 
      JMP INC31     NO. GO CHECK 'Y' OPTION.
* 
      LDA B1000     YES. ASSUME REAL*8; 
      LDB F.EIM     WHAT IS EXPECTED MODE ? 
      CPB DBL       IF REAL*6,
      CLA           THEN SET UP FOR THAT. 
      RSS           (A)=1000 FOR RE8, 0 FOR DBL.
INC31 LDA F.CCW     "D", DECIDE PRECISION OF CONSTANT.
      AND B1000     'Y' BIT.
      LDB DBL       ASSUME DBL = REAL*6 
      SZA           WELL ?
      LDB RE8       WRONG, RE8 = REAL*8.
      STB F.IM      SET UP TYPE.
      LDB K2        ALSO SET UP ADDR OF LAST WORD.
      SZA 
      INB           DBL=2, RE8=3   WORDS AFTER FIRST. 
      JMP INC33 
* 
*                   FINISH REAL/DOUBLE. 
* 
INC32 JSB CEX.F     CHECK FOR '**'. 
      CCA           ADD ANY LEFT-OVER DIGITS. 
      JSB INDIG 
      CLB,INB       COMPUTE ADDR LAST WORD. 
INC33 ADB F.DID 
      STB MANTL 
      LDA F.SID     SCAN MODE ? 
      SZA 
      JMP INC17     YES. CAN STOP NOW.
* 
      LDA F.IDI     TEST FOR ZERO.
      IOR F.IDI+1 
      SZA,RSS 
      JMP INC17     RESULT = 0. 
* 
      JSB NORML     ELSE NORMALIZE. 
      LDB EXPON     FINAL COMPUTATION OF NUMBER 
      ISZ EXPS      COMPUTE EXTERNAL
      CMB,INB          EXPONENT AS NEGATIVE 
      ADB D         ADJUST FOR DECIMAL POINT OR EXCESS DIGITS.
      CMB,INB 
      ADB T4INP     ACCOUNT FOR TRAILING ZEROES, EXTRA DIGITS.
      ASL 9         OFL IF OUTSIDE [-64,+64)
      SOC           SHOULD NEVER BE OUTSIDE [-60,+39] 
      JMP INC34     (MANTISSA IN [1,10**20],
      ASR 9            RESULT IN [10**-39,10**39] ) 
      LDA B 
      JSB PTEN      MULTIPLY BY POWER OF TEN. 
* 
*                   ROUND FLOATING.  CHECK FOR OFL UFL, PACK EXPONENT.
* 
      JSB .XCOM     (NEGATE) & ROUND. 
      LDB EXP       CHECK EXP 
      CLA           FOR USE IN FORMATTING EXP 
      ASL 8         MUST FIT IN 8 BITS WITH SIGN. 
      SOC 
      JMP INC34     NO, OFL/UFL.
      CLE,ELB       E=EXP SIGN, B<15:9>=EXP MANT. 
      BLF,BLF       B<7:1>=EXP MANT.
      RBR,ELB       B<7:0>=FORMATTED EXPONENT.
      LDA MANTL,I   LAST WORD MANTISSA. 
      AND BM400     MAKE ROOM FOR EXP.
      IOR B         PUT TOGETHER. 
      STA MANTL,I 
      JMP INC17     ALL DONE! 
* 
*                   OVERFLOW & UNDERFLOW HANDLING.
* 
INC34 CCE,SSB       OFL OR UFL ? (IF OFL, E=1)
      CLA,CLE,RSS   UFL. (E=0)
INC35 LDA BMAX      OFL.  E=1 IF FLOATING.
      STA F.IDI 
      RAL,ARS       UFL:0  OFL:-1 
      STA F.IDI+1 
      STA F.IDI+2 
      STA F.IDI+3 
      SEZ,RSS       INTEGER OR UFL ?
      JMP INC36     YES, DONE.
      LDA MANTL,I   FLOATING & OFL, CLEAR LAST BIT. 
      ALS 
      STA MANTL,I 
* 
INC36 LDB F.SID     SCAN MODE ? 
      LDA K14 
      SZB,RSS 
      JSB WAR.F     NO, USE UFL/OFL WARNING.
      JMP INC17     EXIT. 
      END 
ASMB,Q,C
      HED INPUT DUMMY LIST / LINK MANIPULATION. 
      NAM IDL.F,8 92834-12001 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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  PGMR:   B.G.                       * 
*************************************** 
* 
      EXT F.A       ASSIGNMENT TABLE ADDRESS (CURRENT ENTRY)
      EXT F.AT      ADDRESS TYPE OF CURRENT F.A 
      EXT F.NAR     NUMBER OF ALTERNATE RETURNS.
      EXT F.NT      NAME TAG: 0=VAR, 1=CONST. 
      EXT F.SBF     0=MAIN, ELSE F.A OF SUBROUTINE. 
      EXT F.SFF     SUBROUTINE/FUNCTION FLAG (0=SUB). 
      EXT F.SLF     STATEMENT LEVEL.
      EXT F.TC      NEXT CHARACTER. 
* 
      EXT DAF.F     DEFINE (F.AF) 
      EXT DAT.F     DEFINE (F.AT) 
      EXT DIU.F     DEFINE (F.IU) 
      EXT EXN.F     EXAMINE THE NEXT NONBLANK CHARACTER.
      EXT ICH.F     GET & TYPE NEXT NONBLANK CHARACTER. 
      EXT ISY.F     INPUT SYMBOL. 
      EXT RP.F      INPUT ')' 
      EXT TCT.F     TEST (A)=F.TC ELSE ERROR 28.
      EXT WAR.F     ISSUE WARNING.
* 
      ENT EL.F      EXCHANGE LINKS OF (F.A) AND (B).
      ENT FL.F      FETCH LINK OF (B).
      ENT IDL.F     INPUT DUMMY LIST. 
      SPC 1 
A     EQU 0 
B     EQU 1 
      SUP 
      SKP 
*         ***************************** 
*         * INPUT DUMMY ARGUMENT LIST * 
*         ***************************** 
      SPC 1 
*     ENTRY: F.A = A.T. ADDR OF SUB/FCT NAME. 
*     EXIT:  (A)=ADDR FIRST FORMAL, LINKED THRU F.AF FIELDS.
* 
IDL.F NOP 
      LDA B50       CHECK FOR 
      JSB TCT.F     '(' 
      JSB EXN.F     O.K., CHECK FOR EMPTY LIST. 
      CPB B51       WELL ?
      JMP IDL03     YES. THAT'S O.K.
* 
      CLA           NO. SET LINK OF DUMMY HEAD TO ZERO. 
      STA PLST+1
      LDA DPLST     START WITH F.A = DUMMY HEAD.
      STA F.A 
IDL00 LDA F.A       SAVE F.A OF PREV ITEM FOR LINKING.
      STA T1IDL 
* 
*                   IF SUBROUTINE'S PARAMS, LOOK FOR ALTERNATE RETURNS. 
* 
      LDA F.SLF     IF IN SUBPROGRAM PARAM LIST,
      IOR F.SFF     AND IT'S A SUBROUTINE,
      SZA 
      JMP IDL02     NO. 
* 
      JSB EXN.F     THEN LOOK FOR ALTERNATE RETURNS.
      CPA B52       '*' ? 
      RSS 
      CPA B46       '&' ? 
      RSS 
      JMP IDL02     NEITHER. NOT AN ALT RTN.
* 
      ISZ F.NAR     YES. COUNT IT.
      JSB ICH.F     AND READ IT.
      JSB ICH.F     AND POSITION AT THE DELIMETER.
      JMP IDL01     DONE WITH IT. 
* 
*                   ELSE GET THE PARAMETER AND DO SOME CHECKING.
* 
IDL02 JSB ISY.F     INPUT THE DUMMY NAME
      CLA           CLEAR WAR.F AS A FLAG 
      STA WAR.F     TO BE TESTED FOR WARNINGS LATER 
      LDB F.NT      IF NOT A NAME 
      LDA K74 
      SZB           SEND
      JSB WAR.F     WARNING 
      LDB F.A       IF SAME AS NAME 
      CPB F.SBF 
      JSB WAR.F     SEND ALSO 
      LDA K76       IF ALREADY DUM
      LDB F.AT      THEN
      CPB DUM       DOUBLY DEFINED DUMMY
      JSB WAR.F     SEND MESSAGE
      CLA           CLEAR 
      JSB DIU.F     THE F.IU
      LDA DUM       SET F.AT
      JSB DAT.F     TO DUM
      LDA WAR.F     IF NO WARNINGS SENT 
      SZA           THEN SKIP TO THE LINK 
      JMP IDL01     ELSE SKIP LINKING IT IN 
* 
      LDB T1IDL     LINK PREVIOUS TO CURRENT. 
      JSB EL.F      (F.AF OF CURRENT = SELF)
      CLA           SET CURRENT LINK TO ZERO. 
      JSB DAF.F     (SAFER THIS WAY: AI.F SET STMT FCT F.AF)
* 
*                   CHECK DELIMETER & LOOP. 
* 
IDL01 LDA F.TC      ANY MORE??
      CPA B54       ',' 
      JMP IDL00     YES GO GET IT 
* 
      JSB RP.F      ')' TEST FOR FINAL ')', PASS IT.
      LDA PLST+1    RETURN ADDR FIRST DUMMY.
      JMP IDL.F,I   EXIT. 
* 
IDL03 JSB ICH.F     EMPTY LIST. READ THE ')'. 
      JSB ICH.F     AND THE ONE AFTER IT. 
      CLA           RETURN A=0, NULL LIST.
      JMP IDL.F,I 
* 
T1IDL NOP 
DPLST DEF PLST      ADDR DUMMY HEAD.
PLST  DEC 0,0       DUMMY LIST HEAD.
B46   OCT 46        & 
B50   OCT 50        ( 
B51   OCT 51        ) 
B52   OCT 52        * 
B54   OCT 54        , 
K74   DEC 74
K76   DEC 76
      SKP 
*         **************
*         * FETCH LINK *
*         **************
      SPC 1 
*     ENTRY: (B) = F.A OF ITEM TO FETCH LINK OF.
*     EXIT:  (B) = ADDRESS OF LINK. 
*            (A) = VALUE OF LINK. 
* 
      SPC 1 
FL.F  NOP 
      STB F.A 
      LDA B,I 
      AND B600
      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 
      JMP FL.F,I
      SPC 2 
*         ******************
*         * EXCHANGE LINKS *
*         ******************
      SPC 1 
*     EXCHANGE AF(F.A) & AF(B)
      SPC 1 
EL.F  NOP 
      LDA F.A 
      STA T1EL
      JSB FL.F      FETCH LINK (B)
      STB T2EL      T2EL=LINK ADDR (B)
      LDB T1EL      (B)=ORIGINAL F.A
      STA T1EL      T1EL=LINK VALUE (B) 
      JSB FL.F      FETCH LINK
      STA T2EL,I    SET CURRENT IN OLD
      LDA T1EL      AND OLD IN
      STA B,I       CURRENT 
      JMP EL.F,I
      SPC 1 
B600  OCT 600       EXTRACT F.IU FIELD
ARR   EQU B600      F.IU=ARR
B7000 OCT 7000      EXTRACT F.AT FIELD. 
BCOM  OCT 3000      F.AT=BCOM 
DUM   OCT 5000      F.AT=DUM
T1EL  BSS 1 
T2EL  BSS 1 
* 
      END 
ASMB,Q,C
      HED FTN4X COMPILER CODE OUTPUT TO PASS 2
      NAM OA.F,8 92834-12001 REV.2030 800623
* 
*************************************************************** 
* (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-18001        * 
*  RELOC:  PART OF 92834-12001        * 
*  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)
*                 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 EXTRY 
   EXT     F.AF     ADDRESS FIELD CURREXT F.A 
   EXT     F.AT     ADDRESS TYPE OF CURREXT F.A 
 ENT       F.C      GENERAL OFFSET FOR CODE GENERATION. 
       EXT F.D.T    ADDRESS OF '.' FUN. TABLE 
   EXT     F.D0     ARRAY ELEMEXT SIZE
      EXT  F.DID    ADDRESS OF F.IDI
       EXT F.GRD    ACCESS TO GRD.F 
   EXT     F.IM     CURREXT ITEM MODE (REAL, COMPLEX,ECT.)
   EXT     F.IU     CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) 
 ENT       F.NIT    NO-INLINE-TEMP FLAG.
   EXT     F.NT     NAME TAG  0 = VAR, 1 = CONSTANT.
       EXT F.RES    F.A OF CURRENT RESULT.
       EXT F.RPL    PROGRAM LOCATION COUNTER
       EXT F.XID    EXTERNAL ID COUNTER.
* 
*     EXT'S WITH A TRAILING '.F' ARE SUBROUTINES
* 
   EXT     DAF.F    DEFINE (F.AF) 
   EXT     DL.F     DEFINE LOCATION SUBROUTINE
   EXT     FA.F     FETCH ASSIGNS 
 ENT       IN2.F    INIT FOR OA.F MODULE
 ENT       OA.F     OUTPUT ASSIGNMEXT TABLE OPERAND 
 ENT       OAD.F    OUTPUT ABS. DATA
 ENT       OAI.F    OUTPUT ABS. INSTRUCTION 
 ENT       OC.F     OUTPUT CONSTANT 
 ENT       ODD.F    OUTPUT DEF TO DOT FUNCTION. 
 ENT       ODF.F    OUTPUT DOT FUNCTION 
 ENT       OID.F    OUTPUT INSTRUCTION, DOT-OPERAND.
 ENT       OLR.F    OUTPUT LOAD ADDRESS 
 ENT       OMR.F    OUTPUT MEMORY REF. INSTRUCTION
 ENT       ORI.F    OUTPUT ABS. REGISTER INSTRUCTION. 
 ENT       OS.F     FLUSH THE BUFFER. 
 ENT       OW.F     OUTPUT WORD 
 ENT       OZ.F     OUTPUT ZREL  (OP *+N) 
 ENT       PDF.F    PRODUCE DEF SUBROUTINE
 ENT       SOA.F    STORE AND OUTPUT (OA.F) 
* 
*     EXTERNALS IN RTM.F .
* 
* 
* 
*     COMPILER LIBRARY ROUTINES 
* 
      EXT WRT.C     WRITE RECORD
      EXT C.SC0     FCB FOR 2ND PASS FILE.
* 
A     EQU 0 
B     EQU 1 
* 
ADDR  OCT 70000     F.IM=7  ADDRESS 
      SPC 1 
* 
      SKP 
*         ******************************************* 
*         * OUTPUT ASSIGNMENT TABLE POINTER OPERAND * 
*         ******************************************* 
      SPC 1 
*                   PROCESS ABSOLUTE INSTRUCTIONS, CHANGE INDIRECTNESS
*                   OF FORMAL PARAMS, OUTPUT 'DEF' ENTRIES IMMEDIATELY. 
* 
OA.F  NOP 
      STA T0OA      TEMP CELL TO HOLD OPCODE WORD 
      LDB F.A       IF F.A IS 
      SZB           ZERO THEN PRODUCE AN
      CPB K1        (ONE ALSO)
      JMP OA03A     ABSOLUTE INSTRUCTION
* 
      JSB CDO.F     NO, CHECK FOR DATA WITH OFFSET. 
      STB F.A 
      JSB FA.F
      LDA T0OA      GET THE OP CODE 
      LDB F.IM      IF THIS IS
      ADB F.NT      A DEF ENTRY 
      CPB K1        THEN SKIP THE REST OF THE CHECKS
      JMP OA015     AND PUT OUT THE CODE
* 
      LDB F.AT
      CPB DUM       IS OPERAND TAGGED DUMMY?
      RSS 
      JMP OA01      NO. 
* 
      XOR KK01      YES, CHANGE THE INDIRECT OPTION.
      STA T0OA      SAVE THE NEW INSTRUCTION
      JMP OA015     GO SEND A.T. BASED INSTRUCTION. 
* 
OA03A AND C2000     CLEAR THE CURRENT PAGE BIT
      STA T0OA      SAVE WHILE GETTING REG INFO.
      JSB F.GRD,I   GET REGISTER INFO.
      DEF F.A 
      LDA T0OA      RESTORE INSTRUCTION,
      IOR F.A       ADD REGISTER NUMBER,
      SSB,RSS       IF THE REGISTER IS DEFINED, 
      SOS           AND IT'S AN ADDRESS,
      RSS           (NO)
      IOR SIGN      SET THE INDIRECT BIT. 
      JSB OAI.F     SEND ABS INSTRUCTION
OA04  CLA           CLEAR THE NO-INLINE-TEMP FLAG.
      STA F.NIT 
      JMP OA.F,I    RETURN
      SKP 
*                   CHECK FOR SPECIAL PROCESSING. 
* 
OA01  LDA F.IU
      CPA SUB       IS OPERAND AN EXTERNAL NAME 
      JMP OA03      YES, GEN. EXT. REF. INSTRUCTION 
* 
      LDB F.AT      IS OPERAND
      CPB BCOM      LABELED COMMON? 
      JMP OA10      YES GO DO SPECIAL 
* 
      CPB DIM       DIMENSION ENTRY ? 
      RSS 
      CPB BCOMI     OR BCOM OFFSET ?
      JMP OA015     YES. MUST BE NORMAL DEF.
* 
      LDA T0OA      LOAD FIRST WORD OF INSTRUCTION
      CPB COM.      IN COMMON?
      ADA K2        YES, SET BIT 2 OF FIRST WORD ON.
      STA T0OA      UPDATE INSTRUCTION. 
      LDB F.IM      DOES OPERAND HOLD 
      CPB ADDR      ARRAY ELEMENT ADDRESS?
      JMP OA05      YES GO CHECK IF DEF 
* 
*                   OUTPUT THE CODE.
* 
OA07  LDB F.AF      (IN CASE ARRAY NAME)
      LDA F.IU      IS OPERAND
      CPA ARR       AN ARRAY NAME?
      JMP OA02      YES, OUTPUT INSTR. WITH RPL 
* 
OA015 LDB F.A       NO, OUTPUT THE
      ADB KK01      INSTRUCTION WITH (B) _ F.A,I
OA02  LDA T0OA
      JSB OMR.F 
      JMP OA.F,I
* 
*                   ADDRESS TEMP.  TRY TO DEFINE IN-LINE. 
* 
OA05  XOR KK01      ADD THE SIGN BIT. 
      STA T0OA      & SET NEW INSTRUCTION.
      LDB F.NIT     (TO CHECK FOR INHIBITION OF INLINE) 
      CPA KK01      IS IT 'DEF TEMP,I' ?
      SZB           AND INHIBIT FLAG CLEAR ?
      JMP OA07      NO. LEAVE IT ALONE. 
* 
      JSB DL.F      SET F.AT TO REL 
      LDA F.LLO     GET THE CURRENT LOAD ADDRESS
      SSA,RSS       IF DIRECT 
      ADA ADON      GET THE ACTUAL ADDRESS
      JSB DAF.F     DEFINE ADDRESS OF ADCON 
      LDA F.LLO     GET THE BASE ADDRESS AGAIN
      LDB ADON      IF A SYMBOL TABLE POINTER 
      SSA,RSS       THEN WE MUST
      CLB             (NO USE ZERO) 
      LDA F.A       INCLUE THE OFFSET 
      ADA K2        SET THE NAME
      STB A,I       IN THE A.T. 
      JMP OA015     GO SEND IT
      SKP 
*                   EXTERNAL REF. 
* 
OA03  LDB F.A       F.IU IS SUBPROG; GEN. EXT. REF. 
      INB           (B) POINTS TO AF FOR
      JSB GETEX     GET EXT NO FOR IT 
      JMP OA015     GO SEND 
* 
*                   LABELLED COMMON REF.
* 
OA10  LDB F.AF      LABELED COMMON REF. 
      INB           GET INFO. ENTRY ADDRESS 
      LDA B,I       GET OFFSET
      ADA F.C       ADD THE THE CURRENT OFFSET
      STA F.C       AND SAVE IT 
      INB           GET ADDRESS OF
      LDB B,I       THE EXT NO
      INB           AND 
      JSB GETEX     GO SET IT UP
      ADB N1PS      SUBTRACT ONE AND ADD THE SIGN 
      LDA T0OA      AND THE INSTRUCTION 
      JSB OW.F      PUT OUT A 
R111  OCT 160000    R=111 3- WORD EXT WITH OFFSET 
      JMP OA.F,I    RETURN
* 
T0OA  NOP 
F.NIT NOP           NO-INLINE-TEMPS FLAG. 
COM.  OCT 4000      F.AT=COM
C2000 OCT 175777    COMPLEMENT OF 2000 (THE CURRENT PAGE BIT) 
K1    DEC 1 
DUM   OCT 5000      AT = 5
DIM   OCT 6000      AT = 6
SUB   OCT 200       IU = 1
ARR   OCT 600       IU = 3
K2    DEC 2 
KM1   DEC -1
B10   OCT 10
BCOM  OCT 3000      F.AT=BCOM 
SIGN  DEF 0,I       NT=1,IM=0  => A DEF ENTRY 
      SKP 
*         ******************************
*         * CHECK FOR DATA WITH OFFSET *
*         ******************************
     SPC 1
*     INPUT:  (B)=CANDIDATE F.A 
*     OUTPUT: (B)=UPDATED F.A;  IF DATA WITH OFFSET, F.C UPDATED. 
      SPC 1 
CDO.F NOP 
      LDA B,I       FIRST WORD. 
      AND NT&IU     F.NT & F.IU 
      CPA DPO       DATA PLUS OFFSET ?
      RSS 
      JMP CDO.F,I   NO, EXIT. 
      ADB K2        YES. ADD OFFSET TO F.C
      LDA B,I 
      ADA F.C 
      STA F.C 
      ADB KM1       SET (B) TO F.A OF MASTER. 
      LDB B,I 
      JMP CDO.F,I 
      SPC 2 
*                   *********************** 
*                   * GET EXT ID FROM TBL * 
*                   *********************** 
* 
* 
GETEX NOP 
GET00 LDA B,I       GET THE CURRENT VALUE 
      CMA,INA,SZA   IF NON-ZERO THATS ALL THERE IS TO IT
      JMP GETEX,I   JUST RETURN IT
* 
      ISZ F.XID     ALLOCATE A NEW EXT
      LDA F.XID     AND 
      CMA,INA       SET ITS NEGATIVE
      STA B,I       IN THE TABLE
      JMP GET00     GO SET IT AND EXIT
      SKP 
*         *********************** 
*         * STORE AND OUTPUT OA * 
*         *********************** 
      SPC 1 
SOA.F NOP 
      STB F.A       SAVE IT 
      JSB OA.F
      JMP SOA.F,I 
      SPC 2 
*         ************************
*         * OUTPUT ABSOLUTE DATA *
*         ************************
      SPC 1 
OAD.F NOP 
      JSB OW.F      OUTPUT THE INSTRUCTION
       OCT 0        R=0 FOR ABSOLUTE DATA (OCT WORD)
      JMP OAD.F,I   RETURN A=0, E=1 
      SPC 2 
*         ******************************* 
*         * OUTPUT ABSOLUTE INSTRUCTION * 
*         ******************************* 
      SPC 1 
OAI.F NOP 
      JSB OW.F
       OCT 060000   R011 FOR MNEMONIC OPCODE
      JMP OAI.F,I   RETURN A=0, E=1 
      SPC 2 
*         ****************************************
*         * OUTPUT ABSOLUTE REGISTER INSTRUCTION *
*         ****************************************
      SPC 1 
ORI.F NOP 
      ALF,RAL       MOVE BIT 11 TO BIT 0. 
      IOR F.RES     INSERT A/B BIT. 
      ALF,ALF       RESTORE.
      ALF,RAR 
      JSB OAI.F     NOW OUTPUT. 
      JMP ORI.F,I   DONE. 
      SKP 
*         *************************************** 
*         * OUTPUT MEMORY REFERENCE INSTRUCTION * 
*         *************************************** 
      SPC 1 
OMR.F NOP 
      JSB OW.F      OUTPUT INSTRUCTION
R101   OCT 120000   R=5 FOR MEMORY REFERENCE
      LDB T1OW      GET THE ADDRESS 
      ADB K8        ALLOW A NEGATIVE OFFSET OF 8
      SSB,RSS       IF NOT AN A.T. REF
      JMP OMR.F,I   JUST RETURN 
* 
      ADB KK03      RESTORE THE ADDRESS TO B
      LDA B,I       SET THE USED BIT
      IOR B10       IN THE A.T. 
      STA B,I       AND THEN
      CLA 
      JMP OMR.F,I   RETURN
      SPC 2 
*         *************************************** 
*         * OUTPUT INSTRUCTION WITH DOT-OPERAND * 
*         *************************************** 
      SPC 1 
OID.F NOP 
      STA T1OID     SAVE THE INSTRUCTION. 
      ADB F.D.T     GET ADDRESS TO B
      JSB GETEX     GET THE EXT ID
      IOR T1OID     ADD THE INSTRUCTION.
      JSB OW.F      SEND IT 
KK01  OCT 100000
      JMP OID.F,I   AND RETURN
* 
T1OID NOP           SAVED INSTRUCTION CODE. 
      SPC 2 
*         *********************** 
*         * OUTPUT DOT FUNCTION * 
*         *********************** 
      SPC 1 
ODF.F NOP 
      LDA JSBI      JUST JSB TO IT. 
      JSB OID.F     SEND IT 
      JMP ODF.F,I   AND RETURN
      SPC 2 
*         ******************************
*         * OUTPUT DEF TO DOT FUNCTION *
*         ******************************
      SPC 1 
ODD.F NOP 
      CLA           A=0 FOR DEF.
      JSB OID.F     SEND IT.
      JMP ODD.F,I   EXIT. 
      SKP 
*                   ********************************************
*                   * PRODUCE THE DEF DESCRIBED BY CURRENT F.A *
*                   ********************************************
* 
* 
PDF.F NOP 
      LDA F.RPL     DEFINE ITS ADDRESS
      JSB DAF.F     AS THE CURRENT ADDRESS
      LDB F.AT      WHERE IS IT 
      CPB BCOMI     LABELED COM?
      JMP PDF03     YES DO SPECIAL
* 
      CLA           NO SET FOR DEF
      CPB COM       IN COMMON?
      LDA K2        YES SET MR
      LDB F.A       INDEX 
      ADB K2        INTO THE ENTRY
      LDB B,I       AND GET THE ADDRESS 
      JSB OMR.F     OUTPUT THE WORD 
PDF02 LDA F.A,I     SET THE R FLAG
      IOR B20       TO SHOW 
      STA F.A,I     IT WAS DONE 
      JMP PDF.F,I   AND RETURN
* 
PDF03 LDB F.A       LABELED COMMON REFERENCE
      ADB K2        GET THE 
      LDA B,I       OFFSET AND
      STA F.C       SET UP
      INB           GET THE 
      LDB B,I       ADDRESS OF THE MASTER 
      JSB CDO.F     IF DATA WITH OFFSET, FIX THAT.
      INB           INDEX TO THE EXT WORD.
      JSB GETEX     GET THE EXT NO
      ADB N1PS      ADD THE SIGN BIT AND SUBTRACT ONE 
      CLA           SET INSTRUCTION TO DEF
      JSB OW.F      SEND IT 
      OCT 160000    MAKE SURE IT IS WITH OFFSET 
      JMP PDF02     GO SEND IT
* 
* 
K8    DEC 8 
F.C   NOP 
B20   OCT 20
COM   OCT 4000      F.AT=COM
BCOMI OCT 7000      F.AT=BCOMI
N1PS  OCT 77777     -1+100000B
KK03  OCT 77770     -8-100000B
JSBI  OCT 16000 
      SKP 
*         *************************** 
*         * OUTPUT LOAD ADDRESS=RPL * 
*         *************************** 
      SPC 1 
OLR.F NOP 
      CLB 
      LDA F.RPL 
      JSB OW.F
R001   OCT 20000    R=1 
      JMP OLR.F,I   RETURN A=0, E=1 
      SPC 2 
*         *************** 
*         * OUTPUT ZREL * 
*         *************** 
      SPC 1 
OZ.F  NOP           OUTPUT COMMAND OF FORM 'OP *+N' 
      ADB ADON      ADD CURRENT DISPLACEMENT
      ADB F.C       NOT CURRENTLY NEEDED BUT FEEL FREE
      STB F.C       SET THE TOTAL DISPLACEMENT
      LDB F.LLO     GET THE BASE ADDRESS
      JSB OMR.F     OUTPUT INSTR. (A) HAS OP IN IT
      JMP OZ.F,I
      SPC 2 
*         ******************* 
*         * OUTPUT CONSTANT * 
*         ******************* 
      SPC 1 
OC.F  NOP           OUTPUT INT,REA,LOG,CPX, OR DBL
      LDA F.D0+1    CONSTANT. 
      CMA,INA 
      STA T0OC      -LENGTH OF CONST
      LDA F.DID     1ST LOC OF F.IDI
      STA T1OC
OC01  LDA T1OC,I
      JSB OAD.F     OUTPUT WORD 
      ISZ T1OC
      ISZ T0OC
      JMP OC01      NOT DONE; OUTPUT MORE WORDS.
      JMP OC.F,I    RETURN A=0, E=1 
* 
T0OC  NOP 
T1OC  NOP 
      SKP 
*         *************** 
*         * OUTPUT WORD * 
*         *************** 
      SPC 1 
*     INPUT: (A)=WORD TO BE OUTPUT
*            (B)=2ND WORD IF MR 
*            (F.C)=OFFSET IF R=111 OR IF R=101 AND F.C#0
*      THEN: JSB OW.F 
*            VFD 3/R,13/0 
*      WHERE R = RELOCATION INDICATOR IN HIGH ORDER (-1 IF SRC) 
* 
*      THE VALUES OF 'R' AND THEIR MEANINGS ARE:
* 
*          R=000  OCTAL DATA. 
*          R=001  ORG TO (B). 
*          R=010  ASCII DATA. 
*          R=011  ABSOLUTE INSTRUCTION. 
*          R=100  EXTERNAL, EXT ID IN LOW BITS. 
*          R=101  MEM REF INSTRUCTION TO (B). 
*          R=110  BYTE DEF; A<15>=LSB, (B)=WORD ADDR. 
*          R=111  EXTERNAL (B) WITH OFFSET (F.C). 
* 
*                   SET UP WORD TO OUTPUT AND RELOCATION INDICATOR. 
*                   IF R=1,5,7 THEN SET UP ADDRESS. 
* 
OW.F  NOP 
      STA T0OW      SAVE (A)
      STB T1OW      SAVE (B), JUST IN CASE. 
      LDA OW.F,I    (A)=RELOCATION INDICATOR. 
      ISZ OW.F
      STA R         SAVE 'R'; SEE IF ADDRESS IN (B).
      CPA R001      R=1,5,7 ? 
      RSS 
      CPA R101
      RSS 
      CPA R111
      RSS 
      JMP OW01      NO. IGNORE (B). (OR BYTE ADDR)
* 
      STB T1OW      YES, SET AS TENTATIVE ADDR. 
      ADB K8        A.T. REF ?
      SSB,RSS 
      JMP OW01      NO. 
* 
      ADB KK03      YES. RESTORE & REMOVE BIT 15. 
      JSB CDO.F     HANDLE DATA WITH OFFSET.
      ADB SIGN      PUT BIT 15 BACK,
      STB T1OW      AND SET AS ADDRESS. 
      SKP 
*                   IF R=5 & F.C#0, CHANGE R TO 7.
* 
OW01  LDB R         (B)=R.
      LDA F.C       (A)=OFFSET. 
      CPB R101      IF R=5, NORMAL MEM REF, 
      SZA,RSS       AND OFFSET#0, 
      RSS           (NO. LEAVE IT)
      LDB R111      THEN SET TO OFFSET TYPE.
      STB R         (IN CASE CHANGED) 
* 
*                   IF NEW RECORD (E.G. INIT) THEN START IT UP. 
* 
      CPB R001      IS THIS A NEW LOAD LOC? 
      JMP OWS41     YES 
* 
      CLB,INB       IF A NEW RECORD 
      CPB F.BUF     THEN
      JMP OW07      GO SET IT UP
* 
*                   SEE IF ENOUGH ROOM IN CURRENT RECORD. 
* 
      LDA KM63      DETERMINE ROOM IN PRESENT SECTOR
      ADA F.BUF     ADD CURRENT USAGE 
      LDB R         ADD TO PRIOR DATA RECORD. 
      CPB R111      IF OFSET
      INA,RSS       ADD TWO 
      CPB R101      MEM REF?
      RSS 
      CPB R110      OR BYTE ADDR ?
      INA           YES. NEEDS EXTRA WORD.
      LDB RNO 
      ADB KM5.
      SSB,RSS       NEW BYTE WORD NEEDED? 
      INA           YES. ALLOW FOR IT 
      SSA,RSS       ROOM FOR THESE WORDS? 
      JMP OW06      NO. USE NEW RECORD. 
* 
*                   IT FITS. BUT MAY STILL NEED NEW R-WORD. 
* 
      SSB,RSS       BYTE WORD FULL? 
      JMP OW16      YES. START NEW BYTE WORD
      JMP OW17      USE PRESENT ONE 
* 
*                   START A NEW RECORD. 
* 
OW06  JSB OS.F      FULL. OUTPUT RECORD 
OW07  LDA F.LLO     LOAD LOCATION 
      JSB WR        SEND IT 
      LDA ADON      ADD-ON
      JSB WR        SEND IT 
      SKP 
*                   START A NEW RELOCATION INDICATOR WORD.
* 
OW16  LDA PBPT      START NEW BYTE WORD.
      STA RPTR      SAVE ITS LOCATION 
      CLA 
      STA RNO 
      JSB WR        SEND A ZERO 
* 
*                   INSERT RELOCATION INDICATOR.
* 
OW17  LDB RNO       REL BYTE NO.
      BLS 
      ADB RNO       3*RNO 
      LDA R         RECORD TYPE BYTE
      CMB,RSS 
      RAR           POSITION R-BYTE 
      INB,SZB       SHIFT COMPLETE? 
      JMP *-2       NO
      IOR RPTR,I
      STA RPTR,I    COMBINE PRIOR BYTE WORD 
      ISZ RNO       BUMP THE COUNT. 
* 
*                   BUMP LOCATION COUNTER & CHECK FOR OFL.
* 
      ISZ ADON      ADON=ADON+1 
      ISZ F.RPL     RPL=RPL+1 
      LDB F.RPL 
      LDA K84       OVERFLOW CODE 
      SSB           OVERFLOW??
      JMP F.ABT     RPL OVERFLOW
* 
*                   OUTPUT THE CODE.
* 
      LDA T0OW
      JSB WR        SEND THE WORD 
      LDB R 
      LDA T1OW      GET WORD TWO
      CPB R101      MEMORY REFERENCE? 
      RSS 
      CPB R110      OR BYTE ADDR ?
      RSS 
      CPB R111      OR OFFSET TYPE? 
      JSB WR        SEND IT IN THIS CASE ALSO 
      LDA F.C       GET OFFSET
      CPB R111      OFFSET TYPE 
      JSB WR        YES SEND THE OFFSET 
      CLA,CCE       CLEAR A AND 
      STA F.C       F.C 
      JMP OW.F,I    RETURN A=0, E=1 
      SKP 
*                   ORG.
* 
OWS41 LDA T0OW      ELSE SET UP 
      STA F.LLO     THE NEW ADDRESS 
      LDA T1OW      AND 
      STA ADON      OFFSET
      JSB OS.F      FLUSH THE CURRENT RECORD
      JMP OW.F,I    AND RETURN (A=0, E=1) 
* 
WR    NOP           WRITE WORD AND PUSH POINTERS
      STA PBPT,I
      ISZ PBPT
      ISZ F.BUF 
      JMP WR,I      RETURN
* 
F.LLO NOP           LOAD LOCATION 
ADON  NOP           ADD-ON TO LOAD LOCATION 
PBPT  NOP           PBUF WORD POINTER 
RPTR  NOP           RECORD R1R2R3R4R5 LOCATION
RNO   NOP           R NUMBER
KM5.  DEC -5
T0OW  NOP           SAVE ENTRY (A)
T1OW  NOP           SAVE ENTRY (B)
R     NOP           INTERMEDIATE CODE RECORD TYPE 
KM63  DEC -63 
R110  OCT 140000
K84   DEC 84
NT&IU OCT 000601    MASK F.NT & F.IU
DPO   EQU NT&IU     F.NT=1 & F.IU=ARR 
      SKP 
*         ***************** 
*         * OUTPUT SECTOR * 
*         ***************** 
      SPC 1 
OS.F  NOP 
      CLB,INB       IF EMPTY RECORD 
      CPB F.BUF     JUST
      JMP OS.F,I    RETURN
* 
      LDB OWK1
      STB PBPT      RESET PBUF POINTER
      JSB WRT.C     OUTPUT BUFFER TO DISC 
      DEF C.SC0 
OWK1  DEF F.BUF 
      DEF F.BUF     FIRST WORD IS THE TRUE LENGTH 
      JMP PASER     IF NO ERROR RETURN
* 
      CLA,CCE       SET BUFFER TO POINT TO NEXT WD
      JSB WR        AND COUNT TO ONE
      JMP OS.F,I    RETURN  A=0, E=1
* 
PASER LDA K99       SEND PASS WRITE BOOM
      JMP F.ABT     NO RETURN 
      SPC 1 
K99   DEC 99
* 
IN2.F NOP           INIT CODE FOR THIS MODULE 
      LDA OWK1      REMOVE THE INDIRECT 
      RAL,CLE,SLA,ERA IF SET
      LDA A,I       GET THE REAL ADDRESS
      STA OWK1      ON THE BUFFER ADDRESS 
      STA PBPT
      CLA           SET COUNT TO 1 AND PUSH THE POINTER.
      JSB WR
      JMP IN2.F,I   RETURN
* 
F.BUF BSS 65        BUFFER FOR WRITING TO PASS FILE.
* 
      END