FTN4 
C 
C 
C           NAME:   EDTU2 
C           SOURCE: 92074-18008 
C           RELOC:  PART OF 92074-12002 
C           PGMR:   J.D.J.
C 
C                                               <800822.0800> 
C include ratdef
C the define are merged in here - normally they're in file ratdef 
C 
C ampersand 
CAPOSTROPHE 
C exclamation mark
C pushback buffer for ngetch and putbak 
C used for debug - change to (DB,) or (DB,#)
C END OF QUOTE STRING 
C temporarily same as standard output 
C must be one more than HASHSZ
C "`" 
C card size 
C characters for outnum 
C max chars in a defn 
C max space for for reinit clauses
C must be 1 more than MAXCARD 
C file name size in gettok
C number of defines in lookup 
C max stack depth for parser
C max chars in all definitions
C MAXTBUF = MAXTOK/2 + 1
C max chars in a token
C number of special characters
C max depth of file inclusion 
C "?" 
C TILDE for now; change for ebcdic
C PPAT ZERO LENGTH LINE MATCH CHAR. 
CDEFINE(BOLCHAR,201B) # PPAT BEGINNIG OF LINE CHAR. 
C AMATCH  (NON-RECURSIVE) - LOOK FOR MATCH STARTING AT LIN(FROM)
      INTEGER FUNCTION AMATCH(LIN ,FROM ,PAT) 
     C,92074-1X008 REV.2034 800818
      INTEGERLIN(82) ,PAT(100)
      INTEGER OMATCH ,PATSIZ
      INTEGER FROM ,I ,J ,OFFSET ,STACK ,TAGED ,TAGLVL ,RCNT ,PATJ
C COMMON BLOCK FOR TAG POINTER IN MATCH PROGRAM 
      COMMON /TAG/ TAGSRT(10),TAGSTP(10),TAGCNT 
      INTEGER TAGSRT,TAGSTP,TAGCNT
      INTEGER BUFF(3) 
      TAGED = 0 
      STACK = 0 
C NEXT UNEXAMINED INPUT CHARACTER 
      OFFSET = FROM       
      CONTINUE
      J = 1 
23000 IF(.NOT.(PAT(J) .NE. -2))GOTO 23002 
      PATJ = PAT(J) 
      IF(.NOT. (PATJ .EQ. 42))GOTO 23003
C A CLOSURE ENTRY 
      STACK = J 
C STEP OVER CLOSURE 
      J = J + 4 
      CONTINUE
      I = OFFSET
23005 IF(.NOT.(LIN(I) .NE. -2))GOTO 23007 
C MATCH AS MANY AS
      IF(.NOT. (OMATCH(LIN, I, PAT, J) .EQ. 0))GOTO 23008 
C POSSIBLE
      GOTO 23007
23008 CONTINUE
23006 GOTO 23005
23007 CONTINUE
      PAT(STACK+1) = I - OFFSET 
      PAT(STACK+3) = OFFSET 
C CHARACTER THAT MADE US FAIL 
      OFFSET = I      
      GOTO 23004
23003 CONTINUE
      IF(.NOT. (PATJ .EQ. 123.OR. PATJ .EQ. 125))GOTO 23010 
C  TAG FIELD
C SAVE POSITION IN PATTERN
      PAT(J+1) = OFFSET           
      TAGED = 1 
CCALL EXEC(2,1,'/AMATCH: FOUND TAG _',-QLENGTH) 
CCALL EXEC(2,1,PATJ,1)
CCALL EXEC(2,1,'/AMATCH: OFFSET=_',-QLENGTH)
CCALL CNUMD(OFFSET,BUFF)
CCALL EXEC(2,1,BUFF,3)
      GOTO 23011
23010 CONTINUE
      IF(.NOT. (OMATCH(LIN, OFFSET, PAT, J) .EQ. 0))GOTO 23012
C NON-CLOSURE 
      CONTINUE
23014 IF(.NOT.(STACK .GT. 0))GOTO 23016 
      IF(.NOT. (PAT(STACK+1) .GT. 0))GOTO 23017 
      GOTO 23016
23017 CONTINUE
23015 STACK=PAT(STACK+2)
      GOTO 23014
23016 CONTINUE
      IF(.NOT. (STACK .LE. 0))GOTO 23019
C STACK IS EMPTY
C RETURN FAILURE
      AMATCH = 0      
      RETURN
23019 CONTINUE
      PAT(STACK+1) = PAT(STACK+1) - 1 
      J = STACK + 4 
      OFFSET = PAT(STACK+3) + PAT(STACK+1)
C ELSE OMATCH SUCCEEDED 
23012 CONTINUE
23011 CONTINUE
23004 CONTINUE
23001 J=J+PATSIZ(PAT,J) 
      GOTO 23000
23002 CONTINUE
      AMATCH = OFFSET 
CCALL EXEC(2,1,'/AMATCH: MATCH =_',-QLENGTH)
CCALL EXEC(2,1,LIN(FROM), (AMATCH-FROM))
      IF(.NOT.( TAGED .EQ. 1))GOTO 23021
C THEN THERE WERE TAGS IN THE PATTERN 
CCALL EXEC(2,1,'/AMATCH: TAGED = YES',-QLENGTH) 
      TAGCNT = 0
      RCNT   = 0
      TAGLVL = 0
      CONTINUE
      J=1 
23023 IF(.NOT.(PAT(J) .NE. -2))GOTO 23025 
C RESCAN
      IF(.NOT.( PAT(J) .EQ. 123))GOTO 23026 
      TAGCNT = TAGCNT + 1 
C PULL START POS. OUT OF PATTERN
      TAGSRT(TAGCNT) = PAT(J+1) 
      TAGLVL = TAGLVL + 1 
CCALL EXEC(2,1,'/AMATCH: TAGLVL=_',-QLENGTH)
CCALL CNUMD(TAGLVL,BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: TAGCNT=_',-QLENGTH)
CCALL CNUMD(TAGCNT,BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: PAT(J+1)=_',-QLENGTH)
CCALL CNUMD(PAT(J+1),BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: J=_',-QLENGTH) 
CCALL CNUMD(J,BUFF) 
CCALL EXEC(2,1,BUFF,3)
      GOTO 23027
23026 CONTINUE
      IF(.NOT.( PAT(J) .EQ. 125))GOTO 23028 
C PULL STOP POS. OUT OF PATTERN 
      TAGSTP(RCNT+TAGLVL) = PAT(J+1)  
      TAGLVL = TAGLVL - 1 
      IF(.NOT.( TAGLVL .EQ. 0 ))GOTO 23030
      RCNT = RCNT + 1 
CCALL EXEC(2,1,'/AMATCH: TAGLVL=_',-QLENGTH)
CCALL CNUMD(TAGLVL,BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: RCNT=_',-QLENGTH)
CCALL CNUMD(RCNT,BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: PAT(J+1)=_',-QLENGTH)
CCALL CNUMD(PAT(J+1),BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: J=_',-QLENGTH) 
CCALL CNUMD(J,BUFF) 
CCALL EXEC(2,1,BUFF,3)
23030 CONTINUE
C ELSE SKIP PATTERN 
23028 CONTINUE
23027 CONTINUE
CCALL EXEC(2,1,'/AMATCH: TAGSRT AND TAGSTP ARRAYS',-QLENGTH)
CFOR(KK=1;KK<TAGCNT;KK=KK+1)[ 
CCALL EXEC(2,1,'/AMATCH: TAGSRT=_',-QLENGTH)
CCALL CNUMD(TAGSRT(KK),BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/AMATCH: TAGSTP=_',-QLENGTH)
CCALL CNUMD(TAGSTP(KK),BUFF)
CCALL EXEC(2,1,BUFF,3)
C}
23024 J=J+PATSIZ(PAT,J) 
      GOTO 23023
23025 CONTINUE
23021 CONTINUE
C SUCCESS 
      RETURN      
      END 
C GETCCL - EXPAND CHAR CLASS AT ARG(I) INTO PAT(J)
      INTEGER FUNCTION GETCCL(ARG ,I ,PAT ,J,MAXPAT)
     C,92074-1X008 REV.2034 800818
      INTEGERARG(40) ,PAT(MAXPAT) 
      INTEGER ADDSET
      INTEGER I ,J ,JSTART ,JUNK
C SKIP OVER 
      I = I + 1       
      IF(.NOT. (ARG(I) .EQ. 94))GOTO 23032
      JUNK = ADDSET(110 ,PAT ,J ,MAXPAT)
      I = I + 1 
      GOTO 23033
23032 CONTINUE
      JUNK = ADDSET(91 ,PAT ,J ,MAXPAT) 
23033 CONTINUE
      JSTART = J
C LEAVE ROOM FOR COUNT
      JUNK = ADDSET(0 ,PAT ,J ,MAXPAT)      
      CALL FILSET(93 ,ARG ,I ,PAT ,J ,MAXPAT) 
C ADD COUNT 
      JUNK = ADDSET(J - JSTART - 1 ,PAT  ,JSTART ,MAXPAT) 
      IF(.NOT. (ARG(I) .EQ. 93))GOTO 23034
      GETCCL = -7 
      GOTO 23035
23034 CONTINUE
      GETCCL = -1 
23035 CONTINUE
      RETURN
      END 
C GETPAT - CONVERT ARGUMENT INTO PATTERN
      INTEGER FUNCTION GETPAT(ARG ,PAT ,PPAT ,MAXPAT) 
     C,92074-1X008 REV.2034 800818
      INTEGER ARG(40) ,PAT(MAXPAT) ,PPAT(MAXPAT)
      INTEGER MAXPAT
      INTEGER MAKPAT
      GETPAT = MAKPAT(ARG ,1 ,-2 ,PAT ,PPAT ,MAXPAT)
      RETURN
      END 
C LOCATE - LOOK FOR C IN CHAR CLASS AT PAT(OFFSET)
      INTEGER FUNCTION LOCATE(C ,PAT ,OFFSET) 
     C,92074-1X008 REV.2034 800818
      INTEGERC ,PAT(100)
      INTEGER I ,OFFSET 
      INTEGER PATI
C SIZE OF CLASS IS AT PAT(OFFSET), CHARACTERS FOLLOW
CCALL EXEC(2,1,'/LOCATE: c=_',-QLENGTH) 
CCALL EXEC(2,1,C,1) 
CCALL EXEC(2,1,'/LOCATE: CLASS=_',-QLENGTH) 
CCALL EXEC(2,1,PAT(OFFSET+1),PAT(OFFSET)) 
      CONTINUE
      I = OFFSET + PAT(OFFSET)
23036 IF(.NOT.(I .GT. OFFSET))GOTO 23038
      PATI = PAT(I) 
C 
C  NEW CODE FOR DASH AS A SUB-PATTERN 
C 
      IF(.NOT.( PATI .EQ. -1))GOTO 23039
      I = I-2 
      IF(.NOT.( C.GE.PAT(I) .AND. C.LE.PAT(I+1) ))GOTO 23041
      LOCATE = 1
CCALL EXEC(2,1,'/LOCATE: RETURN YES FROM DASH PATTERN',-QLENGTH)
      RETURN
23041 CONTINUE
      GOTO 23040
23039 CONTINUE
      IF(.NOT. (C .EQ. PATI))GOTO 23043 
      LOCATE = 1
CCALL EXEC(2,1,'/LOCATE: RETURN YES',-QLENGTH)
      RETURN
23043 CONTINUE
23040 CONTINUE
C CLOSE FOR LOOP
23037 I=I-1 
      GOTO 23036
23038 CONTINUE
      LOCATE = 0
CCALL EXEC(2,1,'/LOCATE: RETURN NO',-QLENGTH) 
      RETURN
      END 
C SUFIX - TEST IF IT IS OK TO HAVE SUFIX ON THIS PATTERN
      INTEGER FUNCTION SUFIX(PAT) 
     C,92074-1X008 REV.2034 800818
      INTEGER PAT 
      IF(.NOT. (PAT.EQ.94.OR. PAT.EQ.36.OR. PAT.EQ.42.OR. PAT.EQ.123.OR.
     * PAT.EQ.125))GOTO 23045 
      SUFIX = 0 
      GOTO 23046
23045 CONTINUE
      SUFIX = 1 
23046 CONTINUE
      RETURN
      END 
C COPY - COPY N CHARACTERS, INCERMENT J 
      SUBROUTINE COPY (N ,FROM ,I ,TO ,J ,MAXTO)
     C,92074-1X008 REV.2034 800818
      INTEGER N ,FROM(100) ,I ,TO(MAXTO) ,J ,MAXTO ,II ,JJ ,K 
      II = I
      CONTINUE
      K=1 
23047 IF(.NOT.(K.LE.N ))GOTO 23049
      IF(.NOT.( J .GT. MAXTO ))GOTO 23050 
      RETURN
23050 CONTINUE
      TO(J) = FROM(II)
      J = J + 1 
      II = II + 1 
23048 K=K+1 
      GOTO 23047
23049 CONTINUE
      RETURN
      END 
C MAKPAT - MAKE PATTERN FROM ARG(FROM), TERMINATE AT DELIM
C        - BUILD POSSIBLE MATCH INTO PPAT 
      INTEGER FUNCTION MAKPAT(ARG ,FROM ,DELIM ,PAT ,PPAT ,MAXPAT)
     C,92074-1X008 REV.2034 800818
      INTEGERESC
      INTEGERARG(40) ,DELIM ,PAT(MAXPAT),PPAT(MAXPAT) 
      INTEGER ADDSET ,GETCCL ,STCLOS ,PATSIZ ,SUFIX ,CTOI 
      INTEGER FROM ,I ,J ,JUNK ,LASTCL ,LASTJ ,LJ ,LP ,TAGPTR 
      INTEGER ARGI,PATN 
C PPAT ESCAPE CHAR
      COMMON /ESCCH/ ESCCH  
      INTEGER ESCCH 
C PPAT ANCHOR CHAR
      COMMON /ANCCH/ ANCCH  
      INTEGER ANCCH 
C PPAT INDEFINATE MATCH CHAR
      COMMON /INDEF/ INDEF  
      INTEGER INDEF 
CCALL EXEC(2,1,'/MAKPAT: ARG=_',-QLENGTH) 
CCALL EXEC(2,1,ARG,LENGTH(ARG)) 
C PAT INDEX 
      J = 1       
      LASTJ = 1 
      LASTCL = 0
      TAGPTR = 0
      CONTINUE
      I = FROM
23052 IF(.NOT.(ARG(I) .NE. DELIM .AND. ARG(I) .NE. -2))GOTO 23054 
      LJ = J
      ARGI = ARG(I) 
      IF(.NOT. (ARGI .EQ. 46))GOTO 23055
      JUNK = ADDSET(46 ,PAT ,J ,MAXPAT) 
      GOTO 23056
23055 CONTINUE
      IF(.NOT. (ARGI .EQ. ANCCH .AND. I .EQ. FROM))GOTO 23057 
      JUNK = ADDSET(94 ,PAT ,J ,MAXPAT) 
      GOTO 23058
23057 CONTINUE
      IF(.NOT. (ARGI .EQ. 36.AND. ARG(I + 1) .EQ. DELIM))GOTO 23059 
      JUNK = ADDSET(36 ,PAT ,J ,MAXPAT) 
      GOTO 23060
23059 CONTINUE
      IF(.NOT.(ARGI .EQ. 58))GOTO 23061 
      JUNK = ADDSET(58 ,PAT ,J ,MAXPAT) 
      GOTO 23062
23061 CONTINUE
      IF(.NOT. (ARGI .EQ. 91))GOTO 23063
      IF(.NOT. (GETCCL(ARG, I, PAT, J, MAXPAT) .EQ. -1))GOTO 23065
      GOTO 23054
23065 CONTINUE
      GOTO 23064
23063 CONTINUE
      IF(.NOT. (ARGI.EQ.123.AND. ARG(I+1) .NE. DELIM))GOTO 23067
      TAGPTR = TAGPTR + 1 
      IF(.NOT.(TAGPTR .GT. 10))GOTO 23069 
      GOTO 23054
23069 CONTINUE
      JUNK = ADDSET(123 ,PAT ,J ,MAXPAT)
C ROOM FOR POINTER
      JUNK = ADDSET(0 ,PAT ,J ,MAXPAT)  
      GOTO 23068
23067 CONTINUE
      IF(.NOT.(ARGI .EQ. 125.AND. I .GT. FROM))GOTO 23071 
      TAGPTR = TAGPTR - 1 
      IF(.NOT.( TAGPTR .LT. 0 ))GOTO 23073
      GOTO 23054
23073 CONTINUE
      JUNK = ADDSET(125 ,PAT ,J ,MAXPAT)
C ROOM FOR POINTER
      JUNK = ADDSET(0 ,PAT ,J ,MAXPAT)    
      GOTO 23072
23071 CONTINUE
      IF(.NOT. ( ARGI .EQ. INDEF     ))GOTO 23075 
C ALLOW '@' TO BE '.*'
      JUNK = ADDSET(46 ,PAT ,J ,MAXPAT) 
      LASTJ = LJ
      LJ = LASTJ
      LASTCL = STCLOS(PAT ,J ,LASTJ ,LASTCL ,MAXPAT)
      GOTO 23076
23075 CONTINUE
      IF(.NOT. (ARGI .EQ. 60))GOTO 23077
      IF(.NOT. (SUFIX(PAT(LASTJ)) .EQ. 0))GOTO 23079
      GOTO 23054
23079 CONTINUE
      L = I+1 
      K = CTOI (ARG ,L) 
      IF(.NOT.( ARG(L) .NE. 62))GOTO 23081
      JUNK = ADDSET( 97 ,PAT ,J ,MAXPAT)
      JUNK = ADDSET( ARGI ,PAT ,J ,MAXPAT)
      GOTO 23082
23081 CONTINUE
C DO REPEAT COUNT 
C SKIP OVER COUNT 
      I = L   
      CONTINUE
      II=1  
23083 IF(.NOT.(II.LE.K-1 ))GOTO 23085 
C GET SIZE
      L = J - LASTJ     
      JTEMP = LASTJ 
      LASTJ = J 
      CALL COPY(L ,PAT ,JTEMP ,PAT ,J ,MAXPAT)
      LJ = J
23084 II=II+1 
      GOTO 23083
23085 CONTINUE
23082 CONTINUE
      GOTO 23078
23077 CONTINUE
      IF(.NOT. ((ARGI.EQ.42.OR. ARGI .EQ. 43) .AND. I .GT. FROM))GOTO 23
     *086 
      IF(.NOT.( SUFIX(PAT(LASTJ)) .EQ. 0))GOTO 23088
C OK TO SUFIX LAST PATTERN ?
      GOTO 23054
23088 CONTINUE
      IF(.NOT. ( ARGI .EQ. 43))GOTO 23090 
C FOR TRANSTIVE CLOSURES
C COPY PREV PATTERN THEN DO CLOSURE 
      L = J - LASTJ           
      JTEMP = LASTJ 
      LASTJ = J 
      CALL COPY(L ,PAT ,JTEMP ,PAT ,J ,MAXPAT)
      LJ = J
23090 CONTINUE
      LJ = LASTJ
      LASTCL = STCLOS(PAT ,J ,LASTJ ,LASTCL ,MAXPAT)
      GOTO 23087
23086 CONTINUE
      JUNK = ADDSET(97 ,PAT ,J ,MAXPAT) 
      JUNK = ADDSET(ESC(ARG ,I) ,PAT ,J ,MAXPAT)
23087 CONTINUE
23078 CONTINUE
23076 CONTINUE
23072 CONTINUE
23068 CONTINUE
23064 CONTINUE
23062 CONTINUE
23060 CONTINUE
23058 CONTINUE
23056 CONTINUE
      LASTJ = LJ
23053 I=I+1 
      GOTO 23052
23054 CONTINUE
      IF(.NOT. (ARG(I) .NE. DELIM))GOTO 23092 
C TERMINATED EARLY
      MAKPAT = -1 
      GOTO 23093
23092 CONTINUE
      IF(.NOT. ( TAGPTR .NE. 0 ))GOTO 23094 
C UNBALANCED TAG FIELDS 
      MAKPAT = -1 
      GOTO 23095
23094 CONTINUE
      IF(.NOT. (ADDSET(-2, PAT, J, MAXPAT) .EQ. 0))GOTO 23096 
C NO ROOM 
      MAKPAT = -1 
      GOTO 23097
23096 CONTINUE
C PATERN OK 
CCALL EXEC(2,1,'/MAKPAT: PAT=_',-QLENGTH) 
CCALL EXEC(2,1,PAT,LENGTH(PAT)) 
      MAKPAT = I
C 
C     BUILD POSSIBLE MATCH PATTERN
C 
C      PPAT IS ALWAYS SMALLER THAN PAT SO WE DON'T NEED TO DO 
C      LIMIT CHECKS 
      J = 1 
      I = 1 
      LP  = -1
      IF(.NOT.( PAT(1) .EQ. 94))GOTO 23098
C SKIP BOL
      I = I + PATSIZ(PAT ,1)    
      IF(.NOT.( PAT(2) .EQ. 36))GOTO 23100
C LOOK FOR ZERO LENGTH LINE 
C SPECIAL TO MATCH ZERO LENGTH LINE 
      LP = 200B 
      GOTO 23101
23100 CONTINUE
C SET IN ANCHOR CHAR
      LP = ANCCH              
23101 CONTINUE
      PPAT(J) = LP
      J = 2 
      GOTO 23099
23098 CONTINUE
C PUT AN INDEF. CHAR AS START OF PATTERN
      LP = INDEF
      PPAT(J) = LP
      J = 2 
23099 CONTINUE
      CONTINUE
23102 IF(.NOT.(PAT(I) .NE. -2))GOTO 23104 
      PATN = PAT(I) 
      IF(.NOT.( PATN .EQ. 97))GOTO 23105
C SINGLE CHAR ? 
      LP = PAT(I+1) 
      IF(.NOT.( LP .EQ. ANCCH .OR. LP .EQ. INDEF .OR. LP .EQ. ESCCH ))GO
     *TO 23107
C TEST FOR SPECIALS 
C ESCAPE SPECIALS 
      PPAT(J) = ESCCH                                 
      J = J + 1 
23107 CONTINUE
      PPAT(J) = LP
      J = J+1 
      GOTO 23106
23105 CONTINUE
      IF(.NOT.( PATN .EQ. 123.OR. PATN .EQ. 125.OR.                  PAT
     *N .EQ. 36.OR. PATN .EQ. 58))GOTO 23109
C JUST SKIP THEM
      GOTO 23110
23109 CONTINUE
      IF(.NOT.(PATN .EQ. 46.OR. PATN .EQ. 91.OR. PATN .EQ. 110.OR.      
     *               PATN .EQ. 42))GOTO 23111 
      IF(.NOT.( LP .NE. INDEF ))GOTO 23113
C USE AN INDEFINATE CHARACTER MATCH 
      LP = INDEF            
      PPAT(J) = INDEF 
      J = J + 1 
23113 CONTINUE
      IF(.NOT.( PATN .EQ. 42))GOTO 23115
C CLOSURE TAKES TWO PATTERNS
      I = I + PATSIZ(PAT ,I)    
23115 CONTINUE
      GOTO 23112
23111 CONTINUE
CPPAT(J) = PATN 
CPPAT(J+1) = EOS
CCALL EXEC(2,1,'MAKPAT: PPAT=_',-QLENGTH) 
CCALL EXEC(2,1,PPAT,LENGTH(PPAT)) 
      CALL ERROR(22HBUG IN POSSIBLE MATCH.) 
23112 CONTINUE
23110 CONTINUE
23106 CONTINUE
C CLOSE FOR 
23103 I=I+PATSIZ(PAT,I) 
      GOTO 23102
23104 CONTINUE
      PPAT(J) = -2
CCALL EXEC(2,1,'MAKPAT: PPAT=_',-QLENGTH) 
CCALL EXEC(2,1,PPAT,LENGTH(PPAT)) 
C CLOSE ELSE PATTERN OK 
23097 CONTINUE
23095 CONTINUE
23093 CONTINUE
      RETURN
      END 
C MATCH - FIND MATCH ANYWHERE ON LINE 
      INTEGER FUNCTION MATCH(LIN ,PAT)
     C,92074-1X008 REV.2034 800818
      INTEGERLIN(82) ,PAT(100)
      INTEGER AMATCH
      INTEGER I ,PATSIZ ,OMATCH ,PATJ ,PRESN
CCALL EXEC(2,1,'/MATCH: LIN=_',-QLENGTH)
CCALL EXEC(2,1,LIN,LENGTH(LIN)) 
CCALL EXEC(2,1,'/MATCH: PAT=_',-QLENGTH)
CCALL EXEC(2,1,PAT,LENGTH(PAT)) 
      IF(.NOT.( PRESN(LIN, PAT) .EQ. 1))GOTO 23117
      CONTINUE
      I = 1 
23119 IF(.NOT.(LIN(I) .NE. -2))GOTO 23121 
      IF(.NOT. (AMATCH(LIN, I, PAT) .GT. 0))GOTO 23122
      MATCH = 1 
      RETURN
23122 CONTINUE
23120 I=I+1 
      GOTO 23119
23121 CONTINUE
23117 CONTINUE
      MATCH = 0 
      RETURN
      END 
C PRESC  - DO PRESCAN TO SEE IF PATTERN MAY MATCH 
      INTEGER FUNCTION PRESN(LIN,PAT) 
     C,92074-1X008 REV.2034 800818
C 
C 
C FIRST SCAN TO SEE IF ALL THE NON-CLOSURE PATTERNS CAN BE
C     MATCHED INORDER WHEN THEY ARE SEPERATED BY ANY NUMBER OF
C     CHARS. THIS PREVENT A HUGE AMOUNT OF BACKTRACKING FOR 
C     PATTERNS LIKE .*[^ ].*[AB][AB]
C 
      INTEGER LIN(100) ,PAT(100) ,PATJ ,PATSIZ ,OMATCH
      I = 1 
      J = 1 
      CONTINUE
23124 CONTINUE
C UNTIL PAT(J) == EOS  OR RETURN ON FAILURE 
      PATJ = PAT(J) 
      IF(.NOT.( PATJ .EQ. -2))GOTO 23127
      GOTO 23126
C END OF PATTERN FOUND SO GO TRY REAL MATCH 
23127 CONTINUE
      IF(.NOT.( PATJ .EQ. 42))GOTO 23129
C SKIP CLOSURE AND IT PATTERN 
      J = J + PATSIZ(PAT ,J)
      GOTO 23130
23129 CONTINUE
      IF(.NOT.( PATJ .EQ. 123.OR. PATJ .EQ. 125))GOTO 23131 
C JUST SKIP THEM
      GOTO 23132
23131 CONTINUE
C SEE IF PATTERN MATCH ANYWHERE ON LINE 
      CONTINUE
23133 CONTINUE
      IF(.NOT.(  LIN(I) .EQ. -2))GOTO 23136 
C THEN UNSUCCESSFUL 
      PRESN = 0 
      RETURN
23136 CONTINUE
      IF(.NOT.( OMATCH(LIN, I, PAT, J) .EQ. 1))GOTO 23138 
      GOTO 23135
C           ELSE
23138 CONTINUE
      I = I + 1 
23134 GOTO 23133
23135 CONTINUE
23132 CONTINUE
23130 CONTINUE
      J = J + PATSIZ(PAT ,J)
CCALL EXEC(2,1,'/MATCH: PRESCAN MATCHED PAT=_',-QLENGTH)
CCALL EXEC(2,1,PAT, J)
C 
C  WE NOW KNOW THERE IS ENOUGH NON-CLOSURE PATTERNS WHICH MATCH 
C  SO THE CLOSURE MATCH MAY BE SUCCESSFUL.
C 
CCALL EXEC(2,1,'/PRESN: SUCCESS',-QLENGTH)
23125 GOTO 23124
23126 CONTINUE
      PRESN = 1 
      RETURN
      END 
C OMATCH - TRY TO MATCH A SINGLE PATTERN AT PAT(J)
      INTEGER FUNCTION OMATCH(LIN ,I ,PAT ,J) 
     C,92074-1X008 REV.2034 800818
      INTEGERLIN(82) ,PAT(100)
      INTEGER LOCATE ,ALPNU 
      INTEGER BUMP ,I ,J ,PATJ ,LINI
      OMATCH = 0
      IF(.NOT. (LIN(I) .EQ. -2))GOTO 23140
      RETURN
23140 CONTINUE
      BUMP = -1 
      PATJ = PAT(J) 
      LINI = LIN(I) 
      IF(.NOT. (PATJ .EQ. 97))GOTO 23142
      IF(.NOT. (LINI .EQ. PAT(J + 1)))GOTO 23144
      BUMP = 1
23144 CONTINUE
      GOTO 23143
23142 CONTINUE
      IF(.NOT. (PATJ .EQ. 94))GOTO 23146
      IF(.NOT. (I .EQ. 1))GOTO 23148
      BUMP = 0
23148 CONTINUE
      GOTO 23147
23146 CONTINUE
      IF(.NOT. (PATJ .EQ. 46))GOTO 23150
      IF(.NOT. (LINI .NE. 13))GOTO 23152
      BUMP = 1
23152 CONTINUE
      GOTO 23151
23150 CONTINUE
      IF(.NOT. (PATJ .EQ. 36))GOTO 23154
      IF(.NOT. (LINI .EQ. 13))GOTO 23156
      BUMP = 0
23156 CONTINUE
      GOTO 23155
23154 CONTINUE
      IF(.NOT.(PATJ .EQ. 58))GOTO 23158 
      IF(.NOT. (I .EQ. 1))GOTO 23160
      BUMP = 0
      GOTO 23161
23160 CONTINUE
      IF(.NOT.( IXOR(ALPNU(LIN(I-1)), ALPNU(LINI)) .NE. 0 ))GOTO 23162
C IF TYPES ARE DIFFERENT THEN MATCH 
      BUMP = 0        
23162 CONTINUE
23161 CONTINUE
      GOTO 23159
23158 CONTINUE
      IF(.NOT. (PATJ .EQ. 91))GOTO 23164
      IF(.NOT. (LOCATE(LINI, PAT, J + 1) .EQ. 1))GOTO 23166 
      BUMP = 1
23166 CONTINUE
      GOTO 23165
23164 CONTINUE
      IF(.NOT. (PATJ .EQ. 110))GOTO 23168 
      IF(.NOT. (LINI .NE. 13.AND. LOCATE(LINI, PAT, J + 1) .EQ. 0))GOTO 
     *23170 
      BUMP = 1
23170 CONTINUE
      GOTO 23169
23168 CONTINUE
      CALL ERROR(24HIN OMATCH: CAN'T HAPPEN.) 
23169 CONTINUE
23165 CONTINUE
23159 CONTINUE
23155 CONTINUE
23151 CONTINUE
23147 CONTINUE
23143 CONTINUE
      IF(.NOT. (BUMP .GE. 0))GOTO 23172 
      I = I + BUMP
      OMATCH = 1
23172 CONTINUE
      RETURN
      END 
C ALPNU - RETURN 1 IF CHAR IS ALPHANUMERIC ELSE RETURN 0
      INTEGER FUNCTION ALPNU(C) 
     C,92074-1X008 REV.2034 800818
      INTEGERC
      INTEGER TYPE,T
      T = TYPE(C) 
      IF(.NOT.( T .EQ. 2.OR. T .EQ. 1))GOTO 23174 
      ALPNU = 1 
      GOTO 23175
23174 CONTINUE
      ALPNU = 0 
23175 CONTINUE
      RETURN
      END 
C PATSIZ - RETURNS SIZE OF PATTERN ENTRY AT PAT(N)
      INTEGER FUNCTION PATSIZ(PAT ,N) 
     C,92074-1X008 REV.2034 800818
      INTEGERPAT(100) 
      INTEGER N ,PATN 
      PATN = PAT(N) 
      IF(.NOT. (PATN .EQ. 97.OR. PATN .EQ. 123.OR. PATN .EQ. 125))GOTO 2
     *3176
      PATSIZ = 2
      GOTO 23177
23176 CONTINUE
      IF(.NOT. (PATN .EQ. 94.OR. PATN .EQ. 36.OR. PATN .EQ. 46.OR. PATN 
     *.EQ. 58))GOTO 23178 
      PATSIZ = 1
      GOTO 23179
23178 CONTINUE
      IF(.NOT. (PATN .EQ. 91.OR. PATN .EQ. 110))GOTO 23180
      PATSIZ = PAT(N + 1) + 2 
      GOTO 23181
23180 CONTINUE
      IF(.NOT. (PATN .EQ. 42))GOTO 23182
      PATSIZ = 4
      GOTO 23183
23182 CONTINUE
      CALL ERROR(24HIN PATSIZ: CAN'T HAPPEN.) 
23183 CONTINUE
23181 CONTINUE
23179 CONTINUE
23177 CONTINUE
      RETURN
      END 
C STCLOS - INSERT CLOSURE ENTRY AT PAT(J) 
      INTEGER FUNCTION STCLOS(PAT ,J ,LASTJ ,LASTCL ,MAXPAT)
     C,92074-1X008 REV.2034 800818
      INTEGERPAT(MAXPAT)
      INTEGER ADDSET
      INTEGER J ,JP ,JT ,JUNK ,LASTCL ,LASTJ
      CONTINUE
      JP = J - 1
23184 IF(.NOT.(JP .GE. LASTJ))GOTO 23186
C MAKE A HOLE 
      JT = JP + 4 
      JUNK = ADDSET(PAT(JP) ,PAT ,JT ,MAXPAT) 
23185 JP=JP-1 
      GOTO 23184
23186 CONTINUE
      J = J + 4 
      STCLOS = LASTJ
C PUT CLOSURE IN IT 
      JUNK = ADDSET(42 ,PAT ,LASTJ ,MAXPAT)   
C COUNT 
      JUNK = ADDSET(0 ,PAT ,LASTJ ,MAXPAT)      
C PREVCL
      JUNK = ADDSET(LASTCL ,PAT ,LASTJ ,MAXPAT)   
C START 
      JUNK = ADDSET(0 ,PAT ,LASTJ ,MAXPAT)      
      RETURN
      END 
C ADDSET - PUT  C  IN  SET(J)  IF IT FITS,  INCREMENT  J
      INTEGER FUNCTION ADDSET(C ,SET ,J ,MAXSIZ)
     C,92074-1X008 REV.2034 800818
      INTEGER J ,MAXSIZ 
      INTEGERC ,SET(MAXSIZ) 
      IF(.NOT. (J .GT. MAXSIZ))GOTO 23187 
      ADDSET = 0
      GOTO 23188
23187 CONTINUE
      SET(J) = C
      J = J + 1 
      ADDSET = 1
23188 CONTINUE
      RETURN
      END 
C DODASH - EXPAND ARRAY(I-1)-ARRAY(I+1) INTO SET(J)... FROM VALID 
C 
C NEW CODE IS BUILD DASH PATTERN AT ARRAY(I-1)-ARRAY(I+1) INTO
C SET(J).    SET(J-1) HAS ARRAY(I-1) ALREADY IN IT. 
C 
C PATTERN IS  <LOW CHAR><HIGH CHAR><DASHFLAG>.  NOTE THAT SET MUST BE 
C SCANED FROM HIGH TO LOW INDEX TO FIND THE DASH FLAG FIRST.
C 
C 
      SUBROUTINE DODASH(VALID ,ARRAY ,I ,SET ,J ,MAXSET)
     C,92074-1X008 REV.2034 800818
      INTEGERESC
      INTEGER ADDSET ,INDEX 
      INTEGER I ,J ,JUNK ,K ,LIMIT ,MAXSET
      INTEGERARRAY(100) ,SET(MAXSET) ,VALID(100)
C SKIP DASH 
      I = I + 1               
C 
C OLD CODE
C  J = J - 1
C  LIMIT = INDEX(VALID, ESC(ARRAY, I))
C  FOR (K = INDEX(VALID, SET(J)); K <= LIMIT; K = K + 1)
C     JUNK = ADDSET(VALID(K), SET, J, MAXSET) 
C 
C NEW CODE
C 
      JUNK = ADDSET(ESC(ARRAY ,I) ,SET ,J ,MAXSET)
      JUNK = ADDSET(-1 ,SET ,J ,MAXSET) 
CCALL EXEC(2,1,'/DODASH: SET =_',-QLENGTH)
CCALL EXEC(2,1,SET,J) 
      RETURN
      END 
C ESC - MAP  ARRAY(I)  INTO ESCAPED CHARACTER IF APPROPRIATE
      INTEGERFUNCTION ESC(ARRAY ,I) 
     C,92074-1X008 REV.2034 800818
      INTEGERARRAY(100) 
      INTEGER I 
      INTEGER ESCAPE
      COMMON /ESCCH/ ESCAPE 
      IF(.NOT. (ARRAY(I) .NE. ESCAPE))GOTO 23189
      ESC = ARRAY(I)
      GOTO 23190
23189 CONTINUE
      IF(.NOT. (ARRAY(I+1) .EQ. -2))GOTO 23191
C ESC NOT SPECIAL AT END
      ESC = ESCAPE
      GOTO 23192
23191 CONTINUE
      I = I + 1 
      ESC = ARRAY(I)
23192 CONTINUE
23190 CONTINUE
      RETURN
      END 
C FILSET - EXPAND SET AT  ARRAY(I)  INTO  SET(J),  STOP AT  DELIM 
      SUBROUTINE FILSET(DELIM ,ARRAY ,I ,SET ,J ,MAXSET)
     C,92074-1X008 REV.2034 800818
      INTEGERESC
      INTEGER ADDSET ,INDEX 
      INTEGER I ,J ,JUNK ,MAXSET
      INTEGERARRAY(100) ,DELIM ,SET(MAXSET) 
      INTEGER ESCAPE
      COMMON /ESCCH/ ESCAPE 
C   STRING DIGITS "0123456789"
      INTEGER DIGITS(11)
C   STRING LOWALF "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
      INTEGER LOWALF(27)
C   STRING UPALF "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
      INTEGER UPALF(27) 
      DATA DIGITS(1)/48/ ,DIGITS(2)/49/ ,DIGITS(3)/50/
      DATA DIGITS(4)/51/ ,DIGITS(5)/52/ ,DIGITS(6)/53/
      DATA DIGITS(7)/54/ ,DIGITS(8)/55/ ,DIGITS(9)/56/
      DATA DIGITS(10)/57/ ,DIGITS(11)/-2/ 
      DATA LOWALF(01)/97/ 
      DATA LOWALF(02)/98/ 
      DATA LOWALF(03)/99/ 
      DATA LOWALF(04)/100/
      DATA LOWALF(05)/101/
      DATA LOWALF(06)/102/
      DATA LOWALF(07)/103/
      DATA LOWALF(08)/104/
      DATA LOWALF(09)/105/
      DATA LOWALF(10)/106/
      DATA LOWALF(11)/107/
      DATA LOWALF(12)/108/
      DATA LOWALF(13)/109/
      DATA LOWALF(14)/110/
      DATA LOWALF(15)/111/
      DATA LOWALF(16)/112/
      DATA LOWALF(17)/113/
      DATA LOWALF(18)/114/
      DATA LOWALF(19)/115/
      DATA LOWALF(20)/116/
      DATA LOWALF(21)/117/
      DATA LOWALF(22)/118/
      DATA LOWALF(23)/119/
      DATA LOWALF(24)/120/
      DATA LOWALF(25)/121/
      DATA LOWALF(26)/122/
      DATA LOWALF(27)/-2/ 
      DATA UPALF(01) /65/ 
      DATA UPALF(02) /66/ 
      DATA UPALF(03) /67/ 
      DATA UPALF(04) /68/ 
      DATA UPALF(05) /69/ 
      DATA UPALF(06) /70/ 
      DATA UPALF(07) /71/ 
      DATA UPALF(08) /72/ 
      DATA UPALF(09) /73/ 
      DATA UPALF(10) /74/ 
      DATA UPALF(11) /75/ 
      DATA UPALF(12) /76/ 
      DATA UPALF(13) /77/ 
      DATA UPALF(14) /78/ 
      DATA UPALF(15) /79/ 
      DATA UPALF(16) /80/ 
      DATA UPALF(17) /81/ 
      DATA UPALF(18) /82/ 
      DATA UPALF(19) /83/ 
      DATA UPALF(20) /84/ 
      DATA UPALF(21) /85/ 
      DATA UPALF(22) /86/ 
      DATA UPALF(23) /87/ 
      DATA UPALF(24) /88/ 
      DATA UPALF(25) /89/ 
      DATA UPALF(26) /90/ 
      DATA UPALF(27) /-2/ 
      CONTINUE
23193 IF(.NOT.(ARRAY(I) .NE. DELIM .AND. ARRAY(I) .NE. -2))GOTO 23195 
      IF(.NOT. (ARRAY(I) .EQ. ESCAPE))GOTO 23196
      JUNK = ADDSET(ESC(ARRAY ,I) ,SET ,J ,MAXSET)
      GOTO 23197
23196 CONTINUE
      IF(.NOT. (ARRAY(I) .NE. 45))GOTO 23198
      JUNK = ADDSET(ARRAY(I) ,SET ,J ,MAXSET) 
      GOTO 23199
23198 CONTINUE
      IF(.NOT. (J .LE. 1 .OR. ARRAY(I+1) .EQ. -2))GOTO 23200
C LITERAL - 
      JUNK = ADDSET(45 ,SET ,J ,MAXSET) 
      GOTO 23201
23200 CONTINUE
      IF(.NOT. (INDEX(DIGITS, SET(J-1)) .GT. 0))GOTO 23202
      CALL DODASH(DIGITS ,ARRAY ,I ,SET ,J ,MAXSET) 
      GOTO 23203
23202 CONTINUE
      IF(.NOT. (INDEX(LOWALF, SET(J-1)) .GT. 0))GOTO 23204
      CALL DODASH(LOWALF ,ARRAY ,I ,SET ,J ,MAXSET) 
      GOTO 23205
23204 CONTINUE
      IF(.NOT. (INDEX(UPALF, SET(J-1)) .GT. 0))GOTO 23206 
      CALL DODASH(UPALF ,ARRAY ,I ,SET ,J ,MAXSET)
      GOTO 23207
23206 CONTINUE
      JUNK = ADDSET(45 ,SET ,J ,MAXSET) 
23207 CONTINUE
23205 CONTINUE
23203 CONTINUE
23201 CONTINUE
23199 CONTINUE
23197 CONTINUE
23194 I=I+1 
      GOTO 23193
23195 CONTINUE
      RETURN
      END 
C MAKSET - MAKE SET FROM  ARRAY(K)  IN  SET 
      INTEGER FUNCTION MAKSET(ARRAY ,K ,SET ,SIZE)
     C,92074-1X008 REV.2034 800818
      INTEGER ADDSET
      INTEGER I ,J ,K ,SIZE 
      INTEGERARRAY(100) ,SET(SIZE)
      I = K 
      J = 1 
      CALL FILSET(-2 ,ARRAY ,I ,SET ,J ,SIZE) 
      MAKSET = ADDSET(-2 ,SET ,J ,SIZE) 
      RETURN
      END 
C XINDEX - INVERT CONDITION RETURNED BY INDEX 
      INTEGER FUNCTION XINDEX(ARRAY ,C ,ALLBUT ,LASTTO) 
     C,92074-1X008 REV.2034 800818
      INTEGERARRAY(100) ,C
      INTEGER INDEX 
      INTEGER ALLBUT ,LASTTO
      IF(.NOT. (C .EQ. -12))GOTO 23208
      XINDEX = 0
      GOTO 23209
23208 CONTINUE
      IF(.NOT. (ALLBUT .EQ. 0))GOTO 23210 
      XINDEX = INDEX(ARRAY ,C)
      GOTO 23211
23210 CONTINUE
      IF(.NOT. (INDEX(ARRAY, C) .GT. 0))GOTO 23212
      XINDEX = 0
      GOTO 23213
23212 CONTINUE
      XINDEX = LASTTO + 1 
23213 CONTINUE
23211 CONTINUE
23209 CONTINUE
      RETURN
      END 
C## GETLN - GET AN INPUT LINE 
C#    INTEGER FUNCTION GETLN(LINE,INFILE) 
C#    INTEGER LINE(ARB) 
C#    INTEGER INFILE
C#    INTEGER C 
C#    INTEGER GETCH 
C## 
C#    FOR(I=1; I<=MAXLINE; I=I+1)[
C#         C = GETCH(C,INFILE)
C#         LINE(I) = C
C#         IF( C == NEWLINE \C == EOF)
C#              BREAK 
C#         ]
C#    LINE(I+1) = EOS 
C#    IF ( C == NEWLINE ) 
C#         GETLN = I
C#    ELSE
C#         GETLN = EOF
C#    RETURN
C#    END 
C CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I
      INTEGER FUNCTION CTOI(IN ,I)
     C,92074-1X008 REV.2034 800818
      INTEGERIN(100)
      INTEGER INDEX 
      INTEGER D ,I
C   STRING DIGITS "0123456789"
      INTEGER DIGITS(11)
      DATA DIGITS(1) /48/ 
      DATA DIGITS(2) /49/ 
      DATA DIGITS(3) /50/ 
      DATA DIGITS(4) /51/ 
      DATA DIGITS(5) /52/ 
      DATA DIGITS(6) /53/ 
      DATA DIGITS(7) /54/ 
      DATA DIGITS(8) /55/ 
      DATA DIGITS(9) /56/ 
      DATA DIGITS(10) /57/
      DATA DIGITS(11) /-2/
      CONTINUE
23214 IF(.NOT. (IN(I) .EQ. 32.OR. IN(I) .EQ. 9))GOTO 23215
      I = I + 1 
      GOTO 23214
23215 CONTINUE
      CONTINUE
      CTOI = 0
23216 IF(.NOT.(IN(I) .NE. -2))GOTO 23218
      D = INDEX(DIGITS ,IN(I))
      IF(.NOT. (D .EQ. 0))GOTO 23219
C NON-DIGIT 
      GOTO 23218
23219 CONTINUE
      CTOI = 10 * CTOI + D - 1
23217 I=I+1 
      GOTO 23216
23218 CONTINUE
      RETURN
      END 
C###################################################################### 
C INDEX - FIND CHARACTER  C  IN STRING  STR 
      INTEGER FUNCTION INDEX(STR ,C)
     C,92074-1X008 REV.2034 800818
      INTEGERC ,STR(100)
      CONTINUE
      INDEX = 1 
23221 IF(.NOT.(STR(INDEX) .NE. -2))GOTO 23223 
      IF(.NOT. (STR(INDEX) .EQ. C))GOTO 23224 
      RETURN
23224 CONTINUE
23222 INDEX=INDEX+1 
      GOTO 23221
23223 CONTINUE
      INDEX = 0 
      RETURN
      END 
C LENGH - COMPUTE LENGTH OF STRING
      INTEGER FUNCTION LENGH(STR) 
     C,92074-1X008 REV.2034 800818
      INTEGER STR(100)
      CONTINUE
      LENGH = 0 
23226 IF(.NOT.(STR(LENGH+1) .NE. -2))GOTO 23228 
23227 LENGH=LENGH+1 
      GOTO 23226
23228 CONTINUE
      RETURN
      END 
C TYPE - RETURN LETTER, DIGIT OR CHARACTER
C THIS ONE WORKS WITH ASCII ALPHABET
      INTEGER FUNCTION TYPE(C)
     C,92074-1X008 REV.2034 800818
      INTEGER C 
      IF(.NOT.( C .GE. 48.AND. C .LE. 57))GOTO 23229
      TYPE = 2
      GOTO 23230
23229 CONTINUE
      IF(.NOT.( C .GE. 97.AND. C .LE. 122))GOTO 23231 
      TYPE = 1
      GOTO 23232
23231 CONTINUE
      IF(.NOT.( C .GE. 65.AND. C .LE. 90))GOTO 23233
      TYPE = 1
      GOTO 23234
23233 CONTINUE
      TYPE = C
23234 CONTINUE
23232 CONTINUE
23230 CONTINUE
      RETURN
      END 
      SUBROUTINE ERROR(MESS)
     C,92074-1X008 REV.2034 800818
      INTEGER MESS(10)
      CALL EXEC(2,1,MESS,20)
      CALL ERTN 
      END 
C========= chang program from chapter 5 ==========
Cdefine(maxpat,128) 
C catsub - add replacement text to end of  new
      SUBROUTINE CATSUB(LIN ,FROM ,TO ,SUB ,NEW ,K ,MAXNEW) 
     C,92074-1X008 REV.2034 800818
      INTEGER ADDSET ,FOLD ,FOLDW 
      INTEGER FROM ,I ,J ,JUNK ,K ,MAXNEW ,TO ,ISTART ,STOP ,SUBF ,C
      INTEGERLIN(100) ,NEW(MAXNEW) ,SUB(100) ,IBUF(15)
      INTEGER SUBI
CINTEGER BUFF(3)
C COMMON BLOCK FOR TAG POINTER IN MATCH PROGRAM 
      COMMON /TAG/ TAGSRT(10),TAGSTP(10),TAGCNT 
      INTEGER TAGSRT,TAGSTP,TAGCNT
      CONTINUE
      I = 1 
23235 IF(.NOT.(SUB(I) .NE. -2))GOTO 23237 
      SUBF = SUB(I) 
      IF(.NOT. (SUBF .EQ. (-3).OR. SUBF .EQ. (-4).OR. SUBF .EQ. (-5)))GO
     *TO 23238
      I = I + 1 
      SUBI = SUB(I) 
C 
C &T no longer an option in substring 
C define(TIME,(-6)
C         if( subi == TIME ) {
C           call ftime(ibuf)
C           for(ii=1  ; ii<=30 ; ii=ii+1 )
C             junk = addset( lbyte(ibuf,ii), new, k, maxnew)
C           istart = 0   # copy nothing 
C           stop  = 0 
C           } 
C           else
      IF(.NOT.( SUBI .EQ. 0))GOTO 23240 
      ISTART = FROM 
      STOP = TO 
      GOTO 23241
23240 CONTINUE
      IF(.NOT.( SUBI .GE. 1 .AND. SUBI .LE. TAGCNT ))GOTO 23242 
      ISTART = TAGSRT( SUBI ) 
      STOP = TAGSTP( SUBI ) 
      GOTO 23243
23242 CONTINUE
      IF(.NOT.( SUBI .GT. TAGCNT .AND. SUBI .LE. 10))GOTO 23244 
C non-secified
C copy nothing
      ISTART = 0    
      STOP = 0
      GOTO 23245
23244 CONTINUE
      CALL ERROR(21HCATSUB : CANT HAPPEN.)
CCALL EXEC(2,1,'/CATSUB: istart=_',-QLENGTH)
CCALL CNUMD(istart,BUFF)
CCALL EXEC(2,1,BUFF,3)
CCALL EXEC(2,1,'/CATSUB:  STOP=_',-QLENGTH) 
CCALL CNUMD(STOP,BUFF)
CCALL EXEC(2,1,BUFF,3)
23245 CONTINUE
23243 CONTINUE
23241 CONTINUE
      CONTINUE
      J = ISTART
23246 IF(.NOT.(J .LT. STOP))GOTO 23248
      C = LIN(J)
      IF(.NOT.( SUBF .EQ. (-4)))GOTO 23249
      C = FOLD(C) 
      GOTO 23250
23249 CONTINUE
      IF(.NOT.( SUBF .EQ. (-5)))GOTO 23251
      C = FOLDW(C)
23251 CONTINUE
23250 CONTINUE
      JUNK = ADDSET(C ,NEW ,K ,MAXNEW)
23247 J=J+1 
      GOTO 23246
23248 CONTINUE
      GOTO 23239
23238 CONTINUE
      JUNK = ADDSET(SUB(I) ,NEW ,K ,MAXNEW) 
23239 CONTINUE
23236 I=I+1 
      GOTO 23235
23237 CONTINUE
      RETURN
      END 
C chang - chang  "from"  into  "to" 
      INTEGER FUNCTION CHANG(LIN,NEW,MAXLIN,PAT,SUBSRC,SUB) 
     C,92074-1X008 REV.2034 800818
      INTEGERLIN(100) ,NEW(MAXLIN) ,PAT(100) ,SUBSRC(100) ,SUB(100) 
C subsrc is the unfolded lin to be used in subsitutions 
      INTEGER ADDSET ,AMATCH ,PRESN 
      INTEGER I ,JUNK ,K ,LASTM ,M
C number of exchanges counter 
      COMMON /FDCNT/ FDCNT    
      INTEGER FDCNT 
C single exchange flag
      COMMON /SXFLG/ SXFLG    
      INTEGER SXFLG 
CCALL EXEC(2,1,'/CHANG: LIN=_',-QLENGTH)
CCALL EXEC(2,1,LIN,LENGTH(LIN)) 
CCALL EXEC(2,1,'/CHANG: PAT=_',-QLENGTH)
CCALL EXEC(2,1,PAT,LENGTH(PAT)) 
CCALL EXEC(2,1,'/CHANG: SUB=_',-QLENGTH)
CCALL EXEC(2,1,SUB,LENGTH(SUB)) 
      CHANG = 0 
      K = 1 
      LASTM = 0 
      IF(.NOT.( PRESN(LIN, PAT) .EQ. 1))GOTO 23253
      CONTINUE
      I =1
23255 IF(.NOT.(LIN(I) .NE. -2))GOTO 23257 
      IF(.NOT.( SXFLG .LT. 0 .AND. CHANG .EQ. 1))GOTO 23258 
C test for single exchange
      M = 0 
      GOTO 23259
23258 CONTINUE
      M = AMATCH(LIN ,I ,PAT) 
23259 CONTINUE
      IF(.NOT. (M .GT. 0 .AND. LASTM .NE. M))GOTO 23260 
C replace matched text
      CHANG = 1 
C bump counter
      FDCNT = FDCNT+1           
      CALL CATSUB(SUBSRC ,I ,M ,SUB ,NEW ,K ,MAXLIN)
      LASTM = M 
23260 CONTINUE
      IF(.NOT. (M .EQ. 0 .OR. M .EQ. I))GOTO 23262
C no match or null match
      JUNK = ADDSET(SUBSRC(I) ,NEW ,K ,MAXLIN)
      I = I + 1 
      GOTO 23263
23262 CONTINUE
C skip matched text 
      I = M 
23263 CONTINUE
23256 GOTO 23255
23257 CONTINUE
23253 CONTINUE
      IF(.NOT. (ADDSET(-2, NEW, K, MAXLIN) .EQ. 0))GOTO 23264 
      K = MAXLIN
      JUNK = ADDSET(-2 ,NEW ,K ,MAXLIN) 
      CHANG = -1
CCALL EXEC(2,1,NEW,LENGTH(NEW)) 
23264 CONTINUE
      RETURN
      END 
C fold - fold to upper case 
      INTEGERFUNCTION FOLD(C) 
     C,92074-1X008 REV.2034 800818
      INTEGERC
      IF(.NOT.( C .GE. 97.AND. C .LE. 122))GOTO 23266 
      FOLD = C - 32 
      GOTO 23267
23266 CONTINUE
      FOLD = C
23267 CONTINUE
      RETURN
      END 
C foldw - fold to lower case
      INTEGERFUNCTION FOLDW(C)
     C,92074-1X008 REV.2034 800818
      INTEGERC
      IF(.NOT.( C .GE. 65.AND. C .LE. 90))GOTO 23268
      FOLDW = C + 32
      GOTO 23269
23268 CONTINUE
      FOLDW = C 
23269 CONTINUE
      RETURN
      END 
C getsub - get substitution pattern into sub
      INTEGER FUNCTION GETSUB(ARG ,SUB ,MAXPAT) 
     C,92074-1X008 REV.2034 800818
      INTEGERARG(128) ,SUB(MAXPAT) ,MAXPAT
      INTEGER MAKSUB
      GETSUB = MAKSUB(ARG ,1 ,-2 ,SUB,MAXPAT) 
      RETURN
      END 
C maksub - make substitution string in sub
      INTEGER FUNCTION MAKSUB(ARG ,FROM ,DELIM ,SUB ,MAXPAT)
     C,92074-1X008 REV.2034 800818
      INTEGERESC
      INTEGERARG(128) ,DELIM ,SUB(MAXPAT) 
      INTEGER ADDSET
      INTEGER FROM ,I ,J ,JUNK ,ARGI ,SUBFLD
      INTEGER DIGITS(10)
      DATA DIGITS(1)/49/ ,DIGITS(2)/50/ ,DIGITS(3)/51/
      DATA DIGITS(4)/52/ ,DIGITS(5)/53/ ,DIGITS(6)/54/
      DATA DIGITS(7)/55/ ,DIGITS(8)/56/ ,DIGITS(9)/57/
      DATA DIGITS(10)/-2/ 
CCALL EXEC(2,1,'MAKSUB: ARG=_',-QLENGTH)
CCALL EXEC(2,1,ARG,LENGTH(ARG)) 
      J = 1 
      CONTINUE
      I = FROM
23270 IF(.NOT.(ARG(I) .NE. DELIM .AND. ARG(I) .NE. -2))GOTO 23272 
      ARGI = ARG(I) 
      IF(.NOT.( ARGI .EQ. 38))GOTO 23273
      SUBFLD = (-3) 
      GOTO 23274
23273 CONTINUE
      IF(.NOT.( ARGI .EQ. 62))GOTO 23275
      SUBFLD = (-4) 
      GOTO 23276
23275 CONTINUE
      IF(.NOT.(ARGI .EQ. 60))GOTO 23277 
      SUBFLD = (-5) 
      GOTO 23278
23277 CONTINUE
      SUBFLD = 0
23278 CONTINUE
23276 CONTINUE
23274 CONTINUE
      IF(.NOT. (SUBFLD .NE. 0 ))GOTO 23279
      JUNK = ADDSET(SUBFLD ,SUB ,J ,MAXPAT) 
C 
C  &T no longer an option in subfield 
C 
C        if( arg(i+1) == bigT \ arg(i+1) == lett ) {
C          junk = addset( TIME, sub, j, maxpat) 
C          i = i + 1
C          }
C        else 
      K = INDEX(DIGITS ,ARG(I+1)) 
      IF(.NOT.( K .NE. 0 ))GOTO 23281 
      I = I + 1 
23281 CONTINUE
      JUNK = ADDSET( K ,SUB ,J ,MAXPAT) 
      GOTO 23280
23279 CONTINUE
      JUNK = ADDSET(ESC(ARG ,I) ,SUB ,J ,MAXPAT)
23280 CONTINUE
23271 I=I+1 
      GOTO 23270
23272 CONTINUE
      IF(.NOT. (ARG(I) .NE. DELIM))GOTO 23283 
C missing delimiter 
      MAKSUB = -1 
      GOTO 23284
23283 CONTINUE
      IF(.NOT. (ADDSET(-2, SUB, J, MAXPAT) .EQ. 0))GOTO 23285 
C no room 
      MAKSUB = -1 
      GOTO 23286
23285 CONTINUE
      MAKSUB = I
CCALL EXEC(2,1,'MAKSUB: SUB =_',-QLENGTH) 
CCALL EXEC(2,1,SUB,LENGTH(SUB)) 
23286 CONTINUE
23284 CONTINUE
      RETURN
      END 
C COMMON BLOCKS 
      BLOCK DATA
     C,92074-1X008 REV.2034 800818
C COMMON BLOCK FOR TAG POINTER IN MATCH PROGRAM 
      COMMON /TAG/ TAGSRT(10),TAGSTP(10),TAGCNT 
      INTEGER TAGSRT,TAGSTP,TAGCNT
      END 
      END$
C 
C 
C           NAME:   EDTU2 
C           SOURCE: 92074-18008 
C           RELOC:  PART OF 92074-12002 
C           PGMR:   J.D.J.
C 
#                                               <800822.0800> 
INCLUDE RATDEF
DEFINE(DB, #) 
DEFINE(DBP,#) 
DEFINE(DB1,#) 
DEFINE(DB3,#) 
DEFINE(DB4,#) 
DEFINE(DB5,#) 
DEFINE(DB6,#) 
DEFINE(DB7,#) 
DEFINE(DB9,#) 
  
DEFINE(ZEROLEN,200B) # PPAT ZERO LENGTH LINE MATCH CHAR.
#DEFINE(BOLCHAR,201B) # PPAT BEGINNIG OF LINE CHAR. 
  
  
DEFINE(TAGS,10) 
  
DEFINE(COUNT,1) 
DEFINE(PREVCL,2)
DEFINE(START,3) 
DEFINE(CLOSIZE,4) 
  
  
DEFINE(TRANSCL,PLUS)
DEFINE(REPEATSC,LESS) 
DEFINE(REPEATEC,GREATER)
DEFINE(INDEFCHAR,ATSIGN)
  
DEFINE(NOT,CARET) 
DEFINE(BOL,CARET) 
DEFINE(ANY,PERIOD)
DEFINE(EOL,DOLLAR)
DEFINE(BOUNDARY,COLON)
DEFINE(CLOSURE,STAR)
DEFINE(CCL,LBRACK)
DEFINE(CCLEND,RBRACK) 
DEFINE(LTAG,LBRACE) 
DEFINE(RTAG,RBRACE) 
DEFINE(NCCL,LETN) 
DEFINE(CHAR,LETA) 
DEFINE(DASH,MINUS)
DEFINE(DASHFLAG,-1) 
# AMATCH  (NON-RECURSIVE) - LOOK FOR MATCH STARTING AT LIN(FROM)
   INTEGER FUNCTION AMATCH(LIN, FROM, PAT)
"     C,92074-1X008 REV.2034 800818"
   CHARACTER LIN(MAXLINE), PAT(ARB) 
   INTEGER OMATCH, PATSIZ 
   INTEGER FROM, I, J, OFFSET, STACK, TAGED, TAGLVL, RCNT, PATJ 
   INCLUDE CTAG 
   INTEGER BUFF(3)
   TAGED = NO 
   STACK = 0
   OFFSET = FROM      # NEXT UNEXAMINED INPUT CHARACTER 
   FOR (J = 1; PAT(J) ^= EOS; J = J + PATSIZ(PAT, J))[
      PATJ = PAT(J) 
      IF (PATJ == CLOSURE) [      # A CLOSURE ENTRY 
         STACK = J
         J = J + CLOSIZE      # STEP OVER CLOSURE 
         FOR (I = OFFSET; LIN(I) ^= EOS; )   # MATCH AS MANY AS 
            IF (OMATCH(LIN, I, PAT, J) == NO)   # POSSIBLE
               BREAK
         PAT(STACK+COUNT) = I - OFFSET
         PAT(STACK+START) = OFFSET
         OFFSET = I      # CHARACTER THAT MADE US FAIL
         ]
      ELSE IF (PATJ == LTAG \ PATJ == RTAG)[     #  TAG FIELD 
         PAT(J+1) = OFFSET          # SAVE POSITION IN PATTERN
         TAGED = YES
DB5 CALL EXEC(2,1,'/AMATCH: FOUND TAG _',-QLENGTH)
DB5 CALL EXEC(2,1,PATJ,1) 
DB6 CALL EXEC(2,1,'/AMATCH: OFFSET=_',-QLENGTH) 
DB6 CALL CNUMD(OFFSET,BUFF) 
DB6 CALL EXEC(2,1,BUFF,3) 
  
  
         ]
      ELSE IF (OMATCH(LIN, OFFSET, PAT, J) == NO) [   # NON-CLOSURE 
         FOR ( ; STACK > 0; STACK = PAT(STACK+PREVCL))
            IF (PAT(STACK+COUNT) > 0) 
               BREAK
         IF (STACK <= 0) [      # STACK IS EMPTY
            AMATCH = 0      # RETURN FAILURE
            RETURN
            ] 
         PAT(STACK+COUNT) = PAT(STACK+COUNT) - 1
         J = STACK + CLOSIZE
         OFFSET = PAT(STACK+START) + PAT(STACK+COUNT) 
         ]
      # ELSE OMATCH SUCCEEDED 
      ] 
   AMATCH = OFFSET
DB4 CALL EXEC(2,1,'/AMATCH: MATCH =_',-QLENGTH) 
DB4 CALL EXEC(2,1,LIN(FROM), (AMATCH-FROM)) 
  
  
   IF( TAGED == YES ) [ # THEN THERE WERE TAGS IN THE PATTERN 
DB6 CALL EXEC(2,1,'/AMATCH: TAGED = YES',-QLENGTH)
  
      TAGCNT = 0
      RCNT   = 0
      TAGLVL = 0
      FOR( J=1 ; PAT(J) ^= EOS ; J = J + PATSIZ(PAT, J)) [ # RESCAN 
         IF( PAT(J) == LTAG) [
            TAGCNT = TAGCNT + 1 
            TAGSRT(TAGCNT) = PAT(J+1) # PULL START POS. OUT OF PATTERN
            TAGLVL = TAGLVL + 1 
DB6  CALL EXEC(2,1,'/AMATCH: TAGLVL=_',-QLENGTH)
DB6  CALL CNUMD(TAGLVL,BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: TAGCNT=_',-QLENGTH)
DB6  CALL CNUMD(TAGCNT,BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: PAT(J+1)=_',-QLENGTH)
DB6  CALL CNUMD(PAT(J+1),BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: J=_',-QLENGTH) 
DB6  CALL CNUMD(J,BUFF) 
DB6  CALL EXEC(2,1,BUFF,3)
            ] 
         ELSE IF( PAT(J) == RTAG ) [
            TAGSTP(RCNT+TAGLVL) = PAT(J+1) # PULL STOP POS. OUT OF PATTERN
            TAGLVL = TAGLVL - 1 
            IF( TAGLVL == 0 ) 
               RCNT = RCNT + 1
DB6  CALL EXEC(2,1,'/AMATCH: TAGLVL=_',-QLENGTH)
DB6  CALL CNUMD(TAGLVL,BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: RCNT=_',-QLENGTH)
DB6  CALL CNUMD(RCNT,BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: PAT(J+1)=_',-QLENGTH)
DB6  CALL CNUMD(PAT(J+1),BUFF)
DB6  CALL EXEC(2,1,BUFF,3)
DB6  CALL EXEC(2,1,'/AMATCH: J=_',-QLENGTH) 
DB6  CALL CNUMD(J,BUFF) 
DB6  CALL EXEC(2,1,BUFF,3)
            ] 
         # ELSE SKIP PATTERN
         ]
DB3  CALL EXEC(2,1,'/AMATCH: TAGSRT AND TAGSTP ARRAYS',-QLENGTH)
DB3   FOR(KK=1;KK<TAGCNT;KK=KK+1)[
DB3  CALL EXEC(2,1,'/AMATCH: TAGSRT=_',-QLENGTH)
DB3  CALL CNUMD(TAGSRT(KK),BUFF)
DB3  CALL EXEC(2,1,BUFF,3)
DB3  CALL EXEC(2,1,'/AMATCH: TAGSTP=_',-QLENGTH)
DB3  CALL CNUMD(TAGSTP(KK),BUFF)
DB3  CALL EXEC(2,1,BUFF,3)
DB3  ]
      ] 
   RETURN      # SUCCESS
   END
# GETCCL - EXPAND CHAR CLASS AT ARG(I) INTO PAT(J)
   INTEGER FUNCTION GETCCL(ARG, I, PAT, J,MAXPAT) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ARG(MAXARG), PAT(MAXPAT) 
   INTEGER ADDSET 
   INTEGER I, J, JSTART, JUNK 
  
   I = I + 1      # SKIP OVER 
   IF (ARG(I) == NOT) [ 
      JUNK = ADDSET(NCCL, PAT, J, MAXPAT) 
      I = I + 1 
      ] 
   ELSE 
      JUNK = ADDSET(CCL, PAT, J, MAXPAT)
   JSTART = J 
   JUNK = ADDSET(0, PAT, J, MAXPAT)      # LEAVE ROOM FOR COUNT 
   CALL FILSET(CCLEND, ARG, I, PAT, J, MAXPAT)
   JUNK = ADDSET(J - JSTART - 1, PAT,  JSTART, MAXPAT) # ADD COUNT
   IF (ARG(I) == CCLEND)
      GETCCL = OK 
   ELSE 
      GETCCL = ERR
   RETURN 
   END
# GETPAT - CONVERT ARGUMENT INTO PATTERN
   INTEGER FUNCTION GETPAT(ARG, PAT, PPAT, MAXPAT)
"     C,92074-1X008 REV.2034 800818"
   INTEGER ARG(MAXARG), PAT(MAXPAT), PPAT(MAXPAT) 
   INTEGER MAXPAT 
   INTEGER MAKPAT 
  
   GETPAT = MAKPAT(ARG, 1, EOS, PAT, PPAT, MAXPAT)
   RETURN 
   END
# LOCATE - LOOK FOR C IN CHAR CLASS AT PAT(OFFSET)
   INTEGER FUNCTION LOCATE(C, PAT, OFFSET)
"     C,92074-1X008 REV.2034 800818"
   CHARACTER C, PAT(ARB)
   INTEGER I, OFFSET
   INTEGER PATI 
   # SIZE OF CLASS IS AT PAT(OFFSET), CHARACTERS FOLLOW 
  
DB7 CALL EXEC(2,1,'/LOCATE: c=_',-QLENGTH)
DB7 CALL EXEC(2,1,C,1)
DB7 CALL EXEC(2,1,'/LOCATE: CLASS=_',-QLENGTH)
DB7 CALL EXEC(2,1,PAT(OFFSET+1),PAT(OFFSET))
   FOR (I = OFFSET + PAT(OFFSET); I > OFFSET; I = I - 1)[ 
      PATI = PAT(I) 
# 
#  NEW CODE FOR DASH AS A SUB-PATTERN 
# 
      IF( PATI == DASHFLAG ) [
         I = I-2
         IF( C>=PAT(I) & C<=PAT(I+1) ) [
           LOCATE = YES 
DB7 CALL EXEC(2,1,'/LOCATE: RETURN YES FROM DASH PATTERN',-QLENGTH) 
           RETURN 
           ]
         ]
      ELSE IF (C == PATI) [ 
         LOCATE = YES 
DB7 CALL EXEC(2,1,'/LOCATE: RETURN YES',-QLENGTH) 
         RETURN 
         ]
      ] # CLOSE FOR LOOP
   LOCATE = NO
DB7 CALL EXEC(2,1,'/LOCATE: RETURN NO',-QLENGTH)
   RETURN 
   END
# SUFIX - TEST IF IT IS OK TO HAVE SUFIX ON THIS PATTERN
   INTEGER FUNCTION SUFIX(PAT)
"     C,92074-1X008 REV.2034 800818"
   INTEGER PAT
  
   IF (PAT==BOL \ PAT==EOL \ PAT==CLOSURE \ PAT==LTAG \ PAT==RTAG ) 
      SUFIX = NO
   ELSE 
      SUFIX = YES 
   RETURN 
   END
# COPY - COPY N CHARACTERS, INCERMENT J 
   SUBROUTINE COPY (N, FROM, I, TO, J, MAXTO) 
"     C,92074-1X008 REV.2034 800818"
   INTEGER N, FROM(ARB), I, TO(MAXTO), J, MAXTO, II, JJ, K
  
   II = I 
   FOR( K=1 ; K<=N ; K=K+1 ) [
      IF( J > MAXTO ) 
         RETURN 
      TO(J) = FROM(II)
      J = J + 1 
      II = II + 1 
      ] 
   RETURN 
   END
# MAKPAT - MAKE PATTERN FROM ARG(FROM), TERMINATE AT DELIM
#        - BUILD POSSIBLE MATCH INTO PPAT 
   INTEGER FUNCTION MAKPAT(ARG, FROM, DELIM, PAT, PPAT, MAXPAT) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ESC
   CHARACTER ARG(MAXARG), DELIM, PAT(MAXPAT),PPAT(MAXPAT) 
   INTEGER ADDSET, GETCCL, STCLOS, PATSIZ, SUFIX, CTOI
   INTEGER FROM, I, J, JUNK, LASTCL, LASTJ, LJ, LP, TAGPTR
   INTEGER ARGI,PATN
  
   COMMON /ESCCH/ ESCCH  # PPAT ESCAPE CHAR 
   INTEGER ESCCH
   COMMON /ANCCH/ ANCCH  # PPAT ANCHOR CHAR 
   INTEGER ANCCH
   COMMON /INDEF/ INDEF  # PPAT INDEFINATE MATCH CHAR 
   INTEGER INDEF
  
DB   CALL EXEC(2,1,'/MAKPAT: ARG=_',-QLENGTH) 
DB   CALL EXEC(2,1,ARG,LENGTH(ARG)) 
  
   J = 1      # PAT INDEX 
   LASTJ = 1
   LASTCL = 0 
   TAGPTR = 0 
   FOR (I = FROM; ARG(I) ^= DELIM & ARG(I) ^= EOS; I = I + 1) [ 
      LJ = J
      ARGI = ARG(I) 
      IF (ARGI == ANY)
         JUNK = ADDSET(ANY, PAT, J, MAXPAT) 
      ELSE IF (ARGI == ANCCH & I == FROM) 
         JUNK = ADDSET(BOL, PAT, J, MAXPAT) 
      ELSE IF (ARGI == EOL & ARG(I + 1) == DELIM) 
         JUNK = ADDSET(EOL, PAT, J, MAXPAT) 
      ELSE IF(ARGI == BOUNDARY) 
         JUNK = ADDSET(BOUNDARY, PAT, J, MAXPAT)
      ELSE IF (ARGI == CCL) [ 
         IF (GETCCL(ARG, I, PAT, J, MAXPAT) == ERR) 
            BREAK 
         ]
      ELSE IF (ARGI==LTAG & ARG(I+1) ^= DELIM) [
         TAGPTR = TAGPTR + 1
         IF(TAGPTR > TAGS ) 
            BREAK 
         JUNK = ADDSET(LTAG, PAT, J, MAXPAT)
         JUNK = ADDSET(0, PAT, J, MAXPAT)  # ROOM FOR POINTER 
         ]
      ELSE IF(ARGI == RTAG & I > FROM) [
         TAGPTR = TAGPTR - 1
         IF( TAGPTR < 0 ) 
            BREAK 
         JUNK = ADDSET(RTAG, PAT, J, MAXPAT)
         JUNK = ADDSET(0, PAT, J, MAXPAT)   # ROOM FOR POINTER
         ]
      ELSE IF ( ARGI == INDEF     ) [     # ALLOW '@' TO BE '.*'
         JUNK = ADDSET(ANY, PAT, J, MAXPAT) 
         LASTJ = LJ 
         LJ = LASTJ 
         LASTCL = STCLOS(PAT, J, LASTJ, LASTCL, MAXPAT) 
         ]
      ELSE IF (ARGI == REPEATSC ) [ 
         IF (SUFIX(PAT(LASTJ)) == NO )
             BREAK
         L = I+1
         K = CTOI (ARG, L)
         IF( ARG(L) ^= REPEATEC) [
            JUNK = ADDSET( CHAR, PAT, J, MAXPAT)
            JUNK = ADDSET( ARGI, PAT, J, MAXPAT)
            ] 
         ELSE [     # DO REPEAT COUNT 
            I = L   # SKIP OVER COUNT 
            FOR( II=1 ; II<=K-1 ; II=II+1 ) [ 
              L = J - LASTJ     # GET SIZE
              JTEMP = LASTJ 
              LASTJ = J 
              CALL COPY(L, PAT, JTEMP, PAT, J, MAXPAT)
              LJ = J
              ] 
            ] 
         ]
      ELSE IF ((ARGI==CLOSURE \ ARGI == TRANSCL ) & I > FROM) [ 
         IF( SUFIX(PAT(LASTJ)) == NO )  # OK TO SUFIX LAST PATTERN ?
            BREAK 
         IF ( ARGI == TRANSCL ) [  # FOR TRANSTIVE CLOSURES 
            L = J - LASTJ          # COPY PREV PATTERN THEN DO CLOSURE
            JTEMP = LASTJ 
            LASTJ = J 
            CALL COPY(L, PAT, JTEMP, PAT, J, MAXPAT)
            LJ = J
            ] 
         LJ = LASTJ 
         LASTCL = STCLOS(PAT, J, LASTJ, LASTCL, MAXPAT) 
         ]
      ELSE [
         JUNK = ADDSET(CHAR, PAT, J, MAXPAT)
         JUNK = ADDSET(ESC(ARG, I), PAT, J, MAXPAT) 
         ]
      LASTJ = LJ
      ] 
  
  
   IF (ARG(I) ^= DELIM)   # TERMINATED EARLY
      MAKPAT = ERR
   ELSE IF ( TAGPTR ^= 0 ) # UNBALANCED TAG FIELDS
      MAKPAT = ERR
   ELSE IF (ADDSET(EOS, PAT, J, MAXPAT) == NO)   # NO ROOM
      MAKPAT = ERR
   ELSE [  # PATERN OK
DB CALL EXEC(2,1,'/MAKPAT: PAT=_',-QLENGTH) 
DB CALL EXEC(2,1,PAT,LENGTH(PAT)) 
      MAKPAT = I
# 
#     BUILD POSSIBLE MATCH PATTERN
# 
#      PPAT IS ALWAYS SMALLER THAN PAT SO WE DON'T NEED TO DO 
#      LIMIT CHECKS 
      J = 1 
      I = 1 
      LP  = ERR 
      IF( PAT(1) == BOL ) [ 
        I = I + PATSIZ(PAT, 1)   # SKIP BOL 
        IF( PAT(2) == EOL ) [    # LOOK FOR ZERO LENGTH LINE
          LP = ZEROLEN           # SPECIAL TO MATCH ZERO LENGTH LINE
          ] 
        ELSE [
          LP = ANCCH             # SET IN ANCHOR CHAR 
          ] 
        PPAT(J) = LP
        J = 2 
        ] 
      ELSE [ # PUT AN INDEF. CHAR AS START OF PATTERN 
        LP = INDEF
        PPAT(J) = LP
        J = 2 
        ] 
      FOR( ; PAT(I) ^= EOS; I=I+PATSIZ(PAT,I)) [
        PATN = PAT(I) 
        IF( PATN == CHAR )[   # SINGLE CHAR ? 
          LP = PAT(I+1) 
          IF( LP == ANCCH \ LP == INDEF \ LP == ESCCH ) [ # TEST FOR SPECIALS 
            PPAT(J) = ESCCH                                # ESCAPE SPECIALS  
            J = J + 1 
            ] 
          PPAT(J) = LP
          J = J+1 
          ] 
        ELSE IF( PATN == LTAG \ PATN == RTAG   \ %
                 PATN == EOL \ PATN == BOUNDARY)
          ;  # JUST SKIP THEM 
        ELSE IF(PATN == ANY \ PATN == CCL \ PATN == NCCL \ %
                    PATN == CLOSURE    ) [
          IF( LP ^= INDEF ) [ 
             LP = INDEF            # USE AN INDEFINATE CHARACTER MATCH
             PPAT(J) = INDEF
             J = J + 1
             ]
          IF( PATN == CLOSURE ) [ 
            I = I + PATSIZ(PAT, I)    # CLOSURE TAKES TWO PATTERNS
            ] 
  
         ]
        ELSE [
DB         PPAT(J) = PATN 
DB         PPAT(J+1) = EOS
DB         CALL EXEC(2,1,'MAKPAT: PPAT=_',-QLENGTH) 
DB         CALL EXEC(2,1,PPAT,LENGTH(PPAT)) 
           CALL ERROR("BUG IN POSSIBLE MATCH.") 
           ]
        ] # CLOSE FOR 
      PPAT(J) = EOS 
DBP   CALL EXEC(2,1,'MAKPAT: PPAT=_',-QLENGTH)
DBP   CALL EXEC(2,1,PPAT,LENGTH(PPAT))
      ] # CLOSE ELSE PATTERN OK 
  
   RETURN 
   END
# MATCH - FIND MATCH ANYWHERE ON LINE 
   INTEGER FUNCTION MATCH(LIN, PAT) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER LIN(MAXLINE), PAT(ARB) 
   INTEGER AMATCH 
   INTEGER I, PATSIZ, OMATCH, PATJ, PRESN 
  
  
DB   CALL EXEC(2,1,'/MATCH: LIN=_',-QLENGTH)
DB   CALL EXEC(2,1,LIN,LENGTH(LIN)) 
DB   CALL EXEC(2,1,'/MATCH: PAT=_',-QLENGTH)
DB   CALL EXEC(2,1,PAT,LENGTH(PAT)) 
   IF( PRESN(LIN, PAT) == YES ) 
     FOR (I = 1; LIN(I) ^= EOS; I = I + 1)
        IF (AMATCH(LIN, I, PAT) > 0) [
           MATCH = YES
           RETURN 
           ]
   MATCH = NO 
   RETURN 
   END
# PRESC  - DO PRESCAN TO SEE IF PATTERN MAY MATCH 
   INTEGER FUNCTION PRESN(LIN,PAT)
"     C,92074-1X008 REV.2034 800818"
# 
# 
# FIRST SCAN TO SEE IF ALL THE NON-CLOSURE PATTERNS CAN BE
#     MATCHED INORDER WHEN THEY ARE SEPERATED BY ANY NUMBER OF
#     CHARS. THIS PREVENT A HUGE AMOUNT OF BACKTRACKING FOR 
#     PATTERNS LIKE .*[^ ].*[AB][AB]
# 
   INTEGER LIN(ARB), PAT(ARB), PATJ, PATSIZ, OMATCH 
  
   I = 1
   J = 1
   REPEAT [ # UNTIL PAT(J) == EOS  OR RETURN ON FAILURE 
      PATJ = PAT(J) 
      IF( PATJ == EOS ) 
         BREAK      # END OF PATTERN FOUND SO GO TRY REAL MATCH 
      IF( PATJ == CLOSURE ) [    # SKIP CLOSURE AND IT PATTERN
        J = J + PATSIZ(PAT, J)
        ] 
      ELSE IF( PATJ == LTAG \ PATJ == RTAG )
        ;                         # JUST SKIP THEM
      ELSE [                      # SEE IF PATTERN MATCH ANYWHERE ON LINE 
        REPEAT [
            IF(  LIN(I) == EOS ) [  # THEN UNSUCCESSFUL 
               PRESN = NO 
               RETURN 
               ]
            IF( OMATCH(LIN, I, PAT, J) == YES ) 
               BREAK
#           ELSE
               I = I + 1
            ] 
        ] 
      J = J + PATSIZ(PAT, J)
DB9 CALL EXEC(2,1,'/MATCH: PRESCAN MATCHED PAT=_',-QLENGTH) 
DB9 CALL EXEC(2,1,PAT, J) 
  
      ] 
# 
#  WE NOW KNOW THERE IS ENOUGH NON-CLOSURE PATTERNS WHICH MATCH 
#  SO THE CLOSURE MATCH MAY BE SUCCESSFUL.
# 
  
DB9 CALL EXEC(2,1,'/PRESN: SUCCESS',-QLENGTH) 
  
    PRESN = YES 
    RETURN
    END 
  
# OMATCH - TRY TO MATCH A SINGLE PATTERN AT PAT(J)
   INTEGER FUNCTION OMATCH(LIN, I, PAT, J)
"     C,92074-1X008 REV.2034 800818"
   CHARACTER LIN(MAXLINE), PAT(ARB) 
   INTEGER LOCATE, ALPNU
   INTEGER BUMP, I, J, PATJ, LINI 
  
   OMATCH = NO
   IF (LIN(I) == EOS) 
      RETURN
   BUMP = -1
   PATJ = PAT(J)
   LINI = LIN(I)
   IF (PATJ == CHAR) [
      IF (LINI == PAT(J + 1)) 
         BUMP = 1 
      ] 
   ELSE IF (PATJ == BOL) [
      IF (I == 1) 
         BUMP = 0 
      ] 
   ELSE IF (PATJ == ANY) [
      IF (LINI ^= NEWLINE)
         BUMP = 1 
      ] 
   ELSE IF (PATJ == EOL) [
      IF (LINI == NEWLINE)
         BUMP = 0 
      ] 
   ELSE IF(PATJ == BOUNDARY) [
      IF (I == 1) 
         BUMP = 0 
      ELSE IF( IXOR(ALPNU(LIN(I-1)), ALPNU(LINI)) ^= 0 )
         BUMP = 0        # IF TYPES ARE DIFFERENT THEN MATCH
      ] 
   ELSE IF (PATJ == CCL) [
      IF (LOCATE(LINI, PAT, J + 1) == YES)
         BUMP = 1 
      ] 
   ELSE IF (PATJ == NCCL) [ 
      IF (LINI ^= NEWLINE & LOCATE(LINI, PAT, J + 1) == NO) 
         BUMP = 1 
      ] 
   ELSE 
      CALL ERROR("IN OMATCH: CAN'T HAPPEN.")
   IF (BUMP >= 0) [ 
      I = I + BUMP
      OMATCH = YES
      ] 
   RETURN 
   END
# ALPNU - RETURN 1 IF CHAR IS ALPHANUMERIC ELSE RETURN 0
  INTEGER FUNCTION ALPNU(C) 
"     C,92074-1X008 REV.2034 800818"
  CHARACTER C 
  INTEGER TYPE,T
  
  T = TYPE(C) 
  IF( T == DIGIT \ T == LETTER )
      ALPNU = 1 
  ELSE
      ALPNU = 0 
  
  RETURN
  END 
  
# PATSIZ - RETURNS SIZE OF PATTERN ENTRY AT PAT(N)
   INTEGER FUNCTION PATSIZ(PAT, N)
"     C,92074-1X008 REV.2034 800818"
   CHARACTER PAT(ARB) 
   INTEGER N, PATN
  
   PATN = PAT(N)
   IF (PATN == CHAR \ PATN == LTAG \ PATN == RTAG)
      PATSIZ = 2
   ELSE IF (PATN == BOL \ PATN == EOL \ PATN == ANY \ PATN == BOUNDARY) 
      PATSIZ = 1
   ELSE IF (PATN == CCL \ PATN == NCCL) 
      PATSIZ = PAT(N + 1) + 2 
   ELSE IF (PATN == CLOSURE)
      PATSIZ = CLOSIZE
   ELSE 
      CALL ERROR("IN PATSIZ: CAN'T HAPPEN.")
   RETURN 
   END
# STCLOS - INSERT CLOSURE ENTRY AT PAT(J) 
   INTEGER FUNCTION STCLOS(PAT, J, LASTJ, LASTCL, MAXPAT) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER PAT(MAXPAT)
   INTEGER ADDSET 
   INTEGER J, JP, JT, JUNK, LASTCL, LASTJ 
  
   FOR (JP = J - 1; JP >= LASTJ; JP = JP - 1) [   # MAKE A HOLE 
      JT = JP + CLOSIZE 
      JUNK = ADDSET(PAT(JP), PAT, JT, MAXPAT) 
      ] 
   J = J + CLOSIZE
   STCLOS = LASTJ 
   JUNK = ADDSET(CLOSURE, PAT, LASTJ, MAXPAT)   # PUT CLOSURE IN IT 
   JUNK = ADDSET(0, PAT, LASTJ, MAXPAT)      # COUNT
   JUNK = ADDSET(LASTCL, PAT, LASTJ, MAXPAT)   # PREVCL 
   JUNK = ADDSET(0, PAT, LASTJ, MAXPAT)      # START
   RETURN 
   END
  
  
  
# ADDSET - PUT  C  IN  SET(J)  IF IT FITS,  INCREMENT  J
  
  
   INTEGER FUNCTION ADDSET(C, SET, J, MAXSIZ) 
"     C,92074-1X008 REV.2034 800818"
   INTEGER J, MAXSIZ
   CHARACTER C, SET(MAXSIZ) 
  
   IF (J > MAXSIZ)
      ADDSET = NO 
   ELSE [ 
      SET(J) = C
      J = J + 1 
      ADDSET = YES
      ] 
   RETURN 
   END
# DODASH - EXPAND ARRAY(I-1)-ARRAY(I+1) INTO SET(J)... FROM VALID 
# 
# NEW CODE IS BUILD DASH PATTERN AT ARRAY(I-1)-ARRAY(I+1) INTO
# SET(J).    SET(J-1) HAS ARRAY(I-1) ALREADY IN IT. 
# 
# PATTERN IS  <LOW CHAR><HIGH CHAR><DASHFLAG>.  NOTE THAT SET MUST BE 
# SCANED FROM HIGH TO LOW INDEX TO FIND THE DASH FLAG FIRST.  
# 
# 
   SUBROUTINE DODASH(VALID, ARRAY, I, SET, J, MAXSET) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ESC
   INTEGER ADDSET, INDEX
   INTEGER I, J, JUNK, K, LIMIT, MAXSET 
   CHARACTER ARRAY(ARB), SET(MAXSET), VALID(ARB)
  
   I = I + 1               # SKIP DASH
# 
# OLD CODE  
#  J = J - 1
#  LIMIT = INDEX(VALID, ESC(ARRAY, I))
#  FOR (K = INDEX(VALID, SET(J)); K <= LIMIT; K = K + 1)
#     JUNK = ADDSET(VALID(K), SET, J, MAXSET) 
# 
# NEW CODE
# 
   JUNK = ADDSET(ESC(ARRAY, I), SET, J, MAXSET) 
   JUNK = ADDSET(DASHFLAG, SET, J, MAXSET)
  
DB7 CALL EXEC(2,1,'/DODASH: SET =_',-QLENGTH) 
DB7 CALL EXEC(2,1,SET,J)
  
   RETURN 
   END
# ESC - MAP  ARRAY(I)  INTO ESCAPED CHARACTER IF APPROPRIATE
   CHARACTER FUNCTION ESC(ARRAY, I) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ARRAY(ARB) 
   INTEGER I
      INTEGER ESCAPE
      COMMON /ESCCH/ ESCAPE 
  
   IF (ARRAY(I) ^= ESCAPE)
      ESC = ARRAY(I)
   ELSE IF (ARRAY(I+1) == EOS)   # ESC NOT SPECIAL AT END 
      ESC = ESCAPE
   ELSE [ 
      I = I + 1 
         ESC = ARRAY(I) 
      ] 
   RETURN 
   END
# FILSET - EXPAND SET AT  ARRAY(I)  INTO  SET(J),  STOP AT  DELIM 
   SUBROUTINE FILSET(DELIM, ARRAY, I, SET, J, MAXSET) 
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ESC
   INTEGER ADDSET, INDEX
   INTEGER I, J, JUNK, MAXSET 
   CHARACTER ARRAY(ARB), DELIM, SET(MAXSET) 
      INTEGER ESCAPE
      COMMON /ESCCH/ ESCAPE 
#   STRING DIGITS "0123456789"
   INTEGER DIGITS(11) 
#   STRING LOWALF "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
   INTEGER LOWALF(27) 
#   STRING UPALF "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 
   INTEGER UPALF(27)
   DATA DIGITS(1)/DIG0/, DIGITS(2)/DIG1/, DIGITS(3)/DIG2/ 
   DATA DIGITS(4)/DIG3/, DIGITS(5)/DIG4/, DIGITS(6)/DIG5/ 
   DATA DIGITS(7)/DIG6/, DIGITS(8)/DIG7/, DIGITS(9)/DIG8/ 
   DATA DIGITS(10)/DIG9/, DIGITS(11)/EOS/ 
   DATA LOWALF(01)/LETA/
   DATA LOWALF(02)/LETB/
   DATA LOWALF(03)/LETC/
   DATA LOWALF(04)/LETD/
   DATA LOWALF(05)/LETE/
   DATA LOWALF(06)/LETF/
   DATA LOWALF(07)/LETG/
   DATA LOWALF(08)/LETH/
   DATA LOWALF(09)/LETI/
   DATA LOWALF(10)/LETJ/
   DATA LOWALF(11)/LETK/
   DATA LOWALF(12)/LETL/
   DATA LOWALF(13)/LETM/
   DATA LOWALF(14)/LETN/
   DATA LOWALF(15)/LETO/
   DATA LOWALF(16)/LETP/
   DATA LOWALF(17)/LETQ/
   DATA LOWALF(18)/LETR/
   DATA LOWALF(19)/LETS/
   DATA LOWALF(20)/LETT/
   DATA LOWALF(21)/LETU/
   DATA LOWALF(22)/LETV/
   DATA LOWALF(23)/LETW/
   DATA LOWALF(24)/LETX/
   DATA LOWALF(25)/LETY/
   DATA LOWALF(26)/LETZ/
   DATA LOWALF(27)/EOS/ 
   DATA UPALF(01) /BIGA/
   DATA UPALF(02) /BIGB/
   DATA UPALF(03) /BIGC/
   DATA UPALF(04) /BIGD/
   DATA UPALF(05) /BIGE/
   DATA UPALF(06) /BIGF/
   DATA UPALF(07) /BIGG/
   DATA UPALF(08) /BIGH/
   DATA UPALF(09) /BIGI/
   DATA UPALF(10) /BIGJ/
   DATA UPALF(11) /BIGK/
   DATA UPALF(12) /BIGL/
   DATA UPALF(13) /BIGM/
   DATA UPALF(14) /BIGN/
   DATA UPALF(15) /BIGO/
   DATA UPALF(16) /BIGP/
   DATA UPALF(17) /BIGQ/
   DATA UPALF(18) /BIGR/
   DATA UPALF(19) /BIGS/
   DATA UPALF(20) /BIGT/
   DATA UPALF(21) /BIGU/
   DATA UPALF(22) /BIGV/
   DATA UPALF(23) /BIGW/
   DATA UPALF(24) /BIGX/
   DATA UPALF(25) /BIGY/
   DATA UPALF(26) /BIGZ/
   DATA UPALF(27) /EOS/ 
  
   FOR ( ; ARRAY(I) ^= DELIM & ARRAY(I) ^= EOS; I = I + 1)
      IF (ARRAY(I) == ESCAPE) 
         JUNK = ADDSET(ESC(ARRAY, I), SET, J, MAXSET) 
      ELSE IF (ARRAY(I) ^= DASH)
         JUNK = ADDSET(ARRAY(I), SET, J, MAXSET)
      ELSE IF (J <= 1 \ ARRAY(I+1) == EOS)   # LITERAL -
         JUNK = ADDSET(DASH, SET, J, MAXSET)
      ELSE IF (INDEX(DIGITS, SET(J-1)) > 0) 
         CALL DODASH(DIGITS, ARRAY, I, SET, J, MAXSET)
      ELSE IF (INDEX(LOWALF, SET(J-1)) > 0) 
         CALL DODASH(LOWALF, ARRAY, I, SET, J, MAXSET)
      ELSE IF (INDEX(UPALF, SET(J-1)) > 0)
         CALL DODASH(UPALF, ARRAY, I, SET, J, MAXSET) 
      ELSE
         JUNK = ADDSET(DASH, SET, J, MAXSET)
   RETURN 
   END
# MAKSET - MAKE SET FROM  ARRAY(K)  IN  SET 
   INTEGER FUNCTION MAKSET(ARRAY, K, SET, SIZE) 
"     C,92074-1X008 REV.2034 800818"
   INTEGER ADDSET 
   INTEGER I, J, K, SIZE
   CHARACTER ARRAY(ARB), SET(SIZE)
  
   I = K
   J = 1
   CALL FILSET(EOS, ARRAY, I, SET, J, SIZE) 
   MAKSET = ADDSET(EOS, SET, J, SIZE) 
   RETURN 
   END
# XINDEX - INVERT CONDITION RETURNED BY INDEX 
   INTEGER FUNCTION XINDEX(ARRAY, C, ALLBUT, LASTTO)
"     C,92074-1X008 REV.2034 800818"
   CHARACTER ARRAY(ARB), C
   INTEGER INDEX
   INTEGER ALLBUT, LASTTO 
  
   IF (C == EOF)
      XINDEX = 0
   ELSE IF (ALLBUT == NO) 
      XINDEX = INDEX(ARRAY, C)
   ELSE IF (INDEX(ARRAY, C) > 0)
      XINDEX = 0
   ELSE 
      XINDEX = LASTTO + 1 
   RETURN 
   END
### GETLN - GET AN INPUT LINE 
##    INTEGER FUNCTION GETLN(LINE,INFILE) 
##    INTEGER LINE(ARB) 
##    INTEGER INFILE
##    INTEGER C 
##    INTEGER GETCH 
### 
##    FOR(I=1; I<=MAXLINE; I=I+1)[
##         C = GETCH(C,INFILE)
##         LINE(I) = C
##         IF( C == NEWLINE \C == EOF)
##              BREAK 
##         ]
##    LINE(I+1) = EOS 
##    IF ( C == NEWLINE ) 
##         GETLN = I
##    ELSE
##         GETLN = EOF
##    RETURN
##    END 
   # CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I 
      INTEGER FUNCTION CTOI(IN, I)
"     C,92074-1X008 REV.2034 800818"
      CHARACTER IN(ARB) 
      INTEGER INDEX 
      INTEGER D, I
   #   STRING DIGITS "0123456789" 
      INTEGER DIGITS(11)
      DATA DIGITS(1) /DIG0/ 
      DATA DIGITS(2) /DIG1/ 
      DATA DIGITS(3) /DIG2/ 
      DATA DIGITS(4) /DIG3/ 
      DATA DIGITS(5) /DIG4/ 
      DATA DIGITS(6) /DIG5/ 
      DATA DIGITS(7) /DIG6/ 
      DATA DIGITS(8) /DIG7/ 
      DATA DIGITS(9) /DIG8/ 
      DATA DIGITS(10) /DIG9/
      DATA DIGITS(11) /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)      # NON-DIGIT 
            BREAK 
         CTOI = 10 * CTOI + D - 1 
         ]
      RETURN
      END 
####################################################################### 
   # INDEX - FIND CHARACTER  C  IN STRING  STR
      INTEGER FUNCTION INDEX(STR, C)
"     C,92074-1X008 REV.2034 800818"
      CHARACTER C, STR(ARB) 
      FOR (INDEX = 1; STR(INDEX) ^= EOS; INDEX = INDEX + 1) 
         IF (STR(INDEX) == C) 
            RETURN
      INDEX = 0 
      RETURN
      END 
   # LENGH - COMPUTE LENGTH OF STRING 
      INTEGER FUNCTION LENGH(STR) 
"     C,92074-1X008 REV.2034 800818"
      INTEGER STR(ARB)
      FOR (LENGH = 0; STR(LENGH+1) ^= EOS; LENGH = LENGH + 1) 
         ;
      RETURN
      END 
   # TYPE - RETURN LETTER, DIGIT OR CHARACTER 
      # THIS ONE WORKS WITH ASCII ALPHABET
      INTEGER FUNCTION TYPE(C)
"     C,92074-1X008 REV.2034 800818"
      INTEGER C 
      IF( C >= DIG0 & C <= DIG9 ) 
         TYPE = DIGIT 
      ELSE IF( C >= LETA & C <= LETZ )
         TYPE = LETTER
      ELSE IF( C >= BIGA & C <= BIGZ )
         TYPE = LETTER
      ELSE
         TYPE = C 
      RETURN
      END 
      SUBROUTINE ERROR(MESS)
"     C,92074-1X008 REV.2034 800818"
      INTEGER MESS(10)
      CALL EXEC(2,1,MESS,20)
      CALL ERTN 
      END 
DEFINE(DB, #) 
DEFINE(DB2,#) 
#========= chang program from chapter 5 ==========
#define(maxpat,128) 
  
define(tags,10) 
define(MAXARG,128)
define(ESCAPE,ATSIGN) 
define(DITTO,(-3))
define(FOLDUP,(-4)) 
define(FOLDDOWN,(-5)) 
  
# catsub - add replacement text to end of  new
   subroutine catsub(lin, from, to, sub, new, k, maxnew)
"     C,92074-1X008 REV.2034 800818"
   integer addset, fold, foldw
   integer from, i, j, junk, k, maxnew, to, istart, stop, subf, c 
   character lin(ARB), new(maxnew), sub(ARB), ibuf(15)
   integer subi 
DB2   INTEGER BUFF(3) 
   include ctag 
  
   for (i = 1; sub(i) ^= EOS; i = i + 1){ 
      subf = sub(i) 
      if (subf == DITTO \ subf == FOLDUP \ subf == FOLDDOWN ) { 
          i = i + 1 
          subi = sub(i) 
# 
# &T no longer an option in substring 
# define(TIME,(-6)
#         if( subi == TIME ) {
#           call ftime(ibuf)
#           for(ii=1  ; ii<=30 ; ii=ii+1 )
#             junk = addset( lbyte(ibuf,ii), new, k, maxnew)
#           istart = 0   # copy nothing 
#           stop  = 0 
#           } 
#           else
                 if( subi == 0) { 
            istart = from 
            stop = to 
            } 
          else if( subi >= 1 & subi <= tagcnt ) { 
            istart = tagsrt( subi )   
            stop = tagstp( subi ) 
            } 
          else if( subi > tagcnt & subi <= TAGS ){ # non-secified 
            istart = 0    # copy nothing  
            stop = 0  
            } 
          else  
            call error('CATSUB : CANT HAPPEN.') 
DB2 CALL EXEC(2,1,'/CATSUB: istart=_',-QLENGTH) 
DB2 CALL CNUMD(istart,BUFF) 
DB2 CALL EXEC(2,1,BUFF,3) 
DB2 CALL EXEC(2,1,'/CATSUB:  STOP=_',-QLENGTH)
DB2 CALL CNUMD(STOP,BUFF) 
DB2 CALL EXEC(2,1,BUFF,3) 
         for (j = istart; j < stop; j = j + 1) {
            c = lin(j)
            if( subf == FOLDUP )
               c = fold(c)
             else if( subf == FOLDDOWN )
               c = foldw(c) 
            junk = addset(c, new, k, maxnew)
            } 
          } 
      else
         junk = addset(sub(i), new, k, maxnew)
      } 
   return 
   end
# chang - chang  "from"  into  "to" 
   integer function chang(lin,new,maxlin,pat,subsrc,sub)
"     C,92074-1X008 REV.2034 800818"
   character lin(ARB), new(maxlin), pat(ARB), subsrc(ARB), sub(ARB) 
   # subsrc is the unfolded lin to be used in subsitutions
  
   integer addset, amatch, presn
   integer i, junk, k, lastm, m 
  
   common /fdcnt/ fdcnt    # number of exchanges counter
   integer fdcnt
  
   common /sxflg/ sxflg    # single exchange flag 
   integer sxflg
  
DB   CALL EXEC(2,1,'/CHANG: LIN=_',-QLENGTH)
DB   CALL EXEC(2,1,LIN,LENGTH(LIN)) 
DB   CALL EXEC(2,1,'/CHANG: PAT=_',-QLENGTH)
DB   CALL EXEC(2,1,PAT,LENGTH(PAT)) 
DB   CALL EXEC(2,1,'/CHANG: SUB=_',-QLENGTH)
DB   CALL EXEC(2,1,SUB,LENGTH(SUB)) 
      chang = NO
      k = 1 
      lastm = 0 
      if( presn(lin, pat) == yes )
        for ( i =1; lin(i) ^= EOS; ) {
           if( sxflg < 0 & chang == YES )  # test for single exchange 
             m = 0
           else 
             m = amatch(lin, i, pat)
  
           if (m > 0 & lastm ^= m) {   # replace matched text 
              chang = YES 
              fdcnt = fdcnt+1          # bump counter 
              call catsub(subsrc, i, m, sub, new, k, maxlin)
              lastm = m 
              } 
  
           if (m == 0 \ m == i) {   # no match or null match
              junk = addset(subsrc(i), new, k, maxlin)
              i = i + 1 
              } 
           else            # skip matched text
              i = m 
           }
        if (addset(EOS, new, k, maxlin) == NO) {
           k = maxlin 
           junk = addset(EOS, new, k, maxlin) 
           chang = ERR
           }
DB   CALL EXEC(2,1,NEW,LENGTH(NEW)) 
   return 
   end
# fold - fold to upper case 
   character function fold(c) 
"     C,92074-1X008 REV.2034 800818"
   character c
   if( c >= leta & c <= letz )
     fold = c - 32
   else 
     fold = c 
   return 
   end
  
# foldw - fold to lower case
   character function foldw(c)
"     C,92074-1X008 REV.2034 800818"
   character c
   if( c >= biga & c <= bigz )
     foldw = c + 32 
   else 
     foldw = c
   return 
   end
  
# getsub - get substitution pattern into sub
   integer function getsub(arg, sub, maxpat)
"     C,92074-1X008 REV.2034 800818"
   character arg(MAXARG), sub(maxpat), maxpat 
   integer maksub 
  
   getsub = maksub(arg, 1, EOS, sub,maxpat) 
   return 
   end
# maksub - make substitution string in sub
   integer function maksub(arg, from, delim, sub, maxpat) 
"     C,92074-1X008 REV.2034 800818"
   character esc
   character arg(MAXARG), delim, sub(maxpat)
   integer addset 
   integer from, i, j, junk, argi, subfld 
   INTEGER DIGITS(10) 
   DATA DIGITS(1)/DIG1/, DIGITS(2)/DIG2/, DIGITS(3)/DIG3/ 
   DATA DIGITS(4)/DIG4/, DIGITS(5)/DIG5/, DIGITS(6)/DIG6/ 
   DATA DIGITS(7)/DIG7/, DIGITS(8)/DIG8/, DIGITS(9)/DIG9/ 
   DATA DIGITS(10)/EOS/ 
  
DB CALL EXEC(2,1,'MAKSUB: ARG=_',-QLENGTH)
DB CALL EXEC(2,1,ARG,LENGTH(ARG)) 
  
   j = 1
   for (i = from; arg(i) ^= delim & arg(i) ^= EOS; i = i + 1){
      argi = arg(i) 
      if( argi == AMPER ) 
        subfld = DITTO
      else if( argi == GREATER )
        subfld = FOLDUP 
      else if(argi == LESS )
        subfld = FOLDDOWN 
      else
        subfld = 0
      if (subfld ^= 0 ) { 
         junk = addset(subfld, sub, j, maxpat)
# 
#  &T no longer an option in subfield 
# 
#        if( arg(i+1) == bigT \ arg(i+1) == lett ) {
#          junk = addset( TIME, sub, j, maxpat) 
#          i = i + 1
#          }
#        else   
              { 
           k = index(digits, arg(i+1))
           if( k ^= 0 ) 
             i = i + 1
           junk = addset( k, sub, j, maxpat)
           }
         }
      else
         junk = addset(esc(arg, i), sub, j, maxpat) 
      } 
   if (arg(i) ^= delim)   # missing delimiter 
      maksub = ERR
   else if (addset(EOS, sub, j, maxpat) == NO)   # no room
      maksub = ERR
   else 
      maksub = i
DB      CALL EXEC(2,1,'MAKSUB: SUB =_',-QLENGTH)
DB      CALL EXEC(2,1,SUB,LENGTH(SUB))
  
   return 
   end
# COMMON BLOCKS 
   BLOCK DATA 
"     C,92074-1X008 REV.2034 800818"
   INCLUDE CTAG 
   END