#======== 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 OF SYMBOLIC CONSTANT.")
   ELSE
      IF (INSTAL(TOKEN,DEFN,LASTP,LASTT,NAMPTR,MAXTBL,MAXPTR,TABLE) == BAD)
         CALL SYNERR ("TOO MANY SYMBOLIC CONSTANT 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
# PCN 107, 29 SEP 80, ALLOW MULTI LEVEL BREAK AND NEXT.
#
   SUBROUTINE  BRKNXT (SP, LEXTYP, LABVAL, TOKEN)
#
   INTEGER I, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN
   INTEGER ALLDIG, SCTOI, N
   CHARACTER T, NUMB(MAXTOK), GTOK
#
   N=0
   T=GTOK (NUMB, MAXTOK)			#***PCN 107
   IF (ALLDIG(NUMB) == YES) [			#WE HAVE A MULTI-LEVEL ONE
      I=1
      N= SCTOI(NUMB, I)-1			#GET THE LEVEL NUMBER
      ]
   ELSE IF (T != SEMICOL)
      CALL PBSTR(NUMB)				#WASN'T MULTI-LEVEL
   FOR (I = SP; I > 0; DECREMENT (I))
      IF (LEXTYP(I) == LEXWHILE \ LEXTYP(I) == LEXDO
            \ LEXTYP(I) == LEXFOR \ LEXTYP(I) == LEXREPEAT)[
         IF (N > 0) [
            DECREMENT (N)	#PCN #107
            NEXT		#SKIP STATEMENT GROUPS TO GET TO RIGHT LEVEL
            ]
         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 SEPARATE 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 NOT ALLOWED.")
            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 I/O 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.
# PCN 109, 1 OCT 80, CHANGE DATA TYPE OF 'LAST' TO INTEGER.
#
   SUBROUTINE ELSEIF (LAB, LAST)
#
   INTEGER LAB, 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 MODULE.")
         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 SYNTAX.")
      ]	 
   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 ("FOR REINIT CLAUSE(S) TOO LONG (INCREASE MAXFORSTK).")	#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
#
#$ GETDEF 	- GET SYMBOLIC CONSTANTS AND DEFINITIONS
# SYKES, DEC76, ALLOW SINGLE ARGUMENT MACRO DEFINITIONS.  STORE "MAXTYPE" AS
#  FIRST CHAR OF MACRO DEFINITIONS, SO 'DEFMAC' CAN TELL MACROS FROM SYMBOLS.
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
#   BLANKS ARE PRESERVED IN A DEFINITION
#
   SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ)		#PCN 94
#
   CHARACTER GTOK, NGETCH, TEMP(5)
   INTEGER DEFSIZ, I, NLPAR, TOKSIZ, INDEX, JUNK, SCOPY
   CHARACTER C, DEFN(DEFSIZ), TOKEN(TOKSIZ)
