home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / beehive / zcat / tptool19.lbr / FPRIMS.PQS / FPRIMS.PAS
Pascal/Delphi Source File  |  1991-01-31  |  6KB  |  266 lines
  1. (* 15 Feb 85 *)
  2. CONST
  3.   MAXPAT=MAXSTR;
  4.   CLOSIZE=1;
  5.   CLOSURE=STAR;
  6.   BOL=PERCENT;
  7.   EOL=DOLLAR;
  8.   ANY=QUESTION;
  9.   CCL=LBRACK;
  10.   CCLEND=RBRACK;
  11.   NEGATE=CARET;
  12.   NCCL=EXCLAM;
  13.   LITCHAR=67;
  14.  
  15.  
  16. FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
  17.   DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;
  18.  
  19. VAR
  20.   I,J,LASTJ,LJ:INTEGER;
  21.   DONE,JUNK:BOOLEAN;
  22.  
  23. FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
  24.   VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
  25. VAR
  26.   JSTART:INTEGER;
  27.   JUNK:BOOLEAN;
  28.  
  29. PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
  30.   VAR I:INTEGER; VAR DEST:XSTRING;
  31.   VAR J:INTEGER; MAXSET:INTEGER);
  32. CONST ESCAPE=ATSIGN;
  33. VAR K:INTEGER;
  34. JUNK:BOOLEAN;
  35.  
  36. FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
  37. BEGIN
  38.   IF(S[I]<>ESCAPE) THEN
  39.     ESC:=S[I]
  40.   ELSE IF (S[I+1]=ENDSTR) THEN
  41.     ESC:=ESCAPE
  42.   ELSE BEGIN
  43.     I:=I+1;
  44.     IF (S[I]=ORD('n')) THEN
  45.       ESC:=NEWLINE
  46.     ELSE IF (S[I]=ORD('t')) THEN
  47.       ESC:=TAB
  48.     ELSE
  49.       ESC:=S[I]
  50.     END
  51. END;
  52.  
  53. BEGIN
  54.   WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
  55.     IF(SRC[I]=ESCAPE)THEN
  56.       JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
  57.     ELSE IF (SRC[I]<>DASH) THEN
  58.       JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
  59.     ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
  60.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
  61.     ELSE IF (ISALPHANUM(SRC[I-1]))
  62.       AND (ISALPHANUM(SRC[I+1]))
  63.       AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
  64.         FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
  65.           JUNK:=ADDSTR(K,DEST,J,MAXSET);
  66.             I:=I+1
  67.     END
  68.     ELSE
  69.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
  70.     I:=I+1
  71.   END
  72. END;
  73.  
  74. BEGIN
  75.   I:=I+1;
  76.   IF(ARG[I]=NEGATE) THEN BEGIN
  77.     JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
  78.     I:=I+1
  79.   END
  80.   ELSE
  81.     JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
  82.   JSTART:=J;
  83.   JUNK:=ADDSTR(0,PAT,J,MAXPAT);
  84.   DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
  85.   PAT[JSTART]:=J-JSTART-1;
  86.   GETCCL:=(ARG[I]=CCLEND)
  87. END;
  88.  
  89. PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
  90.   LASTJ:INTEGER);
  91. VAR
  92.   JP,JT:INTEGER;
  93.   JUNK:BOOLEAN;
  94. BEGIN
  95.   FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
  96.     JT:=JP+CLOSIZE;
  97.     JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
  98.   END;
  99.   J:=J+CLOSIZE;
  100.   PAT[LASTJ]:=CLOSURE
  101. END;
  102.  
  103. BEGIN
  104.   J:=1;
  105.   I:=START;
  106.   LASTJ:=1;
  107.   DONE:=FALSE;
  108.   WHILE(NOT DONE) AND (ARG[I]<>DELIM)
  109.     AND (ARG[I]<>ENDSTR) DO BEGIN
  110.       LJ:=J;
  111.       IF(ARG[I]=ANY) THEN
  112.         JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
  113.       ELSE IF (ARG[I]=BOL) AND (I=START) THEN
  114.         JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
  115.       ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
  116.         JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
  117.       ELSE IF (ARG[I]=CCL) THEN
  118.         DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
  119.       ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
  120.         LJ:=LASTJ;
  121.         IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
  122.           DONE:=TRUE
  123.         ELSE
  124.           STCLOSE(PAT,J,LASTJ)
  125.       END
  126.       ELSE BEGIN
  127.         JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
  128.         JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
  129.       END;
  130.       LASTJ:=LJ;
  131.       IF(NOT DONE) THEN
  132.         I:=I+1
  133.     END;
  134.     IF(DONE) OR (ARG[I]<>DELIM) THEN
  135.       MAKEPAT:=0
  136.     ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
  137.       MAKEPAT:=0
  138.     ELSE
  139.       MAKEPAT:=I
  140.   END;
  141.   
  142.  
  143. FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
  144.   VAR PAT:XSTRING; J:INTEGER):INTEGER;
  145.  
  146. VAR I,K:INTEGER;
  147.    DONE:BOOLEAN;
  148.  
  149. FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
  150.   VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
  151. VAR
  152.   ADVANCE:-1..1;
  153.  
  154. FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
  155.   OFFSET:INTEGER):BOOLEAN;
  156. VAR
  157.   I:INTEGER;
  158. BEGIN
  159.   LOCATE:=FALSE;
  160.   I:=OFFSET+PAT[OFFSET];
  161.   WHILE(I>OFFSET) DO
  162.     IF(C=PAT[I]) THEN BEGIN
  163.       LOCATE :=TRUE;
  164.       I:=OFFSET
  165.     END
  166.     ELSE
  167.       I:=I-1
  168. END;
  169.  
  170. BEGIN
  171.   ADVANCE:=-1;
  172.   IF(LIN[I]=ENDSTR) THEN
  173.     OMATCH:=FALSE
  174.   ELSE IF (NOT( PAT[J] IN
  175.    [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
  176.      ERROR('in OMATCH: can''t happen')
  177.   ELSE
  178.     CASE PAT[J] OF
  179.     LITCHAR:
  180.       IF (LIN[I]=PAT[J+1]) THEN
  181.         ADVANCE:=1;
  182.     BOL:
  183.       IF (I=1) THEN
  184.         ADVANCE:=0;
  185.     ANY:
  186.       IF (LIN[I]<>NEWLINE) THEN
  187.         ADVANCE:=1;
  188.     EOL:
  189.       IF(LIN[I]=NEWLINE) THEN
  190.         ADVANCE:=0;
  191.     CCL:
  192.       IF(LOCATE(LIN[I],PAT,J+1)) THEN
  193.         ADVANCE:=1;
  194.     NCCL:
  195.       IF(LIN[I]<>NEWLINE)
  196.         AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
  197.           ADVANCE:=1
  198.     END;
  199.     IF(ADVANCE>=0) THEN BEGIN
  200.       I:=I+ADVANCE;
  201.       OMATCH:=TRUE
  202.     END
  203.     ELSE
  204.       OMATCH:=FALSE
  205.   END;
  206.  
  207. FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
  208. BEGIN
  209.   IF(NOT (PAT[N] IN
  210.    [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
  211.     ERROR('in PATSIZE: can''t happen')
  212.   ELSE
  213.     CASE PAT[N] OF
  214.       LITCHAR:PATSIZE:=2;
  215.       BOL,EOL,ANY:PATSIZE:=1;
  216.       CCL,NCCL:PATSIZE:=PAT[N+1]+2;
  217.       CLOSURE:PATSIZE:=CLOSIZE
  218.     END
  219. END;
  220.  
  221. BEGIN
  222.   DONE:=FALSE;
  223.   WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
  224.     IF(PAT[J]=CLOSURE) THEN BEGIN
  225.       J:=J+PATSIZE(PAT,J);
  226.       I:=OFFSET;
  227.       WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
  228.         IF (NOT OMATCH(LIN,I,PAT,J)) THEN
  229.           DONE:=TRUE;
  230.       DONE:=FALSE;
  231.       WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
  232.         K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
  233.         IF(K>0) THEN
  234.           DONE:=TRUE
  235.         ELSE
  236.           I:=I-1
  237.       END;
  238.       OFFSET:=K;
  239.       DONE:=TRUE
  240.     END
  241.     ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
  242.       THEN BEGIN
  243.       OFFSET :=0;
  244.       DONE:=TRUE
  245.     END
  246.     ELSE
  247.       J:=J+PATSIZE(PAT,J);
  248.   AMATCH:=OFFSET
  249. END;
  250.  
  251.  
  252. FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;
  253.  
  254. VAR
  255.   I,POS:INTEGER;
  256. BEGIN
  257.   POS:=0;
  258.   I:=1;
  259.   WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
  260.     POS:=AMATCH(LIN,I,PAT,1);
  261.     I:=I+1
  262.   END;
  263.   MATCH:=(POS>0)
  264. END;
  265.  
  266.