home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / cpm86 / trbtol86.lbr / FPRIMS.PQS / FPRIMS.PAS
Pascal/Delphi Source File  |  1985-10-23  |  7KB  |  287 lines
  1.  
  2. {
  3.         Copyright (c) 1981
  4.         By:     Bell Telephone Laboratories, Inc. and
  5.                 Whitesmith's Ltd.,
  6.  
  7.         This software is derived from the book
  8.                 "Software Tools in Pascal", by
  9.                 Brian W. Kernighan and P. J. Plauger
  10.                 Addison-Wesley, 1981
  11.                 ISBN 0-201-10342-7
  12.  
  13.         Right is hereby granted to freely distribute or duplicate this
  14.         software, providing distribution or duplication is not for profit
  15.         or other commercial gain and that this copyright notice remains
  16.         intact.
  17. }
  18.  
  19. CONST
  20.   MAXPAT=MAXSTR;
  21.   CLOSIZE=1;
  22.   CLOSURE=STAR;
  23.   BOL=PERCENT;
  24.   EOL=DOLLAR;
  25.   ANY=QUESTION;
  26.   CCL=LBRACK;
  27.   CCLEND=RBRACK;
  28.   NEGATE=CARET;
  29.   NCCL=EXCLAM;
  30.   LITCHAR=67;
  31.  
  32. FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
  33.   DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;
  34. FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
  35.   VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
  36. FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;
  37. FUNCTION MAKEPAT;
  38. VAR
  39.   I,J,LASTJ,LJ:INTEGER;
  40.   DONE,JUNK:BOOLEAN;
  41.  
  42. FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
  43.   VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
  44. VAR
  45.   JSTART:INTEGER;
  46.   JUNK:BOOLEAN;
  47.  
  48. PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
  49.   VAR I:INTEGER; VAR DEST:XSTRING;
  50.   VAR J:INTEGER; MAXSET:INTEGER);
  51. CONST ESCAPE=ATSIGN;
  52. VAR K:INTEGER;
  53. JUNK:BOOLEAN;
  54.  
  55. FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
  56. BEGIN
  57.   IF(S[I]<>ESCAPE) THEN
  58.     ESC:=S[I]
  59.   ELSE IF (S[I+1]=ENDSTR) THEN
  60.     ESC:=ESCAPE
  61.   ELSE BEGIN
  62.     I:=I+1;
  63.     IF (S[I]=ORD('N')) THEN
  64.       ESC:=NEWLINE
  65.     ELSE IF (S[I]=ORD('T')) THEN
  66.       ESC:=TAB
  67.     ELSE
  68.       ESC:=S[I]
  69.     END
  70. END;
  71.  
  72. BEGIN
  73.   WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
  74.     IF(SRC[I]=ESCAPE)THEN
  75.       JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
  76.     ELSE IF (SRC[I]<>DASH) THEN
  77.       JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
  78.     ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
  79.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
  80.     ELSE IF (ISALPHANUM(SRC[I-1]))
  81.       AND (ISALPHANUM(SRC[I+1]))
  82.       AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
  83.         FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
  84.           JUNK:=ADDSTR(K,DEST,J,MAXSET);
  85.             I:=I+1
  86.     END
  87.     ELSE
  88.       JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
  89.     I:=I+1
  90.   END
  91. END;
  92.  
  93. BEGIN
  94.   I:=I+1;
  95.   IF(ARG[I]=NEGATE) THEN BEGIN
  96.     JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
  97.     I:=I+1
  98.   END
  99.   ELSE
  100.     JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
  101.   JSTART:=J;
  102.   JUNK:=ADDSTR(0,PAT,J,MAXPAT);
  103.   DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
  104.   PAT[JSTART]:=J-JSTART-1;
  105.   GETCCL:=(ARG[I]=CCLEND)
  106. END;
  107.  
  108. PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
  109.   LASTJ:INTEGER);
  110. VAR
  111.   JP,JT:INTEGER;
  112.   JUNK:BOOLEAN;
  113. BEGIN
  114.   FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
  115.     JT:=JP+CLOSIZE;
  116.     JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
  117.   END;
  118.   J:=J+CLOSIZE;
  119.   PAT[LASTJ]:=CLOSURE
  120. END;
  121.  
  122. BEGIN
  123.   J:=1;
  124.   I:=START;
  125.   LASTJ:=1;
  126.   DONE:=FALSE;
  127.   WHILE(NOT DONE) AND (ARG[I]<>DELIM)
  128.     AND (ARG[I]<>ENDSTR) DO BEGIN
  129.       LJ:=J;
  130.       IF(ARG[I]=ANY) THEN
  131.         JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
  132.       ELSE IF (ARG[I]=BOL) AND (I=START) THEN
  133.         JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
  134.       ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
  135.         JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
  136.       ELSE IF (ARG[I]=CCL) THEN
  137.         DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
  138.       ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
  139.         LJ:=LASTJ;
  140.         IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
  141.           DONE:=TRUE
  142.         ELSE
  143.           STCLOSE(PAT,J,LASTJ)
  144.       END
  145.       ELSE BEGIN
  146.         JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
  147.         JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
  148.       END;
  149.       LASTJ:=LJ;
  150.       IF(NOT DONE) THEN
  151.         I:=I+1
  152.     END;
  153.     IF(DONE) OR (ARG[I]<>DELIM) THEN
  154.       MAKEPAT:=0
  155.     ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
  156.       MAKEPAT:=0
  157.     ELSE
  158.       MAKEPAT:=I
  159.   END;
  160.   
  161.  
  162. FUNCTION AMATCH;
  163.  
  164.  
  165. VAR I,K:INTEGER;
  166.    DONE:BOOLEAN;
  167.  
  168.  
  169. FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
  170.   VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
  171. VAR
  172.   ADVANCE:-1..1;
  173.  
  174.  
  175. FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
  176.   OFFSET:INTEGER):BOOLEAN;
  177. VAR
  178.   I:INTEGER;
  179. BEGIN
  180.   LOCATE:=FALSE;
  181.   I:=OFFSET+PAT[OFFSET];
  182.   WHILE(I>OFFSET) DO
  183.     IF(C=PAT[I]) THEN BEGIN
  184.       LOCATE :=TRUE;
  185.       I:=OFFSET
  186.     END
  187.     ELSE
  188.       I:=I-1
  189. END;BEGIN
  190.   ADVANCE:=-1;
  191.   IF(LIN[I]=ENDSTR) THEN
  192.     OMATCH:=FALSE
  193.   ELSE IF (NOT( PAT[J] IN
  194.    [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
  195.      ERROR('IN OMATCH:CAN''T HAPPEN')
  196.   ELSE
  197.     CASE PAT[J] OF
  198.     LITCHAR:
  199.       IF (LIN[I]=PAT[J+1]) THEN
  200.         ADVANCE:=1;
  201.     BOL:
  202.       IF (I=1) THEN
  203.         ADVANCE:=0;
  204.     ANY:
  205.       IF (LIN[I]<>NEWLINE) THEN
  206.         ADVANCE:=1;
  207.     EOL:
  208.       IF(LIN[I]=NEWLINE) THEN
  209.         ADVANCE:=0;
  210.     CCL:
  211.       IF(LOCATE(LIN[I],PAT,J+1)) THEN
  212.         ADVANCE:=1;
  213.     NCCL:
  214.       IF(LIN[I]<>NEWLINE)
  215.         AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
  216.           ADVANCE:=1
  217.         END;
  218.     IF(ADVANCE>=0) THEN BEGIN
  219.       I:=I+ADVANCE;
  220.       OMATCH:=TRUE
  221.     END
  222.     ELSE
  223.       OMATCH:=FALSE
  224.   END;
  225.   
  226. FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
  227. BEGIN
  228.   IF(NOT (PAT[N] IN
  229.    [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
  230.     ERROR('IN PATSIZE:CAN''T HAPPEN')
  231.   ELSE
  232.     CASE PAT[N] OF
  233.       LITCHAR:PATSIZE:=2;
  234.       BOL,EOL,ANY:PATSIZE:=1;
  235.       CCL,NCCL:PATSIZE:=PAT[N+1]+2;
  236.       CLOSURE:PATSIZE:=CLOSIZE
  237.     END
  238. END;
  239.  
  240. BEGIN
  241.   DONE:=FALSE;
  242.   WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
  243.     IF(PAT[J]=CLOSURE) THEN BEGIN
  244.       J:=J+PATSIZE(PAT,J);
  245.       I:=OFFSET;
  246.       WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
  247.         IF (NOT OMATCH(LIN,I,PAT,J)) THEN
  248.           DONE:=TRUE;
  249.       DONE:=FALSE;
  250.       WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
  251.         K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
  252.         IF(K>0) THEN
  253.           DONE:=TRUE
  254.         ELSE
  255.           I:=I-1
  256.       END;
  257.       OFFSET:=K;
  258.       DONE:=TRUE
  259.     END
  260.     ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
  261.       THEN BEGIN
  262.       OFFSET :=0;
  263.       DONE:=TRUE
  264.     END
  265.     ELSE
  266.       J:=J+PATSIZE(PAT,J);
  267.   AMATCH:=OFFSET
  268. END;
  269. FUNCTION MATCH;
  270.  
  271. VAR
  272.   I,POS:INTEGER;
  273.  
  274.   
  275.                                                                                
  276. BEGIN
  277.   POS:=0;
  278.   I:=1;
  279.   WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
  280.     POS:=AMATCH(LIN,I,PAT,1);
  281.     I:=I+1
  282.   END;
  283.   MATCH:=(POS>0)
  284. END;
  285.  
  286.  
  287.