#======== FILE=RAT1.RAT ======================= RATFOR IN RATFOR ==========
#$ ***** FIRST PART OF THE NON-SYSTEM SPECIFIC PARTS OF RATFOR
#NOTE:THE COMPILER MUST CORRECTLY HANDLE NUMBERIC COMPARES OF BYTES AND INTEGERS
IFNOTDEF (ALPHA)
INCLUDE/NL DEFIN
INCLUDE RATDEF
ENDIFDEF

#
#$ ADDDEF	- GET DEFINITION, INSTALL SYMBOLIC CONSTANT AND SORT THE TABLE
# SYKES, 18FEB77
# PCN # 62, 3 SEP 79, FIX BUG ON STORAGE OF STRING DEFINITIONS
# PCN # 68, 10 OCT 79, FIX BUG IF LASTP=1,TESTING NAMPTR(0).
# PCN # 84, 18 JAN 80, FIX BUG IN PCN # 68, CHANGE > TO >= SO 2ND SYMBOL FOUND
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#
   SUBROUTINE ADDDEF (TOKEN, TOKSIZ)			#PCN #93
#
   INTEGER TOKSIZ, LOOKFR, INSTAL, SCOMPR, I, J
   CHARACTER TOKEN(TOKSIZ), DEFN(MAXDEF)
#
INCLUDE CLOOK
#
   CALL GETDEF (TOKEN, TOKSIZ, DEFN, MAXDEF)		#PCN 94
   CALL UNFOLD (TOKEN)
   IF (LOOKFR (TOKEN, DEFN) == YES)
      CALL SYNERR ("ATTEMPTED REDEFINITION.")
   ELSE
      IF (INSTAL(TOKEN,DEFN,LASTP,LASTT,NAMPTR,MAXTBL,MAXPTR,TABLE) == BAD)
         CALL SYNERR ("TOO MANY DEFINITIONS.")
      ELSE IF (LASTP >= 2) [				#***PCN#68,PCN#84
         IF (TWOS*2 <= LASTP)
            TWOS=TWOS*2
         I=NAMPTR(LASTP-1)
         J=NAMPTR(LASTP)
         IF (SCOMPR(TABLE(I),TABLE(J)) > 0)		#PCN#46
            CALL SHELL (LASTP, NAMPTR, TABLE)		#IF NEW ENTRY IS NOT AT END,SORT
         ]
#
   RETURN
   END
#
#$ BALPAR	- COPY BALANCED PARTHENTHESES STRING INTO FORTRAN CODE
# PCN # 21
#
   SUBROUTINE BALPAR
#
   CHARACTER T, TOKEN(MAXTOK), DEFTOK
   INTEGER NLPAR
#
INCLUDE CUCLC
#
   IF (DEFTOK(TOKEN, MAXTOK) != LPAREN)[
      CALL SYNERR("MISSING (.")
      RETURN
      ] 
   CALL OUTSTR(TOKEN)
   NLPAR = 1
   REPEAT[
      T = DEFTOK(TOKEN, MAXTOK)
      IF (T==SEMICOL \ T==LBRACE \ T==RBRACE \ T==EOF)[
         CALL PBSTR(TOKEN)
         BREAK
         ] 
      IF (T == NEWLINE)   		# DELETE NEWLINES
         TOKEN(1) = EOS
      ELSE
         CALL LRPAR (T, NLPAR)	#COUNT ( & )
 # ELSE NOTHING SPECIAL
      IF (T != COMMA & COMPRS == NO)	#PCN # 21
         CALL OUTCH(BLANK)		#INSERT BLANK BETWEEN TOKENS
      CALL OUTSTR(TOKEN)
      ]  UNTIL (NLPAR <= 0)
   IF (NLPAR != 0)
      CALL SYNERR("MISSING ( OR ) IN CONDITION.")
#
   RETURN
   END
#
#$ BRKNXT	- GENERATE FORTRAN CODE FOR 'BREAK' AND 'NEXT' STATEMENTS
#
   SUBROUTINE  BRKNXT (SP, LEXTYP, LABVAL, TOKEN)
#
   INTEGER I, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
