#				FILE= RAT2.RAT
#$ ***** SECOND PART OF NON-SYSTEM-SPECIFIC PARTS OF RATFOR
IFNOTDEF (ALPHA)
INCLUDE/NL DEFIN
INCLUDE RATDEF
ENDIFDEF
#

#
#$ INSTAL	- ADD SYMBOLIC'S NAME AND DEFINITION TO TABLE
# PCN # 62, 3 SEP 79, FIX BUG ON STORAGE OF STRING DEFINITIONS
#
   INTEGER FUNCTION INSTAL (NAME,DEFN,LASTP,LASTT,NAMPTR,MAXTAB,MAXPOI,TABLE)
#
   CHARACTER DEFN(MAXDEF), NAME(MAXTOK), TABLE(DUMMYSIZE)
   INTEGER SLEN, LASTP, LASTT, NAMPTR(DUMMYSIZE)
   INTEGER DLEN, NLEN, SCOPY, JUNK, MAXTAB, MAXPOI
#
   NLEN = SLEN(NAME) + 1
   DLEN = SLEN(DEFN) + 1
   IF ((LASTT + NLEN + DLEN < MAXTAB) & LASTP < MAXPOI) [
      INCREMENT (LASTP)
      NAMPTR(LASTP) = LASTT + 1
      JUNK=SCOPY(NAME, TABLE(LASTT+1), MAXTOK, JUNK)
      JUNK=SCOPY(DEFN, TABLE(LASTT+NLEN+1), MAXDEF, JUNK)
      LASTT = LASTT + NLEN + DLEN
      RETURN (YES)
      ]
   ELSE
      RETURN (BAD)
#
   END
#
#$ LABELC	-  OUTPUT FORTRAN STATEMENT NUMBERS THAT WERE IN RATFOR SOURCE
# PCN #75, ADD FTN LINE NUMBERS TO LISTING. REPLACE CALL TO OUTTAB.
#
   SUBROUTINE LABELC(LEXSTR)
#
   CHARACTER LEXSTR(DUMMYSIZE)
   INTEGER SLEN
#
INCLUDE COUTLN
#
   IF (SLEN(LEXSTR) == 5)				# WARN ABOUT 20XXX LABELS
      IF (LEXSTR(1) == DIG2 & LEXSTR(2) == DIG0)
         CALL SYNERR ("POSSIBLE USER/RATFOR STATEMENT NUMBER CONFLICT.")
   CALL OUTSTR(LEXSTR)
   WHILE (OUTP < 6)				#PCN #75
      CALL OUTCH (BLANK)			#FILL OUT TO 6TH COL
   RETURN
   END
#
#$ LABGEN	- GENERATE  N  CONSECUTIVE LABELS, RETURN FIRST ONE
#
   INTEGER FUNCTION LABGEN(N)
#
   INTEGER LABEL, N
   DATA LABEL /20000/
#
   LABGEN = LABEL
   LABEL = LABEL + N
#
   RETURN
   END
#
#$ LRPAR	- COUNT LEFT & RIGHT PARENTHESES
# SYKES,18FEB77
#
   SUBROUTINE LRPAR (TOK, NLPAR)
#
   INTEGER NLPAR
   CHARACTER TOK
#
   IF (TOK == LPAREN)
      INCREMENT (NLPAR)
   ELSE IF (TOK == RPAREN)
      DECREMENT (NLPAR)
#
   RETURN
   END
#
#$ LEX	- RETURN LEXICAL TYPE OF NEXT VALID TOKEN TO 'PARSE'
# PCN 93, 16 FEB 80, DELETE CKEYWD, USE STRINGS IN 'LEX' INSTEAD.
#			ALSO DO PROCESSOR FEATURE KEYWORDS HERE.
# PCN 98, 27 MAR 80, REORGANIZE SCAN WITH MOST COMMON KEYWORDS FIRST.
#
   INTEGER FUNCTION LEX(TOKEN)
#
   CHARACTER TOKEN(MAXTOK), DEFTOK
   INTEGER ALLDIG, SEQL
