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