#
   FOR (I = SP; I > 0; DECREMENT (I))
      IF (LEXTYP(I) == LEXWHILE \ LEXTYP(I) == LEXDO
            \ LEXTYP(I) == LEXFOR \ LEXTYP(I) == LEXREPEAT)[
         IF (TOKEN == LEXBREAK)
            CALL OUTGO(LABVAL(I)+1)
         ELSE
            CALL OUTGO(LABVAL(I))
         RETURN
         ] 
   IF (TOKEN == LEXBREAK)
      CALL SYNERR("ILLEGAL BREAK.")
   ELSE
      CALL SYNERR("ILLEGAL NEXT.")
#
   RETURN
   END
#
#$ DEFLST	- LIST CURRENT DEFINE TABLE CONTENTS
# SYKES,OCT76
# PCN # 61, 3 SEP 79, ADD SYMBOLIC CONSTANT USAGE DATA AT END OF LISTING
# PCN # 66, 6 OCT 79, DELETE LASTP<2 TEST, NOLONGER VALID
# PCN # 75, DEC 79, ADD FTN LINE NUMBERS TO LISTING
# PCN # 77, 5 JAN 80, INCLUDE CPRTLN AND USE 'PRTBUF' JUST TO SAVE SPACE.
#		(INSTEAD OF SEPERATE INTERNAL BUFFER)
# PCN # 96, 20 MAR 80, ADD PAGE INDEX AT END OF LISTING.
#
   SUBROUTINE DEFLST
#
   CHARACTER FF(2)
   INTEGER I, J, K, LEN1, LEN2, CENTER, LINE, JUNK
   INTEGER SJOIN, SITOC, SLEN, SCOPY
#
INCLUDE CLOOK
#
INCLUDE CPRTLN
#
   STRING TITLE "***SYMBOLIC CONSTANT = DEFINITION***"
   STRING BL " "
   STRING HOW " USED "
   STRING MUCH  " OF POSSIBLE "	;	STRING CHARS " CHARACTERS"
   STRING ANDIT "  & "		;	STRING SYMB  " SYMBOLS"
#
   DATA FF/ FORMFEED, EOS /
#
   IF (LASTP > 0) [
      CALL RATLST (FF,0, 0)		#FORCE ADVANCE TO NEW PAGE#PCN#75
      CALL DOINDX (4, TITLE)		#***PCN #96, INDEX THIS PAGE
      CENTER=(MAXCARD/2)-16		#DON'T QUITE USE CENTER
      IF (CENTER > 30)
         CENTER=30			#CENTER ON PAGE HEADING INSTEAD, PCN #77
IFDEF(DECWRITER)
      CENTER=20				#USE SHORTER LINE FOR SLOW PRINTERS
ENDIFDEF
      PRTBUF(1)=EOS
      CALL SPAD (PRTBUF, 60)				#PCN #77
      JUNK=SCOPY(TITLE, PRTBUF(CENTER-21), 40, JUNK)	#PCN #77
      CALL RATLST (PRTBUF, 0, 0)			#PCN #75,  #77
      CALL RATLST (BL, 0, 0)			#WRITE A BLANK LINE, PCN #75
      FOR (I=1; I <= LASTP; INCREMENT (I)) [
         J=NAMPTR(I)
         LINE=I
         LEN1=SLEN(TABLE(J))			#SYMBOL
         LEN2=SLEN(TABLE(J+1+LEN1))		#DEFINITION
         K=(CENTER-1)-LEN1			#STARTING COL.
         IF (LEN1 > (CENTER-2) \ LEN2 > (CENTER-2))
            K=1
         IF ((LEN1+LEN2) > (MAXCARD-3))	#LOST PART OF THE SYMBOL
            LINE=HUGE				#LINE SO FLAG WITH '****'
         FOR (L=1; L < K; INCREMENT (L))
            PRTBUF(L)=BLANK
         JUNK=SCOPY(TABLE(J), PRTBUF(K), MAXTOK, JUNK)		#COPY THE SYMBOL
         IF (LINE == I)
            L=K+LEN1+3
         ELSE
            L=MAXCARD-LEN2
         IF (TABLE(J+1+LEN1) == MACTYPE)
            J=J+1				#DON'T PRINT THE FLAG CHARS,  IT'S GARBAGE
         JUNK=SCOPY(TABLE(J+1+LEN1), PRTBUF(L), MAXDEF, JUNK)	#COPY THE DEFINITION
         PRTBUF(K+LEN1)=BLANK
         PRTBUF(K+LEN1+1)=EQUALS
         PRTBUF(K+LEN1+2)=BLANK
         CALL RATLST (PRTBUF, LINE, 0)		#PRINT THE LINE, #PCN 75
         ]
      LEN1=SCOPY (HOW, PRTBUF, 30, JUNK)		#PUT THE MESSAGE TOGETHER
      JUNK=SITOC (LASTP, PRTBUF(LEN1+1), 5)		#NUMBER OF SYMBOLS USED
      LEN1=SJOIN (PRTBUF, SYMB, MAXCARD, JUNK)
      LEN1=SJOIN (PRTBUF, MUCH, MAXCARD, JUNK)
      JUNK=SITOC (MAXPTR, PRTBUF(LEN1+1), 6)		#MAX SYMBOLS ALLOWED
      LEN1=SJOIN (PRTBUF, ANDIT, MAXCARD, JUNK)
      JUNK=SITOC (LASTT, PRTBUF(LEN1+1), 6)		#TOTAL CHARACTERS IN ALL SYMBOLS
      LEN1=SJOIN (PRTBUF, CHARS, MAXCARD, JUNK)
      LEN1=SJOIN (PRTBUF, MUCH, MAXCARD, JUNK)
      JUNK=SITOC (MAXTBL, PRTBUF(LEN1+1), 6)		#MAX CHARACTERS ALLOWED
      CALL RATLST (PRTBUF, 0, 0)			#PRINT SUMMARY LINE., PCN #75
      ]
