#%%A-RCB-0047-SL-18-5     THE RATFOR LIBRARY
#
#  MODIFIED FOR USE WITH THE SYKES RATFOR PREPROCESSOR
#
# 
#

INCLUDE DEFN
 
# RETURN YES IF S1==S2, NO OTHERWISE
 
INTEGER FUNCTION EQUAL(S1,S2)
CHAR S1(ARB), S2(ARB)
INTEGER I
FOR (I=1; S1(I)==S2(I); I=I+1)
   IF (S1(I)==EOS) RETURN (YES)
RETURN (NO)
END
# RETURN NUMBER OF CHARACTERS IN STR
 
INTEGER FUNCTION LENGTH(STR)
CHAR STR(ARB)
 
FOR (I=0; STR(I+1)~=EOS; I=I+1)
   ;
RETURN (I)
END
# COPY UP TO MAX CHARACTERS FROM "FROM" TO "TO"
 
SUBROUTINE SCOPY (FROM,START1,TO,START2,MAX)
CHAR FROM(ARB), TO(ARB)
INTEGER START1, START2, K1, K2, MAX, COUNT
 
K1 = START1
K2 = START2
FOR ( COUNT=1; FROM(K1)~=EOS & COUNT<MAX; COUNT=COUNT+1) {
   TO(K2) = FROM(K1)
   K2 = K2+1
   K1 = K1+1
}
TO(K2) = EOS
RETURN
END
# RETURN NUMERIC IF C IS DIGIT, ALPHABETIC IF C IS A LETTER, 
# ELSE RETURN CHARACTER C ITSELF.
 
CHAR FUNCTION TYPE(C)
CHAR C
 
IF (C>=48 & C<=57)
   RETURN (NUMERIC)
ELSE IF ((C>=65 & C<=90) |
         (C>=97 & C<=122)) 
   RETURN (ALPHABETIC)
ELSE
   RETURN (C)
END
# MAKE IN(I) A BASE BASE INTEGER AND BUMP I TO NEXT DELIMITER
 
INTEGER FUNCTION CTOI(IN,I,BASE)
CHAR IN(ARB), DIGITS(11)
INTEGER BASE,I,D
DATA DIGITS /"0","1","2","3","4","5","6","7","8","9",EOS/
 
WHILE (IN(I)==BLANK | IN(I)==TAB) I=I+1
FOR (CTOI=0; IN(I)~=EOS; I=I+1) {
   D = INDEX(DIGITS, IN(I))
   IF (D == 0)
      BREAK
   CTOI = BASE*CTOI + D-1
}
RETURN
END
# FIND CHAR C IN STRING STR; RETURN 0 IF IT IS NO THERE
 
INTEGER FUNCTION INDEX(STR,C)
CHAR C,STR(ARB)
FOR (INDEX=1; STR(INDEX)~=EOS; INDEX=INDEX+1)
   IF (STR(INDEX)==C)
      RETURN
 
RETURN (0)
END
# PUT OUT ERROR MESSAGE MESS ON LUN LUN IDENTIFIED BY PRGNAM
 
SUBROUTINE MCRERR(LUN,PRGNAM,MESS)
CHAR PRGNAM(3),MESS(ARB)
INTEGER LENGTH,LUN,I
WRITE(LUN,10) PRGNAM,(MESS(I),I=1,LENGTH(MESS))
10 FORMAT ("0", 3A1, " -- ", 255A1)
RETURN
END
# UNOPENABLE FILE MESSAGE
 
SUBROUTINE CANT(LUN,PRGNAM,FNAME)
CHAR PRGNAM(3), FNAME(ARB)
INTEGER LENGTH,L,I
 
L=LENGTH(FNAME)
IF (L <= 0)
   WRITE(LUN,10) PRGNAM
ELSE
   WRITE(LUN,20) PRGNAM, (FNAME(I),I=1,L)
RETURN
10 FORMAT("0",3A1, " -- NULL FILE NAME")
20 FORMAT("0",3A1," -- CAN'T OPEN THIS FILE:  ",255A1)
END
# STOP F4P OTS FROM PRINTING MESSAGES FOR SOME FILE OPEN ERRORS
 
SUBROUTINE KILFER             #KILL FILE ERRORS
CALL ERRSET(29,,.FALSE.,,.FALSE.)
CALL ERRSET(43,,.FALSE.,,.FALSE.)
RETURN
END
DEFINE (MAXINPUT,132)
 
# GETC RETURN THE NEXT INPUT CHAR FROM LUN STDLUNIN IN C AND IN GETC
 
CHAR FUNCTION GETC(C)
CHAR C,BUF(MAXINPUT)
INTEGER N,GETL,POS
DATA POS/1/, N/0/
 
IF (POS <= N) {                         # STILL MORE CHARS IN INPUT BUFFER
   C = BUF(POS)
   POS = POS+1
}
ELSE {
   N = GETL(BUF, MAXINPUT, STDLUNIN)
   IF (N == EOF) 
      C = EOF
   ELSE {
      N=N+1
      BUF(N) = NEWLINE
      POS = 2
      C = BUF(1)
   }
}
RETURN (C)
END
# GETL RETURNS THE NEXT MAXLIN CHARS OF THE NEXT LINE FROM LUN LUNIN.
 
INTEGER FUNCTION GETL(LINE, MAXLIN, LUNIN)
INTEGER N,MAXLIN,LUNIN
CHAR LINE(MAXLIN)
 
