#		FILE= RATFOR3.RAT
#
INCLUDE/NL DEFIN
#
INCLUDE RATDEF
#

# OUTCON - GENERATE  "N   CONTINUE" CODE
#
   SUBROUTINE OUTCON(N)
#
   INTEGER N
#
INCLUDE CUCLC
#
   STRING CONU "CONTINUE"
   STRING CONL "continue"
#
   IF (N > 0)
      CALL OUTNUM(N)
   CALL OUTTAB
   IF (LC == YES)
      CALL OUTSTR(CONL)
   ELSE
      CALL OUTSTR(CONU)
   CALL OUTDON
#
   RETURN
   END
#
# OUTDON - FINISH OFF A FORTRAN CODE (OUTPUT) LINE
#
   SUBROUTINE OUTDON
#
INCLUDE COUTLN
#
   IF (OUTP < 0)
      OUTP=IABS(OUTP)		#RESTORE CORRECT VALUE
   OUTBUF(OUTP+1) = NEWLINE
   OUTBUF(OUTP+2) = EOS
   CALL PUTLIN(OUTBUF, STDOUT)
   OUTP = 0
#
   RETURN
   END
#
# OUTGO - GENERATE "GOTO  N" CODE
# PCN#56, 14 APR 79, DROP BLANK AFTER 'GOTO' IF COMPRESSING
#
   SUBROUTINE OUTGO(N)
#
   INTEGER N
#
INCLUDE CUCLC
#
   STRING GOTOU "GOTO"
   STRING GOTOL "goto"
#
   CALL OUTTAB		#TAB OVER
   IF (LC == YES)		#OUTPUT "GOTO "
      CALL OUTSTR(GOTOL)
   ELSE
      CALL OUTSTR(GOTOU)
   IF (COMPRS == NO)		#PCN #56
      CALL OUTCH(BLANK)
   CALL OUTNUM(N)		#OUTPUT THE NUMBER
   CALL OUTDON		#FINISH OFF THE LINE
#
   RETURN
   END
#
# OUTIF - GENERATE "IF (.NOT." CODE FOR 'FOR' AND 'IF' STATEMENTS
# SYKES,18FEB77
#
   SUBROUTINE OUTIF
#
INCLUDE CUCLC
#
   STRING IFNOTU "IF(.NOT."
   STRING IFNOTL "if(.not."
#
   CALL OUTTAB      		# GET TO COLUMN 7
   IF (LC == YES)
      CALL OUTSTR(IFNOTL)	# " IF(.NOT. "
   ELSE
      CALL OUTSTR(IFNOTU)
#
   RETURN
   END
#
IFNOTDEF (ASCII)
# OUTMAP - CONVERT INTERNAL ASCII TO EXTERNAL CODE
#
   CHARFUNC FUNCTION OUTMAP FUNCSIZE (INCHAR)
#
   INTEGER I
   CHARACTER INCHAR
#
INCLUDE CCHAR
#
   IF (INCHAR == INTBLK) [
      OUTMAP = EXTBLK
      RETURN
      ] 
   DO I = 1, 10
      IF (INCHAR == INTDIG(I)) [
         OUTMAP = EXTDIG(I)
         RETURN
         ] 
   DO I = 1, 26
      IF (INCHAR == INTLET(I)) [
         OUTMAP = EXTLET(I)
         RETURN
         ] 
   DO I = 1, 26
      IF (INCHAR == INTBIG(I)) [
         OUTMAP = EXTBIG(I)
         RETURN
         ] 
   DO I = 1, NCHARS
      IF (INCHAR == INTCHR(I)) [
         OUTMAP  = EXTCHR(I)
         RETURN
         ] 
   OUTMAP = INCHAR
   RETURN
   END
ENDIFDEF

#
# OUTNUM - OUTPUT DECIMAL NUMBER TO FORTRAN CODE FILE
#
   SUBROUTINE OUTNUM(N)
#
   CHARACTER CHARS(MAXCHARS)
   INTEGER JUNK, LEN, N, SITOC
#
   JUNK=SITOC(N, CHARS, MAXCHARS)	#SYKES 6 OCT 76 DON'T GO OVER END OF LINE
   CALL OUTSTR(CHARS)
