ASMB,R,L,C
      HED RTE-M FORTRAN--SEGMENT 2--PASS 2
      NAM FTN2,5 92064-16047  REV.1650  761118
      SUP 
* 
* 
*   ********************************************************* 
*   * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1976.           * 
*   *                                                       * 
*   * ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM MAY BE  * 
*   * PHOTOCOPIED, REPRODUCED, OR TRANSLATED TO ANOTHER     * 
*   * PROGRAM LANGUAGE WITHOUT THE PRIOR WRITTEN CONSENT OF * 
*   * HEWLETT-PACKARD COMPANY.                              * 
*   ********************************************************* 
* 
* 
      ENT FTN2
* 
      EXT .STOP,OPEN,FCONT,PURGE,LIMEM,READF,WRITF
      EXT IDCB0,IDCB1,IDCB2,IDCB3,FMPER,CLOSE,RWNDF 
      EXT EXEC,IMESS
* 
      COM LCLIS 
      COM MCBUF(40) 
      COM PTYPE 
      COM BUFAD 
      COM OPT(3)
      COM ...T
* 
      COM AI(6),AO(6),AL(6),AS1(6)
      COM ERRS,OPTS1,OPTS2,OPTS3,NAME,LINES 
      COM FDVL,OPT4 
* 
* 
BUFOR DEF MCBUF     MULTI-COMPILE BUFFER
BUFND DEF MCBUF+40  END OF BUFFER +1
ENTR. DEF GENTR 
ENTRY DEF FTN2      START OF PASS 2 PROCESSING
*                   PTYPE - PROG TYPE: PROG=1,SUBR=2
*                   INT.FUNCTION=3,REAL FUNCT=4 
*                   OPT - OPTION FLAGS: 0 FOR NONE
*                   ORDER: LIST,ASMBLY LIST,BINARY
TILT  CLA,RSS 
STOP  NOP 
      JSB .STOP 
* 
      SKP 
* 
.CON0 OCT 0 
O1    OCT 1 
O2    OCT 2 
O3    OCT 3 
O4    OCT 4 
O5    OCT 5 
O6    OCT 6 
O7    OCT 7 
O10   OCT 10
O11   OCT 11
O12   OCT 12
O14   OCT 14
O16   OCT 16
O17   OCT 17
O20   OCT 20
O21   OCT 21
O22   OCT 22
O23   OCT 23
O24   OCT 24
O25   OCT 25
O31   OCT 31
O32   OCT 32
O34   OCT 34
O35   OCT 35
O40   OCT 40
M1    OCT -1
M2    OCT -2
M3    OCT -3
M4    OCT -4
M5    OCT -5
* 
AEBAS BSS 1         ASF ERASABLE STORAGE BASE ADDR. 
BCLIS BSS 1         FWA OF CONLIST
CLEN  BSS 1         COMMON LENGTH 
CNSIZ BSS 1         MAX.SIZE OF CONSTANTS AREA
CODE  BSS 1 
CSBAS BSS 1         CONSTANTS BASE ADDR.
ENTAD BSS 1         ENTRY POINT ADDR. 
ERBAS BSS 1         PROG ERAS.STORAGE BASE ADDR 
.EXTS DEF HEXTS     SYMBOL TABLE SEARCH & INSERT
C1A   DEF CREP1 
C2A   DEF CREP2 
LABAS BSS 1         LABEL REF BASE ADDR.
LDVL  BSS 1         LWA+1 OF DVLIST 
LVBAS BSS 1         BASE OF LOC.VAR.AREA
LVSIZ BSS 1         SIZE OF LOC.VAR AREA
AESIZ BSS 1         SIZE OF ASF ERAS AREA 
ERSIZ BSS 1         SIZE OF PROG ERAS AREA
LBSIZ BSS 1         SIZE OF LABEL REFS AREA 
MBUF  BSS 40        READ BUFFER FOR FTN MIDDLE OUTP 
MBUF1 DEF *         LWA+1 OF READ BUFFER
MBUFF DEF MBUF      FWA OF READ BUFFER
READB DEF READL     ENTRY TO READ ROUTINE 
PARM  BSS 1         NUMBER OF FORMAL PARAMETERS 
PASS  OCT 1         PASS-FLAG FOR CREP
*                                  1=PUNCH, 2=LIST ASMB, 3=BOTH 
PLEN  BSS 1         PROGRAM LENGTH
RELAD BSS 1         CALUE OF REL.ADDR.FOR WHICH 
RELC  BSS 1         RELOC.CODE:0=ABSOL,1=PROG RELOC,
*                                   3=COMMON RELOC, 4=EXT 
RFLAG BSS 1         FLAG FOR READB. =0 FOR INIT.CALL
SAVAD BSS 1 
SAVOR BSS 1         FWA OF FORMATS-SAVE AREA
SAVND BSS 1         CURRENT ADDR.IN SAVE AREA 
TCLIS BSS 1         CURRENT ADDR.IN CONLIST 
XTORD BSS 1         CURRENT EXT ORDINAL 
IFWAM BSS 1         DUMMY LOCATION
IWRDS BSS 1           "     " 
IWS   BSS 1           "     " 
IFWAS EQU SAVOR     FWAM FOR SEGMENT 2
      SKP 
