/compiler/cutils.pas
Pascal | 1470 lines | 1097 code | 178 blank | 195 comment | 134 complexity | 2334994b3e1a95d868dba10bd8cf2e80 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
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.