Topspeed_JPI/TS-V3/SAVE/WINSTR.LST

Listing:

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

  160 errors