#
   RETURN
   END
#
# OUTSTR - OUTPUT A STRING TO FORTRAN CODE FILE
#
   SUBROUTINE OUTSTR(STR)
#
   CHARACTER C, STR(DUMMYSIZE), CHARS(MAXCHARS)
   INTEGER I, J, SLEN, LEN, K, SITOC
#
INCLUDE COUTLN
#
INCLUDE CUCLC
#
   I=SLEN(STR)
   IF ((OUTP + I >= 72) & (OUTP > 6))	#FORCE IMMEDIATE
      OUTP = -OUTP				#ADVANCE INSTEAD OF RUNNING OVER EOL
   FOR (I = 1; STR(I) != EOS; INCREMENT (I)) [
      C = STR(I)
      IF (C != DQUOTE)
         CALL OUTCH(C)
      ELSE [
         INCREMENT (I)
         FOR (J = I; STR(J) != C; INCREMENT (J))		# FIND END
             ;
         LEN=SITOC(J-I, CHARS, MAXCHARS)
         FOR (K=1; K <= LEN; INCREMENT(K))
         CALL OUTCH (CHARS(K))
         IF (LC == YES)
            CALL OUTCH(LETH)
         ELSE
            CALL OUTCH(BIGH)
         FOR ( ; I < J; INCREMENT (I))
            CALL OUTCH(STR(I))
         ] 
      ] 
#
   RETURN
   END
#
# OUTTAB - GENERATE A TAB AT BEGINNING OF FORTRAN LINE
#
   SUBROUTINE OUTTAB
#
INCLUDE COUTLN
#
   WHILE (OUTP < 6)
      CALL OUTCH(BLANK)
#
   RETURN
   END
#
# PARSE - PARSE RATFOR SOURCE PROGRAM, CALL ROUTINES TO GENERATE CODE
# PCN#10, 21 OCT 77
#
    SUBROUTINE PARSE
#
   CHARACTER LEXSTR(MAXTOK), LAST
   INTEGER LEX
   INTEGER LAB, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOK
#
   SP = 1
   LEXTYP(1) = EOF
   FOR (TOK = LEX(LEXSTR); TOK != EOF; TOK = LEX(LEXSTR)) [
      IF (TOK == LEXIF)
         CALL IFCODE(LAB)
      ELSE IF (TOK == LEXDO)
         CALL DOCODE(LAB)
      ELSE IF (TOK == LEXWHILE)
         CALL WHILEC(LAB, SP)		#SYKES 6 OCT 76
      ELSE IF (TOK == LEXFOR)
         CALL FORCOD(LAB, SP)		#SYKES 6 OCT 76
      ELSE IF (TOK == LEXREPEAT)
         CALL REPCOD(LAB, SP)		#SYKES 6 OCT 76
      ELSE IF (TOK == LEXDIGITS)
         CALL LABELC(LEXSTR)
      ELSE IF (TOK == LEXEND)		#SYKES 25 SEP 76
          CALL ENDCOD (LEXSTR, SP)
      ELSE IF (TOK == LEXELSE) [
         IF (LEXTYP(SP) == LEXIF)
            CALL ELSEIF(LABVAL(SP), LAST)		#PCN#10
         ELSE
            CALL SYNERR("ILLEGAL ELSE.")
         ] 
#
#PCN#10, REMEMBER LAST STATEMENT (BUT DON'T LET ] INTERFEAR)
      IF (TOK != RBRACE)
         LAST=TOK
#
      IF (TOK==LEXIF \ TOK==LEXELSE \ TOK==LEXWHILE
           \ TOK==LEXFOR \ TOK==LEXREPEAT
                 \ TOK==LEXDO \ TOK==LEXDIGITS \ TOK==LBRACE) [
         INCREMENT (SP)     			 	#START OF STATEMENT
         IF (SP > MAXSTACK)
            CALL ERROR("STACK OVERFLOW IN PARSER.")	#TERMINATE
         LEXTYP(SP) = TOK   				# STACK TYPE  VALUE
         LABVAL(SP) = LAB
         ] 
      ELSE [  		   	# END OF STATEMENT-PREPARE TO UNSTACK
         IF (TOK == RBRACE) [
            IF (LEXTYP(SP) == LBRACE)
               DECREMENT (SP)
            ELSE
               CALL SYNERR("ILLEGAL ].")
            ]
         ELSE IF (TOK == LEXOTHER \ TOK == LEXSTOP \ TOK == LEXRETURN)	#PCN#10
            CALL OTHERC(LEXSTR)
         ELSE IF (TOK == LEXBREAK \ TOK == LEXNEXT)
            CALL BRKNXT(SP, LEXTYP, LABVAL, TOK)
         TOK = LEX(LEXSTR)  			 	# PEEK AT NEXT TOK
         CALL PBSTR(LEXSTR)
         CALL UNSTAK(SP, LEXTYP, LABVAL, TOK, LAST)
         ] 
      ] 
