#		FILE=RATFOR1.RAT
#============================================= RATFOR IN RATFOR ==========
# THIS FILE CONTAINS THE NON-SYSTEM SPECIFIC PARTS OF RATFOR
#
INCLUDE/NL DEFIN
#
INCLUDE RATDEF
#

#
# 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).
#
   SUBROUTINE ADDDEF (TOKEN, TOKSIZ, FD)
#
   INTEGER TOKSIZ, FD, LOOKFR, INSTAL, SCOMPR, I, J
   CHARACTER TOKEN(TOKSIZ), DEFN(MAXDEF)
#
INCLUDE CLOOK
#
   CALL GETDEF (TOKEN, TOKSIZ, DEFN, MAXDEF, FD)
   CALL UNFOLD (TOKEN)
   IF (LOOKFR (TOKEN, DEFN) == YES)
      CALL SYNERR ("ATTEMPTED REDEFINITION.")
   ELSE
      IF (INSTAL(TOKEN,DEFN,LASTP,LASTT,NAMPTR,MAXTBL,MAXPTR,TABLE) == BAD)	#PCN#62
         CALL SYNERR ("TOO MANY DEFINITIONS.")
      ELSE IF (LASTP > 2) [		#***PCN#68
         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), GETTOK
   INTEGER NLPAR
#
INCLUDE CUCLC
#
   IF (GETTOK(TOKEN, MAXTOK) != LPAREN)[
      CALL SYNERR("MISSING (.")
      RETURN
      ] 
   CALL OUTSTR(TOKEN)
   NLPAR = 1
   REPEAT[
      T = GETTOK(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 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 - TO 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
#
   SUBROUTINE DEFLST
#
   CHARACTER BUFR(MAXCARD), HEAD(MAXCARD), FF(2)
   INTEGER I, J, K, LEN1, LEN2, CENTER, LINE, JUNK
   INTEGER SJOIN, SITOC, SLEN, SCOPY
#
INCLUDE CLOOK
#
   STRING TITLE "SYMBOLIC CONSTANT = DEFINITION"
   STRING BL " "
   STRING HOW "PROGRAM USED "
   STRING MUCH " OUT OF A POSSIBLE "
   STRING ANDIT "  AND "
   STRING SYMB " SYMBOLS"
   STRING CHARS " CHARACTERS"
   DATA HEAD /MAXCARD*BLANK/
   DATA FF/ FORMFEED, EOS /
#
#  IF (LASTP <= 2)		#DON'T LIST 'MACRO' AND 'DEFINE'***PCN66
#     RETURN			#NOTHING TO DO, SINCE NO DEFINED SYMBOLS***PCN66
#  ELSE [					#***PCN#66
   CALL RATLST (FF,0)		#FORCE ADVANCE TO NEW PAGE
   CENTER=(MAXCARD/2)-6
IFDEF(DECWRITER)
   CENTER=CENTER-20
ENDIFDEF
   JUNK=SCOPY(TITLE, HEAD(CENTER-18), 40, JUNK)
   CALL RATLST (HEAD, 0)
   CALL RATLST (BL, 0)			#WRITE A BLANK LINE
   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))
         BUFR(L)=BLANK
      JUNK=SCOPY(TABLE(J), BUFR(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), BUFR(L), MAXDEF, JUNK)	#COPY THE DEFINITION
      BUFR(K+LEN1)=BLANK
      BUFR(K+LEN1+1)=EQUALS
      BUFR(K+LEN1+2)=BLANK
      CALL RATLST (BUFR, LINE)			#PRINT THE LINE
      ]
#     ]					#***PCN66
   LEN1=SCOPY (HOW, BUFR, 30, JUNK)			#PUT THE MESSAGE TOGETHER
   JUNK=SITOC (LASTP, BUFR(LEN1+1), 5)		#NUMBER OF SYMBOLS USED
   LEN1=SJOIN (BUFR, SYMB, MAXCARD, JUNK)
   LEN1=SJOIN (BUFR, MUCH, MAXCARD, JUNK)
   JUNK=SITOC (MAXPTR, BUFR(LEN1+1), 6)		#MAX SYMBOLS ALLOWED
   LEN1=SJOIN (BUFR, ANDIT, MAXCARD, JUNK)
   JUNK=SITOC (LASTT, BUFR(LEN1+1), 6)		#TOTAL CHARACTERS IN ALL SYMBOLS
   LEN1=SJOIN (BUFR, CHARS, MAXCARD, JUNK)
   LEN1=SJOIN (BUFR, MUCH, MAXCARD, JUNK)
   JUNK=SITOC (MAXTBL, BUFR(LEN1+1), 6)		#MAX CHARACTERS ALLOWED
   CALL RATLST (BUFR, 0)				#PRINT SUMMARY LINE.