READ (LUNIN,10,END=100) N,LINE
10 FORMAT (Q, 255A1)
IF (N >= MAXLIN) N = MAXLIN-1
LINE(N+1) = EOS
RETURN (N)                             # RETURNS THE LINE LENGTH
 
100 RETURN (EOF)
END
# PUTC PUTS NEXT CHAR IN OUTPUT BUFFER, FLUSHING BUFFER IF CHAR == NEWLINE
 
DEFINE (MAXOUTPUT,132)       # FOLD LINES LONGER THAN THIS
SUBROUTINE PUTC(C)
CHAR C,BUF(MAXOUTPUT)
INTEGER POS
DATA POS /1/
 
IF (C==EOF) RETURN
IF (C==NEWLINE | POS>=MAXOUTPUT) {
   BUF(POS) = EOS
   CALL PUTL(BUF,STDLUNOUT)
   POS=1
}
IF (C~=NEWLINE) {
   BUF(POS) = C
   POS = POS+1
}
RETURN
END
# PUTL WRITES STRING LINE TO LUN LUNOUT
 
SUBROUTINE PUTL(LINE, LUNOUT)
CHAR LINE(ARB)
INTEGER L,LENGTH,I,LUNOUT
 
L = LENGTH(LINE)
IF (L>0)
   WRITE(LUNOUT,10) (LINE(I),I=1,L)
ELSE
   WRITE(LUNOUT,10)                        # WRITE A NULL RECORD FOR EMPTY LINES
10 FORMAT( 255A1)
RETURN
END
# GET NEXT MCR LINE: FROM GETMCR, INDIRECT FILE (1 LEVEL), OR PROMPTING.
# PROMPT ON LUNPMT.  LUN LUNIND ~=0 IF INDIRECT FILE LUN AVAILABLE.
# PRE-SCAN MCR LINE, AND SET NUMOUT=NUMBER OF (POSSIBLY NULL) OUTPUT FILES.
 
INTEGER FUNCTION NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)
CHAR PROMPT(3),MCR(82),CJUNK,FN(41),TYPE
INTEGER NUMOUT,DONE,I,N,POS,LUNIND,FIRST,NBRCK,ININD,GETL
COMMON /MCRNFO/ MCR,POS
DATA DONE/NO/, FIRST/YES/, ININD/NO/
 
IF (LUNPMT<0) {
   CLOSE (UNIT=LUNIND)
   ININD=NO
   RETURN (YES)
   }
#%^
REPEAT {          # UNTIL NON-BLANK MCR LINE OR END OF MCR INPUT
   IF (DONE==YES & ININD==NO) RETURN (NO)
   IF (FIRST==YES) {
      CALL GETMCR(MCR,N)
      FOR (POS=1; POS<=N & MCR(POS)~=BLANK & MCR(POS)~=TAB; POS=POS+1) {}
      WHILE (POS<=N & MCR(POS)==BLANK | MCR(POS)==TAB) POS=POS+1
      IF (POS<=N) DONE=YES
      FIRST = NO
      }
   ELSE {
      IF (ININD==YES & LUNIND>0) {
         N = GETL(MCR,80,LUNIND)
         IF (N==EOF) {
            ININD = NO
            CLOSE (UNIT=LUNIND)
            }
         }
      ELSE {
         WRITE(LUNPMT,10) PROMPT
         10 FORMAT ("$",3A1,">")
         READ (LUNPMT,20,END=1000) N,MCR
         20 FORMAT(Q,82A1)
         }
      FOR (POS=1; POS<=N & MCR(POS)==BLANK | MCR(POS)==TAB; POS=POS+1) {}
      }
   IF (POS<N & MCR(POS)=="@") {
      MCR(N+1) = EOS
      N = -1            # FORCE N<POS TO GET ANOTHER READ
      IF (ININD==YES | LUNIND <=0)
         CALL MCRERR(LUNPMT,PROMPT,"COMMAND FILE INVALID HERE")
      ELSE {
         POS = POS+1
         JUNK = NXTFIL(".CMD",FN,41,CJUNK,1)
	 OPEN(UNIT=LUNIND,NAME=FN,TYPE='OLD',ERR=30,READONLY)
         ININD = YES
         GO TO 31	# BRANCH AROUND ERROR MESSAGE
         30 CALL MCRERR(LUNPMT,PROMPT,"CAN'T OPEN INDIRECT COMMAND FILE")
	 31 CONTINUE 
         }
      }
} UNTIL (POS<=N)
#%^
NUMOUT = 1
NBRCK = 0
MCR(N+1) = EOS
 
FOR (I=1; MCR(I)~=EOS; I=I+1)
   IF (MCR(I)=="[")                 NBRCK = NBRCK+1
   ELSE IF (MCR(I)=="]")            NBRCK = NBRCK-1
   ELSE IF (MCR(I)=="," & NBRCK==0) NUMOUT = NUMOUT+1
   ELSE IF (MCR(I)=="=")            BREAK
IF (MCR(I) ~= "=")
   NUMOUT = 0                           # NO = ON MCR LINE
RETURN (YES)     
 
1000 DONE=YES
RETURN (NO)
END
# PICK UP NEXT FILE NAME FROM MCR AND PUT IN FNAME WITH EXTENSION EXT
# IF NONE THERE.  SWITCHES GO INTO SWITCH.  ONLY FIRST MAXFNM CHARS OF 
# FILE NAME KEPT; ONLY FIRST MAXSW CHARS OF SWITCHES KEPT.
 