#
   STRING SBREAK "BREAK"	;	STRING SINCL  "INCLUDE"
   STRING SDEFIN "DEFINE"	;	STRING SMACRO  "MACRO"
   STRING SDO    "DO"		;	STRING SNEXT  "NEXT"
   STRING SELSE  "ELSE"	;	STRING SREPT  "REPEAT"
   STRING SEND   "END"	;	STRING SRETRN "RETURN"
   STRING SENDIF "ENDIFDEF"	;	STRING SSTOP  "STOP"
   STRING SFOR   "FOR"	;	STRING SSTRNG "STRING"
   STRING SIF    "IF"		;	STRING SUNTIL "UNTIL"
   STRING SIFDEF "IFDEF"	;	STRING SWHILE "WHILE"
   STRING SIFNOT "IFNOTDEF"
#
   WHILE (DEFTOK(TOKEN, MAXTOK) ==  NEWLINE)
      ; 
   LEX = TOKEN(1)
   IF (LEX==EOF \ LEX==SEMICOL \ LEX==LBRACE \ LEX==RBRACE)
      RETURN
   IF (ALLDIG(TOKEN) == YES)			LEX=LEXDIGITS
   ELSE IF (SEQL(TOKEN, SIF) == YES)		LEX=LEXIF
   ELSE IF (SEQL(TOKEN, SELSE) == YES)	LEX=LEXELSE
   ELSE IF (SEQL(TOKEN, SFOR) == YES)		LEX=LEXFOR
   ELSE IF (SEQL(TOKEN, SWHILE) == YES)	LEX=LEXWHILE
   ELSE IF (SEQL(TOKEN, SREPT) == YES)	LEX=LEXREPEAT
   ELSE IF (SEQL(TOKEN, SDO) == YES)		LEX=LEXDO
   ELSE IF (SEQL(TOKEN, SUNTIL) == YES)	LEX=LEXUNTIL
   ELSE IF (SEQL(TOKEN, SBREAK) == YES)	LEX=LEXBREAK
   ELSE IF (SEQL(TOKEN, SNEXT) == YES)	LEX=LEXNEXT
   ELSE IF (SEQL(TOKEN, SDEFIN) == YES)	LEX=LEXDEFINE
   ELSE IF (SEQL(TOKEN, SINCL) == YES)	LEX=LEXINCLUD
   ELSE IF (SEQL(TOKEN, SMACRO) == YES)	LEX=LEXMACRO
   ELSE IF (SEQL(TOKEN, SENDIF) == YES)	LEX=LEXENDIF
   ELSE IF (SEQL(TOKEN, SIFDEF) == YES)	LEX=LEXIFDEF
   ELSE IF (SEQL(TOKEN, SIFNOT) == YES)	LEX=LEXIFNOT
   ELSE IF (SEQL(TOKEN, SSTRNG) == YES)	LEX=LEXSTRNG
   ELSE IF (SEQL(TOKEN, SEND) == YES)		LEX=LEXEND
   ELSE IF (SEQL(TOKEN, SRETRN) == YES)	LEX=LEXRETURN
   ELSE IF (SEQL(TOKEN, SSTOP) == YES)	LEX=LEXSTOP
   ELSE
      LEX=LEXOTHER
#
   RETURN
   END
#
#$ LOOKFR	- BINARY SEARCH TO LOCATE DEFINED SYMBOLIC CONSTANTS
# SYKES,NOV76;
# PCN # 67, 6 OCT 79, PREVENT 0 SUBSCRIPTING IF LASTP=0 [NAMPTR(IT)]
#
   INTEGER FUNCTION LOOKFR (NAME, DEFN)
#
   CHARACTER NAME(MAXTOK), DEFN(MAXDEF)
   INTEGER I, J, INDX, IT, INC, JUNK, SCOPY