* 
*CNASC CONVERTS AN INTEGER LT 32K TO ASCII.A=NUMBER 
*AT ENTRY.
* 
CNASC NOP 
      LDB WM10K     -10000D 
      JSB WGETD     GET UPPER DIGIT 
      ADB W6060     CONVERT TO ASCII
      STB CNASC,I   RETURN UPPER 2 DIGITS IN LOC. 
*                   FOLLOWING CALL
      ISZ CNASC     BUMP RETURN ADDR. 
      LDB WM1K      -1000D
      JSB WGETD     GET 2ND DIGIT 
      BLF,BLF       SHIFT TO UPPER 8 BITS 
      STB CNBUF     SAVE
      LDB WM100     -100D 
      JSB WGETD     GET 3RD DIGIT 
      ADB CNBUF     ADD 2ND DIGIT IN
      ADB W6060     CONVERT TO ASCII
      STB CNBUF     SAVE
      LDB WM10D     -10D
      JSB WGETD     GET 4TH AND 5TH DIGIT 
      BLF,BLF 
      ADB 0 
      ADB W6060     B= ASCII OF 4TH AND 5TH DIGIT 
      LDA CNBUF     A= ASCII OF 2ND AND 3RD DIGIT 
      JMP CNASC,I   EXIT
* 
      SKP 
*CNOCT CONVERTS A NUMBER IN A TO OCTAL ASCII **** 
* 
CNOCT NOP 
      RAL 
      STA 1         SAVE IN B 
      AND O1
      ALF,ALF 
      STA CSAVE+1   SAVE SIGN DIGIT 
      JSB OCDIG     GET OCTAL DIGIT IN A
      ADA CSAVE+1   ADD SIGN DIGIT
      ADA W6060     CONVERT TO ASCII
      STA CNOCT,I   RETURN THRU RETURN ADDR 
      ISZ CNOCT     BUMP RETURN ADDR
      JSB OCDIG     3RD DIGIT 
      ALF,ALF 
      STA CSAVE+1   SAVE
      JSB OCDIG     4TH DIGIT 
      ADA CSAVE+1 
      STA CSAVE+1 
      JSB OCDIG     5TH DIGIT 
      ALF,ALF 
      STA CSAVE+2 
      JSB OCDIG     6TH DIGIT 
      ADA CSAVE+2 
      LDB 0 
      LDA CSAVE+1 
      ADA W6060     CONVERT TO ASCII
      ADB W6060 
      JMP CNOCT,I   EXIT
* 
OCDIG NOP 
      LDA 1 
      RAL,RAL 
      RAL 
      STA 1 
      AND O7        MASK OCTAL DIGIT
      JMP OCDIG,I 
      SKP 
* 
*FIND NEXT DVL ENTRY **** 
*ENTER A=LOC DVL  EXIT A=LOC NEXT ENTRY *** 
* 
NENT  NOP 
      LDB 0 
      JSB NXDVL 
      LDA 1 
      JMP NENT,I
* 
      BSS 1 
