Topspeed_JPI/TS-V3/SRC/WINSTR.LST

Listing:

    1  (* Release 3.00 *)
    2  
    3  (* Copyright (C) 1987..1991 Jensen & Partners International *)
    4  
    5  (*# call(o_a_copy => off, near_call=>off, ds_eq_ss=>off) *)
    6  (*# call(seg_name => null) *)
    7  (*# module(implementation=>off, init_code=>off) *)
    8  (*# data(seg_name => null, near_ptr=>off) *)
    9  (*# check(stack=>off,
   10            index=>off,
   11            range=>off,
   12            overflow=>off,
   13            nil_ptr=>off) *)
   14  
   15  IMPLEMENTATION MODULE WinStr;
   16  
   17  IMPORT Lib, MATHLIB, SYSTEM;
   18  
   19  PROCEDURE Compare(S1,S2:ARRAY OF CHAR):INTEGER;                    IN FarAsm;
*****                                   ^ not supported yet
*****                                                                        ^ not supported yet
   20  PROCEDURE Length(S:ARRAY OF CHAR):CARDINAL;                        IN FarAsm;
*****                              ^ not supported yet
*****                                                                        ^ not supported yet
   21  PROCEDURE Concat(VAR R:ARRAY OF CHAR;S1,S2:ARRAY OF CHAR);         IN FarAsm;
*****                                  ^ not supported yet
*****                                                      ^ not supported yet
*****                                                                        ^ not supported yet
   22  PROCEDURE Append(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR);             IN FarAsm;
*****                                  ^ not supported yet
*****                                                  ^ not supported yet
*****                                                                        ^ not supported yet
   23  PROCEDURE Copy(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR);               IN FarAsm;
*****                                ^ not supported yet
*****                                                ^ not supported yet
*****                                                                        ^ not supported yet
   24  PROCEDURE CharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL;                IN FarAsm;
*****                               ^ not supported yet
*****                                                                        ^ not supported yet
   25  PROCEDURE Caps(VAR S:ARRAY OF CHAR);                               IN FarAsm;
*****                                ^ not supported yet
*****                                                                        ^ not supported yet
   26  PROCEDURE Lows(VAR S:ARRAY OF CHAR);                               IN FarAsm;
*****                                ^ not supported yet
*****                                                                        ^ not supported yet
   27  PROCEDURE Slice(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR;P,L:CARDINAL); IN FarAsm;
*****                                 ^ not supported yet
*****                                                 ^ not supported yet
*****                                                                        ^ not supported yet
   28  PROCEDURE Pos(S,P:ARRAY OF CHAR):CARDINAL;                         IN FarAsm;
*****                             ^ not supported yet
*****                                                                        ^ not supported yet
   29  PROCEDURE NextPos(S,P:ARRAY OF CHAR;Place:CARDINAL):CARDINAL;      IN FarAsm;
*****                                 ^ not supported yet
*****                                                                        ^ not supported yet
   30  PROCEDURE RCharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL;               IN FarAsm;
*****                                ^ not supported yet
*****                                                                        ^ not supported yet
   31  
   32  PROCEDURE Prepend(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR);
*****                                    ^ not supported yet
*****                                                     ^ not supported yet
   33  VAR
   34    ShiftLen          : CARDINAL;
   35    S1Len,S2Len       : CARDINAL;
   36  BEGIN
   37    S1Len:=Length(S1)+1;
*****           ^ not supported yet
*****                  ^ not supported yet
   38    S2Len:=Length(S2);
*****           ^ not supported yet
*****                  ^ not supported yet
   39    IF S2Len > HIGH(S1) THEN
*****               ^ undeclared identifier
*****                    ^ not supported yet
   40      Copy(S1,S2);
*****      ^ not supported yet
*****           ^ not supported yet
*****              ^ not supported yet
   41      RETURN;
   42    END;
   43    ShiftLen := HIGH(S1) - S2Len + 1;
*****                ^ undeclared identifier
*****                     ^ not supported yet
   44    IF ShiftLen > S1Len THEN
   45      ShiftLen := S1Len
   46    END; (*IF*)
   47    Lib.Move(ADR(S1),ADR(S1[S2Len]),ShiftLen);
*****    ^ not supported yet
*****        ^ not supported yet
*****             ^ undeclared identifier
*****                 ^ not supported yet
*****                     ^ undeclared identifier
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                            ^ not supported yet
   48    Lib.Move(ADR(S2),ADR(S1),S2Len);
*****    ^ not supported yet
*****        ^ not supported yet
*****             ^ undeclared identifier
*****                 ^ not supported yet
*****                     ^ undeclared identifier
*****                         ^ not supported yet
*****                                  ^ not supported yet
   49  END Prepend;
*****      ^ not supported yet
   50  
   51  PROCEDURE Subst(VAR S1:ARRAY OF CHAR;Target:ARRAY OF CHAR;New:ARRAY OF CHAR);
*****                                  ^ not supported yet
*****                                                       ^ not supported yet
*****                                                                         ^ not supported yet
   52  VAR
   53    TargetPos,
   54    TargetLen         : CARDINAL;
   55  BEGIN
   56    TargetPos := Pos(S1,Target);
*****                 ^ not supported yet
*****                     ^ not supported yet
*****                        ^ not supported yet
   57    IF TargetPos = MAX(CARDINAL) THEN
*****                   ^ undeclared identifier
*****                               ^ not supported yet
   58      RETURN
   59    END; (*IF*)
   60    TargetLen := Length(Target);
*****                 ^ not supported yet
*****                        ^ not supported yet
   61    Lib.Move(ADR(S1[TargetPos+TargetLen]),ADR(S1[TargetPos]),Length(S1)-TargetLen-TargetPos+1);
*****    ^ not supported yet
*****        ^ not supported yet
*****             ^ undeclared identifier
*****                 ^ not supported yet
*****                                       ^ not supported yet
*****                                          ^ undeclared identifier
*****                                              ^ not supported yet
*****                                                          ^ not supported yet
*****                                                             ^ not supported yet
*****                                                                    ^ not supported yet
*****                                                                                             ^ not supported yet
   62    Insert(S1,New,TargetPos);
*****    ^ undeclared identifier
*****           ^ not supported yet
*****              ^ not supported yet
*****                           ^ not supported yet
   63  END Subst;
*****      ^ not supported yet
   64  
   65  PROCEDURE Delete(VAR S:ARRAY OF CHAR;P,L:CARDINAL);
*****                                  ^ not supported yet
   66  VAR
   67    Len,i             : CARDINAL;
   68  BEGIN
   69    IF L # 0 THEN
   70      Len := Length(S);
*****             ^ not supported yet
*****                    ^ not supported yet
   71      IF P < Len THEN
   72        IF L < Len - P THEN
   73          i := P+L;
   74          REPEAT
   75            S[P] := S[i];
*****            ^ not supported yet
*****               ^ not supported yet
*****                    ^ not supported yet
*****                       ^ not supported yet
   76            INC(P);
*****            ^ undeclared identifier
*****                 ^ not supported yet
   77            INC(i);
*****            ^ undeclared identifier
*****                 ^ not supported yet
   78          UNTIL i=Len;
   79        END; (*IF*)
   80        S[P] := 0C;
*****        ^ not supported yet
*****           ^ not supported yet
   81      END; (*IF*)
   82    END; (*IF*)
   83  END Delete;
*****      ^ not supported yet
   84  
   85  PROCEDURE Insert(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR;P:CARDINAL);
*****                                   ^ not supported yet
*****                                                    ^ not supported yet
   86  VAR
   87    I,J,C,L           : CARDINAL;
   88  BEGIN
   89    L := Length(S1);
*****         ^ not supported yet
*****                ^ not supported yet
   90    I := Length(S2);
*****         ^ not supported yet
*****                ^ not supported yet
   91    C := L;
   92    IF C < P THEN
   93      P := C;
   94    END; (*IF*)
   95    DEC(C,P);
*****    ^ undeclared identifier
*****           ^ not supported yet
   96    FOR J := C TO 0 BY -1 DO
   97      IF (J+P+I <= HIGH(S1)) THEN
*****                   ^ undeclared identifier
*****                        ^ not supported yet
   98        S1[J+P+I] := S1[J+P];
*****        ^ not supported yet
*****                ^ not supported yet
*****                     ^ not supported yet
*****                           ^ not supported yet
   99      END; (*IF*)
  100    END; (*FOR*)
  101    J := 0;
  102    WHILE (J<I) & (P+J <= HIGH(S1)) DO
*****                          ^ undeclared identifier
*****                               ^ not supported yet
  103      S1[P+J] := S2[J];
*****      ^ not supported yet
*****            ^ not supported yet
*****                 ^ not supported yet
*****                     ^ not supported yet
  104      INC(J);
*****      ^ undeclared identifier
*****           ^ not supported yet
  105    END; (*WHILE*)
  106  END Insert;
*****      ^ not supported yet
  107  
  108  PROCEDURE Item(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR;T:CHARSET;N:CARDINAL);
*****                                ^ not supported yet
*****                                                ^ not supported yet
*****                                                       ^ undeclared identifier
  109  VAR
  110    I,J               : CARDINAL;
  111    HR,L              : CARDINAL;
  112  BEGIN
  113    I := 0;
  114    L := Length(S);
*****         ^ not supported yet
*****                ^ not supported yet
  115    LOOP
  116      WHILE (I < L) & (S[I] IN T) DO
*****                       ^ not supported yet
*****                          ^ not supported yet
*****                               ^ not supported yet
  117        INC(I);
*****        ^ undeclared identifier
*****             ^ not supported yet
  118      END; (*WHILE*)
  119      IF (N = 0) OR (I = L) THEN
  120        EXIT
  121      END; (*IF*)
  122      DEC(N);
*****      ^ undeclared identifier
*****           ^ not supported yet
  123      WHILE (I < L) & ~(S[I] IN T) DO
*****                        ^ not supported yet
*****                           ^ not supported yet
*****                                ^ not supported yet
  124        INC(I);
*****        ^ undeclared identifier
*****             ^ not supported yet
  125      END; (*WHILE*)
  126    END; (*LOOP*)
  127    J  := 0;
  128    HR := HIGH(R);
*****          ^ undeclared identifier
*****               ^ not supported yet
  129    WHILE (I < L) & ~(S[I] IN T) & (J <= HR) DO
*****                      ^ not supported yet
*****                         ^ not supported yet
*****                              ^ not supported yet
  130      R[J] := S[I];
*****      ^ not supported yet
*****         ^ not supported yet
*****              ^ not supported yet
*****                 ^ not supported yet
  131      INC(I);
*****      ^ undeclared identifier
*****           ^ not supported yet
  132      INC(J);
*****      ^ undeclared identifier
*****           ^ not supported yet
  133    END; (*WHILE*)
  134    IF (J <= HR) THEN
  135      R[J] := 0C;
*****      ^ not supported yet
*****         ^ not supported yet
  136    END; (*IF*)
  137  END Item;
*****      ^ not supported yet
  138  
  139  PROCEDURE ItemS(VAR R:ARRAY OF CHAR;S,T:ARRAY OF CHAR;N:CARDINAL);
*****                                 ^ not supported yet
*****                                                   ^ not supported yet
  140  VAR
  141    CS                : CHARSET;
*****                        ^ undeclared identifier
  142    I                 : CARDINAL;
  143  BEGIN
  144    I  := Length(T);
*****          ^ not supported yet
*****                 ^ not supported yet
  145    CS := CHARSET{};
*****    ^ not supported yet
*****          ^ undeclared identifier
  146    WHILE I > 0 DO
  147      DEC(I);
  148      INCL(CS,T[I]);
  149    END;
  150    Item(R,S,CS,N);
  151  END ItemS;
  152  
  153  PROCEDURE Match(Source,Pattern:ARRAY OF CHAR):BOOLEAN;
  154  
  155    PROCEDURE Rmatch(VAR s:ARRAY OF CHAR;i:CARDINAL;VAR p:ARRAY OF CHAR;j:CARDINAL):BOOLEAN;
  156    VAR
  157      matched        : BOOLEAN;
  158      k              : CARDINAL;
  159    BEGIN
  160      IF p[0]=0C THEN
  161        RETURN TRUE;
  162      END; (*IF*)
  163      LOOP
  164        IF ((i>HIGH(s)) OR (s[i]=0C)) & ((j>HIGH(p)) OR (p[j]=0C)) THEN
  165          RETURN TRUE;
  166        ELSIF ((j>HIGH(p)) OR (p[j]=0C)) THEN
  167          RETURN FALSE;
  168        ELSIF (p[j]='*') THEN
  169          k :=i;
  170          IF ((j=HIGH(p)) OR (p[j+1]=0C)) THEN
  171            RETURN TRUE;
  172          ELSE
  173            LOOP
  174              matched := Rmatch(s,k,p,j+1);
  175              IF matched OR (k>HIGH(s)) OR (s[k]=0C) THEN
  176                RETURN matched;
  177              END; (*IF*)
  178              INC(k);
  179            END; (*LOOP*)
  180          END; (*IF*)
  181        ELSIF ((p[j]='?') & (s[i]#0C)) OR (CAP(p[j])=CAP(s[i])) THEN
  182          INC(i);
  183          INC(j);
  184        ELSE
  185          RETURN FALSE;
  186        END; (*IF*)
  187      END; (*LOOP*)
  188    END Rmatch;
  189  
  190  BEGIN (*Match*)
  191    RETURN Rmatch(Source,0,Pattern,0);
  192  END Match;
  193  
  194  TYPE
  195    ConvIntType = ARRAY ['0'..'F'] OF SHORTCARD;
  196    BA          = ARRAY[0..1] OF SHORTCARD;
  197  
  198  CONST
  199    ConvStr = '0123456789ABCDEF';
  200    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 );
  201    Div     = BA(0,4);
  202  
  203  PROCEDURE CheckBase(VAR b:CARDINAL);
  204  BEGIN
  205    IF b < 2  THEN
  206      b := 2;
  207    END; (*IF*)
  208    IF b > 16 THEN
  209      b := 16;
  210    END; (*IF*)
  211  END CheckBase;
  212  
  213  PROCEDURE Reverse(VAR s: ARRAY OF CHAR; l,h: CARDINAL);
  214  VAR
  215    T                 : CHAR;
  216  BEGIN
  217    WHILE l < h DO
  218      T := s[l];
  219      s[l] := s[h];
  220      s[h] := T;
  221      INC(l);
  222      DEC(h);
  223    END; (*WHILE*)
  224  END Reverse;
  225  
  226  PROCEDURE IntToStr(V:LONGINT;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN);
  227  VAR
  228    i,l               : CARDINAL;
  229    b                 : LONGCARD;
  230  BEGIN
  231    OK := TRUE;
  232    l := HIGH(S);
  233    CheckBase(Base);
  234    b := VAL(LONGCARD,Base);
  235    IF V < 0 THEN
  236      S[0] := '-';
  237      i := 1;
  238      V := -V;
  239    ELSE
  240      i := 0;
  241    END; (*IF*)
  242    LOOP
  243      IF i > l THEN
  244        OK := FALSE;
  245        EXIT;
  246      END; (*IF*)
  247      S[i] := ConvStr[CARDINAL(LONGCARD(V) MOD b)];
  248      INC(i);
  249      V := LONGCARD(V) DIV b;
  250      IF V = 0 THEN
  251        EXIT;
  252      END; (*IF*)
  253    END; (*LOOP*)
  254    IF i <= l THEN
  255      S[i] := 0C;
  256    END; (*IF*)
  257    IF S[0] < '0' THEN
  258      Reverse(S,1,i-1);
  259    ELSE
  260      Reverse(S,0,i-1);
  261    END; (*IF*)
  262  END IntToStr;
  263  
  264  PROCEDURE CardToStr(V:LONGCARD;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN);
  265  VAR
  266    i,l               : CARDINAL;
  267    b                 : LONGCARD;
  268  BEGIN
  269    OK := TRUE;
  270    l  := HIGH(S);
  271    CheckBase(Base);
  272    b := VAL(LONGCARD,Base);
  273    i := 0;
  274    LOOP
  275      IF i > l THEN
  276        OK := FALSE;
  277        EXIT;
  278      END; (*IF*)
  279      S[i] := ConvStr[CARDINAL(V MOD b)];
  280      INC(i);
  281      V := V DIV b;
  282      IF V = 0 THEN
  283        EXIT;
  284      END; (*IF*)
  285    END; (*LOOP*)
  286    IF i <= l THEN
  287      S[i] := 0C;
  288    END; (*IF*)
  289    Reverse(S,0,i-1);
  290  END CardToStr;
  291  
  292  (*# save,call(o_a_copy=>off)*)
  293  PROCEDURE StrToCI(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD;
  294  VAR
  295    i,l               : CARDINAL;
  296    b,t,y             : LONGCARD;
  297    c                 : CHAR;
  298    x                 : SHORTCARD;
  299  BEGIN
  300    CheckBase(Base);
  301    b := VAL(LONGCARD,Base);
  302    i := 0;
  303    l := HIGH(S);
  304    IF (S[0] = '-') OR (S[0] = '+') THEN
  305      i := 1;
  306    END; (*IF*)
  307    t := 0;
  308    IF S[i] = 0C THEN
  309      OK := FALSE;
  310    END; (*IF*)
  311    WHILE (i <= l) & (S[i] # 0C) DO
  312      c := S[i];
  313      IF (c < '0') OR (c > 'F') THEN
  314        OK := FALSE;
  315        RETURN t;
  316      END; (*IF*)
  317      x := ConvInt[c];
  318      IF (x > SHORTCARD(b)-1) OR (t > (MAX(LONGCARD)-LONGCARD(x)) DIV b) THEN
  319        OK := FALSE;
  320      END; (*IF*)
  321      t := t*b+VAL(LONGCARD,x);
  322      INC(i);
  323    END; (*WHILE*)
  324    RETURN t;
  325  END StrToCI;
  326  
  327  PROCEDURE StrToInt(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGINT;
  328  VAR
  329    t                 : LONGCARD;
  330  BEGIN
  331    OK := TRUE;
  332    t  := StrToCI(S,Base,OK);
  333    IF t > 7FFFFFFFH THEN
  334      OK := FALSE;
  335    END; (*IF*)
  336    IF S[0] = '-' THEN
  337      RETURN -LONGINT(t);
  338    ELSE
  339      RETURN LONGINT(t);
  340    END; (*IF*)
  341  END StrToInt;
  342  
  343  PROCEDURE StrToCard(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD;
  344  VAR
  345    t                 : LONGCARD;
  346  BEGIN
  347    OK := TRUE;
  348    t  := StrToCI(S,Base,OK);
  349    IF S[0] = '-' THEN
  350      OK := FALSE;
  351    END; (*IF*)
  352    RETURN t;
  353  END StrToCard;
  354  
  355  PROCEDURE FindSubStr(Source,Pattern: ARRAY OF CHAR;VAR pos:ARRAY OF PosLen) : BOOLEAN;
  356  
  357     PROCEDURE Rmatch(i,j,p:CARDINAL):BOOLEAN;
  358     VAR
  359       matched        : BOOLEAN;
  360       k              : CARDINAL;
  361     BEGIN
  362       LOOP
  363         IF ((i>HIGH(Source)) OR (Source[i]=0C)) & ((j>HIGH(Pattern)) OR (Pattern[j]=0C)) THEN
  364           RETURN TRUE;
  365         ELSIF ((j > HIGH(Pattern)) OR (Pattern[j] = 0C)) THEN
  366           RETURN FALSE;
  367         ELSIF (Pattern[j]='*') THEN
  368           k :=i;
  369           IF  ((j=HIGH(Pattern)) OR (Pattern[j+1]=0C)) THEN
  370             IF p<=HIGH(pos) THEN
  371                pos[p].Pos := i;
  372                WHILE (k#HIGH(Source)) & (Source[k+1]#0C) DO
  373                  INC(k);
  374                END; (*WHILE*)
  375                pos[p].Len := 1+k-i;
  376             END; (*IF*)
  377             RETURN TRUE;
  378           ELSE
  379             LOOP
  380               matched := Rmatch(k,j+1,p+1);
  381               IF matched OR (k > HIGH(Source)) OR (Source[k] = 0C) THEN
  382                 IF matched AND (p<=HIGH(pos)) THEN
  383                    pos[p].Pos := i;
  384                    pos[p].Len := k-i;
  385                 END; (*IF*)
  386                 RETURN matched;
  387               END;
  388               INC(k);
  389             END; (*LOOP*)
  390           END; (*IF*)
  391         ELSIF (Pattern[j] # '?') & (CAP(Pattern[j]) # CAP(Source[i])) THEN
  392           RETURN FALSE;
  393         ELSE
  394           IF Pattern[j]='?' THEN
  395              pos[p].Pos:=i;
  396              pos[p].Len:=1;
  397              INC(p);
  398           END; (*IF*)
  399           INC(i);
  400           INC(j);
  401         END; (*IF*)
  402       END; (*LOOP*)
  403     END Rmatch;
  404  
  405  BEGIN
  406    IF Pattern[0]=0C THEN
  407      RETURN TRUE;
  408    ELSE
  409      RETURN Rmatch(0,0,0);
  410    END;
  411  END FindSubStr;
  412  
  413  PROCEDURE StrToC(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN;
  414  VAR
  415    n                 : CARDINAL;
  416    c                 : CHAR;
  417  BEGIN
  418    n := 0;
  419    LOOP
  420      IF n > HIGH(D) THEN
  421        RETURN FALSE;
  422      END; (*IF*)
  423      IF n > HIGH(S) THEN
  424        c := 0C;
  425      ELSE
  426        c := S[n];
  427      END; (*IF*)
  428      D[n] := c;
  429      IF c = 0C THEN
  430        RETURN TRUE;
  431      END; (*IF*)
  432      INC(n);
  433    END; (*LOOP*)
  434  END StrToC;
  435  
  436  PROCEDURE StrToPas(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN;
  437  VAR
  438    n                 : CARDINAL;
  439    c                 : CHAR;
  440  BEGIN
  441    n := 1;
  442    LOOP
  443      IF n > HIGH(D) THEN
  444        D[0] := 0C;
  445        RETURN FALSE;
  446      END; (*IF*)
  447      IF n > SIZE(S) THEN
  448        c := 0C;
  449      ELSE
  450        c := S[n-1];
  451      END; (*IF*)
  452      IF c = 0C THEN
  453        D[0] := CHAR(n-1);
  454        RETURN TRUE;
  455      END; (*IF*)
  456      D[n] := c;
  457      INC(n);
  458    END; (*LOOP*)
  459  END StrToPas;
  460  
  461  END WinStr.

  160 errors