#
   RETURN
   END
#
# PBSTR - PUSH STRING BACK ONTO INPUT FOR LATER RE-INPUT
#
   SUBROUTINE PBSTR(IN)
#
   CHARACTER IN(DUMMYSIZE)
   INTEGER I, SLEN
#
   FOR (I=SLEN(IN); I > 0; DECREMENT(I))
      CALL PUTBAK(IN(I))
#
   RETURN
   END
#
# PUTBAK - PUSH CHARACTER BACK ONTO INPUT FOR LATER RE-RETRIVAL
#
   SUBROUTINE PUTBAK(C)
#
   CHARACTER C
#
INCLUDE CDEFIO
#
   INCREMENT (BP)
   IF (BP > BUFSIZE)
      CALL ERROR("PUSHBACK STACK OVERFLOW.")		#TERMINATE
   ELSE
      BUF(BP) = C
#
   RETURN
   END
#
# RATGO - RATFOR INITIALIZATION ROUTINE
# SYKES 26 SEP 76
#
   SUBROUTINE RATGO (SWITCH)
#
   INTEGER SWITCH, JUNK, I, LABGEN
#
INCLUDE COUTLN
#
INCLUDE CLINE
#
INCLUDE CDEFIO
#
INCLUDE CFOR
#
INCLUDE CLOOK
#
INCLUDE CLIST
#
INCLUDE CSTR
#
#
###COUTLN
      OUTP=0
#
### CLINE
      LEVEL=1
      LINECT=1 
      INFILE(1)=STDIN
#
### CDEFIO
      BP=0
#
### CFOR
      FORDEP=0
      FORLEN=1
#
### CLOOK
      IF (SWITCH == YES) [
         LASTP=0		#INITIALIZE DEFINITION TABLE PARAMETERS
         LASTT=0
         TWOS=1
         ]
#
### CLIST
      PAGE=0
      PLINE=9999		#FORCE HEADER UPON FIRST PAGE
      ERRORS=0
      INIF=NO
#
### CSTR
      LASTS=0
      LASTR=0
#
   I=LABGEN(0)		#RESET STARTING LABEL TO 20000
   JUNK=LABGEN(20000-I)
#
   RETURN
   END
#
# RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM
#SYKES, 20 NOV 76
#
   SUBROUTINE RELATE(TOKEN, LAST , FD)
#
   CHARACTER NGETCH, DOTS(6,20), TOKEN(DUMMYSIZE)
   INTEGER FD, LAST, LINE, JUNK, SCOPY
