cutils.pas 32 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256
  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. pshortstring = ^string;
  25. Tcharset=set of char;
  26. var
  27. internalerrorproc : procedure(i:longint);
  28. {# Returns the minimal value between @var(a) and @var(b) }
  29. function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  30. function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  31. {# Returns the maximum value between @var(a) and @var(b) }
  32. function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  33. function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  34. {# Returns the value in @var(x) swapped to different endian }
  35. Function SwapInt64(x : int64): int64;{$ifdef USEINLINE}inline;{$endif}
  36. {# Returns the value in @var(x) swapped to different endian }
  37. function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
  38. {# Returns the value in @va(x) swapped to different endian }
  39. function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
  40. {# Returns the value in @va(x) swapped to different endian }
  41. Function SwapQWord(x : qword) : qword;{$ifdef USEINLINE}inline;{$endif}
  42. {# Return value @var(i) aligned on @var(a) boundary }
  43. function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
  44. function used_align(varalign,minalign,maxalign:shortint):shortint;
  45. function isbetteralignedthan(new, org, limit: cardinal): boolean;
  46. function size_2_align(len : longint) : shortint;
  47. function packedbitsloadsize(bitlen: int64) : int64;
  48. procedure Replace(var s:string;s1:string;const s2:string);
  49. procedure Replace(var s:AnsiString;s1:string;const s2:AnsiString);
  50. procedure ReplaceCase(var s:string;const s1,s2:string);
  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 trimbspace(const s:string):string;
  59. function trimspace(const s:string):string;
  60. function space (b : longint): string;
  61. function PadSpace(const s:string;len:longint):string;
  62. function GetToken(var s:string;endchar:char):string;
  63. procedure uppervar(var s : string);
  64. function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
  65. function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  66. function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  67. function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  68. function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
  69. function DStr(l:longint):string;
  70. {# Returns true if the string s is a number }
  71. function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
  72. {# Returns true if value is a power of 2, the actual
  73. exponent value is returned in power.
  74. }
  75. function ispowerof2(value : int64;out power : longint) : boolean;
  76. function nextpowerof2(value : int64; out power: longint) : int64;
  77. function backspace_quote(const s:string;const qchars:Tcharset):string;
  78. function octal_quote(const s:string;const qchars:Tcharset):string;
  79. function maybequoted(const s:string):string;
  80. function maybequoted(const s:ansistring):ansistring;
  81. {# If the string is quoted, in accordance with pascal, it is
  82. dequoted and returned in s, and the function returns true.
  83. If it is not quoted, or if the quoting is bad, s is not touched,
  84. and false is returned.
  85. }
  86. function DePascalQuote(var s: ansistring): Boolean;
  87. function CompareStr(const S1, S2: string): Integer;
  88. function CompareText(S1, S2: string): integer;
  89. { releases the string p and assignes nil to p }
  90. { if p=nil then freemem isn't called }
  91. procedure stringdispose(var p : pshortstring);{$ifdef USEINLINE}inline;{$endif}
  92. { allocates mem for a copy of s, copies s to this mem and returns }
  93. { a pointer to this mem }
  94. function stringdup(const s : string) : pshortstring;{$ifdef USEINLINE}inline;{$endif}
  95. {# Allocates memory for the string @var(s) and copies s as zero
  96. terminated string to that allocated memory and returns a pointer
  97. to that mem
  98. }
  99. function strpnew(const s : string) : pchar;
  100. {# makes the character @var(c) lowercase, with spanish, french and german
  101. character set
  102. }
  103. function lowercase(c : char) : char;
  104. { makes zero terminated string to a pascal string }
  105. { the data in p is modified and p is returned }
  106. function pchar2pshortstring(p : pchar) : pshortstring;
  107. { ambivalent to pchar2pshortstring }
  108. function pshortstring2pchar(p : pshortstring) : pchar;
  109. { Ansistring (pchar+length) support }
  110. procedure ansistringdispose(var p : pchar;length : longint);
  111. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  112. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  113. {Lzw encode/decode to compress strings -> save memory.}
  114. function minilzw_encode(const s:string):string;
  115. function minilzw_decode(const s:string):string;
  116. implementation
  117. uses
  118. SysUtils;
  119. var
  120. uppertbl,
  121. lowertbl : array[char] of char;
  122. function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  123. {
  124. return the minimal of a and b
  125. }
  126. begin
  127. if a<=b then
  128. min:=a
  129. else
  130. min:=b;
  131. end;
  132. function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  133. {
  134. return the minimal of a and b
  135. }
  136. begin
  137. if a<=b then
  138. min:=a
  139. else
  140. min:=b;
  141. end;
  142. function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  143. {
  144. return the maximum of a and b
  145. }
  146. begin
  147. if a>=b then
  148. max:=a
  149. else
  150. max:=b;
  151. end;
  152. function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
  153. {
  154. return the maximum of a and b
  155. }
  156. begin
  157. if a>=b then
  158. max:=a
  159. else
  160. max:=b;
  161. end;
  162. Function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
  163. var
  164. y : word;
  165. z : word;
  166. Begin
  167. y := x shr 16;
  168. y := word(longint(y) shl 8) or (y shr 8);
  169. z := x and $FFFF;
  170. z := word(longint(z) shl 8) or (z shr 8);
  171. SwapLong := (longint(z) shl 16) or longint(y);
  172. End;
  173. Function SwapInt64(x : int64): int64;{$ifdef USEINLINE}inline;{$endif}
  174. Begin
  175. result:=swaplong(longint(hi(x)));
  176. result:=result or (swaplong(longint(lo(x))) shl 32);
  177. End;
  178. Function SwapQWord(x : qword) : qword;{$ifdef USEINLINE}inline;{$endif}
  179. Begin
  180. result:=swaplong(longint(hi(x)));
  181. result:=result or (swaplong(longint(lo(x))) shl 32);
  182. End;
  183. Function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
  184. var
  185. z : byte;
  186. Begin
  187. z := x shr 8;
  188. x := x and $ff;
  189. x := (x shl 8);
  190. SwapWord := x or z;
  191. End;
  192. function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
  193. {
  194. return value <i> aligned <a> boundary
  195. }
  196. begin
  197. { for 0 and 1 no aligning is needed }
  198. if a<=1 then
  199. result:=i
  200. else
  201. begin
  202. if i<0 then
  203. result:=((i-a+1) div a) * a
  204. else
  205. result:=((i+a-1) div a) * a;
  206. end;
  207. end;
  208. function size_2_align(len : longint) : shortint;
  209. begin
  210. if len>16 then
  211. size_2_align:=32
  212. else if len>8 then
  213. size_2_align:=16
  214. else if len>4 then
  215. size_2_align:=8
  216. else if len>2 then
  217. size_2_align:=4
  218. else if len>1 then
  219. size_2_align:=2
  220. else
  221. size_2_align:=1;
  222. end;
  223. function packedbitsloadsize(bitlen: int64) : int64;
  224. begin
  225. case bitlen of
  226. 1,2,4,8:
  227. result := 1;
  228. { 10 bits can never be split over 3 bytes via 1-8-1, because it }
  229. { always starts at a multiple of 10 bits. Same for the others. }
  230. 3,5,7,9,10,12,16:
  231. result := 2;
  232. {$ifdef cpu64bit}
  233. 11,13,14,15,17..26,28,32:
  234. result := 4;
  235. else
  236. result := 8;
  237. {$else cpu64bit}
  238. else
  239. result := 4;
  240. {$endif cpu64bit}
  241. end;
  242. end;
  243. function isbetteralignedthan(new, org, limit: cardinal): boolean;
  244. var
  245. cnt: cardinal;
  246. begin
  247. cnt:=2;
  248. while (cnt <= limit) do
  249. begin
  250. if (org and (cnt-1)) > (new and (cnt-1)) then
  251. begin
  252. result:=true;
  253. exit;
  254. end
  255. else if (org and (cnt-1)) < (new and (cnt-1)) then
  256. begin
  257. result:=false;
  258. exit;
  259. end;
  260. cnt:=cnt*2;
  261. end;
  262. result:=false;
  263. end;
  264. function used_align(varalign,minalign,maxalign:shortint):shortint;
  265. begin
  266. { varalign : minimum alignment required for the variable
  267. minalign : Minimum alignment of this structure, 0 = undefined
  268. maxalign : Maximum alignment of this structure, 0 = undefined }
  269. if (minalign>0) and
  270. (varalign<minalign) then
  271. used_align:=minalign
  272. else
  273. begin
  274. if (maxalign>0) and
  275. (varalign>maxalign) then
  276. used_align:=maxalign
  277. else
  278. used_align:=varalign;
  279. end;
  280. end;
  281. procedure Replace(var s:string;s1:string;const s2:string);
  282. var
  283. last,
  284. i : longint;
  285. begin
  286. s1:=upper(s1);
  287. last:=0;
  288. repeat
  289. i:=pos(s1,upper(s));
  290. if i=last then
  291. i:=0;
  292. if (i>0) then
  293. begin
  294. Delete(s,i,length(s1));
  295. Insert(s2,s,i);
  296. last:=i;
  297. end;
  298. until (i=0);
  299. end;
  300. procedure Replace(var s:AnsiString;s1:string;const s2:AnsiString);
  301. var
  302. last,
  303. i : longint;
  304. begin
  305. s1:=upper(s1);
  306. last:=0;
  307. repeat
  308. i:=pos(s1,upper(s));
  309. if i=last then
  310. i:=0;
  311. if (i>0) then
  312. begin
  313. Delete(s,i,length(s1));
  314. Insert(s2,s,i);
  315. last:=i;
  316. end;
  317. until (i=0);
  318. end;
  319. procedure ReplaceCase(var s:string;const s1,s2:string);
  320. var
  321. last,
  322. i : longint;
  323. begin
  324. last:=0;
  325. repeat
  326. i:=pos(s1,s);
  327. if i=last then
  328. i:=0;
  329. if (i>0) then
  330. begin
  331. Delete(s,i,length(s1));
  332. Insert(s2,s,i);
  333. last:=i;
  334. end;
  335. until (i=0);
  336. end;
  337. Function MatchPattern(const pattern,what:string):boolean;
  338. var
  339. found : boolean;
  340. i1,i2 : longint;
  341. begin
  342. i1:=0;
  343. i2:=0;
  344. if pattern='' then
  345. begin
  346. result:=(what='');
  347. exit;
  348. end;
  349. found:=true;
  350. repeat
  351. inc(i1);
  352. if (i1>length(pattern)) then
  353. break;
  354. inc(i2);
  355. if (i2>length(what)) then
  356. break;
  357. case pattern[i1] of
  358. '?' :
  359. found:=true;
  360. '*' :
  361. begin
  362. found:=true;
  363. if (i1=length(pattern)) then
  364. i2:=length(what)
  365. else
  366. if (i1<length(pattern)) and (pattern[i1+1]<>what[i2]) then
  367. begin
  368. if i2<length(what) then
  369. dec(i1)
  370. end
  371. else
  372. if i2>1 then
  373. dec(i2);
  374. end;
  375. else
  376. found:=(pattern[i1]=what[i2]) or (what[i2]='?');
  377. end;
  378. until not found;
  379. if found then
  380. begin
  381. found:=(i2>=length(what)) and
  382. (
  383. (i1>length(pattern)) or
  384. ((i1=length(pattern)) and
  385. (pattern[i1]='*'))
  386. );
  387. end;
  388. result:=found;
  389. end;
  390. function upper(const c : char) : char;
  391. {
  392. return uppercase of c
  393. }
  394. begin
  395. upper:=uppertbl[c];
  396. end;
  397. function upper(const s : string) : string;
  398. {
  399. return uppercased string of s
  400. }
  401. var
  402. i : longint;
  403. begin
  404. for i:=1 to length(s) do
  405. upper[i]:=uppertbl[s[i]];
  406. upper[0]:=s[0];
  407. end;
  408. function upper(const s : ansistring) : ansistring;
  409. {
  410. return uppercased string of s
  411. }
  412. var
  413. i : longint;
  414. begin
  415. setlength(upper,length(s));
  416. for i:=1 to length(s) do
  417. upper[i]:=uppertbl[s[i]];
  418. end;
  419. function lower(const c : char) : char;
  420. {
  421. return lowercase of c
  422. }
  423. begin
  424. lower:=lowertbl[c];
  425. end;
  426. function lower(const s : string) : string;
  427. {
  428. return lowercased string of s
  429. }
  430. var
  431. i : longint;
  432. begin
  433. for i:=1 to length(s) do
  434. lower[i]:=lowertbl[s[i]];
  435. lower[0]:=s[0];
  436. end;
  437. function lower(const s : ansistring) : ansistring;
  438. {
  439. return lowercased string of s
  440. }
  441. var
  442. i : longint;
  443. begin
  444. setlength(lower,length(s));
  445. for i:=1 to length(s) do
  446. lower[i]:=lowertbl[s[i]];
  447. end;
  448. procedure uppervar(var s : string);
  449. {
  450. uppercase string s
  451. }
  452. var
  453. i : longint;
  454. begin
  455. for i:=1 to length(s) do
  456. s[i]:=uppertbl[s[i]];
  457. end;
  458. procedure initupperlower;
  459. var
  460. c : char;
  461. begin
  462. for c:=#0 to #255 do
  463. begin
  464. lowertbl[c]:=c;
  465. uppertbl[c]:=c;
  466. case c of
  467. 'A'..'Z' :
  468. lowertbl[c]:=char(byte(c)+32);
  469. 'a'..'z' :
  470. uppertbl[c]:=char(byte(c)-32);
  471. end;
  472. end;
  473. end;
  474. function DStr(l:longint):string;
  475. var
  476. TmpStr : string[32];
  477. i : longint;
  478. begin
  479. Str(l,TmpStr);
  480. i:=Length(TmpStr);
  481. while (i>3) do
  482. begin
  483. dec(i,3);
  484. if TmpStr[i]<>'-' then
  485. insert('.',TmpStr,i+1);
  486. end;
  487. DStr:=TmpStr;
  488. end;
  489. function trimbspace(const s:string):string;
  490. {
  491. return s with all leading spaces and tabs removed
  492. }
  493. var
  494. i,j : longint;
  495. begin
  496. j:=1;
  497. i:=length(s);
  498. while (j<i) and (s[j] in [#9,' ']) do
  499. inc(j);
  500. trimbspace:=Copy(s,j,i-j+1);
  501. end;
  502. function trimspace(const s:string):string;
  503. {
  504. return s with all leading and ending spaces and tabs removed
  505. }
  506. var
  507. i,j : longint;
  508. begin
  509. i:=length(s);
  510. while (i>0) and (s[i] in [#9,' ']) do
  511. dec(i);
  512. j:=1;
  513. while (j<i) and (s[j] in [#9,' ']) do
  514. inc(j);
  515. trimspace:=Copy(s,j,i-j+1);
  516. end;
  517. function space (b : longint): string;
  518. var
  519. s: string;
  520. begin
  521. space[0] := chr(b);
  522. s[0] := chr(b);
  523. FillChar (S[1],b,' ');
  524. space:=s;
  525. end;
  526. function PadSpace(const s:string;len:longint):string;
  527. {
  528. return s with spaces add to the end
  529. }
  530. begin
  531. if length(s)<len then
  532. PadSpace:=s+Space(len-length(s))
  533. else
  534. PadSpace:=s;
  535. end;
  536. function GetToken(var s:string;endchar:char):string;
  537. var
  538. i : longint;
  539. quote : char;
  540. begin
  541. GetToken:='';
  542. s:=TrimSpace(s);
  543. if (length(s)>0) and
  544. (s[1] in ['''','"']) then
  545. begin
  546. quote:=s[1];
  547. i:=1;
  548. while (i<length(s)) do
  549. begin
  550. inc(i);
  551. if s[i]=quote then
  552. begin
  553. { Remove double quote }
  554. if (i<length(s)) and
  555. (s[i+1]=quote) then
  556. begin
  557. Delete(s,i,1);
  558. inc(i);
  559. end
  560. else
  561. begin
  562. GetToken:=Copy(s,2,i-2);
  563. Delete(s,1,i);
  564. exit;
  565. end;
  566. end;
  567. end;
  568. GetToken:=s;
  569. s:='';
  570. end
  571. else
  572. begin
  573. i:=pos(EndChar,s);
  574. if i=0 then
  575. begin
  576. GetToken:=s;
  577. s:='';
  578. exit;
  579. end
  580. else
  581. begin
  582. GetToken:=Copy(s,1,i-1);
  583. Delete(s,1,i);
  584. exit;
  585. end;
  586. end;
  587. end;
  588. function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
  589. begin
  590. str(e,result);
  591. end;
  592. function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  593. {
  594. return string of value i
  595. }
  596. begin
  597. str(i,result);
  598. end;
  599. function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  600. {
  601. return string of value i
  602. }
  603. begin
  604. str(i,result);
  605. end;
  606. function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
  607. {
  608. return string of value i
  609. }
  610. begin
  611. str(i,result);
  612. end;
  613. function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
  614. {
  615. return string of value i, but always include a + when i>=0
  616. }
  617. begin
  618. str(i,result);
  619. if i>=0 then
  620. result:='+'+result;
  621. end;
  622. function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
  623. {
  624. is string a correct number ?
  625. }
  626. var
  627. w : integer;
  628. l : longint;
  629. begin
  630. val(s,l,w);
  631. // remove warning
  632. l:=l;
  633. is_number:=(w=0);
  634. end;
  635. function ispowerof2(value : int64;out power : longint) : boolean;
  636. {
  637. return if value is a power of 2. And if correct return the power
  638. }
  639. var
  640. hl : int64;
  641. i : longint;
  642. begin
  643. if value and (value - 1) <> 0 then
  644. begin
  645. ispowerof2 := false;
  646. exit
  647. end;
  648. hl:=1;
  649. ispowerof2:=true;
  650. for i:=0 to 63 do
  651. begin
  652. if hl=value then
  653. begin
  654. power:=i;
  655. exit;
  656. end;
  657. hl:=hl shl 1;
  658. end;
  659. ispowerof2:=false;
  660. end;
  661. function nextpowerof2(value : int64; out power: longint) : int64;
  662. {
  663. returns the power of 2 >= value
  664. }
  665. var
  666. i : longint;
  667. begin
  668. result := 0;
  669. power := -1;
  670. if ((value <= 0) or
  671. (value >= $4000000000000000)) then
  672. exit;
  673. result := 1;
  674. for i:=0 to 63 do
  675. begin
  676. if result>=value then
  677. begin
  678. power := i;
  679. exit;
  680. end;
  681. result:=result shl 1;
  682. end;
  683. end;
  684. function backspace_quote(const s:string;const qchars:Tcharset):string;
  685. var i:byte;
  686. begin
  687. backspace_quote:='';
  688. for i:=1 to length(s) do
  689. begin
  690. if (s[i]=#10) and (#10 in qchars) then
  691. backspace_quote:=backspace_quote+'\n'
  692. else if (s[i]=#13) and (#13 in qchars) then
  693. backspace_quote:=backspace_quote+'\r'
  694. else
  695. begin
  696. if s[i] in qchars then
  697. backspace_quote:=backspace_quote+'\';
  698. backspace_quote:=backspace_quote+s[i];
  699. end;
  700. end;
  701. end;
  702. function octal_quote(const s:string;const qchars:Tcharset):string;
  703. var i:byte;
  704. begin
  705. octal_quote:='';
  706. for i:=1 to length(s) do
  707. begin
  708. if s[i] in qchars then
  709. begin
  710. if ord(s[i])<64 then
  711. octal_quote:=octal_quote+'\'+octstr(ord(s[i]),3)
  712. else
  713. octal_quote:=octal_quote+'\'+octstr(ord(s[i]),4);
  714. end
  715. else
  716. octal_quote:=octal_quote+s[i];
  717. end;
  718. end;
  719. function maybequoted(const s:ansistring):ansistring;
  720. const
  721. {$IFDEF MSWINDOWS}
  722. FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
  723. '{', '}', '''', '`', '~'];
  724. {$ELSE}
  725. FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
  726. '{', '}', '''', ':', '\', '`', '~'];
  727. {$ENDIF}
  728. var
  729. s1 : ansistring;
  730. i : integer;
  731. quoted : boolean;
  732. begin
  733. quoted:=false;
  734. s1:='"';
  735. for i:=1 to length(s) do
  736. begin
  737. case s[i] of
  738. '"' :
  739. begin
  740. quoted:=true;
  741. s1:=s1+'\"';
  742. end;
  743. ' ',
  744. #128..#255 :
  745. begin
  746. quoted:=true;
  747. s1:=s1+s[i];
  748. end;
  749. else begin
  750. if s[i] in FORBIDDEN_CHARS then
  751. quoted:=True;
  752. s1:=s1+s[i];
  753. end;
  754. end;
  755. end;
  756. if quoted then
  757. maybequoted:=s1+'"'
  758. else
  759. maybequoted:=s;
  760. end;
  761. function maybequoted(const s:string):string;
  762. const
  763. {$IFDEF MSWINDOWS}
  764. FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
  765. '{', '}', '''', '`', '~'];
  766. {$ELSE}
  767. FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
  768. '{', '}', '''', ':', '\', '`', '~'];
  769. {$ENDIF}
  770. var
  771. s1 : string;
  772. i : integer;
  773. quoted : boolean;
  774. begin
  775. quoted:=false;
  776. s1:='"';
  777. for i:=1 to length(s) do
  778. begin
  779. case s[i] of
  780. '"' :
  781. begin
  782. quoted:=true;
  783. s1:=s1+'\"';
  784. end;
  785. ' ',
  786. #128..#255 :
  787. begin
  788. quoted:=true;
  789. s1:=s1+s[i];
  790. end;
  791. else begin
  792. if s[i] in FORBIDDEN_CHARS then
  793. quoted:=True;
  794. s1:=s1+s[i];
  795. end;
  796. end;
  797. end;
  798. if quoted then
  799. maybequoted:=s1+'"'
  800. else
  801. maybequoted:=s;
  802. end;
  803. function DePascalQuote(var s: ansistring): Boolean;
  804. var
  805. destPos, sourcePos, len: Integer;
  806. t: string;
  807. ch: Char;
  808. begin
  809. DePascalQuote:= false;
  810. len:= length(s);
  811. if (len >= 1) and (s[1] = '''') then
  812. begin
  813. {Remove quotes, exchange '' against ' }
  814. destPos := 0;
  815. sourcepos:=1;
  816. while (sourcepos<len) do
  817. begin
  818. inc(sourcePos);
  819. ch := s[sourcePos];
  820. if ch = '''' then
  821. begin
  822. inc(sourcePos);
  823. if (sourcePos <= len) and (s[sourcePos] = '''') then
  824. {Add the quote as part of string}
  825. else
  826. begin
  827. SetLength(t, destPos);
  828. s:= t;
  829. Exit(true);
  830. end;
  831. end;
  832. inc(destPos);
  833. t[destPos] := ch;
  834. end;
  835. end;
  836. end;
  837. function pchar2pshortstring(p : pchar) : pshortstring;
  838. var
  839. w,i : longint;
  840. begin
  841. w:=strlen(p);
  842. for i:=w-1 downto 0 do
  843. p[i+1]:=p[i];
  844. p[0]:=chr(w);
  845. pchar2pshortstring:=pshortstring(p);
  846. end;
  847. function pshortstring2pchar(p : pshortstring) : pchar;
  848. var
  849. w,i : longint;
  850. begin
  851. w:=length(p^);
  852. for i:=1 to w do
  853. p^[i-1]:=p^[i];
  854. p^[w]:=#0;
  855. pshortstring2pchar:=pchar(p);
  856. end;
  857. function lowercase(c : char) : char;
  858. begin
  859. case c of
  860. #65..#90 : c := chr(ord (c) + 32);
  861. #154 : c:=#129; { german }
  862. #142 : c:=#132; { german }
  863. #153 : c:=#148; { german }
  864. #144 : c:=#130; { french }
  865. #128 : c:=#135; { french }
  866. #143 : c:=#134; { swedish/norge (?) }
  867. #165 : c:=#164; { spanish }
  868. #228 : c:=#229; { greek }
  869. #226 : c:=#231; { greek }
  870. #232 : c:=#227; { greek }
  871. end;
  872. lowercase := c;
  873. end;
  874. function strpnew(const s : string) : pchar;
  875. var
  876. p : pchar;
  877. begin
  878. getmem(p,length(s)+1);
  879. move(s[1],p^,length(s));
  880. p[length(s)]:=#0;
  881. result:=p;
  882. end;
  883. procedure stringdispose(var p : pshortstring);{$ifdef USEINLINE}inline;{$endif}
  884. begin
  885. if assigned(p) then
  886. begin
  887. freemem(p);
  888. p:=nil;
  889. end;
  890. end;
  891. function stringdup(const s : string) : pshortstring;{$ifdef USEINLINE}inline;{$endif}
  892. begin
  893. getmem(result,length(s)+1);
  894. result^:=s;
  895. end;
  896. function CompareStr(const S1, S2: string): Integer;
  897. var
  898. count, count1, count2: integer;
  899. begin
  900. result := 0;
  901. Count1 := Length(S1);
  902. Count2 := Length(S2);
  903. if Count1>Count2 then
  904. Count:=Count2
  905. else
  906. Count:=Count1;
  907. result := CompareChar(S1[1],S2[1], Count);
  908. if result=0 then
  909. result:=Count1-Count2;
  910. end;
  911. function CompareText(S1, S2: string): integer;
  912. begin
  913. UpperVar(S1);
  914. UpperVar(S2);
  915. Result:=CompareStr(S1,S2);
  916. end;
  917. {*****************************************************************************
  918. Ansistring (PChar+Length)
  919. *****************************************************************************}
  920. procedure ansistringdispose(var p : pchar;length : longint);
  921. begin
  922. if assigned(p) then
  923. begin
  924. freemem(p);
  925. p:=nil;
  926. end;
  927. end;
  928. { enable ansistring comparison }
  929. { 0 means equal }
  930. { 1 means p1 > p2 }
  931. { -1 means p1 < p2 }
  932. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  933. var
  934. i,j : longint;
  935. begin
  936. compareansistrings:=0;
  937. j:=min(length1,length2);
  938. i:=0;
  939. while (i<j) do
  940. begin
  941. if p1[i]>p2[i] then
  942. begin
  943. compareansistrings:=1;
  944. exit;
  945. end
  946. else
  947. if p1[i]<p2[i] then
  948. begin
  949. compareansistrings:=-1;
  950. exit;
  951. end;
  952. inc(i);
  953. end;
  954. if length1>length2 then
  955. compareansistrings:=1
  956. else
  957. if length1<length2 then
  958. compareansistrings:=-1;
  959. end;
  960. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  961. var
  962. p : pchar;
  963. begin
  964. getmem(p,length1+length2+1);
  965. move(p1[0],p[0],length1);
  966. move(p2[0],p[length1],length2+1);
  967. concatansistrings:=p;
  968. end;
  969. {*****************************************************************************
  970. Ultra basic KISS Lzw (de)compressor
  971. *****************************************************************************}
  972. {This is an extremely basic implementation of the Lzw algorithm. It
  973. compresses 7-bit ASCII strings into 8-bit compressed strings.
  974. The Lzw dictionary is preinitialized with 0..127, therefore this
  975. part of the dictionary does not need to be stored in the arrays.
  976. The Lzw code size is allways 8 bit, so we do not need complex code
  977. that can write partial bytes.}
  978. function minilzw_encode(const s:string):string;
  979. var t,u,i:byte;
  980. c:char;
  981. data:array[128..255] of char;
  982. previous:array[128..255] of byte;
  983. lzwptr:byte;
  984. next_avail:set of 0..255;
  985. label l1;
  986. begin
  987. minilzw_encode:='';
  988. fillchar(data,sizeof(data),#0);
  989. fillchar(previous,sizeof(previous),#0);
  990. if s<>'' then
  991. begin
  992. lzwptr:=127;
  993. t:=byte(s[1]);
  994. i:=2;
  995. u:=128;
  996. next_avail:=[];
  997. while i<=length(s) do
  998. begin
  999. c:=s[i];
  1000. if not(t in next_avail) or (u>lzwptr) then goto l1;
  1001. while (previous[u]<>t) or (data[u]<>c) do
  1002. begin
  1003. inc(u);
  1004. if u>lzwptr then goto l1;
  1005. end;
  1006. t:=u;
  1007. inc(i);
  1008. continue;
  1009. l1:
  1010. {It's a pity that we still need those awfull tricks
  1011. with this modern compiler. Without this performance
  1012. of the entire procedure drops about 3 times.}
  1013. inc(minilzw_encode[0]);
  1014. minilzw_encode[length(minilzw_encode)]:=char(t);
  1015. if lzwptr=255 then
  1016. begin
  1017. lzwptr:=127;
  1018. next_avail:=[];
  1019. end
  1020. else
  1021. begin
  1022. inc(lzwptr);
  1023. data[lzwptr]:=c;
  1024. previous[lzwptr]:=t;
  1025. include(next_avail,t);
  1026. end;
  1027. t:=byte(c);
  1028. u:=128;
  1029. inc(i);
  1030. end;
  1031. inc(minilzw_encode[0]);
  1032. minilzw_encode[length(minilzw_encode)]:=char(t);
  1033. end;
  1034. end;
  1035. function minilzw_decode(const s:string):string;
  1036. var oldc,newc,c:char;
  1037. i,j:byte;
  1038. data:array[128..255] of char;
  1039. previous:array[128..255] of byte;
  1040. lzwptr:byte;
  1041. t:string;
  1042. begin
  1043. minilzw_decode:='';
  1044. fillchar(data,sizeof(data),#0);
  1045. fillchar(previous,sizeof(previous),#0);
  1046. if s<>'' then
  1047. begin
  1048. lzwptr:=127;
  1049. oldc:=s[1];
  1050. c:=oldc;
  1051. i:=2;
  1052. minilzw_decode:=oldc;
  1053. while i<=length(s) do
  1054. begin
  1055. newc:=s[i];
  1056. if byte(newc)>lzwptr then
  1057. begin
  1058. t:=c;
  1059. c:=oldc;
  1060. end
  1061. else
  1062. begin
  1063. c:=newc;
  1064. t:='';
  1065. end;
  1066. while c>=#128 do
  1067. begin
  1068. inc(t[0]);
  1069. t[length(t)]:=data[byte(c)];
  1070. byte(c):=previous[byte(c)];
  1071. end;
  1072. inc(minilzw_decode[0]);
  1073. minilzw_decode[length(minilzw_decode)]:=c;
  1074. for j:=length(t) downto 1 do
  1075. begin
  1076. inc(minilzw_decode[0]);
  1077. minilzw_decode[length(minilzw_decode)]:=t[j];
  1078. end;
  1079. if lzwptr=255 then
  1080. lzwptr:=127
  1081. else
  1082. begin
  1083. inc(lzwptr);
  1084. previous[lzwptr]:=byte(oldc);
  1085. data[lzwptr]:=c;
  1086. end;
  1087. oldc:=newc;
  1088. inc(i);
  1089. end;
  1090. end;
  1091. end;
  1092. procedure defaulterror(i:longint);
  1093. begin
  1094. writeln('Internal error ',i);
  1095. runerror(255);
  1096. end;
  1097. initialization
  1098. internalerrorproc:=@defaulterror;
  1099. initupperlower;
  1100. end.