#
   RETURN
   END
#
# DEFMAC - TO PROCESS MACRO CALLS (WITH ARGUMENT)
#  SYKES DEC76
#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, FD)
#
   INTEGER FD, I, NLPAR, SLEN
   CHARACTER DEFN(MAXDEF), TOKEN(MAXTOK), GTOK
#
   IF (DEFN(1) == MACTYPE) [
      IF (GTOK(TOKEN, MAXTOK, FD) != LPAREN) [
         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), FD) == 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)
   RETURN
   END
#
# DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS
# SYKES,OCT76;
# 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, FD, ALF)
#
   INTEGER FD, TOKSIZ, ALF, LOOKFR
   CHARACTER DEFN(MAXDEF), T, TOKEN(TOKSIZ), GTOK, TYPE
#
   ALF=NO
   FOR (T=GTOK(TOKEN, TOKSIZ, FD); T != EOF; T=GTOK(TOKEN, TOKSIZ, FD)) [
      IF (T != ALPHA \ TYPE(TOKEN(1)) != LETTER)	#THROW AWAY NON-ALPHA
         BREAK
      CALL UNFOLD (TOKEN)			#FORCE TO UPPER CASE FOR LOOKUP
      ALF=YES				#TOKEN IS ALPHA
      IF (LOOKFR(TOKEN, DEFN) == NO)		# UNDEFINED
         BREAK
      ELSE
         CALL DEFMAC (DEFN, FD)		#PROCESS MACRO CALLS /PUSHBACK DEFINITION
      ]
   DEFTOK = T
#
   RETURN
   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
#
# EATUP - PROCESS REST OF A STATEMENT; INTERPRET CONTINUATIONS
# ***PCN # 21
#
   SUBROUTINE EATUP
#
   CHARACTER PTOKEN(MAXTOK), T, TOKEN(MAXTOK), GETTOK
   INTEGER NLPAR
#
INCLUDE CUCLC
#
   NLPAR = 0
   REPEAT [
      T = GETTOK(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 \ T == UNDERLINE) [
         IF (GETTOK(PTOKEN, MAXTOK) != NEWLINE)
            CALL PBSTR(PTOKEN)
         IF (T == UNDERLINE)
            TOKEN(1) = EOS
         ] 
      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 - FORCE LISTING PAGE ADVANCE AFTER FORTRAN 'END' STATEMENT
# SYKES,OCT76
#
   SUBROUTINE ENDCOD (LEXSTR, SP)
#
   INTEGER SLEN, SP
   CHARACTER LEXSTR(DUMMYSIZE), PTOK(MAXTOK), GETTOK
#
INCLUDE CLIST
#
   IF (3 == SLEN(LEXSTR) & GETTOK (PTOK, MAXTOK) == NEWLINE) [
      CALL OUTTAB
      CALL OUTSTR(LEXSTR)
      CALL OUTDON
#
      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
      ]
   ELSE
      CALL OTHERC (LEXSTR)
   CALL PBSTR(PTOK)
#
   RETURN
   END
#
# ENDSTR - DUMP PENDING STRING DEFINITIONS
# SYKES,MAR77
#
   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		#RE INIT FOR NEXT TIME
   LASTR=0
ENDIFDEF
#
   RETURN
   END
#
# FORCOD - GENERATE CODE FOR THE BEGINNING OF 'FOR' STATEMENT
# ***PCN # 21
#
   SUBROUTINE FORCOD(LAB, SP)
#
   CHARACTER T, TOKEN(MAXTOK), GETTOK
   INTEGER SLEN, LABGEN
   INTEGER I, J, LAB, NLPAR, SP, JUNK, SCOPY
#
INCLUDE CFOR
#
INCLUDE CUCLC
#
   LAB = LABGEN(3)
   IF (SP > 1)		#IS THERE SOMETHING TO CONTINUE?
      CALL OUTCON(0)		#IF SO, ISSUE CONTINUE
#
   IF (GETTOK(TOKEN, MAXTOK) != LPAREN) [
      CALL SYNERR("MISSING  ( IN FOR.")
      RETURN
      ] 
   IF (GETTOK(TOKEN, MAXTOK) != SEMICOL) [  	# REAL INIT CLAUSE
      CALL PBSTR(TOKEN)
      CALL OUTTAB
      CALL EATUP
      CALL OUTDON
      ] 
   IF (GETTOK(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 = GETTOK(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 = GETTOK(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