#			FILE= RATFOR2.RAT
INCLUDE/NL DEFIN
#
INCLUDE RATDEF
#

# GETDEF  - GET SYMBOLIC CONSTANTS AND DEFINITIONS
# SYKES, DEC76, ALLOW SINGLE ARGUMENT MACRO DEFINITIONS
#   BLANKS ARE PRESERVED IN A DEFINITION
#
   SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD)
#
   CHARACTER GTOK, NGETCH, TEMP(5)
   INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ, INDEX, JUNK, SCOPY
   CHARACTER C, DEFN(DEFSIZ), TOKEN(TOKSIZ)
#
   DEFN(1)=EOS			#ERROR RETURNS GIVE NULL DEFIN.
   IF (GTOK(TOKEN,TOKSIZ,FD) != LPAREN) [
      CALL SYNERR("NO ( IN DEFINE.")
      RETURN
      ]
   IF (GTOK(TOKEN,TOKSIZ,FD) != ALPHA) [
      CALL SYNERR ("NON-ALPHANUMERIC NAME.")
      RETURN
      ]
   ELSE IF (GTOK(TEMP,5,FD) != COMMA & TEMP(1) != EQUALS) [
      CALL SYNERR ("NO , OR = IN DEFINE.")
      RETURN
      ]
# ELSE GOT (NAME,
#NOW GET THE DEFINITION
   NLPAR = 1
   FOR (I = 2; NLPAR > 0; INCREMENT (I)) [
      IF (I > DEFSIZ) [
         CALL SYNERR("DEFINITION TOO LONG.")
         RETURN
         ]
      IF (NGETCH(DEFN(I), FD) == EOF) [
         CALL SYNERR("NO ) IN DEFINE.")
         RETURN
         ]
      ELSE
         IF (DEFN(I) == LESS) [		#LOOK FOR A '<'
            CALL MATH (FD) 			#IF SO, DO THE <...> PART
            DECREMENT (I)			#KILL THE '<'
            ]				#RESULT IS ON INPUT
         ELSE
            CALL LRPAR (DEFN(I), NLPAR)	#COUNT ( & )
      ]
   DEFN(I-1) = EOS
   DEFN(1)=MACTYPE				#ASSUME MACRO
   IF (INDEX(DEFN, PASSCHAR) == 0)			#ARGUMENT PASS FLAGS?
      JUNK=SCOPY(DEFN(2), DEFN(1), MAXDEF, JUNK)	#SHIFT LEFT TO KILL MACRO FLAG
#
   RETURN
   END
#
# GETTOK - GET TOKEN. HANDLES PRE-PROCESSOR FEATURES
# SYKES 18FEB77,15JUN77
#
   CHARFUNC FUNCTION GETTOK FUNCSIZE (TOKEN, TOKSIZ)
#
   INTEGER TOKSIZ, ALF, SEQL, OPENI, STRNGS
   CHARACTER TOKEN(TOKSIZ), DEFTOK
#
INCLUDE CLINE
#
   STRING INCL "INCLUDE"
   STRING ENDIF "ENDIFDEF"
   STRING IFDEFS "IFDEF"
   STRING IFNOT "IFNOTDEF"
   STRING STRNG "STRING"
   STRING DEF "DEFINE"
   STRING MAC "MACRO"
   DATA STRNGS/NO/
