/compiler/cutils.pas

https://github.com/slibre/freepascal · Pascal · 1470 lines · 1097 code · 178 blank · 195 comment · 135 complexity · 2334994b3e1a95d868dba10bd8cf2e80 MD5 · raw file

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