#
   RETURN
   END
#
#$ DEFMAC	- PROCESS MACRO INVOCATIONS (WITH ARGUMENT)
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#THE 'MACRO' AND 'DEFINE' KEYWORDS ARE SYNOMIMUS.
#A MACRO CAN BE DEFINED WITH A DEFINITION CONTAINING ONE OR
#  MORE 'PASSCHARACTERS' IN IT. WHEN THE MACRO IS INVOKED, EACH
#  OCCURANCE OF THE PASSCHARACTER IN THE DEFINITION IS REPLACED 
#  WITH THE CURRENT ARGUMENT OF THE MACRO, WHICH IS CONTAINED IN PAREN
#  FOLLOWING THE MACRO NAME.
#DEFINE(FOO,($=$+1)) OR MACRO(FOO,($=$+1))	THEN
#  UNTIL (I)		IS PROCESSED INTO	UNTIL (I=I+1)
# NO PROCESSING OF THE MACRO DEFINITION IS DONE UNTIL THE MACRO
#   IS RESOLVED. SPECIAL CHAR. AND BLANKS IN DEFINITION ARE PRESERVED.
#
   SUBROUTINE DEFMAC (DEFN)			#PCN 94
#
   INTEGER I, NLPAR, SLEN
   CHARACTER DEFN(MAXDEF), TOKEN(MAXTOK), GTOK
#
   IF (DEFN(1) == MACTYPE) [
      IF (GTOK(TOKEN, MAXTOK) != LPAREN) [		#IT'S A MACRO INVOCATION
         CALL SYNERR ("NO ( IN MACRO.")
         CALL PBSTR (TOKEN)
         RETURN
         ]
      NLPAR=1
      FOR (I=1; NLPAR > 0; INCREMENT (I)) [
         IF (I > MAXTOK) [
            CALL SYNERR ("MACRO ARGUMENT TOO LONG.")
            RETURN
            ]
         IF (NGETCH(TOKEN(I)) == EOF \ TOKEN(I) == NEWLINE) [
            CALL SYNERR ("MACRO > 1 LINE.")
            CALL PUTBAK (TOKEN(I))
            RETURN
            ]
         CALL LRPAR (TOKEN(I), NLPAR)		#COUNT ( & )
         ]
      TOKEN(I-1)=EOS
# PUSH BACK 'DEFINITION' WITH 'TOKEN' IN PLACE OF 'PASSCHAR'
#	BUT NOT THE FIRST CHAR--MACTYPE
      FOR (I=SLEN(DEFN) ; I > 1; DECREMENT (I)) [
         IF (DEFN(I) == PASSCHAR)
            CALL PBSTR (TOKEN)
         ELSE
            CALL PUTBAK (DEFN(I))
         ]
      ]
   ELSE
      CALL PBSTR (DEFN)			#IT'S A REGULAR SYMBOLIC CONSTANT
   RETURN
   END
