Topspeed_JPI/TS-V3/SRC/STR.LST

Listing:

    1  (* Release 3.10 *)
    2  (*-------------------------------------------------------------------------*
    3  *                                                                          *
    4  *  STR.MOD - String functions                                              *
    5  *                                                                          *
    6  *  COPYRIGHT (C) 1987..1992 Clarion Software Corporation.                  *
    7  *  All Rights Reserved                                                     *
    8  *                                                                          *
    9  *--------------------------------------------------------------------------*)
   10  
   11  (*%F _fdata *)
   12  (*# call(seg_name => null) *)
   13  (*%E *)
   14  (*%T _fdata *)
   15  (*# call(seg_name => STR) *)
   16  (*# data(seg_name => null) *)
   17  (*%E *)
   18  (*# module(implementation=>off) *)
   19  (*# call(o_a_copy => off) *)
   20  (*# check(stack=>off,
   21            index=>off,
   22            range=>off,
   23            overflow=>off,
   24            nil_ptr=>off) *)
   25  
   26  IMPLEMENTATION MODULE Str;
   27  
   28  
   29  IMPORT Lib, MATHLIB, SYSTEM;
   30  
   31  CONST
   32    StrictRealConv = FALSE ;
   33  
   34  (*# save *)
   35  (*%T _DLL *)
   36  (*# call(seg_name=>STRDLL) *)
   37  (*%E *)
   38  PROCEDURE Caps(VAR S: ARRAY OF CHAR); IN AsmLib;
*****                                 ^ not supported yet
*****                                           ^ not supported yet
   39  PROCEDURE Lows(VAR S: ARRAY OF CHAR); IN AsmLib;
*****                                 ^ not supported yet
*****                                           ^ not supported yet
   40  PROCEDURE Compare(S1,S2: ARRAY OF CHAR) : INTEGER; IN AsmLib;
*****                                    ^ not supported yet
*****                                                        ^ not supported yet
   41  PROCEDURE Length(S : ARRAY OF CHAR) : CARDINAL; IN AsmLib;
*****                                ^ not supported yet
*****                                                     ^ not supported yet
   42  PROCEDURE Concat(VAR R: ARRAY OF CHAR; S1,S2: ARRAY OF CHAR); IN AsmLib;
*****                                   ^ not supported yet
*****                                                         ^ not supported yet
*****                                                                   ^ not supported yet
   43  PROCEDURE Append(VAR R: ARRAY OF CHAR; S: ARRAY OF CHAR); IN AsmLib;
*****                                   ^ not supported yet
*****                                                     ^ not supported yet
*****                                                               ^ not supported yet
   44  PROCEDURE Copy  (VAR R: ARRAY OF CHAR; S: ARRAY OF CHAR); IN AsmLib;
*****                                   ^ not supported yet
*****                                                     ^ not supported yet
*****                                                               ^ not supported yet
   45  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
   46  PROCEDURE Pos(S,P: ARRAY OF CHAR) : CARDINAL; IN AsmLib;
*****                              ^ not supported yet
*****                                                   ^ not supported yet
   47  PROCEDURE NextPos(S,P: ARRAY OF CHAR; Place: CARDINAL) : CARDINAL; IN AsmLib;
*****                                  ^ not supported yet
*****                                                                        ^ not supported yet
   48  PROCEDURE CharPos(S: ARRAY OF CHAR; C: CHAR) : CARDINAL; IN AsmLib;
*****                                ^ not supported yet
*****                                                              ^ not supported yet
   49  PROCEDURE RCharPos(S: ARRAY OF CHAR; C: CHAR) : CARDINAL; IN AsmLib;
*****                                 ^ not supported yet
*****                                                               ^ not supported yet
   50    PROCEDURE Same(Stg,Pattern:ARRAY OF CHAR):BOOLEAN; IN AsmLib;
*****                                        ^ not supported yet
*****                                                          ^ not supported yet
   51    PROCEDURE Count(Stg:ARRAY OF CHAR;Ch:CHAR):CARDINAL; IN AsmLib;
*****                                 ^ not supported yet
*****                                                            ^ not supported yet
   52  (*# restore *)
   53  
   54  PROCEDURE Prepend(VAR S1: ARRAY OF CHAR; S2: ARRAY OF CHAR);
*****                                     ^ not supported yet
*****                                                        ^ not supported yet
   55  
   56  VAR
   57      ShiftLen: CARDINAL;
   58      S1Len, S2Len: CARDINAL;
   59  BEGIN
   60      S1Len:=Length(S1)+1;
*****             ^ not supported yet
*****                    ^ not supported yet
   61      S2Len:=Length(S2);
*****             ^ not supported yet
*****                    ^ not supported yet
   62      IF S2Len > HIGH(S1) THEN
*****                 ^ undeclared identifier
*****                      ^ not supported yet
   63          Copy(S1, S2);
*****          ^ not supported yet
*****               ^ not supported yet
*****                   ^ not supported yet
   64          RETURN;
   65      END;
   66      ShiftLen:=HIGH(S1)-S2Len + 1;
*****                ^ undeclared identifier
*****                     ^ not supported yet
   67      IF ShiftLen > S1Len THEN ShiftLen:=S1Len END;
   68      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
   69      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
   70  END Prepend;
*****      ^ not supported yet
   71  
   72  PROCEDURE Subst(VAR S1: ARRAY OF CHAR; Target: ARRAY OF CHAR; New: ARRAY OF CHAR);
*****                                   ^ not supported yet
*****                                                          ^ not supported yet
*****                                                                              ^ not supported yet
   73  
   74  VAR
   75      TargetPos, TargetLen: CARDINAL;
   76  BEGIN
   77      TargetPos:=Pos(S1, Target);
*****                 ^ not supported yet
*****                     ^ not supported yet
*****                         ^ not supported yet
   78      IF TargetPos = MAX(CARDINAL) THEN RETURN END;
*****                     ^ undeclared identifier
*****                                 ^ not supported yet
   79      TargetLen:=Length(Target);
*****                 ^ not supported yet
*****                        ^ not supported yet
   80      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
   81      Insert(S1, New, TargetPos);
*****      ^ undeclared identifier
*****             ^ not supported yet
*****                 ^ not supported yet
*****                               ^ not supported yet
   82  END Subst;
*****      ^ not supported yet
   83  
   84  PROCEDURE Delete(VAR S: ARRAY OF CHAR; P,L: CARDINAL);
*****                                   ^ not supported yet
   85  VAR
   86    Le,I : CARDINAL;
   87  BEGIN
   88    IF L # 0 THEN
   89      Le := Length(S);
*****            ^ not supported yet
*****                   ^ not supported yet
   90      IF P < Le THEN
   91        IF L < Le - P THEN
   92          I := P+L;
   93          REPEAT
   94            S[P] := S[I];
*****            ^ not supported yet
*****               ^ not supported yet
*****                    ^ not supported yet
*****                       ^ not supported yet
   95            INC(P);
*****            ^ undeclared identifier
*****                 ^ not supported yet
   96            INC(I);
*****            ^ undeclared identifier
*****                 ^ not supported yet
   97          UNTIL I=Le;
   98        END;
   99        S[P] := CHR(0);
*****        ^ not supported yet
*****           ^ not supported yet
*****                ^ undeclared identifier
*****                     ^ not supported yet
  100      END;
  101    END;
  102  END Delete;
*****      ^ not supported yet
  103  
  104  PROCEDURE Insert(VAR S1: ARRAY OF CHAR; S2: ARRAY OF CHAR; P: CARDINAL);
*****                                    ^ not supported yet
*****                                                       ^ not supported yet
  105  VAR
  106    I,J,C,L : CARDINAL;
  107  BEGIN
  108    L := Length(S1);
*****         ^ not supported yet
*****                ^ not supported yet
  109    I := Length(S2);
*****         ^ not supported yet
*****                ^ not supported yet
  110    C := L;
  111    IF C < P THEN P := C END;
  112    DEC(C,P);
*****    ^ undeclared identifier
*****           ^ not supported yet
  113    FOR J := C TO 0 BY -1 DO
  114      IF (J+P+I <= HIGH(S1)) THEN S1[J+P+I] := S1[J+P]; END;
*****                   ^ undeclared identifier
*****                        ^ not supported yet
*****                                  ^ not supported yet
*****                                          ^ not supported yet
*****                                               ^ not supported yet
*****                                                     ^ not supported yet
  115    END;
  116    J := 0;
  117    WHILE (J<I) AND (P+J <= HIGH(S1)) DO
*****                            ^ undeclared identifier
*****                                 ^ not supported yet
  118      S1[P+J] := S2[J];
*****      ^ not supported yet
*****            ^ not supported yet
*****                 ^ not supported yet
*****                     ^ not supported yet
  119      INC(J);
*****      ^ undeclared identifier
*****           ^ not supported yet
  120    END;
  121  END Insert;
*****      ^ not supported yet
  122  
  123  PROCEDURE Item(VAR R: ARRAY OF CHAR; S: ARRAY OF CHAR; T: CHARSET; N: CARDINAL);
*****                                 ^ not supported yet
*****                                                   ^ not supported yet
*****                                                            ^ undeclared identifier
  124  VAR
  125    I,J  : CARDINAL;
  126    HR,L : CARDINAL;
  127  BEGIN
  128    I := 0;
  129    L := Length(S);
*****         ^ not supported yet
*****                ^ not supported yet
  130    LOOP
  131      WHILE (I < L) AND (S[I] IN T) DO INC(I); END; (* Skip separators *)
*****                         ^ not supported yet
*****                            ^ not supported yet
*****                                 ^ not supported yet
*****                                       ^ undeclared identifier
*****                                            ^ not supported yet
  132      IF (N = 0) OR (I = L) THEN EXIT END;
  133      DEC(N);
*****      ^ undeclared identifier
*****           ^ not supported yet
  134      WHILE (I < L) AND NOT (S[I] IN T) DO INC(I); END; (* Skip item *)
*****                             ^ not supported yet
*****                                ^ not supported yet
*****                                     ^ not supported yet
*****                                           ^ undeclared identifier
*****                                                ^ not supported yet
  135    END;
  136    J  := 0;
  137    HR := HIGH(R);
*****          ^ undeclared identifier
*****               ^ not supported yet
  138    WHILE (I < L) AND NOT (S[I] IN T) AND (J <= HR) DO
*****                           ^ not supported yet
*****                              ^ not supported yet
*****                                   ^ not supported yet
  139      R[J] := S[I];
*****      ^ not supported yet
*****         ^ not supported yet
*****              ^ not supported yet
*****                 ^ not supported yet
  140      INC(I);
*****      ^ undeclared identifier
*****           ^ not supported yet
  141      INC(J);
*****      ^ undeclared identifier
*****           ^ not supported yet
  142    END;
  143    IF (J <= HR) THEN R[J] := CHR(0); END;
*****                      ^ not supported yet
*****                         ^ not supported yet
*****                              ^ undeclared identifier
*****                                   ^ not supported yet
  144  END Item;
*****      ^ not supported yet
  145  
  146  PROCEDURE ItemS(VAR R: ARRAY OF CHAR; S: ARRAY OF CHAR;
*****                                  ^ not supported yet
*****                                                    ^ not supported yet
  147                      T: ARRAY OF CHAR; N: CARDINAL);
*****                                  ^ not supported yet
  148  VAR
  149    CS : CHARSET;
*****         ^ undeclared identifier
  150    I  : CARDINAL;
  151  BEGIN
  152    I  := Length(T);
*****          ^ not supported yet
*****                 ^ not supported yet
  153    CS := CHARSET{};
*****    ^ not supported yet
*****          ^ undeclared identifier
  154    WHILE I>0 DO
  155      DEC(I);
  156      INCL(CS,T[I]);
  157    END;
  158    Item(R,S,CS,N);
  159  END ItemS;
  160  
  161  PROCEDURE Match(Source,Pattern: ARRAY OF CHAR) : BOOLEAN;
  162  (*
  163    returns TRUE if the string in Source matches the string in Pattern
  164    The pattern may contain any number of the wild characters '*' and '?'
  165    '?' matches any single character
  166    '*' matches any sequence of charcters (including a zero length sequence)
  167    EG '*m?t*i*' will match 'Automatic'
  168  *)
  169  
  170     PROCEDURE Rmatch(VAR s: ARRAY OF CHAR; i: CARDINAL;
  171                      VAR p: ARRAY OF CHAR; j: CARDINAL) : BOOLEAN;
  172  
  173     (* s = to be tested ,    i = position in s *)
  174     (* p = pattern to match ,j = position in p *)
  175  
  176     VAR
  177       matched: BOOLEAN;
  178       k      : CARDINAL;
  179     BEGIN
  180       IF p[0]=CHR(0) THEN RETURN TRUE END;
  181       LOOP
  182         IF ((i > HIGH(s)) OR (s[i] = CHR(0))) AND
  183            ((j > HIGH(p)) OR (p[j] = CHR(0))) THEN
  184           RETURN TRUE
  185         ELSIF ((j > HIGH(p)) OR (p[j] = CHR(0))) THEN
  186           RETURN FALSE
  187         ELSIF (p[j] = '*') THEN
  188           k :=i;
  189           IF ((j = HIGH(p)) OR (p[j+1] = CHR(0))) THEN
  190             RETURN TRUE
  191           ELSE
  192             LOOP
  193               matched := Rmatch(s,k,p,j+1);
  194               IF matched OR (k > HIGH(s)) OR (s[k] = CHR(0)) THEN
  195                 RETURN matched;
  196               END;
  197               INC(k);
  198             END;
  199           END
  200         ELSIF ((p[j]='?')AND(s[i]<>0C)) OR (CAP(p[j]) = CAP(s[i])) THEN
  201           INC(i);
  202           INC(j);
  203         ELSE
  204           RETURN FALSE;
  205         END;
  206       END;
  207     END Rmatch;
  208  
  209  BEGIN
  210    RETURN Rmatch(Source,0,Pattern,0);
  211  END Match;
  212  
  213  TYPE
  214    ConvIntType = ARRAY ['0'..'F'] OF SHORTCARD;
  215    BA          = ARRAY[0..1] OF SHORTCARD;
  216  
  217  CONST
  218    ConvStr = '0123456789ABCDEF';
  219    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 );
  220    Div     = BA(0,4);
  221  
  222  VAR FloatUse : BOOLEAN;
  223  
  224  (*%F _WINDOWS *)
  225    PROCEDURE FixRealToStr(V:LONGREAL;Precision:CARDINAL;VAR S:ARRAY OF CHAR;VAR OK:BOOLEAN);
  226      VAR
  227        j,i,l             : CARDINAL;
  228        X                 : MATHLIB.PackedBcd;
  229        c                 : CHAR;
  230        NoDigits          : BOOLEAN;
  231        Z                 : LONGREAL;
  232      BEGIN
  233        OK := TRUE;
  234        IF Precision > 17 THEN
  235          Precision := 17;
  236        END;
  237        l := HIGH(S);
  238        j := 0;
  239        NoDigits := TRUE;
  240        IF ABS(V)  >= 1.0E18 THEN
  241          S[0] := '?';
  242          INC(j);
  243          OK := FALSE;
  244        ELSE
  245          LOOP
  246            Z := V * MATHLIB.IntPow(10.0,Precision);
  247            IF ABS(Z)  < 1.0E18 THEN
  248              EXIT;
  249            END;
  250            DEC(Precision);
  251          END;
  252          X := MATHLIB.LongToBcd(Z);
  253          IF X[9]=80H THEN
  254            S[0] := '-';
  255            INC(j);
  256          END;
  257          FOR i := 17 TO 0 BY -1 DO
  258            c := CHAR(SHORTCARD('0') + (X[i DIV 2] >> Div[i MOD 2]) MOD 16);
  259            IF (c # '0') OR (i = Precision) OR NOT NoDigits THEN
  260              NoDigits := FALSE;
  261              IF j > l THEN
  262                OK := FALSE;
  263                RETURN;
  264              END;
  265              S[j] := c;
  266              INC(j);
  267            END;
  268            IF (i = Precision) AND (i # 0) THEN
  269              IF j > l THEN
  270                OK := FALSE;
  271                RETURN;
  272              END;
  273              S[j] := '.';
  274              INC(j);
  275            END;
  276          END;
  277        END;
  278        IF j <= l THEN
  279          S[j] := CHR(0);
  280        END;
  281      END FixRealToStr;
  282  (*%E *)
  283  
  284  (*%T _WINDOWS *)
  285    PROCEDURE FixRealToStr(V:LONGREAL;Precision:CARDINAL;VAR S:ARRAY OF CHAR;VAR OK:BOOLEAN);
  286      VAR
  287        j,l,m             : INTEGER;
  288        t                 : LONGREAL;
  289      BEGIN
  290        OK := TRUE;
  291        IF V = 0.0 THEN
  292          FOR j := 0 TO Precision + 1 DO
  293            S[j] := '0';
  294          END; (*FOR*)
  295          S[1] := '.';
  296          S[Precision+2] := 0C;
  297        ELSE
  298          S[0] := 0C;
  299          IF V < 0.0 THEN
  300            Copy(S,'-');
  301            V := -V;
  302          END; (*IF*)
  303          t := MATHLIB.IntPow(10.0,INTEGER(Precision));
  304          V := (V * t + 0.5) / t;
  305          m := TRUNC(MATHLIB.Log10(V));
  306          IF m <= 0 THEN
  307            l := 0;
  308            t := V;
  309          ELSE
  310            l := m;
  311            t := V / MATHLIB.IntPow(10.0,m);
  312          END; (*IF*)
  313          FOR j := l TO (-INTEGER(Precision)) BY -1 DO
  314            Append(S,CHR(TRUNC(t) + 48));
  315            IF j = 0 THEN
  316              Append(S,'.');
  317            END; (*IF*)
  318            t := (t - LONGREAL(TRUNC(t))) * 10.0;
  319          END; (*FOR*)
  320        END; (*IF*)
  321      END FixRealToStr;
  322  (*%E *)
  323  
  324  PROCEDURE CheckBase(VAR b: CARDINAL);
  325  BEGIN
  326    IF b < 2  THEN b := 2; END;
  327    IF b > 16 THEN b := 16; END;
  328  END CheckBase;
  329  
  330  PROCEDURE Reverse(VAR s: ARRAY OF CHAR; l,h: CARDINAL);
  331  VAR T : CHAR;
  332  BEGIN
  333    WHILE l < h DO
  334      T := s[l];
  335      s[l] := s[h];
  336      s[h] := T;
  337      INC(l);
  338      DEC(h);
  339    END;
  340  END Reverse;
  341  
  342  
  343  PROCEDURE IntToStr(V: LONGINT;VAR S: ARRAY OF CHAR; Base: CARDINAL; VAR OK: BOOLEAN);
  344  VAR
  345    i,l : CARDINAL;
  346    b   : LONGCARD;
  347  BEGIN
  348    OK := TRUE;
  349    l  := HIGH(S);
  350    CheckBase( Base );
  351    b := VAL( LONGCARD,Base );
  352    IF V < 0 THEN
  353      S[0] := '-';
  354      i := 1;
  355      V := -V;
  356    ELSIF FloatUse THEN
  357      S[0] := '+';
  358      i := 1;
  359    ELSE
  360      i := 0;
  361    END;
  362  
  363    LOOP
  364      IF i > l THEN OK := FALSE; EXIT; END;
  365      S[i] := ConvStr[CARDINAL( LONGCARD(V) MOD b )];
  366      INC(i);
  367      V := LONGCARD(V) DIV b;
  368      IF V = 0 THEN EXIT END;
  369    END;
  370    IF i <= l THEN S[i] := CHR(0); END;
  371    IF S[0] < '0' THEN
  372      Reverse( S,1,i-1 );
  373    ELSE
  374      Reverse( S,0,i-1 );
  375    END;
  376  END IntToStr;
  377  
  378  
  379  PROCEDURE CardToStr(V: LONGCARD; VAR S: ARRAY OF CHAR;
  380                      Base: CARDINAL; VAR OK: BOOLEAN);
  381  VAR
  382    i,l : CARDINAL;
  383    b   : LONGCARD;
  384  BEGIN
  385    OK := TRUE;
  386    l  := HIGH(S);
  387    CheckBase( Base );
  388    b := VAL( LONGCARD,Base );
  389    i := 0;
  390    LOOP
  391      IF i > l THEN OK := FALSE; EXIT END;
  392      S[i] := ConvStr[CARDINAL( V MOD b )];
  393      INC(i);
  394      V := V DIV b;
  395      IF V = 0 THEN EXIT END;
  396    END;
  397    IF i <= l THEN S[i] := CHR(0); END;
  398    Reverse( S,0,i-1 );
  399  END CardToStr;
  400  
  401  
  402  (*$V-*)
  403  PROCEDURE StrToCI(S: ARRAY OF CHAR; Base: CARDINAL; VAR OK: BOOLEAN) : LONGCARD;
  404  VAR
  405    i,l   : CARDINAL;
  406    b,t,y : LONGCARD;
  407    c     : CHAR;
  408    x     : SHORTCARD;
  409  BEGIN
  410    CheckBase( Base );
  411    b := VAL( LONGCARD,Base);
  412    i := 0;
  413    l := HIGH( S );
  414    IF (S[0] = '-') OR (S[0] = '+') THEN
  415      i := 1;
  416    END;
  417    t := 0;
  418    IF S[i] = CHR(0) THEN OK := FALSE; END;
  419    WHILE (i <= l) AND (S[i] # CHR(0)) DO
  420      c := S[i];
  421      IF (c < '0') OR (c > 'F') THEN
  422        OK := FALSE;
  423        RETURN t;
  424      END;
  425      x := ConvInt[c];
  426      IF (x > SHORTCARD(b)-1 ) OR (t > (MAX(LONGCARD)-LONGCARD(x)) DIV b) THEN OK := FALSE; END;
  427      t := t*b+VAL( LONGCARD,x );
  428      INC( i );
  429    END;
  430    RETURN t;
  431  END StrToCI;
  432  
  433  
  434  PROCEDURE StrToInt(S: ARRAY OF CHAR; Base: CARDINAL; VAR OK: BOOLEAN) : LONGINT;
  435  VAR t : LONGCARD;
  436  BEGIN
  437    OK := TRUE;
  438    t  := StrToCI( S,Base,OK);
  439    IF t > 7FFFFFFFH THEN OK := FALSE; END;
  440    IF S[0] = '-' THEN
  441      RETURN -LONGINT(t)
  442    ELSE
  443      RETURN LONGINT(t);
  444    END;
  445  END StrToInt;
  446  
  447  
  448  PROCEDURE StrToCard(S: ARRAY OF CHAR; Base: CARDINAL; VAR OK: BOOLEAN) : LONGCARD;
  449  VAR t : LONGCARD;
  450  BEGIN
  451    OK := TRUE;
  452    t  := StrToCI( S,Base,OK);
  453    IF S[0] = '-' THEN OK := FALSE; END;
  454    RETURN t;
  455  END StrToCard;
  456  
  457  
  458    PROCEDURE StrToReal(S: ARRAY OF CHAR; VAR OK: BOOLEAN) : LONGREAL;
  459      CONST
  460        Zero              = 0.0;
  461      VAR
  462        c,expsign         : CHAR;
  463        exp,after         : INTEGER;
  464        i                 : CARDINAL;
  465        res,p10           : LONGREAL;
  466        Neg               : BOOLEAN;
  467      BEGIN
  468        OK  := TRUE;
  469        c   := S[0];
  470        Neg := FALSE;
  471        IF c = '+' THEN
  472          i := 1;
  473        ELSIF c = '-' THEN
  474          i := 1;
  475          Neg := TRUE;
  476        ELSE
  477          i := 0;
  478        END; (*IF*)
  479        res := Zero;
  480        c := S[i];
  481        WHILE (c # '.') & (i <= HIGH(S)) DO
  482          IF (c > '9') OR (c < '0') THEN
  483            IF StrictRealConv & (c = 0C) THEN
  484              OK := FALSE;
  485              RETURN Zero;
  486            ELSE
  487              c := '.';
  488              DEC(i) ;
  489            END; (*IF*)
  490          ELSE
  491            res := res * 10.0 + VAL(LONGREAL,ORD(c) - ORD('0'));
  492            INC(i);
  493            c := S[i];
  494          END; (*IF*)
  495        END; (*WHILE*)
  496        after := 0;
  497        IF i >= HIGH(S) THEN
  498          IF StrictRealConv THEN
  499            OK := FALSE;
  500            RETURN Zero;
  501          ELSE
  502            RETURN res;
  503          END; (*IF*)
  504        END; (*IF*)
  505        INC(i);
  506        c := S[i];
  507        WHILE (i <= HIGH(S)) & (c # 0C) & (c # 'E') DO
  508          IF (c > '9') OR (c < '0') THEN
  509            OK := FALSE;
  510            RETURN Zero;
  511          END; (*IF*)
  512          res := res * 10.0 + VAL(LONGREAL,ORD(c) - ORD('0'));
  513          INC(i);
  514          INC(after);
  515          c := S[i];
  516        END; (*WHILE*)
  517        IF c = 'E' THEN
  518          INC(i);
  519          expsign := S[i];
  520          IF expsign = '+' THEN
  521            INC(i)
  522          ELSIF expsign = '-' THEN
  523            INC(i)
  524          END; (*IF*)
  525          c := S[i];
  526          exp := 0;
  527          WHILE (i <= HIGH(S)) & (c # 0C) DO
  528            IF (c > '9') OR (c < '0') THEN
  529              OK := FALSE;
  530              RETURN Zero;
  531            END; (*IF*)
  532            exp := exp * 8 + exp * 2 + INTEGER(ORD(c) - ORD('0'));
  533            INC(i);
  534            c := S[i];
  535          END; (*WHILE*)
  536          IF expsign = '-' THEN
  537            exp := -exp;
  538          END; (*IF*)
  539        ELSE
  540          exp := 0;
  541        END; (*IF*)
  542        exp := exp - after;
  543        p10 := 1.0;
  544        FOR i := 1 TO ABS(exp) DO
  545          p10 := p10 * 10.0;
  546        END; (*FOR*)
  547        IF Neg THEN
  548          res := - res;
  549        END; (*IF*)
  550        IF exp < 0 THEN
  551          RETURN res / p10;
  552        ELSE
  553          RETURN res * p10;
  554        END; (*IF*)
  555      END StrToReal;
  556  
  557  (*%F _WINDOWS *)
  558  PROCEDURE RealToStr(V: LONGREAL; Precision: CARDINAL; Eng: BOOLEAN;
  559                      VAR S: ARRAY OF CHAR; VAR OK: BOOLEAN);
  560  VAR
  561    X        : MATHLIB.PackedBcd;
  562    i,j,l    : CARDINAL;
  563    r,t      : LONGREAL;
  564    Exp,m    : INTEGER;
  565    Str      : ARRAY[0..7] OF CHAR;
  566    tb,
  567    FirstTime: BOOLEAN;
  568  
  569  BEGIN
  570    OK := TRUE;
  571    l  := HIGH( S );
  572    IF Precision = 0 THEN
  573      Precision := 1;
  574    ELSIF Precision > 17 THEN
  575      Precision := 17;
  576    END;
  577    FirstTime := TRUE;
  578  
  579    IF V # 0.0 THEN
  580      t := MATHLIB.Log10( ABS( V ) );
  581    ELSE
  582      t := 1.0;
  583    END;
  584  
  585    Exp := TRUNC( t );
  586    LOOP
  587      m := 1;
  588      IF Eng THEN
  589        IF (ABS(V) < 1.0) THEN
  590          DEC(m,ABS(Exp) MOD 3 );
  591          IF m < 1 THEN INC(m,3); END;
  592        ELSE
  593          INC(m,Exp MOD 3 );
  594        END;
  595      END;
  596  
  597      X := MATHLIB.LongToBcd( V*MATHLIB.IntPow(10.0,INTEGER(Precision)-Exp-1) );
  598      j := 0;
  599      IF NOT FirstTime THEN
  600        EXIT;
  601      ELSIF (X[Precision DIV 2] >> Div[Precision MOD 2 ] ) MOD 16 # 0 THEN
  602        INC( Exp );
  603        FirstTime := FALSE;
  604      ELSIF (X[(Precision-1) DIV 2] >> Div[(Precision-1) MOD 2 ] ) MOD 16 = 0 THEN
  605        DEC( Exp );
  606        FirstTime := FALSE;
  607      ELSE
  608        EXIT;
  609      END;
  610  
  611    END;
  612    IF X[9]=80H THEN
  613      S[0] := '-';
  614    ELSE
  615      S[0] := ' ';
  616    END;
  617    INC(j);
  618  
  619    FOR i := Precision-1 TO 0 BY -1 DO
  620      IF j > l THEN OK := FALSE; RETURN; END;
  621  
  622      S[j] := CHAR( SHORTCARD('0') + (X[i DIV 2] >> Div[i MOD 2 ] ) MOD 16 );
  623      INC( j );
  624      IF i = Precision-CARDINAL(m) THEN
  625        IF j > l THEN OK := FALSE; RETURN; END;
  626        S[j] := '.';
  627        INC(j);
  628      END;
  629    END;
  630  
  631    IF j > l THEN OK := FALSE; RETURN; END;
  632    S[j] := 'E';
  633    INC( j );
  634    IF j <= l THEN S[j] := CHR(0); END;
  635  
  636    tb := FloatUse;
  637    FloatUse := TRUE;
  638  
  639    IntToStr( VAL( LONGINT,Exp-m+1 ),Str,10,OK );
  640  
  641    FloatUse := tb;
  642  
  643    IF ( Length( Str ) + j )-1 > l THEN OK := FALSE; END;
  644    Append( S,Str );
  645  END RealToStr;
  646  (*%E *)
  647  
  648  (*%T _WINDOWS *)
  649    PROCEDURE RealToStr(V:LONGREAL;Precision:CARDINAL;Eng:BOOLEAN;VAR S:ARRAY OF CHAR;VAR OK:BOOLEAN);
  650      VAR
  651        j,w               : CARDINAL;
  652        m,i               : INTEGER;
  653        t                 : LONGREAL;
  654      BEGIN
  655        OK := TRUE;
  656        S[0] := 0C;
  657        m := 0;
  658        IF Precision > 17 THEN
  659          Precision := 17;
  660        END; (*IF*)
  661        IF V < 0.0 THEN
  662          Copy(S,'-');
  663          V := -V;
  664        END; (*IF*)
  665        IF V # 0.0 THEN
  666          m := TRUNC(MATHLIB.Log10(V));
  667          IF m > 0 THEN
  668            V := V / MATHLIB.IntPow(10.0,m);
  669          END; (*IF*)
  670          IF V < 1.0 THEN
  671            V := V * 10.0;
  672            DEC(m);
  673          END;
  674          t := MATHLIB.IntPow(10.0,INTEGER(Precision));
  675          V := (V * t + 0.5) / t;
  676          IF V >= 10.0 THEN
  677            V := V / 10.0;
  678            INC(m);
  679          END; (*IF*)
  680          IF Eng THEN
  681            i := m;
  682            IF m > 0 THEN
  683              m := ((m + 2) DIV 3) * 3;
  684            ELSE
  685              m := ((m - 2) DIV 3) * 3;
  686            END; (*IF*)
  687            V := V / MATHLIB.IntPow(10.0,m - i);
  688          END; (*IF*)
  689        END; (*IF*)
  690        w := TRUNC(V);
  691        V := (V - LONGREAL(w)) * 10.0;
  692        IF Eng & (Precision > 0) THEN
  693          IF w DIV 100 > 0 THEN
  694            Str.Append(S,CHR((w DIV 100) + 48));
  695            w := w MOD 100;
  696            DEC(Precision);
  697          END; (*IF*)
  698          IF (w DIV 10 > 0) & (Precision > 0) THEN
  699            Str.Append(S,CHR((w DIV 10) + 48));
  700            w := w MOD 10;
  701            DEC(Precision);
  702          END; (*IF*)
  703        END; (*IF*)
  704        IF Precision > 0 THEN
  705          Str.Append(S,CHR(w + 48));
  706          DEC(Precision);
  707          Str.Append(S,'.');
  708          IF Precision > 0 THEN
  709            FOR j := 1 TO Precision DO
  710              Append(S,CHR(TRUNC(V) + 48));
  711              V := (V - LONGREAL(TRUNC(V))) * 10.0;
  712            END; (*FOR*)
  713          END; (*IF*)
  714        END; (*IF*)
  715        IF m < 0 THEN
  716          Str.Append(S,'E-');
  717          m := -m;
  718        ELSE
  719          Str.Append(S,'E+');
  720        END; (*IF*)
  721        IF m DIV 100 > 0 THEN
  722          Str.Append(S,CHR((m DIV 100) + 48));
  723          m := m MOD 100;
  724        END; (*IF*)
  725        IF m DIV 10 > 0 THEN
  726          Str.Append(S,CHR((m DIV 10) + 48));
  727        END; (*IF*)
  728        Str.Append(S,CHR((m MOD 10) + 48));
  729      END RealToStr;
  730  (*%E *)
  731  
  732  (*# save,call(o_a_copy=>off,o_a_size=>on)*)
  733    PROCEDURE FindSubStr(Source,Pattern:ARRAY OF CHAR;VAR Pos:ARRAY OF PosLen):BOOLEAN;
  734      VAR
  735        s,p,n,l           : CARDINAL;
  736      BEGIN
  737        Lib.Fill(ADR(Pos),SIZE(Pos),0FFH);
  738        IF Length(Source) = 0 THEN
  739          RETURN FALSE;
  740        END; (*IF*)
  741        l := Length(Pattern);
  742        IF l = 0 THEN
  743          Pos[0] := PosLen(0,0);
  744          RETURN TRUE;
  745        END; (*IF*)
  746        IF (Pattern[0] = '*') OR (Pattern[0] = '?') THEN
  747          IF l = 1 THEN
  748            Pos[0].Pos := 0;
  749            IF Pattern[0] = '*' THEN
  750              Pos[0].Pos := 0;
  751              Pos[0].Len := Length(Source);
  752            ELSE
  753              Pos[0] := PosLen(0,1);
  754            END; (*IF*)
  755            RETURN TRUE;
  756          ELSE
  757            s := 0;
  758          END; (*IF*)
  759        ELSE
  760          s := CharPos(Source,Pattern[0]);
  761          IF s = MAX(CARDINAL) THEN
  762            RETURN FALSE;
  763          END; (*IF*)
  764        END; (*IF*)
  765        n := 0;
  766        p := 1;
  767        WHILE p < l DO
  768          INC(s);
  769          IF (s > HIGH(Source)) OR (Source[s] = 0C) THEN
  770            RETURN FALSE;
  771          END; (*IF*)
  772          CASE Pattern[p] OF
  773            '?'           : IF n <= HIGH(Pos) THEN
  774                              Pos[n].Pos := s;
  775                              Pos[n].Len := 1;
  776                              INC(n);
  777                            END; (*IF*)                                     |
  778            '*'           : IF n <= HIGH(Pos) THEN
  779                              Pos[n].Pos := s;
  780                              IF (p >= HIGH(Pattern)) OR (Pattern[p+1] = 0C) THEN
  781                                RETURN TRUE;
  782                              ELSE
  783                                Pos[n].Len := NextPos(Source,Pattern[p+1],s); (* s/b NextCharPos *)
  784                                IF Pos[n].Len = MAX(CARDINAL) THEN
  785                                  RETURN FALSE;
  786                                ELSE
  787                                  DEC(Pos[n].Len,s);
  788                                  INC(s,Pos[n].Len);
  789                                  INC(n);
  790                                END; (*IF*)
  791                              END; (*IF*)
  792                            END; (*IF*)
  793                            INC(p);                                         |
  794          ELSE
  795            IF CAP(Pattern[p]) # CAP(Source[s]) THEN
  796              RETURN FALSE;
  797            END; (*IF*)
  798          END; (*CASE*)
  799          INC(p);
  800        END; (*WHILE*)
  801        RETURN TRUE;
  802      END FindSubStr;
  803  (*# restore *)
  804  (* The following are Implemented in asmlib
  805  
  806  PROCEDURE CapS(VAR S: ARRAY OF CHAR);
  807  VAR I : CARDINAL;
  808  BEGIN
  809    FOR I := 0 TO HIGH(S) DO S[I] := CAP(S[I]); END;
  810  END CapS;
  811  
  812  
  813  PROCEDURE Compare(S1,S2: ARRAY OF CHAR) : INTEGER;
  814  VAR
  815    L1,L2,L,Index : CARDINAL;
  816  BEGIN
  817    L1 := Length(S1);
  818    L2 := Length(S2);
  819    IF L1<L2 THEN L := L1 ELSE L := L2 END;
  820    Index := Lib.Compare(ADR(S1),ADR(S2),L);
  821    IF (Index<L) THEN
  822      IF S1[Index] < S2[Index] THEN
  823        RETURN -1
  824      ELSE
  825        RETURN 1;
  826      END;
  827    ELSIF (L1=L2) THEN
  828      RETURN 0
  829    ELSIF (L1<L2) THEN
  830      RETURN -1
  831    ELSE
  832      RETURN 1;
  833    END;
  834  END Compare;
  835  
  836  
  837  PROCEDURE Length(S1: ARRAY OF CHAR) : CARDINAL;
  838  VAR I : CARDINAL;
  839  BEGIN
  840    RETURN Lib.ScanR(ADR(S1),HIGH(S1)+1,0);
  841  END Length;
  842  
  843  
  844  PROCEDURE Append(VAR Ns: ARRAY OF CHAR; S: ARRAY OF CHAR);
  845  VAR
  846    I,J : CARDINAL;
  847    c : CHAR;
  848  BEGIN
  849    I := Length(Ns);
  850    J := 0;
  851    WHILE (I <= HIGH(Ns)) AND (J <= HIGH(S))  AND (S[J] <> CHR(0)) DO
  852      Ns[I] := S[J];
  853      INC(I);
  854      INC(J);
  855    END;
  856    IF I<=HIGH(Ns) THEN Ns[I] := CHR(0) END;
  857  END Append;
  858  
  859  
  860  PROCEDURE Copy(VAR Ns: ARRAY OF CHAR; S: ARRAY OF CHAR);
  861  VAR
  862    H,L : CARDINAL;
  863  BEGIN
  864    H := HIGH(Ns)+1;
  865    L := Length(S);
  866    IF L > H THEN L := H END;
  867    Lib.Move(ADR(S),ADR(Ns),L);
  868    IF L < H THEN Ns[L] := CHR(0) END;
  869  END Copy;
  870  
  871  
  872  PROCEDURE Concat(VAR Ns: ARRAY OF CHAR; S1,S2: ARRAY OF CHAR);
  873  VAR
  874    I,J : CARDINAL;
  875  BEGIN
  876    J := 0;
  877    WHILE (J <= HIGH(Ns)) AND (J <= HIGH(S1)) AND (S1[J] <> CHAR(0)) DO
  878      Ns[J] := S1[J];
  879      INC(J);
  880    END;
  881  
  882    I := 0;
  883    LOOP
  884      IF (J > HIGH(Ns)) THEN EXIT; END;
  885      IF (I > HIGH(S2)) THEN Ns[J] := CHR(0); EXIT; END;
  886      Ns[J] := S2[I];
  887      IF S2[I] = CHR(0) THEN EXIT; END;
  888      INC(I);
  889      INC(J);
  890    END;
  891  END Concat;
  892  
  893  
  894  PROCEDURE Pos(S,P: ARRAY OF CHAR) : CARDINAL;
  895  VAR
  896    I,J,K,HP,HS : CARDINAL;
  897  BEGIN
  898    HP := HIGH(P);
  899    HS := HIGH(S);
  900    I  := 0;
  901    LOOP
  902      IF (I > HS) OR (S[I] = CHR(0)) THEN RETURN MAX(CARDINAL) END;
  903      J := 0;
  904      K := I;
  905      LOOP
  906        IF (J > HP) OR (P[J] = CHR(0)) THEN RETURN I END;
  907        IF K > HS THEN RETURN MAX( CARDINAL ); END;
  908        IF S[K] # P[J] THEN EXIT END;
  909        INC(J);
  910        INC(K);
  911      END;
  912      INC(I);
  913    END;
  914  END Pos;
  915  
  916  *)
  917  
  918  PROCEDURE StrToC(S: ARRAY OF CHAR; VAR D: ARRAY OF CHAR): BOOLEAN;
  919  
  920  VAR
  921    n: CARDINAL;
  922    c: CHAR;
  923  BEGIN
  924    n := 0;
  925    LOOP
  926      IF n > HIGH(D) THEN
  927        RETURN FALSE;
  928      END;
  929      IF n > HIGH(S) THEN
  930        c := 0C;
  931      ELSE
  932        c := S[n];
  933      END;
  934      D[n] := c;
  935      IF c = 0C THEN
  936        RETURN TRUE
  937      END;
  938      INC(n);
  939    END;
  940  END StrToC;
  941  
  942  PROCEDURE StrToPas(S: ARRAY OF CHAR; VAR D: ARRAY OF CHAR): BOOLEAN;
  943  
  944  VAR
  945    n: CARDINAL;
  946    c: CHAR;
  947  BEGIN
  948    n := 1;
  949    LOOP
  950      IF n > HIGH(D) THEN
  951        D[0] := 0C;
  952        RETURN FALSE;
  953      END;
  954      IF n > SIZE(S) THEN
  955        c := 0C;
  956      ELSE
  957        c := S[n-1];
  958      END;
  959      IF c = 0C THEN
  960        D[0] := CHAR(n-1);
  961        RETURN TRUE
  962      END;
  963      D[n] := c;
  964      INC(n);
  965    END;
  966  END StrToPas;
  967  
  968  BEGIN
  969    FloatUse := FALSE;
  970  END Str.

  169 errors