#
   FOR ( ; LEVEL > 0; DECREMENT (LEVEL)) [
      FOR(GETTOK=DEFTOK(TOKEN,TOKSIZ,INFILE(LEVEL),ALF); GETTOK != EOF;
                       GETTOK=DEFTOK(TOKEN, TOKSIZ, INFILE(LEVEL),ALF)) [
         IF (ALF != YES) [
            IF (STRNGS == YES & GETTOK != NEWLINE) [
               CALL ENDSTR				#DUMP ANY PENDING STRINGS
               STRNGS=N0
               ]
            RETURN		#CAN'T BE COMPILER FEATURE RETURN WITH A GOOD TOK NOW
            ]
#
##LOOK FOR AND PROCESS ENDIFDEFS,IFDEFS,STRINGS,INCLUDES,DEFINES,MACROS
#
         ELSE IF (SEQL(TOKEN,DEF) == YES \ SEQL(TOKEN,MAC) == YES)
            CALL ADDDEF (TOKEN, TOKSIZ, INFILE(LEVEL))		#PROCESS DEFINITIONS
         ELSE IF (SEQL(TOKEN,IFDEFS) == YES)
            CALL IFDEFC (YES)				#PROCESS IFDEFS
         ELSE IF (SEQL(TOKEN,IFNOT) == YES)
            CALL IFDEFC (NO)					#PROCESS IFNOTDEFS
         ELSE IF (SEQL(TOKEN,STRNG) == YES)
            CALL STRNGC(STRNGS, INFILE(LEVEL))		#PROCESS STRING KEYWORD
         ELSE IF (SEQL(TOKEN,ENDIF) == YES)
            NEXT						#IGNORE ENDIFDEFS
         ELSE IF (SEQL(TOKEN, INCL) == YES)			#PROCESS INCLUDES
            IF (LEVEL >= NFILES)
               CALL ERROR("INCLUDES NESTED TOO DEEPLY.")	#TERMINATE HERE
            ELSE [
               INFILE(LEVEL+1) = OPENI()			#ASSIGN INCLUDED FILE
               IF (INFILE(LEVEL+1) == BAD)
                  CALL ERROR ("CAN'T OPEN INCLUDE.")		#TERMINATE HERE
               ELSE
                  INCREMENT (LEVEL)
               ] 
         ELSE [
            IF (STRNGS == YES & GETTOK != NEWLINE) [
               CALL ENDSTR		#DUMP ANY PENDING STRING DEFINITIONS
               STRNGS=NO
               ]
            RETURN			#HAVE A GOOD TOKEN NOW
            ]
         ] 
      IF (LEVEL == 1)
         BREAK			#CAN'T LET LEVEL=0 IF WE DO ANOTHER FILE
      ELSE
         CALL CLOSE (INFILE(LEVEL))
    ]
   GETTOK = EOF
#
   RETURN
   END
#
# GTOK - GET TOKEN; INTERPRET SPECIAL CHAR, DELETE BLANKS,TABS
#
   CHARFUNC FUNCTION GTOK FUNCSIZE(LEXSTR, TOKSIZ, FD)
#
   INTEGER FD, I, TOKSIZ
   CHARACTER C, LEXSTR(TOKSIZ), NGETCH, TYPE
#
   WHILE (NGETCH(C, FD) != EOF)
      IF (C != BLANK & C != TAB)		#DELETE TABS  AND HEADERS
         BREAK
   CALL PUTBAK(C)
   FOR (I = 1; I < TOKSIZ-1; INCREMENT (I)) [
      GTOK = TYPE(NGETCH(LEXSTR(I), FD))	#CONSTRUCT A TOKEN
      IF (GTOK != LETTER & GTOK != DIGIT)
         BREAK
      ] 
   IF (I >= TOKSIZ-1)
      CALL SYNERR("TOKEN TOO LONG.")
   IF (I > 1) [          			# SOME ALPHA SEEN
      CALL PUTBAK(LEXSTR(I))   		# WENT ONE TOO FAR
      LEXSTR(I) = EOS
      GTOK = ALPHA
      ]
   ELSE IF (LEXSTR(1) == BACKSLASH) [	#SYKES 15 OCT 76
      LEXSTR(1)=BAR				#MAKE BACKSLASH=BAR (OR)
      GTOK=BAR
      ]
   ELSE IF (LEXSTR(1) == LBRACK) [		#SYKES 26 SEP 76
      LEXSTR(1)=LBRACE			#MAKE BRACKETS=BRACES
      GTOK=LBRACE
      ]
   ELSE IF (LEXSTR(1) == RBRACK) [
      LEXSTR(1) = RBRACE
      GTOK = RBRACE
      ]