#
#$ DEFTOK	- GET TOKEN; CONVERT SYMBOLIC CONSTANTS, DO INCLUDES
# PCN 93, 18 FEB 80, HANDLE EOF OF INCLUDE FILES
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
# PCN 92, 20 FEB 80, ADD GTFUNC TO SET UP FOR RETURN(EXPRESSION)
# IMPOSSES THE RESTRICTION THAT SYMBOLIC CONSTANTS
# MUST START WITH A LETTER.  ALSO THAT SYMBOLIC CONSTANTS ARE
# ALWAYS CONVERTED TO UPPER CASE BEFORE LOOKUP, THEREFOR CASE
# IS NOT SIGNIFICANT TO SYMBOLIC CONSTANTS.
# SYKES, DEC76, ADD MACRO (WITH ARGUMENTS) CAPABILITY
#
   CHARFUNC FUNCTION DEFTOK FUNCSIZE (TOKEN, TOKSIZ)		#PCN 94
#
   INTEGER TOKSIZ, LOOKFR, SEQL
   CHARACTER DEFN(MAXDEF), T, TOKEN(TOKSIZ), GTOK, TYPE
#
INCLUDE CLINE
#
   STRING FUNC "FUNCTION"
#
   WHILE (LEVEL > 0) [					#PCN #93
      FOR (DEFTOK=GTOK(TOKEN,TOKSIZ); DEFTOK != EOF; DEFTOK=GTOK(TOKEN,TOKSIZ)) [
         IF (DEFTOK != ALPHA \ TYPE(TOKEN(1)) != LETTER)	#THROW AWAY NON-ALPHA
            RETURN					#WITH NON ALPHA TOKEN
         CALL UNFOLD (TOKEN)				#FORCE TO UPPER CASE FOR LOOKUP
         IF (LOOKFR(TOKEN, DEFN) == NO) [		# UNDEFINED
            IF (SEQL(FUNC,TOKEN) == YES)		#PCN 92
               CALL GTFUNC				#GO GET FUNCTION'S NAME
            RETURN					#WITH TOKEN
            ]
         ELSE
            CALL DEFMAC (DEFN)		#PROCESS MACRO CALLS /PUSHBACK DEFINITION
         ]					#LOOP AND GET THE DEFINITION BACK AGAIN
      IF (LEVEL == 1)				#FOUND EOF, WAS IT OF MAIN FILE??
         RETURN				#YES, RETURN EOF, WE'RE DONE
      ELSE [
         CALL CLOSE (INFILE(LEVEL))
         DECREMENT (LEVEL)		#REDUCE LEVEL OF INCLUDE FILES
         ]
      ]			#LOOP, READ NEXT TOKEN FROM HIGHER LEVEL FILE
#
   END
#
#$ DOCODE	- GENERATE CODE FOR BEGINNING OF 'DO' STATEMENT
#
   SUBROUTINE DOCODE(LAB)
#
   INTEGER LABGEN, LAB
#
INCLUDE CUCLC
#
   STRING DOSTRU "DO "
   STRING DOSTRL "do "
#
   CALL OUTTAB
   IF (LC == YES)		#OUTPUT "DO "
      CALL OUTSTR(DOSTRL)
   ELSE
      CALL OUTSTR(DOSTRU)
   LAB = LABGEN(2)
   CALL OUTNUM (LAB)		#OUTPUT STATEMENT NUMBER
   IF (COMPRS == NO)
      CALL OUTCH (BLANK)	#PCN # 21
   CALL EATUP			#OUTPUT CONTROL CLAUSE AS IS
   CALL OUTDON		#FINISH OFF LINE
#
   RETURN
   END
#
#$ DOINDX	- COLLECT, FORMAT, AND SAVE LINES FOR THE INDEX
# PCN # 96, 20 MAR 80
#
   SUBROUTINE DOINDX (MODE, TITLE)
#
   INTEGER MODE, I, JUNK, PAG
   INTEGER STRPUT, SITOC, SJOIN
   CHARACTER BUFR(MAXLINE), TITLE (DUMMYSIZE)