NXDVL NOP      B CONTAINS DVL LOC 
      LDA 1,I  FIRST ENTRY
      SZA           ZERO MEANS LABEL ENTRY
      JMP *+3 
      ADB O4        LENGTH OF LABEL ENTRY 
      JMP NXDVL,I 
      AND O7
      INA 
      ARS 
      ADA O2
      STA NXDVL-1 
      LDA 1,I 
      SSA,RSS 
      JMP NXDV1  NOT DIMEN
      INB 
      RAL 
      SSA 
      INB 
      ARS 
      ALF,ALF 
      AND O77 
      SZA,RSS 
      INB 
NXDV1 ADB NXDVL-1   COUNT ORD 
      JMP NXDVL,I 
**
**
WGETD NOP 
      STB CSAVE+1   SAVE COMPARISON VALUE 
      CLB           0 TO DIGIT
WGTD1 STA CSAVE     SAVE REMAINDER
      ADA CSAVE+1   COMPARE 
      SSA           LARGER ?
      JMP WGTD2     NO,READY
      ISZ 1         YES,BUMP DIGIT
      JMP WGTD1     CONTINUE
WGTD2 LDA CSAVE     A=REMAINDER 
      JMP WGETD,I    EXIT 
      SKP 
* 
*SCATR SCATTERS A SYMBTAB ENTRY FOR WHICH THE BETA
*FORMAT IS GIVEN IN A. IT RETURNS: A= ADDR.+1 OF
*ENTRY IN SYMBTAB, B= NO.OF WORDS IN NAME OF ENTRY+1
*OTHER VALUES THROUGH PARAMETERS. 
* 
SCATR NOP 
      LDB 0         FORMAT TO A FOR WPFAD 
      JSB WPFAD 
      CMA,INA 
      STA CSAVE     SET COUNT 
      LDA FDVL      FWA OF DVLIS
      JSB NENT      GET FWA OF NEXT ENTRY 
      ISZ CSAVE     READY?
      JMP *-2       NO,GET NEXT ENTRY 
      STA CSAVE     YES, SAVE FWA OF ENTRY
      INA 
      STA CSAVE+1   SAVE FWA+1
      LDA CSAVE,I   1ST WORD IN ENTRY 
      RAL,RAL 
      AND O3
      STA V         SET V-FIELD 
      ADA M3
      STA SSAVE     SAVE FLAG 
      LDA CSAVE,I 
      AND O7        GET NO. OF CHARS. 
      ADA O3
      ARS 
      STA SSAVE+1   SAVE NO.OF WORDS+1 IN NAME
      ADA CSAVE+1   A=ADDR. OF ORD
      LDB 0,I 
      STB ORD       SET ORDINAL 
      INA 
      LDB 0,I 
      STB DIM1
      ISZ SSAVE 
      INA           NO,BUMP ADDR.TO NEXT LOC
      LDB 0,I 
      STB DIM12 
      LDA CSAVE,I 
      ALF,ALF 
      AND O77 
      STA PARAM     PARAM NO. 
      LDA CSAVE,I 
      AND O20 
      STA T         T-FIELD VALUE (0 OR 20B)
      LDA CSAVE,I 
      AND O10 
      STA CFLAG     C-FIELD VALUE (0 OR 10B)
      LDA CSAVE,I 
      ALF,ALF 
      RAL,RAL 
      AND O3
      STA F         F-FIELD VALUE (0-2) 
      LDA CSAVE+1   A= ADDR.OF ENTRY +1 
      LDB SSAVE+1   NO.OF WORDS+1 IN NAME 
      JMP SCATR,I   EXIT
* 
WPFAD NOP 
      LDA 1 
      AND MO100     SAVE UPPER 10 BITS
      ALF,ALF 
      RAL,RAL       SHIFT L 10
      JMP WPFAD,I   EXIT
* 
V     BSS 1         V-FIELD VALUE:0 THRU 3
PARAM BSS 1         FORM.PARAM NUMBER:1 THRU 63, OR 0 
F     BSS 1         F-FIELD VALUE:0 THRU 2
T     BSS 1         TYPE:0=INTEGER,20B= REAL
CFLAG BSS 1         COMMON-BIT: 1=COMMON, 0=PROG
ORD   BSS 1         REL.PROG.ADDR.OF FWA OF ARRAY 
DIM1  BSS 1         VALUE OF 1ST DIMENSION
DIM12 BSS 1         DIM1 * DIM2 
CSAVE BSS 2 
CNBUF BSS 1 
SSAVE BSS 2 
GENC. DEF GENCO 
      SKP 