#
INCLUDE CUCLC
#
##  STRING DOTGE ".GE."
##  STRING DOTGT ".GT."
##  STRING DOTLT ".LT."
##  STRING DOTLE ".LE."
##  STRING DOTNE ".NE."
##  STRING DOTNOT ".NOT."
##  STRING DOTEQ ".EQ."
##  STRING DOTAND ".AND."
##  STRING DOTOR ".OR."
##   STRING DOTXOR ".XOR."
   DATA DOTS/ PERIOD, BIGG, BIGE, PERIOD, EOS, EOS,
              PERIOD, LETG, LETE, PERIOD, EOS, EOS,
              PERIOD, BIGG, BIGT, PERIOD, EOS, EOS,
              PERIOD, LETG, LETT, PERIOD, EOS, EOS,
              PERIOD, BIGL, BIGE, PERIOD, EOS, EOS,
              PERIOD, LETL, LETE, PERIOD, EOS, EOS,
              PERIOD, BIGL, BIGT, PERIOD, EOS, EOS,
              PERIOD, LETL, LETT, PERIOD, EOS, EOS,
              PERIOD, BIGN, BIGE, PERIOD, EOS, EOS,
              PERIOD, LETN, LETE, PERIOD, EOS, EOS,
              PERIOD, BIGN, BIGO, BIGT, PERIOD, EOS,
              PERIOD, LETN, LETO, LETT, PERIOD, EOS,
              PERIOD, BIGE, BIGQ, PERIOD, EOS, EOS,
              PERIOD, LETE, LETQ, PERIOD, EOS, EOS,
              PERIOD, BIGA, BIGN, BIGD, PERIOD, EOS,
              PERIOD, LETA, LETN, LETD, PERIOD, EOS,
              PERIOD, BIGO, BIGR, PERIOD, EOS, EOS,
              PERIOD, LETO, LETR, PERIOD, EOS, EOS,
              PERIOD, BIGX, BIGO, BIGR, PERIOD, EOS,
              PERIOD, LETX, LETO, LETR, PERIOD, EOS/
#
   LINE=0
   IF (NGETCH(TOKEN(2), FD) != EQUALS & TOKEN(2) != BAR		#***DPS9MAR77
                                 & TOKEN(2) != BACKSLASH)
      CALL PUTBAK(TOKEN(2))
   IF (TOKEN(1) == GREATER) [
      IF (TOKEN(2) == EQUALS)
         LINE=1
      ELSE
         LINE=3
      ]
   ELSE IF (TOKEN(1) == LESS)
      IF (TOKEN(2) == EQUALS)
         LINE=5
      ELSE
         LINE=7
   ELSE IF (TOKEN(1) == NOT)
      IF (TOKEN(2) == EQUALS)
         LINE=9
      ELSE
         LINE=11
   ELSE IF (TOKEN(1) == EQUALS) [
      IF (TOKEN(2) == EQUALS)
         LINE=13
#      ELSE  TOKEN(2)=EOS
      ]
   ELSE IF (TOKEN(1) == AMPER)
         LINE=15
   ELSE IF (TOKEN(1) == BAR) [
      IF (TOKEN(2) == BAR \ TOKEN(2) == BACKSLASH)	#***DPS9MAR7
         LINE=19
      ELSE
         LINE=17
      ]
#
   IF (LINE > 0) [
      IF (LC == YES)
         INCREMENT (LINE)			#MAKE IT LOWER CASE
      LAST=SCOPY (DOTS(1,LINE), TOKEN, 10, JUNK)
      ]
   ELSE [			# CAN'T HAPPEN EXCEPT FOR =
      TOKEN(2) = EOS
      LAST = 1
      ]
#
   RETURN
   END
#
# REPCOD - GENERATE CODE FOR BEGINNING OF 'REPEAT'
#
   SUBROUTINE REPCOD(LAB, SP)
#
   INTEGER LAB, SP, LABGEN
#
   IF (SP > 1)		#SYKES 6 OCT 76, ONLY IF THERE MIGHT BE SOMETHING
      CALL OUTCON(0)		# IN CASE THERE WAS A LABEL
   LAB = LABGEN(3)
   CALL OUTCON(LAB)
   INCREMENT (LAB)		# LABEL TO GO ON NEXT'S
#
   RETURN
   END