#
INCLUDE CLIST
#
   STRING FIL "FILE: "
   STRING INCL "    INCLUDE: "
#
   IF (INDXIT == YES) [
      PAG=PAGE					#GET CURRENT PAGE NUMBER
      IF (MODE == 1) 
         INCREMENT (PAG)				#NOT QUITE THERE YET
      JUNK=SITOC (PAG, BUFR(1), 4)			#ADD THE CURRENT PAGE NUMBER
      I=5
      IF (MODE == 2)
         I=7
      CALL SPAD (BUFR, I)
      IF (MODE == 1) 
         JUNK=SJOIN (BUFR, FIL, MAXCARD, JUNK)
      IF (MODE == 3)
         JUNK=SJOIN (BUFR, INCL, MAXCARD, JUNK)
      JUNK=SJOIN (BUFR, TITLE, MAXCARD, JUNK)		#ADD THE INDEX LINE
      IF (STRPUT (LUNINDX, BUFR, NO) != YES)		#WRITE LINE TO TEMP FILE
         CALL ERROR ("DOINDX ERROR WRITING INDEX FILE.")	#TERMINATE HERE
      ]
   RETURN
   END
#
#$ DMPIDX	- PRINT THE INDEX PAGES
# PCN #96, 20 MAR 80
#
   SUBROUTINE DMPIDX
#
   INTEGER STRGET
   CHARACTER BUFR(133)
#
   REWIND LUNINDX
   BUFR(1)=FORMFEED
   BUFR(2)=EOS
   CALL RATLST (BUFR, 0, 0)				#FORCE PAGE ADVANCE
   CALL RATLST ("PAGE", 0, 0)
   CALL RATLST (" ", 0, 0)
   WHILE (STRGET (LUNINDX, BUFR, 132) != EOF)		#GET AN INDEX LINE
      CALL RATLST (BUFR, 0, 0)			#WRITE IT TO LIST FILE
#
   RETURN
   END
#
#$ EATUP	- PROCESS REST OF A STATEMENT; INTERPRET CONTINUATIONS
# PCN 102, 29 MAR 80, ALLOW UNDERLINE EMBEDDED IN TOKENS
#
   SUBROUTINE EATUP
#
   CHARACTER PTOKEN(MAXTOK), T, TOKEN(MAXTOK), DEFTOK
   INTEGER NLPAR, SLEN
#
INCLUDE CUCLC
#
   NLPAR = 0
   REPEAT [
      T = DEFTOK(TOKEN, MAXTOK)
      IF (T == SEMICOL \ T == NEWLINE)
         BREAK
      IF (T == RBRACE) [
         CALL PBSTR(TOKEN)
         BREAK
         ] 
      IF (T == LBRACE \ T == EOF) [
         IF (NLPAR > 0)			#***DPS8MAR77 FOR DO'S
            CALL SYNERR("UNEXPECTED BRACE OR EOF.")
         CALL PBSTR(TOKEN)
         BREAK
         ] 
      IF (T == COMMA \ TOKEN(SLEN(TOKEN)) == UNDERLINE) [	#PCN 102. LAST CHAR A _?
         IF (DEFTOK(PTOKEN, MAXTOK) != NEWLINE)
            CALL PBSTR(PTOKEN)			#IF CONTINUATION, EAT THE NEWLINE HERE
         ELSE IF (T != COMMA)
            TOKEN(SLEN(TOKEN)) = EOS		#PCN 102, EAT TRAILING UNDERLINES
         ] 
      ELSE
         CALL LRPAR (T, NLPAR)		#COUNT (  & )
      IF (T != COMMA & COMPRS == NO)		#***PCN # 21
         CALL OUTCH (BLANK)			#INSERT BLANK BEFORE TOKEN 
      CALL OUTSTR(TOKEN)
      ]  UNTIL (NLPAR < 0)
   IF (NLPAR != 0)
      CALL SYNERR("UNBALANCED ( ).")
#
   RETURN
   END
#
#$ ELSEIF	- GENERATE CODE FOR END OF 'IF' BEFORE ELSE
# PCN#10, 21 OCT 77 DON'T GENERATE THE 'GOTO' IF THE PRECEEDING LINE GENERATED
#  A 'GOTO', MAKING THIS ONE UNREACHABLE, WHICH SOME COMPILERS DON'T LIKE.
#
   SUBROUTINE ELSEIF (LAB, LAST)