## ELSE IF (LEXSTR(1) == DOLLAR) [  		# ALLOW $( AND $) FOR BRACES
##    IF (NGETCH(LEXSTR(2), FD) == LPAREN) [
##       LEXSTR(1) = LBRACE
##       GTOK = LBRACE
##       ] 
##    ELSE IF (LEXSTR(2) == RPAREN) [
##       LEXSTR(1) = RBRACE
##       GTOK = RBRACE		##SYKES, 22NOV76
##       ] 
##    ELSE
##       CALL PUTBAK(LEXSTR(2))
##    ] 
   ELSE IF (LEXSTR(1) == DQUOTE) [
      FOR (I = 2; NGETCH(LEXSTR(I), FD) != LEXSTR(1); INCREMENT (I))
         IF (LEXSTR(I) == NEWLINE \ I >= TOKSIZ-1)[
            CALL SYNERR("MISSING QUOTE.")
            LEXSTR(I) = LEXSTR(1)
            CALL PUTBAK(NEWLINE)
            BREAK
            ] 
      ] 
   ELSE IF (LEXSTR(1) == SHARP) [		# STRIP COMMENTS
      WHILE (NGETCH(LEXSTR(1), FD) != NEWLINE)
           ; 
      GTOK = NEWLINE
      ] 
   IF (LEXSTR(1) == GREATER \ LEXSTR(1) == LESS \ LEXSTR(1) == NOT
      \ LEXSTR(1) == EQUALS \ LEXSTR(1) == AMPER \ LEXSTR(1) == BAR)
      CALL RELATE(LEXSTR, I, FD)
   LEXSTR(I+1) = EOS
#
   RETURN
   END
#
# IFCODE - GENERATE INITIAL CODE FOR 'IF' STATEMENTS
#
   SUBROUTINE IFCODE(LAB)
#
   INTEGER LAB, LABGEN
#
   LAB = LABGEN(2)
   CALL IFGO(LAB)
#
   RETURN
   END
#
# IFDEFC - PROCESS IFDEF AND IFNOTDEF CONDITIONALS
#SYKES, FEB77,APR77,
#CTRL='YES' FOR IFDEF; 'NO' FOR IFNOTDEF
#IFDEF (SYMBOL)		OR IFNOTDEF (SYMBOL)
#   <STATEMENT>
#ENDIFDEF
#
   SUBROUTINE IFDEFC  (CTRL)
#
   INTEGER LOOKFR, SEQL, LAYER, CTRL
   CHARACTER TOKEN(MAXTOK), JUNK(MAXDEF), GTOK, TYPE
#
INCLUDE CLINE
#
INCLUDE CKEYWD
#
   STRING ENDIF "ENDIFDEF"
   STRING IFDEFS "IFDEF"
   STRING IFNOT "IFNOTDEF"
#
   IF (GTOK(TOKEN,MAXTOK,INFILE(LEVEL)) != LPAREN) [
      CALL SYNERR ("MISSING ( IN IFDEF.")
      CALL PBSTR (TOKEN)
      RETURN
      ]
   IF (GTOK(TOKEN,MAXTOK,INFILE(LEVEL)) != ALPHA \
                          TYPE(TOKEN(1)) != LETTER) [
      CALL SYNERR ("ILLEGAL SYMBOLIC IN IFDEF.")
      CALL PBSTR (TOKEN)
      RETURN
      ]
#
   IF (LOOKFR(TOKEN,JUNK) == CTRL)[			#RIGHT FOR IFDEF AND IFNOTDEF
      IF (GTOK(TOKEN,MAXTOK,INFILE(LEVEL)) != RPAREN) [	#IT'S DEFINED
         CALL SYNERR ("MISSING ) IN IFDEF.")
         CALL PBSTR (TOKEN)
         RETURN
         ]
      RETURN				#IT'S DEFINED
      ]
