/* FORTRAN TO PL/I TRANSLATOR BY LANSE M LEACH COMPUTER SCIENCE DEPARTMENT STANFORD UNIVERSITY, STANFORD, CALIFORNIA AUGUST 1,1967 TRANSLATION IS FROM THE ASA FORTRAN STANDARDIZATION SPECIFICATIONS PUBLISHED IN THE 'COMMUNICATIONS OF THE ACM', OCTOBER 1964 INTO PL/I (F LEVEL) AS DESCRIBED IN 'IBM SYSTEM/360 OPERATING SYSTEM PL/I LANGUAGE SPECIFICATIONS', FORM C28-6571. THE TRANSLATOR IS WRITTEN IN IBM PL/I (F LEVEL) USING THE METHOD OF RECURSIVE DESCENT AND PL/I CHARACTER STRINGS AS THE MAJOR TOOLS FOR THE TRANSLATION. OUTPUT IS BOTH PRINTED AND PUNCHED. DEBUGGING AND TESTING WAS ACCOMPLISHED ON THE IBM SYSTEM/360 AT STANFORD UNIVERSITY. A COMPLETE DESCRIPTION OF THE TRANSLATOR HAS BEEN PUBLISHED IN STANFORD COMPUTATION CENTER REPORT (NUMBER 33-78-2), STANFORD UNIVERSITY, STANFORD, CALIFORNIA */ /* Modified by R. A. Vowels, 5 October 2009, for Windows PL/I. */ /* l. 27: CRLF not an ENVIRONMENT option; V conflicts with LNGLVL option. */ /* l. 116: Lac not declared. */ /* l. 121: "not" sign changed to circumflex. */ /* l. 241: I not declared. */ /* l. 301: I not declared. */ /* l. 1291: J not declared. */ /* and in various other places. */ /* BUGS CORRECTED: */ /* 5/10/2009 Now generates FIXED BINARY (31) for INTEGER variables, */ /* which is necessary for any conversion to PL/I of a FORTRAN */ /* program. There are two reasons: */ /* 1. to avoid fixed-point overflow (FORTRAN integer variables */ /* are 32 bits; PL/I FIXED BINAREY variables are 16 bits). */ /* 2. to ensure that integer division yields an integer result. */ /* (For PL/I systems that have other size than 32-bit */ /* integers, the maximum precision must be used.) */ /* 5/10/2009 FORMAT modified to insert blank following any repeat factor; */ /* 6/10/2009 FORMAT modified to insert SKIP as the final format item in a */ /* format list. */ /* 6/10/2009 Declarations now supplied for undeclared variables that */ /* appear on the LHS of an assignment. */ /* Also for variables in dummy argument list. */ /* Also for variables in READ/WRITE (except for implied DO). */ /* Also for variables used as control variable in DO stateemnt. */ /* Also for variables used as control variables in implied DO. */ /* Improved spacing for variables in data lists. */ /* More than 7 continuation lines were not handled in assignment */ /* statements. The length of variable LINE was increased from */ /* 500 to 5000. */ /* 7/10/2009 The statement SUBROUTINE ABC causes an infinite loop with */ /* STRINGRANGE. */ /* 7/10/2009 The statement FUNCTION DEF causes an infinite loop with */ /* STRINGRANGE. */ /* 7/10/2009 CALL statements without an argument list cause an infinite */ /* loop with STRINGRANGE. */ /* 7/10/2009 A = L .NEQV. N was translated incorrectly to A = L; */ /* without warning. */ /* 7/10/2009 A = L .EQV. N was translated incorrectly to A = L; */ /* without warning. */ /* .EQV. and .NEQV. are now treated with same priority as .OR. */ /* 7/10/2009 With new procedures for stacking and unstacking declarations, */ /* and stacking and unstacking executable statements, */ /* instead of using temporary files, the problems of jumbling */ /* multiple procedures has been resolved. */ /* 7/10/2009 The name FORT supplied to the main PL/I procedure (when the */ /* FORTRAN program has no PROGRAM statement) was changed to 8 */ /* characters, in order to avoid a name conflict in the event */ /* that a CALL statement referred to FORT. */ /* 7/10/2009 The first line after an END statement was ignored owing to */ /* incorrectly-placed initialization. */ /* That usually meant that the following SUBROUTINE or FUNCTION */ /* statement was missed. */ /* 9/10/2009 While the form of the generated PROCEDURE statement for */ /* functions was correct for the PL/I (F) compiler, it is not */ /* any longer correct, and now requires the RETURNS option. */ /* In the case of the FORTRAN to PL/I converter, the value to be */ /* returned was assigned to a temporary, but the temporary was */ /* of default type, which could have been wrong. */ /* 9/10/2009 A spurious additional PROCEDURE statement was generated when */ /* a FUNCTION statement had an explicit type. This was because */ /* the first token in the statement was compared against the */ /* words 'FUNCTION' and 'SUBROUTINE'. */ /* 9/10/2009 The imaginary part of complex constants was "lost" without */ /* warning. */ /* 9/10/2009 FORTRAN's REAL constants must be expanded to 6 digits for */ /* single precision and 15 digits for double precision. */ /* Furthermore, FORTRAN's REAL constants must also have an */ /* exponent appended to them if they already do not have one. */ /* The real and imaginary parts of a COMPLEX constant are */ /* processed as two real constants by a special procedure, */ /* CONSTANT. */ /* NOTES: */ /* Minimum one-trip DO was in vogue in early FORTRAN codes. */ /* Check your DO statements to ensure that there is none in the */ /* FORTRAN code, and if present, make an appropriate adjustment */ /* to the DO statement in the corresponding PL/I code. */ /* */ /* Statement keywords such as DOUBLE (in DOUBLE PRECISION) and */ /* COMPLEX and LOGICAL must be terminated by a blank. */ /* BUGS TO FIX: */ /* nil */ /* If long words are used, such as DOUBLEPRECISION, the */ /* STRINGSIZE condition will be raised. */ /* ENHANCEMENTS */ /* 6/10/2009 Blank lines are accepted as comment lines. */ /* Comments commencing with ! and * are accepted. */ /* 6/10/2009 OPTIONS (REORDER) included in PROCEDURE statements. */ /* 7/10/2009 Initial comment lines now precede the PROCEDURE statement, */ /* instead of following all declarations. */ /* 7/10/2009 Improved spacing of arguments in CALL statements */ /* and in parameter lists of PROCEDURE statements. */ /* 7/10/2009 PROGRAM statement is translated. */ /* 7/10/2009 'BY 1' omitted from DO statements and implied DO when */ /* the increment is not provided in FORTRAN. */ /* 7/10/2009 A subset of DATA statements is translated. Translated are */ /* the following forms: */ /* DATA X /5/ */ /* DATA AR /4, 6*3, 0/ where AR is an array of 8 elements. */ /* DATA A, B, C / 5.2, 6.9, 9.1 / */ /* COMPLEX constants are not handled. */ /* 7/10/2009 Arithmetic IF statements optimised. */ /* VERSION 1.2 of 9/10/2009 */ (FOFL, SIZE, STRINGRANGE, STRINGSIZE): F#to#p: Procedure Options (Main, Reorder); Declare Sysin File Record Input; /*20090928*/ /* Environment( V CRLF ); /*20090928*/ Declare (Declist, Prglist) File Stream; Declare Punlist File Stream Print; Declare (Labcount, Symlength, Dopoint) Fixed Binary (15, 0); Declare Empty Character (71) Initial ((71)' '); Declare Tab Character (30) Varying; Declare (Lem, Len, Lab, Functname, Labstr) Character (10) Varying; Declare Symbol (200) Character (8) Varying; Declare Symdim (200) Character(20) Varying; Declare Symtype (200) Character (22) Varying; Declare Symcom (200) Character (30) Varying; Declare /* 7/10/2009 */ Initial_value (200) Character (30) Varying; Declare /* 7/10/2009 */ (Position, Discard) Fixed Binary; Declare (Unit, Le, Fmt#) Character (12) Varying; Declare Docount (50) Character (6) Varying; Declare (Word, Line, Iostring, Varstring) Character (5000) Varying; Declare (Outputline, Next) Character (72) Varying; Declare (Col1, Col6, Logic) Character (1); Declare Col25 Character (4), Col772 Character (66); Declare Dummy Character (8); Declare (Arithfunc, Newcard, Funct) Bit (1); Declare Builtin (53) Character (10) Varying Static Initial ('ABS', 'IABS', 'DABS', 'AINT', 'INT', 'IDINT', 'AMOD', 'MOD', 'AMAX0', 'AMAX1', 'MAX0', 'MAX1', 'DMAX1', 'AMIN0', 'AMIN1', 'MIN0', 'MIN1', 'DMIN1', 'FLOAT', 'IFIX', 'SIGN', 'ISIGN', 'DSIGN', 'SNGL', 'REAL', 'AIMAG', 'DBLE', 'CMPLX', 'CONJG', 'EXP', 'DEXP', 'CEXP', 'ALOG', 'DLOG', 'CLOG', 'ALOG10', 'DLOG10', 'SIN', 'DSIN', 'CSIN', 'COS', 'DCOS', 'CCOS', 'TANH', 'SQRT', 'DSQRT', 'CSQRT', 'ATAN', 'DATAN', 'ATAN2', 'DATAN2', 'DMOD', 'CABS'); Declare Cbuiltin (53) Character (10) Varying Static Initial ((3)(1)'ABS', (3)(1)'TRUNC', (2)(1)'MOD', (5)(1)'MAX', (5)(1)'MIN', 'FLOAT', 'FIXED', (3)(1)'SIGN', '', 'REAL', 'IMAG', 'FLOAT', 'COMPLEX', 'CONJ', (3)(1)'EXP', ( 3)(1)'LOG', (2)(1)'LOG10', (3)(1)'SIN', (3 )(1)'COS', 'TAN', (3)(1)'SQRT', (4)(1) 'ATAN', 'MOD', 'ABS'); /* Additional declarations. 5/10/2009 */ Declare Lac fixed binary; /* New declarations. 5/10/2009 */ Declare Current_procedure_name CHARACTER (8) VARYING; Declare Is_Function_Statement BIT (1) aligned; Declare SOURCELINE BUILTIN; Declare SL fixed binary; SL = SOURCELINE(); ON ERROR SNAP SYSTEM; ON STRINGRANGE SNAP BEGIN; put skip edit ('... at line ', TRIM(SL)) (a); END; Program: Procedure; /* INITIALIZATION AND CONTROL OF ONE PROGRAM OR SUBPROGRAM TRANSLATION */ ON ERROR SNAP SYSTEM; /* Open file (Declist) output title ('/Declist,type(crlf),recsize(132)'); Open file (Prglist) output title ('/Prglist,type(crlf),recsize(132)'); */ Open file (Punlist) output title ('/Punlist,type(crlf),recsize(132)'); /* Put File (Declist) List */ /* (' /* FORTRAN PROGRAM TRANSLATED TO PL/I * /'); */ Put File (Sysprint) List ('FORTRAN SOURCE PROGRAM') Page; Put File (Sysprint) Skip(3); Labcount = 0; Symlength, Dopoint, Lac = 0; Initial_value = ''; /* 7/10/2009 */ Funct = '0'B; /* 7/10/2009 */ /* Pass any initial comment lines to the output files. */ pass: If ^Newcard Then call card; Newcard = '0'B; if col1 = 'C' | col1 = 'c' | col1 = '*' | col1 = '!' then do; Call STACK ( ' /* ' || SUBSTR(outputline, 2) || ' */' ); /*put file (declist) list (' /* ' || SUBSTR(outputline, 2) || ' * /' ); */ go to pass; end; /* Pass any initial blank lines to the output files. */ if col1 = '' & col25 = '' & col6 = '' & col772 = '' & dummy = '' then do; Call STACK (outputline); /* put file (declist) list (outputline); */ go to pass; end; Newcard = '1'B; /* Because we have already read in one non-comment line. */ Tab = ' '; Symdim, Symcom, Symtype = ''; Call Scan('1'B); Next = UPPERCASE(Next); /* 6/10/2009 */ /* 9/10/2009 */ /* If the next token in LINE is one of the words FUNCTION, */ /* PRECISION, COMPLEX, look ahead to see whether the word */ /* FUNCTION occurs. */ /* If the word FUNCTION exists, it MUST appear in the initial line */ /* of the statement. */ If INDEX (Line, 'FUNCTION') > 0 THEN Is_Function_Statement = '1'b; Else Is_Function_Statement = '0'b; If Next = 'FUNCTION' then Is_Function_Statement = '1'b; If ^Is_Function_Statement & Next ^= 'SUBROUTINE' & Next ^= 'PROGRAM' Then do; /* The line is neither a FUNCTION, SUBROUTINE, nor SUBROUTINE*/ /* statement, so emit a PROCEDURE statement. */ Call Stack ( ' ' ); Call STACK ( ' (SUBSCRIPTRANGE):' ); Call STACK ( ' MAINPROG: PROCEDURE OPTIONS (MAIN);' ); /* Put File (Declist) List (' (SUBSCRIPTRANGE):' ); /* 7/10/2009 */ /* Put File (Declist) List (' MAINPROG: PROCEDURE OPTIONS (MAIN);');*/ Current_procedure_name = 'MAINPROG'; /* 6/10/2009 */ end; Loop: Do While (Next ^= 'END'); Call Statement; End Loop; Call STACK_EX ( ' END ' || Current_procedure_name || ';' ); /* Put File (Prglist) List (' END ' || Current_procedure_name || ';'); */ /* 6/10/2009 */ Call Fill_attributes; Call Output; End Program; /* Search Symbol table, find any identifiers without attributes, */ /* and add them. 6/10/2009 */ Fill_attributes: procedure; declare i fixed binary; do i = 1 to Symlength; if symtype(i) = '' then /* Apply the initial letter convention */ if INDEX('IJKLMN', substr(Symbol(I), 1, 1)) > 0 then Symtype(i) = ' fixed binary (31)'; else Symtype(i) = ' float binary'; end; end Fill_attributes; Statement: Procedure Recursive; /* PASSES CONTROL TO APPROPRIATE TRANSLATING PROCEDURE */ If Next = 'DIMENSION' Then Call Dimension; Else If Next = 'COMMON' Then Call Common; Else If Next = 'EQUIVALENCE' Then Call Equivalence; Else If Next = 'SUBROUTINE' Then Call Subroutine; Else if Next = 'PROGRAM' Then Call Program_Statement; Else If Next = 'ENTRY' Then Call Entry; Else If Next = 'READ' Then Call Readwrite('GET'); Else If Next = 'WRITE' Then Call Readwrite('PUT'); Else If Next = 'COMPLEX' Then Call Typ (' COMPLEX FLOAT BINARY '); Else If Next = 'ENDFILE' Then Call Rewind; Else If Next = 'REWIND' Then Call Rewind; Else If Next = 'BACKSPACE' Then Call Backspace; Else If Next = 'LOGICAL' Then Call Typ (' BIT (1) '); Else If Next = 'GO' Then Call Go; Else If Next = 'ASSIGN' Then Call Assign; Else If Next = 'IF' Then Call If; Else If Next = 'DO' Then Call Do; Else If Next = 'STOP' Then Call Stop; Else If Next = 'PAUSE' Then Call Pause; Else If Next = 'FORMAT' Then Call Format; Else If Next = 'CONTINUE' Then Call Continue; Else If Next = 'CALL' Then Call Call; Else If Next = 'RETURN' Then Call Return; Else If Next = 'FUNCTION' Then Call Function (''); Else If Next = 'REAL' Then Call Typ (' FLOAT BINARY '); Else If Next = 'DOUBLE' Then Call Double; Else If Next = 'INTEGER' Then Call Typ (' FIXED BINARY (31)'); /* 5/10/2009 */ Else If Next = 'DATA' Then Call Data; Else If Next = 'EXTERNAL' Then Call External; Else Call Assignment; End Statement; Scan: Procedure (W); /* SCAN RETURNS EITHER A STRING OF LETTERS, STRING OF DIGITS, OR A SPECIAL CHARACTER. SCAN ALSO PROCESSES COMMENT CARDS AND LABELS */ Declare W Bit(1) aligned; /* 7/10/2009 */ /* Additional declarations 5/10/2009 */ Declare (I, Icount) fixed binary; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; SL = SOURCELINE(); Icount = 0; Next = ''; New: If W = '1'B Then Do; Do I = 1 To Labcount; Call Disk ('END;'); Tab = Substr(Tab, 4); End; Labcount = 0; If Newcard = '0'B Then Call Card; Line = Col772; if col1 = '' & col25 = '' & col6 = '' & col772 = '' & dummy = '' then /* It was a blank line. 6/10/2009 */ do; Newcard = '0'B; call disk (' '); go to New; end; If Col1 = 'C' | Col1 = '*' | Col1 = '!' Then /* 6/10/2009 */ Do; Call Comment; Newcard = '0'B; Go To New; End; If Col1 ^= ' ' | Col25 ^= ' ' Then Call Label; Else Lab = ''; New1: Call Card; If Col6 ^= '0' & Col6 ^= ' ' & Col1 ^= 'C' Then Do; Line = Line || Col772; Go To New1; End; Newcard = '1'B; End; Blank: If Substr(Line, 1, 1) = ' ' Then Do; Line = Substr(Line, 2); If Line = '' Then Return; Go To Blank; End; If Line = '' Then Return; IF IS_DIGIT (Substr(Line, 1, 1) ) Then /* 5/10/2009 */ Go To Num; IF IS_LETTER (Substr(Line, 1, 1) ) Then /* 5/10/2009 */ Go To Str; Next = Substr(Line, 1, 1); Line = Substr(Line, 2); Return; Num: Icount = Icount + 1; IF IS_DIGIT (Substr(Line, Icount + 1, 1) ) Then /* 5/10/2009 */ Go To Num; Next = Substr(Line, 1, Icount); Line = Substr(Line, Icount + 1); Return; Str: Icount = Icount + 1; IF IS_LETTER (Substr(Line, Icount + 1, 1) ) Then /* 5/10/2009 */ Go To Str; Next = Substr(Line, 1, Icount); Line = Substr(Line, Icount + 1); End Scan; Error: Procedure (Message); /* PRINTS OUT ERROR MESSAGES IN THE FORTRAN LISTING */ Declare Message Character (60) Varying; Put File (Sysprint) List ('**********' || Message || '**********') Skip; End Error; Output: Procedure; /* CONTROLS PL/I LISTING AND CARD PUNCHING */ Declare I fixed binary; /* 5/10/2009 */ Put File (Sysprint) List('PL/I VERSION OF FORTRAN PROGRAM') Page; Put File (Sysprint) Skip(3); /* If the variable has an initial value, expand it as shown below: */ Do I = 1 to Symlength; if Initial_value(i) ^= '' then Initial_Value(i) = ' STATIC INITIAL (' || Initial_Value(I) || ')' ; end; /* Emit a complete declaration */ Do I = 1 To Symlength; Call STACK (' DECLARE ' || Symbol(I) || Symdim(I) || Symtype(I) || Symcom(I) || Initial_value (I) || ';'); /* Put File (Declist) List (' DECLARE ' || Symbol(I) || Symdim(I) || Symtype(I) || Symcom(I) || ';'); */ End; /* On Endfile (Declist) Go To Label2; */ /* On Endfile (Prglist) Go To Thatsall; */ On Conversion Go To Thatsall; /* Close File (Declist); */ /* Close File (Prglist); */ /* Redundant 7/10/2009 Label1: Open file (Declist) input title ('/Declist,type(crlf),recsize(132)'); Get File (Declist) List (Word); Put File (Sysprint) List (Word) Skip; Put File (Punlist) List (Word) Skip; Go To Label1; */ Call UNSTACK; Call OUT_DECLARATIONS; Put File (Sysprint) Skip; Put File (Punlist) skip; Label2: /* Redundant 7/10/2009 Open file (Prglist) input title ('/Prglist,type(crlf),recsize(132)'); Get File (Prglist) List (Word); Put File (Sysprint) List (Word) Skip; Put File (Punlist) List (Word) Skip; Go To Label2; */ Call UNSTACK_EX; Call OUT_EXECUTABLES; Thatsall: /* Close File (Declist); */ /* Close File (Prglist); */ End Output; Card: Procedure; Declare /*20090928*/ Crdv Character (80) Varying, /*20090928*/ Crd Character (80); /*20090928*/ /* READS A CARD FROM THE INPUT STREAM */ Read File( Sysin) Into(Crdv); /*20090928*/ Crd = Crdv; /*20090928*/ Put File (Sysprint) List (Outputline) Skip; Get String (Crd) Edit (Col1, Col25, Col6, Col772, Dummy)/*0928*/ (A(1), A(4), A(1), A(66), A(8)); Outputline = SUBSTR(Crd, 1, 72); /* 7/10/2009 */ End Card; Disk: Procedure (D); /* TRANSFERS VARYING LENGTH CHARACTER STRINGS TO TEMPORARY FILE ON A 2311 DISK */ Declare D Character (200) Varying; Declare I fixed binary; /* 5/10/2009 */ Dgo: D = Tab || D; If Length(D) < 72 Then Do; /* Put File (Prglist) List (D); */ Call STACK_EX (D); Return; End; Do I = 72 By - 1 To 1; If Substr(D, I, 1) = ' ' | Substr(D, I, 1) = ',' Then Go To Dgg; End; I = 72; Dgg: Call STACK_EX ( Substr(D, 1, I - 1) ); /* Put File (Prglist) List (Substr(D, 1, I - 1)); */ D = Substr(D, I); Go To Dgo; End Disk; Comment: Procedure; /* COMMENT PROCESSING -- BLANKS ARE REMOVED FROM THE HEAD AND TAIL OF ALL COMMENTS FOR MORE PRESENTABLE OUTPUT */ Declare I fixed binary; /* 5/10/2009 */ Iostring = Col25 || Col6 || Col772; If Iostring = Empty Then Do; Call Disk (' '); Return; End; Do I = 71 By - 1 To 1; If Substr(Iostring, I, 1) ^= ' ' Then Go To Outp1; Iostring = Substr(Iostring, 1, I - 1); End; Outp1: Do While (Substr(Iostring, 1, 1) = ' '); Iostring = Substr(Iostring, 2); End; Call Disk ('/* ' || Iostring || ' */'); End Comment; Assignment: Procedure; /* FORTRAN ASSIGNMENT STATEMENT */ Declare I fixed binary; /* 6/10/2009 */ Declare Identifier CHARACTER (20) varying; /* 6/10/2009 */ ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; If Funct = '1'B & Functname = Next Then Next = Next || '#'; Identifier = Next; /* 9/10/2009 */ /* Save the identifier (which may be a modified function name) */ /* for entering the name in symbol table. */ Call Variable('1'B); /* TEST FOR SIMPLE ARITHMETIC STATEMENT FUNCTION */ If Arithfunc = '1'B Then Return; Word = Varstring; /* 6/10/2009 */ /* Search symbol table for name. 6/10/2009 */ do i = 1 to Symlength; if Identifier = Symbol(i) Then go to Already_defined; end; /* Come here if symbol is not defined. */ if INDEX('IJKLMN', substr(Identifier, 1, 1)) > 0 Then do; if symlength < HBOUND(Symbol) then symlength = symlength + 1; symbol(symlength) = Identifier; Symtype(i) = ' fixed binary (31)'; end; Else do; if symlength < HBOUND(Symbol) then symlength = symlength + 1; symbol(symlength) = Identifier; Symtype(i) = ' float binary'; end; Already_defined: If Next ^= '=' Then Do; Call Error ('UNRECOGNIZABLE FORTRAN STATEMENT'); Call Scan ('1'B); Return; End; Call Scan ('0'B); Word = Word || ' = ' || Expression; Call Disk (Lab || Word || ';'); Call Scan ('1'B); End Assignment; Expression: Procedure Returns( Character (2000) Varying ) Recursive; /* EXPRESSION AND THE FOLLOWING SIX PROCEDURES PROCESS FORTRAN EXPRESSIONS */ Declare T Character (2000) Varying; Declare Operation Character (5); ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; T = Logfac; Do While (Next = '.'); Call Scan ('0'B); If Next ^= 'OR' & Next ^= 'EQV' & Next ^= 'NEQV' Then /* 7/10/2009 */ Do; Line = Next || Line; Next = '.'; Return (T); End; if Next = 'OR' then /* 7/10/2009 */ operation = ' | '; else if Next = 'EQV' Then Operation = ' = '; else Operation = ' ^= '; Call Scan ('0'B); Call Scan ('0'B); T = T || Operation || Logfac; /* 7/10/2009 */ End; Return (T); End Expression; Logfac: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; T = Logneg; Do While (Next = '.'); Call Scan ('0'B); If Next ^= 'AND' Then Do; Line = Next || Line; Next = '.'; Return (T); End; Call Scan ('0'B); Call Scan ('0'B); T = T || ' & ' || Logneg; End; Return (T); End Logfac; Logneg: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; If Next ^= '.' Then Return (Logprim); Call Scan ('0'B); If Next ^= 'NOT' Then Do; Line = Next || Line; Next = '.'; Return (Logprim); End; Call Scan ('0'B); Call Scan ('0'B); Return (' ^ (' || Logprim || ')'); End Logneg; Logprim: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; Declare Op Character (2) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; T = Arithexpr; Do While (Next = '.'); Call Scan ('0'B); If Next = 'GT' Then Op = '>'; Else If Next = 'GE' Then Op = '>='; Else If Next = 'LT' Then Op = '<'; Else If Next = 'LE' Then Op = '<='; Else If Next = 'EQ' Then Op = '='; Else If Next = 'NE' Then Op = '^='; Else Do; Line = Next || Line; Next = '.'; Return (T); End; Call Scan ('0'B); Call Scan ('0'B); T = T || ' ' || Op || ' ' || Arithexpr; End; Return (T); End Logprim; Arithexpr: Procedure Returns( Character (2000) Varying ) Recursive; Declare T Character (2000) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; If Next = '+' | Next = '-' Then Do; T = Next; Call Scan ('0'B); End; Else T = ''; T = T || Term; Do While (Next = '+' | Next = '-'); T = T || ' ' || Next || ' '; Call Scan ('0'B); T = T || Term; End; Return (T); End Arithexpr; Term: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; T = Factor; Do While (Next = '*' | Next = '/'); T = T || Next; Call Scan ('0'B); T = T || Factor; End; Return (T); End Term; Factor: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; T = Primary; Do While (Next = '*' & Substr(Line, 1, 1) = '*'); T = '(' || T || '**'; Call Scan ('0'B); Call Scan ('0'B); T = T || Primary || ')'; End; Return (T); End Factor; Primary: Procedure Returns( Character (200) Varying ) Recursive; Declare T Character (200) Varying; /* Declarations for processing complex constants. */ declare save_position fixed binary; declare (real_part, imag_part) character (30) varying; declare text character (72) varying; declare i fixed binary; ON STRINGSIZE SNAP BEGIN; put skip edit ('... on line ', TRIM(SL)) (a); END; If Next = '(' Then Do; /* Look ahead for a possible complex constant. */ /* As this is a limited context check, we require that */ /* the constant have at least one decimal point. */ /* We also require that the constant be entirely on one line. */ /* We scan to the next right parentiesis. */ /* Therefore, we expect only the following characters: */ /* digits 0-9, period (.), plus, minus, comma, the letters */ /* E or D, and blank. */ I = INDEX(Line, ')' ); save_position = i; if I > 0 then I = VERIFY ( substr(line, 1, i-1), '0123456789.+-,DE ' ); IF I = 0 THEN do; /* save_position = i; */ text = substr(line, 1, save_position); i = index(text, '.'); if i = 0 then go to not_a_complex_constant; i = index(text, ','); if i = 0 then go to not_a_complex_constant; /* Things are looking hopeful that it is a complex */ /* constant. */ i = TALLY(text, ','); if i ^= 1 then go to not_a_complex_constant; i = index(text, ','); real_part = substr(text, 1, i-1); imag_part = substr(text, i+1); real_part = trim(real_part); imag_part = trim(imag_part); /* which still has a ')' */ if IS_DIGIT(substr(imag_part, 1, 1)) then imag_part = '+' || imag_part; imag_part = substr(imag_part, 1, length(imag_part)-1); real_part = constant (real_part); imag_part = constant (imag_part); T = '(' || real_part || imag_part || 'I)' ; return (T); end; not_a_complex_constant: Call Scan ('0'B); T = '(' || Expression || ')'; Call Scan ('0'B); Return (T); End; If ( Next < '0' | Next > '9' ) & /*20090917*/ Next ^= '.' Then /*20090917*/ Do; Call Variable ('0'B); Return (Varstring); End; If Next ^= '.' Then Return (Number); Else Do; Call Scan ('0'B); If Next ^= 'TRUE' & Next ^= 'FALSE' Then Do; Line = Next || Line; Next = '.'; Return (Number); End; Else Do; If Next = 'TRUE' Then Logic = '1'; Else Logic = '0'; Call Scan ('0'B); Call Scan ('0'B); Return ('''' || Logic || '''B'); End; End; End Primary; Number: Procedure Returns( Character (200) Varying ); /* PROCESSES BOTH FIXED AND FLOATING POINT NUMBERS FOR EXPRESSIONS */ Declare Numstring Character (200) Varying; Declare (Num_digits, I) fixed binary; If Next = '.' Then Do; Numstring = Next; Call Scan ('0'B); Numstring = Numstring || Next; Call Scan ('0'B); Go To Exp; End; Numstring = Next; Call Scan ('0'B); If Next ^= '.' Then Return (Numstring); Call Scan ('0'B); If Next = 'GT' | Next = 'GE' | Next = 'EQ' | Next = 'LT' | Next = 'LE' | Next = 'TRUE' | Next = 'FALSE' | Next = 'NE' | Next = 'AND' | Next = 'OR' | Next = 'NOT' | Next = 'EQV' | Next = 'NEQV' Then /* 9/10/2009 */ Do; Line = Next || Line; Next = '.'; Return (Numstring); End; Numstring = Numstring || '.'; If IS_DIGIT( Substr(Next, 1, 1) ) Then /* 9/10/2009 */ Do; Numstring = Numstring || Next; Call Scan ('0'B); End; Exp: /* 9/10/2009 */ if index(Numstring, '.') > 0 then /* We have REAL constant. */ do; /* Expand to 6 digits for single precision, or 15 digits */ /* for double precision. */ num_digits = 0; do i = 1 to length(numstring); if IS_DIGIT (substr(numstring, i, 1) ) then num_digits = num_digits + 1; end; if Next = 'E' & num_digits < 6 then numstring = numstring || repeat ('0', 6 - num_digits); else if Next = 'D' & num_digits < 15 then numstring = numstring || repeat ('0', 15 - num_digits); else numstring = numstring || repeat ('0', 6 - num_digits); end; If Next ^= 'D' & Next ^= 'E' Then Return (Numstring || 'E0'); /* Must have an exponent for */ /* FORTRAN's REAL constants. */ Numstring = Numstring || 'E'; Call Scan ('0'B); If Next = '+' | Next = '-' Then Do; Numstring = Numstring || Next; Call Scan ('0'B); End; Numstring = Numstring || Next; Call Scan ('0'B); Return (Numstring); End Number; /* PROCESSES BOTH FIXED AND FLOATING POINT NUMBERS FOR */ /* REAL CONSTANTS. TWO CALLS ARE MADE FOR COMPLEX CONSTANTS. */ /* THIS PROCEDURE DIFFERS FROM IN THAT IT PROCESSES */ /* A STRING HELD IN . 9/10/2009 */ Constant: Procedure (TEXT) RETURNS (CHARACTER (200) VARYING); Declare Text CHARACTER (*) VARYING; Declare Numstring Character (200) Varying; Declare Next character (20) varying; Declare Position fixed binary; Declare (Num_digits, I) fixed binary; on error snap system; Text = text || ',' ; Position = 1; call scan_constant; /* To initialize Next. */ if Next = '+' | next = '-' then do; Numstring = Next; call Scan_constant; end; else Numstring = ''; If Next = '.' Then Do; Numstring = Numstring || Next; Call Scan_constant; Numstring = Numstring || Next; Call Scan_constant; Go To Exp; /* with a period (.) followed by one or more digits. */ End; Numstring = Numstring || Next; /* This can be a sign or a digit. */ Call Scan_constant; if IS_DIGIT (substr(Next, 1, 1)) then Numstring = Numstring || Next; else if Next ^= '.' Then Return (Numstring); Call Scan_constant; If Next = 'GT' | Next = 'GE' | Next = 'EQ' | Next = 'LT' | Next = 'LE' | Next = 'TRUE' | Next = 'FALSE' | Next = 'NE' | Next = 'AND' | Next = 'OR' | Next = 'NOT' | Next = 'EQV' | Next = 'NEQV' Then /* 9/10/2009 */ Do; Line = Next || Line; Next = '.'; Return (Numstring); End; Numstring = Numstring || '.'; If IS_DIGIT( Substr(Next, 1, 1) ) Then /* 9/10/2009 */ Do; Numstring = Numstring || Next; Call Scan_constant; End; Exp: /* 9/10/2009 */ if index(Numstring, '.') > 0 then /* We have REAL constant. */ do; /* Expand to 6 digits for single precision, or 15 digits */ /* for double precision. */ num_digits = 0; do i = 1 to length(numstring); if IS_DIGIT (substr(numstring, i, 1) ) then num_digits = num_digits + 1; end; if Next = 'E' & num_digits < 6 then numstring = numstring || repeat ('0', 6 - num_digits); else if Next = 'D' & num_digits < 15 then numstring = numstring || repeat ('0', 15 - num_digits); else numstring = numstring || repeat ('0', 6 - num_digits); end; If Next ^= 'D' & Next ^= 'E' Then Return (Numstring || 'E0'); /* Must have an exponent for */ /* FORTRAN's REAL constants. */ Numstring = Numstring || 'E'; Call Scan_constant; If Next = '+' | Next = '-' Then Do; Numstring = Numstring || Next; Call Scan_constant; End; Numstring = Numstring || Next; Call Scan_constant; if Next ^= ',' & Next ^= ')' then call error ('INVALID NUMBER ' || TEXT || ' IN COMPLEX CONSTANT'); Return (Numstring); /* Finds the position of the next token in Text as well as the token. */ /* Token can be a sign (+ or -) a period (.), or a string of digits */ scan_constant: Procedure; declare Ch character (1); declare i fixed binary; on error snap system; Ch = substr(text, position, 1); do while (Ch = ' '); position = position + 1; if position > length(Text) then do; call error ('TEXT exhausted in SCAN_CONSTANT'); put skip data (Position); stop; end; Ch = substr(text, position, 1); end; Next = Ch; if Ch = '+' then do; position = position + 1; return; end; if Ch = '-' then do; position = position + 1; return; end; if Ch = '.' then do; position = position + 1; return; end; if ^IS_DIGIT (Ch) then do; position = position + 1; return; end; i = verify(text, '0123456789', position ); IF I = 0 THEN CALL ERROR ('MISSING DIGITS IN SCAN_CONSTANT'); Next = substr(text, position, i-position); position = i; return; end scan_constant; End Constant; Variable: Procedure (W) Recursive; /* VARIABLE PROCESSING TO INCLUDE BUILTIN FUNCTION CHECKING */ /* AND SIMPLE ARITHMETIC FUNCTION STATEMENT CHECKING */ Declare Bfunct Character (200) Varying; Declare (W, Db) Bit (1); Declare I fixed binary; /* 5/10/2009 */ Call Fortiden; Varstring = Next; Call Scan ('0'B); If Next ^= '(' Then Return; If W = '1'B Then Do; /* TEST FOR SIMPLE ARITHMETIC STATEMENT FUNCTION */ Do I = 1 To Symlength; If Varstring = Symbol(I) Then Go To Nof; End; Arithfunc = '1'B; Call Arglist; Call Disk (Varstring || ': PROCEDURE (' || Word || ';'); Tab = Tab || ' '; Call Scan ('0'B); Call Scan ('0'B); Word = Expression; Call Disk ('RETURN (' || Word || ');'); Call Disk ('END;'); Tab = Substr(Tab, 4); Call Scan ('1'B); Return; End; Else Do; /* TEST FOR BUILT IN FUNCTION */ If Varstring = 'DBLE' Then Db = '1'B; Else Db = '0'B; Do I = 1 To Symlength; If Varstring = Symbol(I) Then Go To Nof; End; Do I = 1 To 53; If Varstring = Builtin(I) Then Varstring = Cbuiltin(I); End; Bfunct = Varstring; Do While (Next ^= ')'); Bfunct = Bfunct || Next; Call Scan ('0'B); Bfunct = Bfunct || Expression; End; Call Scan ('0'B); If Db = '1'B Then Varstring = Bfunct || ',53)'; Else Varstring = Bfunct || ')'; Return; End; Nof: Bfunct = Varstring; Do While (Next ^= ')'); Bfunct = Bfunct || Next; Call Scan ('0'B); Bfunct = Bfunct || Expression; End; Varstring = Bfunct || ')'; Call Scan ('0'B); End Variable; Fortiden: Procedure; /* PACKS CHARACTERS TO FORM VALID FORTRAN IDENTIFIERS */ DECLARE Ch CHARACTER (1); Fun: Ch = Substr(Line, 1, 1); If IS_LETTER(Ch) | IS_DIGIT(Ch) Then /* 6/10/2009 */ Do; Next = Next || Substr(Line, 1, 1); Line = Substr(Line, 2); Go To Fun; End; End Fortiden; Dimension: Procedure; /* FORTRAN DIMENSION STATEMENT */ Call Scan ('0'B); Call Typelist (''); Call Scan ('1'B); End Dimension; Common: Procedure; /* FORTRAN COMMON STATEMENT */ Call Scan ('0'B); Begcom: If Next = '' Then Go To Endcom; If Next = '/' Then Do; Call Scan ('0'B); Call Scan ('0'B); Call Error ('NAMED COMMON NOT TRANSLATABLE'); Call Scan ('0'B); End; Call Typelist (' EXTERNAL '); Go To Begcom; Endcom: Call Scan ('1'B); End Common; Equivalence: Procedure; /* FORTRAN EQUIVALENCE STATEMENT */ Call Error('EQUIVALENCE NOT TRANSLATED IN THIS VERSION'); Call Scan ('1'B); End Equivalence; External: Procedure; /* FORTRAN EXTERNAL STATEMENT */ Call Scan ('0'B); Call Typelist (' ENTRY '); Call Scan ('1'B); End External; Double: Procedure; /* FORTRAN DOUBLE PRECISION DECLARATION */ Call Scan ('0'B); /* To discard the keyword 'PRECISION'. */ Call Typ (' FLOAT BINARY (53) '); End Double; Data: Procedure; /* FORTRAN DATA STATEMENT */ Declare Work character (40) varying; /* 7/10/2009 */ Declare Constant character (40) varying controlled; Declare Name character (6) varying controlled; Declare Save_Next character (72) varying; Call Error ('FORTRAN DATA STATEMENT PARTIALLY TRANSLATED'); DO UNTIL (LINE = '' ); call scan ('0'b); if IS_LETTER ( substr(Next, 1, 1) ) then do; position = enter (Next); call scan ('0'b); if Next = '/' then /* Expect constant(s) */ do; work = ''; do until (Next = '/'); Save_next = Next; call scan ('0'b); if Next = '*' then /* we have a repeat factor */ do; work = substr(work, 1, length(work)-length(save_next) ); work = work || '(' || Save_Next || ')' ; end; else work = work || Next; end; work = substr(work, 1, length(work)-1 ); /* Discard the slash */ initial_value(Position) = work; put skip list ('The initial value(s) ' || work || ' has/have been inserted in symbol table'); end; else if Next = ',' then /* Multiple names. */ do; allocate name; Name = symbol(position); put skip list ('Name ' || Name || ' stacked' ); Call Scan ('0'b); allocate name; name = Next; put skip list ('Name ' || Next || ' stacked' ); do while (next ^= '/' ); call scan ('0'b); if Next = '/' then leave; if Next ^= ',' then /* We assume that it's a name */ do; allocate name; Name = Next; put skip list ('Name ' || Next || ' stacked' ); end; end; /* At this point, we have a list of stacked names. */ /* Now process the list of constants. */ call scan ('0'b); put skip list ('Ready to process constants'); Work = ''; do until (Next = '/'); work = work || Next; Call Scan ('0'B); if Next = ',' | Next = '/' then do; allocate constant; constant = work; put skip list ('Constant ' || Work || ' stacked'); work = ''; if Next = ',' then call scan ('0'b); end; if Next = '/' then leave; end; /* At this point, we have two stacks: */ /* Name has names of variables; */ /* Constant has corresponding constant values */ /* We now store those values in symbol table. */ if allocation(Name) ^= Allocation(Constant) then call error ('The ' || trim(allocation(name)) || ' name(s) do not correspond with ' || trim(allocation(constant)) || ' constant(s)'); do while (allocation(Name) > 0); Position = enter (Name); If allocation(constant) > 0 then Initial_Value(Position) = Constant; else call error ('Insufficnent constants in list'); free name; if allocation(Constant) > 0 then free constant; end; /* Free any constant values remaining. */ do while (allocation(Constant) > 0 ); Free Constant; end; end; else call error ('Syntax error in DATA statement'); end; END; Call Scan ('1'B); End Data; Typelist: Procedure (Type); /* SYMBOL TABLE BUILDING */ Declare Type Character (22) Varying; Declare I fixed binary; /* 5/10/2009 */ Do While (Next ^= '' & Next ^= '/'); Call Fortiden; Do I = 1 To Symlength; If Symbol(I) = Next Then Go To Got; End; Symlength, I = Symlength + 1; Got: If Type ^= '' & Type ^= ' EXTERNAL ' Then Symtype(I) = Type; If Type = ' EXTERNAL ' Then Symcom(I) = Type; Symbol(I) = Next; Call Scan ('0'B); If Next = '(' Then Do; Word = '('; Do While (Next ^= ')'); Call Scan ('0'B); Word = Word || Next; End; Call Scan ('0'B); Symdim(I) = Word; End; If Next = '/' Then Return; Call Scan ('0'B); End; End Typelist; Typeargs: Procedure (Type); /* ADDING ARGUMENTS TO THE SYMBOL TABLE */ Declare Type Character (22) Varying; Declare I fixed binary; /* 5/10/2009 */ Call Fortiden; Do I = 1 To Symlength; If Symbol(I) = Next Then Go To Got; End; Symlength, I = Symlength + 1; Got: Symtype(I) = Type; Symbol(I) = Next; End Typeargs; Typ: Procedure (Type); /* SYMBOL TABLE BUILDING */ Declare Type Character (22) Varying; Call Scan ('0'B); If Next = 'FUNCTION' Then Do; Call Function (Type); Return; End; Call Typelist (Type); Call Scan ('1'B); End Typ; Call: Procedure; /* FORTRAN CALL STATEMENT */ Call Scan ('0'B); Word = Next; /* 7/10/2009 */ If Line = '' then /* It's a CALL statement without arguments. */ do; Word = 'CALL ' || Word ; Call Disk (Lab || Word || ';'); Call Scan ('1'B); Return; end; Call Scan ('0'B); Do While (Next ^= ')'); Word = Word || Next; If Next = ',' Then Word = Word || ' '; /* 7/10/2009 */ Call Scan ('0'B); Word = Word || Expression; End; If Word ^= 'EXIT' Then Word = 'CALL ' || Word || ')'; Call Disk (Lab || Word || ';'); Call Scan ('1'B); End Call; /* PROGRAM STATEMENT */ Program_Statement: Procedure; Call Scan ('0'B); Call Fortiden; Current_procedure_name, Functname = Next; Call STACK ( ' ' ); Call STACK ( ' (SUBSCRIPTRANGE):' ); /* Put File (Declist) List (' (SUBSCRIPTRANGE):' ); */ Call STACK ( ' ' || Functname || ':PROCEDURE OPTIONS (REORDER);' ); /* Put File (Declist) List (' ' || Functname || */ /* ':PROCEDURE OPTIONS (REORDER);' ); */ Call Scan ('1'B); end Program_Statement; Subroutine: Procedure; /* SUBROUTINE DECLARATION */ Call Scan ('0'B); Call Fortiden; Current_procedure_name, /* 6/10/2009 */ Functname = Next; /* 7/10/2009 */ Call STACK ( ' ' ); Call STACK ( ' (SUBSCRIPTRANGE):' ); /* Put File (Declist) List (' (SUBSCRIPTRANGE):' ); */ If Line = '' then /* It's a SUBROUTINE statement without arguments. */ do; Call STACK ( ' ' || Functname || ':PROCEDURE OPTIONS (REORDER);' ); /* Put File (Declist) List (' ' || Functname || */ /* ':PROCEDURE OPTIONS (REORDER);' ); */ Call Scan ('1'B); Return; end; Call Arglist; Call STACK ( ' ' || Functname || ':PROCEDURE' || Word || ' OPTIONS(REORDER);' ); /* Put File (Declist) List (' ' || Functname || ':PROCEDURE' || */ /* Word || ' OPTIONS(REORDER);' ); */ Call Scan ('1'B); End Subroutine; Function: Procedure (Type); /* FUNCTION DECLARATION */ Declare Type Character (22) Varying; /* The type can be: */ /* 'FIXED BINARY' */ /* 'FLOAT BINARY' */ /* 'FLOAT BINARY (53)' */ /* 'COMPLEX FLOAT BINARY' */ /* 'BIT(1)' */ Call Scan ('0'B); Current_procedure_name, /* 6/10/2009 */ Functname = Next; Position = ENTER (Functname || '#' ); /* 9/10/2009 */ Symtype(Position) = Type; /* 9/10/2009 */ Symdim(Position), Symcom(Position), Initial_value(Position) = ''; Funct = '1'B; /* 7/10/2009 */ Call STACK ( ' ' ); Call STACK ( ' (SUBSCRIPTRANGE):' ); /* Put File (Declist) List ( ' (SUBSCRIPTRANGE):' ); */ If Line = '' then /* It's a FUNCTION statement without arguments. */ do; Call STACK ( ' ' || Functname || ': PROCEDURE RETURNS (' || Type || ') OPTIONS (REORDER);' ); /* Put File (Declist) List (' ' || Functname || */ /* ': PROCEDURE RETURNS (' || Type || ') OPTIONS (REORDER);' ); */ Call Scan ('1'B); Return; end; Call Arglist; Call STACK ( ' ' || Functname || ': PROCEDURE ' || Word || ' RETURNS (' || Type || ');'); /* Put File (Declist) List (' ' || Functname || ': PROCEDURE ' || */ /* Word || ' RETURNS (' || Type || ');'); */ Call Scan ('1'B); End Function; Dump_Symbol_Table: procedure; declare i fixed binary; put skip list ('SYMBOL TABLE'); do i = 1 to symlength; put skip list (Symbol(i), symtype(i)); end; End Dump_Symbol_table; Entry: Procedure; /* ENTRY DECLARATION */ Declare Entryname Character (6) Varying; Call Scan ('0'B); Call Fortiden; Entryname = Next; Call Arglist; Call Disk (Lab || Entryname || ': ENTRY' || Word || ';'); Call Scan ('1'B); End Entry; Arglist: Procedure; /* ARGUMENT LIST PROCESSING */ Declare I fixed binary; Word = ''; Do While (Next ^= ')'); Call Scan ('0'B); if Next ^= ',' & Next ^= ')' & Next ^= '(' then /* 6/10/2009 */ do; /* We have a dummy argument. Enter it into the symbol table. */ do I = 1 to Symlength; if Next = Symbol(i) then go to found_identifier; end; /* Add the identifier to the symbol table. */ if symlength < HBOUND(symbol, 1) Then symlength = symlength + 1; symbol(symlength) = Next; end; found_identifier: Word = Word || Next; if Next = ',' then Word = Word || ' '; End; End Arglist; Return: Procedure; /* FORTRAN RETURN STATEMENT */ If Funct = '0'B Then Call Disk (Lab || 'RETURN;'); Else Call Disk (Lab || 'RETURN (' || Functname || '#);'); Call Scan ('1'B); End Return; Readwrite: Procedure (Rw); /* FORTRAN READ AND WRITE STATEMENTS */ Declare Rw Character (3); Call Scan ('0'B); If Next ^= '(' Then Call Error ('MISSING LEFT PAREN IN READ'); Call Scan ('0'B); If Next = '6' Then Unit = 'SYSPRINT'; Else If Next = '5' Then Unit = 'SYSIN'; Else Do; Call Typeargs (' FILE '); Next, Unit = 'FILE' || Next; End; Call Scan ('0'B); If Next = ',' Then Do; Call Scan ('0'B); Le = ' EDIT'; /* 6/10/2009 */ Fmt# = ' (R(#' || Next || '))'; /* 9/10/2009 */ Call Scan ('0'B); End; Else Do; Le = ' LIST'; /* 6/10/2009 */ Fmt# = ''; End; Call Scan ('0'B); Call List; Call Disk (Lab || Rw || ' FILE (' || Unit || ')' || Le || Iostring || Fmt# || ';'); Call Scan ('1'B); End Readwrite; Format: Procedure; /* FORTRAN FORMAT STATEMENTS */ Iostring = 'FORMAT '; Call Fmtlist; Call Disk (Lab || Iostring || ';'); Call Scan ('1'B); End Format; Fmtlist: Procedure; /* FORMAT SPECIFICATION LISTS */ Declare Holl Bit(1); Declare I fixed binary; /* 5/10/2009 */ Holl = '0'B; Fmt1: Call Scan ('0'B); Fmt2: If Next = '' Then Do; If Holl = '1'B Then Call Error ('HOLLERITH STRING IS NOT PERMITTED IN PL/I FORMAT'); /* Insert SKIP at end of format specification, in order to */ /* faithfully reproduce FORTRAN's action. */ /* The format specification is held in IOSTRING. */ IF SUBSTR(IOSTRING, LENGTH(IOSTRING), 1) = ')' THEN DO; IOSTRING = SUBSTR(IOSTRING, 1, LENGTH(IOSTRING) - 1) || ', SKIP)' ; END; Return; End; If Next = '/' Then Do; If Substr(Iostring, Length(Iostring), 1) = ',' | Substr(Iostring, Length(Iostring), 1) = '(' Then Len = ''; Else Len = ','; Call Scan ('0'B); If Next = ',' | Next = ')' Then Lem = ''; Else Lem = ','; Iostring = Iostring || Len || 'SKIP' || Lem; Go To Fmt2; End; If Next = '(' | Next = ',' | Next = ')' Then Do; Iostring = Iostring || Next; Go To Fmt1; End; If IS_DIGIT(Next) Then /* 6/10/2009 */ Go To Num; If Next = 'I' Then Len = 'F'; Else If Next = 'G' | Next = 'D' Then Len = 'E'; Else If Next = 'L' Then Len = 'B'; Else Len = Next; Iostring = Iostring || ' ' || Len; /* 5/10/2009 */ /* Insert a blank after any repeat factor. */ /* It does this by inserting a blank before */ /* the letters, I, F, G, L, B. */ If Next = 'I' | Next = 'L' | Next = 'A' Then Do; Call Scan ('0'B); Iostring = Iostring || '(' || Next || ')'; Go To Fmt1; End; Call Scan ('0'B); Iostring = Iostring || '(' || Next || ','; Call Scan ('0'B); Call Scan ('0'B); Iostring = Iostring || Next || ')'; Go To Fmt1; Num: Len = Next; Call Scan ('0'B); If Substr(Next, 1, 1) = 'H' Then Do; I = Len; Line = Substr(Line, I - Length(Next) + 2); Call Scan ('0'B); If Next = ',' Then Call Scan ('0'B); Else If Substr(Iostring, Length(Iostring), 1) = ',' Then Iostring = Substr(Iostring, 1, Length(Iostring) - 1); Holl = '1'B; Go To Fmt2; End; If Next = 'X' Then Do; Iostring = Iostring || 'X(' || Len || ')'; Go To Fmt1; End; If Next = 'P' Then Go To Fmt1; Iostring = Iostring || Len; Go To Fmt2; End Fmtlist; List: Procedure; /* READ AND WRITE LISTS */ on STRINGRANGE snap system; Iostring = ''; Do While (Next ^= ''); /* Enter data list identifiers into the symbol table if they are */ /* not already there. 6/10/2009 */ if IS_LETTER(substr(Next, 1, 1)) then Discard = Enter(Next); /* Does not handle IMPLIED DO */ Call Element; Iostring = Iostring || Varstring; Call Scan ('0'B); End; If Iostring ^= '' Then Iostring = '(' || Iostring || ')'; End List; Element: Procedure Recursive; /* READ AND WRITE LIST ELEMENTS */ on STRINGRANGE snap system; If Next = '(' Then Do; Call Impdo; Call Scan ('0'B); If Next ^= '' Then Varstring = Varstring || ', '; /* 6/10/2009 */ Return; End; Call Variable ('0'B); If Next ^= '' Then Varstring = Varstring || ', '; /* 6/10/2009 */ End Element; Impdo: Procedure Recursive; /* READ AND WRITE IMPLIED DO LISTS */ Declare Impdovar Character (6) Varying; on STRINGRANGE snap system; Iostring = Iostring || '('; Call Scan ('0'B); El: Call Element; If Next = '=' Then Do; /* Don't know why yet, but there is a blank at end of variables */ /* VARSTRING and IOSTRING */ /* that prevents a comma from being deleted from the variables. */ /* Temporarily remove it: 6/10/2009 */ Varstring = trim(Varstring, '', ' '); Iostring = trim(Iostring, '', ' '); Impdovar = Substr(Varstring, 1, Length(Varstring) - 1); Discard = ENTER (Impdovar); /* 6/10/2009 */ /* Enters the implied do-variable in the symbol table. */ Call Scan ('0'B); Iostring = Substr(Iostring, 1, Length(Iostring) - 1); Iostring = Iostring || ' DO ' || Impdovar || '=' || Next || ' TO '; If IS_LETTER(substr(Next, 1, 1)) then /*9/10/2009 */ Discard = ENTER (Next); Call Scan ('0'B); Call Scan ('0'B); Iostring = Iostring || Next; If IS_LETTER(substr(Next, 1, 1)) then /*9/10/2009 */ Discard = ENTER (Next); Call Scan ('0'B); If Next = ')' Then Iostring = Iostring || ')'; Else Do; Call Scan ('0'B); Impdovar = Next; Call Scan ('0'B); Iostring = Iostring || ' BY ' || Impdovar || ')'; End; Varstring = ''; Return; End; Iostring = Iostring || Varstring; Call Scan ('0'B); Go To El; End Impdo; Backspace: Procedure; /* FORTRAN BACKSPACE STATEMENT */ Call Error('NO EQUIVALENT FOR BACKSPACE IN PL/I'); Call Scan ('1'B); End Backspace; Rewind: Procedure; /* FORTRAN REWIND AND ENDFILE STATEMENTS */ Call Scan('0'B); Call Disk (Lab || 'CLOSE FILE (FILE' || Next || ');'); Call Scan ('1'B); End Rewind; Do: Procedure; /* FORTRAN DO STATEMENTS */ DECLARE Initial_Value character (72) varying; Call Scan ('0'B); Dopoint = Dopoint + 1; Docount(Dopoint) = Next; Call Scan ('0'B); Call Fortiden; Discard = ENTER (Next); /* 6/10/2009 */ /* Enters the Do-variable in the symbol table. */ Word = 'DO ' || Next || '='; Call Scan ('0'B); Call Scan ('0'B); If ^IS_DIGIT (Substr(Next, 1, 1)) Then /* 6/10/2009 */ Call Fortiden; Initial_value = Next; Word = Word || Next; Call Scan ('0'B); Call Scan ('0'B); If ^IS_DIGIT (Substr(Next, 1, 1)) Then /* 6/10/2009 */ Call Fortiden; Word = Word || ' TO ' || Next; Call Scan ('0'B); If Next = ',' Then Do; Call Scan ('0'B); If ^IS_DIGIT(Substr(Next, 1, 1)) Then /* 6/10/2009 */ Call Fortiden; Call Disk (Lab || Word || ' BY ' || Next || ';'); End; Else Call Disk (Lab || Word || ';'); Tab = Tab || ' '; Call Scan ('1'B); End Do; If: Procedure; /* FORTRAN ARITHMETIC AND LOGICAL IF STATEMENTS */ Declare (Num1, Num2, Num3) Character (6) Varying; Call Scan ('0'B); Word = Expression; /* TEST FOR LOGICAL IF STATEMENT */ If ^IS_DIGIT (Substr(Next, 1, 1)) Then /* 6/10/2009 */ Do; Call Disk (Lab || 'IF ' || Word || ' THEN '); Call Statement; Return; End; /* ARITHMETIC IF STATEMENT */ Num1 = Next; Call Scan ('0'B); Call Scan ('0'B); Num2 = Next; Call Scan ('0'B); Call Scan ('0'B); Num3 = Next; if Num1 = Num2 then do; Call Disk(Lab || 'IF ' || Word || ' > 0 THEN ' || 'GO TO #' || Num3 || ';'); Call Disk ('ELSE GO TO #' || Num1 || ';'); end; else if Num2 = Num3 then do; Call Disk(Lab || 'IF ' || Word || ' >= 0 THEN ' || 'GO TO #' || Num3 || ';'); Call Disk ('ELSE GO TO #' || Num1 || ';'); end; else if Num1 = Num3 then do; Call Disk(Lab || 'IF ' || Word || ' = 0 THEN ' || 'GO TO #' || Num2 || ';'); Call Disk ('ELSE GO TO #' || Num1 || ';'); end; else do; Call Disk(Lab || 'IF ' || Word || ' > 0 THEN ' || 'GO TO #' || Next || ';'); Call Disk('ELSE IF ' || Word || ' = 0 THEN GO TO #' || Num2 || ';'); Call Disk ('ELSE GO TO #' || Num1 || ';'); end; Call Scan ('1'B); End If; Assign: Procedure; /* FORTRAN ASSIGN STATEMENT */ Declare Num Character (6) Varying; Call Scan ('0'B); Num = Next; Call Scan ('0'B); If Next ^= 'TO' Then Call Error('MISSING IN ASSIGN'); Call Scan ('0'B); Call Fortiden; Call Disk (Lab || Next || '=#' || Num || ';'); Call Scan ('1'B); End Assign; Go: Procedure; /* FORTRAN COMPUTED,ASSIGNED, AND UNCONDITIONAL GO TO */ Declare (Num, Mum) Character (9); Declare (I, J) fixed binary; /* 5/10/2009 */ Call Scan ('0'B); If Next ^= 'TO' Then Call Error('MISSING IN GO TO STATEMENT'); Call Scan ('0'B); If Substr(Next, 1, 1) >= '0' & /*20090917*/ Substr(Next, 1, 1) <= '9' Then /*20090917*/ Do; /* UNCONDITIONAL GO TO STATEMENT */ Call Disk (Lab || 'GO TO #' || Next || ';'); Call Scan ('1'B); Return; End; /* COMPUTED GO TO STATEMENT */ If Next = '(' Then Do; I = 0; Word = Next; Do While (Next ^= ')'); Call Scan ('0'B); I = I + 1; Word = Word || '#' || Next; Call Scan ('0'B); Word = Word || Next; End; Call Scan ('0'B); If Next ^= ',' Then Call Error('MISSING COMMA IN COMP GO TO'); Call Scan ('0'B); Call Fortiden; Lac = Lac + 1; Num = Lac; J, Symlength = Symlength + 1; Symbol(J) = 'LAB' || Substr(Num, 9, 1); Mum = I; Symdim(J) = '(' || Substr(Mum, 9, 1) || ')'; Symcom(J) = ' INITIAL ' || Word; Symtype(J) = ' LABEL '; Call Disk(Lab || 'GO TO LAB' || Substr(Num, 9, 1) || '(' || Next || ');'); Call Scan ('1'B); Return; End; /* ASSIGNED GO TO STATEMENT */ Call Typeargs (' LABEL '); Call Disk (Lab || 'GO TO ' || Next || ';'); Call Scan ('1'B); End Go; Stop: Procedure; /* FORTRAN STOP STATEMENT */ Call Disk (Lab || 'STOP;'); Call Scan ('1'B); End Stop; Pause: Procedure; /* FORTRAN PAUSE STATEMENT */ Call Scan ('0'B); Call Disk (Lab || 'DISPLAY (''PAUSE' || Next || ''');'); Call Scan ('1'B); End Pause; Continue: Procedure; /* FORTRAN CONTINUE STATEMENT */ Call Disk (Lab || ''); Call Scan ('1'B); End Continue; Label: Procedure; /* LABEL PROCESSING */ Declare (I, J) fixed binary; /* 5/10/2009 */ Labcount = 0; If Col1 = ' ' Then Labstr = ''; Else Labstr = Col1; Do I = 1 To 4; If Substr(Col25, I, 1) ^= ' ' Then Labstr = Labstr || Substr(Col25, I, 1); End; Do J = 1 To Dopoint; If Docount(J) = Labstr Then Labcount = Labcount + 1; End; Lab = '#' || Labstr || ': '; End Label; IS_DIGIT: PROCEDURE (C) RETURNS ( BIT(1) ALIGNED ); DECLARE C CHARACTER(1); DECLARE I FIXED BINARY (7); I = INDEX('0123456789', C); RETURN (I > 0); END IS_DIGIT; IS_LETTER: PROCEDURE (C) RETURNS ( BIT(1) ALIGNED ); DECLARE C CHARACTER(1); DECLARE I FIXED BINARY (7); I = INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', C); RETURN (I > 0); END IS_LETTER; ENTER: PROCEDURE (S) RETURNS (FIXED BINARY); DECLARE S CHARACTER (*) VARYING; DECLARE I fixed binary; do i = 1 to symlength; if S = symbol(i) then return (i); end; /* Did not find identifier in symbol table, so add it. */ If Symlength < HBOUND(Symbol) Then Symlength = Symlength + 1; else Call Error ('Symbol Table Overflow'); symbol(Symlength) = S; symtype(Symlength), Symcom(Symlength), Symdim(Symlength) = ''; Return (Symlength); END ENTER; UPPERCASE: PROCEDURE (S) RETURNS (CHARACTER (32767) VARYING); DECLARE S CHARACTER (*) VARYING; RETURN (TRANSLATE(S, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 'abcdefghijklmnopqrstuvwxyz') ); END UPPERCASE; /* Procedures to simulate a sequential file for declarations. */ DECLARE DECLARATIONS CHARACTER (REC_LEN) VARYING CONTROLLED; DECLARE DEC_FILE CHARACTER (REC_LEN) VARYING CONTROLLED; DECLARE REC_LEN FIXED BINARY; STACK: PROCEDURE (S); DECLARE S CHARACTER (*) VARYING; REC_LEN = LENGTH(S); ALLOCATE DECLARATIONS; DECLARATIONS = S; END STACK; /* This procedure unstacks DECLARATIONS and re-allocates the contents */ /* so that the contents are in the reverse order, ready for printing. */ UNSTACK: PROCEDURE; DO WHILE ( ALLOCATION(DECLARATIONS) > 0 ); REC_LEN = LENGTH(DECLARATIONS); ALLOCATE DEC_FILE; dec_file = declarations; FREE DECLARATIONS; END; /* Upon exit, DEC_FILE holds the content of DECLARATIONS, in the */ /* reverse order. */ END UNSTACK; OUT_DECLARATIONS: PROCEDURE; DO WHILE ( ALLOCATION(DEC_FILE) > 0 ); PUT FILE (SYSPRINT) LIST (DEC_FILE) SKIP; PUT FILE (PUNLIST) LIST (DEC_FILE) SKIP; FREE DEC_FILE; END; END OUT_DECLARATIONS; /* Procedures to simulate a sequential file for executable statements. */ DECLARE EXECUTABLES CHARACTER (REC_LEN) VARYING CONTROLLED; DECLARE PRG_FILE CHARACTER (REC_LEN) VARYING CONTROLLED; STACK_EX: PROCEDURE (S); DECLARE S CHARACTER (*) VARYING; REC_LEN = LENGTH(S); ALLOCATE EXECUTABLES; EXECUTABLES = S; END STACK_EX; /* This procedure unstacks DECLARATIONS and re-allocates the contents */ /* so that the contents are in the reverse order, ready for printing. */ UNSTACK_EX: PROCEDURE; DO WHILE ( ALLOCATION(EXECUTABLES) > 0 ); REC_LEN = LENGTH(EXECUTABLES); ALLOCATE PRG_FILE; Prg_file = executables; FREE EXECUTABLES; END; /* Upon exit, DEC_FILE holds the content of DECLARATIONS, in the */ /* reverse order. */ END UNSTACK_EX; OUT_EXECUTABLES: PROCEDURE; DO WHILE ( ALLOCATION(PRG_FILE) > 0 ); PUT FILE (SYSPRINT) LIST (PRG_FILE) SKIP; PUT FILE (PUNLIST) LIST (PRG_FILE) SKIP; FREE PRG_FILE; END; END OUT_EXECUTABLES; /* MAIN DRIVER WHICH CALL PROCEDURE 'PROGRAM' FOR EACH FORTRAN MAIN OR SUBPROGRAM IN THE INPUT STREAM */ On Endfile (Sysin) Go To Nextb; Outputline, Line = ''; Newcard = '0'B; Nexta: Call Program; Go To Nexta; Nextb: Put File (Sysprint) List ('END OF INPUT') Skip(3); End F#to#p;