0079#======== FILE=RAT1.RAT ======================= RATFOR IN RATFOR ==========0064# THIS FILE CONTAINS THE NON-SYSTEM SPECIFIC PARTS OF RATFOR0084#NOTE:THE COMPILER MUST CORRECTLY HANDLE NUMBERIC COMPARES OF BYTES AND INTEGERS0072# EDITED TO PLACE SUBPROGRAM DECLARATIONS AHEAD OF COMMENTS FOR THAT0052# SUBPROGRAM, SO F4 V2.2 KEEPS COMMENTS WITH IT.0015# BOB DENNY0015# 25-MAR-800005#0020IFNOTDEF (ALPHA)0020INCLUDE/NL DEFIN0018INCLUDE RATDEF0012ENDIFDEF00050051   SUBROUTINE ADDDEF (TOKEN, TOKSIZ)			#PCN #930005#0075# ADDDEF - GET DEFINITION, INSTALL SYMBOLIC CONSTANT AND SORT THE TABLE0020# SYKES, 18FEB770066# PCN # 62, 3 SEP 79, FIX BUG ON STORAGE OF STRING DEFINITIONS0064# PCN # 68, 10 OCT 79, FIX BUG IF LASTP=1,TESTING NAMPTR(0).0082# PCN # 84, 18 JAN 80, FIX BUG IN PCN # 68, CHANGE > TO >= SO 2ND SYMBOL FOUND0070# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.0005#0005#0051   INTEGER TOKSIZ, LOOKFR, INSTAL, SCOMPR, I, J0044   CHARACTER TOKEN(TOKSIZ), DEFN(MAXDEF)0005#0017INCLUDE CLOOK^^^0005#0057   CALL GETDEF (TOKEN, TOKSIZ, DEFN, MAXDEF)		#PCN 940026   CALL UNFOLD (TOKEN)0039   IF (LOOKFR (TOKEN, DEFN) == YES)0049      CALL SYNERR ("ATTEMPTED REDEFINITION.")0011   ELSE0079      IF (INSTAL(TOKEN,DEFN,LASTP,LASTT,NAMPTR,MAXTBL,MAXPTR,TABLE) == BAD)0050         CALL SYNERR ("TOO MANY DEFINITIONS.")0053      ELSE IF (LASTP >= 2) [				#***PCN#68,PCN#840033         IF (TWOS*2 <= LASTP)0027            TWOS=TWOS*20030         I=NAMPTR(LASTP-1)0028         J=NAMPTR(LASTP)^^^^^^^^^^^^^^^^^^^^^^^^^0056         IF (SCOMPR(TABLE(I),TABLE(J)) > 0)		#PCN#460083            CALL SHELL (LASTP, NAMPTR, TABLE)		#IF NEW ENTRY IS NOT AT END,SORT0014         ]0005#0013   RETURN0010   END00050024   SUBROUTINE BALPAR0005#0067# BALPAR - COPY BALANCED PARTHENTHESES STRING INTO FORTRAN CODE0014# PCN # 210005#0005#0041   CHARACTER T, TOKEN(MAXTOK), DEFTOK0020   INTEGER NLPAR0005#0017INCLUDE CUCLC0005#0044   IF (DEFTOK(TOKEN, MAXTOK) != LPAREN)[0035      CALL SYNERR("MISSING (.")0016      RETURN0012      ] ^^^^^^^^^^^0025   CALL OUTSTR(TOKEN)0016   NLPAR = 10014   REPEAT[0035      T = DEFTOK(TOKEN, MAXTOK)0059      IF (T==SEMICOL \ T==LBRACE \ T==RBRACE \ T==EOF)[0030         CALL PBSTR(TOKEN)0018         BREAK0015         ] 0049      IF (T == NEWLINE)   		# DELETE NEWLINES0027         TOKEN(1) = EOS0014      ELSE0047         CALL LRPAR (T, NLPAR)	#COUNT ( & )0027 # ELSE NOTHING SPECIAL0050      IF (T != COMMA & COMPRS == NO)	#PCN # 210060         CALL OUTCH(BLANK)		#INSERT BLANK BETWEEN TOKENS^^^^^^^^^^^^^^^^^^^^^^^^^^0028      CALL OUTSTR(TOKEN)0031      ]  UNTIL (NLPAR <= 0)0022   IF (NLPAR != 0)0053      CALL SYNERR("MISSING ( OR ) IN CONDITION.")0005#0013   RETURN0010   END00050053   SUBROUTINE  BRKNXT (SP, LEXTYP, LABVAL, TOKEN)0005#0062# BRKNXT - GENERATE CODE FOR 'BREAK' AND 'NEXT' STATEMENTS0005#0005#0063   INTEGER I, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN0005#0041   FOR (I = SP; I > 0; DECREMENT (I))0056      IF (LEXTYP(I) == LEXWHILE \ LEXTYP(I) == LEXDO^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0064            \ LEXTYP(I) == LEXFOR \ LEXTYP(I) == LEXREPEAT)[0035         IF (TOKEN == LEXBREAK)0039            CALL OUTGO(LABVAL(I)+1)0017         ELSE0037            CALL OUTGO(LABVAL(I))0019         RETURN0015         ] 0029   IF (TOKEN == LEXBREAK)0039      CALL SYNERR("ILLEGAL BREAK.")0011   ELSE0038      CALL SYNERR("ILLEGAL NEXT.")0005#0013   RETURN0010   END00050024   SUBROUTINE DEFLST0005#0052# DEFLST - TO LIST CURRENT DEFINE TABLE CONTENTS0017# SYKES,OCT76^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0076# PCN # 61, 3 SEP 79, ADD SYMBOLIC CONSTANT USAGE DATA AT END OF LISTING0061# PCN # 66, 6 OCT 79, DELETE LASTP<2 TEST, NOLONGER VALID0055# PCN # 75, DEC 79, ADD FTN LINE NUMBERS TO LISTING0077# PCN # 77, 5 JAN 80, INCLUDE CPRTLN AND USE 'PRTBUF' JUST TO SAVE SPACE.0044#		(INSTEAD OF SEPERATE INTERNAL BUFFER)0005#0005#0022   CHARACTER FF(2)0054   INTEGER I, J, K, LEN1, LEN2, CENTER, LINE, JUNK0040   INTEGER SJOIN, SITOC, SLEN, SCOPY0005#0017INCLUDE CLOOK0005#0018INCLUDE CPRTLN0005#^^^^^^^^^^^^^^^^^^^^^^^0052   STRING TITLE "SYMBOLIC CONSTANT = DEFINITION"0020   STRING BL " "0026   STRING HOW " USED "0064   STRING MUCH  " OF POSSIBLE "	;	STRING CHARS " CHARACTERS"0053   STRING ANDIT "  & "		;	STRING SYMB  " SYMBOLS"0005#0031   DATA FF/ FORMFEED, EOS /0005#0023   IF (LASTP > 0) [0066      CALL RATLST (FF,0, 0)		#FORCE ADVANCE TO NEW PAGE#PCN#750056      CENTER=(MAXCARD/2)-16		#DON'T QUITE USE CENTER0026      IF (CENTER > 30)0065         CENTER=30			#CENTER ON PAGE HEADING INSTEAD, PCN #770020IFDEF(DECWRITER)0058      CENTER=20				#USE SHORTER LINE FOR SLOW PRINTERS0012ENDIFDEF0023      PRTBUF(1)=EOS0044      CALL SPAD (PRTBUF, 60)				#PCN #770065      JUNK=SCOPY(TITLE, PRTBUF(CENTER-18), 40, JUNK)	#PCN #770053      CALL RATLST (PRTBUF, 0, 0)			#PCN #75,  #770063      CALL RATLST (BL, 0, 0)			#WRITE A BLANK LINE, PCN #750048      FOR (I=1; I <= LASTP; INCREMENT (I)) [0024         J=NAMPTR(I)0019         LINE=I0042         LEN1=SLEN(TABLE(J))			#SYMBOL0052         LEN2=SLEN(TABLE(J+1+LEN1))		#DEFINITION^^^^^^^^^0047         K=(CENTER-1)-LEN1			#STARTING COL.0055         IF (LEN1 > (CENTER-2) \ LEN2 > (CENTER-2))0019            K=10068         IF ((LEN1+LEN2) > (MAXCARD-3))	#LOST PART OF THE SYMBOL0054            LINE=HUGE				#LINE SO FLAG WITH '****'0044         FOR (L=1; L < K; INCREMENT (L))0031            PRTBUF(L)=BLANK0076         JUNK=SCOPY(TABLE(J), PRTBUF(K), MAXTOK, JUNK)		#COPY THE SYMBOL0027         IF (LINE == I)0026            L=K+LEN1+30017         ELSE0030            L=MAXCARD-LEN2^^^^^^^^^^^^^^^^^^0044         IF (TABLE(J+1+LEN1) == MACTYPE)0067            J=J+1				#DON'T PRINT THE FLAG CHARS,  IT'S GARBAGE0086         JUNK=SCOPY(TABLE(J+1+LEN1), PRTBUF(L), MAXDEF, JUNK)	#COPY THE DEFINITION0033         PRTBUF(K+LEN1)=BLANK0036         PRTBUF(K+LEN1+1)=EQUALS0035         PRTBUF(K+LEN1+2)=BLANK0068         CALL RATLST (PRTBUF, LINE, 0)		#PRINT THE LINE, #PCN 750014         ]0071      LEN1=SCOPY (HOW, PRTBUF, 30, JUNK)		#PUT THE MESSAGE TOGETHER^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0072      JUNK=SITOC (LASTP, PRTBUF(LEN1+1), 5)		#NUMBER OF SYMBOLS USED0050      LEN1=SJOIN (PRTBUF, SYMB, MAXCARD, JUNK)0050      LEN1=SJOIN (PRTBUF, MUCH, MAXCARD, JUNK)0070      JUNK=SITOC (MAXPTR, PRTBUF(LEN1+1), 6)		#MAX SYMBOLS ALLOWED0051      LEN1=SJOIN (PRTBUF, ANDIT, MAXCARD, JUNK)0081      JUNK=SITOC (LASTT, PRTBUF(LEN1+1), 6)		#TOTAL CHARACTERS IN ALL SYMBOLS0051      LEN1=SJOIN (PRTBUF, CHARS, MAXCARD, JUNK)0050      LEN1=SJOIN (PRTBUF, MUCH, MAXCARD, JUNK)^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0073      JUNK=SITOC (MAXTBL, PRTBUF(LEN1+1), 6)		#MAX CHARACTERS ALLOWED0068      CALL RATLST (PRTBUF, 0, 0)			#PRINT SUMMARY LINE., PCN #750011      ]0005#0013   RETURN0010   END00050041   SUBROUTINE DEFMAC (DEFN)			#PCN 940005#0053# DEFMAC - TO PROCESS MACRO CALLS (WITH ARGUMENT)0070# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.0053#THE 'MACRO' AND 'DEFINE' KEYWORDS ARE SYNOMIMUS.0063#A MACRO CAN BE DEFINED WITH A DEFINITION CONTAINING ONE OR^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0067#  MORE 'PASSCHARACTERS' IN IT. WHEN THE MACRO IS INVOKED, EACH0068#  OCCURANCE OF THE PASSCHARACTER IN THE DEFINITION IS REPLACED 0074#  WITH THE CURRENT ARGUMENT OF THE MACRO, WHICH IS CONTAINED IN PAREN0032#  FOLLOWING THE MACRO NAME.0051#DEFINE(FOO,($=$+1)) OR MACRO(FOO,($=$+1))	THEN0049#  UNTIL (I)		IS PROCESSED INTO	UNTIL (I=I+1)0067# NO PROCESSING OF THE MACRO DEFINITION IS DONE UNTIL THE MACRO0074#   IS RESOLVED. SPECIAL CHAR. AND BLANKS IN DEFINITION ARE PRESERVED.0005#0005#^^^^^^^^^^^^^^^^^^^^0029   INTEGER I, NLPAR, SLEN0050   CHARACTER DEFN(MAXDEF), TOKEN(MAXTOK), GTOK0005#0032   IF (DEFN(1) == MACTYPE) [0072      IF (GTOK(TOKEN, MAXTOK) != LPAREN) [		#IT'S A MACRO INVOCATION0043         CALL SYNERR ("NO ( IN MACRO.")0031         CALL PBSTR (TOKEN)0019         RETURN0014         ]0017      NLPAR=10047      FOR (I=1; NLPAR > 0; INCREMENT (I)) [0030         IF (I > MAXTOK) [0056            CALL SYNERR ("MACRO ARGUMENT TOO LONG.")0022            RETURN0017            ]^^^^^^^^^^^^^^^^^^^^^^^^^^^^0065         IF (NGETCH(TOKEN(I)) == EOF \ TOKEN(I) == NEWLINE) [0047            CALL SYNERR ("MACRO > 1 LINE.")0038            CALL PUTBAK (TOKEN(I))0022            RETURN0017            ]0055         CALL LRPAR (TOKEN(I), NLPAR)		#COUNT ( & )0014         ]0024      TOKEN(I-1)=EOS0064# PUSH BACK 'DEFINITION' WITH 'TOKEN' IN PLACE OF 'PASSCHAR'0037#	BUT NOT THE FIRST CHAR--MACTYPE0053      FOR (I=SLEN(DEFN) ; I > 1; DECREMENT (I)) [0037         IF (DEFN(I) == PASSCHAR)0034            CALL PBSTR (TOKEN)^^^^^0017         ELSE0037            CALL PUTBAK (DEFN(I))0014         ]0011      ]0011   ELSE0063      CALL PBSTR (DEFN)			#IT'S A REGULAR SYMBOLIC CONSTANT0013   RETURN0010   END00050065   CHARFUNC FUNCTION DEFTOK FUNCSIZE (TOKEN, TOKSIZ)		#PCN 940005#0061# DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS0052# PCN 93, 18 FEB 80, HANDLE EOF OF INCLUDE FILES0070# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.0068# PCN 92, 20 FEB 80, ADD GTFUNC TO SET UP FOR RETURN(EXPRESSION)^^^^^^^^^^0054# IMPOSSES THE RESTRICTION THAT SYMBOLIC CONSTANTS0065# MUST START WITH A LETTER.  ALSO THAT SYMBOLIC CONSTANTS ARE0065# ALWAYS CONVERTED TO UPPER CASE BEFORE LOOKUP, THEREFOR CASE0047# IS NOT SIGNIFICANT TO SYMBOLIC CONSTANTS.0057# SYKES, DEC76, ADD MACRO (WITH ARGUMENTS) CAPABILITY0005#0005#0035   INTEGER TOKSIZ, LOOKFR, SEQL0059   CHARACTER DEFN(MAXDEF), T, TOKEN(TOKSIZ), GTOK, TYPE0005#0017INCLUDE CLINE0005#0029   STRING FUNC "FUNCTION"0005#0039   WHILE (LEVEL > 0) [					#PCN #93^^^^^^^^^^^^^^^^^^^^0085      FOR (DEFTOK=GTOK(TOKEN,TOKSIZ); DEFTOK != EOF; DEFTOK=GTOK(TOKEN,TOKSIZ)) [0082         IF (DEFTOK != ALPHA \ TYPE(TOKEN(1)) != LETTER)	#THROW AWAY NON-ALPHA0048            RETURN					#WITH NON ALPHA TOKEN0067         CALL UNFOLD (TOKEN)				#FORCE TO UPPER CASE FOR LOOKUP0058         IF (LOOKFR(TOKEN, DEFN) == NO) [		# UNDEFINED0053            IF (SEQL(FUNC,TOKEN) == YES)		#PCN 920057               CALL GTFUNC				#GO GET FUNCTION'S NAME0038            RETURN					#WITH TOKEN0017            ]^^^^^^^0017         ELSE0077            CALL DEFMAC (DEFN)		#PROCESS MACRO CALLS /PUSHBACK DEFINITION0058         ]					#LOOP AND GET THE DEFINITION BACK AGAIN0062      IF (LEVEL == 1)				#FOUND EOF, WAS IT OF MAIN FILE??0051         RETURN				#YES, RETURN EOF, WE'RE DONE0016      ELSE [0039         CALL CLOSE (INFILE(LEVEL))0062         DECREMENT (LEVEL)		#REDUCE LEVEL OF INCLUDE FILES0014         ]0059      ]			#LOOP, READ NEXT TOKEN FROM HIGHER LEVEL FILE0005#0010   END00050029   SUBROUTINE DOCODE(LAB)0005#^^^0060# DOCODE - GENERATE CODE FOR BEGINNING OF 'DO' STATEMENT0005#0005#0026   INTEGER LABGEN, LAB0005#0017INCLUDE CUCLC0005#0026   STRING DOSTRU "DO "0026   STRING DOSTRL "do "0005#0018   CALL OUTTAB0036   IF (LC == YES)		#OUTPUT "DO "0029      CALL OUTSTR(DOSTRL)0011   ELSE0029      CALL OUTSTR(DOSTRU)0022   LAB = LABGEN(2)0050   CALL OUTNUM (LAB)		#OUTPUT STATEMENT NUMBER0024   IF (COMPRS == NO)0038      CALL OUTCH (BLANK)	#PCN # 210048   CALL EATUP			#OUTPUT CONTROL CLAUSE AS IS^^^^^^^^^^^^^^^^^^^^^^^^^^^0036   CALL OUTDON		#FINISH OFF LINE0005#0013   RETURN0010   END00050023   SUBROUTINE EATUP0005#0066# EATUP - PROCESS REST OF A STATEMENT; INTERPRET CONTINUATIONS0005#0005#0057   CHARACTER PTOKEN(MAXTOK), T, TOKEN(MAXTOK), DEFTOK0020   INTEGER NLPAR0005#0017INCLUDE CUCLC0005#0016   NLPAR = 00015   REPEAT [0035      T = DEFTOK(TOKEN, MAXTOK)0042      IF (T == SEMICOL \ T == NEWLINE)0018         BREAK0028      IF (T == RBRACE) [0030         CALL PBSTR(TOKEN)0018         BREAK0015         ] ^^^^^^^^^^^^^^^^^^0039      IF (T == LBRACE \ T == EOF) [0052         IF (NLPAR > 0)			#***DPS8MAR77 FOR DO'S0055            CALL SYNERR("UNEXPECTED BRACE OR EOF.")0030         CALL PBSTR(TOKEN)0018         BREAK0015         ] 0044      IF (T == COMMA \ T == UNDERLINE) [0051         IF (DEFTOK(PTOKEN, MAXTOK) != NEWLINE)0034            CALL PBSTR(PTOKEN)0032         IF (T == UNDERLINE)0030            TOKEN(1) = EOS0015         ] 0014      ELSE0049         CALL LRPAR (T, NLPAR)		#COUNT (  & )^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0054      IF (T != COMMA & COMPRS == NO)		#***PCN # 210061         CALL OUTCH (BLANK)			#INSERT BLANK BEFORE TOKEN 0028      CALL OUTSTR(TOKEN)0030      ]  UNTIL (NLPAR < 0)0022   IF (NLPAR != 0)0040      CALL SYNERR("UNBALANCED ( ).")0005#0013   RETURN0010   END00050036   SUBROUTINE ELSEIF (LAB, LAST)0005#0056# ELSEIF - GENERATE CODE FOR END OF 'IF' BEFORE ELSE0082# PCN#10, 21 OCT 77 DON'T GENERATE THE 'GOTO' IF THE PRECEEDING LINE GENERATED^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0078#  A 'GOTO', MAKING THIS ONE UNREACHABLE, WHICH SOME COMPILERS DON'T LIKE.0005#0005#0018   INTEGER LAB0021   CHARACTER LAST0005#0046   IF (LAST != LEXBREAK & LAST != LEXNEXT 0056              & LAST != LEXSTOP & LAST != LEXRETURN)0027      CALL OUTGO(LAB+1)0023   CALL OUTCON(LAB)0005#0013   RETURN0010   END00050037   SUBROUTINE ENDCOD (LEXSTR, SP)0005#0071# ENDCOD - FORCE LISTING PAGE ADVANCE AFTER FORTRAN 'END' STATEMENT0065# PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING^^^^^^^^^^^^^^^^^0056# PCN #92, 20 FEB 80, RESET IN-FUNCTION STATUS FLAG.0005#0005#0023   INTEGER SLEN, SP0056   CHARACTER LEXSTR(DUMMYSIZE), PTOK(MAXTOK), DEFTOK0005#0017INCLUDE CFUNC0005#0017INCLUDE CLIST0005#0018INCLUDE CPRTLN0005#0017INCLUDE CLINE0005#0066   IF (3 == SLEN(LEXSTR) & DEFTOK (PTOK, MAXTOK) == NEWLINE) [0021      CALL OUTTAB0044      CALL OUTSTR(LEXSTR)		#OUTPUT 'END'0021      CALL OUTDON0054      CALL PRTLIN			#PCN #75, PRINT THE 'END' LINE0067      IF (SP != 1) [			#STACK SHOULD BE EMPTY AT END OF PROGRAM0067         CALL SYNERR ("MISSING CLAUSE OR BRACE IN ABOVE PROG.")0017         SP=10014         ]0046      PLINE=9999			#ADVANCE LISTING A PAGE0062      CALL OUTCH (FORMFEED)		#ADD A FORMFEED TO CLEAR PAGE0046      CALL OUTDON			#WHEN WE LIST THE FILE0058      FTNLN=0				#PCN75,RESET FTN LINE # FOR NEXT PROG0063      INFUNC=NO			#PCN 92, WE CAN'T BE IN FUNCTION ANYMORE.0011      ]0011   ELSE0055      CALL OTHERC (LEXSTR)		#FALSE ALARM, NOT 'END'0023   CALL PBSTR(PTOK)0013   RETURN0010   END0005^^^^^^^^^^^0024   SUBROUTINE ENDSTR0005#0046# ENDSTR - DUMP PENDING STRING DEFINITIONS0005#0005#0019IFDEF (STRINGS)0025   INTEGER J, K, SLEN0005#0016INCLUDE CSTR0005#0017INCLUDE CUCLC0005#0050   STRING DATAU "DATA "	;	STRING DATAL "data "0005#0044   FOR (K=1; K <= LASTS; INCREMENT(K)) [0021      CALL OUTTAB0024      IF (LC == YES)0032         CALL OUTSTR (DATAL)0014      ELSE0032         CALL OUTSTR (DATAU)0021      J=STRPTR(K)0033      CALL OUTSTR (TABLES(J))0029      CALL OUTCH  (SLASH)^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^0071      FOR (J=J+SLEN(TABLES(J))+1; TABLES(J) != EOS; INCREMENT(J)) [0030         CALL OUTCH (DIG1)0027         IF (LC == YES)0032            CALL OUTCH(LETH)0017         ELSE0032            CALL OUTCH(BIGH)0035         CALL OUTCH (TABLES(J))0031         CALL OUTCH (COMMA)0014         ]0027      CALL OUTNUM (EOS)0029      CALL OUTCH  (SLASH)0044      CALL OUTDON		#'DATA NAME/...,EOS/'0011      ]0048   LASTS=0	;	LASTR=0		#RE INIT FOR NEXT TIME0012ENDIFDEF0013   RETURN0010   END0005^^^^^^^^^^^^^^^^^^^^^^^^0028   SUBROUTINE ERROR(BUF)0005#0049# ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE0020#SYKES 28 SEP 760005#0005#0031   CHARACTER BUF(DUMMYSIZE)0005#0023   CALL SYNERR(BUF)0033   CALL SYNERR ("**ABORT**.")0034   CALL EXIT			#TERMINATE HERE0010   END00050033   SUBROUTINE FORCOD(LAB, SP)0005#0065# FORCOD - GENERATE CODE FOR THE BEGINNING OF 'FOR' STATEMENT0017# ***PCN # 210054# PCN #75, DEC 79, ADD FTN LINE NUMBERS TO LISTING0005#0005#0041   CHARACTER T, TOKEN(MAXTOK), DEFTOK0027   INTEGER SLEN, LABGEN^^^^^^^0048   INTEGER I, J, LAB, NLPAR, SP, JUNK, SCOPY0005#0016INCLUDE CFOR0005#0018INCLUDE CPRTLN0005#0017INCLUDE CUCLC0005#0022   LAB = LABGEN(3)0053   IF (SP > 1)			#IS THERE SOMETHING TO CONTINUE?0049      CALL OUTCON(0)			#IF SO, ISSUE CONTINUE0005#0045   IF (DEFTOK(TOKEN, MAXTOK) != LPAREN) [0043      CALL SYNERR("MISSING  ( IN FOR.")0016      RETURN0012      ] 0067   IF (DEFTOK(TOKEN, MAXTOK) != SEMICOL) [  	# REAL INIT CLAUSE0027      CALL PBSTR(TOKEN)0021      CALL OUTTAB0020      CALL EATUP^^^^^^^^^^^^^0021      CALL OUTDON0054      FORTYP=YES				#PCN#75, WE HAVE AN EXTRA LINE0012      ] 0063   IF (DEFTOK(TOKEN,  MAXTOK) == SEMICOL)	# EMPTY CONDITION0026      CALL OUTCON(LAB)0041   ELSE [  					# NON-EMPTY CONDITION0027      CALL PBSTR(TOKEN)0026      CALL OUTNUM(LAB)0040      CALL OUTIF				#ADD "IF (.NOT."0028      CALL OUTCH(LPAREN)0019      NLPAR = 00030      WHILE (NLPAR >= 0) [0038         T = DEFTOK(TOKEN, MAXTOK)0030         IF (T == SEMICOL)0021            BREAK0017         ELSE^^^^^^^^^^^^^^^^^^^0052            CALL LRPAR(T,NLPAR)			#COUNT ( AND )0049         IF (T != NEWLINE & T != UNDERLINE) [0060            IF (T != COMMA & COMPRS == NO)		#***PCN # 210037               CALL OUTCH (BLANK)0034            CALL OUTSTR(TOKEN)0017            ]0014         ]0028      CALL OUTCH(RPAREN)0028      CALL OUTCH(RPAREN)0042      IF (COMPRS == NO)			#***PCN # 210030         CALL OUTCH(BLANK)0027      CALL OUTGO(LAB+2)0024      IF (NLPAR < 0)0047         CALL SYNERR("INVALID FOR CLAUSE.")0013      ]	 ^^^^^^^^^^0050   INCREMENT (FORDEP)				# STACK REINIT CLAUSE0015   J=FORLEN0051   FORSTK(J) = EOS				# NULL, IN CASE NO REINIT0016   NLPAR = 00027   WHILE (NLPAR >= 0) [0035      T = DEFTOK(TOKEN, MAXTOK)0031      CALL LRPAR (T, NLPAR)0059      IF (NLPAR >= 0 & T != NEWLINE & T != UNDERLINE) [0033         J =  J + SLEN(TOKEN)0033         IF (J+2 > MAXFORSTK)0069            CALL ERROR ("REINIT CLAUSE(S) TOO LONG.")		#TERMINATE0019         ELSE [0061            JUNK=SCOPY(TOKEN, FORSTK(FORLEN), HUGE, JUNK)^^^^^^^^^^^^^0051            IF (COMPRS == NO) [				#***PCN # 210036               FORSTK(J) = BLANK0032               INCREMENT (J)0020               ]0031            FORSTK(J) = EOS0024            FORLEN=J0017            ]0014         ]0012      ] 0025   INCREMENT (FORLEN)0042   INCREMENT (LAB)		# LABEL FOR NEXT'S0005#0013   RETURN0010   END00050027   SUBROUTINE FORS(LAB)0005#0053# FORS - GENERATE CODE FOR END OF 'FOR' STATEMENT0005#0005#0030   INTEGER I, J, LAB, SLEN0005#0016INCLUDE CFOR0005#0023   CALL OUTNUM(LAB)^0012   J = 10080   FOR (I = 1; I < FORDEP; INCREMENT (I))	#FIND RIGHT REINIT CLAUSE IN STACK0037      J = J + SLEN(FORSTK(J)) + 10033   IF (SLEN(FORSTK(J)) > 0) [0054      CALL OUTTAB			#MAKE A FORTRAN LINE OUT OF IT0032      CALL OUTSTR(FORSTK(J))0021      CALL OUTDON0012      ] 0041   CALL OUTGO(LAB-1)			#OUTPUT "GOTO"0046   CALL OUTCON(LAB+1)			#OUTPUT "CONTINUE"0043   DECREMENT (FORDEP)			#TRIM THE STACK0015   FORLEN=J0005#0013   RETURN0010   END^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^