#
# STRNGC - GENERATE FIRST PART OF CODE FOR 'STRING' KEYWORD
#SYKES 15OCT76, 12MAR77
# PCN # 21, 10 DEC 77
# PCN # 62, 3 SEP 79, FIX BUG ON STORAGE OF STRING DEFINITIONS
#ASSUMES THAT THE TARGET COMPILER ALLOWS MULTIPLE ELEMENT SPECIFICATION
# IN DATA STATEMENTS .
#THE STRING KEYWORDS MUST BE POSITIONED AFTER ALL OTHER FORTRAN
#  SPECIFICATION STATEMENTS, EXCEPT FOR ANY DATA STATEMENTS.
#EACH "STRING FOO "BLATS"" LINE CAUSES IMMEDIATE OUTPUT OF A
# "CHARACTER FOO(4)" LINE AND A "DATA FOO/.../" LINE IS HELD UNTIL
# ALL STRING LINES HAVE BEEN PROCESSED, THEN INSERTED BEFORE THE
# FIRST NON-STRING LINE, SO THAT ALL DATA STATEMENTS ARE AT THE
# BOTTOM OF THE SPECIFICATION STATEMENTS.
#
   SUBROUTINE STRNGC (STRNGS, FILE)
#
IFDEF (STRINGS)
#
   CHARACTER TOKEN(MAXTOK), NAME(MAXTOK)
   CHARACTER DEFTOK
   INTEGER J, LEN, JUNK, STRNGS, INSTAL, FILE
#
INCLUDE CSTR
#
INCLUDE CUCLC
#
   STRING CHAR "CHARACTER"
#
   CALL PUTBAK (FORMFEED)		#SOME UNIQUE FLAG
   CALL PBSTR(CHAR)
   CALL OUTTAB
   WHILE (DEFTOK(TOKEN,MAXTOK,FILE,JUNK) != FORMFEED) [
      CALL OUTSTR (TOKEN)			#COMES BACK DEFINED
      IF (COMPRS == NO)			#***PCN # 21
         CALL OUTCH (BLANK)
      ]
   IF ((DEFTOK(NAME,MAXTOK,FILE,JUNK) != ALPHA) \
       (DEFTOK(TOKEN,MAXTOK,FILE,JUNK) != DQUOTE))  [
      CALL SYNERR ("ILLEGAL STRING.")
      RETURN
      ]
   CALL OUTSTR (NAME)
   IF (COMPRS == NO)			#***PCN # 21
      CALL OUTCH  (BLANK)
   CALL OUTCH  (LPAREN)
   FOR (LEN=2; TOKEN(LEN) != DQUOTE; INCREMENT(LEN))
      ;
   CALL OUTNUM (LEN-1)
   CALL OUTCH  (RPAREN)
   CALL OUTDON			#'CHARACTER NAME(N)'
   TOKEN(LEN)=EOS			#CLOBBER TRAILING "
#
# FILE THE ARRAY NAME AND THE STRING DEFINITION AWAY FOR FUTURE DUMPING
   IF (INSTAL(NAME,TOKEN(2),LASTS,LASTR,STRPTR,MAXSTR,NUMSTR,TABLES) == BAD)	#PCN#62
      CALL SYNERR ("TOO MANY STRINGS.")
   ELSE
      STRNGS=YES		#FLAG THAT THERE ARE SOME
#
ENDIFDEF
#
IFNOTDEF (STRINGS)
   CALL SYNERR ("STRING KEYWORD NOT ALLOWED.")
ENDIFDEF
#
   RETURN
   END
#
# TOKDEF - GET TOKEN; SPECIAL VERSION OF 'DEFTOK' FOR USE BY 'MATH'
#SYKES, APR77, 
#  USED TO GET DEFINED TOKENS (SYMBOLIC CONSTANTS) BY 'MATH' BECAUSE 'MATH'
#  IS CALLED BY DEFTOK AND THEREFORE CANNOT CALL DEFTOK. THIS MAKES SURE
#  THAT SYMBOLS  WITHIN <> ARE REDUCED TO NUMBERS BEFORE BEING
#  MATH-ED UPON. SPECIAL PROCESSING ALLOWS NEGATIVE INTEGERS AND SYMBOLIC
#  CONSTANTS DEFINED AS NEGATIVE INTEGERS, WHICH ARE RETURNED AS A
#  SINGLE TOKEN INSTEAD OF TWO TOKENS.
#
   CHARFUNC FUNCTION TOKDEF FUNCSIZE (TOKEN, TOKSIZ, FD)
#
   INTEGER FD, TOKSIZ, LOOKFR, SUB
   CHARACTER DEFN(MAXDEF), T, TOKEN(TOKSIZ), GTOK, TYPE
