IMPLEMENTATION MODULE MYSTR; (*************************************************************************** Environnement : Solaris 2.3 Modula -2 ------------- Programmeurs : Pierre L'Ecuyer, Benoit Martin. ------------ ***************************************************************************) IMPORT Strings; IMPORT ConNum; FROM MYINOUT IMPORT WriteString, WriteLn; FROM SYSTEM IMPORT UNSIGNED_16; CONST wordsize= 32 (* SYSTEM.BITSPERBITSET *); PROCEDURE Error (Str : ARRAY OF CHAR); BEGIN WriteLn; WriteString (Str); WriteLn; HALT END Error; PROCEDURE Append (VAR Res: ARRAY OF CHAR; Source : ARRAY OF CHAR); VAR succes : BOOLEAN; BEGIN Strings.Insert (Source, Res, Strings.Length(Res)); END Append; PROCEDURE Caps ( VAR source : ARRAY OF CHAR ); VAR i : CARDINAL; BEGIN FOR i := 0 TO (Strings.Length (source) - 1) DO IF (ORD (source[i]) >= ORD ('a')) AND (ORD (source[i]) <= ORD ('z')) THEN source[i] := CHR (ORD (source[i]) - ORD ('a') + ORD ('A')); END; END END Caps; PROCEDURE Compare (S1, S2: ARRAY OF CHAR): INTEGER; VAR result : INTEGER; BEGIN result := Strings.Compare (S1, S2); RETURN result; END Compare; PROCEDURE Concat (VAR Res : ARRAY OF CHAR; S1, S2 : ARRAY OF CHAR); BEGIN Strings.Concat (S1, S2, Res) END Concat; PROCEDURE Copy (VAR Dest : ARRAY OF CHAR; Source : ARRAY OF CHAR); BEGIN Strings.Assign (Source, Dest) END Copy; PROCEDURE Delete (VAR S : ARRAY OF CHAR; index : CARDINAL; len : CARDINAL); BEGIN Strings.Delete (S, index, len); END Delete; PROCEDURE Insert (VAR Res : ARRAY OF CHAR; Source : ARRAY OF CHAR; Pos : CARDINAL); BEGIN Strings.Insert (Source, Res, Pos); END Insert; PROCEDURE Item (VAR R : ARRAY OF CHAR; S : ARRAY OF CHAR; T : CharSet; N : CARDINAL); VAR I, J, HR, L : CARDINAL; BEGIN I := 0; L := Strings.Length(S); LOOP WHILE (I0 DO DEC (I); set (CS,T[I]) END; Item(R,S,CS,N); END ItemS; PROCEDURE Length(S : ARRAY OF CHAR): CARDINAL; BEGIN RETURN Strings.Length(S); END Length; PROCEDURE Match(Source,Pattern: ARRAY OF CHAR) : BOOLEAN; (* returns TRUE if the string in Source matches the string in Pattern The pattern may contain any number of the wild characters '*' and '?' '?' matches any single character '*' matches any sequence of charcters (including a zero length sequence) EG '*m?t*i*' will match 'Automatic' *) PROCEDURE Rmatch(VAR s: ARRAY OF CHAR; i: CARDINAL; VAR p: ARRAY OF CHAR; j: CARDINAL) : BOOLEAN; (* s = to be tested , i = position in s *) (* p = pattern to match ,j = position in p *) VAR matched: BOOLEAN; k : CARDINAL; BEGIN IF p[0]=CHR(0) THEN RETURN TRUE END; LOOP IF ((i > HIGH(s)) OR (s[i] = CHR(0))) AND ((j > HIGH(p)) OR (p[j] = CHR(0))) THEN RETURN TRUE ELSIF ((j > HIGH(p)) OR (p[j] = CHR(0))) THEN RETURN FALSE ELSIF (p[j] = '*') THEN k :=i; IF ((j = HIGH(p)) OR (p[j+1] = CHR(0))) THEN RETURN TRUE ELSE LOOP matched := Rmatch(s,k,p,j+1); IF matched OR (k > HIGH(s)) OR (s[k] = CHR(0)) THEN RETURN matched; END; INC(k); END; END ELSIF ((p[j]='?')AND(s[i]<>0C)) OR (CAP(p[j]) = CAP(s[i])) THEN INC(i); INC(j); ELSE RETURN FALSE; END; END; END Rmatch; BEGIN RETURN Rmatch(Source,0,Pattern,0) END Match; PROCEDURE Slice (VAR R: ARRAY OF CHAR; S : ARRAY OF CHAR; P, L : CARDINAL); VAR i : CARDINAL; BEGIN IF (P+L) > Strings.Length(S) THEN Error ("*** ERROR : MYSTR.Slice Pattern longer then Source"); END; FOR i:= 0 TO L DO R[i] := S[i+P] END; IF (i) <= HIGH(R) THEN R[i] := 0C END; END Slice; PROCEDURE Subst (VAR source : ARRAY OF CHAR; OldPattern : ARRAY OF CHAR; NewPattern : ARRAY OF CHAR ); VAR len : CARDINAL; index : UNSIGNED_16; BEGIN IF Strings.SearchPos (OldPattern, source, 0, index) THEN len := Strings.Length (OldPattern); Strings.Delete (source, index, len); Strings.Insert (NewPattern, source, index); END; END Subst; PROCEDURE Position (Substring : ARRAY OF CHAR; Source : ARRAY OF CHAR; at : CARDINAL; VAR pos : UNSIGNED_16; VAR found : BOOLEAN ); BEGIN found := Strings.SearchPos (Substring, Source, at, pos ); END Position; PROCEDURE StrToInt (S : ARRAY OF CHAR; b : INTEGER; VAR OK : BOOLEAN) : LONGINT; VAR s : LONGINT; BEGIN ConNum.StrToSigned_32 (S, b, s, OK); RETURN s; IF NOT OK THEN WriteString ("ERROR MYSTR.StrToInt : "); WriteString ("This implementation works only for 2 < b < 36"); WriteLn; END END StrToInt; (************** SET OF CHAR *******************) PROCEDURE set(VAR s: CharSet; ch: CHAR); BEGIN INCL(s[ORD(ch) DIV wordsize],ORD(ch) MOD wordsize); END set; PROCEDURE setn(VAR s: CharSet; ch: ARRAY OF CHAR); VAR i:CARDINAL; BEGIN i:=0; WHILE (i<=HIGH(ch)) & (ch[i]#0C) DO set(s,ch[i]); INC(i) END END setn; PROCEDURE inset(VAR s: CharSet; ch: CHAR): BOOLEAN; BEGIN RETURN (ORD(ch) MOD wordsize) IN s[ORD(ch) DIV wordsize] END inset; PROCEDURE insetn(VAR s: CharSet; ch: ARRAY OF CHAR): BOOLEAN; VAR i:CARDINAL; BEGIN i:=0; WHILE (i<=HIGH(ch)) & (ch[i]#0C)DO IF inset(s,ch[i]) THEN INC(i) ELSE RETURN FALSE END END; RETURN TRUE END insetn; PROCEDURE addset(VAR s,s1,s2: CharSet); VAR i:CARDINAL; BEGIN FOR i:=0 TO words-1 DO s[i]:=s1[i] + s2[i] END END addset; PROCEDURE inclset(VAR s,s1: CharSet); VAR i:CARDINAL; BEGIN FOR i:=0 TO words-1 DO s[i]:=s[i] + s1[i] END END inclset; PROCEDURE subset(VAR s,s1,s2: CharSet); VAR i:CARDINAL; BEGIN FOR i:=0 TO words-1 DO s[i]:=s1[i] - s2[i] END END subset; PROCEDURE exclset(VAR s,s1: CharSet); VAR i:CARDINAL; BEGIN FOR i:=0 TO words-1 DO s[i]:=s[i] - s1[i] END END exclset; PROCEDURE genset(VAR s,s1: CharSet; ch: CHAR); BEGIN s:=s1; set(s,ch) END genset; PROCEDURE gensetn(VAR s,s1: CharSet; ch: ARRAY OF CHAR); BEGIN s:=s1; setn(s,ch) END gensetn; PROCEDURE InCharSet(CH: CHAR; S: CharSet): BOOLEAN; VAR ActPosition: [0..bits-1]; ActGroup: [0..words-1]; Membership: BOOLEAN; BEGIN (* InCharSet *) ActGroup := ORD(CH) DIV bits; ActPosition := ORD(CH) MOD bits; Membership := (ActPosition IN S[ ActGroup]); RETURN Membership; END InCharSet; PROCEDURE CharSetUnion(A, B: CharSet; VAR C: CharSet); VAR I: CARDINAL; BEGIN (* CharSetUnion *) FOR I := 0 TO words-1 DO C[ I ] := A[ I ] + B[ I ]; END; END CharSetUnion; PROCEDURE CharSetDifference(A, B: CharSet; VAR C: CharSet); VAR I: CARDINAL; BEGIN (* CharSetDifference *) FOR I := 0 TO words-1 DO C[ I ] := A[ I ] - B[ I ]; END; END CharSetDifference; PROCEDURE CharSetIntersection(A, B: CharSet; VAR C: CharSet); VAR I: CARDINAL; BEGIN (* CharSetIntersection *) FOR I := 0 TO words-1 DO C[ I ] := A[ I ] * B[ I ]; END; END CharSetIntersection; PROCEDURE CharSetSymmetricDifference(A, B: CharSet; VAR C: CharSet); VAR I: CARDINAL; BEGIN (* CharSetSymmetricDifference *) FOR I := 0 TO words-1 DO C[ I ] := A[ I ] / B[ I ]; END; END CharSetSymmetricDifference; PROCEDURE DefineCharSet(Constructor: ARRAY OF CHAR; VAR S: CharSet; VAR ErrorNumber: CARDINAL); VAR CH: CHAR; (* Presently examined character of Constructor *) CharPointer, (* Pointer to CH *) I: CARDINAL; EndOfConstructor: BOOLEAN; PROCEDURE GetNextChar; (* GetNextChar loads CH with the next valid character of Constructor of with 0C. EndOfConstructor is true if and only CH = 0C. *) BEGIN (* GetNextChar *) REPEAT IF CharPointer > HIGH(Constructor) THEN CH := 0C; EndOfConstructor := TRUE; ELSE CH := Constructor[ CharPointer ]; IF CH = 0C THEN EndOfConstructor := TRUE; ELSE INC(CharPointer); END; END; UNTIL (CH <> ' ') OR EndOfConstructor; END GetNextChar; PROCEDURE ElementarySet(VAR ErrorNumber: CARDINAL); VAR Number, ESetStart, ESetEnd: CARDINAL; PROCEDURE PointSet(VAR ErrorNumber: CARDINAL); PROCEDURE GetNumber(VAR ErrorNumber: CARDINAL); BEGIN (* GetNumber *) IF (ORD(CH) >=ORD('0')) AND (ORD(CH) <=ORD('9')) THEN Number := ORD(CH) -ORD('0'); ELSE ErrorNumber := 6; RETURN; END; GetNextChar; WHILE (ORD(CH) >=ORD('0')) AND (ORD(CH) <= ORD('9')) DO Number := 10 * Number+ORD(CH) - ORD('0'); GetNextChar; END; IF Number > 1023 THEN ErrorNumber := 7; END; END GetNumber; BEGIN (* PointSet *) IF CH = '(' THEN IF CharPointer > HIGH(Constructor) THEN CH := 0C; EndOfConstructor := TRUE; ELSE CH :=Constructor [ CharPointer ]; IF CH = 0C THEN EndOfConstructor := TRUE; ELSE INC(CharPointer); END; END; IF EndOfConstructor THEN ErrorNumber := 3; RETURN; END; Number := ORD(CH); GetNextChar; IF CH <> ')' THEN ErrorNumber :=4; RETURN; END; GetNextChar; ELSIF CH = '[' THEN GetNextChar; GetNumber(ErrorNumber); IF ErrorNumber <> 0 THEN RETURN; END; IF CH <> ']' THEN ErrorNumber := 5; RETURN; END; GetNextChar; ELSE ErrorNumber := 1; RETURN; END; END PointSet; PROCEDURE AddToCharSet; VAR TempCardinal: CARDINAL; ActPosition: [0..bits-1]; ActGroup: [0..words-1]; BEGIN (* AddToCharSet *) IF ESetStart > ESetEnd THEN TempCardinal := ESetEnd; ESetEnd := ESetStart; ESetStart := TempCardinal; END; ActGroup := ESetStart DIV bits; ActPosition := ESetStart MOD bits; INCL(S[ ActGroup ], ActPosition); WHILE ESetStart < ESetEnd DO INC(ESetStart); IF ActPosition =bits-1 THEN ActPosition := 0; INC(ActGroup); ELSE INC(ActPosition); END; INCL(S[ ActGroup ], ActPosition); END; END AddToCharSet; BEGIN (* ElementarySet *) IF NOT ((CH =',') OR EndOfConstructor) THEN PointSet(ErrorNumber); IF ErrorNumber <> 0 THEN RETURN; END; ESetStart := Number; ESetEnd := Number; IF CH = '.' THEN GetNextChar; IF CH <> '.' THEN ErrorNumber := 2; RETURN; END; GetNextChar; PointSet(ErrorNumber); IF ErrorNumber <> 0 THEN RETURN; END; ESetEnd := Number; END; AddToCharSet; END; END ElementarySet; BEGIN (* DefineCharSet *) (* Intialisation. *) FOR I := 0 TO words-1 DO S[I] := {}; END; ErrorNumber := 0; CharPointer := 0; EndOfConstructor := FALSE; GetNextChar; ElementarySet(ErrorNumber); IF ErrorNumber <> 0 THEN RETURN; END; WHILE CH = ',' DO GetNextChar; ElementarySet(ErrorNumber); IF ErrorNumber <> 0 THEN RETURN END; END; IF NOT EndOfConstructor THEN ErrorNumber := 1; RETURN; END; END DefineCharSet; VAR i: CARDINAL; BEGIN FOR i:=0 TO words-1 DO s0[i]:={} END; END MYSTR.