C;+ C----------------------------------------------------------------------- C 27-JUN-85 (MAO) This version of the MAIN routine for FLECS generates C FORTRAN II code only. IE. it generates GOTOs rather C than IF-THEN-ELSEs. A new version of this routine C exists and generates F77 code. C C SAVE THIS FILE FOR FUTURE REFERENCE!!!!!!!!!!!!!!!!!!!!!!!!!!!! C C----------------------------------------------------------------------- C - . . . F L E C****NAME: PROGRAM FLECS (...FLE) C IDENT: /840814/ C FILE: [201,13]M.FLX C C****PURPOSE: FLECS FORTRAN PREPROCESSOR C C****RESTRICTIONS: C C SYSTEM: RSX11M V4.0 C LANGUAGE: FLECS/FORTRAN C AUTHOR: TERRY BEYER C DATE: 20-NOV-74 C REVISIONS: C 11-SEP-75 (MK) COMMENT OUT PROCEDURE "GENERATE-PROCEDURE-DISPATCH- C AREA" & ITS CALL IN "COMPILE-END" TO SHORTEN FLECS. C SEE NOTE 1. CHANGE MARGINS. SEE NOTE 2. C 25-JAN-80 (MAO) DEFINE "!" AS IN-LINE COMMENT CHAR; PUT IN /PARAM/. C 26-JAN-80 (MAO) ADDED COMMENTS C 20-FEB-80 (MAO) ADD CODE FOR ALECS; NOTE ALL ALECS LINES ARE DELIMITED BY C C C C ALECS VVVVV C ALECS CODE C C ALECS ^^^^^ C C C IF YOU DO NOT WANT ALECS, SIMPLY COMMENT OUT THE DELIMITED LINES. C C 30-APR-80 (MAO) REPLACE "CALL EXIT" BY "CALL EXFLE" C CONVERT FROM 11D TO 11M C 22-JUN-81 (MAO) ENABLE FLECS DIRECTIVES C 22-JUN-81 (MAO) ADD .PAGE DIRECTIVE C 26-JUN-81 (MAO) FOR # IN COL 1, REPLACE BY BLANK FOR FTN FILE C 29-JUN-81 (MAO) ADD .INCLUDE DIRECTIVE C 30-JUN-81 (MAO) ADD .PASSx AND .NAME DIRECTIVES C 07-MAR-83 (MAO) ADD CODE TO LIST FORTRAN LINE # IN FLL FILE C 08-MAR-83 (MAO) SET ERROR FLAG IF FLECS GENERATES FORT CONTINUATION LINE C 11-MAR-83 (MAO) CORRECT CALCULATION OF REFNO IN PERFORM-INIT C 07-MAR-84 (MAO) ADD CODE FOR .IMPLICIT NONE C 13-AUG-84 (MAO) USE CONDITIONALS FOR FLECS/ALECS CODE. C 14-AUG-84 (MAO) CALL IMPWRT FROM BETTER PLACE IN CODE. C C****CALLING SEQUENCE: MCR>FLE OUT/[-]FU,LIST/[-]SP=IN C C INPUT: C C IN =NAME OF FILE CONTAINING FLECS SOURCE (DEFAULT EXTENSION=.FLX). C C OUTPUT: C C LIST =NAME OF FILE TO RECEIVE FLECS LISTING, OPTIONAL. THE SWITCH C /SP OR /-SP [DEFAULT] MAY ALSO BE GIVEN FOR SPOOLING/NO C SPOOLING OF OUTPUT (DEFAULT EXTENSION=.FLL). C OUT =NAME OF FILE TO RECEIVE FORTRAN OUTPUT, OPTIONAL. THE SWITCH C /FU OR /-FU [DEFAULT] MAY ALSO BE GIVEN. /FU PUTS ALL COMMENT C LINES AND FLECS LINES (AS COMMENTS) INTO THE OUTPUT FTN FILE C (DEFAULT EXTENSION=.FTN). C C CMN BLOCK I/O: BLANK COMMON, /PARAM/ C C RESOURCES: C LIBRARIES: NONE C OTHER SUBR: [201,13]ANALYZ,CATNUM,CATSTR,CATSUB,CLOSEF,CPYSTR,CPYSUB C EXFLE,HASH,LIST,NEWNO,OPENF,PUT,PUTNUM,STREQ, C STRLT C ALEBRI,ALEDO,ALEINV,ALERTS,ALESXP,LAMPFI, C PUTLBL,PUTLOG C DISK FILES: FILES SPECIFIED IN INPUT LINE C DEVICES: TI:1:2, DISK:3:4:5 C SGAS: NONE C EVENT FLAGS: NONE C SYSTEM DIR: NONE C C****NOTES: C 1. IN ORDER TO SHORTEN THE TRANSLATOR, THE PROCEDURE "GENERATE- C PROCEDURE-DISPATCH-AREA" AND ITS CALL IN "COMPILE-END" HAVE BEEN C COMMENTED OUT. THEY MUST BE RE-INSTATED IF IT IS DESIRED TO C GENERATE A TRANSLATOR THAT WILL GENERATE LONG OR COMPUTED PRO- C CEDURE LINKAGES (LONG=.TRUE. OR COGOTO=.TRUE.). C C 2. THE NUMBER OF COLUMNS ALLOWED IN THE LISTING FOR MARGIN AND LINE C NUMBER HAS BEEN INCREASED FROM 6 TO 10. THIS AFFECTS THE COM- C PUTATION OF "WWIDTH" AND "REFNO" IN "PERFORM-INITIALIZATION". C;- PROGRAM FLECS .PASSUNLESS ALECS .PASSUNLESS FLECS ERROR--YOU MUST SPECIFY EITHER /CO:ALECS OR /CO:FLECS .PASSEND .PASSEND C C MAIN PROGRAM FOR FLECS TRANSLATOR C USES SUBROUTINE ANALYZ AND LIST C C C--------------------------------------- C C FLECS TRANSLATOR (PRELIMINARY VERSION 22) C (FOR A MORE PRECISE VERSION NUMBER, SEE THE STRING SVER) C C AUTHOR -- TERRY BEYER C C ADDRESS -- COMPUTING CENTER C UNIVERSITY OF OREGON C EUGENE, OREGON 97405 C C TELEPHONE -- (503) 686-4416 C C DATE -- NOVEMBER 20, 1974 C C--------------------------------------- C C DISCLAIMER C C NEITHER THE AUTHOR NOR THE UNIVERSITY OF OREGON SHALL BE C LIBAL FOR ANY DIRECT OR INDIRECT, INCIDENTAL, CONSEQUENTIAL, C OR SPECIFIC DAMAGES OF ANY KIND OR FROM ANY CAUSE WHATSOEVER C ARISING OUT OF OR IN ANY WAY CONNECTED WITH THE USE OR C PERFORMANCE OF THIS PROGRAM. C C--------------------------------------- C C PERMISSION C C THIS PROGRAM IS IN THE PUBLIC DOMAIN AND MAY BE ALTERED C OR REPRODUCED WITHOUT EXPLICIT PERMISSION OF THE AUTHOR. C C--------------------------------------- C C NOTE TO THE PROGRAMMER WHO WISHES TO ALTER THIS CODE C C C THE PROGRAM BELOW IS THE RESULT OF ABOUT SIX MONTHS OF C RAPID EVOLUTION IN ADDITION TO BEING THE FIRST SUCH C PROGRAM I HAVE EVER WRITTEN. YOU WILL FIND IT IS UNCOMMENTED, C AND IN MANY PLACES OBSCURE. THE LOGIC IS FREQUENTLY C BURIED UNDER A PILE OF PATCHES WHICH BARELY TOLERATE EACH C OTHER S EXISTENCE. C C I PLAN TO WRITE A CLEANER, SMALLER, AND FASTER VERSION OF C THIS PROGRAM WHEN GIVEN THE OPPORTUNITY. IT WAS NEVER C MY INTENT TO PRODUCE A PROGRAM MAINTAINABLE BY ANYONE OTHER C THAN MYSELF ON THIS FIRST PASS. NEVERTHLESS PLEASE C ACCEPT MY APOLOGIES FOR THE CONDITION OF THE CODE BELOW. C I WOULD PREFER IT IF YOU WOULD CONTACT ME AND WAIT FOR C THE NEWER VERSION BEFORE MAKING ANY BUT THE MOST NECESSARY C CHANGES TO THIS PROGRAM. YOU WILL PROBABLY SAVE YOURSELF C MUCH TIME AND GRIEF. C C--------------------------------------- C C SPECIAL NOTES FOR THE PDP-11 C C C 1. DUE TO A RESTRICTION IN THE DOS FORTRAN COMPILER, C ALL DATA STATEMENTS HAVE BEEN COMMENTED OUT IN THEIR C ORIGINAL LOCATIONS AND HAVE BEEN REPRODUCED IN A BLOCK C AT THE END OF THE OTHER DECLARATIONS. C C 2. DUE TO THE INABILITY OF THE DOS FORTRAN COMPILER TO C CORRECTLY INTERPRET THE STATEMENT CALLNO=CALLNO+1 C THE VARIABLE CALLNO HAS BEEN RENAMED TO NOCALL C C--------------------------------------- C C THE FOLLOWING IS FOR THE LAMPF VERSION OF FLECS C INTEGER NUMLIN !830307 MAO LOGICAL CNTALL !830307 MAO COMMON/FLINE/CNTALL,NUMLIN C INTEGER DTYPE !22-JUN-81 (MAO) COMMON/DIR/DTYPE !22-JUN-81 (MAO) C LOGICAL PASFLG !30JUN81MAO INTEGER CNDLVL !30JUN81MAO INTEGER OFFLVL !30JUN81MAO INTEGER COND !30JUN81MAO INTEGER CNDVAL !30JUN81MAO COMMON/COND/PASFLG,CNDLVL,OFFLVL,COND,CNDVAL(4,10) !30JUN81MAO C C INTEGER DECLARATIONS C C INTEGER POUND !26-JUN-81MAO INTEGER TDIR !22-JUN-81MAO INTEGER TOFF !30JUN81MAO INTEGER DPAGE !22-JUN-81MAO INTEGER DPIF,DPUNL,DPEND !30JUN81MAO INTEGER DNAME !30JUN81MAO INTEGER DINCL !29-JUN-81MAO INTEGER UDIR !29-JUN-81MAO INTEGER DIMP !840307MAO INTEGER ACSEQ , ACTION, AELSE , AFSEQ , AGCONT, AGGOTO INTEGER AGRET , AGSTNO, AMSEQ ,ASSEQ , ATSEQ INTEGER BLN , NOCALL, CHC , CHSPAC, CHZERO INTEGER CINLIN !25-JAN-80 INTEGER CLASS , CONTNO, DUMMY , ELSNO , ENDNO , ENTNO INTEGER ERRCL , ERROR , ERRSTK, ERSTOP, EXTYPE, FLXNO INTEGER FORTCL, GGOTON, GOTONO, GSTNO , HASH , HOLDNO INTEGER I , ITEMP , J , L , LEVEL , LINENO INTEGER LL , LP , LR , LT INTEGER LISTCL, LOOPNO, LSTLEV, LWIDTH, MAJCNT INTEGER MAX , MAXSTK, MINCNT, MLINE , NCHPWD, NEWNO INTEGER NEXTNO, NUNITS, NXIFNO, OFFSET, OFFST2, P INTEGER PARAM1, PARAM2, PARAM3, PARAM4, PDUMMY, PENT INTEGER PARAM5 !25-JAN-80 INTEGER PRIME , PTABLE, Q , QM , QP , READ INTEGER REFNO , RETNO , RETRY , S , SAFETY, SASSN1 INTEGER SASSN2, SB , SB5I1 , SB6 , SB6I , SB7 , SBGOTO INTEGER SCONT INTEGER SCOMMA, SCP , SDASH , SDOST , SDUM , SEEDNO, SEQ INTEGER SETUP , SFLX , SFORCE, SGOTO , SGOTOI, SGUP1 INTEGER SGOTOP INTEGER SGUP2 , SHOLD , SIF , SIFP , SIFPN , SLIST INTEGER SNE , SOURCE, SPB , SPGOTO, SPINV , SPUTGO INTEGER SRP , SRTN , SSPACR, SST , SSTMAX, SSTOP INTEGER SRPCI INTEGER STACK , STNO , SVER , TCEXP , TCOND , TDO INTEGER TELSE , TEND , TESTNO, TEXEC , TFIN , TFORT INTEGER TIF , TINVOK, TMAX , TOP , TOPNO , TOPTYP INTEGER TRUNTL, TRWHIL, TSELCT, TTO , TUNLES, TUNTIL INTEGER TWHEN , TWHILE, UDO , UEXP , UFORT , ULEN INTEGER UOWSE , UPINV , USTART, UTYPE , WWIDTH C C--------------------------------------- C C LOGICAL DECLARATIONS C C LOGICAL ALECS !20-FEB-80 LOGICAL IMPSET !840307MAO LOGICAL COGOTO, FAKE , LONG LOGICAL DONE , ENDFIL, ENDPGM, ERLST , FIRST , FOUND , INSERT LOGICAL NOPGM , NOTFLG, PASS , SAVED ,SHORT , STREQ , STRLT C C--------------------------------------- C C ARRAY DECLARATIONS C C C ARRAYS WHICH HOLD RESULTS OF SCANNERS ANALYSIS DIMENSION UTYPE(3), USTART(3), ULEN(3) C C STACK/TABLE AREA AND POINTER TO TOP OF STACK DIMENSION STACK(2000) C C SYNTAX ERROR STACK AND TOP POINTER DIMENSION ERRSTK(5) C C--------------------------------------- C C COMMON DECLARATIONS C (SEE ALSO PARAMETERS BELOW) C C C THE FOLLOWING VARIABLES ARE COMMON TO TWO OR MORE SUBPROGRAMS COMMON BLN , CLASS , DONE , ENDFIL, ENDPGM, ERLST COMMON ERROR , ERRSTK, ERSTOP, EXTYPE, FIRST , FLXNO COMMON FOUND , HOLDNO, LEVEL , LINENO, LSTLEV, MAJCNT COMMON MINCNT, MLINE , NOPGM , NUNITS, PASS , PTABLE, QP COMMON REFNO , SAVED , SFLX , SHOLD , SLIST , SOURCE COMMON SPINV , SPUTGO, SST , STACK , TOP , ULEN COMMON USTART, UTYPE , WWIDTH C C--------------------------------------- C C MNEMONIC DECLARATIONS C C C I/O CLASS CODES FOR USE WITH SUBROUTINE PUT C DATA FORTCL /1/, LISTCL /2/, ERRCL /3/ C C ACTION CODES FOR USE ON ACTION STACK C DATA ACSEQ/1/, AELSE/2/, AFSEQ/3/, AGCONT/4/, AGGOTO/5/ C DATA AGSTNO/6/, AMSEQ/7/, AGRET/8/, ASSEQ/9/, ATSEQ/10/ C C TYPE CODES USED BY SCANNERS C DATA UEXP/1/, UFORT/2/, UOWSE/3/, UPINV/4/, UDO/5/ C DATA UDIR/6/ !29-JUN-81MAO C C TYPE CODES ASSIGNED TO THE VARIABLE CLASS C DATA TCEXP/1/, TELSE/2/, TEND/3/, TEXEC/4/, TFIN/5/, TTO/6/ C DATA TDIR/7/ !22-JUN-81 C DATA TOFF/8/ !30JUN81MAO C C TYPE CODES ASSIGNED TO THE VARIABLE EXTYPE C DATA TCOND/1/, TDO/2/, TFORT/3/, TIF/4/, TINVOK/5/, TRUNTL/6/ C DATA TRWHIL/7/, TSELCT/8/, TUNLES/9/, TUNTIL/10/, TWHEN/11/ C DATA TWHILE/12/ C C TYPE CODES ASSIGNED TO THE VARIABLE DTYPE C DATA DPAGE/1/, DINCL/2/ !29-JUN-81MAO C DATA DPIF/3/, DPUNL/4/, DPEND/5/, DNAME/6/ !30JUN81MAO C DATA DIMP/7/ !840307MAO C C CODES INDICATING SOURCE OF NEXT STATEMENT C IN SUBROUTINE ANALYZ C DATA SETUP /1/, RETRY /2/, READ /3/ C C--------------------------------------- C C C PARAMETERS C C THE FOLLOWING VARIABLES ARE PARAMETERS FOR THE PROGRAM. C THE MEANING OF EACH IS GIVEN BRIEFLY BELOW. FOR MORE INFORMATION C ON THE EFFECT OF THESE PARAMETERS, CONSULT THE SYSTEM MODIFICATION C GUIDE. C C INTEGER VALUE OF THE CHARACTER C C DATA CHC /67/ C C INTEGER VALUE OF IN-LINE COMMENT CHARACTER "!" !25-JAN-80 C DATA CINLIN /33/ !25-JAN-80 C C LISTING WIDTH IN CHARACTERS C DATA LWIDTH /132/ C C SIZE OF THE MAIN STACK C DATA MAXSTK /2000/ C C NUMBER OF CHARACTERS PER WORD (PER INTEGER) IN A FORMAT C DATA NCHPWD /2/ C C SIZE OF HASH TABLE FOR PROCEDURE NAMES - SHOULD BE PRIME. C DATA PRIME /53/ C C SAFETY MARGIN BETWEEN TOP AND MAX AT BEGINNING OF EACH LOOP C DATA SAFETY /35/ C C SEED FOR GENERATION OF STATEMENT NUMBERS C DATA SEEDNO /32760/ C C CAUSES LONG FORM OF ASSIGNED GO TO TO BE GENERATED C DATA LONG /.FALSE./ C C CAUSES SHORT FORM OF ASSIGNED GO TO TO BE GENERATED C DATA SHORT /.TRUE./ C C CAUSES FAKE LONG FORM OF ASSIGNED GO TO TO BE GENERATED C DATA FAKE /.FALSE./ C C CAUSES COMPUTED GO TO'S TO BE GENERATED C DATA COGOTO /.FALSE./ C C INTEGER VALUE OF THE CHARACTER SPACE C DATA CHSPAC /32/ C C INTEGER VALUE OF THE CHARACTER CODE FOR ZERO C DATA CHZERO /48/ C C THE PARAMETERS NCHPWD, CHZERO, CHSPAC, AND CHC C ARE COMMUNICATED TO VARIOUS C SUBPROGRAMS VIA THE FOLLOWING COMMON (SEE PERFORM-INITIALIZATION) C COMMON /PARAM/ NCHPWD, CHZERO, CHSPAC, CHC, CINLIN !25-JAN-80 COMMON /PARAM/ PARAM1, PARAM2, PARAM3, PARAM4, PARAM5 !25-JAN-80 C C--------------------------------------- C C STRING DECLARATIONS C C C THE FOLLOWING ARRAYS ARE USED FOR STORAGE OF WORKING STRINGS C AND CORRESPOND TO STRINGS OF THE LENGTHS INDICATED. C THE SIZES GIVEN BELOW ARE EXCESSIVE AND SHOULD BE C BE REDUCED AFTER CAREFUL ANALYSIS (NO TIME NOW). C C SFLX 100 CHARACTERS DIMENSION SFLX (51) C SHOLD 100 CHARACTERS DIMENSION SHOLD (51) C SLIST 200 CHARACTERS DIMENSION SLIST (101) C SPINV 80 CHARACTERS DIMENSION SPINV (41) C SPUTGO 20 CHARACTERS DIMENSION SPUTGO (11) C SST 200 CHARACTERS DIMENSION SST (101) C DATA SSTMAX /200/ C C THE FOLLOWING STRINGS REPRESENT CONSTANTS C C SASSN1 // ASSIGN // DIMENSION SASSN1 (8) C DATA SASSN1 / 13, 2H , 2H , 2H , 2HAS, 2HSI, 2HGN, 1H / C SASSN2 // TO I// DIMENSION SASSN2 (4) C DATA SASSN2 / 5, 2H T, 2HO , 1HI/ C SB // // DIMENSION SB (2) C DATA SB / 1, 1H / C SB5I1 // 1// DIMENSION SB5I1 (4) C DATA SB5I1 / 6, 2H , 2H , 2H 1/ C SB6 // // DIMENSION SB6 (4) C DATA SB6 / 6, 2H , 2H , 2H / C SB7 // // DIMENSION SB7 (5) C DATA SB7 / 7, 2H , 2H , 2H , 1H / C SB6I // I// DIMENSION SB6I (5) C DATA SB6I / 7, 2H , 2H , 2H , 1HI/ C SBGOTO // GO TO // DIMENSION SBGOTO (5) C DATA SBGOTO / 7, 2H G, 2HO , 2HTO, 1H / C SCOMMA //,// DIMENSION SCOMMA (2) C DATA SCOMMA / 1, 1H,/ C SCONT //CONTINUE// DIMENSION SCONT (5) C DATA SCONT / 8, 2HCO, 2HNT, 2HIN, 2HUE/ C SCP //,(// DIMENSION SCP (2) C DATA SCP / 2, 2H,(/ C SDOST // DO // DIMENSION SDOST (6) C DATA SDOST / 9, 2H , 2H , 2H , 2HDO, 1H / C SDASH //----------------------------------------// DIMENSION SDASH (21) C DATA SDASH / 40, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H-- C 1 , 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H-- C 1 , 2H--, 2H--, 2H--, 2H--/ C SDUM //DUMMY-PROCEDURE// DIMENSION SDUM (9) C DATA SDUM / 15, 2HDU, 2HMM, 2HY-, 2HPR, 2HOC, 2HED, 2HUR, 1HE/ C SEQ //=// DIMENSION SEQ (2) C DATA SEQ / 1, 1H=/ C SFORCE // CONTINUE// DIMENSION SFORCE (8) C DATA SFORCE / 14, 2H , 2H , 2H , 2HCO, 2HNT, 2HIN, 2HUE/ C SGOTO // GO TO // DIMENSION SGOTO (7) C DATA SGOTO / 12, 2H , 2H , 2H , 2HGO, 2H T, 2HO / C SGOTOI // GO TO I// DIMENSION SGOTOI (8) C DATA SGOTOI / 13, 2H , 2H , 2H , 2HGO, 2H T, 2HO , 1HI/ C SGOTOP // GO TO (// DIMENSION SGOTOP (8) C DATA SGOTOP / 13, 2H , 2H , 2H , 2HGO, 2H T, 2HO , 1H(/ C SGUP1 //***** TRANSLATOR HAS USED UP ITS ALLOTED SPACE FOR TABLES// DIMENSION SGUP1 (30) C DATA SGUP1 / 57, 2H**, 2H**, 2H* , 2HTR, 2HAN, 2HSL, 2HAT, 2HOR C 1 , 2H H, 2HAS, 2H U, 2HSE, 2HD , 2HUP, 2H I, 2HTS C 1 , 2H A, 2HLL, 2HOT, 2HED, 2H S, 2HPA, 2HCE, 2H F C 1 , 2HOR, 2H T, 2HAB, 2HLE, 1HS/ C SGUP2 //***** TRANSLATION MUST TERMINATE IMMEDIATELY// DIMENSION SGUP2 (23) C DATA SGUP2 / 44, 2H**, 2H**, 2H* , 2HTR, 2HAN, 2HSL, 2HAT, 2HIO C 1 , 2HN , 2HMU, 2HST, 2H T, 2HER, 2HMI, 2HNA, 2HTE C 1 , 2H I, 2HMM, 2HED, 2HIA, 2HTE, 2HLY/ C SIF // IF// DIMENSION SIF (5) C DATA SIF / 8, 2H , 2H , 2H , 2HIF/ C SIFP // IF(// DIMENSION SIFP (6) C DATA SIFP / 9, 2H , 2H , 2H , 2HIF, 1H(/ C SIFPN // IF(.NOT.// DIMENSION SIFPN (8) C DATA SIFPN / 14, 2H , 2H , 2H , 2HIF, 2H(., 2HNO, 2HT./ C SNE //.NE.// DIMENSION SNE (3) C DATA SNE / 4, 2H.N, 2HE./ C SPB //) // DIMENSION SPB (2) C DATA SPB / 2, 2H) / C SPGOTO //) GO TO // DIMENSION SPGOTO (5) C DATA SPGOTO / 8, 2H) , 2HGO, 2H T, 2HO / C SRP //)// DIMENSION SRP (2) C DATA SRP / 1, 1H)/ C SRPCI //), I// DIMENSION SRPCI (3) C DATA SRPCI / 4, 2H),, 2H I/ C SRTN // RETURN// DIMENSION SRTN (7) C DATA SRTN / 12, 2H , 2H , 2H , 2HRE, 2HTU, 2HRN/ C SSPACR //. // DIMENSION SSPACR (3) C DATA SSPACR / 3, 2H. , 1H / C SSTOP // CALL EXIT// DIMENSION SSTOP (9) C DATA SSTOP / 15, 2H , 2H , 2H , 2HCA, 2HLL, 2H E, 2HXI, 1HT/ C SVER //(FLECS VERSION 22.38)// DIMENSION SVER (12) C DATA SVER / 21, 2H(F, 2HLE, 2HCS, 2H V, 2HER, 2HSI, 2HON, 2H 2 C 1 , 2H2., 2H38, 1H)/ C C--------------------------------------- C C THE DATA DECLARATIONS FOLLOW C C DATA POUND/"43/ !# SIGN FOR COLUMN 1 !26-JUN-81MAO DATA FORTCL /1/, LISTCL /2/, ERRCL /3/ DATA ACSEQ/1/, AELSE/2/, AFSEQ/3/, AGCONT/4/, AGGOTO/5/ DATA AGSTNO/6/, AMSEQ/7/, AGRET/8/, ASSEQ/9/, ATSEQ/10/ DATA UEXP/1/, UFORT/2/, UOWSE/3/, UPINV/4/, UDO/5/ DATA UDIR/6/ !29-JUN-81MAO DATA TCEXP/1/, TELSE/2/, TEND/3/, TEXEC/4/, TFIN/5/, TTO/6/ DATA TDIR /7/ !22-JUN-81 DATA TOFF /8/ !30JUN81MAO DATA TCOND/1/, TDO/2/, TFORT/3/, TIF/4/, TINVOK/5/, TRUNTL/6/ DATA TRWHIL/7/, TSELCT/8/, TUNLES/9/, TUNTIL/10/, TWHEN/11/ DATA TWHILE/12/ DATA DPAGE /1/ !22-JUN-81 DATA DINCL /2/ !29-JUN-81MAO DATA DPIF /3/, DPUNL /4/, DPEND /5/ !30JUN81MAO DATA DNAME /6/ !30JUN81MAO DATA DIMP /7/ !840307MAO DATA SETUP /1/, RETRY /2/, READ /3/ DATA CHC /67/ DATA CINLIN /33/ !25-JAN-80 DATA LWIDTH /132/ DATA MAXSTK /2000/ DATA NCHPWD /2/ DATA PRIME /53/ DATA SAFETY /35/ DATA SEEDNO /32760/ DATA LONG /.FALSE./ DATA SHORT /.TRUE./ DATA FAKE /.FALSE./ DATA COGOTO /.FALSE./ DATA CHSPAC /32/ DATA CHZERO /48/ DATA SSTMAX /200/ DATA SASSN1 / 13, 2H , 2H , 2H , 2HAS, 2HSI, 2HGN, 1H / DATA SASSN2 / 5, 2H T, 2HO , 1HI/ DATA SB / 1, 1H / DATA SB5I1 / 6, 2H , 2H , 2H 1/ DATA SB6 / 6, 2H , 2H , 2H / DATA SB7 / 7, 2H , 2H , 2H , 1H / DATA SB6I / 7, 2H , 2H , 2H , 1HI/ DATA SBGOTO / 7, 2H G, 2HO , 2HTO, 1H / DATA SCOMMA / 1, 1H,/ DATA SCONT / 8, 2HCO, 2HNT, 2HIN, 2HUE/ DATA SCP / 2, 2H,(/ DATA SDOST / 9, 2H , 2H , 2H , 2HDO, 1H / DATA SDASH / 40, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H-- 1 , 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H--, 2H-- 1 , 2H--, 2H--, 2H--, 2H--/ DATA SDUM / 15, 2HDU, 2HMM, 2HY-, 2HPR, 2HOC, 2HED, 2HUR, 1HE/ DATA SEQ / 1, 1H=/ DATA SFORCE / 14, 2H , 2H , 2H , 2HCO, 2HNT, 2HIN, 2HUE/ DATA SGOTO / 12, 2H , 2H , 2H , 2HGO, 2H T, 2HO / DATA SGOTOI / 13, 2H , 2H , 2H , 2HGO, 2H T, 2HO , 1HI/ DATA SGOTOP / 13, 2H , 2H , 2H , 2HGO, 2H T, 2HO , 1H(/ DATA SGUP1 / 57, 2H**, 2H**, 2H* , 2HTR, 2HAN, 2HSL, 2HAT, 2HOR 1 , 2H H, 2HAS, 2H U, 2HSE, 2HD , 2HUP, 2H I, 2HTS 1 , 2H A, 2HLL, 2HOT, 2HED, 2H S, 2HPA, 2HCE, 2H F 1 , 2HOR, 2H T, 2HAB, 2HLE, 1HS/ DATA SGUP2 / 44, 2H**, 2H**, 2H* , 2HTR, 2HAN, 2HSL, 2HAT, 2HIO 1 , 2HN , 2HMU, 2HST, 2H T, 2HER, 2HMI, 2HNA, 2HTE 1 , 2H I, 2HMM, 2HED, 2HIA, 2HTE, 2HLY/ DATA SIF / 8, 2H , 2H , 2H , 2HIF/ DATA SIFP / 9, 2H , 2H , 2H , 2HIF, 1H(/ DATA SIFPN / 14, 2H , 2H , 2H , 2HIF, 2H(., 2HNO, 2HT./ DATA SNE / 4, 2H.N, 2HE./ DATA SPB / 2, 2H) / DATA SPGOTO / 8, 2H) , 2HGO, 2H T, 2HO / DATA SRP / 1, 1H)/ DATA SRPCI / 4, 2H),, 2H I/ DATA SRTN / 12, 2H , 2H , 2H , 2HRE, 2HTU, 2HRN/ DATA SSPACR / 3, 2H. , 1H / DATA SSTOP / 15, 2H , 2H , 2H , 2HCA, 2HLL, 2H E, 2HXI, 1HT/ DATA SVER / 21, 2H(F, 2HLE, 2HCS, 2H V, 2HER, 2HSI, 2HON, 2H 2 1 , 2H2., 2H38, 1H)/ C C--------------------------------------- C C MAIN PROGRAM C PERFORM-INITIALIZATION REPEAT UNTIL (DONE) NOCALL=NOCALL+1 !ONE MORE CALL MADE TO OPENF CALL OPENF(NOCALL,DONE,SVER) !GET CMD LINE, OPEN FTN,FLL,FLX UNLESS (DONE) ENDFIL=.FALSE. MINCNT=0 !NUMBER OF WARNINGS MAJCNT=0 !NUMBER OF ERRORS LINENO=0 !INITIALIZE LINE # FOR FLX FILE REPEAT UNTIL (ENDFIL) PREPARE-TO-PROCESS-PROGRAM PROCESS-PROGRAM !STAYS IN HERE UNTIL HITS "END" FIN CALL CLOSEF(MINCNT,MAJCNT) !CLOSE FLX,FTN,FLL FILES FIN FIN CALL EXFLE !MAO, 30-APR-80 TO CHANGE-PAGE-HEADER-NAME !30JUN81MAO C C PROCESS .NAME DIRECTIVE C CALL CPYSUB (SST,SFLX,USTART(1),ULEN(1)) CALL NEWNAM (SST(1),SST(2)) FIN!to change-page-header-name TO COMPILE-CEXP !HANDLE CONDITIONAL SUBCLAUSE EXPRESSION GENERATE-BRANCH-AROUND-AND-ESTABLISH-NEXT-NUMBER SET-UP-STATEMENT-NUMBER !IF STMNT # ON FLX LINE, PUT IN NEXT WHEN (UTYPE(1).EQ.UEXP) !NORMAL CLAUSE GOTONO=NEWNO(0) STACK(TOP-2)=GOTONO PUT-IF-NOT-GOTO !IF(.NOT.(L))GOTO 'GOTONO' FIN ELSE STACK(TOP-2)=0 !OTHERWISE CLAUSE COMPLETE-ACTION FIN TO COMPILE-CONDITIONAL C C HANDEL CONDITIONAL STATEMENT--NOTE GENERATES NO CODE, MERELY C SETS UP STACK FOR FOLLOWING SUBCLAUSES C TOP=TOP+4 STACK(TOP)=ACSEQ STACK(TOP-1)=LINENO STACK(TOP-2)=0 STACK(TOP-3)=0 LEVEL=LEVEL+1 SET-UP-STATEMENT-NUMBER !IF STMNT # ON FLX LINE, PUT IN NEXTNO FIN TO COMPILE-DO !DO(), DO()FORT OR DO()C-O-A .PASSIF ALECS FORCE-OUT-LABELS GSTNO=NEWNO(0) PUSH-GSTNO !LOOP EXIT LABEL NEXTNO=NEWNO(0) !START OF SCOPE LABEL CONTNO=NEWNO(0) !LOOP NON-EXIT LABEL PUSH-GCONT C CALL ALEDO(SST,SFLX,USTART(1),ULEN(1),CONTNO,NEXTNO,GSTNO, 1 LINENO,MAJCNT,FORTCL,ERRCL) .PASSEND .PASSIF FLECS CONTNO=NEWNO(0) PUSH-GCONT !COMMAND TO GENERATE TERMINATING CONTINUE CALL CPYSTR(SST,SDOST) CALL CATNUM(SST,CONTNO) CALL CATSTR(SST,SB) CALL CATSUB(SST,SFLX,USTART(1)+1,ULEN(1)-2) STNO=FLXNO FLXNO=0 PUT-STATEMENT !"DO 'CONTNO' [CONTROL FROM FLX LESS PAREN]" .PASSEND COMPLETE-ACTION FIN TO COMPILE-ELSE !HANDLE ELSE, ELSE FORT OR ELSE C-O-A TOP=TOP-2 SET-UP-STATEMENT-NUMBER !IF STMNT # ON ELSE, PUT IN NEXTNO WHEN (NUNITS.EQ.1) !ELSE FORT OR ELSE C-O-A WHEN (UTYPE(1).EQ.UPINV) COMPILE-INVOKE !ELSE C-O-A ELSE CALL CPYSUB(SST,SFLX,USTART(1),ULEN(1)) UNLESS (STREQ(SST,SCONT)) COMPILE-FORTRAN FIN FIN ELSE PUSH-FINSEQ !PLAIN ELSE FIN TO COMPILE-END !HAVE HIT FORTRAN END IN FLX WHEN (CNDLVL.NE.0) ERROR=404 !30JUN81MAO ELSE !30JUN81MAO SORT-TABLE !TABLE OF PROCEDURE NAMES C IF (LONG.OR.COGOTO) GENERATE-PROCEDURE-DISPATCH-AREA !11-SEP-75 PUT-COPY IF (ENDFIL) ERROR=25 ENDPGM=.TRUE. .PASSIF FLECS IF (IMPSET) !840307MAO CALL IMPCLS !840307MAO IMPSET=.FALSE. !840307MAO FIN!if !840307MAO .PASSEND FIN!else !30JUN81MAO FIN TO COMPILE-EXEC !TRANSLATE EXECUTABLE FLECS STMNT SELECT (EXTYPE) (TFORT) PUT-COPY !PURE FORTRAN LINE, JUST OUTPUT IT (TIF) COMPILE-IF (TUNLES) COMPILE-UNLESS (TWHEN) COMPILE-WHEN (TWHILE) COMPILE-WHILE (TUNTIL) COMPILE-UNTIL (TRWHIL) COMPILE-RWHILE (TRUNTL) COMPILE-RUNTIL (TINVOK) COMPILE-INVOKE !PROCEDURE INVOKATION (TCOND) COMPILE-CONDITIONAL (TSELCT) COMPILE-SELECT (TDO) COMPILE-DO FIN FIN TO COMPILE-FORTRAN !FORTRAN LINE FOUND ON A FLECS LINE STNO=FLXNO !IF STMNT # ON FLX LINE, PUT IT ON THIS LINE CALL CPYSTR(SST,SB6) !PUT IN 6 BLANKS WHEN (UTYPE(1).EQ.UFORT) J=1 ELSE J=2 CALL CATSUB(SST,SFLX,USTART(J),ULEN(J)) !ADD ON FORTRAN LINE PUT-STATEMENT !PUT OUT LINE WITH STNO (IF IT EXISTS) FIN TO COMPILE-IF .PASSIF ALECS FINISH-IF-UNLESS .PASSEND .PASSIF FLECS WHEN (NUNITS.EQ.2.AND.UTYPE(2).EQ.UFORT) PUT-COPY !PLAIN FORT IF ELSE FINISH-IF-UNLESS !FLECS IF OR UNLESS .PASSEND FIN TO COMPILE-INVOKE !PROCEDURE INVOCATION FIND-ENTRY !FIND THE PROCEDURE IN THE PROCEDURE TABLE ENTNO=STACK(PENT+1) !START OF PROCEDURE STMNT # RETNO=NEWNO(0) !WHERE TO RETURN FROM THIS CALL MAX=MAX-(1+OFFSET) STACK(MAX+1)=STACK(PENT+3) STACK(PENT+3)=MAX+1 STACK(MAX+2)=LINENO IF (LONG.OR.COGOTO) STACK(MAX+3)=RETNO .PASSIF ALECS FORCE-OUT-LABELS CALL ALEINV(ENTNO,LINENO,FORTCL) .PASSEND .PASSIF FLECS WHEN (COGOTO) STACK(PENT-2)=STACK(PENT-2)+1 CALL CPYSTR(SST,SB6I) CALL CATNUM(SST,ENTNO) CALL CATSTR(SST,SEQ) CALL CATNUM(SST,STACK(PENT-2)) FIN ELSE CALL CPYSTR(SST,SASSN1) CALL CATNUM(SST,RETNO) CALL CATSTR(SST,SASSN2) CALL CATNUM(SST,ENTNO) !ASSIGN 'RETNO' TO I'ENTNO FIN STNO=FLXNO PUT-STATEMENT !PUT OUT ASSIGN STMNT GOTONO=ENTNO PUT-GOTO !GOTO 'ENTNO' NEXTNO=RETNO !NEXT STMNT #=RETURN PLACE FROM PROCEDURE .PASSEND FIN TO COMPILE-RUNTIL !HANDEL REPEAT UNTIL AS REPEAT WHILE(.NOT. NOTFLG=.FALSE. COMPILE-RWHILE FIN TO COMPILE-RWHILE !REPEAT WHILE OR REPEAT UNTIL SET-UP-STATEMENT-NUMBER !PUT # FROM FLX LINE INTO NEXTNO TESTNO=NEWNO(0) !# ON IF(.NOT. TOPNO=NEWNO(0) !# AT TOP OF SCOPE ENDNO=NEWNO(0) !# PAST END OF LOOP GOTONO=TOPNO PUT-GOTO !PUT OUT GOTO 'TOPNO' STNO=TESTNO GOTONO=ENDNO PUT-IF-NOT-GOTO !PUT OUT IF()GOTO 'ENDNO' GSTNO=ENDNO PUSH-GSTNO !STACK CMD TO GENERATE GOTO TARGET STMNT # GGOTON=TESTNO PUSH-GGOTO !STACK CMD TO GENERATE GOTO 'TESTNO' NEXTNO=TOPNO !NEXT STMNT #=TOPNO COMPLETE-ACTION FIN TO COMPILE-SELECT !PROCESS SELECT(E) SET-UP-STATEMENT-NUMBER !IF # ON FLX LINE, PUT INTO NEXTNO LEVEL=LEVEL+1 L=(ULEN(1)-1)/NCHPWD+6 !PREPARE TO STORE EXPRESSION ON STACK TOP=TOP+L+1 WHEN (TOP+SAFETY.LT.MAX) STACK(TOP)=ASSEQ STACK(TOP-1)=LINENO STACK(TOP-2)=0 STACK(TOP-3)=0 STACK(TOP-4)=L STACK(TOP-L)=0 CALL CATSUB(STACK(TOP-L),SFLX,USTART(1),ULEN(1)) !PUT ON STACK FIN ELSE GIVE-UP !STACK OVERFLOW--HOPELESS FIN TO COMPILE-SEQ-FIN !FIN AT END OF CONDITIONAL OR SELECT LEVEL=LEVEL-1 SET-UP-STATEMENT-NUMBER !IF # ON FLX LINE, PUT IN NEXTNO STNO=STACK(TOP-2) UNLESS (STNO.EQ.0) PUT-CONTINUE !WILL=0 IF WAS A OTHERWISE FORCE-NEXT-NUMBER !USE UP NEXTNO NEXTNO=STACK(TOP-3) !GET # BEYOND END OF CONDITIONAL POP-STACK FIN TO COMPILE-SEXP !PROCESS SELECT SUBCLAUSE GENERATE-BRANCH-AROUND-AND-ESTABLISH-NEXT-NUMBER SET-UP-STATEMENT-NUMBER !IF STMNT # ON FLX LINE, PUT IN NEXTNO WHEN (UTYPE(1).EQ.UEXP) !NORMAL EXPRESSION .PASSIF ALECS FORCE-OUT-LABELS I=STACK(TOP-4) NXIFNO=NEWNO(0) STACK(TOP-2)=NXIFNO CALL ALESXP(SST,SFLX,USTART(1),ULEN(1),STACK(TOP-I), 1 NXIFNO,LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL CPYSTR(SST,SIFP) CALL CATSUB(SST,SFLX,USTART(1),ULEN(1)) CALL CATSTR(SST,SNE) I=STACK(TOP-4) CALL CATSTR(SST,STACK(TOP-I)) CALL CATSTR(SST,SPGOTO) NXIFNO=NEWNO(0) STACK(TOP-2)=NXIFNO CALL CATNUM(SST,NXIFNO) !"IF((E1.NE.(E))GOTO NXIFNO" STNO=0 PUT-STATEMENT .PASSEND FIN ELSE STACK(TOP-2)=0 !FOR (OTHERWISE) COMPLETE-ACTION FIN TO COMPILE-SIMPLE-FIN C C FOR IF() OR UNLESS() OR WHEN() OR ELSE C SET-UP-STATEMENT-NUMBER LEVEL=LEVEL-1 TOP=TOP-2 FIN TO COMPILE-TO !PROCESS TO C-O-A, TO C-O-A FORT OR TO C-O-A A-B FIND-ENTRY WHEN(STACK(PENT+2).NE.0) !THIS PROCEDURE NEVER REFERENCED(?) ERROR=26 MLINE=STACK(PENT+2) ENTNO=NEWNO(0) FIN ELSE !GET ENTRY LABEL ENTNO=STACK(PENT+1) STACK(PENT+2)=LINENO FIN SET-UP-STATEMENT-NUMBER !PUT ANY FLX LINE STMNT # IN NEXTNO FORCE-NEXT-NUMBER !--> 'ENTNO' CONTINUE NEXTNO=ENTNO FORCE-NEXT-NUMBER TOP=TOP+2 STACK(TOP)=AGRET WHEN (SHORT.OR.FAKE) STACK(TOP-1)=ENTNO !SHORT .T. AT LAMPF ELSE STACK(TOP-1)=STACK(PENT-1) UTYPE(1)=0 COMPLETE-ACTION FIN TO COMPILE-UNLESS .PASSIF ALECS NOTFLG=.FALSE. FINISH-IF-UNLESS .PASSEND .PASSIF FLECS WHEN (NUNITS.EQ.2.AND.UTYPE(2).EQ.UFORT) !UNLESS()FORT CALL CPYSTR(SST,SIFPN) CALL CATSUB(SST,SFLX,USTART(1),ULEN(1)) CALL CATSTR(SST,SPB) CALL CATSUB(SST,SFLX,USTART(2),ULEN(2)) STNO=FLXNO PUT-STATEMENT FIN ELSE !UNLESS() OR UNLESS()C-O-A NOTFLG=.FALSE. FINISH-IF-UNLESS FIN .PASSEND FIN TO COMPILE-UNTIL !PROCESS AS WHILE(.NOT. NOTFLG=.FALSE. COMPILE-WHILE FIN TO COMPILE-WHEN !PROCESS WHEN(), WHEN()FORT OR WHEN()C-O-A ENDNO=NEWNO(0) !PAST END OF WHEN-ELSE ELSNO=NEWNO(0) !START OF ELSE GSTNO=ENDNO PUSH-GSTNO !STACK CMD TO PUT OUT STMNT # FOR GOTO TARGET TOP=TOP+2 STACK(TOP-1)=LINENO STACK(TOP)=AELSE !STACK CMD TO LOOK FOR ELSE GSTNO=ELSNO PUSH-GSTNO !PUT ELSE STMNT # ON STACK GGOTON=ENDNO PUSH-GGOTO !STACK CMD: GENERATE GOTO @ END OF WHEN CLAUSE GOTONO=ELSNO !WHERE TO GO IF LOGICAL CONDITION FALSE STNO=FLXNO FLXNO=0 PUT-IF-NOT-GOTO !IF(.NOT.(L))GOTO 'ELSENO' COMPLETE-ACTION FIN TO COMPILE-WHILE CONDITIONAL !GET STMNT # FOR HEAD OF LOOP (FLXNO.NE.0) LOOPNO=FLXNO FLXNO=0 FIN (NEXTNO.NE.0) LOOPNO=NEXTNO NEXTNO=0 FIN (OTHERWISE) LOOPNO=NEWNO(0) FIN FIN ENDNO=NEWNO(0) GSTNO=ENDNO PUSH-GSTNO !STMNT # FOR END OF LOOP ONTO STACK GGOTON=LOOPNO PUSH-GGOTO !PUSH CMD TO GENERATE GOTO 'LOOPNO' GOTONO=ENDNO STNO=LOOPNO PUT-IF-NOT-GOTO COMPLETE-ACTION FIN TO COMPLETE-ACTION C C FOR ALL FLECS LINES OF THE FORMS (), ()FORT, ()C-O-A, C C-O-A FORT OR C-O-A A-B DO FINAL PROCESSING C CONDITIONAL (NUNITS.EQ.1) PUSH-FINSEQ !() (UTYPE(2).EQ.UPINV) COMPILE-INVOKE !PROCEDURE INVOKE (OTHERWISE) !FORT ON THE LINE CALL CPYSUB(SST,SFLX,USTART(2),ULEN(2)) !IS IT JUST "CONTINUE"? UNLESS (STREQ(SST,SCONT)) COMPILE-FORTRAN FIN FIN FIN TO FIND-ENTRY !LOCATE PROCEDURE DFN ON STACK WHEN (UTYPE(1).EQ.UPINV) J=1 ELSE J=2 CALL CPYSUB(SPINV,SFLX,USTART(J),ULEN(J)) WHEN (STREQ(SPINV,SDUM)) PENT=PDUMMY STACK(PENT+2)=0 FIN ELSE P=MAXSTK-HASH(SPINV,PRIME) FOUND=.FALSE. UNLESS(STACK(P).EQ.0) REPEAT UNTIL(STACK(P).EQ.0.OR.FOUND) P=STACK(P) IF (STREQ(SPINV,STACK(P+4))) FOUND=.TRUE. FIN FIN WHEN (FOUND) PENT=P ELSE !NOT THERE, CREATE NEW ENTRY TMAX=MAX-(4+OFFST2+(SPINV(1)+NCHPWD-1)/NCHPWD) WHEN (TMAX.LE.TOP+SAFETY) PENT=PDUMMY STACK(PENT+2)=0 FIN ELSE MAX=TMAX PENT=MAX+OFFST2 IF (LONG.OR.COGOTO) STACK(PENT-1)=NEWNO(0) IF (COGOTO) STACK(PENT-2)=0 STACK(PENT)=0 STACK(P)=PENT STACK(PENT+1)=NEWNO(0) .PASSIF FLECS IF(IMPSET)CALL IMPWRT(STACK(PENT+1),LINENO,FORTCL)!840814MAO .PASSEND STACK(PENT+2)=0 STACK(PENT+3)=0 CALL CPYSTR(STACK(PENT+4),SPINV) FIN FIN FIN FIN TO FINISH-IF-UNLESS !FLECS IF OR UNLESS GOTONO=NEWNO(0) !GET STMNT # TO GOTO STNO=FLXNO FLXNO=0 PUT-IF-NOT-GOTO !IF([.NOT.](L))GOTO GSTNO=GOTONO PUSH-GSTNO COMPLETE-ACTION FIN TO FORCE-NEXT-NUMBER C C IF THERE IS A STMNT # IN NEXTNO TO BE USED AS TARGET OF A GOTO C PUT IT OUT NOW ON A CONTINUE STMNT C IF (NEXTNO.NE.0) .PASSIF ALECS CALL PUTLBL(NEXTNO,LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL PUTNUM(SFORCE,NEXTNO) CALL PUT(LINENO,SFORCE,FORTCL) .PASSEND NEXTNO=0 FIN FIN TO FORCE-OUT-LABELS !30JUN81MAO C C DIRECTIVES MAY NEED TO PUT OUT ALL OUTSTANDING LINE #S C (ALSO NECESSARY FOR ALECS SUBR). C FORCE-NEXT-NUMBER !USE UP NEXTNO IF(STNO.NE.0) NEXTNO=STNO FORCE-NEXT-NUMBER STNO=0 FIN IF (FLXNO.NE.0) NEXTNO=FLXNO FORCE-NEXT-NUMBER FLXNO=0 FIN!if FIN TO GENERATE-BRANCH-AROUND-AND-ESTABLISH-NEXT-NUMBER C C USED BY CONDITIONAL AND SELECT LOGIC SUBCLAUSES C ENDNO=STACK(TOP-3) WHEN (ENDNO.EQ.0) !.T. FOR FIRST SUBCLAUSE SEEN STACK(TOP-3)=NEWNO(0) FIN ELSE !FOR 2ND AND LATER NEED GOTO FOR PREVIOUS SUBCLAUSE GOTONO=ENDNO PUT-GOTO FIN CONDITIONAL (NEXTNO.EQ.0) NEXTNO=STACK(TOP-2) (STACK(TOP-2).EQ.0) CONTINUE (OTHERWISE) FORCE-NEXT-NUMBER NEXTNO=STACK(TOP-2) FIN FIN FIN TO GENERATE-CONTINUE !DO LOOP TERMINATING CONTINUE .PASSIF ALECS FORCE-OUT-LABELS CALL ALEBRI(STACK(TOP-1),LINENO,FORTCL) .PASSEND .PASSIF FLECS STNO=STACK(TOP-1) PUT-CONTINUE .PASSEND TOP=TOP-2 FIN TO GENERATE-GOTO C C GENERATE A GOTO, EG FROM END OF WHEN CLAUSE TO PAST END OF FIN C GOTONO=STACK(TOP-1) PUT-GOTO TOP=TOP-2 FIN C C COMMENT OUT FOLLOWING PROCEDURE TO SHORTEN FLECS !11-SEP-75 C C TO GENERATE-PROCEDURE-DISPATCH-AREA C P=PTABLE C UNTIL (P.EQ.0) C WHEN (STACK(P+2).NE.0) C WHEN (LONG) C CALL CPYSTR(SST,SGOTOI) C CALL CATNUM(SST,STACK(P+1)) C CALL CATSTR(SST,SCP) C FIN C ELSE CALL CPYSTR(SST,SGOTOP) C Q=STACK(P+3) C STNO=STACK(P-1) C WHEN(Q.EQ.0) CALL CATNUM(SST,STACK(P+1)) C ELSE C REPEAT UNTIL (Q.EQ.0) C IF (SST(1).GT.SSTMAX-6) C PUT-STATEMENT C CALL CPYSTR(SST,SB5I1) C FIN C CALL CATNUM(SST,STACK(Q+2)) C CALL CATSTR(SST,SCOMMA) C Q=STACK(Q) C FIN C SST(1)=SST(1)-1 C FIN C WHEN (LONG) CALL CATSTR(SST,SRP) C ELSE C IF(SST(1).GT.SSTMAX-9) C PUT-STATEMENT C CALL CPYSTR(SST,SB5I1) C FIN C CALL CATSTR(SST,SRPCI) C CALL CATNUM(SST,STACK(P+1)) C FIN C PUT-STATEMENT C FIN C ELSE C CALL CPYSTR(SST,SSTOP) C STNO=STACK(P+1) C PUT-STATEMENT C FIN C P=STACK(P) C FIN C FIN TO GENERATE-RETURN-FROM-PROC STNO=0 .PASSIF ALECS FORCE-OUT-LABELS CALL ALERTS(LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL CPYSTR(SST,SGOTOI) IF (LONG.OR.COGOTO) SST(1)=SST(1)-1 CALL CATNUM(SST,STACK(TOP-1)) !GOTO I# IF (FAKE) !NOT IN THIS VERSION CALL CATSTR(SST,SCP) CALL CATNUM(SST,STACK(TOP-1)) CALL CATSTR(SST,SRP) FIN PUT-STATEMENT .PASSEND TOP=TOP-2 FIN TO GENERATE-STATEMENT-NUMBER C C PUT SAVED GOTO TARGET # INTO NEXTNO SO IT WILL APPEAR ON C NEXT STMNT C FORCE-NEXT-NUMBER NEXTNO=STACK(TOP-1) TOP=TOP-2 FIN TO GIVE-UP !ABORT ON STACK OVERFLOW CALL PUT(0,SGUP1,ERRCL) CALL PUT(0,SGUP2,ERRCL) CALL CLOSEF(MINCNT,-1) CALL EXFLE !MAO, 30-APR-80 FIN C C THE FOLLOWING PROCEDURE IS NOT USED IF LINE IN C "TO PREPARE-TO PROCESS-PROGRAM" IS COMMENTED OUT 30JUN81MAO C C TO LIST-DASHES C CALL PUT(0,SB,LISTCL) !BLANK LINE C CALL PUT(0,SDASH,LISTCL) !DASH LINE C CALL PUT(0,SB,LISTCL) !BLANK LINE C FIN TO OPEN-INCLUDE-FILE !29-JUN-81MAO C C PROCESS .INCLUDE name C CALL CPYSUB (SST,SFLX,USTART(1),ULEN(1)) CALL OPNINC (SST(1),SST(2),ERROR) IF (ERROR.NE.0) ERROR=ERROR+300 FIN!to open-include-file TO PERFORM-INITIALIZATION C C CALLED ONCE PER EXECUTION OF FLECS C CALL LAMPFI(ALECS,CHC,CINLIN) !20-FEB-80 C NOCALL=0 !# OF TIMES OPENF HAS BEEN CALLED PARAM1=NCHPWD !# OF CHARACTERS PER INTEGER WORD PARAM2=CHZERO PARAM3=CHSPAC PARAM4=CHC !COMMENT CHARACTER PARAM5=CINLIN !IN-LINE COMMENT CHAR !25-JAN-80 BLN=0 WWIDTH=LWIDTH-18 !11-SEP-75, 830307 ADD FORT LINE # REFNO=(WWIDTH-6)/7 !11-SEP-75 !830311 CONDITIONAL (SHORT.OR.FAKE) OFFSET=1 OFFST2=1 FIN (COGOTO) OFFSET=2 OFFST2=3 FIN (OTHERWISE) OFFSET=2 OFFST2=3 FIN FIN NOTFLG=.TRUE. ERLST=.FALSE. IMPSET=.FALSE. !840307MAO FIN TO POP-STACK TOPTYP=STACK(TOP) SELECT (TOPTYP) (ASSEQ) TOP=TOP-STACK(TOP-4)-1 (ACSEQ) TOP=TOP-4 (AGGOTO) TOP=TOP-2 (AGCONT) TOP=TOP-2 (AFSEQ) TOP=TOP-2 (AELSE) TOP=TOP-2 (AGSTNO) TOP=TOP-2 (ATSEQ) TOP=TOP-1 (AMSEQ) TOP=TOP-1 (AGRET) TOP=TOP-2 FIN FIN TO PREPARE-TO-PROCESS-PROGRAM C C CALLED AT START-OF-FILE OR AFTER HITTING "END" (CONCAT MODULES) DUMMY=NEWNO(SEEDNO) !INITIALIZE STMNT # GENERATOR ENDPGM=.FALSE. MAX=MAXSTK-(PRIME+OFFSET+3) PDUMMY=MAX+OFFSET DO (I=MAX,MAXSTK) STACK(I)=0 TOP=1 !START OF STACK STACK(TOP)=AMSEQ !INITIAL CMD: LOOK FOR FLECS MAIN LINE OR FORT ERROR=0 FIRST=.TRUE. !THIS IS FIRST READ ON THIS FILE NOPGM=.FALSE. NEXTNO=0 !STMNT # FOR NEXT STMNT PUT IN FTN FILE SOURCE=READ !GET INPUT FROM FILE LEVEL=0 LSTLEV=0 PASFLG=.TRUE. !30JUN81MAO CNDLVL=0 !30JUN81MAO OFFLVL=0 !30JUN81MAO C NUMLIN=0 !NO FORT LINES YET !830307 C C NEXT LINE PREVENTS .NAME name FROM WORKING FOR 1ST PAGE C OF FLL FILE. THUS IT WAS COMMENTED OUT. 30JUN81MAO C C LIST-DASHES FIN TO PROCESS-DIRECTIVE !22-JUN-81 C C PROCESS THE FLECS DIRECTIVES C SELECT (DTYPE) (DPAGE) PUT-OUT-NEW-PAGE (DINCL) OPEN-INCLUDE-FILE !29-JUN-81MAO (DPIF) PROCESS-PASSIF !30JUN81MAO (DPUNL) PROCESS-PASSUNLESS !30JUN81MAO (DPEND) PROCESS-PASSEND !30JUN81MAO (DNAME) CHANGE-PAGE-HEADER-NAME !30JUN81MAO .PASSIF FLECS (DIMP) PROCESS-IMPLICIT-NONE !840307MAO .PASSEND FIN!select FIN!to process-directive .PASSIF FLECS TO PROCESS-IMPLICIT-NONE !840307MAO C Open .FID file CALL IMPOPN (IMPSET,LINENO,FORTCL,ERRCL,MAJCNT) !840307MAO FIN!to process-implicit-none .PASSEND TO PROCESS-PASSEND !process .PASSEND !30JUN81MAO FORCE-OUT-LABELS !just to be safe WHEN (CNDLVL.EQ.0) ERROR=401 !extra .PASSEND ELSE IF (CNDLVL.EQ.OFFLVL) PASFLG=.TRUE. !back on CNDLVL=CNDLVL-1 FIN!else FIN!to process-passend TO PROCESS-PASSIF !process .PASSIF name !30JUN81MAO C FORCE-OUT-LABELS !MUST do this, vital if turning off output! CNDLVL=CNDLVL+1 !one more level of conditional IF (PASFLG) !passing code? (If not skip below) C C Is the conditional name defined? C CALL CPYSUB (SST,SFLX,USTART(1),ULEN(1)) !get the name IF (SST(1).GT.6) !name too long, truncate SST(1)=6 ERROR=402 FIN!if IF (SST(1).LT.1) ERROR=403 !no name given! IF (ERROR.EQ.0) I=1 FOUND=.FALSE. UNTIL (I.GT.COND .OR. FOUND) FOUND=STREQ (SST,CNDVAL(1,I)) I=I+1 FIN!until UNLESS (NOTFLG) FOUND=.NOT.FOUND !invert for .PASSUNLESS UNLESS (FOUND) !if wrong sense, turn off passing PASFLG=.FALSE. OFFLVL=CNDLVL FIN!unless FIN!if FIN!if FIN!to process-passif TO PROCESS-PASSUNLESS !process .PASSUNLESS !30JUN81MAO NOTFLG=.FALSE. !signal really PASSUNLESS PROCESS-PASSIF !process NOTFLG=.TRUE. !reset to default value FIN!to process-passunless TO PROCESS-PROGRAM REPEAT UNTIL (ENDPGM) !IE. HIT END STATEMENT IF(TOP+SAFETY.GT.MAX) GIVE-UP ACTION=STACK(TOP) !ON FIRST PASS=AMSEQ SELECT (ACTION) (AGGOTO) GENERATE-GOTO (AGRET) GENERATE-RETURN-FROM-PROC (AGCONT) GENERATE-CONTINUE (AGSTNO) GENERATE-STATEMENT-NUMBER (OTHERWISE) CALL ANALYZ !GET INPUT AND FIGURE OUT WHAT NEEDS DOING SELECT (ACTION) (AFSEQ) !A FIN IS OUTSTANDING SELECT(CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TEXEC) COMPILE-EXEC (TFIN) COMPILE-SIMPLE-FIN (TEND) ERROR=1 (TELSE) ERROR=10 (TTO) ERROR=13 (TCEXP) ERROR=19 (TOFF)CONTINUE !30JUN81MAO FIN FIN (AMSEQ) !LOOK FOR MAIN STMNT OR FORT SELECT(CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TEXEC) COMPILE-EXEC (TEND) WHEN (NOPGM) ENDPGM=.TRUE. ELSE COMPILE-END FIN (TFIN) ERROR=5 (TELSE) ERROR=8 (TTO) STACK(TOP)=ATSEQ !NOTE TOP NOT SHIFTED!!-->ONLY PROC DFN LEGAL COMPILE-TO FIN (TCEXP) ERROR=17 (TOFF)CONTINUE !30JUN81MAO FIN FIN (ASSEQ) !LOOKING FOR SELECT SUBCLAUSE SELECT (CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TCEXP) COMPILE-SEXP (TFIN) COMPILE-SEQ-FIN (TEND) ERROR=3 (TELSE) ERROR=12 (TTO) ERROR=15 (TEXEC) ERROR=23 (TOFF)CONTINUE !30JUN81MAO FIN FIN (ACSEQ) !LOOKING FOR A CONDITIONAL SUBCLAUSE SELECT(CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TCEXP) COMPILE-CEXP (TFIN) COMPILE-SEQ-FIN !FIN TERMINATING CONDITIONAL (TEND) ERROR=2 (TELSE) ERROR=11 (TTO) ERROR=14 (TEXEC) ERROR=22 (TOFF)CONTINUE !30JUN81MAO FIN FIN (AELSE) !NEED ELSE NEXT SELECT(CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TELSE) COMPILE-ELSE (TEND) ERROR=4 (TFIN) ERROR=7 (TTO) ERROR=16 (TCEXP) ERROR=20 (TEXEC) ERROR=24 (TOFF)CONTINUE !30JUN81MAO FIN FIN (ATSEQ) !ONLY TO OR DIRECTIVE OR END LEGAL SELECT (CLASS) (TDIR) PROCESS-DIRECTIVE !22-JUN-81 MAO (TTO) COMPILE-TO (TEND) COMPILE-END (TFIN) ERROR=6 (TELSE) ERROR=9 (TCEXP) ERROR=18 (TEXEC) ERROR=21 (TOFF)CONTINUE !30JUN81MAO FIN FIN FIN UNLESS (NOPGM .OR. CLASS.EQ.TOFF) CALL LIST !30JUN81MAO FIN FIN FIN FIN TO PUSH-FINSEQ !IF(), UNLESS(), WHEN() OR ELSE TOP=TOP+2 STACK(TOP-1)=LINENO STACK(TOP)=AFSEQ LEVEL=LEVEL+1 FIN TO PUSH-GCONT !TERMINATING CONTINUE FOR DO TOP=TOP+2 STACK(TOP-1)=CONTNO STACK(TOP)=AGCONT FIN TO PUSH-GGOTO !PUT CMD TO GENERAGE A GOTO 'GGOTON' ON STACK TOP=TOP+2 STACK(TOP-1)=GGOTON STACK(TOP)=AGGOTO FIN TO PUSH-GSTNO !PUT STMNT # THAT IS TARGET OF GOTO ON STACK TOP=TOP+2 STACK(TOP-1)=GSTNO STACK(TOP)=AGSTNO FIN TO PUT-CONTINUE !PUT OUT "'STNO' CONTINUE" FORCE-NEXT-NUMBER !MAKE SURE NEXTNO IS USED UP .PASSIF ALECS CALL PUTLBL(STNO,LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL PUTNUM(SFORCE,STNO) CALL PUT(LINENO,SFORCE,FORTCL) .PASSEND STNO=0 FIN TO PUT-COPY !PUT A LINE INTO FTN FILE FROM STRING SFLX C C IF "#" IN COL 1, REMOVE FOR OUTPUT TO FTN FILE. C CALL CPYSTR (SST,SFLX) !26JUN81MAO CALL GETCH (SST(2),1,I) !# IN COL 1? !26-JUN-81(MAO) IF (I.EQ.POUND)CALL PUTCH(SST(2),1,CHSPAC) !BLANK OUT !26JUN81MAO CONDITIONAL (NEXTNO.EQ.0) CALL PUT(LINENO,SST,FORTCL) !26JUN81MAO (FLXNO.NE.0.OR.PASS) !WAS SOMETHING IN COL1-5 OF FLX LINE FORCE-NEXT-NUMBER CALL PUT(LINENO,SST,FORTCL) !26JUN81MAO FIN (OTHERWISE) !PUT NEXTNO ON LINE AND OUTPUT IT C .PASSIF ALECS CALL PUTLBL(NEXTNO,LINENO,FORTCL) CALL PUT(LINENO,SST,FORTCL) !26JUN81MAO .PASSEND .PASSIF FLECS CALL PUTNUM(SST,NEXTNO) CALL PUT(LINENO,SST,FORTCL) .PASSEND NEXTNO=0 FIN FIN FIN TO PUT-GOTO !PUT OUT A GOTO 'GOTONO' .PASSIF ALECS FORCE-OUT-LABELS CALL ALEBRI(GOTONO,LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL CPYSTR(SPUTGO,SGOTO) CALL CATNUM(SPUTGO,GOTONO) IF (NEXTNO.NE.0) CALL PUTNUM(SPUTGO,NEXTNO) NEXTNO=0 FIN CALL PUT(LINENO,SPUTGO,FORTCL) .PASSEND FIN TO PUT-IF-NOT-GOTO C C PUT OUT IF(.NOT.())GOTO OR IF()GOTO C .PASSIF ALECS FORCE-OUT-LABELS CALL PUTLOG(SFLX,USTART(1),ULEN(1),NOTFLG,GOTONO,LINENO, 1 MAJCNT,FORTCL,ERRCL) .PASSEND .PASSIF FLECS WHEN(NOTFLG) CALL CPYSTR(SST,SIFPN) ELSE CALL CPYSTR(SST,SIF) CALL CATSUB(SST,SFLX,USTART(1),ULEN(1)) WHEN (NOTFLG) CALL CATSTR(SST,SPGOTO) ELSE CALL CATSTR(SST,SBGOTO) CALL CATNUM(SST,GOTONO) PUT-STATEMENT .PASSEND NOTFLG=.TRUE. FIN TO PUT-OUT-NEW-PAGE !22-JUN-81 MAO C C .PAGE FORCES A NEW PAGE C CALL NEWPG FIN!to put-out-new-page TO PUT-STATEMENT !PUT OUTPUT IN FTN FILE UNLESS (NEXTNO.EQ.0) !MUST USE UP NEXTNO WHEN (STNO.EQ.0) STNO=NEXTNO NEXTNO=0 FIN ELSE FORCE-NEXT-NUMBER FIN UNLESS (STNO.EQ.0) .PASSIF ALECS CALL PUTLBL(STNO,LINENO,FORTCL) .PASSEND .PASSIF FLECS CALL PUTNUM(SST,STNO) .PASSEND STNO=0 FIN C C PUT OUT FORTRAN LINE, WITH CONTINUATION LINES IF >72 COLUMNS C WHEN (SST(1).LE.72) CALL PUT(LINENO,SST,FORTCL) ELSE C C This operation may cause bugs in the output code. Eg. consider C UNLESS (CNTALL) NUMLIN=NUMLIN-1 !USUALLY DONT COUNT !830307 MAO C which generates the following code C IF(.NOT.(CNTALL)) NUMLIN=NUMLIN-1 !USUALLY DONT COUNT !83030 C 17 C since the 7 doesn't fit on first line. But FORTRAN now says C we are subtracting 17, not 1!! Thus set warning flag C ERROR=500 !Warning message from L!830308 CALL CPYSUB (SLIST,SST,1,72) CALL PUT(LINENO,SLIST,FORTCL) S=73 L=66 REPEAT UNTIL (S.GT.SST(1)) IF(S+L-1.GT.SST(1)) L=SST(1)-S+1 CALL CPYSTR(SLIST,SB5I1) CALL CATSUB(SLIST,SST,S,L) CALL PUT(LINENO,SLIST,FORTCL) UNLESS (CNTALL) NUMLIN=NUMLIN-1 !USUALLY DONT COUNT !830307 S=S+66 FIN FIN FIN TO REVERSE-LIST LL=0 LR=STACK(LP) UNTIL (LR.EQ.0) LT=STACK(LR) STACK(LR)=LL LL=LR LR=LT FIN STACK(LP)=LL FIN TO SET-UP-STATEMENT-NUMBER IF (FLXNO.NE.0) !IF IS STMNT # ON LINE FROM FLX FILE FORCE-NEXT-NUMBER !USE UP NEXTNO AS 'NEXTNO' CONTINUE NEXTNO=FLXNO FLXNO=0 FIN FIN TO SORT-TABLE P=MAX STACK(MAX)=0 ITEMP=MAXSTK-PRIME+1 DO (I=ITEMP,MAXSTK) UNLESS (STACK(I).EQ.0) STACK(P)=STACK(I) REPEAT UNTIL (STACK(P).EQ.0) P=STACK(P) LP=P+3 REVERSE-LIST FIN FIN FIN Q=MAX-1 STACK(Q)=0 UNTIL (STACK(MAX).EQ.0) P=STACK(MAX) STACK(MAX)=STACK(P) QM=Q QP=STACK(QM) INSERT=.FALSE. UNTIL (INSERT) CONDITIONAL (QP.EQ.0) INSERT=.TRUE. (STRLT(STACK(P+4),STACK(QP+4))) INSERT=.TRUE. (OTHERWISE) QM=QP QP=STACK(QM) FIN FIN FIN STACK(P)=QP STACK(QM)=P FIN PTABLE=STACK(Q) FIN END