#
   ELSE [				#IT'S NOT DEFINED
      INIF=YES			#WE ARE IN AN UNDEFINED IFDEF
      LAYER=1
      REPEAT [						#SEARCH FOR 'ENDIFDEF' AND
         IF (GTOK (TOKEN,MAXTOK,INFILE(LEVEL)) != EOF) [	#THROW STUFF AWAY MEANWHILE
            IF (SEQL(TOKEN,ENDIF) == YES) [
               IF (LAYER == 1)
                  BREAK				#WE'RE DONE
               ELSE
                  DECREMENT (LAYER)
               ]
            ELSE IF (SEQL(TOKEN,IFDEFS) == YES \ SEQL(TOKEN,IFNOT) == YES)
               INCREMENT (LAYER)
            ]
         ELSE [
            CALL SYNERR ("UNTERMINATED IFDEF.")
            CALL PUTBAK (TOKEN)
            BREAK
            ]
         ]
      INIF=NO		#FINISHED WITH OUR UNDEFINED IFDEF
      RETURN
      ]
#
   END
#
# IFGO - GENERATE "IF(.NOT.(...))GOTO LAB"
# ***PCN # 21
#
   SUBROUTINE IFGO(LAB)
#
   INTEGER LAB
#
INCLUDE CUCLC
#
   CALL OUTIF		#OUTPUT "IF (.NOT."
   CALL BALPAR      		# COLLECT AND OUTPUT CONDITION
   CALL OUTCH(RPAREN)	# " ) "
   IF (COMPRS == NO)		#***PCN#21
      CALL OUTCH(BLANK)	#SYKES 6 OCT 76
   CALL OUTGO(LAB)   	# " GOTO LAB "
#
   RETURN
   END
#
IFNOTDEF (ASCII)
# INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII
#
   CHARFUNC FUNCTION INMAP FUNCSIZE (INCHAR)
#
   CHARACTER INCHAR
   INTEGER I
#
INCLUDE CCHAR
#
   IF (INCHAR == EXTBLK) [
      INMAP = INTBLK
      RETURN
      ] 
   DO I = 1, 10
      IF (INCHAR == EXTDIG(I)) [
         INMAP = INTDIG(I)
         RETURN
         ] 
    DO I = 1, 26
      IF (INCHAR == EXTLET(I)) [
         INMAP = INTLET(I)
         RETURN
         ] 
   DO I = 1, 26
      IF (INCHAR == EXTBIG(I)) [
         INMAP = INTBIG(I)
         RETURN
         ] 
   DO I = 1, NCHARS
      IF (INCHAR == EXTCHR(I)) [
         INMAP = INTCHR(I)
         RETURN
         ] 
   INMAP = INCHAR
   RETURN
   END
ENDIFDEF

#
# INSTAL - ADD 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
      INSTAL=YES
      ]
   ELSE
      INSTAL=BAD
#
   RETURN
   END
#
# LABELC -  OUTPUT FORTRAN STATEMENT NUMBERS
#
   SUBROUTINE LABELC(LEXSTR)
#
   CHARACTER LEXSTR(DUMMYSIZE)
   INTEGER SLEN
#
   IF (SLEN(LEXSTR) == 5)				# WARN ABOUT 20XXX LABELS
      IF (LEXSTR(1) == DIG2 & LEXSTR(2) == DIG0)
         CALL SYNERR ("POSSIBLE STATEMENT NUMBER CONFLICT.")
   CALL OUTSTR(LEXSTR)
   CALL OUTTAB
   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'
#
   INTEGER FUNCTION LEX(LEXSTR)
#
   CHARACTER LEXSTR(MAXTOK), GETTOK
   INTEGER ALLDIG, SEQL
