C FILE= RAT3.RAT C C EDITED TO PUT SUBPROGRAM DECLARATIONS IN FRONT OF COMMENTS FOR THAT C SUBPROGRAM. THIS ALLOWS F4 V2.2 TO KEEP COMMENTS IN THE RIGHT PLACE. C BOB DENNY C 25-MAR-80 C CFILE=DEFIN.RAT ===== GENERAL CHARACTER SET DEFINITIONS =============== C PCN #73, DEC 79, ADD CARET,TILDE FOR .NOT. C C ****************** C FILE=RATDEF.RT C ****************** C C==============DEFINITIONS FOR RT-11 RATFOR PREPROCESSOR=============== C CLINK LIBRARY FOR COMPILE/LINK/GO OPTION C C=========================================================================== C SUBROUTINE OUTCON ( N ) C OUTCON - GENERATE "N CONTINUE" CODE C C INTEGER N C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C LOGICAL * 1 CONU (9) LOGICAL * 1 CONL (9) C DATA CONU/1HC,1HO,1HN,1HT,1HI,1HN,1HU,1HE,0/ DATA CONL/1Hc,1Ho,1Hn,1Ht,1Hi,1Hn,1Hu,1He,0/ IF (.NOT.( N .GT. 0 )) GOTO 20000 CALL OUTNUM ( N ) 20000 CONTINUE CALL OUTTAB IF (.NOT.( LC .EQ. 1 )) GOTO 20002 CALL OUTSTR ( CONL ) GOTO 20003 20002 CONTINUE CALL OUTSTR ( CONU ) 20003 CONTINUE CALL OUTDON C RETURN END SUBROUTINE OUTDON C C OUTDON - FINISH OFF A FORTRAN CODE (OUTPUT) LINE C PCN #77, 5 JAN 80, DELETE 'NEWLINE' CHARACTER AT END OF LINE. C C C FILE= COUTLN.RAT FOR RATFOR.RAT COMMON / COUTLN / OUTP, OUTBUF ( 91 ) INTEGER OUTP LOGICAL * 1 OUTBUF C IF (.NOT.( OUTP .LT. 0 )) GOTO 20004 OUTP = IABS ( OUTP ) C# OUTBUF(OUTP+1) = NEWLINE #PCN #77 20004 CONTINUE OUTBUF ( OUTP + 1 ) = 0 CALL PUTLIN ( OUTBUF, 8, 0 ) OUTP = 0 C RETURN END SUBROUTINE OUTGO ( N ) C C OUTGO - GENERATE "GOTO N" CODE C PCN#56, 14 APR 79, DROP BLANK AFTER 'GOTO' IF COMPRESSING C C INTEGER N C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C LOGICAL * 1 GOTOU (5) LOGICAL * 1 GOTOL (5) C DATA GOTOU/1HG,1HO,1HT,1HO,0/ DATA GOTOL/1Hg,1Ho,1Ht,1Ho,0/ CALL OUTTAB IF (.NOT.( LC .EQ. 1 )) GOTO 20006 CALL OUTSTR ( GOTOL ) GOTO 20007 20006 CONTINUE CALL OUTSTR ( GOTOU ) 20007 CONTINUE IF (.NOT.( COMPRS .EQ. 0 )) GOTO 20008 CALL OUTCH ( 32 ) 20008 CONTINUE CALL OUTNUM ( N ) CALL OUTDON C RETURN END SUBROUTINE OUTIF C C OUTIF - GENERATE "IF (.NOT." CODE FOR 'FOR' AND 'IF' STATEMENTS C SYKES,18FEB77 C PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING C PCN #76, DEC 79, FIX BUG IN DUMPIN/OUTIF. NOT NUMBERING IF'S RIGHT C C C FILE=CPRTLN.RAT FOR RATFOR COMMON / CPRTLN / FORTYP, IFTYP, READY, PRTBUF ( 91 ) INTEGER FORTYP INTEGER IFTYP INTEGER READY LOGICAL * 1 PRTBUF C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C C LOGICAL * 1 IFNOTU (10) LOGICAL * 1 IFNOTL (10) C DATA IFNOTU/1HI,1HF,1H ,1H(,1H.,1HN,1HO,1HT,1H.,0/ DATA IFNOTL/1Hi,1Hf,1H ,1H(,1H.,1Hn,1Ho,1Ht,1H.,0/ CALL OUTTAB IF (.NOT.( LC .EQ. 1 )) GOTO 20010 CALL OUTSTR ( IFNOTL ) GOTO 20011 20010 CONTINUE CALL OUTSTR ( IFNOTU ) C 20011 CONTINUE IFTYP = 1 C RETURN END SUBROUTINE OUTNUM ( N ) C C OUTNUM - OUTPUT DECIMAL NUMBER TO FORTRAN CODE FILE C C LOGICAL * 1 CHARS ( 8 ) INTEGER JUNK, LEN, N, SITOC C JUNK = SITOC ( N, CHARS, 8 ) CALL OUTSTR ( CHARS ) C RETURN END SUBROUTINE OUTSTR ( STR ) C C OUTSTR - OUTPUT A STRING TO FORTRAN CODE FILE C ALSO CONVERT DOUBLE QUOTED STRINGS TO HOLLERITH. C PASS SINGLE QUOTED STRINGS UNPROCESSED. C C LOGICAL * 1 C, STR ( 1 ), CHARS ( 8 ) INTEGER I, J, SLEN, LEN, K, SITOC C C FILE= COUTLN.RAT FOR RATFOR.RAT COMMON / COUTLN / OUTP, OUTBUF ( 91 ) INTEGER OUTP LOGICAL * 1 OUTBUF C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C I = SLEN ( STR ) IF (.NOT.( ( OUTP + I .GE. 72 ) .AND. ( OUTP .GT. 6 ) )) GOTO $20012 OUTP = - OUTP 20012 CONTINUE I = 1 20014 IF (.NOT.( STR ( I ) .NE. 0)) GOTO 20016 C = STR ( I ) IF (.NOT.( C .NE. 34 )) GOTO 20017 CALL OUTCH ( C ) GOTO 20018 20017 CONTINUE I = I + 1 CONTINUE J = I 20019 IF (.NOT.( STR ( J ) .NE. C)) GOTO 20021 20020 J = J + 1 GOTO 20019 20021 CONTINUE LEN = SITOC ( J - I, CHARS, 8 ) CONTINUE K = 1 20022 IF (.NOT.( K .LE. LEN)) GOTO 20024 CALL OUTCH ( CHARS ( K ) ) 20023 K = K + 1 GOTO 20022 20024 CONTINUE IF (.NOT.( LC .EQ. 1 )) GOTO 20025 CALL OUTCH ( 104 ) GOTO 20026 20025 CONTINUE CALL OUTCH ( 72 ) 20026 CONTINUE CONTINUE 20027 IF (.NOT.( I .LT. J)) GOTO 20029 CALL OUTCH ( STR ( I ) ) 20028 I = I + 1 GOTO 20027 20029 CONTINUE 20018 CONTINUE C 20015 I = I + 1 GOTO 20014 20016 CONTINUE RETURN END SUBROUTINE OUTTAB C C OUTTAB - GENERATE A TAB AT BEGINNING OF FORTRAN LINE C PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING C C C FILE= COUTLN.RAT FOR RATFOR.RAT COMMON / COUTLN / OUTP, OUTBUF ( 91 ) INTEGER OUTP LOGICAL * 1 OUTBUF C C FILE = CLINE.RAT FOR RATFOR.RAT C PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING COMMON / CLINE / LEVEL, INFILE ( 3 ), LINECT, INIF, FTNLN INTEGER LEVEL INTEGER INFILE INTEGER LINECT INTEGER INIF INTEGER FTNLN C 20030 IF (.NOT.( OUTP .LT. 6 )) GOTO 20031 CALL OUTCH ( 32 ) C GOTO 20030 20031 CONTINUE IF (.NOT.( OUTP .EQ. 6 )) GOTO 20032 FTNLN = FTNLN + 1 C 20032 CONTINUE RETURN END SUBROUTINE PARSE C C PARSE - PARSE RATFOR SOURCE PROGRAM, CALL ROUTINES TO GENERATE CODE C PCN # 93, 17 FEB 80, MOVE FINDING PROCESSOR FEATURES HERE FROM GETTOK. C PCN #92, 20 FEB 80, ADD RETURN (EXPRESSION). C C LOGICAL * 1 LEXSTR ( 70 ), LAST INTEGER LEX, STRNGS INTEGER LAB, LABVAL ( 100 ), LEXTYP ( 100 ), SP, TOK DATA STRNGS / 0 / C SP = 1 LEXTYP ( 1 ) = - 3 TOK = LEX ( LEXSTR ) 20034 IF (.NOT.( TOK .NE. - 3)) GOTO 20036 IF (.NOT.( STRNGS .EQ. 1 .AND. TOK .NE. - 130 .AND. TOK .NE. 59 ) $) GOTO 20037 CALL ENDSTR STRNGS = 0 20037 CONTINUE IF (.NOT.( TOK .EQ. - 116 )) GOTO 20039 CALL IFCODE ( LAB ) GOTO 20040 20039 CONTINUE IF (.NOT.( TOK .EQ. - 124 .OR. TOK .EQ. - 125 )) GOTO 20041 CALL ADDDEF ( LEXSTR, 70 ) GOTO 20042 20041 CONTINUE IF (.NOT.( TOK .EQ. - 112 )) GOTO 20043 CALL DOCODE ( LAB ) GOTO 20044 20043 CONTINUE IF (.NOT.( TOK .EQ. - 111 )) GOTO 20045 CALL LABELC ( LEXSTR ) GOTO 20046 20045 CONTINUE IF (.NOT.( TOK .EQ. - 114 )) GOTO 20047 CALL ENDCOD ( LEXSTR, SP ) GOTO 20048 20047 CONTINUE IF (.NOT.( TOK .EQ. - 128 )) GOTO 20049 GOTO 20050 20049 CONTINUE IF (.NOT.( TOK .EQ. - 126 )) GOTO 20051 CALL IFDEFC ( 1 ) GOTO 20052 20051 CONTINUE IF (.NOT.( TOK .EQ. - 127 )) GOTO 20053 CALL IFDEFC ( 0 ) GOTO 20054 20053 CONTINUE IF (.NOT.( TOK .EQ. - 129 )) GOTO 20055 CALL OPENI GOTO 20056 20055 CONTINUE IF (.NOT.( TOK .EQ. - 115 )) GOTO 20057 CALL FORCOD ( LAB, SP ) GOTO 20058 20057 CONTINUE IF (.NOT.( TOK .EQ. - 119 )) GOTO 20059 CALL REPCOD ( LAB, SP ) GOTO 20060 20059 CONTINUE IF (.NOT.( TOK .EQ. - 130 )) GOTO 20061 STRNGS = 1 CALL STRNGC GOTO 20062 20061 CONTINUE IF (.NOT.( TOK .EQ. - 113 )) GOTO 20063 IF (.NOT.( LEXTYP ( SP ) .EQ. - 116 )) GOTO 20065 CALL ELSEIF ( LABVAL ( SP ), LAST ) GOTO 20066 20065 CONTINUE CALL SYNERR ( 13HILLEGAL ELSE. ) 20066 CONTINUE GOTO 20064 20063 CONTINUE IF (.NOT.( TOK .EQ. - 121 )) GOTO 20067 CALL WHILEC ( LAB, SP ) C CPCN#10, REMEMBER LAST STATEMENT (BUT DON'T LET ] INTERFEAR) 20067 CONTINUE 20064 CONTINUE 20062 CONTINUE 20060 CONTINUE 20058 CONTINUE 20056 CONTINUE 20054 CONTINUE 20052 CONTINUE 20050 CONTINUE 20048 CONTINUE 20046 CONTINUE 20044 CONTINUE 20042 CONTINUE 20040 CONTINUE IF (.NOT.( TOK .NE. 125 )) GOTO 20069 LAST = TOK C 20069 CONTINUE IF (.NOT.( TOK .EQ. - 116 .OR. TOK .EQ. - 113 .OR. TOK .EQ. - 121 $ .OR. TOK .EQ. - 115 .OR. TOK .EQ. - 119 .OR. TOK .EQ. - 112 $.OR. TOK .EQ. - 111 .OR. TOK .EQ. 123 )) GOTO 20071 SP = SP + 1 IF (.NOT.( SP .GT. 100 )) GOTO 20073 CALL ERROR ( 25HSTACK OVERFLOW IN PARSER. ) 20073 CONTINUE LEXTYP ( SP ) = TOK LABVAL ( SP ) = LAB GOTO 20072 20071 CONTINUE IF (.NOT.( TOK .EQ. 125 )) GOTO 20075 IF (.NOT.( LEXTYP ( SP ) .EQ. 123 )) GOTO 20077 SP = SP - 1 GOTO 20078 20077 CONTINUE CALL SYNERR ( 10HILLEGAL ]. ) 20078 CONTINUE GOTO 20076 20075 CONTINUE IF (.NOT.( TOK .EQ. - 118 .OR. TOK .EQ. - 123 )) GOTO 20079 CALL OTHERC ( LEXSTR ) GOTO 20080 20079 CONTINUE IF (.NOT.( TOK .EQ. - 122 )) GOTO 20081 CALL RETCOD ( LEXSTR ) GOTO 20082 20081 CONTINUE IF (.NOT.( TOK .EQ. - 110 .OR. TOK .EQ. - 117 )) GOTO 20083 CALL BRKNXT ( SP, LEXTYP, LABVAL, TOK ) C 20083 CONTINUE 20082 CONTINUE 20080 CONTINUE 20076 CONTINUE TOK = LEX ( LEXSTR ) CALL PBSTR ( LEXSTR ) CALL UNSTAK ( SP, LEXTYP, LABVAL, TOK, LAST ) 20072 CONTINUE C 20035 TOK = LEX ( LEXSTR ) GOTO 20034 20036 CONTINUE RETURN END SUBROUTINE PBSTR ( IN ) C C PBSTR - PUSH STRING BACK ONTO INPUT FOR LATER RE-INPUT C C LOGICAL * 1 IN ( 1 ) INTEGER I, SLEN C I = SLEN ( IN ) 20085 IF (.NOT.( I .GT. 0)) GOTO 20087 CALL PUTBAK ( IN ( I ) ) C 20086 I = I - 1 GOTO 20085 20087 CONTINUE RETURN END SUBROUTINE PUTBAK ( C ) C C PUTBAK - PUSH CHARACTER BACK ONTO INPUT FOR LATER RE-RETRIVAL C C LOGICAL * 1 C C C FILE = CDEFIO.RAT FOR RATFOR.RAT COMMON / CDEFIO / BP, BUF ( 160 ) INTEGER BP LOGICAL * 1 BUF C BP = BP + 1 IF (.NOT.( BP .GT. 160 )) GOTO 20088 CALL ERROR ( 24HPUSHBACK STACK OVERFLOW. ) GOTO 20089 20088 CONTINUE BUF ( BP ) = C C 20089 CONTINUE RETURN END SUBROUTINE RATGO ( SWITCH ) C C RATGO - RATFOR INITIALIZATION ROUTINE C SYKES 26 SEP 76 C C INTEGER SWITCH, JUNK, I, LABGEN C C FILE = CDEFIO.RAT FOR RATFOR.RAT COMMON / CDEFIO / BP, BUF ( 160 ) INTEGER BP LOGICAL * 1 BUF C C FILE = CFOR.RAT FOR RATFOR.RAT COMMON / CFOR / FORDEP, FORSTK ( 120 ), FORLEN INTEGER FORDEP LOGICAL * 1 FORSTK INTEGER FORLEN C C FILE=CFUNC.RAT FOR RATFOR COMMON / CFUNC / INFUNC, FNAM ( 12 ) INTEGER INFUNC LOGICAL * 1 FNAM C C FILE = CLINE.RAT FOR RATFOR.RAT C PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING COMMON / CLINE / LEVEL, INFILE ( 3 ), LINECT, INIF, FTNLN INTEGER LEVEL INTEGER INFILE INTEGER LINECT INTEGER INIF INTEGER FTNLN C C FILE = CLIST. RAT FOR RATFOR.RAT ; SYKES,26SEP76 COMMON / CLIST / LST ( 3 ), PLINE, PAGE, OUTPUT, ERRORS, IFPNT, $DEBUG INTEGER LST INTEGER PLINE INTEGER PAGE INTEGER ERRORS INTEGER OUTPUT INTEGER IFPNT INTEGER DEBUG C C FILE = CLOOK.RAT FOR RATFOR.RAT COMMON / CLOOK / LASTP, TWOS, LASTT, NAMPTR ( 200 ), TABLE ( 2200 $ ) INTEGER LASTP INTEGER TWOS INTEGER LASTT INTEGER NAMPTR LOGICAL * 1 TABLE C C FILE= COUTLN.RAT FOR RATFOR.RAT COMMON / COUTLN / OUTP, OUTBUF ( 91 ) INTEGER OUTP LOGICAL * 1 OUTBUF C C FILE=CPRTLN.RAT FOR RATFOR COMMON / CPRTLN / FORTYP, IFTYP, READY, PRTBUF ( 91 ) INTEGER FORTYP INTEGER IFTYP INTEGER READY LOGICAL * 1 PRTBUF C C FILE= CSTR.RAT FOR RATFOR COMMON / CSTR / LASTS, LASTR, STRPTR ( 20 ), TABLES ( 300 ) INTEGER LASTS INTEGER LASTR INTEGER STRPTR LOGICAL * 1 TABLES C C C##COUTLN OUTP = 0 C C## CLINE LEVEL = 1 LINECT = 1 INFILE ( 1 ) = 1 FTNLN = 0 C C## CDEFIO BP = 0 C C## CFOR FORDEP = 0 FORLEN = 1 C C## CFUNC INFUNC = 0 C C## CLOOK IF (.NOT.( SWITCH .EQ. 1 )) GOTO 20090 LASTP = 0 LASTT = 0 TWOS = 1 C C## CLIST 20090 CONTINUE PAGE = 0 PLINE = 9999 ERRORS = 0 INIF = 0 C C## CPRTLN READY = 0 C C## CSTR LASTS = 0 LASTR = 0 C I = LABGEN ( 0 ) JUNK = LABGEN ( 20000 - I ) C RETURN END SUBROUTINE RELATE ( TOKEN, LAST ) C C RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM CSYKES, 20 NOV 76 C PCN #73, DEC 79, ADD CARET,TILDE FOR .NOT., ADD && FOR .EQV. C PCN #77, 5 JAN 80, USE FOLD TO GET LOWER CASE VERSIONS, IF NEEDED C PCN #87, 10 FEB 80, ALLOW << AND >> FOR < AND >. C PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER. C C LOGICAL * 1 NGETCH, DOTS ( 6, 11 ), TOKEN ( 1 ), NEXTCH, THISCH INTEGER LAST, LINE, JUNK, SCOPY C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C DATA DOTS / 46, 71, 69, 46, 0, 0, 46, 71, 84, 46, 0, 0, 46, 76, $69, 46, 0, 0, 46, 76, 84, 46, 0, 0, 46, 78, 69, 46, 0, 0, 46, 78, $ 79, 84, 46, 0, 46, 69, 81, 46, 0, 0, 46, 65, 78, 68, 46, 0, 46, $79, 82, 46, 0, 0, 46, 88, 79, 82, 46, 0, 46, 69, 81, 86, 46, 0 / C LINE = 0 THISCH = TOKEN ( 1 ) NEXTCH = NGETCH ( NEXTCH ) IF (.NOT.( THISCH .EQ. 62 )) GOTO 20092 IF (.NOT.( NEXTCH .EQ. 61 )) GOTO 20094 LINE = 1 GOTO 20095 20094 CONTINUE IF (.NOT.( NEXTCH .EQ. 60 )) GOTO 20096 LINE = 5 GOTO 20097 20096 CONTINUE IF (.NOT.( NEXTCH .EQ. 62 )) GOTO 20098 LINE = 2 GOTO 20099 20098 CONTINUE LINE = 2 CALL PUTBAK ( NEXTCH ) 20099 CONTINUE 20097 CONTINUE 20095 CONTINUE GOTO 20093 20092 CONTINUE IF (.NOT.( THISCH .EQ. 60 )) GOTO 20100 IF (.NOT.( NEXTCH .EQ. 61 )) GOTO 20102 LINE = 3 GOTO 20103 20102 CONTINUE IF (.NOT.( NEXTCH .EQ. 62 )) GOTO 20104 LINE = 5 GOTO 20105 20104 CONTINUE IF (.NOT.( NEXTCH .EQ. 60 )) GOTO 20106 LINE = 4 GOTO 20107 20106 CONTINUE LINE = 4 CALL PUTBAK ( NEXTCH ) 20107 CONTINUE 20105 CONTINUE 20103 CONTINUE GOTO 20101 20100 CONTINUE IF (.NOT.( THISCH .EQ. 33 )) GOTO 20108 IF (.NOT.( NEXTCH .EQ. 61 )) GOTO 20110 LINE = 5 GOTO 20111 20110 CONTINUE LINE = 6 CALL PUTBAK ( NEXTCH ) 20111 CONTINUE GOTO 20109 20108 CONTINUE IF (.NOT.( THISCH .EQ. 61 )) GOTO 20112 IF (.NOT.( NEXTCH .EQ. 61 )) GOTO 20114 LINE = 7 GOTO 20115 20114 CONTINUE CALL PUTBAK ( NEXTCH ) 20115 CONTINUE GOTO 20113 20112 CONTINUE IF (.NOT.( THISCH .EQ. 38 )) GOTO 20116 IF (.NOT.( NEXTCH .EQ. 38 )) GOTO 20118 LINE = 11 GOTO 20119 20118 CONTINUE LINE = 8 CALL PUTBAK ( NEXTCH ) 20119 CONTINUE GOTO 20117 20116 CONTINUE IF (.NOT.( THISCH .EQ. 124 )) GOTO 20120 IF (.NOT.( NEXTCH .EQ. 124 .OR. NEXTCH .EQ. 92 )) GOTO 20122 LINE = 10 GOTO 20123 20122 CONTINUE LINE = 9 CALL PUTBAK ( NEXTCH ) C 20123 CONTINUE 20120 CONTINUE 20117 CONTINUE 20113 CONTINUE 20109 CONTINUE 20101 CONTINUE 20093 CONTINUE IF (.NOT.( LINE .GT. 0 )) GOTO 20124 LAST = SCOPY ( DOTS ( 1, LINE ), TOKEN, 10, JUNK ) IF (.NOT.( LC .EQ. 1 )) GOTO 20126 CALL FOLD ( TOKEN ) 20126 CONTINUE GOTO 20125 20124 CONTINUE TOKEN ( 2 ) = 0 LAST = 1 20125 CONTINUE RETURN END SUBROUTINE REPCOD ( LAB, SP ) C C REPCOD - GENERATE CODE FOR BEGINNING OF 'REPEAT' C C INTEGER LAB, SP, LABGEN C IF (.NOT.( SP .GT. 1 )) GOTO 20128 CALL OUTCON ( 0 ) 20128 CONTINUE LAB = LABGEN ( 3 ) CALL OUTCON ( LAB ) LAB = LAB + 1 C RETURN END SUBROUTINE RETCOD ( LEXSTR ) C C RETCOD - PROCESS RETURN (EXPRESSION). C PCN #92, 20 FEB 80, C C LOGICAL * 1 LEXSTR ( 70 ), TOKEN ( 70 ), GTOK C C FILE=CFUNC.RAT FOR RATFOR COMMON / CFUNC / INFUNC, FNAM ( 12 ) INTEGER INFUNC LOGICAL * 1 FNAM C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C IF (.NOT.( INFUNC .EQ. 1 .AND. GTOK ( TOKEN, 70 ) .EQ. 40 )) GOTO $ 20130 CALL PBSTR ( TOKEN ) CALL OUTTAB IF (.NOT.( LC .EQ. 1 )) GOTO 20132 CALL FOLD ( FNAM ) 20132 CONTINUE CALL OUTSTR ( FNAM ) IF (.NOT.( COMPRS .EQ. 0 )) GOTO 20134 CALL OUTCH ( 32 ) 20134 CONTINUE CALL OUTCH ( 61 ) IF (.NOT.( COMPRS .EQ. 0 )) GOTO 20136 CALL OUTCH ( 32 ) 20136 CONTINUE CALL BALPAR CALL OUTDON IF (.NOT.( LC .EQ. 1 )) GOTO 20138 CALL FOLD ( LEXSTR ) 20138 CONTINUE CALL OTHERC ( LEXSTR ) GOTO 20131 20130 CONTINUE CALL PBSTR ( TOKEN ) CALL OTHERC ( LEXSTR ) C 20131 CONTINUE RETURN END SUBROUTINE STRNGC C C STRNGC - GENERATE FIRST PART OF CODE FOR 'STRING' KEYWORD CSYKES 15OCT76, 12MAR77 C PCN # 21, 10 DEC 77 C PCN # 62, 3 SEP 79, FIX BUG ON STORAGE OF STRING DEFINITIONS C PCN # 93, 17 FEB 80, CALL FROM PARSE, CHANGE CALLING SEQ. C PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER. CASSUMES THAT THE TARGET COMPILER ALLOWS MULTIPLE ELEMENT SPECIFICATION C IN DATA STATEMENTS . CTHE STRING KEYWORDS MUST BE POSITIONED AFTER ALL OTHER FORTRAN C SPECIFICATION STATEMENTS, EXCEPT FOR ANY DATA STATEMENTS. CEACH "STRING FOO "BLATS"" LINE CAUSES IMMEDIATE OUTPUT OF A C "CHARACTER FOO(4)" LINE AND A "DATA FOO/.../" LINE IS HELD UNTIL C ALL STRING LINES HAVE BEEN PROCESSED, THEN INSERTED BEFORE THE C FIRST NON-STRING LINE, SO THAT ALL DATA STATEMENTS ARE AT THE C BOTTOM OF THE SPECIFICATION STATEMENTS. C C C LOGICAL * 1 TOKEN ( 70 ), NAME ( 70 ) LOGICAL * 1 DEFTOK INTEGER J, LEN, JUNK, INSTAL C C FILE= CSTR.RAT FOR RATFOR COMMON / CSTR / LASTS, LASTR, STRPTR ( 20 ), TABLES ( 300 ) INTEGER LASTS INTEGER LASTR INTEGER STRPTR LOGICAL * 1 TABLES C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C LOGICAL * 1 CHAR (10) C DATA CHAR/1HC,1HH,1HA,1HR,1HA,1HC,1HT,1HE,1HR,0/ CALL PUTBAK ( 12 ) CALL PBSTR ( CHAR ) CALL OUTTAB 20140 IF (.NOT.( DEFTOK ( TOKEN, 70 ) .NE. 12 )) GOTO 20141 CALL OUTSTR ( TOKEN ) IF (.NOT.( COMPRS .EQ. 0 )) GOTO 20142 CALL OUTCH ( 32 ) 20142 CONTINUE GOTO 20140 20141 CONTINUE IF (.NOT.( ( DEFTOK ( NAME, 70 ) .NE. - 100 ) .OR. ( DEFTOK ( $TOKEN, 70 ) .NE. 34 ) )) GOTO 20144 CALL SYNERR ( 15HILLEGAL STRING. ) RETURN 20144 CONTINUE CALL OUTSTR ( NAME ) IF (.NOT.( COMPRS .EQ. 0 )) GOTO 20146 CALL OUTCH ( 32 ) 20146 CONTINUE CALL OUTCH ( 40 ) LEN = 2 20148 IF (.NOT.( TOKEN ( LEN ) .NE. 34)) GOTO 20150 20149 LEN = LEN + 1 GOTO 20148 20150 CONTINUE CALL OUTNUM ( LEN - 1 ) CALL OUTCH ( 41 ) CALL OUTDON TOKEN ( LEN ) = 0 C C FILE THE ARRAY NAME AND THE STRING DEFINITION AWAY FOR FUTURE DUMPING IF (.NOT.( INSTAL ( NAME, TOKEN ( 2 ), LASTS, LASTR, STRPTR, 300, $ 20, TABLES ) .EQ. - 1 )) GOTO 20151 CALL SYNERR ( 17HTOO MANY STRINGS. ) C C C 20151 CONTINUE RETURN END LOGICAL FUNCTION TOKDEF * 1 ( TOKEN, TOKSIZ ) C C TOKDEF - GET TOKEN; SPECIAL VERSION OF 'DEFTOK' FOR USE BY 'MATH' CSYKES, APR77, C PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER. C USED TO GET DEFINED TOKENS (SYMBOLIC CONSTANTS) BY 'MATH' BECAUSE 'MATH' C IS CALLED BY DEFTOK AND THEREFORE CANNOT CALL DEFTOK. THIS MAKES SURE C THAT SYMBOLS WITHIN <> ARE REDUCED TO NUMBERS BEFORE BEING C MATH-ED UPON. SPECIAL PROCESSING ALLOWS NEGATIVE INTEGERS AND SYMBOLIC C CONSTANTS DEFINED AS NEGATIVE INTEGERS, WHICH ARE RETURNED AS A C SINGLE TOKEN INSTEAD OF TWO TOKENS. C C INTEGER TOKSIZ, LOOKFR, SUB LOGICAL * 1 DEFN ( 80 ), T, TOKEN ( TOKSIZ ), GTOK, TYPE C SUB = 1 T = GTOK ( TOKEN ( SUB ), TOKSIZ ) 20153 IF (.NOT.( T .NE. - 3)) GOTO 20155 IF (.NOT.( T .NE. - 100 .OR. TYPE ( TOKEN ( SUB ) ) .NE. - 30 )) $GOTO 20156 IF (.NOT.( T .EQ. 45 )) GOTO 20158 SUB = 2 GOTO 20154 20158 CONTINUE GOTO 20155 20159 CONTINUE 20156 CONTINUE CALL UNFOLD ( TOKEN ) IF (.NOT.( LOOKFR ( TOKEN, DEFN ) .EQ. 0 )) GOTO 20160 CALL SYNERR ( 29HUNDEFINED SYMBOLIC IN . ) TOKDEF = ( - 1 ) RETURN 20160 CONTINUE CALL PBSTR ( DEFN ) 20161 CONTINUE 20154 T = GTOK ( TOKEN ( SUB ) , TOKSIZE ) GOTO 20153 20155 CONTINUE TOKDEF = ( 1 ) RETURN C END SUBROUTINE UNSTAK ( SP, LEXTYP, LABVAL, TOKEN, LAST ) C C UNSTAK - CLEAN UP PARSE STACK AT END OF STATEMENT C PCN # 16, 14 NOV 77 C PCN 93, 16 FEB 80, MOVE FEATURE FINDING FROM GETTOK TO PARSE/LEX C C INTEGER LABVAL ( 100 ), LEXTYP ( 100 ), SP, TOKEN LOGICAL * 1 LAST C IF (.NOT.( TOKEN .NE. - 127 .AND. TOKEN .NE. - 126 .AND. TOKEN $.NE. - 128 .AND. TOKEN .NE. - 129 )) GOTO 20162 CONTINUE 20164 IF (.NOT.( SP .GT. 1)) GOTO 20166 IF (.NOT.( LEXTYP ( SP ) .EQ. 123 )) GOTO 20167 GOTO 20166 20167 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 116 .AND. TOKEN .EQ. - 113 )) $GOTO 20169 GOTO 20166 20169 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 116 )) GOTO 20171 CALL OUTCON ( LABVAL ( SP ) ) LAST = 32 GOTO 20172 20171 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 113 )) GOTO 20173 IF (.NOT.( SP .GT. 2 )) GOTO 20175 SP = SP - 1 20175 CONTINUE CALL OUTCON ( LABVAL ( SP ) + 1 ) LAST = 32 GOTO 20174 20173 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 112 )) GOTO 20177 CALL OUTCON ( LABVAL ( SP ) ) CALL OUTCON ( LABVAL ( SP ) + 1 ) GOTO 20178 20177 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 121 )) GOTO 20179 CALL OUTGO ( LABVAL ( SP ) ) CALL OUTCON ( LABVAL ( SP ) + 1 ) GOTO 20180 20179 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 115 )) GOTO 20181 CALL FORS ( LABVAL ( SP ) ) GOTO 20182 20181 CONTINUE IF (.NOT.( LEXTYP ( SP ) .EQ. - 119 )) GOTO 20183 CALL UNTILS ( LABVAL ( SP ), TOKEN ) 20183 CONTINUE 20182 CONTINUE 20180 CONTINUE 20178 CONTINUE 20174 CONTINUE 20172 CONTINUE 20170 CONTINUE 20168 CONTINUE 20165 SP = SP - 1 GOTO 20164 20166 CONTINUE C 20162 CONTINUE RETURN END SUBROUTINE UNTILS ( LAB, TOKEN ) C C UNTILS - GENERATE CODE FOR 'UNTIL' OR END OF 'REPEAT' STATEMENTS C PCN #75, DEC 79, ADD FTN LINE NUMBERS TO RATFOR LISTING C C LOGICAL * 1 PTOKEN ( 70 ) INTEGER JUNK, LAB, TOKEN, LEX C C FILE=CPRTLN.RAT FOR RATFOR COMMON / CPRTLN / FORTYP, IFTYP, READY, PRTBUF ( 91 ) INTEGER FORTYP INTEGER IFTYP INTEGER READY LOGICAL * 1 PRTBUF C C FILE= CUCLC.RAT FOR RATFOR COMMON / CUCLC / LC, COMPRS INTEGER LC INTEGER COMPRS C CALL OUTNUM ( LAB ) IF (.NOT.( TOKEN .EQ. - 120 )) GOTO 20185 JUNK = LEX ( PTOKEN ) CALL IFGO ( LAB - 1 ) FORTYP = 1 GOTO 20186 20185 CONTINUE CALL OUTGO ( LAB - 1 ) 20186 CONTINUE CALL OUTCON ( LAB + 1 ) C RETURN END SUBROUTINE WHILEC ( LAB, SP ) C C WHILEC - GENERATE CODE FOR BEGINNING OF 'WHILE' STATEMENTS C C INTEGER LAB, SP, LABGEN C IF (.NOT.( SP .GT. 1 )) GOTO 20187 CALL OUTCON ( 0 ) 20187 CONTINUE LAB = LABGEN ( 2 ) CALL OUTNUM ( LAB ) CALL IFGO ( LAB + 1 ) C RETURN END �