C EXTENDED FORTRAN PREPROCESSOR C C THIS PROGRAM RETRIEVES ITS COMMAND LINE, AND USES THAT AS THE NAME OF C A FILE. THIS FILE NAME MUST NOT HAVE AN EXTENSION. IT IS ASSUMED THAT C THE SOURCE FILE IS OF THE TYPE "FILENAME.FTE". IT MAY THEN PRODUCE A C LISTING FILE "FILENAME.LST" AND A STANDARD FORTRAN IV FILE NAMED C "FILENAME.TMP". C THE INPUT FILE CONTAINS STANDARD FORTRAN STATEMENTS, AND MAY ALSO C CONTAIN EXTENDED FORTRAN STATEMENTS SUCH AS IF-THEN-ELSE CLAUSES, C AND VARIABLE NAMES WHICH EXCEED 6 CHARACTERS IN LENGTH. THESE EXTENSIONS C ARE TRANSLATED INTO VALID FORTRAN IN THE OUTPUT FILE WHICH MAY THEN BE C COMPILED IN THE USUAL WAY. C THIS FILE CONTAINS VARIANTS FOR RSX-11M AND VAX/VMS. C SEE SUBROUTINES AND FOR THE REQUISITE CHANGES. C C C MCR COMMAND LINE: >FTE FILENAME C C IF A LISTING FILE IS DESIRED, APPEND "/LI" (EXACTLY) C TO THE FILENAME: >FTE FILENAME/LI C IF A CROSS REFERENCE SYMBOL TABLE IS ALSO DESIRED, APPEND "/CR" (EXACTLY) C TO THE FILENAME: >FTE FILENAME/CR C C IF THE TASK IS NOT INSTALLED, IT MAY BE RUN AS FOLLOWS: C >RUN FTE/PRM="FILENAME" C C WE ALSO HAVE A COMMAND WHICH RUNS FTE AND THEN SUBMITS THE TRANSLATED C FILE TO THE REGULAR FORTRAN COMPILER, THEN DELETES THE INTERMEDIATE C FILE: >FTC FILENAME C OR >FTC FILENAME/CR C C C C LONG VARIABLE NAMES: C C THIS PREPROCESSOR SCANS FOR VARIABLE NAMES WHICH ARE LONGER THAN 6 CHARACTERS C OR WHICH HAVE AN UNDERSCORE IN THEM. THESE NAMES ARE CONVERTED TO VALID C FORTRAN NAMES CONSISTING OF THE FIRST LETTER OF THE LONG NAME, FOLLOWED BY C A UNIQUE 5 DIGIT NUMBER STARTING AT 30000. SHORT NAMES OF THIS FORM SHOULD C NOT BE USED ELSEWHERE IN THE PROGRAM. VALID LONG NAMES ARE: C C THIS_IS_A_VALID_LONG_NAME C SOISTHISONE C A_1 C C STRUCTURED STATEMENTS: C C EXTENDED FORTRAN PERMITS THE USE OF CERTAIN STATEMENTS AVAILABLE IN OTHER C LANGUAGES, SUCH AS ALGOL, A, B, C, PASCAL, PL/I, WHICH ENABLE THE WRITING C OF STRUCTURED PROGRAMS, I.E. THOSE WITHOUT GO TO STATEMENT AND LABELS. C ALL SUCH EXTENDED STATEMENTS ARE TRANSLATED INTO VALID FORTRAN GOTO'S C AND CONTINUES. STATEMENT LABELS USED IN THE TRANSLATION START AT 30000, C SO DO NOT USE ANY STATEMENT LABELS GREATER THAN 30000. C C THE BASIC FORM FOR THE VALID STRUCTURED STATEMENTS IS: C C IFF (LOGICAL RESULT) C THEN C STATEMENT1 C ELSE C STATEMENT2 C C IFF (LOGICAL RESULT) C THEN C STATEMENT1 C ELSEIF (LOGICAL RESULT) C STATEMENT2 C ELSEIF (LOGICAL RESULT) C STATEMENT3 C .... C ELSE C STATEMENT N C C WHILE (LOGICAL RESULT) C STATEMENT1 C C REPEAT C STATEMENT1 C C REPEAT C STATEMENT1 C UNTIL (LOGICAL RESULT) C C FOR VAR1 = EXP1, EXP2 {,EXP3} C STATEMENT1 C C IN ALL CASES, THE STATEMENTS MAY BE MADE UP OF SEVERAL STATEMENTS SURROUNDED C BY BRACE BRACKETS "{" AND "}". THE EXTENDED STATEMENTS MUST BE ON THEIR OWN C LINES, SEPARATE FROM FORTRAN STATEMENTS. THE OPTIONAL BRACES MAY C APPEAR ON THE SAME LINE AS THE EXTENDED STATEMENT, OR ON THEIR OWN LINES. C FOR EXAMPLE: C C IFF (A .GT. B) C THEN { C A = C + D C WHILE (X .LT. 0.0) C READ (5,10) X C } C ELSE C { C A = C - D C REPEAT { C FOR J=1,10 C { C Z = Z+1 C ENTRY_ELEMENT(J) = Z C } C READ (5,10) X C Y = SQRT(X) C } UNTIL (Y .GT. 10.0) C } C C THE OPENING BRACE IS NOT PERMITTED ON THE SAME LINE AS THE WHILE OR FOR, BUT C IT MAY FOLLOW THEN, ELSE, REPEAT. THE UNTIL IS OPTIONAL, AND MAY FOLLOW THE C CLOSING BRACE OR MAY BE ON THE NEXT LINE. AN ELSEIF STATEMENT MAY BE USED C IN PLACE OF AN ELSE STATEMENT TO CHAIN TOGETHER A NUMBER OF C POSSIBLE CHOICES. SUCH A CHAIN STARTS WITH AN IFF / THEN, C THEN ANY NUMBER OF ELSEIF / THEN CLAUSES, AND OPTIONALLY ENDED C BY AN ELSE CLAUSE WHICH IS EXECUTED IF NONE OF THE PRECEDING C CONDITIONALS IS MET. C C IF SIMPLE CLAUSES ARE USED (I.E. NO BRACE BRACKETS AROUND STATEMENT) C THEN THE STATEMENT MUST BE A REGULAR FORTRAN STATEMENT; EXTENDED STATEMENTS C WOULD NOT BE RECOGNIZED. C C UNLABELLED FORMAT STATEMENTS C C IN ORDER TO MINIMIZE THE NUMBER OF STATEMENT LABELS REQUIRED, AN C UNLABELLED FORMAT STATEMENT IS PROVIDED. THE READ OR WRITE STATEMENT C PRECEDING IT HAS TWO PERCENT SIGNS WHERE THE FORMAT NUMBER USUALLY GOES. C THE NEXT STATEMENT MUST BE A FORMAT STATEMENT WITHOUT A LEADING C STATEMENT NUMBER. A NUMBER GREATER THAN 30000 WILL BE SUBSTITUTED. C SUCH A STATEMENT MAY GO ANYWHERE AN EXTENDED STATEMENT MAY APPEAR. C FOR EXAMPLE, WRITE (5,%%) A,B,C C FORMAT (3F10.1) C C LISTING CONTROL C C THE .PAGE DIRECTIVE, STARTING IN COLUMN 1, CAUSES A NEW PAGE TO BE C BEGUN IN THE LISTING. THE DIRECTIVE ITSELF IS NOT PRINTED. C COMMENTS STARTING WITH "!" AT THE END OF A STATEMENT ARE REMOVED, C SO THAT THEY MAY APPEAR AT THE END OF CONTINUED LINES. C TOTALLY BLANK OR ZERO-LENGTH LINES ARE PERMITTED TO IMPROVE READABILITY. C THE LISTING CONTAINS BOTH FORTRAN STATEMENT NUMBERS AND INPUT FILE C LINE NUMBERS; THE LATTER CAN BE USED BY EDITOR TO FIND LINES EASILY. C C .LIST, .NOLIST DIRECTIVES C C THESE ARE USED TO TURN ON AND OFF THE PRINTING OF TEXT ON THE C LISTING FILE. THEY DO NOT AFFECT THE TRANSLATION. THEY STAY C IN EFFECT ACROSS MODULE BOUNDARIES. C C .CONDLIST, .NOCONDLIST DIRECTIVES C C THESE ARE USED TO TURN ON AND OFF THE PRINTING OF TEXT INSIDE C UNSATISFIED .IFDF CLAUSES. NORMALLY SUCH TEXT, WHICH IS NOT C INCLUDED IN THE TRANSLATED FILE, IS LISTED IN THE LISTING FILE C WITH A LEADING HYPHEN TO SHOW IT WAS NOT INCLUDED. IF THE C .NOCONDLIST IS IN EFFECT, THESE LINES ARE NOT LISTED, EXCEPT FOR C THE FIRST .IFDF AND THE LAST .ENDC. C C .COMMENT, .NOCOMMENT DIRECTIVES C C IF .COMMENT IS SPECIFIED, COMMENTS BEGINNING WITH A "C" IN COLUMN 1 C ARE WRITTEN INTO THE TRANSLATED TEXT FILE, OTHERWISE THEY ARE NOT. C C .INCLUDE DIRECTIVE C C THE .INCLUDE DIRECTIVE, WHICH BEGINS IN COLUMN 1, IS USED TO GET FORTRAN C SOURCE LINES FROM A SECONDARY FILE, WHOSE NAME FOLLOWS THE DIRECTIVE. C THE INCLUDED TEXT MAY ITSELF CONTAIN AN .INCLUDE DIRECTIVE. THE C INCLUDED TEXT IS NUMBERED FROM THE BEGINNING OF THE SECONDARY FILE, C AND THE LINE NUMBERING OF THE MAIN TEXT FILE IS RESUMED AT THE END OF C THE SECONDARY FILE. A TOTAL OF 3 FILES MAY BE OPEN FOR INPUT AT ANY C ONE TIME. FOR THE CYBER VERSION, THE FILE NAME IS FIRST CONSIDERED C A LOCAL FILE. IF THE OPEN FAILS, IT WILL ATTEMP TO GET THE FILE C FROM THE PERMANENT FILE DIRECTORY. "/UN=USERNO" MAY BE APPENDED TO C SPECIFY WHICH ACCOUNT THE FILE IS TO BE FOUND IN. C EXAMPLES: C .INCLUDE PERMFIL C .INCLUDE HISFILE/UN=EXDV001 C C .DEFINE DIRECTIVE C C THIS PERMITS LOCAL SYMBOLS TO BE DEFINED BY THE PREPROCESSOR. C THE SYMBOL IS GIVEN A VALUE WHICH IS SUBSTITUTED WHENEVER THE SYMBOL C IS COME ACROSS LATER. THIS ALLOWS LITERALS TO BE DEFINED EASILY. C THE FORMAT IS: .DEFINE SYMBOL VALUE C WHERE SYMBOL IS ANY VALID VARIABLE NAME (INCLUDING A LONG NAME), C AND VALUE IS THE CONTENTS OF THE REST OF THE LINE FOLLOWING THE C SPACE AFTER SYMBOL. THE SUBSTITUTED TEXT WILL AGAIN BE SCANNED FOR C ANY DEFINED SYMBOLS AFTER SUBSTITUTION; TAKE CARE TO AVOID SUBSTITUTION LOOPS. C COMMENTS MAY BE APPENDED AFTER EXCLAMATION POINTS. TRAILING C BLANKS BETWEEN THE DEFINING STRING AND THE COMMENT ARE REMOVED. C FOR EXAMPLE: C .DEFINE OUTPUT WRITE (5,%%) C OUTPUT A,B,C C FORMAT (3F10.1) C C SYMBOLS MAY BE REDEFINED LATER. RESERVED NAMES MAY NOT BE USED C FOR SYMBOLS. THE DEFINITIONS ONLY HOLD FOR THE CURRENT MODULE. C C .IFDF, .IFNDF, .ENDC DIRECTIVES C C THESE ARE THE CONDITIONAL COMPILATION DIRECTIVES. .IFDF AND .IFNDF C ARE USED TO TEST WHETHER A SYMBOL HAS BEEN DEFINED (EITHER BY A C .DEFINE DIRECTIVE OR AS A VARIABLE). .IFDF IS TRUE IF IT HAS BEEN C DEFINED, .IFNDF IS TRUE IF IT HAS NOT BEEN DEFINED. ALL CODE C BETWEEN THE .IFDF/.IFNDF AND THE MATCHING .ENDC DIRECTIVE WILL NOT C BE COMPILED IF THE DIRECTIVE IS FALSE. SUCH DIRECTIVES MAY BE C NESTED UP TO 10 DEEP. THE FORM IS: .IFDF SYMBOL !OPTIONAL COMMENT C AND: .ENDC {SYMBOL}, WHERE SYMBOL IS NOT USED. C NOTE THAT THESE DIRECTIVES CAN CROSS MODULE BOUNDARIES, UNLIKE C DEFINED SYMBOLS. THIS PERMITS ONE TO CONDITIONALLY DEFINED C SUBROUTINES. C SEVERAL SYMBOLS MAY BE TESTED IN THE SAME STATEMENT BY USING THE C OPERATORS &(AND) AND /(OR) TO JOIN SYMBOLS. FOR EXAMPLE, C .IFDF A & B / C . THE EXPRESSION IS EVALUATED STRICTLY LEFT TO C RIGHT. ONE MAY ALSO COMPARE THE VALUE OF A SYMBOL TO A STRING C BY USING RELATIONAL OPERATORS = < > <= >= != . THE LEFT HAND SIDE C MUST BE AN ALREADY DEFINED SYMBOL (OTHERWISE RELATION IS SET FALSE), C AND THE RIGHT SIDE IS A SYMBOL OR NUMBERS WHICH IS TO BE COMPARED. C NOTE THAT THE RIGHT SIDE IS TREATED AS A CHARACTER STRING ONLY, AND C IS NOT TREATED AS A SYMBOL EXCEPT FOR PARSING. SINCE THE COMPARISON C IS BY CHARACTERS, CARE MUST BE TAKEN WITH NUMBERS. C .DEFINE A 10 C .IFDF A = 010 IS FALSE, C .IFDF A = 10 IS TRUE. C THE RELATIONAL OPERATORS MAY BE JOINED WITH THE & OPERATOR. THE OR C MAY NOT BE MIXED WITH RELATIONALS AT THIS TIME. C C .NOTRANSLATE, .TRANSLATE DIRECTIVES C C IF THE PROGRAM CONTAINS TEXT WHICH THIS PREPROCESSOR C MIGHT INCORRECTLY MODIFY (SUCH AS COMPASS SOURCE FOR C THE CDC), THE .NOTRANSLATE DIRECTIVE MAY BE USED TO C SKIP ALL SCANNING OF THE LINES, EXCEPT FOR DIRECTIVES. C THIS SKIPPING IS TURNED OFF BY ISSUING A .TRANSLATE C DIRECTIVE TO RESUME NORMAL PREPROCESSING. C C .ERROR DIRECTIVE C C IF THIS STATEMENT IS ENCOUNTERED, A MESSAGE IS DISPLAYED C AT THE TERMINAL, PRINTING THE ERROR DIRECTIVE. THIS IS C USEFUL IS SOME CONFLICTING SITUATION MUST BE FLAGGED. C TRANSLATION CONTINUES AFTER THE MESSAGE, WITHOUT ANY C EFFECT ON THE TRANSLATED CODE. THE MESSAGE MAY BE ADDED C AFTER THE WORD ERROR. FOR EXAMPLE, C .ERROR PARAMETER 'NTOTAL' MUST BE SET TO A LARGER NUMBER C C C SYMBOL TABLE C C A SORTED SYMBOL TABLE IS PRINTED AT THE END OF EACH MODULE. C ALL VARIABLES AND DEFINED SYMBOLS ARE LISTED, AS WELL AS A LIST C OF WHICH LINE NUMBERS THEY WERE USED. NOTE THAT IF THE .INCLUDE C FACILITY IS USED, THERE IS SOME AMBIGUITY AS TO WHICH LINE IS C REFERRED TO BY THE LINE NUMBER. SINCE THIS PROGRAM DOES NOT FULLY C PARSE EACH FORTRAN STATEMENT, IT WILL REJECT ALL VARIABLE NAMES C WHICH ARE RESERVED FORTRAN STATEMENTS, SUCH AS WRITE, REAL, ETC. C SUCH NAMES MAY BE VALID IN THE PROGRAM, HOWEVER THEY WILL NOT C APPEAR IN THE SYMBOL TABLE. AS A RULE, ONE SHOULD AVOID RESERVED C NAMES IN ANY CASE. C C RESTRICTIONS: C C 1. USE OF FORTRAN-77 IF-THEN-ELSE CONSTRUCTS ON TOP OF THE PREPROCESSOR'S C CONSTRUCTS CAN BE CONFUSING, AND ALTHOUGH LEGAL, SHOULD BE AVOIDED. C C 2. EXTENDED FORTRAN STATEMENTS MAY NOT DIRECTLY FOLLOW ANOTHER EXTENDED C STATEMENT, THEY MUST BE ENCLOSED IN BRACKETS. THIS IS ALSO TRUE C FOR READ/WRITE STATEMENTS WITH UNNUMBERED FORMATS. C C 3. LONG NAMES MAY NOT BE SPLIT ACROSS LINES; THEY MUST BE COMPLETE C ON EACH LINE. QUOTED STRINGS MAY NOT BE SPLIT ACROSS LINES. C C 4. THE KEYWORDS "FOR", "THEN", "ELSE", "WHILE", "REPEAT", "UNTIL", "ELSEIF", C AND "IFF" ARE RESERVED AND MAY NOT BE USED FOR VARIABLE NAMES. C C 5. VARIABLES WHOSE NAMES ARE THE SAME AS LEGAL FORTRAN STATEMENTS WILL C NOT APPEAR IN THE SYMBOL TABLE. C C 6. LONG NAMES OR DEFINED SYMBOLS IN DIRECT ACCESS READS OR WRITES ARE C NOT RECOGNIZED BECAUSE TEXT IN QUOTES IS NOT RECOGNIZED. C (READ (1'2) NOT_RECOGNIZED). C C 7. FORMAT STATEMENTS AND OPEN AND CLOSE STATEMENTS ARE NOT SCANNED C IN THE SAME WAY AS OTHERS, BECAUSE OF THE FUNNY SYNTAX. C NAMES WHICH HAVE A SUBSTITUTION VALUE, SUCH AS DEFINED VALUES C AND PREVIOUSLY DEFINED LONGNAMES, WILL BE CORRECTLY SUBSTITUTED C FOR. HOWEVER NEW LONGNAMES WILL NOT BE TRANSLATED, NOR WILL C NEW NAMES APPEAR IN THE SYMBOL TABLE. IF YOU C DEFINE A SYMBOL TO BE A FORMAT STATEMENT, THE FORMAT SPECIFIERS C MAY APPEAR IN THE SYMBOL TABLE. DO NOT ADD ! COMMENTS TO THE C END OF FORMAT STATEMENTS. C C C C C LUN ASSIGNMENTS: C 1 => PRIMARY INPUT FILE (TAPE1 OR NAME ON LGO CARD) C 2 => SECONDARY INPUT FILE (FILENAME2) C 3 => TERTIARY INPUT FILE (FILENAME3) !BOTH FROM .INCLUDE DIRECTIVES C 4 => OUTPUT SOURCE FILE (TAPE4) C 5 => OUTPUT FOR ERROR MESSAGES C 6 => OUTPUT LISTING FILE (TAPE6 OR NAME ON LGO CARD) C C PROGRAM FTEV5 INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE SPACE(5), PART(10) INTEGER POSN, POSN1 DATA SPACE / 5*' ' / C C GET COMMAND LINE AND OPEN THE THREE FILES NEEDED C CALL INIT NEXTNO = 30000 C C AT END OF EACH INPUT MODULE, CHECK FOR PENDING CLAUSES C 100 IF (STATNO .GT. 1) GO TO 120 IF (STKPTR .GT. 0) WRITE (5,110) LINENO 110 FORMAT (' FTE -- Unbalanced brackets before line', I6) NEXTNO = 30000 !END OF PROGRAM, RESET THINGS STKPTR = 0 !EMPTY STACK C C READ INPUT LINE AND DECIDE WHAT TO DO WITH IT C 120 CALL READLN (POSN, ICONT) !GET NEXT INPUT LINE 140 IF (LINE(1) .EQ. "56) GO TO 450 !DIRECTIVE STATEMENT IF (LINE(POSN) .EQ. "175) GO TO 2000 !"}" MEANS END OF CLAUSE POSN1 = POSN !SAVE POSITION OF BEGINNING OF LINE CALL KEYWD (POSN, WORD) !GET NEXT KEY WORD LEWORD = LENGTH (WORD) C C DO NOT PARSE FORMAT, OPEN OR CLOSE STATEMENTS C IF (LEWORD .NE. 4) GO TO 160 CALL STRCMP (I1, WORD, 'OPEN') IF (I1 .EQ. 0) GO TO 170 160 IF (LEWORD .NE. 5) GO TO 162 CALL STRCMP (I1, WORD, 'CLOSE') IF (I1 .EQ. 0) GO TO 170 162 IF (LEWORD .NE. 6) GO TO 180 CALL STRCMP (I1, WORD, 'FORMAT') IF (I1 .NE. 0) GO TO 180 C 170 NONEW = .TRUE. !DONT ADD NEW ENTRIES TO TABLE CALL LONGNA (POSN) !TRANSLATE ANY DEFININITION WRITE (4,10300) (LINE(J), J=1,LEN) 175 IF (LEN .LE. 80) GO TO 178 WRITE (5,176) LINENO 176 FORMAT (' FTE -- Line may exceed 80 characters, at line', I6) IF (IPRINT .AND. LLIST) 1 WRITE (6,177) LINENO 177 FORMAT (' *** LINE MAY EXCEED 80 CHARACTERS, AT LINE', I6) 178 CALL READLN (POSN, ICONT) !LOOK FOR CONTINUATION LINES IF (ICONT .NE. 0) GO TO 170 NONEW = .FALSE. GO TO 140 C C PARSE THE LINE FOR THE SYMBOL TABLE, IF NOT ALREADY DONE C 180 NONEW = .FALSE. IF (ISCAN .EQ. 0) CALL LONGNA (POSN1) !ENTER SYMBOLS IN TABLE ISCAN = 1 C C LOOK FOR EXTENDED STATEMENTS C IF (LEWORD .NE. 3) GO TO 200 CALL STRCMP (I1, WORD, 'IFF') IF (I1 .EQ. 0) GO TO 500 !IFF STMT CALL STRCMP (I1, WORD, 'FOR') IF (I1 .EQ. 0) GO TO 1700 !FOR STMT C 200 IF (LEWORD .NE. 4) GO TO 210 CALL STRCMP (I1, WORD, 'THEN') IF (I1 .EQ. 0) GO TO 1000 !THEN STMT C 210 IF (LEWORD .NE. 5) GO TO 220 CALL STRCMP (I1, WORD, 'WHILE') IF (I1 .EQ. 0) GO TO 1200 !WHILE STMT C 220 IF (LEWORD .NE. 6) GO TO 240 CALL STRCMP (I1, WORD, 'REPEAT') IF (I1 .EQ. 0) GO TO 1500 !REPEAT STMT C C REGULAR FORTRAN STATEMENT C 240 CALL FMT (NEXTNO, IFMT) !CHECK FOR UNLABEL FMT IF (IFMT .NE. 0) GO TO 400 WRITE (4,10300) (LINE(J), J=1,LEN) !NORMAL FORTRAN STATEMENT C C CHECK FOR END STATEMENT - IF SO PRINT SYMBOL TABLE AND RESET IT C IF (LEWORD .NE. 3) GO TO 100 CALL STRCMP (I1, WORD, 'END') IF (I1 .NE. 0) GO TO 100 IF (ITABLE) CALL PRINTX !PRINT SYMBOL TABLE CALL LONGNA (0) !RESET SYMBOL TABLE IENDED = 1 !TELL READLN END SEEN STATNO = 1 !RESET STMT COUNTER GO TO 100 C C HANDLE UNLABELLED FORMAT STATEMENT. C TRANSLATE CONTINUATION LINES OF READ/WRITE, C THEN ADD STATEMENT NUMBER TO FOLLOWING (FORMAT) STATEMENT, C THIS TIME NOT ADDING ANY NEW NAMES TO SYMBOL TABLE. C 400 WRITE (4,10300) (LINE(J), J=1,LEN) CALL READLN (POSN, ICONT) IF (ICONT .EQ. 0) GO TO 420 CALL LONGNA (POSN) GO TO 400 C 420 NONEW = .TRUE. !DO NOT ADD NEW NAMES TO SYMBOL TABLE CALL LONGNA (POSN) !TRANSLATE LONG NAMES WRITE (4,440) NEXTNO, (LINE(J), J=POSN,LEN) 440 FORMAT (I5, 1X, 130A1) NEXTNO = NEXTNO + 1 GO TO 175 !LOOK FOR CONTINUATIONS C C DIRECTIVE STATEMENT C 450 CALL DIRCTV GO TO 120 C C IFF STATEMENT C 500 M = MIN0(POSN1-1,5) !INCLUDE STMT LABEL IF THERE IS ONE WRITE (4,10400) (LINE(J),J=1,M), (SPACE(J),J=1,6-M) DO 520 J=1,POSN-1 !REMOVE IFF 520 LINE(J) = "40 LINE(1) = "11 LINE(2) = "61 STATNO = STATNO + 1 CALL COPYNX (POSN) !COPY REST OF IF(.NOT. (...) ) WRITE (4,10200) NEXTNO CALL PUSH (NEXTNO, 1) !PUSH THEN ADR NEXTNO = NEXTNO + 1 700 CALL KEYWD (POSN, WORD) !LOOK FOR THEN STMT IF (LENGTH(WORD) .NE. 4) GO TO 900 CALL STRCMP (I1, WORD, 'THEN') IF (I1 .NE. 0) GO TO 900 800 CALL SKIP (POSN) IF (LINE(POSN) .EQ. "173) GO TO 100 CALL READNX (POSN, ICONT) IF (LINE(POSN) .EQ. "173) GO TO 100 CALL COPYNX (POSN) !SIMPLE THEN CLAUSE CALL POP (N, ITYPE) !PRETEND RIGHT BRACKET APPEARED GO TO 2600 !TREAT END OF THEN CLAUSE 900 WRITE (5,920) LINENO 920 FORMAT (' FTE -- Missing then-clause at line', I4) CALL POP (N, ITYPE) GO TO 140 C C THEN STMT WITHOUT PRECEEDING IFF - FOR COMPATABILITY WITH V04 C 1000 WRITE (4,10600) NEXTNO !1 GO TO N WRITE (4,10100) NEXTNO + 1 ! GO TO N+1 WRITE (4,10000) NEXTNO !N CONTINUE CALL PUSH (NEXTNO+1, 1) NEXTNO = NEXTNO + 2 STATNO = STATNO + 1 GO TO 800 !LOOK FOR CLAUSE C C WHILE STATEMENT C 1200 WRITE (4,10000) NEXTNO !N CONTINUE M = MIN0(POSN1-1,5) !INCLUDE STMT LABEL IF THERE IS ONE WRITE (4,10400) (LINE(J),J=1,M), (SPACE(J),J=1,6-M) DO 1220 J=1,POSN-1 !REMOVE WHILE 1220 LINE(J) = "40 LINE(1) = "11 LINE(2) = "61 STATNO = STATNO + 2 CALL COPYNX (POSN) !COPY REST OF IF(.NOT. (...) ) WRITE (4,10200) NEXTNO + 1 ! 1 GO TO N+1 CALL PUSH (NEXTNO, 3) CALL PUSH (NEXTNO+1, 3) NEXTNO = NEXTNO + 2 STATNO = STATNO + 1 IF (LINE(POSN) .EQ. "173) GO TO 100 CALL COPYNX (POSN) !SIMPLE WHILE CLAUSE CALL POP (N, ITYPE) CALL POP (N2, ITYPE) WRITE (4,10100) N2 !GO TO N WRITE (4,10000) N !N+2 CONTINUE STATNO = STATNO + 1 GO TO 140 C C REPEAT STATEMENT C 1500 WRITE (4,10000) NEXTNO !N CONTINUE M = MIN0(POSN1-1,5) IF (LINE(1) .NE. "11) * WRITE (4,10500) (LINE(J),J=1,M), (SPACE(J),J=1,6-M) IF (LINE(1) .NE. "11) STATNO = STATNO + 1 CALL PUSH (NEXTNO, 4) NEXTNO = NEXTNO + 1 CALL SKIP (POSN) IF (LINE(POSN) .EQ. "173) GO TO 100 CALL READNX (POSN, ICONT) IF (LINE(POSN) .EQ. "173) GO TO 100 !REGULAR REPEAT CLAUSE CALL COPYNX (POSN) !SIMPLE REPEAT CLAUSE CALL POP (N, ITYPE) !LOOK FOR UNTIL STMT GO TO 4050 C C FOR STATEMENT C 1700 CALL SUBSTR (WORD, LINE, 1, POSN-4) !BEGINNING OF LINE CALL CONCAT (WORD, 'DO ') ENCODE (5, 1750, PART) NEXTNO 1750 FORMAT (I5) PART(6) = 0 CALL CONCAT (WORD, PART) !INSERT LABEL NUMBER CALL CONCAT (WORD, LINE(POSN)) !COPY REST OF LINE CALL STRING (LINE, WORD) !COPY WORD INTO LINE LEN = LEN + 5 CALL PUSH (NEXTNO, 5) NEXTNO = NEXTNO + 1 CALL COPYNX (POSN) !COPY DO N ... IF (LINE(POSN) .EQ. "173) GO TO 100 !NORMAL FOR CLAUSE CALL COPYNX (POSN) !SIMPLE FOR CLAUSE CALL POP (N, ITYPE) WRITE (4,10000) N !N CONTINUE STATNO = STATNO + 1 GO TO 140 C C CLOSING BRACE - END OF A CLAUSE C 2000 CALL POP (N, ITYPE) IF (ITYPE .EQ. 1 .OR. ITYPE .EQ. 6) GO TO 2500 !IFF OR ELSEIF IF (ITYPE .EQ. 2) GO TO 3400 !ELSE IF (ITYPE .EQ. 3) GO TO 3500 !WHILE IF (ITYPE .EQ. 4) GO TO 4000 !REPEAT IF (ITYPE .EQ. 5) GO TO 4800 !FOR GO TO 100 !ERROR MSG PRINTED BY POP C C END OF THEN CLAUSE - LOOK FOR ELSE OR ELSEIF C 2500 CALL READNX (POSN, ICONT) 2600 POSN1 = POSN CALL KEYWD (POSN, WORD) IF (LENGTH(WORD) .NE. 4) GO TO 2800 CALL STRCMP (I1, WORD, 'ELSE') IF (I1 .NE. 0) GO TO 2800 IF (ITYPE .EQ. 6) GO TO 2700 !ELSE FOLLOWING ELSEIF CHAIN CALL PUSH (NEXTNO, 2) !ELSE CLAUSE FOLLOWS WRITE (4,10100) NEXTNO NEXTNO = NEXTNO + 1 2620 WRITE (4,10000) N STATNO = STATNO + 1 CALL SKIP (POSN) IF (LINE(POSN) .EQ. "173) GO TO 100 CALL READNX (POSN, ICONT) IF (LINE(POSN) .EQ. "173) GO TO 100 CALL COPYNX (POSN) !SIMPLE ELSE CLAUSE CALL POP (N, ITYPE) 2660 WRITE (4,10000) N !END OF ELSE CLAUSE STATNO = STATNO + 1 GO TO 140 C 2700 CALL POP (N2, ITYPE) !ELSE FOLLOWING ELSEIF CHAIN CALL PUSH (N2, ITYPE) WRITE (4,10100) N2 GO TO 2620 C C ELSEIF STATEMENT C 2800 IF (LENGTH(WORD) .NE. 6) GO TO 2950 CALL STRCMP (I1, WORD, 'ELSEIF') IF (I1 .NE. 0) GO TO 2950 IF (ITYPE .EQ. 6) GO TO 2900 !INSIDE STRING OF ELSEIF'S WRITE (4,10100) NEXTNO !FIRST ELSEIF CALL PUSH (NEXTNO, 2) !MARK FIRST AS ELSE NEXTNO = NEXTNO + 1 2820 WRITE (4,10000) N STATNO = STATNO + 1 M = MIN0(POSN1-1,5) WRITE (4,10400) (LINE(J),J=1,M), (SPACE(J),J=1,6-M) DO 2830 J=1,POSN-1 2830 LINE(J) = "40 LINE(1) = "11 LINE(2) = "61 STATNO = STATNO + 1 CALL COPYNX (POSN) !COPY IF(.NOT. (...) ) WRITE (4,10200) NEXTNO CALL PUSH (NEXTNO, 6) !MARK AS ELSEIF NEXTNO = NEXTNO + 1 STATNO = STATNO + 1 GO TO 700 !TREAT THEN CLAUSE C 2900 CALL POP (N2, ITYPE) !SUBSEQUENT ELSEIF CALL PUSH (N2, ITYPE) !MAINTAIN COMMON END ADR WRITE (4,10100) N2 GO TO 2820 C 2950 POSN = POSN1 IF (ITYPE .EQ. 1) GO TO 2660 CALL POP (N2, ITYPE) !ELSEIF ENDED BY THEN ONLY WRITE (4,10000) N !BRANCH OF LAST IF(.NOT. WRITE (4,10000) N2 !COMMON END POINT STATNO = STATNO + 2 GO TO 140 C C END OF ELSE CLAUSE C 3400 WRITE (4,10000) N !N+2 CONTINUE STATNO = STATNO + 1 GO TO 100 C C END OF WHILE CLAUSE C 3500 CALL POP (N2, ITYPE) WRITE (4,10100) N2 ! GO TO N WRITE (4,10000) N !N+2 CONTINUE STATNO = STATNO + 2 GO TO 120 C C END OF REPEAT CLAUSE C 4000 LINE(POSN) = "40 !BLANK OUT "}" CALL SKIP (POSN) STATNO = STATNO + 1 !IN CASE UNTIL FOLLOWS "}" IF (POSN .GT. LEN .OR. LINE(POSN) .EQ. "41) GO TO 4500 4050 IF (ISCAN .EQ. 0) CALL LONGNA (POSN) 4055 POSN1 = POSN CALL KEYWD (POSN, WORD) IF (LENGTH(WORD) .NE. 5) GO TO 4060 CALL STRCMP (I1, WORD, 'UNTIL') IF (I1 .EQ. 0) GO TO 4080 !UNTIL CLAUSE 4060 STATNO = STATNO + 1 !NO UNTIL CLAUSE WRITE (4,10100) N ! GO TO N POSN = POSN1 GO TO 140 C C UNTIL STATEMENT FOLLOWING REPEAT CLAUSE C 4080 M = MIN0(POSN1-1,5) WRITE (4,10400) (LINE(J),J=1,M), (SPACE(J),J=1,6-M) DO 4100 J=1,POSN-1 4100 LINE(J) = "40 LINE(1) = "11 LINE(2) = "61 STATNO = STATNO + 1 CALL COPYNX (POSN) !COPY IF(.NOT. (...) ) WRITE (4,10200) N STATNO = STATNO + 1 GO TO 140 4500 CALL READNX (POSN, ICONT) !UNTIL ON NEXT LINE STATNO = STATNO - 1 !READNX ALREADY COUNTED UNTIL GO TO 4055 C C END OF FOR CLAUSE C 4800 WRITE (4,10000) N !N CONTINUE STATNO = STATNO + 1 GO TO 100 C C C FORMAT STATEMENTS C 10000 FORMAT (I5, ' CONTINUE') 10100 FORMAT (' GO TO', I6) 10200 FORMAT (' 1 )GO TO', I6) 10300 FORMAT (130A1) 10400 FORMAT (6A1, 'IF(.NOT.') 10500 FORMAT (6A1, 'CONTINUE') 10600 FORMAT (' 1 GO TO', I6) END SUBROUTINE INIT C C INITIALIZES ALL LISTS - CALLED AT BEGINNING ONLY. C OPENS INPUT AND OUTPUT FILES, SETS UP FIRST TITLE LINE. C C NOTE FOR THE VAX VERSION, THE "CHARACTER" DECLARATION NEAR C THE TOP SHOULD BE UNCOMMENTED, AS SHOULD THE VAX CODE FOR C GETTING THE COMMAND LINE, AND THE CORRESPONDING RSX CODE C SHOULD BE COMMENTED. IN ADDITION, THE KEYWORD "ACCEPT" C SHOULD BE REPLACED WITH "CHARACTER" FOR THE VAX VERSION. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE RESNAM(12,52) INTEGER RESLEN(52) COMMON /RESERV/ RESLEN COMMON /RESERC/ RESNAM C C THIS LINE FOR VAX ONLY - COMMENT OUT FOR RSX-11M C C CHARACTER LINCHR*80 C C INITIALIZE LISTS AND GLOBAL VARIABLES C LAVAIL = 0 NAVAIL = 0 MAVAIL = 0 STATNO = 1 LINENO = 0 STKPTR = 0 LINECT = 0 PAGENO = 0 INPUT = 1 NOTRAN = .FALSE. !TRUE IF .NOTRANSLATE IN EFFECT LLIST = .TRUE. !TURE IF .LIST IS IN EFFECT LCOND = .TRUE. !TRUE IF .CONDLIST IS IN EFFECT LCOMM = .FALSE. !TRUE IF COMMENTS TO BE PASSED TO OUTPUT FILE IGNORE = .FALSE. !TRUE IF IN UNSATISFIED .IFDF IPRINT = .FALSE. !TRUE IF PRODUCING A LISTING FILE ITABLE = .FALSE. !TRUE IF GENERATING CROSS REF TABLE NONEW = .FALSE. !TRUE IF NEW LONGNAMES NOT TO BE ENTERED IN TREE ICONDP = 1 ICOND(1) = .TRUE. !IMPLIED .IFDF .TRUE. AT BEGINNING C C DEFINE RESERVED NAMES HERE UNTIL I FIGURE OUT HOW TO USE A LONG DATA STMT C CALL STRING (RESNAM(1,1), 'VIRTUAL') CALL STRING (RESNAM(1,2), 'BACKSPACE') CALL STRING (RESNAM(1,3), 'BLOCK') CALL STRING (RESNAM(1,4), 'CALL') CALL STRING (RESNAM(1,5), 'COMMON') CALL STRING (RESNAM(1,6), 'CONTINUE') CALL STRING (RESNAM(1,7), 'DATA') CALL STRING (RESNAM(1,8), 'DECODE') CALL STRING (RESNAM(1,9), 'DEFINE') CALL STRING (RESNAM(1,10), 'DIMENSION') CALL STRING (RESNAM(1,11), 'DO') CALL STRING (RESNAM(1,12), 'ENCODE') CALL STRING (RESNAM(1,13), 'END') CALL STRING (RESNAM(1,14), 'ERR') CALL STRING (RESNAM(1,15), 'ENTRY') CALL STRING (RESNAM(1,16), 'EQUIVALENCE') CALL STRING (RESNAM(1,17), 'EXTERNAL') CALL STRING (RESNAM(1,18), 'FIND') CALL STRING (RESNAM(1,19), 'FORMAT') CALL STRING (RESNAM(1,20), 'FUNCTION') CALL STRING (RESNAM(1,21), 'FILE') CALL STRING (RESNAM(1,22), 'GO') CALL STRING (RESNAM(1,23), 'IF') CALL STRING (RESNAM(1,24), 'IMPLICIT') CALL STRING (RESNAM(1,25), 'PAUSE') CALL STRING (RESNAM(1,26), 'PRINT') CALL STRING (RESNAM(1,27), 'PROGRAM') CALL STRING (RESNAM(1,28), 'READ') CALL STRING (RESNAM(1,29), 'RETURN') CALL STRING (RESNAM(1,30), 'REWIND') CALL STRING (RESNAM(1,31), 'STOP') CALL STRING (RESNAM(1,32), 'SUBROUTINE') CALL STRING (RESNAM(1,33), 'TYPE') CALL STRING (RESNAM(1,34), 'WRITE') CALL STRING (RESNAM(1,35), 'INTEGER') CALL STRING (RESNAM(1,36), 'LOGICAL') CALL STRING (RESNAM(1,37), 'REAL') CALL STRING (RESNAM(1,38), 'DOUBLE') CALL STRING (RESNAM(1,39), 'PRECISION') CALL STRING (RESNAM(1,40), 'BYTE') CALL STRING (RESNAM(1,41), 'TO') CALL STRING (RESNAM(1,42), 'THEN') CALL STRING (RESNAM(1,43), 'ELSE') CALL STRING (RESNAM(1,44), 'REPEAT') CALL STRING (RESNAM(1,45), 'UNTIL') CALL STRING (RESNAM(1,46), 'FOR') CALL STRING (RESNAM(1,47), 'WHILE') CALL STRING (RESNAM(1,48), 'COMPLEX') CALL STRING (RESNAM(1,49), 'IFF') CALL STRING (RESNAM(1,50), 'ELSEIF') CALL STRING (RESNAM(1,51), 'OPEN') CALL STRING (RESNAM(1,52), 'CLOSE') DO 10 J=1,52 10 RESLEN(J) = LENGTH(RESNAM(1,J)) C C GET COMMAND LINE AND SET UP FILES - RSX-11M SPECIFIC C CALL GETMCR (CMDLIN, IDS) IF (IDS .LE. 0) CALL EXIT CMDLIN(IDS+1) = 0 CMDLEN = IDS IF (CMDLEN .LE. 0) CALL EXIT CALL ASNLUN (1, 'SY', 0) CALL ASNLUN (2, 'SY', 0) CALL ASNLUN (3, 'SY', 0) CALL ASNLUN (4, 'SY', 0) CALL ASNLUN (6, 'SY', 0) C C GET COMMAND LINE - VAX SPECIFIC C C IDS = LIB$GET_FOREIGN( LINCHR, 'FTE> ', CMDLEN ) C IF (IDS .NE. 1) CALL EXIT C IF (CMDLEN .LE. 0) CALL EXIT C DO 30 J=1,CMDLEN !CONVERT TO BYTE STRING C30 CMDLIN(J) = ICHAR(LINCHR(J:J)) C CMDLIN(CMDLEN+1) = 0 C C MAKE UP THE REQUIRED FILE NAMES COMPLETE WITH EXTENSIONS C IF (CMDLIN(CMDLEN-2) .NE. "57) GO TO 50 IF (CMDLIN(CMDLEN-1) .EQ. "103) ITABLE = .TRUE. !TABLE REQUESTED BY /CR IPRINT = .TRUE. !LISTING REQUESTED BY /CR OR /LI CMDLEN = CMDLEN-3 CMDLIN(CMDLEN+1) = 0 !REMOVE /CR 50 CALL INDEXC (ISTART, ' ', CMDLIN) !REMOVE "FTE" FROM BEGINNING ISTART = ISTART+1 CALL STRING (TITLE, CMDLIN(ISTART)) CALL CONCAT (TITLE, '.FTE') OPEN (UNIT=1, NAME=TITLE, TYPE='OLD', READONLY, ERR=600) CALL STRING (TITLE, CMDLIN(ISTART)) CALL CONCAT (TITLE, '.TMP') OPEN (UNIT=4, NAME=TITLE, TYPE='NEW', CARRIAGECONTROL='LIST') CALL STRING (TITLE, CMDLIN(ISTART)) CALL CONCAT (TITLE, '.LST') IF (IPRINT) OPEN (UNIT=6, NAME=TITLE, TYPE='NEW') C C GET FIRST LINE OF SOURCE FILE FOR HEADER TITLE C 500 READ (1,550,ERR=600) LEN, LINE 550 FORMAT (Q,130A1) LINE(LEN+1) = 0 K = 1 IF (LINE(1) .EQ. "103) K = 2 !SKIP COMMENT MARKER CALL SKIP (K) CALL STRING (TITLE, LINE(K)) !COPY TITLE REWIND 1 CALL HEADER RETURN C C ERROR IN OPENNING MAIN INPUT FILE C 600 WRITE (5,620) (CMDLIN(K), K=ISTART,CMDLEN) 620 FORMAT (' FTE -- Unable to open input file ', 82A1) CALL EXIT END SUBROUTINE READNX (POSN, ICONT) C C READS THE NEXT LINE FROM THE INPUT FILE, AND ALSO CALLS LONGNA. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM INTEGER POSN 10 CALL READLN (POSN, ICONT) IF (LINE(1) .EQ. "56) GO TO 20 !!DIRECTIVE CALL LONGNA (POSN) !ENTER SYMBOLS RETURN 20 CALL DIRCTV !OPERATE ON DIRECTIVE GO TO 10 END SUBROUTINE COPYNX (POSN) C C WRITES THE LINE CURRENTLY IN , READS THE NEXT INPUT LINE C VIA READNX, AND CONTINUES TO WRITE UNTIL A NON-CONTINUATION C LINE IS REACHED. POSN IS SET AS BY READLN. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM INTEGER POSN C 10 WRITE (4,20) (LINE(K),K=1,LEN) 20 FORMAT (130A1) CALL READNX (POSN, ICONT) IF (ICONT .NE. 0) GO TO 10 RETURN END SUBROUTINE READLN (POSN, ICONT) C C READS A LINE FROM THE SOURCE FILE, AND PRINTS IT IN LISTING FILE. C LINES STARTING WITH "{", "}", AND CONTINUATION LINES, DO NOT HAVE C STATEMENT NUMBERS WRITTEN, NOR IS STATNO INCREMENTED. C IF IT IS A COMMENT LINE, ANOTHER LINE IS FETCHED. THE LINE IS IS C "LINE", AND ITS LENGTH IS "LEN", WHICH ARE IN COMMON. "STATNO" KEEPS C TRACK OF THE FORTRAN STATEMENT NUMBER, WHILE "LINENO" KEEPS TRACK OF C THE SOURCE FILE LINE NUMBER. THE ARGUMENT "POSN" IS SET THE THE FIRST C NON-BLANK NON-TAB CHARACTER OF THE FIRST NON-COMMENT LINE. C ICONT IS SET IF IT IS A CONTINUATION LINE. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM INTEGER POSN BYTE NUMBER(10), CHAR LOGICAL TF DATA IENDED /0/ DATA NUMBER / '0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ C ISCAN = 0 !MARK LINE NOT YET SCANNED BY LONGNA C C READ NEXT LINE FROM CURRENT INPUT FILE C 10 LINENO = LINENO + 1 ICONT = 0 READ (INPUT, 15, END=200) LEN, LINE 15 FORMAT (Q, 130A1) LEN = MIN0(LEN,129) LINE(LEN+1) = 0 !MARK END OF VARIABLE LENGTH STRING IF (IENDED .EQ. 0) GO TO 20 POSN = 1 !SAVE TITLE FOR HEADER IF (LINE(1) .EQ. "103 .OR. LINE(1) .EQ. "143) POSN = 2 CALL SKIP (POSN) CALL STRING (TITLE, LINE(POSN)) 20 IF (IENDED .NE. 0 .OR. LINECT .GE. 54) CALL HEADER IENDED = 0 C C FORM INDIRECTION INDICATOR FOR LISTING C IND1 = "40 IND2 = "40 !ASSUME NONE IF (INPUT .GT. 1) IND1 = "56 IF (INPUT .GT. 1) IND2 = NUMBER(INPUT) IF (IGNORE) IND1 = "55 C C CHECK FOR SPECIAL STATEMENTS C IF (LEN .LE. 0) GO TO 60 !NULL LINE IF (LINE(1) .EQ. "103 .OR. LINE(1) .EQ. "143) GO TO 55 !COMMENT IF (LINE(1) .EQ. "56) RETURN !DIRECTIVE IF (IGNORE .OR. NOTRAN) GO TO 60 !IGNORED TEXT POSN = 2 IF (LINE(1) .EQ. "11 .AND. LINE(2) .GE. "60 * .AND. LINE(2) .LE. "71) GO TO 80 !CONTINUATION IF (LINE(1) .NE. "11) GO TO 100 !NOT A LEADING TAB POSN = 1 25 DO 30 J=POSN,LEN !SKIP LEADING BLANKS IF (LINE(J) .NE. "40 .AND. LINE(J) .NE. "11) GO TO 40 30 CONTINUE GO TO 60 !BLANK LINE C C FIRST NON-BLANK CHARACTER REACHED C 40 POSN = J CHAR = LINE(POSN) IF (CHAR.EQ."173.OR. CHAR.EQ."175) GO TO 90 ! { OR } IF (CHAR .EQ. "41) GO TO 60 ! "!" TYPE COMMENT C C PRINT LINE IN LISTING FILE C IF (IPRINT .AND. LLIST) 1 WRITE (6,50) LINENO, IND1, IND2, STATNO, (LINE(J), J=1,LEN) 50 FORMAT (1X, I4, 2A1, I4, 6X, 130A1) IF (IPRINT .AND. LLIST) LINECT = LINECT + 1 STATNO = STATNO + 1 IF (CHAR .NE. "111 .AND. CHAR .NE. "151) RETURN IF ((LINE(POSN+1) .EQ. "106 .OR. LINE(POSN+1) .EQ. "146) * .AND. (LINE(POSN+2) .EQ. "40 .OR. LINE(POSN+2) .EQ. "50)) * STATNO = STATNO + 1 !DEC FTN COUNTS IF AS TWO STMTS RETURN C C COMMENT LINE, IGNORED TEXT, OR .NOTRANSLATE TEXT C 55 IF (LCOMM) WRITE (4,75) (LINE(J),J=1,LEN) !PASS COMMENT LINES 60 TF = IPRINT .AND. LLIST .AND. (LCOND .OR. .NOT. IGNORE) IF (TF) WRITE (6,70) LINENO, IND1, IND2, (LINE(J), J=1,LEN) 70 FORMAT (1X, I4, 2A1, 10X, 130A1) IF (TF) LINECT = LINECT + 1 IF (.NOT. NOTRAN) GO TO 10 WRITE (4,75) (LINE(J), J=1,LEN) !PRINT LINE VERBATIM FOR .NOTRANSLATE 75 FORMAT (130A1) STATNO = STATNO + 1 GO TO 10 C C CONTINUATION LINE OR SPECIAL EXTENDED STATEMENT C 80 ICONT = 1 !MARK AS CONTINUATION LINE POSN = POSN+1 !SKIP CONTINUATION CHARACTER CALL SKIP (POSN) !SKIP TO NEXT NON-BLANK 90 IF (IPRINT .AND. LLIST) 1 WRITE (6,50) LINENO, IND1, IND2, STATNO, (LINE(J), J=1,LEN) IF (IPRINT .AND. LLIST) LINECT = LINECT + 1 RETURN C C LABEL FIELD NOT EMPTY - CHECK FOR CONTINUATION, REG LABEL OR ORPHAN LABEL. C ALSO USED IF FIVE OR SIX LEADING BLANKS INSTEAD OF TAB. C 100 POSN = 1 CALL SKIP (POSN) IF (POSN .GT. LEN) GO TO 60 !NULL LINE IF (POSN .GE. 7) GO TO 25 !LEADING BLANKS IF (POSN .EQ. 6) GO TO 80 !CONTINUATION K = POSN DO 120 POSN=K,LEN !LOOK FOR END OF STMT LABEL IF (LINE(POSN) .EQ. "40 .OR. LINE(POSN) .EQ. "11) GO TO 25 120 CONTINUE C C STATEMENT HAS LABEL FIELD ONLY WITH NO TRAILING BLANKS - ADD CONTINUE C IF (IPRINT .AND. LLIST) * WRITE (6,50) LINENO, IND1, IND2, STATNO, (LINE(J), J=1,LEN) IF (IPRINT .AND. LLIST) LINECT = LINECT + 1 CALL CONCAT (LINE, ' CONTINUE') WRITE (4,75) (LINE(J),J=1,LENGTH(LINE)) STATNO = STATNO + 1 GO TO 10 C C END OF INPUT FILE C 200 IF (INPUT .EQ. 1) GO TO 220 !END OF MAIN FILE CLOSE (UNIT=INPUT) !END OF INDIRECT FILE INPUT = INPUT - 1 LINENO = LINETP(INPUT) !RESTORE PREVIOUS LINE NUMBERING GO TO 10 C C OUR JOB IS NOW DONE C C C RSX-11M SPECIFIC TO THIS SITE - PREVENT FORTRAN CARRIAGE C CONTROL INTERPRETATION ON OUTPUT - JUST A PRETTY. C C220 CALL GETFDB (4, 0, IRTYP) !CHANGE LUN 4 FDB TO FD.CR C IRTYP = IOR( IAND( IRTYP, "177377), "1000 ) C CALL PUTFDB (4, 0, IRTYP) C 220 IF (STKPTR .LE. 0) CALL EXIT !SEE IF STACK EMPTY WRITE (5,240) LINENO 240 FORMAT (' FTE -- Unbalanced brackets before line', I6) CALL EXIT END SUBROUTINE DIRCTV C C PROCESSES PREPROCESSOR DIRECTIVE LINES C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM INTEGER POSN LOGICAL IFDF, LRESUL, LRESU2 BYTE COR, CAND, CEX, CLT, CEQ, CGT DATA COR, CAND, CEX, CLT, CEQ, CGT / '|', '&', '!', '<', '=', '>' / C C C .PAGE DIRECTIVE C CALL STRCMP (I1, LINE(2), 'PAGE') IF (I1 .NE. 0) GO TO 10 IF (.NOT. IGNORE .AND. LLIST) CALL HEADER RETURN C C PRINT DIRECTIVE (EXCEPT .PAGE) IN LISTING FILE C 10 LRESUL = IPRINT .AND. LLIST .AND. (LCOND .OR. .NOT. IGNORE) IF (LRESUL) WRITE (6,20) LINENO, IND1, IND2, (LINE(J), J=1,LEN) 20 FORMAT (1X, I4, 2A1, 10X, 130A1) IF (LRESUL) LINECT = LINECT + 1 IF (IGNORE) GO TO 400 !IGNORE ALL EXCEPT .ENDC C C .INCLUDE DIRECTIVE C CALL STRCMP (I1, LINE(2), 'INCLUDE') IF (I1 .NE. 0) GO TO 50 IF (INPUT .LT. 3) GO TO 30 WRITE (5,25) LINENO 25 FORMAT (' FTE -- Too many include directives, at line', I5) RETURN 30 LINETP(INPUT) = LINENO !SAVE CURRENT LINENO LINENO = 0 INPUT = INPUT + 1 POSN = 9 CALL SKIP (POSN) CALL SUBSTR (WORD, LINE, POSN, 100) OPEN (UNIT=INPUT, NAME=WORD, TYPE='OLD', READONLY) RETURN C C .DEFINE DIRECTIVE - FORM: .DEFINE SYMBOL VALUE !COMMENT C 50 CALL STRCMP (I1, LINE(2), 'DEFINE') IF (I1 .NE. 0) GO TO 100 POSN = 8 CALL SKIP (POSN) !FIND FIRST CHAR OF SYMBOL K1 = POSN DO 60 J=K1,LEN IF (LINE(J) .EQ. "40 .OR. LINE(J) .EQ. "11) GO TO 70 60 K2 = J 70 CALL SUBSTR (WORD, LINE, K1, K2-K1+1) CALL REFNAM (WORD, LINENO, INDEX, INEW, ISUBST) !ADD LINENO REF SUBPTR(INDEX) = -(NAVAIL+1) !POINT TO SUBSTITUTE VALUE LINE(LEN+2) = 0 K = K2+1 80 NAVAIL = NAVAIL + 1 K = K+1 NAME(NAVAIL) = LINE(K) !COPY DEFINING VALUE IF (LINE(K) .NE. 0 .AND. LINE(K) .NE. "41) GO TO 80 NAME(NAVAIL) = 0 RETURN C C .NOTRANSLATE, .TRANSLATE DIRECTIVES C 100 CALL STRCMP (I1, LINE(2), 'NOTRANS') IF (I1 .NE. 0) GO TO 120 NOTRAN = .TRUE. RETURN 120 CALL STRCMP (I1, LINE(2), 'TRANS') IF (I1 .NE. 0) GO TO 125 NOTRAN = .FALSE. RETURN C C .LIST, .NOLIST DIRECTIVES C 125 CALL STRCMP (I1, LINE(2), 'LIST') IF (I1 .NE. 0) GO TO 130 LLIST = .TRUE. RETURN 130 CALL STRCMP (I1, LINE(2), 'NOLIST') IF (I1 .NE. 0) GO TO 135 LLIST = .FALSE. RETURN C C .CONDLIST, .NOCONDLIST DIRECTIVES C 135 CALL STRCMP (I1, LINE(2), 'CONDLIST') IF (I1 .NE. 0) GO TO 140 LCOND = .TRUE. RETURN 140 CALL STRCMP (I1, LINE(2), 'NOCONDLIST') IF (I1 .NE. 0) GO TO 150 LCOND = .FALSE. RETURN C C .COMMENT, .NOCOMMENT DIRECTIVES C 150 CALL STRCMP (I1, LINE(2), 'COMMENT') IF (I1 .NE. 0) GO TO 155 LCOMM = .TRUE. RETURN 155 CALL STRCMP (I1, LINE(2), 'NOCOMMENT') IF (I1 .NE. 0) GO TO 200 LCOMM = .FALSE. RETURN C C .ERROR DIRECTIVE C 200 CALL STRCMP (I1, LINE(2), 'ERROR') IF (I1 .NE. 0) GO TO 400 WRITE (5,210) LINENO, (LINE(J), J=1,LEN) 210 FORMAT (' Error directive issued at line', I5 / 1X, 130A1) RETURN C C .IFDF, .IFNDF DIRECTIVES C 400 CALL STRCMP (I1, LINE(2), 'IFDF') IF (I1 .NE. 0) GO TO 410 IFDF = .TRUE. !MARK AS .IFDF POSN = 6 GO TO 420 410 CALL STRCMP (I1, LINE(2), 'IFNDF') IF (I1 .NE. 0) GO TO 500 IFDF = .FALSE. !MARK AS .IFNDF POSN = 7 C 420 LRESUL = .NOT. IFDF !ASSUME FALSE IF (IGNORE) GO TO 460 LRESUL = .FALSE. IOPER = 0 C 450 CALL SKIP (POSN) IF (POSN .GT. LEN) GO TO 460 !END OF LINE IF (LINE(POSN) .EQ. COR) GO TO 491 IF (LINE(POSN) .EQ. CAND) GO TO 492 IF (LINE(POSN) .EQ. CEX) GO TO 493 IF (LINE(POSN) .EQ. CLT) GO TO 494 IF (LINE(POSN) .EQ. CEQ) GO TO 495 IF (LINE(POSN) .EQ. CGT) GO TO 496 C CALL KEYWD (POSN, WORD) !GET NEXT SYMBOL IF (IOPER .LT. 10) CALL FIND (WORD, INDEX) !LOOK UP SYMBOL LRESU2 = INDEX .GT. 0 !.TRUE. IF SYMBOL DEFINED IF (IOPER .EQ. 0) LRESUL = LRESU2 IF (IOPER .EQ. 1) LRESUL = LRESUL .OR. LRESU2 !OR IF (IOPER .EQ. 2) LRESUL = LRESUL .AND. LRESU2 !AND IF (IOPER .LT. 10) GO TO 450 !SKIP RELATIONAL STUFF C LRESU2 = .FALSE. IF (INDEX .LE. 0) GO TO 450 !IGNORE IF SYMBOL NOT DEFINED CALL CMPVAL (WORD, INDEX, IRESUL) !COMPARE SYMBOL'S VALUE TO RHS IF (IRESUL .GT. 0 .AND. IOPER .LE. 12) LRESU2 = .TRUE. IF (IRESUL .LT. 0 .AND. (IOPER .GE. 14 .OR. IOPER .EQ. 10)) * LRESU2 = .TRUE. IF (IRESUL .EQ. 0 .AND. (IOPER .GE. 12 .AND. IOPER .LE. 14)) * LRESU2 = .TRUE. LRESUL = LRESUL .AND. LRESU2 !RELATIONALS MAY ONLY BE ANDED GO TO 450 C 460 ICONDP = ICONDP + 1 !PUSH CONDITIONAL RESULT ONTO STACK ICOND(ICONDP) = IFDF .EQV. LRESUL IGNORE = .NOT. ICOND(ICONDP) RETURN C 491 IOPER = 1 !OR GO TO 499 492 IOPER = 2 !AND GO TO 499 493 IOPER = 10 !!= POSN = POSN + 1 GO TO 499 494 IOPER = 11 !< OR <= POSN = POSN + 1 IF (LINE(POSN) .EQ. CEQ) IOPER = 12 GO TO 499 495 IOPER = 13 != GO TO 499 496 IOPER = 15 !> OR >= POSN = POSN + 1 IF (LINE(POSN) .EQ. CEQ) IOPER = 14 499 IF (IOPER .NE. 11 .AND. IOPER .NE. 15) POSN = POSN + 1 GO TO 450 C C .ENDC DIRECTIVE C 500 CALL STRCMP (I1, LINE(2), 'ENDC') IF (I1 .NE. 0) GO TO 600 IF (ICONDP .EQ. 1) GO TO 520 !EXRANEOUS .ENDC ICONDP = ICONDP-1 LRESUL = IPRINT .AND. LLIST .AND. ICOND(ICONDP) * .AND. IGNORE .AND. .NOT. LCOND IF (LRESUL) * WRITE (6,20) LINENO, IND1, IND2, (LINE(J), J=1,LEN) !PRINT LAST .ENDC IF (LRESUL) LINECT = LINECT + 1 IGNORE = .NOT. ICOND(ICONDP) RETURN C 520 WRITE (5,540) LINENO 540 FORMAT (' FTE -- Extraneous .ENDC at line', I5) RETURN C C ALL UNKNOWN DIRECTIVES FALL THROUGH TO HERE C 600 IF (IGNORE) RETURN WRITE (5,640) LINENO 640 FORMAT (' FTE -- Unrecognized directive at line', I5) RETURN END SUBROUTINE LONGNA (POSN) C C SCANS FOR SUBSTITUTE NAMES OR LONG NAMES, AND MAKES C THE APPROPRIATE SUBSTITUTIONS. ENTERS LINE NUMBER REFERENCES C TO EACH NON-KEYWORD NAME. C C NOTE THAT THERE ARE TWO LINES WHICH DEPEND ON WHETHER THIS PROGRAM C IS INTENDED FOR RSX-11M OR VAX/VMS. ONE SUCH LINE IS IN THE "DO 200" C LOOP AND CHECKS FOR A DOLLAR SIGN IN NAME. THIS LINE SHOULD BE INCLUDED C FOR THE VAX VERSION, AND REMOVED FOR RSX. SECONDLY, AFTER STATEMENT 500, C THERE IS A CHOICE OF TWO LINES. THESE CHANGES RESULT IN LONG NAMES WITH C UNDERSCORES AND DOLLAR SIGNS NOT BEING TRANSLATED SINCE THEY ARE VALID C UNDER VMS FORTRAN. C C THE TREE STRUCTURE USED TO MAINTAIN THE SYMBOL TABLE IS AS FOLLOWS: C C EACH SYMBOL NODE HAS POINTERS: C C NAMPTR - INDEX INTO WHERE SYMBOL IS, C SUBPTR - INDEX INTO WHERE SUBSTITUTE SYMBOL IS, IF ANY, C REFPTR - INDEX INTO WHERE LIST OF STATEMENT REFERENCES IS, C LEFLNK - INDEX INTO FOR LEFT NODE IN TREE BELOW, C RIGLNK - INDEX INTO FOR RIGHT NODE IN TREE BELOW. C C THE NAMES AND SUBSTITUTE NAMES ARE KEPT IN CHARACTER STRING , C EACH INDEXED FROM THE SYMBOL NODES, AND EACH TERMINATED BY A ZERO BYTE. C C THE STATEMENT NUMBERS EACH SYMBOL IS REFERENCED IN IS IN A LINKED C LIST MADE UP OF CONTAINING THE NUMBER, AND CONTAINING C THE INDEX INTO OF THE FOLLOWING NODE OF THE LIST. C C IN ALL CASES, A ZERO POINTER MEANS END OF LIST. C C THE AVAILABILITY LISTS ARE HEADED BY THE FOLLOWING, EACH OF WHICH C POINT TO THE LAST USED NODE, I.E. MUST BE INCREMENTED TO GIVE THE C NEXT FREE INDEX: C C LAVAIL - NODE AVAILABILITY LIST FOR NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK. C NAVAIL - CHARACTER AVAILABILITY LIST FOR NAME STRING. C MAVAIL - NODE AVAILABILITY LIST FOR STMTNO AND STMLNK. C C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM INTEGER POSN, RESLEN(52) BYTE RESNAM(12,52), STR(130), QUOTE, CHAR, CHAR0, CHAR1 BYTE CA, CD, CE, CH, CR, CZ, C0, C9 BYTE CQ1, CQ2, CEX, CUN, CDOT BYTE CAS, CZS COMMON /RESERV/ RESLEN COMMON /RESERC/ RESNAM DATA CA, CD, CE, CH, CZ, C0, C9 / 'A', 'D', 'E', 'H', 'Z', '0', '9' / DATA CQ1, CQ2, CEX, CUN, CDOT, CDOL / '''', '"', '!', '_', '.', '$' / DATA CAS, CZS, CR / 'a', 'z', 'R' / DATA NEXNUM /30000/ ISCAN = 1 !MARK LINE AS HAVING BEEN SCANNED BY LONGNA C C IF POSN=0 HAVE REACHED END STMT, CLEAR NAME LIST C IF (POSN .GT. 0) GO TO 5 NEXNUM = 30000 NAVAIL = 0 !EMPTY ALL LISTS LAVAIL = 0 MAVAIL = 0 RETURN C C SCAN FOR VARIABLE NAMES C 5 K1 = POSN 10 DO 50 K=K1,LEN CHAR = LINE(K) IF (CHAR .EQ. CEX) GO TO 90 !COMMENT AT END OF LINE "!" IF (CHAR .GE. CA .AND. CHAR .LE. CZ) GO TO 100 IF (CHAR .GE. CAS .AND. CHAR .LE. CZS) GO TO 100 IF (CHAR .EQ. CQ1) GO TO 60 !QUOTE 50 CONTINUE GO TO 1000 C C LOOK FOR CLOSING QUOTE C 60 K1 = K + 1 QUOTE = CHAR DO 80 K=K1,LEN IF (LINE(K) .NE. QUOTE) GO TO 80 K1 = K+1 GO TO 10 80 CONTINUE GO TO 1000 C C REMOVE COMMENT AT END OF LINE C 90 LEN = K-1 LINE(LEN+1) = 0 GO TO 1000 C C PICK UP VARIABLE NAME C 100 K1 = K KNAME = K !POSITION OF START OF NAME LENAME = 0 ISCORE = 0 DO 200 K=K1,LEN CHAR = LINE(K) IF (CHAR .GE. CAS .AND. CHAR .LE. CZS) CHAR = CHAR-"40 IF (.NOT. ((CHAR .GE. C0 .AND. CHAR .LE. C9) * .OR. (CHAR .GE. CA .AND. CHAR .LE. CZ) C * .OR. CHAR .EQ. CDOL * .OR. CHAR .EQ. CUN)) GO TO 300 IF (CHAR .EQ. CUN) ISCORE = 1 !UNDERSCORE IN NAME LENAME = LENAME + 1 STR(LENAME) = CHAR 200 CONTINUE C C REACHED END OF NAME, DISCARD HOLLERITHS, LOGICALS, EXPONENTS C CHAR1 = FIRST CHAR OF NAME C CHAR0 = CHAR BEFORE NAME C CHAR = FIRST CHAR AFTER NAME C 300 K1 = K CHAR0 = LINE(KNAME-1) CHAR1 = STR(1) IF (CHAR0 .EQ. CDOT .AND. CHAR .EQ. CDOT) GO TO 10 !.AND., .OR. OPERATORS IF (CHAR1 .NE. CE .AND. CHAR1 .NE. CD) GO TO 330 IF (CHAR0 .EQ. CDOT .OR. (CHAR0 .GE. C0 * .AND. CHAR0 .LE. C9)) GO TO 10 !1E5, 1D5 330 IF (CHAR1 .NE. CR) GO TO 340 IF (CHAR0 .GE. C0 .AND. CHAR0 .LE. C9) GO TO 10 !RAD-50 CONSTANT, NOT A NAME 340 IF (CHAR1 .NE. CH) GO TO 350 IF (CHAR0 .GE. C0 .AND. CHAR0 .LE. C9) GO TO 10 !HOLLERITH CONSTANT, NOT A NAME 350 STR(LENAME+1) = 0 IF (ISCORE .NE. 0 .OR. LENAME .GT. 12) GO TO 500 C C SEE IF NAME IS ON RESERVED LIST C DO 400 K=1,52 IF (RESLEN(K) .NE. LENAME) GO TO 400 CALL COMPAR (I1, STR, RESNAM(1,K)) IF (I1 .EQ. 0) GO TO 10 !A HIT 400 CONTINUE C C IT IS NOT A KEYWORD, MAKE LINE NUMBER ENTRY IN TREE C 500 CALL REFNAM (STR, LINENO, INDEX, INEW, ISUBST) IF (NOTRAN) GO TO 10 !DON'T CHANGE ANYTHING IF (ISUBST .NE. 0) GO TO 600 !SUBSTITUTION TO BE MADE IF (INEW .EQ. 0) GO TO 10 !NAME IS ALREADY IN TREE IF (ISCORE .EQ. 0 .AND. LENAME .LE. 6) GO TO 10 !REGULAR NAME - RSX-11M C IF (LENAME .LT. 32) GO TO 10 !REGULAR NAME - VAX C C FIRST REFERENCE TO A LONG VARIABLE NAME - ENTER SUBSTITUTE NAME IN TREE C 550 NAVAIL = NAVAIL + 1 SUBPTR(INDEX) = NAVAIL ENCODE (7, 560, NAME(NAVAIL)) STR(1), NEXNUM, 0 560 FORMAT (A1, I5, A1) NAVAIL = NAVAIL + 6 NEXNUM = NEXNUM + 1 C C MAKE SUBSTITUTION IN LINE C 600 CALL SUBSTR (STR, LINE, 1, KNAME-1) CALL CONCAT (STR, NAME(IABS(SUBPTR(INDEX)))) CALL CONCAT (STR, LINE(KNAME+LENAME)) CALL STRING (LINE, STR) LEN = LENGTH(LINE) !UPDATE LENGTH K1 = KNAME !RESUME IN SUBSTITUTION IF (SUBPTR(INDEX) .LT. 0) GO TO 10 !RESCAN NEW PART K1 = KNAME + 6 !RESCAN AFTER SHORT NAME GO TO 10 C C EXIT AFTER CHECKING LENGTH OF MODIFIED LINE C 1000 IF (LEN .LE. 80) RETURN WRITE (5,1020) LINENO 1020 FORMAT (' FTE -- Line may exceed 80 characters, at line', I6) IF (IPRINT) 1 WRITE (6,1040) LINENO 1040 FORMAT (' *** LINE MAY EXCEED 80 CHARACTERS AT LINE', I6) RETURN END SUBROUTINE HEADER C C PUTS A HEADER LINE AT THE TOP OF A NEW PAGE IN THE LISTING FILE C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE ITIME(8), IDATE(9) CALL DATE (IDATE) CALL TIME (ITIME) PAGENO = PAGENO + 1 IF (IPRINT) 1 WRITE (6,10) IDATE, ITIME, PAGENO, (CMDLIN(J),J=1,CMDLEN) 10 FORMAT ('1EXTENDED FORTRAN IV V05', 10X, 9A1, 2X, 8A1, 1 20X, 'PAGE', I3 / 1X, 'FILENAME = ', 82A1) IF (IPRINT) 1 WRITE (6,20) (TITLE(J),J=1,LENGTH(TITLE)) 20 FORMAT (1X, 130A1) IF (IPRINT) * WRITE (6,30) 30 FORMAT (/) LINECT = 0 RETURN END SUBROUTINE PRINTX C C PRINTS OUT THE CONTENTS OF THE SYMBOL TABLE C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE SPACE(30) !AT LEAST NREF BYTES LONG DATA SPACE / 30*' ' / C C NSUB IS COLUMN WHERE SUBSTITUTION VALUES GO. C NREF IS COLUMN WHERE LINE REFERENCES GO. C NSUB = 19 NREF = 26 C CALL HEADER IF (IPRINT) 1 WRITE (6,10) 10 FORMAT (26X, ' SYMBOL TABLE' // 1 1X, 'SYMBOL SUBST LINE NUMBER REFERENCES'/) LINECT = 0 NPTR = 1 IF (LAVAIL .EQ. 0) RETURN !EMPTY TREE STACK(1) = 1 C C FOLLOW LEFT LINK OF THIS NODE, THEN PRINT THIS NODES CONTENTS, C THEN FOLLOW RIGHT LINK. THIS WILL BE RECURSIVE, HENCE THE USE C OF THE STACK. C 100 IF (LEFLNK(STACK(NPTR)) .GT. 0) GO TO 500 !FOLLOW LEFT LINK C C EXAMINE THIS NODE'S CONTENTS C 110 CALL STRING (LINE, NAME(NAMPTR(STACK(NPTR)))) LEN = LENGTH(LINE) IF (SUBPTR(STACK(NPTR)) .EQ. 0) GO TO 160 !NO SUBST C C ADD SUBSTITUTE VALUE TO LISTING C NSPACE = NSUB - LEN - 1 !NUMBER OF SPACES TO APPEND IF (NSPACE .GT. 0) GO TO 150 !ROOM ON LINE LINECT = LINECT + 1 !NAME OVERLIES SUBST COLUMN IF (LINECT .GT. 50) CALL HEADER IF (IPRINT) 1 WRITE (6,350) (LINE(J), J=1,LEN) NSPACE = NSUB - 1 LEN = 0 150 CALL SUBSTR (LINE(LEN+1), SPACE, 1, NSPACE) !LEADING BLANKS CALL CONCAT (LINE, NAME(IABS(SUBPTR(STACK(NPTR))))) LEN = LENGTH(LINE) 160 NSPACE = NREF - LEN - 1 IF (NSPACE .GT. 0) GO TO 180 !ROOM ON LINE LINECT = LINECT + 1 !SUBST OVERLIES CROSS RFERENCES IF (LINECT .GT. 50) CALL HEADER IF (IPRINT) 1 WRITE (6,350) (LINE(J), J=1,LEN) NSPACE = NREF - 1 LEN = 0 180 CALL SUBSTR (LINE(LEN+1), SPACE, 1, NSPACE) !LEADING BLANKS C C ADD REFERENCE TO LINE NUMBERS C K = REFPTR(STACK(NPTR)) 200 IF (K .EQ. 0) GO TO 300 CALL CATREF (STMTNO(K)) !APPEND NUMBER TO LINE K = STMLNK(K) GO TO 200 C C WRITE LINE C 300 LEN = LENGTH(LINE) LINE(LEN-1) = "40 !KNOCK OFF LAST COMMA LINECT = LINECT + 1 IF (LINECT .GT. 50) CALL HEADER IF (IPRINT) 1 WRITE (6,350) (LINE(J), J=1,LEN) 350 FORMAT (1X, 130A1) C C FOLLOW RIGHT LINK OF NODE C IF (RIGLNK(STACK(NPTR)) .EQ. 0) GO TO 400 !NO RIGHT LINK TYPE(NPTR) = 2 STACK(NPTR+1) = RIGLNK(STACK(NPTR)) NPTR = NPTR + 1 GO TO 100 C C EFFECT RETURN FROM RECURSION LEVEL - POP UP STACK C 400 NPTR = NPTR - 1 IF (NPTR .LE. 0) GO TO 1000 !FINISHED WITH TREE K = TYPE(NPTR) GO TO (110, 400), K C C FOLLOW LEFT LINK OF NODE C 500 TYPE(NPTR) = 1 STACK(NPTR+1) = LEFLNK(STACK(NPTR)) NPTR = NPTR + 1 GO TO 100 C C FINISHED GOING THRU TREE - PRINT STATISTICS C 1000 IF (IPRINT) 1 WRITE (6,1010) LAVAIL, MAVAIL, NAVAIL 1010 FORMAT (//26X, 'PREPROCESSOR TABLE USAGE: SYMBOLS =', I3, * '/200, STATNOS =', I4, '/1001, CHARS =', I4, '/2000') RETURN END SUBROUTINE CATREF (NUM) C C APPENDS INTO , FOLLOWED BY A COMMA. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE TEMP(10), NUMBER(10) DATA NUMBER /'0', '1', '2', '3', '4', '5', '6', '7', '8', '9'/ N = NUM I = 9 C C BUMP DIGITS OFF RIGHT END OF N C 10 TEMP(I) = NUMBER( (N - N/10*10) + 1 ) I = I-1 N = N/10 IF (N .GT. 0) GO TO 10 TEMP(10) = 0 IF (LENGTH(LINE) .LT. 100) GO TO 50 LINECT = LINECT + 1 IF (LINECT .GT. 50) CALL HEADER IF (IPRINT) 1 WRITE (6,20) (LINE(J), J=1,LENGTH(LINE)) !OVERFLOWED LINE 20 FORMAT (1X, 130A1) CALL STRING (LINE, ' ') !NREF-1 SPACES 50 CALL CONCAT (LINE, TEMP(I+1)) CALL CONCAT (LINE, ', ') RETURN END SUBROUTINE PUSH (N, ITYPE) C C PUSHS THE VALUE N ONTO THE 'STACK', ALONG WITH ITYPE C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM IF (STKPTR .LT. 40) GO TO 20 WRITE (5,10) 10 FORMAT (' FTE -- TOO MANY NESTED IF-THEN-ELSE CLAUSES') STOP 20 STKPTR = STKPTR + 1 STACK(STKPTR) = N TYPE(STKPTR) = ITYPE RETURN END SUBROUTINE POP (N, ITYPE) C C POPS THE NEXT VALUE ON THE 'STACK' INTO N, ALONG WITH ITYPE. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM IF (STKPTR .GT. 0) GO TO 20 WRITE (5,10) LINENO 10 FORMAT (' FTE -- UNEXPECTED "}" AT LINE', I6) IF (IPRINT) 1 WRITE (6,15) 15 FORMAT (' *** UNEXPECTED END OF CLAUSE ***') ITYPE = 0 RETURN 20 N = STACK(STKPTR) ITYPE = TYPE(STKPTR) STKPTR = STKPTR - 1 RETURN END SUBROUTINE SKIP (POSN) C C FINDS THE NEXT NON-BLANK NON-TAB CHARACTER IN LINE, STARTING AT C LINE(POSN:POSN). IF THERE IS NONE, IT RETURNS POSN = LEN+1, ELSE IT C LEAVES POSN AT THE NEXT CHARACTER C INTEGER POSN INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM 10 IF (LINE(POSN) .NE. "40 .AND. LINE(POSN) .NE. "11) RETURN POSN = POSN + 1 IF (POSN .LE. LEN) GO TO 10 RETURN END SUBROUTINE KEYWD (POSN, WORD1) C C FINDS THEN NEXT KEY WORD STARTING AT LINE(POSN:POSN). KEYWORDS ARE ONLY C MADE UP OF LETTERS, NUMBERS OR UNDERSCORES. C POSN IS SET TO POSITION FOLLOWING LAST LETTER OF KEYWORD. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE WORD1(1), CHAR INTEGER POSN J = 0 10 CHAR = LINE(POSN) IF ((CHAR .LT. "101 .OR. CHAR .GT. "132) * .AND. (CHAR .LT. "141 .OR. CHAR .GT. "172) * .AND. (CHAR .LT. "60 .OR. CHAR .GT. "71) * .AND. CHAR .NE. "137) GO TO 20 J = J+1 WORD1(J) = LINE(POSN) POSN = POSN + 1 IF (POSN .LE. LEN) GO TO 10 20 WORD1(J+1) = 0 RETURN END SUBROUTINE FIND (STR, INDEX) C C SETS TO THE INDEX OF NODE CONTAINING NAME . C IF THERE IS NO SUCH NODE, SETS TO MINUS OF INDEX OF C NODE TO WHICH THE NEW NODE SHOULD BE ATTACHED. C FOR SPECIAL CASE OF EMPTY TREE, RETURNS INDEX = 0. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE STR(1) NPTR = 1 INDEX = 0 IF (LAVAIL .EQ. 0) RETURN !NOTHING IN TREE 10 CALL CMPNAM (STR, NPTR, IRESUL) !COMPARE NAMES IF (IRESUL .EQ. 0) GO TO 50 !A HIT INDEX = -NPTR IF (IRESUL .LT. 0) NPTR = LEFLNK(NPTR) IF (IRESUL .GT. 0) NPTR = RIGLNK(NPTR) IF (NPTR .GT. 0) GO TO 10 !TRY NEXT NODE C C HAVE NOT FOUND NAME IN TREE - RETURN MINUS OF NEAREST NODE C RETURN C C HAVE FOUND NAME - RETURN ITS INDEX C 50 INDEX = NPTR RETURN END SUBROUTINE CMPNAM (STR, NPTR, IRESUL) C C COMPARES THE NAME IN WITH THE NAME REFERRED TO BY THE NODE C POINTED TO BY . SETS DEPENDING ON MATCH: C C IRESUL < 0 IF STR < [NPTR] C = 0 IF STR = [NPTR] C > 0 IF STR > [NPTR]. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE STR(1) BYTE CHAR, CHARNM J = NAMPTR(NPTR) !INDEX INTO OF NODE WORD K = 1 !INDEX INTO 10 CHAR = STR(K) CHARNM = NAME(J) IF (CHAR .LT. CHARNM) GO TO 20 IF (CHAR .GT. CHARNM) GO TO 30 IF (CHAR .EQ. 0) GO TO 50 !END OF STRING J = J+1 K = K+1 GO TO 10 C C < NAME C 20 IRESUL = -1 RETURN C C > NAME C 30 IRESUL = 1 RETURN C C = NAME C 50 IRESUL = 0 RETURN END SUBROUTINE CMPVAL (STR, NPTR, IRESUL) C C COMPARES THE SUBSTITUTE VALUE IN WITH THE NAME REFERRED TO C BY THE NODE POINTED TO BY . SETS DEPENDING ON MATCH: C C IRESUL < 0 IF STR < [NPTR] C = 0 IF STR = [NPTR] C > 0 IF STR > [NPTR]. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE STR(1) BYTE CHAR, CHARNM IRESUL = 1 J = IABS(SUBPTR(NPTR)) !INDEX INTO OF NODE WORD IF (J .EQ. 0) RETURN K = 1 !INDEX INTO 10 CHAR = STR(K) CHARNM = NAME(J) IF (CHAR .LT. CHARNM) GO TO 20 IF (CHAR .GT. CHARNM) GO TO 30 IF (CHAR .EQ. 0) GO TO 50 !END OF STRING J = J+1 K = K+1 GO TO 10 C C < NAME C 20 IRESUL = -1 RETURN C C > NAME C 30 IRESUL = 1 RETURN C C = NAME C 50 IRESUL = 0 RETURN END SUBROUTINE ADDNAM (STR, INDEX) C C CREATES A NODE IN THE TREE REFERRING TO THE NAME IN . C MUST BE NODE NEAREST TO PLACE WHERE INSERTION TAKES PLACE. C ALSO SETS TO INDEX OF NEW NODE. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE STR(1) IF (INDEX .EQ. 0) GO TO 100 !EMPTY TREE CALL CMPNAM (STR, INDEX, IRESUL) !INSERT TO LEFT OR RIGHT? LAVAIL = LAVAIL + 1 IF (IRESUL .LT. 0) GO TO 20 C C INSERT ON RIGHT SIDE OF NODE C RIGLNK(INDEX) = LAVAIL !POINT TO NEW NODE GO TO 30 C C INSERT ON LEFT SIDE OF NODE C 20 LEFLNK(INDEX) = LAVAIL !POINT TO NEW NODE C C INSERT INTO NAME LIST C 30 NAVAIL = NAVAIL + 1 NAMPTR(LAVAIL) = NAVAIL !POINT NODE TO WHERE NAME WILL BE K = 1 !INDEX INTO 50 NAME(NAVAIL) = STR(K) !COPY NAME IF (NAME(NAVAIL) .EQ. 0) GO TO 60 !END OF NAME K = K+1 NAVAIL = NAVAIL + 1 GO TO 50 C C END OF NAME C 60 LEFLNK(LAVAIL) = 0 !RESET NEW NODE RIGLNK(LAVAIL) = 0 SUBPTR(LAVAIL) = 0 REFPTR(LAVAIL) = 0 INDEX = LAVAIL RETURN C C FIRST NODE IN TREE C 100 LAVAIL = LAVAIL + 1 INDEX = 1 GO TO 30 END SUBROUTINE REFNAM (STR, NUMBER, INDEX, INEW, ISUBST) C C ENTERS A LINE NUMBER INTO LIST OF SUCH REFERENCES TO NAME IN . C IF THE NAME IS NOT YET ENTERED IN TREE, IT WILL DO SO. C ONLY THE FIRST REFERENCE ON ANY ONE LINE IS RECORDED. C SETS INEW=1 IF NOT YET IN TREE. SETS INDEX TO POSITION IN TREE. C SETS ISUBST=1 IF THERE IS A SUBSTITUTION TO BE MADE. C IF NONEW IS TRUE, WILL NOT ADD NEW NAMES TO LIST, SETS INEW=0. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE STR(1) C CALL FIND (STR, INDEX) !FIND NODE INEW = 0 !ASSUME ALREADY THERE ISUBST = 0 !ASSUME NO SUBSTITUTION IF (INDEX .GT. 0) GO TO 10 !ALREADY THERE C C NAME NOT YET IN TREE - ENTER IT C IF (NONEW) RETURN !DO NOT ADD NEW NAMES TO LIST INEW = 1 INDEX = -INDEX CALL ADDNAM (STR, INDEX) !ADD NAME TO TREE C C INDEX POINTS TO NODE - ADD REFERENCE TO LINE NUMBER C 10 IF (.NOT. ITABLE) GO TO 40 !NO SYMBOL TABLE REQUIRED NPTR = REFPTR(INDEX) IF (NPTR .EQ. 0) GO TO 50 !EMPTY REFERENCE LIST 20 NPTR0 = NPTR NPTR = STMLNK(NPTR) IF (NPTR .GT. 0) GO TO 20 !FOLLOW REFERENCE LIST IF (STMTNO(NPTR0) .EQ. NUMBER) GO TO 40 !SAME LINE NUMBER, IGNORE C C ADD ANOTHER ELEMENT TO STMTNO LIST C MAVAIL = MAVAIL + 1 STMLNK(NPTR0) = MAVAIL 30 STMLNK(MAVAIL) = 0 STMTNO(MAVAIL) = NUMBER 40 ISUBST = 0 IF (SUBPTR(INDEX) .NE. 0) ISUBST = 1 !A SUBSTITUTE EXISTS RETURN C C FIRST ENTRY IN THIS LIST C 50 MAVAIL = MAVAIL + 1 REFPTR(INDEX) = MAVAIL GO TO 30 END SUBROUTINE FMT (NUM, IFMT) C C SCANS LINE FOR UNLABELLED FORMAT SPECIFIER %%. C IF FOUND, REPLACES WITH NUM, AND SETS IFMT. C INTEGER STATNO, STACK(40), TYPE(40), STKPTR, PAGENO, CMDLEN, 1 NAMPTR(200), SUBPTR(200), REFPTR(200), LEFLNK(200), 2 RIGLNK(200), STMTNO(1001), STMLNK(1001) LOGICAL ICOND, NOTRAN, LLIST, LCOND, IGNORE, IPRINT, ITABLE, 1 NONEW, LCOMM BYTE LINE(130), TITLE(130), CMDLIN(82), NAME(2000), IND1, IND2 BYTE WORD(130) COMMON /FTECHA/ LINE, TITLE, CMDLIN, NAME, WORD, IND1, IND2 COMMON /FTECOM/ LEN, CMDLEN, STATNO, NEXNUM, 1 PAGENO, LINENO, LINECT, ISCAN, STACK, TYPE, STKPTR, 2 NAMPTR, SUBPTR, REFPTR, LEFLNK, RIGLNK, STMTNO, IENDED, 3 STMLNK, LAVAIL, NAVAIL, MAVAIL, ITABLE, LINETP(5), 4 INPUT, IGNORE, ICONDP, ICOND(10), NOTRAN, IPRINT, 5 LLIST, LCOND, NONEW, LCOMM BYTE LINE2(130) C IFMT = 0 DO 10 J=1,LEN IF (LINE(J) .NE. "45) GO TO 10 K = J IF (LINE(J+1) .EQ. "45 .AND. J .LT. LEN) GO TO 20 10 CONTINUE RETURN C C HAVE FOUND %%, REPLACE WITH NUM C 20 CALL SUBSTR (LINE2, LINE, 1, K-1) ENCODE (5,30,LINE2(K)) NUM 30 FORMAT (I5) LINE2(K+5) = 0 CALL CONCAT (LINE2, LINE(K+2)) !COPY REST OF LINE CALL STRING (LINE, LINE2) LEN = LEN + 3 IFMT = 1 RETURN END SUBROUTINE STRCMP (IRES, LINE, NAME) C C COMPARES THE TEXT STRING IN TO THE TEXT IN , C STOPPING AFTER THE END OF . SETS IRES TO 0 IF THEY C ARE EQUAL, 1 OTHERWISE. SHOULD BE UPPER CASE, C LINE CAN BE EITHER AS CASE IS IGNORED. C BYTE LINE(1), NAME(1) C IRES = 0 !ASSUME EQUAL DO 100 J=1,10000 IF (NAME(J) .EQ. 0) RETURN IF (LINE(J) .NE. NAME(J) .AND. LINE(J)-"40 .NE. NAME(J)) GO TO 200 100 CONTINUE 200 IRES = 1 RETURN END