#
   SUB=1
   FOR (T=GTOK(TOKEN(SUB), TOKSIZ, FD); T != EOF;
                           T=GTOK(TOKEN(SUB), TOKSIZE, FD)) [
      IF (T != ALPHA \ TYPE(TOKEN(SUB)) != LETTER)
         IF (T == MINUS) [			#IF A '-', ASSUME A NUMBER FOLLOWS
            SUB=2				#SO GO GET IT INTO 'TOKEN' AFTER THE '-'
            NEXT
            ]
         ELSE
            BREAK					#DONE WHEN WE GET A NUMBER
      CALL UNFOLD (TOKEN)				#FORCE TO UPPER CASE FOR LOOKUP
      IF (LOOKFR(TOKEN, DEFN) == NO) [		# UNDEFINED
         CALL SYNERR ("UNDEFINED SYMBOLIC IN <MATH>.")
         TOKDEF=BAD
         RETURN
         ]
      ELSE
         CALL PBSTR (DEFN)		#TRY REDEFINING DEFINITION UNTIL WE GET A NUMBER
      ]
   TOKDEF =YES
#
   RETURN
   END
#
# UNSTAK - CLEAN UP PARSE STACK AT END OF STATEMENT
# PCN # 16, 14 NOV 77
#
   SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN, LAST)	#PCN#16
#
   INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
   CHARACTER LAST
#
   FOR ( ; SP > 1; DECREMENT(SP)) [
      IF (LEXTYP(SP) == LBRACE)
         BREAK
      ELSE IF (LEXTYP(SP) == LEXIF & TOKEN == LEXELSE)	#PCN#20
         BREAK
      ELSE IF  (LEXTYP(SP) == LEXIF) [			#PCN#20
         CALL OUTCON(LABVAL(SP))
         LAST = BLANK				#PCN #16
         ]
      ELSE IF (LEXTYP(SP) == LEXELSE) [
         IF (SP > 2)
            DECREMENT (SP)
         CALL OUTCON(LABVAL(SP)+1)
         LAST = BLANK		#PCN 16, DON'T NEED TO IT ANYMORE WE CAN GET THERE
         ]
      ELSE IF (LEXTYP(SP) == LEXDO) [
         CALL OUTCON(LABVAL(SP))		#DOSTAT, END OF DO
         CALL OUTCON(LABVAL(SP)+1)
         ]
      ELSE IF (LEXTYP(SP) == LEXWHILE) [
         CALL OUTGO(LABVAL(SP))		#WHILES, END OF WHILE
         CALL OUTCON(LABVAL(SP)+1)
         ]
      ELSE IF (LEXTYP(SP) == LEXFOR)
         CALL FORS(LABVAL(SP))
      ELSE IF (LEXTYP(SP) == LEXREPEAT)
         CALL UNTILS(LABVAL(SP), TOKEN)
      ]
#
   RETURN
   END
#
# UNTILS - GENERATE CODE FOR 'UNTIL' OR END OF 'REPEAT' STATEMENTS
#
   SUBROUTINE UNTILS(LAB, TOKEN)
#
   CHARACTER PTOKEN(MAXTOK)
   INTEGER JUNK, LAB, TOKEN, LEX
#
   CALL OUTNUM(LAB)
   IF (TOKEN == LEXUNTIL) [
      JUNK = LEX(PTOKEN)
      CALL IFGO(LAB-1)
     ]
   ELSE
      CALL OUTGO(LAB-1)
   CALL OUTCON(LAB+1)
#
   RETURN
   END
#
# WHILEC - GENERATE CODE FOR BEGINNING OF 'WHILE' STATEMENTS
#
   SUBROUTINE WHILEC(LAB, SP)
#
   INTEGER LAB, SP, LABGEN
#
   IF (SP > 1)		#SYKES, 6 OCT 76, 
      CALL OUTCON(0)		#UNLABELED CONTINUE, IN CASE THERE WAS A LABEL
   LAB = LABGEN(2)
   CALL OUTNUM(LAB)
   CALL IFGO(LAB+1)
#
   RETURN
   END