#
   INTEGER LAB
   CHARACTER LAST
#
   IF (LAST != LEXBREAK & LAST != LEXNEXT 
              & LAST != LEXSTOP & LAST != LEXRETURN)
      CALL OUTGO(LAB+1)
   CALL OUTCON(LAB)
#
   RETURN
   END
#
#$ ENDCOD	- PROCESS 'END' STATEMENT
# PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING
# PCN #92, 20 FEB 80, RESET IN-FUNCTION STATUS FLAG.
#
   SUBROUTINE ENDCOD (LEXSTR, SP)
#
   INTEGER SLEN, SP
   CHARACTER LEXSTR(DUMMYSIZE), PTOK(MAXTOK), DEFTOK
#
INCLUDE CFUNC
#
INCLUDE CLIST
#
INCLUDE CPRTLN
#
INCLUDE CLINE
#
   IF (3 == SLEN(LEXSTR) & DEFTOK (PTOK, MAXTOK) == NEWLINE) [
      CALL OUTTAB
      CALL OUTSTR(LEXSTR)		#OUTPUT 'END'
      CALL OUTDON
      CALL PRTLIN			#PCN #75, PRINT THE 'END' LINE
      IF (SP != 1) [			#STACK SHOULD BE EMPTY AT END OF PROGRAM
         CALL SYNERR ("MISSING CLAUSE OR BRACE IN ABOVE PROG.")
         SP=1
         ]
      PLINE=9999			#ADVANCE LISTING A PAGE
      CALL OUTCH (FORMFEED)		#ADD A FORMFEED TO CLEAR PAGE
      CALL OUTDON			#WHEN WE LIST THE FILE
      FTNLN=0				#PCN75,RESET FTN LINE # FOR NEXT PROG
      INFUNC=NO			#PCN 92, WE CAN'T BE IN FUNCTION ANYMORE.
      ]
   ELSE
      CALL OTHERC (LEXSTR)		#FALSE ALARM, NOT 'END'
   CALL PBSTR(PTOK)
   RETURN
   END
#
#$ ENDSTR	- DUMP PENDING STRING DEFINITIONS
#
   SUBROUTINE ENDSTR
#
IFDEF (STRINGS)
   INTEGER J, K, SLEN
#
INCLUDE CSTR
#
INCLUDE CUCLC
#
   STRING DATAU "DATA "	;	STRING DATAL "data "
#
   FOR (K=1; K <= LASTS; INCREMENT(K)) [
      CALL OUTTAB
      IF (LC == YES)
         CALL OUTSTR (DATAL)
      ELSE
         CALL OUTSTR (DATAU)
      J=STRPTR(K)
      CALL OUTSTR (TABLES(J))
      CALL OUTCH  (SLASH)
      FOR (J=J+SLEN(TABLES(J))+1; TABLES(J) != EOS; INCREMENT(J)) [
         CALL OUTCH (DIG1)
         IF (LC == YES)
            CALL OUTCH(LETH)
         ELSE
            CALL OUTCH(BIGH)
         CALL OUTCH (TABLES(J))
         CALL OUTCH (COMMA)
         ]
      CALL OUTNUM (EOS)
      CALL OUTCH  (SLASH)
      CALL OUTDON		#'DATA NAME/...,EOS/'
      ]
   LASTS=0	;	LASTR=0		#RE INIT FOR NEXT TIME
ENDIFDEF
   RETURN
   END
#
#$ ERROR	- PRINT FATAL ERROR MESSAGE, THEN DIE
#SYKES 28 SEP 76
#
   SUBROUTINE ERROR(BUF)
#
   CHARACTER BUF(DUMMYSIZE)
#
   CALL SYNERR(BUF)
   CALL SYNERR ("**ABORT**.")
   CALL EXIT			#TERMINATE HERE
   END
#
#$ FORCOD	- GENERATE CODE FOR THE BEGINNING OF 'FOR' STATEMENT
# ***PCN # 21
# PCN #75, DEC 79, ADD FTN LINE NUMBERS TO LISTING
#
   SUBROUTINE FORCOD(LAB, SP)
