ASMB,Q,C HED ** ** 16K FTN4 COMPILER (F4.1:EXPRESSION EVALUATOR) ** NAM F4.1,5 92060-16095 REV.2001 791101 * *************************************** * FORTRAN-4 COMPILER OVERLAY 1 *************************************** * * THIS OVERLAY IS THE EXPRESSION EVALUATOR. * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: F4.1, PART OF FTN4 COMPILER. * * SOURCE: 92060-18095 * * RELOC: 92060-16095 * * PGMR: BILL GIBBONS. * *************************************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..DP BASE OF SYMBOL TABLE EXT F..E DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ACC TEMP ACCUMULATOR FLAG EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.C OFFSET FOR CURRENT MR INSTRUCTION EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD EXT F.D DO TABLE POINTER EXT F.DID ADDRESS OF F.IDI EXT F.DLF DELIMETER FLAG EXT F.DNI ADDRESS OF NID EXT F.DP BASE OF USER SYMBOL TABLE EXT F.DTY IMPLICIT TYPE TABLE EXT F.EMA F.A OF EMA EXT ENTRY, WINDOW SIZE EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.INT TEMP VARIABLE ARRAY EXT F.IOF INDICATOR FOR I/O INDEX EVALUATOR EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.NC NAME CHANGE FLAG. EXT F.ND NUMBER OF DIMENSIONS EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.R JSB ERR0 FLAG EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEE RETURN FROM F4.1 EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SRL SAVE RPL AT BEGINNING OF RECORD EXT F.SVL SAVE # WORDS ON OPER STACK (F.L) EXT F.SXF COMPLEX CONSTANT FLAG EXT F.T # WORDS ON STACK 1 EXT F.TAC ? EXT F.TC NEXT CHARACTER EXT F.X1 F.A OF F.D1 EXT F.X2 F.A OF F.D2 * * EXT'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 CRP.F CROSS REF PAIR SUB. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DIM.F DEFIND (F.IM) EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT ESD.F ESTABLISH DEF SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT FID.F FETCH (ID) TO NID (UNPACK) EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT II.F INPUT ITEM EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT NTI.F MOVE NID TO F.IDI (PACKS) EXT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT OLR.F OUTPUT LOAD ADDRESS EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT OW.F OUTPUT WORD EXT OZ.F OUTPUT ZREL (OP *+N) EXT PSL.F PRINT LINE ON PRINTER EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * * SEGMENT ENTRY POINTS * ENT EA?.F TEST IF VAR. IS IN EMA * * * ENTRY POINTS FOR ROUTINES IN THIS SEGMENT * * ENT EE.F EXPRESSION ANALIZER (THE WHOLE REASON FOR EXISTANCE) ENT GIM.F GET IM OF ITEM ENT GST.F STORE REGISTER IN TEMP. ENT PU2.F PUSH ONTO OPERATOR STACK ENT MAP.F IF F.A POINTS TO EMA GEN. .EMAP CALL FOR IT ENT FER.F FORM PROGRAM ENTRANCE SPC 1 * * * * * * * OTHER LIB. UTILITIES * EXT .MVW MOVE WORDS MACRO * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 .TBL EQU 0 FEDP EQU 0 DEC 1 OVERLAY NUMBER SKP * **************************** * FORM PROGRAM ENTRANCE CODE * * **************************** * * FER.F DEF DBSZ CALLED JUST BEFOR THE FIRST EXECUTABLE STMT. ISZ BENHR SKIP IF NOT BEEN HERE BEFORE JMP FER.F,I ALREADY DONE ONCE JUST EXIT * LDA L.INT INITIALIZE TEMP CELL BASE NAMES. RAL,CLE,SLA,ERA (INDIRECT ? CLEAR IT) LDA A,I (YES. REMOVE IT) LDB LT.IN JSB .MVW DEF K7 NOP LDA F.SFF IF BLOCK DATA CPA K2 SUBPROGRAM JMP FER.F,I THERE IS NO ENTRY * JSB OLR.F PUT OUT LOAD ADDRESS LDA F.RPL SAVE THE ADDRESS OF STA F.SRL THE FIRST PRAM (FOR .ENTR) LDB F.SBF GET SUB ROUTINE F.A STB F.A AND SET IT SZB,RSS MAIN IF NONE JMP FER06 MAIN SKIP ENTRY CODE * JSB FA.F FETCH ASSIGNS FOR THIS GUY JSB CTYP CHECK IF IMPLICIT STMT CHANGED TYPE LDA F.SFF GET PROGRAM TYPE FLAG SZA,RSS IS IT A FUNCTION? JMP FER00 NO DO NOT MAKE SUB A DUM * LDB F.IM GET MODE OF FUNCTION CPB CPX IF COMPLEX RSS OR CPB DBL DOUBLE THEN JMP FER02 GO MAKE DUM AND PUT OUT NOP FOR IT * FER00 LDA F.AF GET THE LINK TO THE FIRST DUMMY FER01 STA F.A SET LINK TO NEXT DUMMY CPA F.SBF IF END OF LIST JMP FER03 GO PRODUCE THE .ENTR CALL * STA T1FER SAVE F.A OF DUMMY. JSB FA.F FETCH ASSIGNS JSB CTYP CHECK IF IMPLICIT STMT CHANGED TYPE FER02 LDB F.AF SAVE LINK TO NEXT ONE LDA B,I IF NEXT IS BCOMI, AND B7000 CPA BCOMI INB,RSS JMP FER11 NO. LDA B,I YES. SAVE LINK. STA NXT STB T2FER SAVE ADDR 2ND WD BCOMI ENTRY. LDA F.RPL SAVE F.RPL OF NOP IN WORD 5. ADB K3 STA B,I JSB DRT.F CREATE STACK ENTRY FOR NON-ARRAY. LDA T1FER,I GET F.IU OF DUMMY. AND B600 CPA ARR ARRAY ? RSS JMP FER10 NO. ISZ T2FER YES. ANOTHER TEMP FOR ARRAY USE. ISZ T2FER JSB DRT.F LDA F.ND # DIM (SHOULD BE INTACT) CMA,INA STA T2FER COUNTER FOR LOOP. LDB T1FER F.A OF DUMMY INB LDB B,I OF ITS DIM ENTRY. ADB K3 OF FIRST DIM SIZE ENTRY. STB T3FER FER08 LDA T3FER,I ADDR SIZE ENTRY THIS DIM LDB A,I CHECK F.NT SSB NAMED ? JMP FER09 NO, CONSTANT, LEAVE IT. JSB PU2.F TEMP. IS DUPLICATE, STACK IT. LDA T3FER JSB PU2.F AND ADDR DIM SIZE ENTRY. FER09 ISZ T3FER LOOP THRU ENTRIES. ISZ T2FER JMP FER08 * FER10 LDA T1FER RESTORE F.A OF DUMMY STA F.A LDA BCOM TYPE IT "BCOM" JMP FER12 * FER11 STB NXT SAVE LINK LDA F.RPL DEFINE LOC OF NORMAL DUMMY JSB DAF.F LDA DUM TYPE IT "DUM" FER12 JSB DAT.F * CLA AND OUTPUT A JSB OAI.F NOP PLACE HOLDER LDA NXT GET NEXT F.A JMP FER01 AND GO DO IT * FER03 LDA F.RPL SAVE LOCATION OF ENTRY STA F.REL FOR RETURN CODE AND PASS TWO CLA PRODUCE JSB OAI.F A NOP PLACE HOLDER LDB .ENTR OUT PUT A JSB .ENTR JSB ODF.F LDB F.SRL DEF TO THE FIRST JSB OMR.F PRAM SKP * AT THIS POINT WE SCAN STACK 2 AND PRODUCE ENTRY CODE. * THE ENTRIES ON THE STACK HAVE THE FOLLOWING FORMATS: * * 1) WORD1: F.A OF DUMMY USED AS VARIABLE DIM SIZE. * WORD2: F.A OF TEMP TO COPY VALUE INTO. * * 2) WORD1: F.A OF TEMP PREV USED IN TYPE 1 ENTRY. * WORD2: ADDR TO STORE F.A OF NEW TEMP WHICH * HAS SAME VALUE AS EARLIER TEMP. * * 3) WORD1: COMPL OF REL ADDR OF A SUBR PARAM ADDR. * WORD2: F.A OF TEMP TO COPY (2-WD) VALUE INTO. * * THE LIST IS TERMINATED BY A ZERO WORD. ENTRIES ARE * DELETED BY SETTING BOTH WORDS TO +1. * CLA PUT END MARKER ON STACK 2. STA T2FER (RELATIVE POSITION IN STACK) JSB PU2.F FER04 JSB S2NXT GET NEXT ELEMENT. FER17 SZB,RSS END ? JMP FER05 YES. CPB K1 DELETED ? JMP FER04 YES. SSB EMA DUMMY ENTRY ? JMP FER15 YES. STB F.A IN EMA ? JSB EA?.F JMP FER19 NO. LDA K48 YES. ERROR 48. JSB ER.F * FER19 LDA LDAI OUTPUT A JSB OA.F LDA DUM,I LDA F.IM IF DUM IS CPA INT INTEGER JMP FER07 THEN SKIP ERROR REPORT * LDA F.CC ELSE REPORT STA TYPEX ERROR DUM USED AS LDA K5 DIMENSION CCB AND STB F.CC IT IS NOT JSB WAR.F INTEGER JSB FID.F JSB NTI.F MOVE SYMBOL TO F.IDI AND PAD LDA K3 NOW LDB F.DID SEND IT JSB PSL.F TO THE PRINTER LDA INT MAKE IT INTEGER JSB DIM.F NOW LDA TYPEX RESTOR STA F.CC CHAR COUNT (SET ZERO TO FLAG PRIOR LINE) FER07 LDA STAI AND A STA JSB S2NXT IN THE TEMP. JSB SOA.F (F.A = B) LDA T2FER SET UP TO SCAN REST OF STACK FOR DUPLICATES. STA T3FER (REMEMBER WHERE WE WERE) FER13 JSB S2NXT NEXT ITEM. SZB,RSS DONE ? JMP FER18 YES. LDA F.S2B GET ORIGINAL TEMP. ADA T3FER CPB A,I SAME AS ONE NOW WORKING ON ? CLE,RSS YES. (E=0) JMP FER13 NO, GO ON TO NEXT. CPB F.A FIRST ONE ? JMP FER14 YES, USE ORIGINAL. (E=0) LDA INT NO, ALLOCATE NEW ONE. JSB ATC.F CCA PERMANENTLY. ADA F.INT (E=1) STA F.INT FER14 LDA F.S2B T1FER = ADDR CURRENT WORD. ADA T2FER STA T1FER CLA,INA DELETE FIRST WORD OF ENTRY. STA T1FER,I ISZ T1FER GET SECOND WORD. LDA T1FER,I STB A,I USE IT TO PLACE ADDR TEMP IN DIM TABLE. CLA,INA DELETE SECOND WORD. STA T1FER,I LDA STAI GEN "STA" INTO TEMP SEZ IF FIRST ONE, HAS ALREADY BEEN DONE. JSB SOA.F CLA DON'T REUSE TEMP FROM DIM PROCESSING. STA F.A JMP FER13 LOOK FOR MORE. FER18 LDA T3FER RESTORE POSITION. STA T2FER JMP FER04 * FER15 STB T1FER SAVE FIRST WORD. LDB .DLD GEN "DLD" JSB ODF.F LDB T1FER CMB LDA KK01 JSB OMR.F FER16 LDB .DST GEN "DST TEMP" JSB ODF.F JSB S2NXT JSB DEF.F JSB S2NXT LOOK AT NEXT ENTRY. CPB T1FER SAME AS THIS ONE ? JMP FER16 YES, ISSUE ANOTHER "DST" JMP FER17 NO, LOOP. (B = NEXT WORD) * S2NXT NOP GET NEXT ELEMENT ON STACK 2. ISZ T2FER BUMP RELATIVE POINTER. LDB F.S2B BASE ADB T2FER PLUS OFFSET LDB B,I ELEMENT JMP S2NXT,I * FER05 LDA F.LO CUT BACK STA F.S2B THE STACK STA F.S2T CLA STA F.L JMP FER.F,I RETURN SKP FER06 LDA F.RPL SAVE THE ENTRY LOCATION STA F.REL FOR END PROCESSOR CLA PRODUCE MAIN PROGRAM JSB OAI.F ENTRY CODE LDA JSBI JSB CLRIO LDB CLRIO ADB F..DP JSB SOA.F AND CLA CLB,INB DEF *+1 JSB OZ.F JMP FER.F,I RETURN * CLRIO DEF FEDP+252B F.A OFFSET OF CLRIO .ENTR DEF .TBL+27 .TBL OFFSET OF .ENTR NXT NOP TEMPS T1FER NOP T2FER NOP T3FER NOP KK01 OCT 100000 B7000 OCT 7000 BCOMI EQU B7000 K5 DEC 5 K48 DEC 48 BENHR OCT -1 BEEN HERE FLAG * CTYP NOP CHECK IF TYPE NOT EXPLICIT THEN SET IMPLICIT LDA F..E GET EXPLICIT TYPE FLAG SZA IF SET JMP CTYP,I RETURN * LDA F.A GET THE FIRST ADA K2 CHAR OF THE NAME LDA A,I TO A ALF,ALF ROTATE AND AND B377 ISOLATE ADA BM101 SUBTRACT 'A' CLE,ERA CONVERT TO CHAR ADDRESS ADA F.DTY ADD THE ADDRESS OF THE TYPE TABLE LDA A,I GET THE TYPE FROM THE TABLE SEZ USE RIGHT END ALF,ALF AND ADDR ISOLATE THE MODE JSB DIM.F DEFINE NEW IM JMP CTYP,I RETURN * BM101 OCT -101 SPC 2 DRT.F NOP CREATE STACK ENTRIES FOR EMA F.P. LDA F.RPL PUSH COMP. OF LOAD ADDR CMA JSB PU2.F LDA REA GET REAL TEMP JSB ATC.F CMB COMP: FLAG IS REALLY DUMMY STB T2FER,I PUT IN BCOMI ENTRY CCB MAKE TEMP PERMANENT. ADB F.INT+1 STB F.INT+1 JSB PU2.F PUT TEMP ADDR ON STACK. JMP DRT.F,I EXIT. SKP TABT DEF .IAND TABNO ABS .IAND-.END SPC 2 * *------------------* * * START HERE * * *------------------* * F4.1 LDA TABT,I ADD FIXED EXTERNAL TABLE BASE ADA F..DP ADDRESS TO DISPLACEMENTS IN STA TABT,I TABLE ABOVE AND REINSERT IN TABL ISZ TABT ISZ TABNO JMP F4.1 * LDA F.CCW GET THE Y- BIT AND B1000 AND LDB K3 SZA IF SET INB STB FER.F,I SET DOUBLE WORD SIZE TO 4 LDA .CFER IF SET CPB K4 FOR 4-WORD DOUBLE STA .DFER USE CFER FOR DOUBLE MOVES JMP F.SEE RETURN TO MAIN PROGRAM SPC 1 EQFLG NOP EQUALS FLAG L.INT DEF F.INT+0 LT.IN DEF T.INT B1000 OCT 1000 REL EQU B1000 SPC 2 * ************************ * * EXPRESSION EVALUATOR * * ************************ SPC 1 * PARAM IS TYPE OF INPUT EXPRESSION: SPC 1 * = 0, STATEMENT FUNCTION. * =-1, SUBROUTINE CALL STATEMENT. * =-2, DO INITIAL PARAMETER. * =-3, ARRAY ELEMENT IN I/O LIST. * =-4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. * =-5, COMPUTED GO TO INDEX EXPRESSION. * =-6, ASSIGNMENT STATEMENT. * =-7, IF EXPRESSION. SPC 1 * FLOW CHART OF THE EXPRESSION ANALIZER * * PRIOR,LASTC_-1,OPCOD_-1,T4_0 * ! * (-7)'IF' EXPRESSION? * 1! 0! * !<<<<<<<<<<<<<<<<<<<<<<< ------------ *(CPX FLG)SXF_#0 ! * PU2.F(21) STACK '(' C31P1 (0 )STMT. FUN. * II.F (-4)DO TERM. OR * F.IM=CPX (-5)GO TO INDX.? * & F.NT #0? 1! 0! * 1! 0! ! <<<<<<<<<<<<<<<< ! *PO2.F '(' ! ^------------O (-1)SUB.& *! ! ^ EXN.F F.TC#'(' *! ! ^ ! 0! 1! *! !<<<<<< ^ T4=0? ! OA.F (JSB) *! LASTC=')' ^ 1! 0! F.A_T5 ! OZ.F (DEF *+1) *! 0! 1! ^ F.TC='+' F.TC_T4,F.IM_T6 ! ! *! LASTC_'(' ER.F ^ OR '-' F.IM=0? ! RETURN *! F.IM=0? (53) ^ 1! 0! 0! 1! ! *! 0! 1! ^ LASTC= II.F FA.F ! ! *O<<<< ! ^ '=','(', ! ! ! ! *! F.TC='+'? ^ OR <0? ! O<<< F.CC ! *----------------------)!(------------------------------O * ! ! * ! F.IM=0? * ! 1! 0! * ! ! EMAFL_CLEAR * ! ! EQFLG<0?(LEFT OF '=') * ! ! 0! 1! * ! ! ! F.L=F.SVL& EMA? * ! ! ! 0! 1! * ! ! O<<<< PU1.F(-1) * ! ! ! PU2.F(INASS) * ! ! ! EMAFL_SET * ! ! O<<<<<<<<< F.TC_' ' F.TC='('? LASTC=')'& * ! 1! 0! F.TC='N0'? * ! ! 0! 1! * ! (TOP LEFT)! ! ER.F(53) * ! ! F.TC='('? * ! ! 0! 1! * ! !<<<<<< F.IU=0? F.IU=ARR * ! ! 0! 1! OR SUB? * ! ! ! ER.F 1! 0! * ! ! ! (49) PU1.F ER.F * ! ! EMAFL? (F.A,I) (49) * ! ! 1! 0! PU2.F '[' * ! ! ! MAP.F (C33P1ORC32P1) * ! ! ! ! '<'OR '[' * ! ! !<<<<<< ARR SUB * ! ! ! (P=0 IF (SIGN * ! ! PU1.F(F.A) EMA<'=') IF * ! ! ! INT * ! O<<<< ! FUN * ! ! * ! F.IM=0? ! * ! 1! 0! * ! F.TC='NO'? ! TOP CENTER * ! 1! 0! ! * ! LASTC='N0'? LASTC=')'?! * ! 0! 1! 0! 1!! * O<<<<<<< ER.F(53) -O * ! ! * ! F.TC=')'OR ','? * ! 0! 1! * ! F.TC='C/R'? CRPIO_3 * ! 0! 1! ! * ! F.TC='*'? CPRIO_0 ! * ! 1! 0!! ! * ! EXN.F F.TC='-'? ------O * ! F.TC='*'? 0! 1! ! * ! 0! 1! ! EXN.F CCODE_0 * ! F.TC_'*' ! ! F.TC=DELIM.? ! * ! ! F.TC_'**'! 1! 0! !------ * ! ! F.CC_F.CC+1! ! ! ! * ! ! ! ! ! T6_F.A ! * O<<<<<<< LOOK UP OPCODE ^ F.NT=0? ! * IN TABLE ^ 1! ! ! * =,+,-, ,*,/,**, ^<<<<<<<<F.TC='='? ! * 0! 1! ! * ! EQFLG_EQFLG+1 ! * ! EQFLG=0? ! * ! 0! 1! ! * O<<<<<< ER.!(53) ! * ! ! * GET CPRIO FROM TABLE ! * CCODE FROM TABLE ! * CPRIO>PRIOR? ! * 1! 0! ! * PU2.F ! ! * (OP) ! ! * LASTC_F.TC ! ! * ! ! * TOP CENTER ! !