#
INCLUDE CKEYWD
#
   WHILE (GETTOK(LEXSTR, MAXTOK) ==  NEWLINE)
      ; 
   LEX = LEXSTR(1)
   IF (LEX==EOF \ LEX==SEMICOL \ LEX==LBRACE \ LEX==RBRACE)
      RETURN
   IF (ALLDIG(LEXSTR) == YES)
      LEX = LEXDIGITS
   ELSE IF (SEQL(LEXSTR, SIF) == YES)
      LEX = LEXIF
   ELSE IF (SEQL(LEXSTR, SELSE) == YES)
      LEX = LEXELSE
   ELSE IF (SEQL(LEXSTR, SWHILE) == YES)
      LEX = LEXWHILE
   ELSE IF (SEQL(LEXSTR, SDO) == YES)
      LEX = LEXDO
   ELSE IF (SEQL(LEXSTR, SBREAK) == YES)
      LEX = LEXBREAK
   ELSE IF (SEQL(LEXSTR, SNEXT) == YES)
      LEX = LEXNEXT
   ELSE IF (SEQL(LEXSTR, SFOR) == YES)
      LEX = LEXFOR
   ELSE IF (SEQL(LEXSTR, SREPT) == YES)
      LEX = LEXREPEAT
   ELSE IF (SEQL(LEXSTR, SUNTIL) == YES)
      LEX = LEXUNTIL
   ELSE IF (SEQL(LEXSTR,SEND) == YES)		#SYKES 26 SEP 76
      LEX = LEXEND
   ELSE IF (SEQL(LEXSTR, SSTOP) == YES)		#PCN#10
      LEX=LEXSTOP
   ELSE IF (SEQL(LEXSTR, SRETRN) == YES)		#PCN#10
      LEX=LEXRETURN
   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)
               LOOKFR=YES
               RETURN
               ]
            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)
      ]
   LOOKFR=NO
#
   RETURN
   END
#
# MATH - SUBROUTINE TO DO MATH IN MACRO DEFINITIONS
# SYKES APR 77
# + AND - INTEGER NUMBERS AND DEFINITIONS ARE ALLOWED
#
   SUBROUTINE MATH  (FILE)
#
   INTEGER SCTOI, SITOC, NUM1, NUM2, JUNK, FILE
   CHARACTER TOKDEF, OPR, NGETCH, TOKEN(MAXTOK)
#
   IF (TOKDEF (TOKEN, MAXTOK, FILE) != BAD) [	#FIRST NUMBER
      JUNK=1
      NUM1=SCTOI (TOKEN, JUNK)
      WHILE (NGETCH(OPR, FILE) != GREATER) [		#MATH OPERATOR
         JUNK=TOKDEF (TOKEN, MAXTOK, FILE)		#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 OPERATION.")
            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
#
   CHARFUNC FUNCTION NGETCH FUNCSIZE(C, F)
#
   CHARACTER BUFR(MAXLINE), C, GETLIN
   INTEGER F, LASTC
#
INCLUDE CDEFIO
#
INCLUDE CLINE
#
  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, F) == EOF) [		#READ A LINE IN
            C=EOF
            NGETCH=EOF
            LASTC=MAXLINE		#FOR REINITIALIZATION SYKES 5 OCT 76
            BP=0
            RETURN
            ]
         ]
      INCREMENT(LASTC)
      IF (BUFR(LASTC) == EOS)
         BUFR(LASTC) = NEWLINE		#EOS FROM GETLIN REALLY MEANS EOL
      C=BUFR(LASTC)
      ] 
   DECREMENT(BP)
   NGETCH = C
#
   RETURN
   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
   INTEGER I
#
INCLUDE COUTLN
#
   IF (OUTP > 70 \ OUTP < 0) [  	# CONTINUATION CARD,  SYKES 26 SEP 76
      CALL OUTDON
      FOR (I = 1; I < 6; INCREMENT (I))
         OUTBUF(I) = BLANK
      OUTBUF(6) = CONTINCHAR		#THE CONTINUATION FLAG CHAR.
      OUTP = 6
      ] 
   INCREMENT (OUTP)
   OUTBUF(OUTP) = C
#
   RETURN
   END