#
   DEFN(1)=EOS			#ERROR RETURNS GIVE NULL DEFIN.
   IF (GTOK(TOKEN,TOKSIZ) != LPAREN) [
      CALL SYNERR("NO ( IN DEFINE.")
      RETURN
      ]
   IF (GTOK(TOKEN,TOKSIZ) != ALPHA) [
      CALL SYNERR ("SYMBOLIC CONSTANT NAMES MUST START WITH LETTER.")
      RETURN
      ]
   ELSE IF (GTOK(TEMP,5) != 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("SYMBOLIC DEFINITION TOO LONG (INCREASE MAXDEF).")
         RETURN
         ]
      IF (NGETCH(DEFN(I)) == EOF) [
         CALL SYNERR("NO ) IN DEFINE.")
         RETURN
         ]
      ELSE
         IF (DEFN(I) == LESS) [		#LOOK FOR A '<'
            CALL MATH  			#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
#
#$ GTFUNC	- GET AND SAVE THE FUNCTION NAME FOR RETURN(EXPRESSION)
#PCN #92, 20 FEB 80
# PCN #103, LOOKUP ANY DEFINITION OF FUNCTION NAME BEFORE SAVEING
## DEPENDS ON THE WAY LOOKFR DOES NOT CHANGE 2ND STRING UNLES DEFIN. IS FOUND.
#
   SUBROUTINE GTFUNC
#
?  INTEGER STRPUT
   INTEGER LOOKFR, JUNK
   CHARACTER GTOK, T, TYPE
#
INCLUDE CFUNC
#
   T=GTOK (FNAM, MAXTOK)			#1ST THING AFTER 'FUNCTION' IS FUNCTION'S NAME
   CALL UNFOLD (FNAM)		#CONVERT TO UPPER CASE
   JUNK=LOOKFR (FNAM, FNAM)		#CONVERT IT TO DEFINED NAME, IF ANY***PCN103
   CALL PBSTR (FNAM)			#PUT IT BACK FOR NEXT DEFTOK
   IF (INFUNC == YES \ T != ALPHA \ TYPE(FNAM(1)) != LETTER)	#IS IT LEGAL?
      CALL SYNERR ("ILLEGAL FUNCTION NAME.")
   ELSE
      INFUNC=YES			#NOTE THAT WE ARE IN A VALID FUNCTION
?  JUNK=STRPUT (USEROUT, FNAM, BLANK)
#
   RETURN
   END
#
#$ GTOK	- GET TOKEN; INTERPRET SPECIAL CHAR, DELETE BLANKS,TABS
# PCN #73, DEC 79, ADD TILDE,CARET FOR .NOT.
# PCN #87, 12 FEB 80, PASS '...' STRINGS WITHOUT PROCESSING.
# PCN 94, 17 FEB 80, STOP PASSING CURRENT INPUT FILE LUN ALL OVER.
# PCN 102, 29 MAR 80, ALLOW UNDERLINE EMBEDDED IN TOKENS
#
   CHARFUNC FUNCTION GTOK FUNCSIZE(TOKEN, TOKSIZ)		#PCN 94
#
   INTEGER I, TOKSIZ
   CHARACTER C, TOKEN(TOKSIZ), NGETCH, TYPE
#
   WHILE (NGETCH(C) != 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(TOKEN(I)))		#CONSTRUCT A TOKEN
      IF (GTOK != LETTER & GTOK != DIGIT & GTOK != UNDERLINE)	#PCN 102
         BREAK
      ] 
#
   IF (I >= TOKSIZ-1)
      CALL SYNERR("TOKEN TOO LONG (INCREASE MAXTOK).")
   IF (I > 1) [          			# SOME ALPHA SEEN
      CALL PUTBAK(TOKEN(I))   		# WENT ONE TOO FAR
      TOKEN(I) = EOS
      GTOK = ALPHA
      ]
#
# DO SOME CHARACTER CONVERSIONS TO MAKE THINGS EASIER LATER
   ELSE IF (TOKEN(1) == BACKSLASH) [		#SYKES 15 OCT 76
      TOKEN(1)=BAR				#MAKE BACKSLASH=BAR (OR)
      GTOK=BAR
      ]
   ELSE IF (TOKEN(1) == LBRACK) [		#SYKES 26 SEP 76
      TOKEN(1)=LBRACE				#MAKE BRACKETS=BRACES
      GTOK=LBRACE
      ]
   ELSE IF (TOKEN(1) == RBRACK) [
      TOKEN(1) = RBRACE
      GTOK = RBRACE
      ]
   ELSE IF (TOKEN(1) == TILDE \ TOKEN(1) == CARET) [	#PCN#73, DEC 79
      TOKEN(1)=NOT
      GTOK=NOT
      ]