INTEGER FUNCTION NXTFIL(EXT, FNAME, MAXFNM, SWITCH, MAXSW)
CHAR EXT(4),FNAME(MAXFNM),SWITCH(MAXSW), MCR(82)
INTEGER MAXFNM,MAXSW,POS,GOTDOT,I,J,NBRK
COMMON /MCRNFO/ MCR, POS
 
WHILE (MCR(POS)==BLANK | MCR(POS)==TAB) POS = POS+1
IF (MCR(POS)==EOS) RETURN (NO)
FNAME(1) = EOS
SWITCH(1) = EOS
I = 1
GOTDOT = NO
 
FOR (NBRAK=0; MCR(POS)~=EOS & MCR(POS)~="/" & MCR(POS)~="=" &
              (MCR(POS)~="," | NBRK > 0);   POS = POS+1) {
   IF (MCR(POS)>=97 & MCR(POS)<=122) MCR(POS) = MCR(POS) - 32 
   ELSE IF (MCR(POS) == ".") GOTDOT = YES
   ELSE IF (MCR(POS) == "[") NBRK = NBRK+1
   ELSE IF (MCR(POS) == "]") NBRK = NBRK-1
   ELSE IF (MCR(POS)==";" & GOTDOT==NO) {
      FOR (J=1; I<MAXFNM & J<=4; J=J+1) {
         FNAME(I) = EXT(J)                    #COPY IN EXTENSION BEFORE ;
         I = I+1
      }
      GOTDOT = YES
   }
   IF (I<MAXFNM & MCR(POS)~=BLANK & MCR(POS)~=TAB) {
      FNAME(I) = MCR(POS)
      I=I+1
   }
}
#%^
IF (GOTDOT==NO & I>1)
   FOR (J=1; I<MAXFNM & J<=4; J=J+1) {
      FNAME(I) = EXT(J)
      I=I+1
   }
FNAME(I) = EOS
J = 1
IF (MCR(POS)=="/")
   FOR (POS=POS+1; MCR(POS)~="=" & MCR(POS)~=EOS &
                                   MCR(POS)~=","     ; POS=POS+1)
      IF (J < MAXSW) {
         SWITCH(J) = MCR(POS)
         J = J+1
      }
SWITCH(J) = EOS
IF (MCR(POS)~=EOS) POS = POS+1
RETURN (YES)                                # YES, I GOT A FILE NAME
END
 
# SET UP LISTING PROGRAM - MCR LINE CONTAINS ONLY INPUT FILE & SWITCHES.
# IF NO INPUT, DEFAULT TO PIPE.LYN & OPEN FILE AS DELETE DISPOSITION.
 
INTEGER FUNCTION SETOTL (LUNPMT,PROMPT,EXTIN,LUNIND)
CHAR EXTIN(4),SWITCH(80),FIN(41),DEFILE(9),PROMPT(3)
INTEGER NXTFIL,I,DELETE,EQUAL,LUNPMT,LUNIND,NXTMCR
COMMON /SWITCH/ SWITCH
DATA DEFILE/"P", "I", "P", "E",".","L","Y","N",EOS/
 
CALL KILFER
 
CLOSE (UNIT=STDLUNIN)
REPEAT {         # UNTIL GOOD MCR LINE OR NO MORE MCR INPUT
   IF (NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)==NO) RETURN (NO)
   IF (NUMOUT>0) {
      CALL MCRERR(LUNPMT,PROMPT,"EXACTLY ONE INPUT FILE NEEDED")
      NEXT
   }
   JUNK = NXTFIL(EXTIN,FIN,41,SWITCH,80)
   IF (FIN(1) == EOS) CALL SCOPY(DEFILE,1,FIN,1,41)
   IF (EQUAL(DEFILE,FIN)==YES)
	OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,DISP='DELETE')
   ELSE
	OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,READONLY)
   RETURN (YES)
    
   1000  CALL MCRERR(LUNPMT,PROMPT,"CAN'T OPEN INPUT FILE")
}
END
INTEGER FUNCTION SETFLT(LUNPMT,PROMPT,EXTIN,EXTOUT,LUNIND)
INTEGER MAXSW,FIRST,NXTMCR,NXTFIL,JUNK,LUNIND,EQUAL,I
CHAR SWITCH(80),PROMPT(3),EXTIN(4),EXTOUT(4),FIN(41),FOUT(41),DEFILE(9)
COMMON /SWITCH/ SWITCH
DATA  DEFILE/"P","I","P","E",".","L","Y","N",EOS/
 
CALL KILFER
CLOSE(UNIT=STDLUNIN)
CLOSE(UNIT=STDLUNOUT)
REPEAT {             # UNTIL GOOD MCR LINE OR END OF MCR INPUT
   IF (NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)==NO) RETURN (NO)
   IF (NUMOUT>1)  {
      CALL MCRERR(LUNPMT,PROMPT,"BAD MCR LINE")
      NEXT
   }
   ELSE IF (NUMOUT==1) 
      JUNK = NXTFIL(EXTOUT,FOUT,41,SWITCH,80)
   ELSE 
      FOUT(1) = EOS
   IF (NXTFIL(EXTIN,FIN,41,SWITCH,80)==NO)
      FIN(1) = EOS
   ELSE 
      IF (NXTFIL (EXTIN,FIN,41,SWITCH,80)==YES) {
         CALL MCRERR(LUNPMT,PROMPT,"BAD MCR LINE")
         NEXT
      }
   IF (FIN(1)==EOS) CALL SCOPY(DEFILE,1,FIN,1,41)
   IF (FOUT(1)==EOS) CALL SCOPY(DEFILE,1,FOUT,1,41)
   IF (EQUAL(DEFILE,FIN)==YES)
	OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',DISPOSE='DELETE',ERR=1000)
   ELSE
	OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,READONLY)
	OPEN (UNIT=STDLUNOUT,NAME=FOUT,CARRIAGECONTROL='LIST',ERR=1001,
	 TYPE='NEW')
   RETURN (YES)
 
   1000  CALL CANT(LUNPMT,PROMPT,FIN)
         NEXT
   1001  CALL CANT(LUNPMT,PROMPT,FOUT)
         CLOSE (UNIT=STDLUNIN,DISPOSE='SAVE')    #  IF BAD OUTPUT, KEEP INPUT
}
END
# GET SLASH DELIMITED ARGUMENT NUMBER ARGNUM PLACING FIRST MAXARG CHARS
# IN ARG. SLASHES LOSE DELIMITER FUNCTION IF PRECEDED BY ESCAPECHAR.
# ARGS NOW STORED IN ARRAY SWITCH SET BY SETFLT OR SETOTL. 
 