* 
*JUMP TABLE FOLLOWS ****
W2TAB DEF *,I 
      DEF W2LDA     1 LDA 
      DEF W2LAC     2 LAC 
      DEF W2ADA     3 ADA 
      DEF W2MIN     4 SUB 
      DEF W2CMA     5 CMA,INA 
      DEF W2STA     6 STA 
      DEF W2JSE     7 EXT,JSB 
      DEF W2DEF     10 DEF
      DEF W2JMP     11 JMP LOC. 
      DEF W2OCT     12 OCT
      DEF W2MPY     13 MPY
      DEF W2DIV     14 DIV
      DEF W2JMP     JMP 
      DEF W2SZA     16 SZA
      DEF W2ENT     17 PROGRAM ENTRY
      DEF W2SSA     20 SSA
      DEF W2INA     21 INA
      DEF W2CLA     22 CAL
      DEF *,I       23
      DEF WPUT2     24 END,GO ON TO SYMBOL TABLE
      DEF *,I       25
      DEF *,I       26
      DEF W2JSI     27 JSB LOC. (ASF) 
      DEF W2ALS     30 ALS
      DEF W2FOR     31 FORMAT 
      DEF W2BSS     32 BSS
      DEF *,I       33
      DEF *,I       34
      DEF W2LDB     35 LDB
      DEF W2DLD     36 DOUBLE LOAD:DLD
      DEF W2DLC     37 DOUBLE LOAD COMP:DLC 
      DEF W2FAD     40 FAD OR: *** SYMBOL TABLE *** 
      DEF W2FSB     41 FSB
      DEF W2FCM     42 FCM (FLOATING COMP.) 
      DEF W2DST     43 DST: DOUBLE STORE
      DEF W2RPI     44 R**I 
      DEF W2RPR     45 R**R 
      DEF W2IPI     46 I**I 
      DEF *,I       47
      DEF W2FMP     50 FMP
      DEF W2FDV     51 FDV
      DEF W2RSI     52 REAL TO INT. STORE 
      DEF W2ISR     53 INT.TO REAL STORE
      SKP 
* 
W2REL NOP 
      JSB READB,I   READ 2ND WORD OF OPND.
      ADA M1        COMPENSATE ORDINAL STARTS AT 1
      STA RELAD     OPERAND VALUE 
      CLA,INA 
      STA RELC      PROG.BASE 
      LDA PCODE 
      ALF,ALF 
      AND O77 
      ADA *+2 
      JMP 0,I 
      DEF *+1,I 
* 
      DEF W2ABS     ABSOLUTE
      DEF W2PAD     PROG. ADDR. 
      DEF W2LAB     LABEL REF 
      DEF W2LVR     LOCAL VAR REF 
      DEF W2ICS     INT.CONST 
      DEF W2COM     COMMON REF
      DEF W2PER     PROG.ERAS 
      DEF W2AER     ASF ERAS
      DEF W2RCS     REAL CONST
      DEF W2PAR     PARAM.REF 
* 
W2LAB LDA LABAS     LABEL BASE
W2RLC ADA RELAD     ADD REL.ADDRESS 
      JSB FIXAD     CORRECT ADDR FOR INDIR.REFS 
      STA RELAD     SET REL.ADDR. 
      JMP W2REL,I   EXIT
* 
W2LVR LDA LVBAS     LOC.VAR.BASE
      JMP W2RLC 
* 
W2ABS ISZ RELAD     BUMP TO ORIGINAL VALUE
      NOP 
      CLA 
      STA RELC      ABSOL.RELOCATION
      JMP W2REL,I   EXIT
* 
WUP8  OCT 37400 
PCODE BSS 1         PUTAWAY 1ST WORD
POPCD BSS 1         PUTAWAY OPCODE
WCOUN BSS 1         COUNTER 
VAROP BSS 1         DEF OR STA OPCODE 
MICOP OCT 3004      CMA,INA 
      OCT 2002      SZA 
      OCT 2020      SSA 
      OCT 2004      INA 
      OCT 2400      CLA 
      OCT 1200      ALS 
      BSS 1         AVAILABLE 
      SKP 