## ELSE IF (TOKEN(1) == DOLLAR) [  		# ALLOW $( AND $) FOR BRACES
##    IF (NGETCH(TOKEN(2)) == LPAREN) [
##       TOKEN(1) = LBRACE
##       GTOK = LBRACE
##       ] 
##    ELSE IF (TOKEN(2) == RPAREN) [
##       TOKEN(1) = RBRACE
##       GTOK = RBRACE		##SYKES, 22NOV76
##       ] 
##    ELSE
##       CALL PUTBAK(TOKEN(2))
##    ] 
   ELSE IF (TOKEN(1) == DQUOTE \ TOKEN(1) == SQUOTE) [	#***PCN #87
# COLLECT QUOTED STRINGS AS SINGLE TOKENS WITHOUT PROCESSING.
      FOR (I = 2; NGETCH(TOKEN(I)) != TOKEN(1); INCREMENT (I))
         IF (TOKEN(I) == NEWLINE \ I >= TOKSIZ-1)[
            CALL SYNERR("MISSING QUOTE.")
            TOKEN(I) = TOKEN(1)			#ADD A QUOTE TO TRY TO RECOVER
            CALL PUTBAK(NEWLINE)
            BREAK
            ] 
      IF (TOKEN(1) == SQUOTE & I == 2)		#***PCN #87, CONVERT '' TO '
         I=1						# FOR WRITE (?'?)
      ] 
   ELSE IF (TOKEN(1) == SHARP) [			# STRIP COMMENTS
      WHILE (NGETCH(TOKEN(1)) != NEWLINE)
           ; 
      GTOK = NEWLINE
      ] 
   IF (TOKEN(1) == GREATER \ TOKEN(1) == LESS \ TOKEN(1) == NOT
      \ TOKEN(1) == EQUALS \ TOKEN(1) == AMPER \ TOKEN(1) == BAR)
      CALL RELATE(TOKEN, I)			#CONVERT RELATIONAL EXPRESSIONS
   TOKEN(I+1) = EOS
#
   RETURN
   END
#
#$ IFFORTRAN CODE	- 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,
# PCN 77, 5 JAN 80, ADD UNFOLD, SO 'IFDEF' ETC CAN BE LOWER CASE.
#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
#
   STRING ENDIF "ENDIFDEF"
   STRING IFDEFS "IFDEF"
   STRING IFNOT "IFNOTDEF"
#
   IF (GTOK(TOKEN,MAXTOK) != LPAREN) [
      CALL SYNERR ("MISSING ( IN IFDEF.")
      CALL PBSTR (TOKEN)
      RETURN
      ]
   IF (GTOK(TOKEN,MAXTOK) != ALPHA \
                          TYPE(TOKEN(1)) != LETTER) [
      CALL SYNERR ("ILLEGAL SYMBOLIC CONSTANT USED IN IFDEF.")
      CALL PBSTR (TOKEN)
      RETURN
      ]
#
   IF (LOOKFR(TOKEN,JUNK) == CTRL)[			#RIGHT FOR IFDEF AND IFNOTDEF
      IF (GTOK(TOKEN,MAXTOK) != 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) != EOF) [		#THROW STUFF AWAY MEANWHILE
            CALL UNFOLD (TOKEN)			#PCN#77, CONVERT TO UPPER CASE
            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 (NO ENDIFDEF).")
            CALL PUTBAK (TOKEN)
            BREAK
            ]
         ]
      INIF=NO		#FINISHED WITH OUR UNDEFINED IFDEF
      RETURN
      ]
#
   END
#
#$ IFGO	- GENERATE CODE:  "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 EXTERNAL CHAR TO INTERNAL ASCII
#
   CHARFUNC FUNCTION INMAP FUNCSIZE (INCHAR)
#
   CHARACTER INCHAR
   INTEGER I
#
INCLUDE CCHAR
#
   IF (INCHAR == EXTBLK) 
      RETURN (INTBLK)
   DO I = 1, 10
      IF (INCHAR == EXTDIG(I)) 
         RETURN (INTDIG(I))
    DO I = 1, 26
      IF (INCHAR == EXTLET(I)) 
         RETURN (INTLET(I))
   DO I = 1, 26
      IF (INCHAR == EXTBIG(I)) 
         RETURN (INTBIG(I))
   DO I = 1, NCHARS
      IF (INCHAR == EXTCHR(I)) 
         RETURN (INTCHR(I))
   RETURN (INCHAR)
   END
ENDIFDEF