INTEGER FUNCTION GETARG(ARGNUM,ARG,MAXARG)
CHAR SWITCH(80), ARG(MAXARG)
INTEGER ARGNUM,MAXARG,I,CNTARG,J
DEFINE (DELIMITER,"/")
COMMON /SWITCH/ SWITCH
 
ARG(1) = EOS
IF (ARGNUM<=0 | MAXARG<=1 | SWITCH(1)==EOS) RETURN (EOF) # NO SUCH ARGUMENT
 
I=1
CNTARG=1
WHILE (CNTARG<ARGNUM) {
   IF (SWITCH(I)==EOS)
      RETURN (EOF)
   IF (SWITCH(I)==DELIMITER)
      CNTARG=CNTARG+1
   IF (SWITCH(I)==ESCAPECHAR & SWITCH(I+1)~=EOS)
      I=I+2
   ELSE
      I=I+1
}
 
J=1
FOR (; J<MAXARG & SWITCH(I)~=DELIMITER & SWITCH(I)~=EOS; I=I+1) {
   IF (SWITCH(I)==ESCAPECHAR & SWITCH(I+1)~=EOS)
      I=I+1
   ARG(J) = SWITCH(I)
   J=J+1
}
ARG(J)=EOS
RETURN (J-1)    # DON"T COUNT EOS IN RETURNED LENGTH
END
#			R A T L B 2
#
#		     RATFOR LIBRARY 2
#	     MORE STRING PROCESSING ROUTINES
#
#		   RICHARD L. MICHAUD
#		   BRIDGEPORT CONTROLS
#		   200 PRECISION ROAD
#		       HORSHAM,PA.
#		       18-JUL-78
#
#	RATLB2 CONTAINS SEVERAL STRING PROCESSING FUNCTIONS WRITTEN
# IN RATFOR.  EACH FUNCTION MUST BE DECLARED AS INTEGER BY THE
# CALLING PROGRAM.  STRINGS ARE THE STANDARD RATFOR STRING - BYTE
# ARRAYS WITH AN OCTAL ZERO AS THE LAST CHARACTER IN THE STRING.
#
## MODIFICATIONS MADE TO MAKE COMPATABLE WITH SYKES" INCLUDE:
##	>>  -->  >
##	<<  -->  <
##
## THERE WERE NO "&&", "!!", OR OCTAL REPRESENTATIONS.
## 	AL 1/16/80
 

# * - SPAN - SPAN ACROSS (REMOVE) LONGEST STRING IN S1 CONTAINED IN S2.
#	ON SUCCESS, SPAN WILL STORE SPANNED SUBSTRING IN S3 AND
#	THE FUNCTION WILL RETURN THE NEW SIZE OF S1.
#
#	SPAN WILL FAIL IF ALL CHARACTERS IN S1 ARE CONTAINED IN S2.
#	THE FUNCTION WILL RETURN -1 AND S3 WILL BECOME A NULL STRING.
#
#	SPAN WILL ALSO FAIL IF THE FIRST CHARACTER IN S1 IS NOT CONTAINED
#	IN S2.  THE FUNCTION WILL RETURN 0 AND S3 WILL BECOME A NULL STRING.
 
#	SPAN MUST BE DECLARED INTEGER BY THE CALLING PROGRAM AND S1,S2 AND
#	S3 MUST BE RATFOR STRINGS. S1 AND S2 MAY BE LITERAL, BUT S3 MUST
#	BE A STRING VARIABLE.
 
INTEGER FUNCTION SPAN(S1,S2,S3)
 
CHAR S1(ARB), S2(ARB), S3(ARB)
INTEGER D,INDEX,LENGTH
 