#
INCLUDE CLOOK
#
   INDX=0
   INC=TWOS
   IF (LASTP > 0) [			#***PCN#67
      REPEAT [
         IT=INC+INDX
         IF (IT > LASTP)		#CAN'T GO PAST END OF TABLE!
            IT=LASTP
         I=1
         J=NAMPTR(IT)
         WHILE (NAME(I) == TABLE(J))
            IF (NAME(I) == EOS) [
               JUNK=SCOPY (TABLE(J+1), DEFN, MAXDEF, JUNK)
               RETURN (YES)
               ]
            ELSE [
               INCREMENT (I)
               INCREMENT (J)
               ]
         IF (NAME(I) > TABLE(J))
            IF (IT == LASTP)		#SPECIAL CASE, MEANS IT'S NOT THERE
               BREAK			#SO QUIT EARLY
            ELSE
               INDX=IT		#MOVE UP THE TABLE
         INC=INC/2			#***PCN67
         ] UNTIL (INC <= 0)
      ]
   RETURN (NO)
#
   END
#
#$ MATH	- DO MATH IN MACRO DEFINITIONS
# SYKES APR 77
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
# + AND - INTEGER NUMBERS AND DEFINITIONS ARE ALLOWED
#
   SUBROUTINE MATH 			#PCN #94
#
   INTEGER SCTOI, SITOC, NUM1, NUM2, JUNK
   CHARACTER TOKDEF, OPR, NGETCH, TOKEN(MAXTOK)
#
   IF (TOKDEF (TOKEN, MAXTOK) != BAD) [		#FIRST NUMBER
      JUNK=1
      NUM1=SCTOI (TOKEN, JUNK)
      WHILE (NGETCH(OPR) != GREATER) [		#MATH OPERATOR
         JUNK=TOKDEF (TOKEN, MAXTOK)			#NEXT NUMBER
         JUNK=1
         NUM2=SCTOI (TOKEN,JUNK)
         IF (OPR == PLUS)
            NUM1=NUM1+NUM2
         ELSE IF (OPR == MINUS)
            NUM1=NUM1-NUM2
         ELSE IF (OPR == STAR)
            NUM1=NUM1*NUM2
         ELSE IF (OPR == SLASH & NUM2 != 0)
            NUM1=NUM1/NUM2				#TRUNCATION
         ELSE [
            CALL SYNERR ("ILLEGAL MATH OPERATOR (TRY + - / *).")
            CALL PBSTR (TOKEN)
            RETURN
            ]
         ]
      JUNK=SITOC (NUM1, TOKEN, MAXTOK)	#PUSH BACK RESULT
      CALL PBSTR (TOKEN)			#RESULT IS RETURNED ON INPUT STACK
      ]
#
   RETURN
   END
#
#$ NGETCH	- GET A (POSSIBLY PUSHED BACK) CHARACTER
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#
   CHARFUNC FUNCTION NGETCH FUNCSIZE (C)		#PCN #94
#
   CHARACTER BUFR(MAXLINE), C
   INTEGER LASTC, GETLIN
#
INCLUDE CDEFIO
#
  DATA LASTC/MAXLINE/, BUFR(MAXLINE)/NEWLINE/
#
   IF (BP > 0)
      C = BUF(BP)
   ELSE [
      BP = 1
      IF (BUFR(LASTC) == NEWLINE \ LASTC >= MAXLINE) [
         LASTC=0
         IF (GETLIN(BUFR) == EOF) [		#READ A LINE IN
            C=EOF
            LASTC=MAXLINE		#FOR REINITIALIZATION SYKES 5 OCT 76
            BP=0
            RETURN (EOF)
            ]
         ]
      INCREMENT(LASTC)
      IF (BUFR(LASTC) == EOS)
         BUFR(LASTC) = NEWLINE		#EOS FROM GETLIN REALLY MEANS EOL
      C=BUFR(LASTC)
      ] 
   DECREMENT(BP)
   RETURN (C)
#
   END
#
#$ OTHERC	- OUTPUT ORDINARY FORTRAN STATEMENT
#
   SUBROUTINE OTHERC(LEXSTR)
#
   CHARACTER LEXSTR(DUMMYSIZE)
#
   CALL OUTTAB
   CALL OUTSTR(LEXSTR)		#OUTPUT TOKEN WE ALREADY HAVE
   CALL EATUP				#OUTPUT REST OF THE STATEMENT
   CALL OUTDON			#FINISH OFF LINE
#
   RETURN
   END
#
#$ OUTCH	- PUT ONE CHARACTER INTO OUTPUT BUFFER, CREATE CONTINUATION LINES
#
   SUBROUTINE OUTCH(C)
