(* ------------------------------------------------------------------------
  :Program.       PatMatch
  :Contents.      Match filenames exaktly like AmigaDos
  :Author.        Bernd Preusing
  :Address.       Gerhardstr. 16  D-2200 Elmshorn
  :Phone.         04121/22486
  :Copyright.     Public Domain
  :Language.      Oberon
  :Translator.    OBERON v1.08
  :Support.       Translated from BCPL and C to Modula-2
  :Support.       Translated from Modula-2 to Oberon (by [kai])
  :History.       v1.0 10-Feb-90 Bernd Preusing
  :History.       v1.1 17-Jun-90 [kai] Added "*" (= "#?")
  :Remark.        This is fully reentrant!
  :Remark.        Who understands this code??? Please add a "~"-feature
------------------------------------------------------------------------ *)
MODULE PatMatch;

IMPORT str : Strings,
       sys : SYSTEM;

PROCEDURE PreProcess (VAR Pat : ARRAY OF CHAR); (* "*" -> "#?" *)

VAR at : INTEGER;

BEGIN
   LOOP
      at := str.Occurs (Pat, "*");
      IF at = -1 THEN EXIT END;
      Pat[at] := "#"; str.InsertChar (Pat, at+1, "?");
   END; (* LOOP *)
END PreProcess;


PROCEDURE CmplPat * (Pat : ARRAY OF CHAR;
                     VAR Aux : ARRAY OF SHORTINT) : BOOLEAN;
(* ------------------------------------------------------------------------
  :Input.    Pat ist das Pattern das "compiliert" werden soll
  :Output.   Aux ist das "compilierte" Pattern als Argument für "Match"
  :Result.   Fehler beim "compilieren" ?
  :Semantic. Pattern muß vor Aufruf der Prozedur "Match" "compiliert" werden
------------------------------------------------------------------------ *)

CONST eos = 00X;

VAR Ch      : CHAR;
    PatP    : SHORTINT;
    Patlen  : INTEGER;
    ErrFlag : BOOLEAN;
    i       : SHORTINT;


   PROCEDURE Rch;

   BEGIN
      IF PatP >= Patlen THEN
         Ch := eos
      ELSE
         Ch := Pat[PatP];
         INC (PatP);
      END;
   END Rch;


   PROCEDURE NextItem;

   BEGIN
      IF Ch = "'" THEN Rch END;
      Rch;
   END NextItem;


   PROCEDURE SetExits (List, Val : SHORTINT);

   VAR A: SHORTINT;
       H: SHORTINT;

   BEGIN
      REPEAT
         A := Aux[List];
         Aux[List] := Val;
         List := A;
      UNTIL List=0;
   END SetExits;


   PROCEDURE Join (A ,B: SHORTINT) : SHORTINT;

   VAR T : SHORTINT;

   BEGIN
      T := A;
      IF A = 0 THEN RETURN B END;
      WHILE Aux[A] # 0 DO A := Aux[A] END;
      Aux[A] := B;
      RETURN T;
   END Join;


   PROCEDURE ^Exp (AltP : SHORTINT) : SHORTINT;


   PROCEDURE Prim () : SHORTINT;

   VAR A  : SHORTINT;
       Op : CHAR;

   BEGIN
      A := PatP;
      Op := Ch;
      NextItem;
      IF Op = '#' THEN
         SetExits (Prim (), A)
      ELSIF Op = '(' THEN
         A := Exp (A);
         IF Ch # ')' THEN ErrFlag := TRUE END;
         NextItem;
      ELSIF (Op = eos) OR (Op = '|') OR (Op = ')') THEN
         ErrFlag := TRUE
      END;
      RETURN A;
   END Prim;


   PROCEDURE Exp (AltP : SHORTINT) : SHORTINT;

   VAR Exits, A : SHORTINT;

   BEGIN
      Exits := 0;
      LOOP
         A := Prim ();
         IF (Ch = '|') OR (Ch = ')') OR (Ch = eos) THEN
            Exits := Join(Exits,A);
            IF Ch # '|' THEN RETURN Exits END;
            Aux[AltP] := PatP;
            AltP := PatP;
            NextItem;
         ELSE
            SetExits (A, PatP);
         END;
      END; (* LOOP *)
   END Exp;


BEGIN
   PreProcess (Pat);
   PatP := 0;
   Patlen := str.Length (Pat);
   ErrFlag := FALSE;
   i := 0;
   WHILE i <= Patlen DO Aux[i] := 0; INC (i) END;
   Rch;
   SetExits (Exp (0), 0);
   RETURN ~ErrFlag;
END CmplPat;


PROCEDURE Match * (Pat : ARRAY OF CHAR; Aux : ARRAY OF SHORTINT;
                   Str : ARRAY OF CHAR) : BOOLEAN;
(* ------------------------------------------------------------------------
  :Input.    Pat ist das Pattern, Aux ist mit "CmplPat" "compiliert"
  :Input.    Str ist der String, der verglichen werden soll
  :Result.   Paßt der String zum Pattern ?
  :Semantic. Prozedur zum Pattermatching
------------------------------------------------------------------------ *)

VAR StrIndex, I, N : SHORTINT;
    Strlength      : INTEGER;
    P, Q           : SHORTINT;
    K, Ch          : CHAR;
    Succflag       : BOOLEAN;
    Wp             : SHORTINT;
    Work           : ARRAY 128 OF SHORTINT;

   PROCEDURE Put (N: SHORTINT);

   TYPE IntPtr = POINTER TO SHORTINT;

   VAR ip, to: IntPtr;

   BEGIN
      IF N = 0 THEN
         Succflag := TRUE
      ELSE
         ip := sys.ADR (Work[1]);
         to := sys.ADR (Work[Wp]);
         WHILE sys.VAL (LONGINT, ip) <= sys.VAL (LONGINT, to) DO
            IF ip^ = N THEN RETURN END;
            INC (ip);
         END;
         INC (Wp); Work[Wp] := N;
      END;
   END Put;

BEGIN (* Match *)
   PreProcess (Pat);
   StrIndex := 0;
   Wp := 0;
   Succflag := FALSE;
   Strlength := str.Length(Str);
   Put (1);
   IF Aux[0] # 0 THEN Put (Aux[0]) END;
   LOOP
      N := 1;
      WHILE N <= Wp DO
         P := Work[N];
         K := Pat[P-1];
         Q := Aux[P];
         IF (K='#') THEN
            Put (P+1); Put (Q);
         ELSIF (K='%') THEN
            Put (Q)
         ELSIF (K='(') OR (K='|') THEN
            Put (P+1);
            IF Q # 0 THEN Put (Q) END;
         END;
         INC (N);
      END;
      IF StrIndex >= Strlength THEN RETURN Succflag END;
      IF Wp = 0 THEN RETURN FALSE END;
      Ch := Str[StrIndex]; INC (StrIndex);
      N := Wp;
      Wp := 0;
      Succflag := FALSE;
      I := 1;
      WHILE I <= N DO
         P := Work[I];
         K := Pat[P-1];
         IF (K = '?') THEN
            Put (Aux[P]);
         ELSIF (K = '#') OR (K = '|') OR (K = '%') OR (K = '(') THEN
            (* nix! *)
         ELSE
            IF K = "'" THEN K := Pat[P] END;
            IF CAP (Ch) = CAP(K) THEN Put (Aux[P]) END;
         END;
         INC (I);
      END;
   END; (* LOOP *)
END Match;

END PatMatch.