Topspeed_JPI/TS/SAVE/WINSTR.MOD

(* Release 3.10 *)
(*-------------------------------------------------------------------------*
*                                                                          *
*  WINSTR.MOD - String functions with far interface for use under Windows  *
*                                                                          *
*  COPYRIGHT (C) 1987..1992 Clarion Software Corporation.                  *
*  All Rights Reserved                                                     *
*                                                                          *
*--------------------------------------------------------------------------*)

(*# call(o_a_copy => off, near_call=>off, ds_eq_ss=>off) *)
(*# call(seg_name => null) *)
(*# module(implementation=>off, init_code=>off) *)
(*# data(seg_name => null, near_ptr=>off) *)
(*# check(stack=>off,
          index=>off,
          range=>off,
          overflow=>off,
          nil_ptr=>off) *)

IMPLEMENTATION MODULE WinStr;

IMPORT Lib, MATHLIB, SYSTEM;

PROCEDURE Compare(S1,S2:ARRAY OF CHAR):INTEGER;                    IN AsmLib;
PROCEDURE Length(S:ARRAY OF CHAR):CARDINAL;                        IN AsmLib;
PROCEDURE Concat(VAR R:ARRAY OF CHAR;S1,S2:ARRAY OF CHAR);         IN AsmLib;
PROCEDURE Append(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR);             IN AsmLib;
PROCEDURE Copy(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR);               IN AsmLib;
PROCEDURE CharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL;                IN AsmLib;
PROCEDURE Caps(VAR S:ARRAY OF CHAR);                               IN AsmLib;
PROCEDURE Lows(VAR S:ARRAY OF CHAR);                               IN AsmLib;
PROCEDURE Slice(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR;P,L:CARDINAL); IN AsmLib;
PROCEDURE Pos(S,P:ARRAY OF CHAR):CARDINAL;                         IN AsmLib;
PROCEDURE NextPos(S,P:ARRAY OF CHAR;Place:CARDINAL):CARDINAL;      IN AsmLib;
PROCEDURE RCharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL;               IN AsmLib;

PROCEDURE Prepend(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR);
VAR
  ShiftLen          : CARDINAL;
  S1Len,S2Len       : CARDINAL;
BEGIN
  S1Len:=Length(S1)+1;
  S2Len:=Length(S2);
  IF S2Len > HIGH(S1) THEN
    Copy(S1,S2);
    RETURN;
  END;
  ShiftLen := HIGH(S1) - S2Len + 1;
  IF ShiftLen > S1Len THEN
    ShiftLen := S1Len
  END; (*IF*)
  Lib.Move(ADR(S1),ADR(S1[S2Len]),ShiftLen);
  Lib.Move(ADR(S2),ADR(S1),S2Len);
END Prepend;

PROCEDURE Subst(VAR S1:ARRAY OF CHAR;Target:ARRAY OF CHAR;New:ARRAY OF CHAR);
VAR
  TargetPos,
  TargetLen         : CARDINAL;
BEGIN
  TargetPos := Pos(S1,Target);
  IF TargetPos = MAX(CARDINAL) THEN
    RETURN
  END; (*IF*)
  TargetLen := Length(Target);
  Lib.Move(ADR(S1[TargetPos+TargetLen]),ADR(S1[TargetPos]),Length(S1)-TargetLen-TargetPos+1);
  Insert(S1,New,TargetPos);
END Subst;

PROCEDURE Delete(VAR S:ARRAY OF CHAR;P,L:CARDINAL);
VAR
  Len,i             : CARDINAL;
BEGIN
  IF L # 0 THEN
    Len := Length(S);
    IF P < Len THEN
      IF L < Len - P THEN
        i := P+L;
        REPEAT
          S[P] := S[i];
          INC(P);
          INC(i);
        UNTIL i=Len;
      END; (*IF*)
      S[P] := 0C;
    END; (*IF*)
  END; (*IF*)
END Delete;

PROCEDURE Insert(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR;P:CARDINAL);
VAR
  I,J,C,L           : CARDINAL;
BEGIN
  L := Length(S1);
  I := Length(S2);
  C := L;
  IF C < P THEN
    P := C;
  END; (*IF*)
  DEC(C,P);
  FOR J := C TO 0 BY -1 DO
    IF (J+P+I <= HIGH(S1)) THEN
      S1[J+P+I] := S1[J+P];
    END; (*IF*)
  END; (*FOR*)
  J := 0;
  WHILE (J<I) & (P+J <= HIGH(S1)) DO
    S1[P+J] := S2[J];
    INC(J);
  END; (*WHILE*)
END Insert;

PROCEDURE Item(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR;T:CHARSET;N:CARDINAL);
VAR
  I,J               : CARDINAL;
  HR,L              : CARDINAL;
BEGIN
  I := 0;
  L := Length(S);
  LOOP
    WHILE (I < L) & (S[I] IN T) DO
      INC(I);
    END; (*WHILE*)
    IF (N = 0) OR (I = L) THEN
      EXIT
    END; (*IF*)
    DEC(N);
    WHILE (I < L) & ~(S[I] IN T) DO
      INC(I);
    END; (*WHILE*)
  END; (*LOOP*)
  J  := 0;
  HR := HIGH(R);
  WHILE (I < L) & ~(S[I] IN T) & (J <= HR) DO
    R[J] := S[I];
    INC(I);
    INC(J);
  END; (*WHILE*)
  IF (J <= HR) THEN
    R[J] := 0C;
  END; (*IF*)
END Item;

PROCEDURE ItemS(VAR R:ARRAY OF CHAR;S,T:ARRAY OF CHAR;N:CARDINAL);
VAR
  CS                : CHARSET;
  I                 : CARDINAL;
BEGIN
  I  := Length(T);
  CS := CHARSET{};
  WHILE I > 0 DO
    DEC(I);
    INCL(CS,T[I]);
  END;
  Item(R,S,CS,N);
END ItemS;

PROCEDURE Match(Source,Pattern:ARRAY OF CHAR):BOOLEAN;

  PROCEDURE Rmatch(VAR s:ARRAY OF CHAR;i:CARDINAL;VAR p:ARRAY OF CHAR;j:CARDINAL):BOOLEAN;
  VAR
    matched        : BOOLEAN;
    k              : CARDINAL;
  BEGIN
    IF p[0]=0C THEN
      RETURN TRUE;
    END; (*IF*)
    LOOP
      IF ((i>HIGH(s)) OR (s[i]=0C)) & ((j>HIGH(p)) OR (p[j]=0C)) THEN
        RETURN TRUE;
      ELSIF ((j>HIGH(p)) OR (p[j]=0C)) THEN
        RETURN FALSE;
      ELSIF (p[j]='*') THEN
        k :=i;
        IF ((j=HIGH(p)) OR (p[j+1]=0C)) THEN
          RETURN TRUE;
        ELSE
          LOOP
            matched := Rmatch(s,k,p,j+1);
            IF matched OR (k>HIGH(s)) OR (s[k]=0C) THEN
              RETURN matched;
            END; (*IF*)
            INC(k);
          END; (*LOOP*)
        END; (*IF*)
      ELSIF ((p[j]='?') & (s[i]#0C)) OR (CAP(p[j])=CAP(s[i])) THEN
        INC(i);
        INC(j);
      ELSE
        RETURN FALSE;
      END; (*IF*)
    END; (*LOOP*)
  END Rmatch;

BEGIN (*Match*)
  RETURN Rmatch(Source,0,Pattern,0);
END Match;

TYPE
  ConvIntType = ARRAY ['0'..'F'] OF SHORTCARD;
  BA          = ARRAY[0..1] OF SHORTCARD;

CONST
  ConvStr = '0123456789ABCDEF';
  ConvInt = ConvIntType( 0,1,2,3,4,5,6,7,8,9,255,255,255,255,255,255,255,10,11,12,13,14,15 );
  Div     = BA(0,4);

PROCEDURE CheckBase(VAR b:CARDINAL);
BEGIN
  IF b < 2  THEN
    b := 2;
  END; (*IF*)
  IF b > 16 THEN
    b := 16;
  END; (*IF*)
END CheckBase;

PROCEDURE Reverse(VAR s: ARRAY OF CHAR; l,h: CARDINAL);
VAR
  T                 : CHAR;
BEGIN
  WHILE l < h DO
    T := s[l];
    s[l] := s[h];
    s[h] := T;
    INC(l);
    DEC(h);
  END; (*WHILE*)
END Reverse;

PROCEDURE IntToStr(V:LONGINT;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN);
VAR
  i,l               : CARDINAL;
  b                 : LONGCARD;
BEGIN
  OK := TRUE;
  l := HIGH(S);
  CheckBase(Base);
  b := VAL(LONGCARD,Base);
  IF V < 0 THEN
    S[0] := '-';
    i := 1;
    V := -V;
  ELSE
    i := 0;
  END; (*IF*)
  LOOP
    IF i > l THEN
      OK := FALSE;
      EXIT;
    END; (*IF*)
    S[i] := ConvStr[CARDINAL(LONGCARD(V) MOD b)];
    INC(i);
    V := LONGCARD(V) DIV b;
    IF V = 0 THEN
      EXIT;
    END; (*IF*)
  END; (*LOOP*)
  IF i <= l THEN
    S[i] := 0C;
  END; (*IF*)
  IF S[0] < '0' THEN
    Reverse(S,1,i-1);
  ELSE
    Reverse(S,0,i-1);
  END; (*IF*)
END IntToStr;

PROCEDURE CardToStr(V:LONGCARD;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN);
VAR
  i,l               : CARDINAL;
  b                 : LONGCARD;
BEGIN
  OK := TRUE;
  l  := HIGH(S);
  CheckBase(Base);
  b := VAL(LONGCARD,Base);
  i := 0;
  LOOP
    IF i > l THEN
      OK := FALSE;
      EXIT;
    END; (*IF*)
    S[i] := ConvStr[CARDINAL(V MOD b)];
    INC(i);
    V := V DIV b;
    IF V = 0 THEN
      EXIT;
    END; (*IF*)
  END; (*LOOP*)
  IF i <= l THEN
    S[i] := 0C;
  END; (*IF*)
  Reverse(S,0,i-1);
END CardToStr;

(*# save,call(o_a_copy=>off)*)
PROCEDURE StrToCI(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD;
VAR
  i,l               : CARDINAL;
  b,t,y             : LONGCARD;
  c                 : CHAR;
  x                 : SHORTCARD;
BEGIN
  CheckBase(Base);
  b := VAL(LONGCARD,Base);
  i := 0;
  l := HIGH(S);
  IF (S[0] = '-') OR (S[0] = '+') THEN
    i := 1;
  END; (*IF*)
  t := 0;
  IF S[i] = 0C THEN
    OK := FALSE;
  END; (*IF*)
  WHILE (i <= l) & (S[i] # 0C) DO
    c := S[i];
    IF (c < '0') OR (c > 'F') THEN
      OK := FALSE;
      RETURN t;
    END; (*IF*)
    x := ConvInt[c];
    IF (x > SHORTCARD(b)-1) OR (t > (MAX(LONGCARD)-LONGCARD(x)) DIV b) THEN
      OK := FALSE;
    END; (*IF*)
    t := t*b+VAL(LONGCARD,x);
    INC(i);
  END; (*WHILE*)
  RETURN t;
END StrToCI;

PROCEDURE StrToInt(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGINT;
VAR
  t                 : LONGCARD;
BEGIN
  OK := TRUE;
  t  := StrToCI(S,Base,OK);
  IF t > 7FFFFFFFH THEN
    OK := FALSE;
  END; (*IF*)
  IF S[0] = '-' THEN
    RETURN -LONGINT(t);
  ELSE
    RETURN LONGINT(t);
  END; (*IF*)
END StrToInt;

PROCEDURE StrToCard(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD;
VAR
  t                 : LONGCARD;
BEGIN
  OK := TRUE;
  t  := StrToCI(S,Base,OK);
  IF S[0] = '-' THEN
    OK := FALSE;
  END; (*IF*)
  RETURN t;
END StrToCard;

PROCEDURE FindSubStr(Source,Pattern: ARRAY OF CHAR;VAR pos:ARRAY OF PosLen) : BOOLEAN;

   PROCEDURE Rmatch(i,j,p:CARDINAL):BOOLEAN;
   VAR
     matched        : BOOLEAN;
     k              : CARDINAL;
   BEGIN
     LOOP
       IF ((i>HIGH(Source)) OR (Source[i]=0C)) & ((j>HIGH(Pattern)) OR (Pattern[j]=0C)) THEN
         RETURN TRUE;
       ELSIF ((j > HIGH(Pattern)) OR (Pattern[j] = 0C)) THEN
         RETURN FALSE;
       ELSIF (Pattern[j]='*') THEN
         k :=i;
         IF  ((j=HIGH(Pattern)) OR (Pattern[j+1]=0C)) THEN
           IF p<=HIGH(pos) THEN
              pos[p].Pos := i;
              WHILE (k#HIGH(Source)) & (Source[k+1]#0C) DO
                INC(k);
              END; (*WHILE*)
              pos[p].Len := 1+k-i;
           END; (*IF*)
           RETURN TRUE;
         ELSE
           LOOP
             matched := Rmatch(k,j+1,p+1);
             IF matched OR (k > HIGH(Source)) OR (Source[k] = 0C) THEN
               IF matched AND (p<=HIGH(pos)) THEN
                  pos[p].Pos := i;
                  pos[p].Len := k-i;
               END; (*IF*)
               RETURN matched;
             END;
             INC(k);
           END; (*LOOP*)
         END; (*IF*)
       ELSIF (Pattern[j] # '?') & (CAP(Pattern[j]) # CAP(Source[i])) THEN
         RETURN FALSE;
       ELSE
         IF Pattern[j]='?' THEN
            pos[p].Pos:=i;
            pos[p].Len:=1;
            INC(p);
         END; (*IF*)
         INC(i);
         INC(j);
       END; (*IF*)
     END; (*LOOP*)
   END Rmatch;

BEGIN
  IF Pattern[0]=0C THEN
    RETURN TRUE;
  ELSE
    RETURN Rmatch(0,0,0);
  END;
END FindSubStr;

PROCEDURE StrToC(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN;
VAR
  n                 : CARDINAL;
  c                 : CHAR;
BEGIN
  n := 0;
  LOOP
    IF n > HIGH(D) THEN
      RETURN FALSE;
    END; (*IF*)
    IF n > HIGH(S) THEN
      c := 0C;
    ELSE
      c := S[n];
    END; (*IF*)
    D[n] := c;
    IF c = 0C THEN
      RETURN TRUE;
    END; (*IF*)
    INC(n);
  END; (*LOOP*)
END StrToC;

PROCEDURE StrToPas(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN;
VAR
  n                 : CARDINAL;
  c                 : CHAR;
BEGIN
  n := 1;
  LOOP
    IF n > HIGH(D) THEN
      D[0] := 0C;
      RETURN FALSE;
    END; (*IF*)
    IF n > SIZE(S) THEN
      c := 0C;
    ELSE
      c := S[n-1];
    END; (*IF*)
    IF c = 0C THEN
      D[0] := CHAR(n-1);
      RETURN TRUE;
    END; (*IF*)
    D[n] := c;
    INC(n);
  END; (*LOOP*)
END StrToPas;

END WinStr.