/compiler/cutils.pas

   1{
   2    Copyright (c) 1998-2002 by Florian Klaempfl
   3
   4    This unit implements some support functions
   5
   6    This program is free software; you can redistribute it and/or modify
   7    it under the terms of the GNU General Public License as published
   8    by the Free Software Foundation; either version 2 of the License, or
   9    (at your option) any later version.
  10
  11    This program is distributed in the hope that it will be useful,
  12    but WITHOUT ANY WARRANTY; without even the implied warranty of
  13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14    GNU General Public License for more details.
  15
  16    You should have received a copy of the GNU General Public License
  17    along with this program; if not, write to the Free Software
  18    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20
  21****************************************************************************
  22}
  23{# This unit contains some generic support functions which are used
  24   in the different parts of the compiler.
  25}
  26unit cutils;
  27
  28{$i fpcdefs.inc}
  29
  30interface
  31
  32  type
  33    Tcharset=set of char;
  34
  35  var
  36    internalerrorproc : procedure(i:longint);
  37
  38
  39    {# Returns the minimal value between @var(a) and @var(b) }
  40    function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  41    function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  42    {# Returns the maximum value between @var(a) and @var(b) }
  43    function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  44    function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  45    {# Return value @var(i) aligned on @var(a) boundary }
  46    function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
  47    { if you have an address aligned using "oldalignment" and add an
  48      offset of (a multiple of) offset to it, this function calculates
  49      the new minimally guaranteed alignment
  50    }
  51    function newalignment(oldalignment: longint; offset: int64): longint;
  52    {# Return @var(b) with the bit order reversed }
  53    function reverse_byte(b: byte): byte;
  54
  55    function next_prime(l: longint): longint;
  56
  57    function used_align(varalign,minalign,maxalign:shortint):shortint;
  58    function isbetteralignedthan(new, org, limit: cardinal): boolean;
  59    function size_2_align(len : longint) : shortint;
  60    function packedbitsloadsize(bitlen: int64) : int64;
  61    procedure Replace(var s:string;s1:string;const s2:string);
  62    procedure Replace(var s:AnsiString;s1:string;const s2:AnsiString);
  63    procedure ReplaceCase(var s:string;const s1,s2:string);
  64    procedure ReplaceCase(var s:ansistring;const s1,s2:ansistring);
  65    Function MatchPattern(const pattern,what:string):boolean;
  66    function upper(const c : char) : char;
  67    function upper(const s : string) : string;
  68    function upper(const s : ansistring) : ansistring;
  69    function lower(const c : char) : char;
  70    function lower(const s : string) : string;
  71    function lower(const s : ansistring) : ansistring;
  72    function rpos(const needle: char; const haystack: shortstring): longint; overload;
  73    function rpos(const needle: shortstring; const haystack: shortstring): longint; overload;
  74    function trimbspace(const s:string):string;
  75    function trimspace(const s:string):string;
  76    function space (b : longint): string;
  77    function PadSpace(const s:string;len:longint):string;
  78    function GetToken(var s:string;endchar:char):string;
  79    procedure uppervar(var s : string);
  80    function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
  81    function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  82    function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  83    function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  84    function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
  85    function DStr(l:longint):string;
  86    {# Returns true if the string s is a number }
  87    function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
  88    {# Returns true if value is a power of 2, the actual
  89       exponent value is returned in power.
  90    }
  91    function ispowerof2(value : int64;out power : longint) : boolean;
  92    function nextpowerof2(value : int64; out power: longint) : int64;
  93{$ifdef VER2_6}  { only 2.7.1+ has a popcnt function in the system unit }
  94    function PopCnt(AValue : Byte): Byte;
  95    function PopCnt(AValue : Word): Word;
  96    function PopCnt(AValue : DWord): DWord;
  97    function PopCnt(Const AValue : QWord): QWord;
  98{$endif VER2_6}
  99
 100    function backspace_quote(const s:string;const qchars:Tcharset):string;
 101    function octal_quote(const s:string;const qchars:Tcharset):string;
 102
 103    {# If the string is quoted, in accordance with pascal, it is
 104       dequoted and returned in s, and the function returns true.
 105       If it is not quoted, or if the quoting is bad, s is not touched,
 106       and false is returned.
 107    }
 108    function DePascalQuote(var s: ansistring): Boolean;
 109    function CompareStr(const S1, S2: string): Integer;
 110    function CompareText(S1, S2: string): integer;
 111    function CompareVersionStrings(s1,s2: string): longint;
 112
 113    { releases the string p and assignes nil to p }
 114    { if p=nil then freemem isn't called          }
 115    procedure stringdispose(var p : pshortstring);{$ifdef USEINLINE}inline;{$endif}
 116
 117
 118    { allocates mem for a copy of s, copies s to this mem and returns }
 119    { a pointer to this mem                                           }
 120    function stringdup(const s : string) : pshortstring;{$ifdef USEINLINE}inline;{$endif}
 121
 122    {# Allocates memory for the string @var(s) and copies s as zero
 123       terminated string to that allocated memory and returns a pointer
 124       to that mem
 125    }
 126    function  strpnew(const s : string) : pchar;
 127    function  strpnew(const s : ansistring) : pchar;
 128
 129    {# makes the character @var(c) lowercase, with spanish, french and german
 130       character set
 131    }
 132    function lowercase(c : char) : char;
 133
 134    { makes zero terminated string to a pascal string }
 135    { the data in p is modified and p is returned     }
 136    function pchar2pshortstring(p : pchar) : pshortstring;
 137
 138    { inverse of pchar2pshortstring }
 139    function pshortstring2pchar(p : pshortstring) : pchar;
 140
 141    { allocate a new pchar with the contents of a}
 142    function ansistring2pchar(const a: ansistring) : pchar;
 143
 144    { Ansistring (pchar+length) support }
 145    procedure ansistringdispose(var p : pchar;length : longint);
 146    function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
 147    function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
 148
 149    {Lzw encode/decode to compress strings -> save memory.}
 150    function minilzw_encode(const s:string):string;
 151    function minilzw_decode(const s:string):string;
 152
 153    Function nextafter(x,y:double):double;
 154
 155  { hide Sysutils.ExecuteProcess in units using this one after SysUtils}
 156  const
 157    ExecuteProcess = 'Do not use' deprecated 'Use cfileutil.RequotedExecuteProcess instead, ExecuteProcess cannot deal with single quotes as used by Unix command lines';
 158
 159implementation
 160
 161    uses
 162      SysUtils;
 163
 164    var
 165      uppertbl,
 166      lowertbl  : array[char] of char;
 167
 168
 169    function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
 170    {
 171      return the minimal of a and b
 172    }
 173      begin
 174         if a<=b then
 175           min:=a
 176         else
 177           min:=b;
 178      end;
 179
 180
 181    function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
 182    {
 183      return the minimal of a and b
 184    }
 185      begin
 186         if a<=b then
 187           min:=a
 188         else
 189           min:=b;
 190      end;
 191
 192
 193    function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
 194    {
 195      return the maximum of a and b
 196    }
 197      begin
 198         if a>=b then
 199           max:=a
 200         else
 201           max:=b;
 202      end;
 203
 204
 205    function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
 206    {
 207      return the maximum of a and b
 208    }
 209      begin
 210         if a>=b then
 211           max:=a
 212         else
 213           max:=b;
 214      end;
 215
 216
 217    function newalignment(oldalignment: longint; offset: int64): longint;
 218      var
 219        localoffset: longint;
 220      begin
 221        localoffset:=longint(offset);
 222        while (localoffset mod oldalignment)<>0 do
 223          oldalignment:=oldalignment div 2;
 224        newalignment:=oldalignment;
 225      end;
 226
 227
 228    function reverse_byte(b: byte): byte;
 229      const
 230        reverse_nible:array[0..15] of 0..15 =
 231          (%0000,%1000,%0100,%1100,%0010,%1010,%0110,%1110,
 232           %0001,%1001,%0101,%1101,%0011,%1011,%0111,%1111);
 233      begin
 234        reverse_byte:=(reverse_nible[b and $f] shl 4) or reverse_nible[b shr 4];
 235      end;
 236
 237    function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
 238    {
 239      return value <i> aligned <a> boundary
 240    }
 241      begin
 242        { for 0 and 1 no aligning is needed }
 243        if a<=1 then
 244          result:=i
 245        else
 246          begin
 247            if i<0 then
 248              result:=((i-a+1) div a) * a
 249            else
 250              result:=((i+a-1) div a) * a;
 251          end;
 252      end;
 253
 254
 255    function size_2_align(len : longint) : shortint;
 256      begin
 257         if len>16 then
 258           size_2_align:=32
 259         else if len>8 then
 260           size_2_align:=16
 261         else if len>4 then
 262           size_2_align:=8
 263         else if len>2 then
 264           size_2_align:=4
 265         else if len>1 then
 266           size_2_align:=2
 267         else
 268           size_2_align:=1;
 269      end;
 270
 271
 272    function packedbitsloadsize(bitlen: int64) : int64;
 273      begin
 274         case bitlen of
 275           1,2,4,8:
 276             result := 1;
 277           { 10 bits can never be split over 3 bytes via 1-8-1, because it }
 278           { always starts at a multiple of 10 bits. Same for the others.  }
 279           3,5,6,7,9,10,12,16:
 280             result := 2;
 281  {$ifdef cpu64bitalu}
 282           { performance penalty for unaligned 8 byte access is much   }
 283           { higher than for unaligned 4 byte access, at least on ppc, }
 284           { so use 4 bytes even in some cases where a value could     }
 285           { always loaded using a single 8 byte load (e.g. in case of }
 286           { 28 bit values)                                            }
 287           11,13,14,15,17..32:
 288             result := 4;
 289           else
 290             result := 8;
 291  {$else cpu64bitalu}
 292           else
 293             result := 4;
 294  {$endif cpu64bitalu}
 295         end;
 296      end;
 297
 298
 299    function isbetteralignedthan(new, org, limit: cardinal): boolean;
 300      var
 301        cnt: cardinal;
 302      begin
 303        cnt:=2;
 304        while (cnt <= limit) do
 305          begin
 306            if (org and (cnt-1)) > (new and (cnt-1)) then
 307              begin
 308                result:=true;
 309                exit;
 310              end
 311            else if (org and (cnt-1)) < (new and (cnt-1)) then
 312              begin
 313                result:=false;
 314                exit;
 315              end;
 316            cnt:=cnt*2;
 317          end;
 318        result:=false;
 319      end;
 320
 321
 322    function next_prime(l: longint): longint;
 323      var
 324        check, checkbound: longint;
 325        ok: boolean;
 326      begin
 327        result:=l or 1;
 328        while l<high(longint) do
 329          begin
 330            ok:=true;
 331            checkbound:=trunc(sqrt(l));
 332            check:=3;
 333            while check<checkbound do
 334              begin
 335                if (l mod check) = 0 then
 336                  begin
 337                    ok:=false;
 338                    break;
 339                  end;
 340                inc(check,2);
 341              end;
 342            if ok then
 343              exit;
 344            inc(l);
 345          end;
 346      end;
 347
 348
 349    function used_align(varalign,minalign,maxalign:shortint):shortint;
 350      begin
 351        { varalign  : minimum alignment required for the variable
 352          minalign  : Minimum alignment of this structure, 0 = undefined
 353          maxalign  : Maximum alignment of this structure, 0 = undefined }
 354        if (minalign>0) and
 355           (varalign<minalign) then
 356         used_align:=minalign
 357        else
 358         begin
 359           if (maxalign>0) and
 360              (varalign>maxalign) then
 361            used_align:=maxalign
 362           else
 363            used_align:=varalign;
 364         end;
 365      end;
 366
 367
 368    procedure Replace(var s:string;s1:string;const s2:string);
 369      var
 370         last,
 371         i  : longint;
 372      begin
 373        s1:=upper(s1);
 374        last:=0;
 375        repeat
 376          i:=pos(s1,upper(s));
 377          if i=last then
 378           i:=0;
 379          if (i>0) then
 380           begin
 381             Delete(s,i,length(s1));
 382             Insert(s2,s,i);
 383             last:=i;
 384           end;
 385        until (i=0);
 386      end;
 387
 388
 389    procedure Replace(var s:AnsiString;s1:string;const s2:AnsiString);
 390      var
 391         last,
 392         i  : longint;
 393      begin
 394        s1:=upper(s1);
 395        last:=0;
 396        repeat
 397          i:=pos(s1,upper(s));
 398          if i=last then
 399           i:=0;
 400          if (i>0) then
 401           begin
 402             Delete(s,i,length(s1));
 403             Insert(s2,s,i);
 404             last:=i;
 405           end;
 406        until (i=0);
 407      end;
 408
 409
 410    procedure ReplaceCase(var s:string;const s1,s2:string);
 411      var
 412         last,
 413         i  : longint;
 414      begin
 415        last:=0;
 416        repeat
 417          i:=pos(s1,s);
 418          if i=last then
 419           i:=0;
 420          if (i>0) then
 421           begin
 422             Delete(s,i,length(s1));
 423             Insert(s2,s,i);
 424             last:=i;
 425           end;
 426        until (i=0);
 427      end;
 428
 429
 430    procedure ReplaceCase(var s: ansistring; const s1, s2: ansistring);
 431      var
 432         last,
 433         i  : longint;
 434      begin
 435        last:=0;
 436        repeat
 437          i:=pos(s1,s);
 438          if i=last then
 439           i:=0;
 440          if (i>0) then
 441           begin
 442             Delete(s,i,length(s1));
 443             Insert(s2,s,i);
 444             last:=i;
 445           end;
 446        until (i=0);
 447      end;
 448
 449
 450    Function MatchPattern(const pattern,what:string):boolean;
 451      var
 452        found : boolean;
 453        i1,i2 : longint;
 454      begin
 455        i1:=0;
 456        i2:=0;
 457        if pattern='' then
 458          begin
 459            result:=(what='');
 460            exit;
 461          end;
 462        found:=true;
 463        repeat
 464          inc(i1);
 465          if (i1>length(pattern)) then
 466            break;
 467          inc(i2);
 468          if (i2>length(what)) then
 469            break;
 470          case pattern[i1] of
 471            '?' :
 472              found:=true;
 473            '*' :
 474              begin
 475                found:=true;
 476                if (i1=length(pattern)) then
 477                 i2:=length(what)
 478                else
 479                 if (i1<length(pattern)) and (pattern[i1+1]<>what[i2]) then
 480                  begin
 481                    if i2<length(what) then
 482                     dec(i1)
 483                  end
 484                else
 485                 if i2>1 then
 486                  dec(i2);
 487              end;
 488            else
 489              found:=(pattern[i1]=what[i2]) or (what[i2]='?');
 490          end;
 491        until not found;
 492        if found then
 493          begin
 494            found:=(i2>=length(what)) and
 495                   (
 496                    (i1>length(pattern)) or
 497                    ((i1=length(pattern)) and
 498                     (pattern[i1]='*'))
 499                   );
 500          end;
 501        result:=found;
 502      end;
 503
 504
 505    function upper(const c : char) : char;
 506    {
 507      return uppercase of c
 508    }
 509      begin
 510        upper:=uppertbl[c];
 511      end;
 512
 513
 514    function upper(const s : string) : string;
 515    {
 516      return uppercased string of s
 517    }
 518      var
 519        i  : longint;
 520      begin
 521        for i:=1 to length(s) do
 522          upper[i]:=uppertbl[s[i]];
 523        upper[0]:=s[0];
 524      end;
 525
 526
 527    function upper(const s : ansistring) : ansistring;
 528    {
 529      return uppercased string of s
 530    }
 531      var
 532        i  : longint;
 533      begin
 534        setlength(upper,length(s));
 535        for i:=1 to length(s) do
 536          upper[i]:=uppertbl[s[i]];
 537      end;
 538
 539
 540    function lower(const c : char) : char;
 541    {
 542      return lowercase of c
 543    }
 544      begin
 545        lower:=lowertbl[c];
 546      end;
 547
 548
 549    function lower(const s : string) : string;
 550    {
 551      return lowercased string of s
 552    }
 553      var
 554        i : longint;
 555      begin
 556        for i:=1 to length(s) do
 557          lower[i]:=lowertbl[s[i]];
 558        lower[0]:=s[0];
 559      end;
 560
 561
 562    function lower(const s : ansistring) : ansistring;
 563    {
 564      return lowercased string of s
 565    }
 566      var
 567        i : longint;
 568      begin
 569        setlength(lower,length(s));
 570        for i:=1 to length(s) do
 571          lower[i]:=lowertbl[s[i]];
 572      end;
 573
 574
 575    procedure uppervar(var s : string);
 576    {
 577      uppercase string s
 578    }
 579      var
 580         i : longint;
 581      begin
 582         for i:=1 to length(s) do
 583          s[i]:=uppertbl[s[i]];
 584      end;
 585
 586
 587    procedure initupperlower;
 588      var
 589        c : char;
 590      begin
 591        for c:=#0 to #255 do
 592         begin
 593           lowertbl[c]:=c;
 594           uppertbl[c]:=c;
 595           case c of
 596             'A'..'Z' :
 597               lowertbl[c]:=char(byte(c)+32);
 598             'a'..'z' :
 599               uppertbl[c]:=char(byte(c)-32);
 600           end;
 601         end;
 602      end;
 603
 604
 605    function DStr(l:longint):string;
 606      var
 607        TmpStr : string[32];
 608        i : longint;
 609      begin
 610        Str(l,TmpStr);
 611        i:=Length(TmpStr);
 612        while (i>3) do
 613         begin
 614           dec(i,3);
 615           if TmpStr[i]<>'-' then
 616            insert('.',TmpStr,i+1);
 617         end;
 618        DStr:=TmpStr;
 619      end;
 620
 621
 622    function rpos(const needle: char; const haystack: shortstring): longint;
 623      begin
 624        result:=length(haystack);
 625        while (result>0) do
 626          begin
 627            if haystack[result]=needle then
 628              exit;
 629            dec(result);
 630          end;
 631      end;
 632
 633
 634    function rpos(const needle: shortstring; const haystack: shortstring): longint;
 635      begin
 636        result:=0;
 637        if (length(needle)=0) or
 638           (length(needle)>length(haystack)) then
 639          exit;
 640        result:=length(haystack)-length(needle);
 641        repeat
 642          if (haystack[result]=needle[1]) and
 643             (copy(haystack,result,length(needle))=needle) then
 644            exit;
 645          dec(result);
 646        until result=0;
 647      end;
 648
 649
 650    function trimbspace(const s:string):string;
 651    {
 652      return s with all leading spaces and tabs removed
 653    }
 654      var
 655        i,j : longint;
 656      begin
 657        j:=1;
 658        i:=length(s);
 659        while (j<i) and (s[j] in [#9,' ']) do
 660         inc(j);
 661        trimbspace:=Copy(s,j,i-j+1);
 662      end;
 663
 664
 665
 666    function trimspace(const s:string):string;
 667    {
 668      return s with all leading and ending spaces and tabs removed
 669    }
 670      var
 671        i,j : longint;
 672      begin
 673        i:=length(s);
 674        while (i>0) and (s[i] in [#9,' ']) do
 675         dec(i);
 676        j:=1;
 677        while (j<i) and (s[j] in [#9,' ']) do
 678         inc(j);
 679        trimspace:=Copy(s,j,i-j+1);
 680      end;
 681
 682
 683    function space (b : longint): string;
 684      var
 685       s: string;
 686      begin
 687        space[0] := chr(b);
 688        s[0] := chr(b);
 689        FillChar (S[1],b,' ');
 690        space:=s;
 691      end;
 692
 693
 694    function PadSpace(const s:string;len:longint):string;
 695    {
 696      return s with spaces add to the end
 697    }
 698      begin
 699         if length(s)<len then
 700          PadSpace:=s+Space(len-length(s))
 701         else
 702          PadSpace:=s;
 703      end;
 704
 705
 706    function GetToken(var s:string;endchar:char):string;
 707      var
 708        i : longint;
 709        quote : char;
 710      begin
 711        GetToken:='';
 712        s:=TrimSpace(s);
 713        if (length(s)>0) and
 714           (s[1] in ['''','"']) then
 715         begin
 716           quote:=s[1];
 717           i:=1;
 718           while (i<length(s)) do
 719            begin
 720              inc(i);
 721              if s[i]=quote then
 722               begin
 723                 { Remove double quote }
 724                 if (i<length(s)) and
 725                    (s[i+1]=quote) then
 726                  begin
 727                    Delete(s,i,1);
 728                    inc(i);
 729                  end
 730                 else
 731                  begin
 732                    GetToken:=Copy(s,2,i-2);
 733                    Delete(s,1,i);
 734                    exit;
 735                  end;
 736               end;
 737            end;
 738           GetToken:=s;
 739           s:='';
 740         end
 741        else
 742         begin
 743           i:=pos(EndChar,s);
 744           if i=0 then
 745            begin
 746              GetToken:=s;
 747              s:='';
 748              exit;
 749            end
 750           else
 751            begin
 752              GetToken:=Copy(s,1,i-1);
 753              Delete(s,1,i);
 754              exit;
 755            end;
 756         end;
 757      end;
 758
 759
 760   function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
 761     begin
 762        str(e,result);
 763     end;
 764
 765
 766   function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
 767   {
 768     return string of value i
 769   }
 770     begin
 771        str(i,result);
 772     end;
 773
 774
 775   function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
 776   {
 777     return string of value i
 778   }
 779     begin
 780        str(i,result);
 781     end;
 782
 783
 784   function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
 785   {
 786     return string of value i
 787   }
 788     begin
 789        str(i,result);
 790     end;
 791
 792
 793   function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
 794   {
 795     return string of value i, but always include a + when i>=0
 796   }
 797     begin
 798        str(i,result);
 799        if i>=0 then
 800          result:='+'+result;
 801     end;
 802
 803
 804    function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
 805    {
 806      is string a correct number ?
 807    }
 808      var
 809         w : integer;
 810         l : longint;
 811      begin
 812         val(s,l,w);
 813         // remove warning
 814         l:=l;
 815         is_number:=(w=0);
 816      end;
 817
 818
 819    function ispowerof2(value : int64;out power : longint) : boolean;
 820    {
 821      return if value is a power of 2. And if correct return the power
 822    }
 823      begin
 824        if (value = 0) or (value and (value - 1) <> 0) then
 825          exit(false);
 826        power:=BsfQWord(value);
 827        result:=true;
 828      end;
 829
 830
 831    function nextpowerof2(value : int64; out power: longint) : int64;
 832    {
 833      returns the power of 2 >= value
 834    }
 835      var
 836        i : longint;
 837      begin
 838        result := 0;
 839        power := -1;
 840        if ((value <= 0) or
 841            (value >= $4000000000000000)) then
 842          exit;
 843        result := 1;
 844        for i:=0 to 63 do
 845          begin
 846            if result>=value then
 847              begin
 848                power := i;
 849                exit;
 850              end;
 851            result:=result shl 1;
 852          end;
 853      end;
 854
 855{$ifdef VER2_6}
 856    const
 857      PopCntData : array[0..15] of byte = (0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4);
 858
 859    function PopCnt(AValue : Byte): Byte;
 860      var
 861        i : SizeInt;
 862      begin
 863        Result:=PopCntData[AValue and $f]+PopCntData[(AValue shr 4) and $f];
 864      end;
 865
 866
 867    function PopCnt(AValue : Word): Word;
 868      var
 869        i : SizeInt;
 870      begin
 871        Result:=0;
 872        for i:=0 to 3 do
 873          begin
 874            inc(Result,PopCntData[AValue and $f]);
 875            AValue:=AValue shr 4;
 876          end;
 877      end;
 878
 879
 880    function PopCnt(AValue : DWord): DWord;
 881      var
 882        i : SizeInt;
 883      begin
 884        Result:=0;
 885        for i:=0 to 7 do
 886          begin
 887            inc(Result,PopCntData[AValue and $f]);
 888            AValue:=AValue shr 4;
 889          end;
 890      end;
 891
 892
 893    function PopCnt(Const AValue : QWord): QWord;
 894      begin
 895        Result:=PopCnt(lo(AValue))+PopCnt(hi(AValue))
 896      end;
 897 {$endif VER2_6}
 898
 899
 900    function backspace_quote(const s:string;const qchars:Tcharset):string;
 901
 902    var i:byte;
 903
 904    begin
 905      backspace_quote:='';
 906      for i:=1 to length(s) do
 907        begin
 908          if (s[i]=#10) and (#10 in qchars) then
 909            backspace_quote:=backspace_quote+'\n'
 910          else if (s[i]=#13) and (#13 in qchars) then
 911            backspace_quote:=backspace_quote+'\r'
 912          else
 913            begin
 914              if s[i] in qchars then
 915                backspace_quote:=backspace_quote+'\';
 916              backspace_quote:=backspace_quote+s[i];
 917            end;
 918        end;
 919    end;
 920
 921
 922    function octal_quote(const s:string;const qchars:Tcharset):string;
 923
 924    var i:byte;
 925
 926    begin
 927      octal_quote:='';
 928      for i:=1 to length(s) do
 929        begin
 930          if s[i] in qchars then
 931            begin
 932              if ord(s[i])<64 then
 933                octal_quote:=octal_quote+'\'+octstr(ord(s[i]),3)
 934              else
 935                octal_quote:=octal_quote+'\'+octstr(ord(s[i]),4);
 936            end
 937          else
 938            octal_quote:=octal_quote+s[i];
 939        end;
 940    end;
 941
 942
 943    function DePascalQuote(var s: ansistring): Boolean;
 944      var
 945        destPos, sourcePos, len: Integer;
 946        t: string;
 947        ch: Char;
 948    begin
 949      DePascalQuote:= false;
 950      len:= length(s);
 951      if (len >= 1) and (s[1] = '''') then
 952        begin
 953          {Remove quotes, exchange '' against ' }
 954          destPos := 0;
 955          sourcepos:=1;
 956          while (sourcepos<len) do
 957            begin
 958              inc(sourcePos);
 959              ch := s[sourcePos];
 960              if ch = '''' then
 961                begin
 962                  inc(sourcePos);
 963                  if (sourcePos <= len) and (s[sourcePos] = '''') then
 964                    {Add the quote as part of string}
 965                  else
 966                    begin
 967                      SetLength(t, destPos);
 968                      s:= t;
 969                      Exit(true);
 970                    end;
 971                end;
 972              inc(destPos);
 973              t[destPos] := ch;
 974            end;
 975        end;
 976    end;
 977
 978
 979    function pchar2pshortstring(p : pchar) : pshortstring;
 980      var
 981         w,i : longint;
 982      begin
 983         w:=strlen(p);
 984         for i:=w-1 downto 0 do
 985           p[i+1]:=p[i];
 986         p[0]:=chr(w);
 987         pchar2pshortstring:=pshortstring(p);
 988      end;
 989
 990
 991    function pshortstring2pchar(p : pshortstring) : pchar;
 992      var
 993         w,i : longint;
 994      begin
 995         w:=length(p^);
 996         for i:=1 to w do
 997           p^[i-1]:=p^[i];
 998         p^[w]:=#0;
 999         pshortstring2pchar:=pchar(p);
1000      end;
1001
1002
1003    function ansistring2pchar(const a: ansistring) : pchar;
1004      var
1005        len: ptrint;
1006      begin
1007        len:=length(a);
1008        getmem(result,len+1);
1009        if (len<>0) then
1010          move(a[1],result[0],len);
1011        result[len]:=#0;
1012      end;
1013
1014
1015    function lowercase(c : char) : char;
1016       begin
1017          case c of
1018             #65..#90 : c := chr(ord (c) + 32);
1019             #154 : c:=#129;  { german }
1020             #142 : c:=#132;  { german }
1021             #153 : c:=#148;  { german }
1022             #144 : c:=#130;  { french }
1023             #128 : c:=#135;  { french }
1024             #143 : c:=#134;  { swedish/norge (?) }
1025             #165 : c:=#164;  { spanish }
1026             #228 : c:=#229;  { greek }
1027             #226 : c:=#231;  { greek }
1028             #232 : c:=#227;  { greek }
1029          end;
1030          lowercase := c;
1031       end;
1032
1033
1034    function strpnew(const s : string) : pchar;
1035      var
1036         p : pchar;
1037      begin
1038         getmem(p,length(s)+1);
1039         move(s[1],p^,length(s));
1040         p[length(s)]:=#0;
1041         result:=p;
1042      end;
1043
1044    function strpnew(const s: ansistring): pchar;
1045      var
1046         p : pchar;
1047      begin
1048        getmem(p,length(s)+1);
1049        move(s[1],p^,length(s)+1);
1050        result:=p;
1051      end;
1052
1053
1054    procedure stringdispose(var p : pshortstring);{$ifdef USEINLINE}inline;{$endif}
1055      begin
1056         if assigned(p) then
1057           begin
1058             freemem(p);
1059             p:=nil;
1060           end;
1061      end;
1062
1063
1064    function stringdup(const s : string) : pshortstring;{$ifdef USEINLINE}inline;{$endif}
1065      begin
1066         getmem(result,length(s)+1);
1067         result^:=s;
1068      end;
1069
1070
1071    function CompareStr(const S1, S2: string): Integer;
1072      var
1073        count, count1, count2: integer;
1074      begin
1075        result := 0;
1076        Count1 := Length(S1);
1077        Count2 := Length(S2);
1078        if Count1>Count2 then
1079          Count:=Count2
1080        else
1081          Count:=Count1;
1082        result := CompareChar(S1[1],S2[1], Count);
1083        if result=0 then
1084          result:=Count1-Count2;
1085      end;
1086
1087
1088    function CompareText(S1, S2: string): integer;
1089      begin
1090        UpperVar(S1);
1091        UpperVar(S2);
1092        Result:=CompareStr(S1,S2);
1093      end;
1094
1095
1096    function CompareVersionStrings(s1,s2: string): longint;
1097      var
1098        start1, start2,
1099        i1, i2,
1100        num1,num2,
1101        res,
1102        err        : longint;
1103      begin
1104        i1:=1;
1105        i2:=1;
1106        repeat
1107          start1:=i1;
1108          start2:=i2;
1109          while (i1<=length(s1)) and
1110                (s1[i1] in ['0'..'9']) do
1111             inc(i1);
1112          while (i2<=length(s2)) and
1113                (s2[i2] in ['0'..'9']) do
1114             inc(i2);
1115          { one of the strings misses digits -> other is the largest version }
1116          if i1=start1 then
1117            if i2=start2 then
1118              exit(0)
1119            else
1120              exit(-1)
1121          else if i2=start2 then
1122            exit(1);
1123          { get version number part }
1124          val(copy(s1,start1,i1-start1),num1,err);
1125          val(copy(s2,start2,i2-start2),num2,err);
1126          { different -> done }
1127          res:=num1-num2;
1128          if res<>0 then
1129            exit(res);
1130          { if one of the two is at the end while the other isn't, add a '.0' }
1131          if (i1>length(s1)) and
1132             (i2<=length(s1)) then
1133            s1:=s1+'.0'
1134          else if i2>length(s2) then
1135            s2:=s2+'.0';
1136          { compare non-numerical characters normally }
1137          while (i1<=length(s1)) and
1138                not(s1[i1] in ['0'..'9']) and
1139                (i2<=length(s2)) and
1140                not(s2[i2] in ['0'..'9']) do
1141            begin
1142              res:=ord(s1[i1])-ord(s2[i2]);
1143              if res<>0 then
1144                exit(res);
1145              inc(i1);
1146              inc(i2);
1147            end;
1148          { both should be digits again now, otherwise pick the one with the
1149            digits as the largest (it more likely means that the input was
1150            ill-formatted though) }
1151          if (i1<=length(s1)) and
1152             not(s1[i1] in ['0'..'9']) then
1153            exit(-1);
1154          if (i2<=length(s2)) and
1155             not(s2[i2] in ['0'..'9']) then
1156            exit(1);
1157        until false;
1158      end;
1159
1160
1161{*****************************************************************************
1162                               Ansistring (PChar+Length)
1163*****************************************************************************}
1164
1165    procedure ansistringdispose(var p : pchar;length : longint);
1166      begin
1167         if assigned(p) then
1168           begin
1169             freemem(p);
1170             p:=nil;
1171           end;
1172      end;
1173
1174
1175    { enable ansistring comparison }
1176    { 0 means equal }
1177    { 1 means p1 > p2 }
1178    { -1 means p1 < p2 }
1179    function compareansistrings(p1,p2 : pchar;length1,length2 :  longint) : longint;
1180      var
1181         i,j : longint;
1182      begin
1183         compareansistrings:=0;
1184         j:=min(length1,length2);
1185         i:=0;
1186         while (i<j) do
1187          begin
1188            if p1[i]>p2[i] then
1189             begin
1190               compareansistrings:=1;
1191               exit;
1192             end
1193            else
1194             if p1[i]<p2[i] then
1195              begin
1196                compareansistrings:=-1;
1197                exit;
1198              end;
1199            inc(i);
1200          end;
1201         if length1>length2 then
1202          compareansistrings:=1
1203         else
1204          if length1<length2 then
1205           compareansistrings:=-1;
1206      end;
1207
1208
1209    function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
1210      var
1211         p : pchar;
1212      begin
1213         getmem(p,length1+length2+1);
1214         move(p1[0],p[0],length1);
1215         move(p2[0],p[length1],length2+1);
1216         concatansistrings:=p;
1217      end;
1218
1219
1220{*****************************************************************************
1221                       Ultra basic KISS Lzw (de)compressor
1222*****************************************************************************}
1223
1224    {This is an extremely basic implementation of the Lzw algorithm. It
1225     compresses 7-bit ASCII strings into 8-bit compressed strings.
1226     The Lzw dictionary is preinitialized with 0..127, therefore this
1227     part of the dictionary does not need to be stored in the arrays.
1228     The Lzw code size is allways 8 bit, so we do not need complex code
1229     that can write partial bytes.}
1230
1231    function minilzw_encode(const s:string):string;
1232
1233    var t,u,i:byte;
1234        c:char;
1235        data:array[128..255] of char;
1236        previous:array[128..255] of byte;
1237        lzwptr:byte;
1238        next_avail:set of 0..255;
1239
1240    label l1;
1241
1242    begin
1243      minilzw_encode:='';
1244      fillchar(data,sizeof(data),#0);
1245      fillchar(previous,sizeof(previous),#0);
1246      if s<>'' then
1247        begin
1248          lzwptr:=127;
1249          t:=byte(s[1]);
1250          i:=2;
1251          u:=128;
1252          next_avail:=[];
1253          while i<=length(s) do
1254            begin
1255              c:=s[i];
1256              if not(t in next_avail) or (u>lzwptr) then goto l1;
1257              while (previous[u]<>t) or (data[u]<>c) do
1258                begin
1259                  inc(u);
1260                  if u>lzwptr then goto l1;
1261                end;
1262              t:=u;
1263              inc(i);
1264              continue;
1265            l1:
1266              {It's a pity that we still need those awfull tricks
1267               with this modern compiler. Without this performance
1268               of the entire procedure drops about 3 times.}
1269              inc(minilzw_encode[0]);
1270              minilzw_encode[length(minilzw_encode)]:=char(t);
1271              if lzwptr=255 then
1272                begin
1273                  lzwptr:=127;
1274                  next_avail:=[];
1275                end
1276              else
1277                begin
1278                  inc(lzwptr);
1279                  data[lzwptr]:=c;
1280                  previous[lzwptr]:=t;
1281                  include(next_avail,t);
1282                end;
1283              t:=byte(c);
1284              u:=128;
1285              inc(i);
1286            end;
1287          inc(minilzw_encode[0]);
1288          minilzw_encode[length(minilzw_encode)]:=char(t);
1289        end;
1290    end;
1291
1292    function minilzw_decode(const s:string):string;
1293
1294    var oldc,newc,c:char;
1295        i,j:byte;
1296        data:array[128..255] of char;
1297        previous:array[128..255] of byte;
1298        lzwptr:byte;
1299        t:string;
1300
1301    begin
1302      minilzw_decode:='';
1303      fillchar(data,sizeof(data),#0);
1304      fillchar(previous,sizeof(previous),#0);
1305      if s<>'' then
1306        begin
1307          lzwptr:=127;
1308          oldc:=s[1];
1309          c:=oldc;
1310          i:=2;
1311          minilzw_decode:=oldc;
1312          while i<=length(s) do
1313            begin
1314              newc:=s[i];
1315              if byte(newc)>lzwptr then
1316                begin
1317                  t:=c;
1318                  c:=oldc;
1319                end
1320              else
1321                begin
1322                  c:=newc;
1323                  t:='';
1324                end;
1325              while c>=#128 do
1326                begin
1327                  inc(t[0]);
1328                  t[length(t)]:=data[byte(c)];
1329                  byte(c):=previous[byte(c)];
1330                end;
1331              inc(minilzw_decode[0]);
1332              minilzw_decode[length(minilzw_decode)]:=c;
1333              for j:=length(t) downto 1 do
1334                begin
1335                  inc(minilzw_decode[0]);
1336                  minilzw_decode[length(minilzw_decode)]:=t[j];
1337                end;
1338              if lzwptr=255 then
1339                lzwptr:=127
1340              else
1341                begin
1342                  inc(lzwptr);
1343                  previous[lzwptr]:=byte(oldc);
1344                  data[lzwptr]:=c;
1345                end;
1346              oldc:=newc;
1347              inc(i);
1348            end;
1349        end;
1350    end;
1351
1352
1353    procedure defaulterror(i:longint);
1354      begin
1355        writeln('Internal error ',i);
1356        runerror(255);
1357      end;
1358
1359    Function Nextafter(x,y:double):double;
1360    // Returns the double precision number closest to x in
1361    // the direction toward y.
1362
1363    // Initial direct translation by Soeren Haastrup from
1364    // www.netlib.org/fdlibm/s_nextafter.c according to
1365    // ====================================================
1366    // Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
1367    // Developed at SunSoft, a Sun Microsystems, Inc. business.
1368    // Permission to use, copy, modify, and distribute this
1369    // software is freely granted, provided that this notice
1370    // is preserved.
1371    // ====================================================
1372    // and with all signaling policies preserved as is.
1373
1374    type
1375      {$if defined(ENDIAN_LITTLE) and not defined(FPC_DOUBLE_HILO_SWAPPED)}
1376        twoword=record
1377                  lo,hi:longword; // Little Endian split of a double.
1378                end;
1379      {$else}
1380        twoword=record
1381                  hi,lo:longword; // Big Endian split of a double.
1382                end;
1383      {$endif}
1384
1385    var
1386        hx,hy,ix,iy:longint;
1387        lx,ly:longword;
1388
1389    Begin
1390    hx:=twoword(x).hi;    // high and low words of x and y
1391    lx:=twoword(x).lo;
1392    hy:=twoword(y).hi;
1393    ly:=twoword(y).lo;
1394    ix:=hx and $7fffffff;  // absolute values
1395    iy:=hy and $7fffffff;
1396
1397    // Case x=NAN or y=NAN
1398
1399    if ( (ix>=$7ff00000) and ((longword(ix-$7ff00000) or lx) <> 0) )
1400        or ( (iy>=$7ff00000) and ((longword(iy-$7ff00000) OR ly) <> 0) )
1401    then exit(x+y);
1402
1403    // Case x=y
1404
1405    if x=y then exit(x); // (implies Nextafter(0,-0) is 0 and not -0...)
1406
1407    // Case x=0
1408
1409    if (longword(ix) or lx)=0
1410    then begin
1411          twoword(x).hi:=hy and $80000000;  // return +-minimalSubnormal
1412          twoword(x).lo:=1;
1413          y:=x*x;    // set underflow flag (ignored in FPC as default)
1414          if y=x
1415          then exit(y)
1416          else exit(x);
1417        end;
1418
1419    // all other cases
1420
1421    if hx>=0  // x>0
1422    then begin
1423          if (hx>hy) or ( (hx=hy) and (lx>ly) ) // x>y , return x-ulp
1424          then begin
1425                if (lx=0) then hx:=hx-1;
1426                lx:=lx-1;
1427              end
1428          else begin                      // x<y, return x+ulp
1429                lx:=lx+1;
1430                if lx=0 then hx:=hx+1;
1431              end
1432        end
1433    else begin // x<0
1434          if (hy>=0) or (hx>=hy) or ( (hx=hy) and (lx>ly)) // x<y, return x-ulp
1435          then begin
1436                if (lx=0) then hx:=hx-1;
1437                lx:=lx-1;
1438              end
1439          else begin            // x>y , return x+ulp
1440                lx:=lx+1;
1441                if lx=0 then hx:=hx+1;
1442              end
1443        end;
1444
1445    // finally check if overflow or underflow just happend
1446
1447    hy:=hx and $7ff00000;
1448    if (hy>= $7ff00000) then exit(x+x); // overflow and signal
1449    if (hy<$0010000)                    // underflow
1450    then begin
1451          y:=x*x;              // raise underflow flag
1452          if y<>x
1453          then begin
1454                twoword(y).hi:=hx;
1455                twoword(y).lo:=lx;
1456                exit(y);
1457              end
1458        end;
1459
1460    twoword(x).hi:=hx;
1461    twoword(x).lo:=lx;
1462    nextafter:=x;
1463
1464    end;
1465
1466
1467initialization
1468  internalerrorproc:=@defaulterror;
1469  initupperlower;
1470end.