* 
* *************************************************** 
* 
*       BASIC EXTERNAL FUNCTIONS/NAMES TABLE
* 
FXTBL DEF *+1       STOP 00B
      ASC 3,.STOP 
      DEF *+1       RTOI 04B
      ASC 3,.RTOI 
      DEF *+1       RTOR 10B
      ASC 3,.RTOR 
      DEF *+1       ITOI 14B
      ASC 3,.ITOI 
      DEF *+1       DLC  20B
      ASC 3,..DLC 
      DEF *+1       FCM  24B
      ASC 3,..FCM 
      DEF *+1       IFIX 30B
      ASC 3,IFIX
      DEF *+1       FLOAT34B
      ASC 3,FLOAT 
* 
      DEF *+1       FMP  40B
      ASC 3,.FMP
      DEF *+1       FDV  44B
      ASC 3,.FDV
      DEF *+1       FAD  50B
      ASC 3,.FAD
      DEF *+1       FSB  54B
      ASC 3,.FSB
* 
EAOPS OCT 100200    EAU-CODE FOR MPY
      OCT 100400                 DIV
      OCT 104200                 DLD
      OCT 104400                 DST
      SKP 
* 
* *************************************************** 
* 
* 
FIXAD NOP           FIXAD ADJUST THE ADDR.IN A IF IT
      LDB RELAD     IS LT.0 AND RETURNS THE CORRECT 
*                   ADDR.FOR INDIR.REF IN A 
      SSB,RSS       INDIRECT REF ?
      JMP FIXAD,I   NO,RETURN 
      CMB,INB       ABSOL VALUE 
      RBL           *2
      ADA M2        -2 TO COUNTERACT PREV -1
      ADA 1         ADD IN PREVSLY.COMPUTED ADDR
      CMA,INA,SZA,RSS   COMPLMNT FOR IND.REF. 
      LDA IBIT      FOR 0,I REF.
      JMP FIXAD,I 
      SKP 
* 
*GENERATES DEF-S FOR FWA OF ARRAYS **** 
* 
GNDEF NOP 
      JSB READB,I   READ BSS
      JSB READB,I   READ:-NO.OF DEF-S 
      SZA,RSS       0 ? 
      JMP GNDEF,I   YES,EXIT
      STA WCOUN     NO,SET COUNT
      LDA O10       10B FOR DEF.
      STA CODE      SET OPCODE
GLOOP LDA O100      100B=ORD. 1 IN DVLIST 
      STA ORDSV 
      CLB,INB 
      STB RELC      SET PROG.RELOC. 
      JSB SCATR     SCATTER  DVLIST ENTRY 
      LDB V         V-FIELD VALUE 
      ADB M2
      SSB           ARRAY ? 
      JMP GNDF1     NO
      LDB PARAM     YES 
      LDA 0,I       FWA OF ARRAY FOR NON-PARAMS 
      SZB           PARAMETER ? 
      JMP GNDF1     YES 
      ADA M1
      STA RELAD     SET ADDR.FOR CREP 
      LDA CFLAG 
      SZA,RSS       COMMON ?
      JMP *+3       NO
      ISZ RELC
      ISZ RELC      SET TO COMMON BASE = 3
      JSB .EXTS+2,I    GENERATE DEF 
      ISZ WCOUN     READY ? 
      RSS           NO,CONTINUE 
      JMP GNDEF,I   YES,EXIT
GNDF1 LDA ORDSV 
      ADA O100      BUMP ORDINAL BY 1 
      JMP GLOOP+1   NEXT ARRAY
* 
ORDSV BSS 1 
      SKP 
* 
*CEQS SEARCHES CONLIST FOR A CONSTANT IN A. BCLIS=
*FWA OF CONLIST, TCLIS= TOP OF CONLIS+1.ENTER WITH
*A= VALUE,B= ADDR.IN CONLIST
* 
CEQS  NOP 
      CPB TCLIS     TOP OF CONLIS+1 ? 
      JMP CEQS1     YES,NOT FOUND 
      CPA 1,I       EQUALITY ?
      JMP CEQS,I    YES,NORMAL EXIT 
      INB           NO
      JMP CEQS+1    CONTINUE SEARCH 