#
   CHARACTER C
#
INCLUDE COUTLN
#
   IF (OUTP > 70 \ OUTP < 0) [  	# CONTINUATION CARD,  SYKES 26 SEP 76
      CALL OUTDON
      FOR (OUTP = 1; OUTP < 6; INCREMENT (OUTP))	#PCN #77
         OUTBUF(OUTP) = BLANK
      OUTBUF(OUTP) = CONTINCHAR		#THE CONTINUATION FLAG CHAR. IN COL 6
      ] 
   INCREMENT (OUTP)
   OUTBUF(OUTP) = C
#
   RETURN
   END
#$ OUTCON	- GENERATE  "N   CONTINUE" CODE
# PCN #106, SEP 80, SUPPRESS UNLABELED 'CONTINUE'S(NO LABEL THERE & NUM TO PUT).
#
   SUBROUTINE OUTCON(N)
#
   INTEGER N
#
INCLUDE CUCLC
INCLUDE COUTLN
#
   STRING CONU "CONTINUE"
   STRING CONL "continue"
#
   IF (N <= 0 & OUTP <= 0)		#***PCN 106 NOTHING TO DO
      RETURN
   ELSE [
      IF (N > 0)
         CALL OUTNUM(N)		#OUTPUT STATEMENT NUMBER, IF ANY
      CALL OUTTAB
      IF (LC == YES)
         CALL OUTSTR(CONL)
      ELSE
         CALL OUTSTR(CONU)
      CALL OUTDON
   ]
#
   RETURN
   END
#
#$ OUTDON	- FINISH OFF A FORTRAN CODE (OUTPUT) LINE
# PCN #77, 5 JAN 80, DELETE 'NEWLINE' CHARACTER AT END OF LINE.
#
   SUBROUTINE OUTDON
#
INCLUDE COUTLN
#
   IF (OUTP < 0)
      OUTP=IABS(OUTP)			#RESTORE CORRECT VALUE
## OUTBUF(OUTP+1) = NEWLINE		#PCN #77
   OUTBUF(OUTP+1) = EOS
   CALL PUTLIN(OUTBUF, STDOUT, NO)	#PCN 77, NO CARRIAGE CONTROL
   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 BEGINNING OF LINE
   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
# PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING
# PCN #76, DEC 79, FIX BUG IN DUMPIN/OUTIF. NOT NUMBERING IF'S RIGHT
#
   SUBROUTINE OUTIF
#
INCLUDE CPRTLN
#
INCLUDE CUCLC
#
#
   STRING IFNOTU "IF (.NOT."		#PCN#76, ADD BLANK
   STRING IFNOTL "if (.not."
#
   CALL OUTTAB      			# GET TO COLUMN 7
   IF (LC == YES)
      CALL OUTSTR(IFNOTL)		# " IF(.NOT. "
   ELSE
      CALL OUTSTR(IFNOTU)
#
   IFTYP=YES				#PCN #75, TELL 'PRTLN' IS WAS AN 'IF'
#
   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) 
      RETURN (EXTBLK)
   DO I = 1, 10
      IF (INCHAR == INTDIG(I)) 
         RETURN (EXTDIG(I))
   DO I = 1, 26
      IF (INCHAR == INTLET(I)) 
         RETURN (EXTLET(I))
   DO I = 1, 26
      IF (INCHAR == INTBIG(I)) 
         RETURN (EXTBIG(I))
   DO I = 1, NCHARS
      IF (INCHAR == INTCHR(I)) 
         RETURN (EXTCHR(I))
   RETURN (INCHAR)
   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
#  ALSO CONVERT DOUBLE QUOTED STRINGS TO HOLLERITH.
#   PASS SINGLE QUOTED STRINGS UNPROCESSED.
#
   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
# PCN #75, DEC 79, ADD FORTRAN LINE NUMBERS TO RATFOR LISTING
#
   SUBROUTINE OUTTAB
#
INCLUDE COUTLN
#
INCLUDE CLINE				#PCN#75
#
   WHILE (OUTP < 6)
      CALL OUTCH(BLANK)