#
   CHARACTER T, TOKEN(MAXTOK), DEFTOK
   INTEGER SLEN, LABGEN
   INTEGER I, J, LAB, NLPAR, SP, JUNK, SCOPY
#
INCLUDE CFOR
#
INCLUDE CPRTLN
#
INCLUDE CUCLC
#
   LAB = LABGEN(3)
   IF (SP > 1)			#IS THERE SOMETHING TO CONTINUE?
      CALL OUTCON(0)			#IF SO, ISSUE CONTINUE
#
   IF (DEFTOK(TOKEN, MAXTOK) != LPAREN) [
      CALL SYNERR("MISSING  ( IN FOR.")
      RETURN
      ] 
   IF (DEFTOK(TOKEN, MAXTOK) != SEMICOL) [  	# REAL INIT CLAUSE
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL EATUP
      CALL OUTDON
      FORTYP=YES				#PCN#75, WE HAVE AN EXTRA LINE
      ] 
   IF (DEFTOK(TOKEN,  MAXTOK) == SEMICOL)	# EMPTY CONDITION
      CALL OUTCON(LAB)
   ELSE [  					# NON-EMPTY CONDITION
      CALL PBSTR(TOKEN)
      CALL OUTNUM(LAB)
      CALL OUTIF				#ADD "IF (.NOT."
      CALL OUTCH(LPAREN)
      NLPAR = 0
      WHILE (NLPAR >= 0) [
         T = DEFTOK(TOKEN, MAXTOK)
         IF (T == SEMICOL)
            BREAK
         ELSE
            CALL LRPAR(T,NLPAR)			#COUNT ( AND )
         IF (T != NEWLINE & T != UNDERLINE) [
            IF (T != COMMA & COMPRS == NO)		#***PCN # 21
               CALL OUTCH (BLANK)
            CALL OUTSTR(TOKEN)
            ]
         ]
      CALL OUTCH(RPAREN)
      CALL OUTCH(RPAREN)
      IF (COMPRS == NO)			#***PCN # 21
         CALL OUTCH(BLANK)
      CALL OUTGO(LAB+2)
      IF (NLPAR < 0)
         CALL SYNERR("INVALID FOR CLAUSE.")
      ]	 
   INCREMENT (FORDEP)				# STACK REINIT CLAUSE
   J=FORLEN
   FORSTK(J) = EOS				# NULL, IN CASE NO REINIT
   NLPAR = 0
   WHILE (NLPAR >= 0) [
      T = DEFTOK(TOKEN, MAXTOK)
      CALL LRPAR (T, NLPAR)
      IF (NLPAR >= 0 & T != NEWLINE & T != UNDERLINE) [
         J =  J + SLEN(TOKEN)
         IF (J+2 > MAXFORSTK)
            CALL ERROR ("REINIT CLAUSE(S) TOO LONG.")		#TERMINATE
         ELSE [
            JUNK=SCOPY(TOKEN, FORSTK(FORLEN), HUGE, JUNK)
            IF (COMPRS == NO) [				#***PCN # 21
               FORSTK(J) = BLANK
               INCREMENT (J)
               ]
            FORSTK(J) = EOS
            FORLEN=J
            ]
         ]
      ] 
   INCREMENT (FORLEN)
   INCREMENT (LAB)		# LABEL FOR NEXT'S
#
   RETURN
   END
#
#$ FORS	- GENERATE CODE FOR END OF 'FOR' STATEMENT
#
   SUBROUTINE FORS(LAB)
#
   INTEGER I, J, LAB, SLEN
#
INCLUDE CFOR
#
   CALL OUTNUM(LAB)
   J = 1
   FOR (I = 1; I < FORDEP; INCREMENT (I))	#FIND RIGHT REINIT CLAUSE IN STACK
      J = J + SLEN(FORSTK(J)) + 1
   IF (SLEN(FORSTK(J)) > 0) [
      CALL OUTTAB			#MAKE A FORTRAN LINE OUT OF IT
      CALL OUTSTR(FORSTK(J))
      CALL OUTDON
      ] 
   CALL OUTGO(LAB-1)			#OUTPUT "GOTO"
   CALL OUTCON(LAB+1)			#OUTPUT "CONTINUE"
   DECREMENT (FORDEP)			#TRIM THE STACK
   FORLEN=J
#
   RETURN
   END