CEQS1 ISZ CEQS      BUMP FOR
      JMP CEQS,I    ALTERNATE RETURN
* 
ICEQS NOP 
      LDB BCLIS     BOTTOM OF CONLIST 
      JSB CEQS      SEARCH FOR CONST
      JMP *+3       FOUND 
      STA 1,I       NOT FOUND,ENTER CONSTANT
      ISZ TCLIS     BUMP TCLIS
      LDA BCLIS 
      CMA,INA 
      ADA 1         REL.ADDR.IN CONLIST 
      JMP ICEQS,I   EXIT
      SKP 
* 
*REAL CONSTANT SEARCH ROUTINE  **** 
* 
RCEQS NOP 
      STA CSAVE 
      STB CSAVE+1 
      LDB BCLIS 
RCEQ2 JSB CEQS      SEARCH FOR UPPER PART 
      JMP RCEQ1     FOUND,TEST LOWER PART 
RCEQ3 STA 1,I       NOT FOUND,ENTER UPPER PART
      ISZ TCLIS 
      LDA CSAVE+1 
      STA TCLIS,I   ENTER LOWER PART
      ISZ TCLIS     BUMP TCLIS
RCEQ4 LDA BCLIS 
      CMA,INA 
      ADA 1         REL.ADDR.IN CONLIST 
      JMP RCEQS,I 
* 
RCEQ1 INB 
      CPB TCLIS     END OF CONLIST ?
      JMP RCEQ3     YES,ENTER CONST 
      LDA CSAVE+1   NO,COMPARE LOWER PART 
      CPA 1,I 
      JMP *+3       EQUALITY
      LDA CSAVE     NO EQUALITY,CONTINUE SEARCH 
      JMP RCEQ2 
      ADB M1        -1, RESET AT ADDR OF UPPER PART 
      JMP RCEQ4     FINISH UP 
      SKP 
* 
*            **************************** 
*             * CREP DATA AND TABLE AREA *
*             ****************************
* 
HLN   EQU 64   SET EXT TABLE LENGTH(193)
A     EQU 0    A REGISTER 
B     EQU 1    B REGISTER 
* 
MO100 OCT -100
WM10K DEC -10000
WM1K  DEC -1000 
WM100 DEC -100
WM10D DEC -10 
W6060 OCT 30060     CONVERSION FACTOR TO ASCII
* 
MD14  DEC -14 
O210  OCT 210       FWA MASK
MD54  DEC -54 
O77   OCT 77        SET LOW MASK FOR XTORD
O100  OCT 100 
O377  OCT 377 
.UMSK OCT 177400    WORD MASK (UPPER HALF)
O200  OCT 200       FOR EXT TEST
CMTSZ BSS 1         SIZE OF COMMENTS IN NAM 
IBIT  OCT 100000    INDIRECT BIT
      SKP 
* 
*               READB INPUT ROUTINE IN PASS 2 
*               ***************************** 
* 
READL NOP 
      LDB PNT02     INITIALIZE FMP ERROR
      STB NAME       FILE NAME POINTER
      LDA RFLAG 
      SZA           IS THIS THE FIRST TIME
      JMP MRDB2     NO ,JUMP
RENXT EQU * 
      LDA MDM40     YES, A = WORD COUNT OF 40 
      JMP PTAPE      NO 
TP.RD LDA MBUF
      AND O77 
* 
      CPA O3
      RSS 
      JMP MRDB1 
      JSB MCKSM 
      CLA,INA 
      STA RTEMP 
* 
      JSB READF     READ A
      DEF *+6        RECORD FROM
      DEF IDCB3       INTERMEDIATE
      DEF ERRS         CODE IN
      DEF MBUF          SCRATCH FILE
      DEF RTEMP 
      DEF LENS
      SSA           ERROR OCCUR?
      JMP FMPER     YES.REPORT IT 
      LDA LENS      NO.GET
      CPA M1         AN EOF?
      JMP FMPER     YES.EOS.ERROR HERE
      JMP RENXT 
* 
MRDB1 CPA O1        IS THIS TYPE 1, PUTAWAY 
      JMP CONT.     YES, CONTINUE 
                                                                                                                                                  