#
   IF (OUTP == 6)		#PCN #75, MAY BE CALLED IN MIDDLE OF LINE
      INCREMENT (FTNLN)	#PCN75, COUNT THIS FTN LINE, IF A NEW ONE
#
   RETURN
   END
#
#$ PARSE	- PARSE RATFOR SOURCE PROGRAM, CALL ROUTINES TO GENERATE CODE
# PCN # 93, 17 FEB 80, MOVE FINDING PROCESSOR FEATURES HERE FROM GETTOK.
# PCN #92, 20 FEB 80, ADD RETURN (EXPRESSION).
# PCN #109, 1 OCT 80, CHANGE DATA TYPE OF 'LAST' TO INTEGER.
#
    SUBROUTINE PARSE
#
   CHARACTER LEXSTR(MAXTOK)
   INTEGER LEX, STRNGS, LAST
   INTEGER LAB, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOK
   DATA STRNGS / NO /
#
   SP = 1
   LEXTYP(1) = EOF
   FOR ( TOK = LEX(LEXSTR);  TOK != EOF;  TOK = LEX(LEXSTR) ) [
      IF (STRNGS == YES & TOK != LEXSTRNG & TOK != SEMICOL) [	#PCN #93
         CALL ENDSTR
         STRNGS=NO
         ]
      IF (TOK == LEXIF)
         CALL IFCODE(LAB)
      ELSE IF (TOK == LEXFOR)
         CALL FORCOD(LAB, SP)
      ELSE IF (TOK == LEXREPEAT)
         CALL REPCOD(LAB, SP)
      ELSE IF (TOK == LEXDEFINE \ TOK == LEXMACRO) 
         CALL ADDDEF (LEXSTR, MAXTOK)			#PCN #93
      ELSE IF (TOK == LEXDO)
         CALL DOCODE(LAB)
      ELSE IF (TOK == LEXWHILE)
         CALL WHILEC(LAB, SP)			#SYKES 6 OCT 76
      ELSE IF (TOK == LEXDIGITS)
         CALL LABELC(LEXSTR)
      ELSE IF (TOK == LEXEND)
          CALL ENDCOD (LEXSTR, SP)
      ELSE IF (TOK == LEXENDIF) 			#PCN # 93
            ;						#NO ACTION NEEDED
      ELSE IF (TOK == LEXIFDEF) 			#PCN #93
         CALL IFDEFC (YES)
      ELSE IF (TOK == LEXIFNOT) 			#PCN #93
         CALL IFDEFC (NO)
      ELSE IF (TOK == LEXINCLUD)			#PCN #93
         CALL OPENI					#OPEN THE INCLUDE FILE
      ELSE IF (TOK == LEXSTRNG) [			#PCN #93
         STRNGS=YES				#AT LEAST 1 STRING HAS BEEN FOUND
         CALL STRNGC
         ]
      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 (INCREASE MAXSTACK).")	#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)
            CALL OTHERC (LEXSTR)
         ELSE IF (TOK == LEXRETURN)				#PCN #92
            CALL RETCOD (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 (INCREASE BUFSIZE).")		#TERMINATE
   ELSE
      BUF(BP) = C
#
   RETURN
   END
#
#$ RELATE	- CONVERT RELATIONAL SHORTHANDS INTO LONG (FORTRAN) FORM
#SYKES, 20 NOV 76
# PCN #73, DEC 79, ADD CARET,TILDE FOR .NOT., ADD  && FOR .EQV.
# PCN #77, 5 JAN 80, USE FOLD TO GET LOWER CASE VERSIONS, IF NEEDED
# PCN #87, 10 FEB 80, ALLOW << AND >> FOR < AND >.
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#
   SUBROUTINE RELATE (TOKEN, LAST)		#PCN #94
#
   CHARACTER NGETCH, DOTS(6,11), TOKEN(DUMMYSIZE), NEXTCH, THISCH
   INTEGER LAST, LINE, JUNK, SCOPY
#
INCLUDE CUCLC
#
   DATA DOTS/ PERIOD, BIGG, BIGE, PERIOD, EOS, EOS,
              PERIOD, BIGG, BIGT, PERIOD, EOS, EOS,
              PERIOD, BIGL, BIGE, PERIOD, EOS, EOS,
              PERIOD, BIGL, BIGT, PERIOD, EOS, EOS,
              PERIOD, BIGN, BIGE, PERIOD, EOS, EOS,
              PERIOD, BIGN, BIGO, BIGT, PERIOD, EOS,
              PERIOD, BIGE, BIGQ, PERIOD, EOS, EOS,
              PERIOD, BIGA, BIGN, BIGD, PERIOD, EOS,
              PERIOD, BIGO, BIGR, PERIOD, EOS, EOS,
              PERIOD, BIGX, BIGO, BIGR, PERIOD, EOS,
              PERIOD, BIGE, BIGQ, BIGV, PERIOD, EOS/	#PCN #73, DEC 79, PCN#77, JAN 80
#
   LINE=0
   THISCH=TOKEN(1)
   NEXTCH=NGETCH(NEXTCH)		#PCN 73, DEC 79, WE NEED TO LOOK AT NEXT CHAR
   IF (THISCH == GREATER)
      IF (NEXTCH == EQUALS)		#>=
         LINE=1			#.GE.
      ELSE IF (NEXTCH == LESS)	#><
         LINE=5			#.NE. PCN#73
      ELSE IF (NEXTCH == GREATER)	#>> PCN # 87
         LINE=2			#.GT.
      ELSE [
         LINE=2			#.GT.
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
         ]
   ELSE IF (THISCH == LESS)
      IF (NEXTCH == EQUALS)		#<=
         LINE=3			#.LE.
      ELSE IF (NEXTCH == GREATER)	#<>
         LINE=5			#.NE.  PCN#73
      ELSE IF (NEXTCH == LESS)	#<<, PCN #87
         LINE=4			#.LT.
      ELSE [
         LINE=4			#.LT.
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
         ]
   ELSE IF (THISCH == NOT)
      IF (NEXTCH == EQUALS)		#!=
         LINE=5			#.NE.
      ELSE [
         LINE=6			#.NOT.
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
         ]
   ELSE IF (THISCH == EQUALS)
      IF (NEXTCH == EQUALS)		#==
         LINE=7			#.EQ.
      ELSE
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
   ELSE IF (THISCH == AMPER)
      IF (NEXTCH == AMPER)		#PCN#73, DEC 79, .EQV.
         LINE=11			#.EQV.
      ELSE [
         LINE=8			#.AND.
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
         ]
   ELSE IF (THISCH == BAR)
      IF (NEXTCH == BAR \ NEXTCH == BACKSLASH)	#***DPS9MAR7
         LINE=10			#.XOR.
      ELSE [
         LINE=9			#.OR.
         CALL PUTBAK(NEXTCH)		#NEXT CHAR NOT NEEDED
         ]
#
   IF (LINE > 0) [
      LAST=SCOPY (DOTS(1,LINE), TOKEN, 10, JUNK)
      IF (LC == YES)
         CALL FOLD (TOKEN)		#CONVERT TO LOWER CASE, PCN#77
      ]
   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
#
#$ RETCOD	- PROCESS RETURN (EXPRESSION)
# PCN #92, 20 FEB 80,
#
   SUBROUTINE RETCOD (LEXSTR)
#
   CHARACTER LEXSTR(MAXTOK), TOKEN(MAXTOK), GTOK
#
INCLUDE CFUNC
#
INCLUDE CUCLC
#
   IF (INFUNC == YES & GTOK(TOKEN,MAXTOK) == LPAREN) [
      CALL PBSTR (TOKEN)					#PUT THE '(' BACK
      CALL OUTTAB
      IF (LC == YES)
         CALL FOLD (FNAM)			#FUNC NAME TO LOWER CASE
      CALL OUTSTR (FNAM)			#OUTPUT FUNCTION NAME
      IF (COMPRS == NO)
         CALL OUTCH (BLANK)
      CALL OUTCH (EQUALS)			#OUTPUT =
      IF (COMPRS == NO)
         CALL OUTCH (BLANK)
      CALL BALPAR				#OUTPUT (EXPRESSION)
      CALL OUTDON				#FINISH OFF LINE
      IF (LC == YES)
         CALL FOLD (LEXSTR)			#CONVERT 'RETURN' TO LC
      CALL OTHERC (LEXSTR)			#OUTPUT 'RETURN'
      ]
   ELSE [
      CALL PBSTR (TOKEN)			#FALSE ALARM, DON'T NEED IT
      CALL OTHERC (LEXSTR)			#JUST OUTPUT 'RETURN'
      ]
#
   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
# PCN # 93, 17 FEB 80, CALL FROM PARSE, CHANGE CALLING SEQ.
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#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 				#PCN 93
#
IFDEF (STRINGS)
#
   CHARACTER TOKEN(MAXTOK), NAME(MAXTOK)
   CHARACTER DEFTOK
   INTEGER J, LEN, JUNK, INSTAL
#
INCLUDE CSTR
#
INCLUDE CUCLC
#
   STRING CHAR "CHARACTER"
#
   CALL PUTBAK (FORMFEED)		#SOME UNIQUE FLAG
   CALL PBSTR(CHAR)
   CALL OUTTAB
   WHILE (DEFTOK(TOKEN,MAXTOK) != FORMFEED) [		#PCN #93
      CALL OUTSTR (TOKEN)			#COMES BACK DEFINED
      IF (COMPRS == NO)			#***PCN # 21
         CALL OUTCH (BLANK)
      ]
   IF ((DEFTOK(NAME,MAXTOK) != ALPHA) \
       (DEFTOK(TOKEN,MAXTOK) != DQUOTE))  [
      CALL SYNERR ("ILLEGAL STRING SYNTAX.")
      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 (INCREASE MAXSTR & NUMSTR).")
#
ENDIFDEF
#
IFNOTDEF (STRINGS)
   CALL SYNERR ("SORRY, THIS RATFOR WAS NOT BUILT WITH STRING SUPPORT".)
ENDIFDEF
#
   RETURN
   END
#
#$ TOKDEF	- GET TOKEN; SPECIAL VERSION OF 'DEFTOK' FOR USE BY 'MATH'
#SYKES, APR77, 
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
# PCN 109, 1 OCT 80, FIX TYPO IN GTOK CALL
#  USED TO GET DEFINED TOKENS (SYMBOLIC CONSTANTS) BY 'MATH'.  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)		#PCN #94
#
   INTEGER TOKSIZ, LOOKFR, SUB
   CHARACTER DEFN(MAXDEF), T, TOKEN(TOKSIZ), GTOK, TYPE
#
   SUB=1
   FOR (T=GTOK(TOKEN(SUB), TOKSIZ); T != EOF;
                           T=GTOK(TOKEN(SUB), TOKSIZ)) [	#PCN 109
      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 CONSTANT IN <MATH>.")
         RETURN (BAD)
         ]
      ELSE
         CALL PBSTR (DEFN)		#TRY REDEFINING DEFINITION UNTIL WE GET A NUMBER
      ]
   RETURN (YES)
#
   END
#
#$ UNSTAK	- CLEAN UP PARSE STACK AT END OF STATEMENT
# PCN # 16, 14 NOV 77
# PCN 93, 16 FEB 80, MOVE FEATURE FINDING FROM GETTOK TO PARSE/LEX
# PCN 109, 1 OCT 80, CHANGE DATA TYPE OF LAST TO INTEGER.
#
   SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN, LAST)
#
   INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN, LAST
#
   IF (TOKEN != LEXIFNOT & TOKEN != LEXIFDEF  & TOKEN != LEXENDIF
                                              & TOKEN != LEXINCLUD) [	#PCN #93
      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
# PCN #75, DEC 79, ADD FTN LINE NUMBERS TO RATFOR LISTING
#
   SUBROUTINE UNTILS(LAB, TOKEN)
#
   CHARACTER PTOKEN(MAXTOK)
   INTEGER JUNK, LAB, TOKEN, LEX
#
INCLUDE CPRTLN
#
INCLUDE CUCLC			#PCN #75
#
   CALL OUTNUM(LAB)
   IF (TOKEN == LEXUNTIL) [
      JUNK = LEX(PTOKEN)
      CALL IFGO(LAB-1)
      FORTYP=YES		#PCN #75, HAVE PRTLIN SUBTRACT 1 FTN LINE NUM
     ]
   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