FOR (I=0; S1(I+1) <> EOS; I=I+1)[
  IF(INDEX(S2,S1(I+1)) == EOS)
    IF(I == 0)[
      S3(1)= EOS
      RETURN (0)
  ENDIF
 
  ELSE[
    K=I+1
    CALL SCOPY(S1,1,S3,1,K)		# COPY SPANNED CHARS INTO S3
    CALL SCOPY(S1,K,S1,1,ARB)		# S1 INTO S1, REMOVING K CHARS.
    K=LENGTH(S1)			# FIND NEW LENGTH OF S1.
    RETURN (K)				# RETURN NEW SIZE OF S1.
  ENDELSE
 
ENDFOR
S3(1) = EOS				# FINISH FOR LOOP IF ALL S1 IN S2.
RETURN (-1)
END
# * - BRAKE - SKIP ACROSS LONGEST SUBSTRING IN S1 NOT CONTAINED IN S2.
#
#	ON SUCCESS, BRAKE WILL TRANSFER TO S3 ALL CHARS UP TO THE FIRST BREAK
#	CHARACTER AND RETURN THE NEW SIZE OF S1.
#
#	BRAKE WILL FAIL IF THE FIRST CHAR IN S1 IS A BREAK CHARACTER, S3
#	WILL BE MADE A NULL STRING, AND THE FUNCTION WILL RETURN 0.
#
#	BRAKE WILL FAIL IF S1 CONTAINS NO CHARACTERS IN S2, S3 WILL BE 
#	MADE A NULL STRING AND THE FUNCTION WILL RETURN -1.
#
#	BRAKE MUST BE DECLARED AS INTEGER, S1,S2, AND S3 AS CHAR.
#	S2 MAY BE LITERAL.
 
INTEGER FUNCTION BRAKE(S1,S2,S3)
 
INTEGER INDEX,I,K
CHAR S1(ARB), S2(ARB), S3(ARB)
 
FOR (I=0; S1(I+1) <> EOS; I=I+1)[
 
  IF(INDEX(S2,S1(I+1)) <> EOS)		# IF CAN FIND A MATCH-
 
    IF (I== 0)[				#   IF S1(1) HAS A BREAK CHAR-
      S3(1)=EOS				#   MAKE S3 A NULL STRING-
      RETURN (0)			#   AND RETURN 0.
    ENDIF
 
    ELSE[
      K=I+1
      CALL SCOPY(S1,1,S3,1,K)		# SAVE SKIP INTO S3
      CALL SCOPY(S1,K,S1,1,ARB)		# AND SKIP TO BREAK CHAR,
      K=LENGTH(S1)			# FIND NEW LENGTH-
      RETURN (K)			# AND RETURN IT.
    ENDELSE
 
ENDFOR					# GET HERE IF NO BREAK CHARS.
 
S3(1)=EOS
RETURN (-1)				# RETURN FAILURE CODE.
END
# * - ANY - RETURN FIRST POSITION IN S1 MATCHED BY ANY CHAR IN S2
#
# ON SUCCESS, FUNCTION RETURNS FIRST MATCH POSITION
# ON FAILURE RETURN EOS.
#
# ANY MUST BE DECLARED INTEGER, S1 AND S2 DECLARED CHAR.  S1 AND S2
# MAY BE LITERAL.
 
INTEGER FUNCTION ANY(S1,S2)
 
CHAR S1(ARB), S2(ARB)
INTEGER INDEX,I
 
FOR (I=1; S1(I) <> EOS; I=I+1)
  IF(INDEX(S2,S1(I)) <> EOS)		# IF HAVE A MATCH-
    RETURN (I)				# RETURN POS OF MATCH
RETURN (EOS)				# RETURN EOS IF NO MATCH
END
# * - NOTANY - RETURN FIRST POSITION IN S1 NOT MATCHED BY ANY CHAR IN S2.
# FUNCTION RETURNS EOS IF ALL CHARS IN S1 MATCH WITH ANY CHAR IN S2.
# NOTANY MUST BE DECLARED INTEGER.
# S1 AND S2 MUST BE STRING OF CHAR, AND MAY BE LITERAL.
 
INTEGER FUNCTION NOTANY(S1,S2)
 
CHAR S1(ARB),S2(ARB)
INTEGER INDEX,I
 
FOR (I=1; S1(I) <> EOS; I=I+1)
  IF(INDEX(S2,S1(I)) == EOS)
    RETURN (I)
 
RETURN(EOS)			# HERE IF ALL MATCH
END
# * - SHIFT - SHIFT FIRST N CHARACTERS FROM STRING S1
#
# FUNCTION RETURNS NUMBER OF CHARACTERS IN S1 AFTER SHIFT.
#
# SHIFT		 MUST BE DECLARED INTEGER.
# N 		MUST BE INTEGER OR INTEGER VARIABLE
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED.
 
INTEGER FUNCTION SHIFT(S1,N)
 
#	CORRECTED 9/10/79 SML

INTEGER LENGTH,I,J,N
CHAR S1(ARB)
 
I=LENGTH(S1)			# GET SIZE
J=N+1				# START POS OF COPY
I=(I-N)+1			# NUMBER OF CHARS TO COPY (INCLUDES EOS)
CALL SCOPY(S1,J,S1,1,I)		# REMOVE SHIFTED CHARS VIA OVERLAY.
RETURN(I-1)			# NEW LENGTH IS I - 1
END
# * - RPLACE - REPLACE ALL OCCURRENCES OF CHARACTER <A> BY CHARACTER <B>
#	FUNCTION WILL REPLACE ALL <A> WITH <B> IN S1 AND RETURN NUMBER
#	OF REPLACEMENTS.
#
#	FUNCTION WILL FAIL IF S1 DOES NOT COINTAIN <A> OR IF <A>=<B>  - 
#	RETURN 0.
#
# RPLACE	MUST BE DECLARED INTEGER
# A AND B	MUST BE SINGLE CHARACTER STRING OF CHAR OR LITERAL
 
INTEGER FUNCTION RPLACE(S1,A,B)
 
CHAR S1(ARB),A,B
INTEGER INDEX,I
 
IF(A==B)			# QUIT IF A=B
  RETURN(0)
 
I=0
REPEAT[
  I=INDEX(S1,A)			# FIND A
  IF(I==EOS)			# IF NO A
    BREAK			# DONE OR NONE
  S1(I)=B			# REPLACE ONE
  I=I+1
ENDREPEAT
 
RETURN(I)			# RETURN NUMBER OF REPLACEMENTS
END
# * - TRIM - REMOVE TRAILING BLANKS OR TABS
# FUNCTION REMOVES TRAILING BLANKS OR TABS AND RETURNS NEW LENGTH OF S1.
#
# TRIM		MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR, NO LITERAL ALLOWED.
 
INTEGER FUNCTION TRIM(S1)
 
CHAR S1(ARB)
INTEGER LENGTH,I
 
FOR (I=LENGTH(S1); I > 0; I=I-1)[
  IF(S1(I) == BLANK \ S1(I) == TAB)	# IF BLANK OR TAB, TRIM IT.
    S1(I) = EOS
  ELSE
    BREAK				# DONE IF NONE
ENDFOR
 
I=LENGTH(S1)
RETURN (I)
END
# * - ITOC - CONVERT INTEGER TO CHAR STRING OF RADIX <BASE>.
#
# FUNCTION TO CONVERT INTEGER <NUMBR> TO STRING <S1> OF RADIX <BASE>
# ON SUCCESS, FUNCTION RETURNS SIZE OF CONVERTED STRING <S1>.
# FUNCTION WILL FAIL IF BASE IS LT 2. OR GT 16. AND WILL MAKE
# S1 A NULL STRING AND RETURN 0.
#
# ITOC		MUST BE DECLARED INTEGER 
# NUMBR		MUST BE INTEGER OR INTEGER VARIABLE
# S1		MUST BE STRING OF CHAR.
# BASE		MUST BE INTEGER OR INTEGER VARIABLE GE 2 AND LE 16.
#
# EXAMPLE:
#
# ITOC(10,S1,16)	WILL PRODUCE "A" IN S1 WITH EOS IN S1(2) AND
#			RETURN 1
 
INTEGER FUNCTION ITOC(NUMBR,S1,BASE)
 
INTEGER BASE,NUMBR,I,J,K,WRKNUM
CHAR S1(ARB),JUNK(MAXDIGITS),TABLE(16)
DATA TABLE /"0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"/
 
IF (BASE .LT. 2 .OR. BASE .GT. 16)[
  S1(1)=EOS				# BAD BASE IF HERE
  RETURN (0)				# SO SET FAILURE AND RETURN
ENDIF
 
WRKNUM=NUMBR		# SET WORK NUMBER SO INPUT NOT DESTROYED
I=1
REPEAT[
J=MOD(WRKNUM,BASE)+1			# GET REMAINDER AND MAKE POINTER
JUNK(I)=TABLE(J)			# FIND THE CHAR
I=I+1					# INC INDEX
WRKNUM=WRKNUM/BASE			# QUOTIENT BECOMES DIVISOR
ENDREPEAT UNTIL (WRKNUM <=0 )		# DONE WHEN WRKNUM =0.
 
I=I-1					# BACK UP JUMP INDEX
K=1					# RESULT INDEX
 
FOR (J=I; J > 0; J=J-1)[		# REVERSE ORDER ( CORRECECT 9/20 SML)
  S1(K)=JUNK(J)
  K=K+1
ENDFOR
 
S1(K)=EOS				# MARK END OF STRING
RETURN (I)				# RETURN SIZE OF S1
END
# * - CHEXTI - CONVERT ASCII NUMERIC SUBSTRING TO INTEGER OF RADIX <BASE>.
#
# NOTE: CHEXTI IS A SUPERSET OF CTOI THAT INCLUDES HEXADECIMAL AS A LEGAL
#	BASE.  THEREFORE A-F ARE LEGAL NUMERIC CHARACTERS IF <BASE> IS GT 10.
#
# CHEXTI WILL CONVERT NUMERIC CHARACTERS IN S1 STARTING AT POSITION I UNTIL
# FIRST NON-NUMERIC CHARACTER OF RADIX <BASE> TO INTEGER.
#
# CHEXTI		MUST BE DECLARED INTEGER
# S1			STRING OF CHAR OR LITERAL STRING
# I			INTEGER VARIABLE. MUST NOT BE A CONSTANT (SEE CTOI).
# BASE			INTEGER CONSTANT OR INTEGER VARIABLE.
#
# EXAMPLE:
#
# I=1
# CHEXTI("A",I,16)		WILL RETURN THE INTEGER 10.
 
INTEGER FUNCTION CHEXTI(S1,I,BASE)
 
CHAR S1(ARB),DIGITS(17)
INTEGER BASE,I,J,INDEX
 
DATA DIGITS /"0","1","2","3","4","5","6","7","8","9","A","B",
 "C","D","E","F",EOS/
 
WHILE (S1(I) == BLANK \ S1(I) == TAB)	# SKIP LEADING BLANKS AND TABS
  I=I+1
 
FOR (CHEXTI=0; S1(I) <> EOS; I=I+1)[
  J = INDEX(DIGITS,S1(I))		# INDEX INTO <DIGIT> FOR DIGIT AT S1(I)
  IF(J == 0)				# IF CAN"T FIND ONE-
    BREAK				# DONE OR NONE.
  CHEXTI = BASE*CHEXTI + J - 1		# CONVERT TO INTEGER OF RADIX <BASE>
ENDFOR
 
RETURN
END
# * - MATCH - FIND MATCH ANYWHERE ON LINE
#
# FUNCTION WILL RETURN POSITION IN <LIN> OF THE FIRST IDENTICAL OCCURRENCE
# OF THE STRING IN <PAT> WITHIN <LIN>. IF MATCH FAILS, FUNCTION WILL
# RETURN <NO>.
#
#	FROM KERNIGHAN AND PLAUGER "SOFTWARE TOOLS" PAGE 140.
#
# MATCH		MUST BE DECLARED INTEGER BY CALLING PROGRAM
# LIN		MUST BE STRING OF CHAR OR LITERAL
# PAT		MUST BE STRING OF CHAR OR LITERAL
 
INTEGER FUNCTION MATCH(LIN,PAT)
 
CHAR LIN(ARB),PAT(ARB)
INTEGER AMATCH,I
 
FOR (I=1; LIN(I) <> EOS; I=I+1)
  IF(AMATCH(LIN,I,PAT) > 0)
    RETURN (I)			# RETURN POSITION IN LIN OF MATCH
  
RETURN (NO)			# IF FALL THRU FORLOOP, NO MATCH.
END
# * - AMATCH - WORK ROUTINE FOR MATCH WITH NO METACHARACTERS
#
# FROM KERNIGHAN AND PLAUGER "SOFTWARE TOOLS" PAGE 140.
 
INTEGER FUNCTION AMATCH(LIN,FROM,PAT)
 
CHAR LIN(ARB),PAT(ARB)
INTEGER FROM,I,J
 
I=FROM
FOR (J =1; PAT(J) <> EOS; J=J+1)[
  IF(LIN(I) <> PAT(J))
    RETURN (0)				# WITH NO MATCH
  I=I+1
ENDFOR
 
RETURN (I)				# WITH MATCH
END
# * - APPEND - APPEND S2 ONTO END OF S1
#
# FUNCTION WILL CONCATENATE S2 ON THE END OF S1 <COUNT> TIMES AND
# RETURN THE NEW LENGTH OF S1.
#
# APPEND	MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR.  LITERAL NOT ALLOWED
#		NOTE THAT S1 MUST BE LARGE ENOUGH TO CONTAIN THE RESULT.
# S2		MUST BE STRING OF CHAR OR LITERAL.
# COUNT		MUST BE INTEGER OR INTEGER VARIABLE.
 
INTEGER FUNCTION APPEND(S1,S2,COUNT)
 
CHAR S1(ARB),S2(ARB)
INTEGER LENGTH,I,J,K,COUNT	# ( CORRECTED SML 9/4/79)

J=LENGTH(S2) +1			# FIND END OF S2
IF (COUNT <= 0)			# IF BAD COUNT PARAM
  RETURN (0)			# RETURN FAILURE
 
FOR (K=1; K <= COUNT; K=K+1)[	# DO COUNT TIMES
  I=LENGTH(S1) +1		# GET LENGTH OF S1
  CALL SCOPY(S2,1,S1,I,J)	# DO AN APPEND
ENDFOR
RETURN ( LENGTH(S1) )		# RETURN THE LENGTH   ( CORRECTED SML 8/31/79)
END
# * - REMOVE - REMOVE SUBSTRING FROM STRING <S1>
#
# FUNCTION WILL REMOVE A SUBSTRING FROM <S1> BEGINNING AT POSITION <FROM>
# THROUGH POSITION <TO>, AND RETURN THE NEW SIZE OF <S1>
#
# FUNCTION WILL FAIL IF <TO> IS LE <FROM> AND RETURN <EOS>
# FUNCTION WILL FAIL IF <FROM> IS GE LENGTH(S1) AND RETURN <EOS>
# IF <FROM> IS LE 1, <TO> CHARS WILL BE REMOVED FROM <S1> STARTING
# AT S1(1).
# IF <TO> GE LENGTH(S1), <S1> WILL BE TRUNCATED AT <FROM>
#
# REMOVE	MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED.
# FROM		MUST BE INTEGER OR INTEGER VARIABLE
# TO		MUST BE INTEGER OR INTEGER VARIABLE
 
INTEGER FUNCTION REMOVE(S1,FROM,TO)
 
CHAR S1(ARB)
INTEGER LENGTH,I,FROM,TO,SHIFT
 
I=LENGTH(S1)			# GET LENGTH
IF(TO <= FROM)			# IF TO TOO LOW
  RETURN (EOS)
ELSE IF (FROM >= I)		# IF FROM TOO BIG
  RETURN (EOS)
 
IF(TO >= I)			# IF REALLY WANT TO TRUNCATE
  S1(FROM)=EOS
ELSE IF (FROM <= 1)		# IF REALLY WANT TO SHIFT
  I=SHIFT(S1,TO)
ELSE[
  I=TO+1
  CALL SCOPY(S1,I,S1,FROM,ARB)
ENDELSE
I=LENGTH(S1)			# GET NEW LENGTH
RETURN (I)
END
# * - INSERT - INSERT <S2> INTO <S1> AFTER <FROM>.
#
# FUNCTION WILL INSERT STRING <S2> INTO <S1> AFTER S1(FROM) AND RETURN
# NEW LENGTH OF <S1>.
#
# IF <FROM> GE LENGTH(S1), <S2> WILL BE APPENDED TO <S1>
# IF <FROM> LT 1, <S2> WILL BE PREPENDED TO <S1>
#
# INSERT	MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED.
# S2		MUST BE STRING OF CHAR OR LITERAL.
# FROM		MUST BE INTEGER OR INTEGER VARIABLE.
 
INTEGER FUNCTION INSERT(S1,FROM,S2)
 
CHAR S1(ARB),S2(ARB),JUNK(MAXLINE)
INTEGER FROM,I,APPEND,LENGTH
 
IF(FROM >= LENGTH(S1))[		# IF WANT TO APPEND
  I=APPEND(S1,S2,1)	# LET APPEND DO IT
  RETURN (I)
ENDIF
 
IF(FROM < 1)	# IF WANT TO PREPEND
  I=1
ELSE
  I=FROM+1
CALL SCOPY(S1,I,JUNK,1,ARB)	# COPY 2ND PART OF S1
CALL SCOPY(S2,1,S1,I,ARB)	# STICK IN S2
I=APPEND(S1,JUNK,1)		# AND REPLACE 2ND PART OF S1
RETURN (I)
END
# * - LPAD - LEFT PAD <N> BLANKS IN STRING <S1>
#
# FUNCTION INSERTS <N> BLANKS AT THE BEGINNING OF <S1> (PREPENDS),
# AND RETURNS NEW LENGTH OF <S1>.  IF <N> LT 1, NO BLANKS ARE
# PREPENDED AND LENGTH(S1) IS UNCHANGED.
#
# LPAD		MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED.
# N		MUST BE INTEGER OR INTEGER VARIABLE.
 
INTEGER FUNCTION LPAD(S1,N)
 
CHAR S1(ARB),JUNK(DUMMYSIZE)
INTEGER N,APPEND,LENGTH
IF (N < 1)			# IF N IS 0 OR LESS
  LPAD=LENGTH(S1)		# JUST RETURN SIZE OF S1
ELSE[
  CALL SCOPY(S1,1,JUNK,1,ARB)		# SAVE S1
  S1(1) = EOS				# NULL OUT S1
  LPAD=APPEND(S1,BLANK,N)			# MAKE N BLANKS
  LPAD=APPEND(S1,JUNK,1)			# AND ADD ORIGINAL S1
ENDELSE
 
RETURN
END
# * - RPAD - PAD END OF <S1> WITH BLANKS
#
# FUNCTION APPENDS <S1> WITH <N> SPACES AND RETURNS NEW SIZE OF S1.
# IF <N> LT 1, FUNCTION RETURNS ORIGINAL SIZE OF <S1> WITH NO PADDING DONE.
#
# RPAD		MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED
# N		MUST BE INTEGER OR INTEGER VARIABLE.
 
INTEGER FUNCTION RPAD(S1,N)
 
CHAR S1(ARB)
INTEGER APPEND,LENGTH
 
IF (N < 1)
  RPAD=LENGTH(S1)
ELSE
  RPAD=APPEND(S1,BLANK,N)		# PAD N TIMES
 
RETURN
END
# * - ALIGN - ALIGN <S1> TO RIGHT, LEFT, OR CENTER OF <FIELD>
#
# FUNCTION LEFT JUSTIFIES, RIGHT JUSTIFIES OR CENTERS <S1> IN A FIELD
# OF LENGTH <FIELD> DEPENDING ON VALUE OF <POS> AND RETURNS NEW LENGTH
# OF <S1>.  THIS IS ACCOMPLISHED BY PREPENDING THE CORRECT NUMBER OF
# SPACES ONTO <S1>.
#
# IF <FIELD> IS LE LENGTH(S1) FUNCTION WILL FAIL AND RETURN EOS
# IF <POS> IS LT 0 <S1> WILL BE LEFT JUSTIFIED (ANY LEADING BLANKS OR TABS
# WILL BE REMOVED.
# IF <POS> IS EQ 0 <S1> WILL BE CENTERED ON <FIELD>.
# IF <POS> IS GT 0 <S1> WILL BE RIGHT JUSTIFIED.
#
# ALIGN		MUST BE DECLARED INTEGER
# S1		MUST BE STRING OF CHAR - LITERAL NOT ALLOWED
# FIELD		MUST BE INTEGER OR INTEGER VARIABLE
# POS		MUST BE INTEGER OR INTEGER VARIABLE
 
INTEGER FUNCTION ALIGN(S1,POS,FIELD)
 
CHAR S1(ARB)
INTEGER LPAD,I,J,POS,FIELD,LENGTH,SHIFT
 
IF(FIELD <= LENGTH(S1))			# IF FIELD IS TOO SHORT
  RETURN (EOS)

 
IF (POS < 0)[			# IF WANT LEFT JUSTIFICATION
  REPEAT[				# GET RID OF LEADING BLANKS AND TABS
    IF(S1(1) <>BLANK .AND . S1(1) <> TAB)
      BREAK				# DONE IF NOT BLANK OR TAB
    
    ELSE 
      I=SHIFT(S1,1) 			# GET RID OF BLANK OR TAB
    
  ENDREPEAT UNTIL(S1(1) == EOS)		# IF FALL THRU - ENTIRE STRING WAS BLANK
ENDIF

IF (POS == 0)[			# IF WANT CENTER
  I=LENGTH(S1)/2			# FIND MIDPOINT OF S1
  I=(FIELD/2) - I			# FIND OUT HOW MANY LPADS
  J=LPAD(S1,I)				# CENTER S1
ENDIF
 
IF ( POS > 0) [			# HERE IF WANT RIGHT JUSTIFICATION
  I=FIELD - LENGTH(S1)			# FIND OUT HOW MANY LPADS.
  J=LPAD(S1,I)
ENDIF

ALIGN=LENGTH(S1)			# RETURN NEW LENGTH OF S1
RETURN
END