cutils.pas 27 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. This unit implements some support functions
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published
  7. by the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. {# This unit contains some generic support functions which are used
  19. in the different parts of the compiler.
  20. }
  21. unit cutils;
  22. {$i fpcdefs.inc}
  23. interface
  24. type
  25. pstring = ^string;
  26. {# Returns the minimal value between @var(a) and @var(b) }
  27. function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  28. {# Returns the maximum value between @var(a) and @var(b) }
  29. function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  30. {# Returns the value in @var(x) swapped to different endian }
  31. function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
  32. {# Returns the value in @va(x) swapped to different endian }
  33. function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
  34. {# Return value @var(i) aligned on @var(a) boundary }
  35. function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
  36. function used_align(varalign,minalign,maxalign:longint):longint;
  37. function size_2_align(len : longint) : longint;
  38. procedure Replace(var s:string;s1:string;const s2:string);
  39. procedure ReplaceCase(var s:string;const s1,s2:string);
  40. function upper(const s : string) : string;
  41. function lower(const s : string) : string;
  42. function trimbspace(const s:string):string;
  43. function trimspace(const s:string):string;
  44. function space (b : longint): string;
  45. function PadSpace(const s:string;len:longint):string;
  46. function GetToken(var s:string;endchar:char):string;
  47. procedure uppervar(var s : string);
  48. function hexstr(val : cardinal;cnt : cardinal) : string;
  49. function tostru(i:cardinal) : string;{$ifdef USEINLINE}inline;{$endif}
  50. function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
  51. function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
  52. function int64tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
  53. function tostr_with_plus(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
  54. function DStr(l:longint):string;
  55. procedure valint(S : string;var V : longint;var code : integer);
  56. {# Returns true if the string s is a number }
  57. function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
  58. {# Returns true if value is a power of 2, the actual
  59. exponent value is returned in power.
  60. }
  61. function ispowerof2(value : int64;var power : longint) : boolean;
  62. function maybequoted(const s:string):string;
  63. function CompareText(S1, S2: string): longint;
  64. { releases the string p and assignes nil to p }
  65. { if p=nil then freemem isn't called }
  66. procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
  67. { allocates mem for a copy of s, copies s to this mem and returns }
  68. { a pointer to this mem }
  69. function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
  70. {# Allocates memory for the string @var(s) and copies s as zero
  71. terminated string to that allocated memory and returns a pointer
  72. to that mem
  73. }
  74. function strpnew(const s : string) : pchar;
  75. procedure strdispose(var p : pchar);
  76. {# makes the character @var(c) lowercase, with spanish, french and german
  77. character set
  78. }
  79. function lowercase(c : char) : char;
  80. { makes zero terminated string to a pascal string }
  81. { the data in p is modified and p is returned }
  82. function pchar2pstring(p : pchar) : pstring;
  83. { ambivalent to pchar2pstring }
  84. function pstring2pchar(p : pstring) : pchar;
  85. { Speed/Hash value }
  86. Function GetSpeedValue(Const s:String):cardinal;
  87. { Ansistring (pchar+length) support }
  88. procedure ansistringdispose(var p : pchar;length : longint);
  89. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  90. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  91. function DeleteFile(const fn:string):boolean;
  92. {Lzw encode/decode to compress strings -> save memory.}
  93. function minilzw_encode(const s:string):string;
  94. function minilzw_decode(const s:string):string;
  95. implementation
  96. uses
  97. {$ifdef delphi}
  98. sysutils
  99. {$else}
  100. strings
  101. {$endif}
  102. ;
  103. var
  104. uppertbl,
  105. lowertbl : array[char] of char;
  106. function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  107. {
  108. return the minimal of a and b
  109. }
  110. begin
  111. if a>b then
  112. min:=b
  113. else
  114. min:=a;
  115. end;
  116. function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
  117. {
  118. return the maximum of a and b
  119. }
  120. begin
  121. if a<b then
  122. max:=b
  123. else
  124. max:=a;
  125. end;
  126. Function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
  127. var
  128. y : word;
  129. z : word;
  130. Begin
  131. y := x shr 16;
  132. y := word(longint(y) shl 8) or (y shr 8);
  133. z := x and $FFFF;
  134. z := word(longint(z) shl 8) or (z shr 8);
  135. SwapLong := (longint(z) shl 16) or longint(y);
  136. End;
  137. Function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
  138. var
  139. z : byte;
  140. Begin
  141. z := x shr 8;
  142. x := x and $ff;
  143. x := (x shl 8);
  144. SwapWord := x or z;
  145. End;
  146. function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
  147. {
  148. return value <i> aligned <a> boundary
  149. }
  150. begin
  151. { for 0 and 1 no aligning is needed }
  152. if a<=1 then
  153. align:=i
  154. else
  155. align:=((i+a-1) div a) * a;
  156. end;
  157. function size_2_align(len : longint) : longint;
  158. begin
  159. if len>16 then
  160. size_2_align:=32
  161. else if len>8 then
  162. size_2_align:=16
  163. else if len>4 then
  164. size_2_align:=8
  165. else if len>2 then
  166. size_2_align:=4
  167. else if len>1 then
  168. size_2_align:=2
  169. else
  170. size_2_align:=1;
  171. end;
  172. function used_align(varalign,minalign,maxalign:longint):longint;
  173. begin
  174. { varalign : minimum alignment required for the variable
  175. minalign : Minimum alignment of this structure, 0 = undefined
  176. maxalign : Maximum alignment of this structure, 0 = undefined }
  177. if (minalign>0) and
  178. (varalign<minalign) then
  179. used_align:=minalign
  180. else
  181. begin
  182. if (maxalign>0) and
  183. (varalign>maxalign) then
  184. used_align:=maxalign
  185. else
  186. used_align:=varalign;
  187. end;
  188. end;
  189. procedure Replace(var s:string;s1:string;const s2:string);
  190. var
  191. last,
  192. i : longint;
  193. begin
  194. s1:=upper(s1);
  195. last:=0;
  196. repeat
  197. i:=pos(s1,upper(s));
  198. if i=last then
  199. i:=0;
  200. if (i>0) then
  201. begin
  202. Delete(s,i,length(s1));
  203. Insert(s2,s,i);
  204. last:=i;
  205. end;
  206. until (i=0);
  207. end;
  208. procedure ReplaceCase(var s:string;const s1,s2:string);
  209. var
  210. last,
  211. i : longint;
  212. begin
  213. last:=0;
  214. repeat
  215. i:=pos(s1,s);
  216. if i=last then
  217. i:=0;
  218. if (i>0) then
  219. begin
  220. Delete(s,i,length(s1));
  221. Insert(s2,s,i);
  222. last:=i;
  223. end;
  224. until (i=0);
  225. end;
  226. function upper(const s : string) : string;
  227. {
  228. return uppercased string of s
  229. }
  230. var
  231. i : longint;
  232. begin
  233. for i:=1 to length(s) do
  234. upper[i]:=uppertbl[s[i]];
  235. upper[0]:=s[0];
  236. end;
  237. function lower(const s : string) : string;
  238. {
  239. return lowercased string of s
  240. }
  241. var
  242. i : longint;
  243. begin
  244. for i:=1 to length(s) do
  245. lower[i]:=lowertbl[s[i]];
  246. lower[0]:=s[0];
  247. end;
  248. procedure uppervar(var s : string);
  249. {
  250. uppercase string s
  251. }
  252. var
  253. i : longint;
  254. begin
  255. for i:=1 to length(s) do
  256. s[i]:=uppertbl[s[i]];
  257. end;
  258. procedure initupperlower;
  259. var
  260. c : char;
  261. begin
  262. for c:=#0 to #255 do
  263. begin
  264. lowertbl[c]:=c;
  265. uppertbl[c]:=c;
  266. case c of
  267. 'A'..'Z' :
  268. lowertbl[c]:=char(byte(c)+32);
  269. 'a'..'z' :
  270. uppertbl[c]:=char(byte(c)-32);
  271. end;
  272. end;
  273. end;
  274. function hexstr(val : cardinal;cnt : cardinal) : string;
  275. const
  276. HexTbl : array[0..15] of char='0123456789ABCDEF';
  277. var
  278. i,j : cardinal;
  279. begin
  280. { calculate required length }
  281. i:=0;
  282. j:=val;
  283. while (j>0) do
  284. begin
  285. inc(i);
  286. j:=j shr 4;
  287. end;
  288. { generate fillers }
  289. j:=0;
  290. while (i+j<cnt) do
  291. begin
  292. inc(j);
  293. hexstr[j]:='0';
  294. end;
  295. { generate hex }
  296. inc(j,i);
  297. hexstr[0]:=chr(j);
  298. while (val>0) do
  299. begin
  300. hexstr[j]:=hextbl[val and $f];
  301. dec(j);
  302. val:=val shr 4;
  303. end;
  304. end;
  305. function tostru(i:cardinal):string;{$ifdef USEINLINE}inline;{$endif}
  306. {
  307. return string of value i, but for cardinals
  308. }
  309. begin
  310. str(i,result);
  311. end;
  312. function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
  313. {
  314. return string of value i
  315. }
  316. begin
  317. str(i,result);
  318. end;
  319. function DStr(l:longint):string;
  320. var
  321. TmpStr : string[32];
  322. i : longint;
  323. begin
  324. Str(l,TmpStr);
  325. i:=Length(TmpStr);
  326. while (i>3) do
  327. begin
  328. dec(i,3);
  329. if TmpStr[i]<>'-' then
  330. insert('.',TmpStr,i+1);
  331. end;
  332. DStr:=TmpStr;
  333. end;
  334. function trimbspace(const s:string):string;
  335. {
  336. return s with all leading spaces and tabs removed
  337. }
  338. var
  339. i,j : longint;
  340. begin
  341. j:=1;
  342. i:=length(s);
  343. while (j<i) and (s[j] in [#9,' ']) do
  344. inc(j);
  345. trimbspace:=Copy(s,j,i-j+1);
  346. end;
  347. function trimspace(const s:string):string;
  348. {
  349. return s with all leading and ending spaces and tabs removed
  350. }
  351. var
  352. i,j : longint;
  353. begin
  354. i:=length(s);
  355. while (i>0) and (s[i] in [#9,' ']) do
  356. dec(i);
  357. j:=1;
  358. while (j<i) and (s[j] in [#9,' ']) do
  359. inc(j);
  360. trimspace:=Copy(s,j,i-j+1);
  361. end;
  362. function space (b : longint): string;
  363. var
  364. s: string;
  365. begin
  366. space[0] := chr(b);
  367. s[0] := chr(b);
  368. FillChar (S[1],b,' ');
  369. space:=s;
  370. end;
  371. function PadSpace(const s:string;len:longint):string;
  372. {
  373. return s with spaces add to the end
  374. }
  375. begin
  376. if length(s)<len then
  377. PadSpace:=s+Space(len-length(s))
  378. else
  379. PadSpace:=s;
  380. end;
  381. function GetToken(var s:string;endchar:char):string;
  382. var
  383. i : longint;
  384. begin
  385. GetToken:='';
  386. s:=TrimSpace(s);
  387. if s[1]='''' then
  388. begin
  389. i:=1;
  390. while (i<length(s)) do
  391. begin
  392. inc(i);
  393. if s[i]='''' then
  394. begin
  395. { Remove double quote }
  396. if (i<length(s)) and
  397. (s[i+1]='''') then
  398. begin
  399. Delete(s,i,1);
  400. inc(i);
  401. end
  402. else
  403. begin
  404. GetToken:=Copy(s,2,i-2);
  405. Delete(s,1,i);
  406. exit;
  407. end;
  408. end;
  409. end;
  410. GetToken:=s;
  411. s:='';
  412. end
  413. else
  414. begin
  415. i:=pos(EndChar,s);
  416. if i=0 then
  417. begin
  418. GetToken:=s;
  419. s:='';
  420. exit;
  421. end
  422. else
  423. begin
  424. GetToken:=Copy(s,1,i-1);
  425. Delete(s,1,i);
  426. exit;
  427. end;
  428. end;
  429. end;
  430. function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
  431. begin
  432. str(e,result);
  433. end;
  434. function int64tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
  435. {
  436. return string of value i
  437. }
  438. begin
  439. str(i,result);
  440. end;
  441. function tostr_with_plus(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
  442. {
  443. return string of value i, but always include a + when i>=0
  444. }
  445. begin
  446. str(i,result);
  447. if i>=0 then
  448. result:='+'+result;
  449. end;
  450. procedure valint(S : string;var V : longint;var code : integer);
  451. {
  452. val() with support for octal, which is not supported under tp7
  453. }
  454. {$ifndef FPC}
  455. var
  456. vs : longint;
  457. c : byte;
  458. begin
  459. if s[1]='%' then
  460. begin
  461. vs:=0;
  462. longint(v):=0;
  463. for c:=2 to length(s) do
  464. begin
  465. if s[c]='0' then
  466. vs:=vs shl 1
  467. else
  468. if s[c]='1' then
  469. vs:=vs shl 1+1
  470. else
  471. begin
  472. code:=c;
  473. exit;
  474. end;
  475. end;
  476. code:=0;
  477. longint(v):=vs;
  478. end
  479. else
  480. system.val(S,V,code);
  481. end;
  482. {$else not FPC}
  483. begin
  484. system.val(S,V,code);
  485. end;
  486. {$endif not FPC}
  487. function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
  488. {
  489. is string a correct number ?
  490. }
  491. var
  492. w : integer;
  493. l : longint;
  494. begin
  495. valint(s,l,w);
  496. is_number:=(w=0);
  497. end;
  498. function ispowerof2(value : int64;var power : longint) : boolean;
  499. {
  500. return if value is a power of 2. And if correct return the power
  501. }
  502. var
  503. hl : int64;
  504. i : longint;
  505. begin
  506. if value and (value - 1) <> 0 then
  507. begin
  508. ispowerof2 := false;
  509. exit
  510. end;
  511. hl:=1;
  512. ispowerof2:=true;
  513. for i:=0 to 63 do
  514. begin
  515. if hl=value then
  516. begin
  517. power:=i;
  518. exit;
  519. end;
  520. hl:=hl shl 1;
  521. end;
  522. ispowerof2:=false;
  523. end;
  524. function maybequoted(const s:string):string;
  525. var
  526. s1 : string;
  527. i : integer;
  528. quoted : boolean;
  529. begin
  530. quoted:=false;
  531. s1:='"';
  532. for i:=1 to length(s) do
  533. begin
  534. case s[i] of
  535. '"' :
  536. begin
  537. quoted:=true;
  538. s1:=s1+'\"';
  539. end;
  540. ' ',
  541. #128..#255 :
  542. begin
  543. quoted:=true;
  544. s1:=s1+s[i];
  545. end;
  546. else
  547. s1:=s1+s[i];
  548. end;
  549. end;
  550. if quoted then
  551. maybequoted:=s1+'"'
  552. else
  553. maybequoted:=s;
  554. end;
  555. function pchar2pstring(p : pchar) : pstring;
  556. var
  557. w,i : longint;
  558. begin
  559. w:=strlen(p);
  560. for i:=w-1 downto 0 do
  561. p[i+1]:=p[i];
  562. p[0]:=chr(w);
  563. pchar2pstring:=pstring(p);
  564. end;
  565. function pstring2pchar(p : pstring) : pchar;
  566. var
  567. w,i : longint;
  568. begin
  569. w:=length(p^);
  570. for i:=1 to w do
  571. p^[i-1]:=p^[i];
  572. p^[w]:=#0;
  573. pstring2pchar:=pchar(p);
  574. end;
  575. function lowercase(c : char) : char;
  576. begin
  577. case c of
  578. #65..#90 : c := chr(ord (c) + 32);
  579. #154 : c:=#129; { german }
  580. #142 : c:=#132; { german }
  581. #153 : c:=#148; { german }
  582. #144 : c:=#130; { french }
  583. #128 : c:=#135; { french }
  584. #143 : c:=#134; { swedish/norge (?) }
  585. #165 : c:=#164; { spanish }
  586. #228 : c:=#229; { greek }
  587. #226 : c:=#231; { greek }
  588. #232 : c:=#227; { greek }
  589. end;
  590. lowercase := c;
  591. end;
  592. function strpnew(const s : string) : pchar;
  593. var
  594. p : pchar;
  595. begin
  596. getmem(p,length(s)+1);
  597. strpcopy(p,s);
  598. strpnew:=p;
  599. end;
  600. procedure strdispose(var p : pchar);
  601. begin
  602. if assigned(p) then
  603. begin
  604. freemem(p,strlen(p)+1);
  605. p:=nil;
  606. end;
  607. end;
  608. procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
  609. begin
  610. if assigned(p) then
  611. begin
  612. freemem(p,length(p^)+1);
  613. p:=nil;
  614. end;
  615. end;
  616. function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
  617. begin
  618. getmem(result,length(s)+1);
  619. result^:=s;
  620. end;
  621. function CompareText(S1, S2: string): longint;
  622. begin
  623. UpperVar(S1);
  624. UpperVar(S2);
  625. if S1<S2 then
  626. CompareText:=-1
  627. else
  628. if S1>S2 then
  629. CompareText:= 1
  630. else
  631. CompareText:=0;
  632. end;
  633. {*****************************************************************************
  634. GetSpeedValue
  635. *****************************************************************************}
  636. {$ifdef ver1_0}
  637. {$R-}
  638. {$endif}
  639. var
  640. Crc32Tbl : array[0..255] of cardinal;
  641. procedure MakeCRC32Tbl;
  642. var
  643. crc : cardinal;
  644. i,n : integer;
  645. begin
  646. for i:=0 to 255 do
  647. begin
  648. crc:=i;
  649. for n:=1 to 8 do
  650. if odd(longint(crc)) then
  651. crc:=cardinal(crc shr 1) xor cardinal($edb88320)
  652. else
  653. crc:=cardinal(crc shr 1);
  654. Crc32Tbl[i]:=crc;
  655. end;
  656. end;
  657. Function GetSpeedValue(Const s:String):cardinal;
  658. var
  659. i : integer;
  660. InitCrc : cardinal;
  661. begin
  662. InitCrc:=cardinal($ffffffff);
  663. for i:=1 to Length(s) do
  664. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
  665. GetSpeedValue:=InitCrc;
  666. end;
  667. {*****************************************************************************
  668. Ansistring (PChar+Length)
  669. *****************************************************************************}
  670. procedure ansistringdispose(var p : pchar;length : longint);
  671. begin
  672. if assigned(p) then
  673. begin
  674. freemem(p,length+1);
  675. p:=nil;
  676. end;
  677. end;
  678. { enable ansistring comparison }
  679. { 0 means equal }
  680. { 1 means p1 > p2 }
  681. { -1 means p1 < p2 }
  682. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  683. var
  684. i,j : longint;
  685. begin
  686. compareansistrings:=0;
  687. j:=min(length1,length2);
  688. i:=0;
  689. while (i<j) do
  690. begin
  691. if p1[i]>p2[i] then
  692. begin
  693. compareansistrings:=1;
  694. exit;
  695. end
  696. else
  697. if p1[i]<p2[i] then
  698. begin
  699. compareansistrings:=-1;
  700. exit;
  701. end;
  702. inc(i);
  703. end;
  704. if length1>length2 then
  705. compareansistrings:=1
  706. else
  707. if length1<length2 then
  708. compareansistrings:=-1;
  709. end;
  710. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  711. var
  712. p : pchar;
  713. begin
  714. getmem(p,length1+length2+1);
  715. move(p1[0],p[0],length1);
  716. move(p2[0],p[length1],length2+1);
  717. concatansistrings:=p;
  718. end;
  719. {*****************************************************************************
  720. File Functions
  721. *****************************************************************************}
  722. function DeleteFile(const fn:string):boolean;
  723. var
  724. f : file;
  725. begin
  726. {$I-}
  727. assign(f,fn);
  728. erase(f);
  729. {$I-}
  730. DeleteFile:=(IOResult=0);
  731. end;
  732. {*****************************************************************************
  733. Ultra basic KISS Lzw (de)compressor
  734. *****************************************************************************}
  735. {This is an extremely basic implementation of the Lzw algorithm. It
  736. compresses 7-bit ASCII strings into 8-bit compressed strings.
  737. The Lzw dictionary is preinitialized with 0..127, therefore this
  738. part of the dictionary does not need to be stored in the arrays.
  739. The Lzw code size is allways 8 bit, so we do not need complex code
  740. that can write partial bytes.}
  741. function minilzw_encode(const s:string):string;
  742. var t,u,i:byte;
  743. c:char;
  744. data:array[128..255] of char;
  745. previous:array[128..255] of byte;
  746. lzwptr:byte;
  747. next_avail:set of 0..255;
  748. label l1;
  749. begin
  750. minilzw_encode:='';
  751. if s<>'' then
  752. begin
  753. lzwptr:=127;
  754. t:=byte(s[1]);
  755. i:=2;
  756. u:=128;
  757. next_avail:=[];
  758. while i<=length(s) do
  759. begin
  760. c:=s[i];
  761. if not(t in next_avail) or (u>lzwptr) then goto l1;
  762. while (previous[u]<>t) or (data[u]<>c) do
  763. begin
  764. inc(u);
  765. if u>lzwptr then goto l1;
  766. end;
  767. t:=u;
  768. inc(i);
  769. continue;
  770. l1:
  771. {It's a pity that we still need those awfull tricks
  772. with this modern compiler. Without this performance
  773. of the entire procedure drops about 3 times.}
  774. inc(minilzw_encode[0]);
  775. minilzw_encode[length(minilzw_encode)]:=char(t);
  776. if lzwptr=255 then
  777. begin
  778. lzwptr:=127;
  779. next_avail:=[];
  780. end
  781. else
  782. begin
  783. inc(lzwptr);
  784. data[lzwptr]:=c;
  785. previous[lzwptr]:=t;
  786. include(next_avail,t);
  787. end;
  788. t:=byte(c);
  789. u:=128;
  790. inc(i);
  791. end;
  792. inc(minilzw_encode[0]);
  793. minilzw_encode[length(minilzw_encode)]:=char(t);
  794. end;
  795. end;
  796. function minilzw_decode(const s:string):string;
  797. var oldc,newc,c:char;
  798. i,j:byte;
  799. data:array[128..255] of char;
  800. previous:array[128..255] of byte;
  801. lzwptr:byte;
  802. t:string;
  803. begin
  804. minilzw_decode:='';
  805. if s<>'' then
  806. begin
  807. lzwptr:=127;
  808. oldc:=s[1];
  809. c:=oldc;
  810. i:=2;
  811. minilzw_decode:=oldc;
  812. while i<=length(s) do
  813. begin
  814. newc:=s[i];
  815. if byte(newc)>lzwptr then
  816. begin
  817. t:=c;
  818. c:=oldc;
  819. end
  820. else
  821. begin
  822. c:=newc;
  823. t:='';
  824. end;
  825. while c>=#128 do
  826. begin
  827. inc(t[0]);
  828. t[length(t)]:=data[byte(c)];
  829. byte(c):=previous[byte(c)];
  830. end;
  831. inc(minilzw_decode[0]);
  832. minilzw_decode[length(minilzw_decode)]:=c;
  833. for j:=length(t) downto 1 do
  834. begin
  835. inc(minilzw_decode[0]);
  836. minilzw_decode[length(minilzw_decode)]:=t[j];
  837. end;
  838. if lzwptr=255 then
  839. lzwptr:=127
  840. else
  841. begin
  842. inc(lzwptr);
  843. previous[lzwptr]:=byte(oldc);
  844. data[lzwptr]:=c;
  845. end;
  846. oldc:=newc;
  847. inc(i);
  848. end;
  849. end;
  850. end;
  851. initialization
  852. makecrc32tbl;
  853. initupperlower;
  854. end.
  855. {
  856. $Log$
  857. Revision 1.31 2004-01-15 15:16:18 daniel
  858. * Some minor stuff
  859. * Managed to eliminate speed effects of string compression
  860. Revision 1.30 2004/01/11 23:56:19 daniel
  861. * Experiment: Compress strings to save memory
  862. Did not save a single byte of mem; clearly the core size is boosted by
  863. temporary memory usage...
  864. Revision 1.29 2003/10/31 15:51:11 peter
  865. * USEINLINE directive added (not enabled yet)
  866. Revision 1.28 2003/09/03 15:55:00 peter
  867. * NEWRA branch merged
  868. Revision 1.27.2.2 2003/08/29 17:28:59 peter
  869. * next batch of updates
  870. Revision 1.27.2.1 2003/08/29 09:41:25 daniel
  871. * Further mkx86reg development
  872. Revision 1.27 2003/07/05 20:06:28 jonas
  873. * fixed some range check errors that occurred on big endian systems
  874. * slightly optimized the swap*() functions
  875. Revision 1.26 2003/04/04 15:34:25 peter
  876. * quote names with hi-ascii chars
  877. Revision 1.25 2003/01/09 21:42:27 peter
  878. * realtostr added
  879. Revision 1.24 2002/12/27 18:05:27 peter
  880. * support quotes in gettoken
  881. Revision 1.23 2002/10/05 12:43:24 carl
  882. * fixes for Delphi 6 compilation
  883. (warning : Some features do not work under Delphi)
  884. Revision 1.22 2002/09/05 19:29:42 peter
  885. * memdebug enhancements
  886. Revision 1.21 2002/07/26 11:16:35 jonas
  887. * fixed (actual and potential) range errors
  888. Revision 1.20 2002/07/07 11:13:34 carl
  889. * range check error fix (patch from Sergey)
  890. Revision 1.19 2002/07/07 09:52:32 florian
  891. * powerpc target fixed, very simple units can be compiled
  892. * some basic stuff for better callparanode handling, far from being finished
  893. Revision 1.18 2002/07/01 18:46:22 peter
  894. * internal linker
  895. * reorganized aasm layer
  896. Revision 1.17 2002/05/18 13:34:07 peter
  897. * readded missing revisions
  898. Revision 1.16 2002/05/16 19:46:36 carl
  899. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  900. + try to fix temp allocation (still in ifdef)
  901. + generic constructor calls
  902. + start of tassembler / tmodulebase class cleanup
  903. Revision 1.14 2002/04/12 17:16:35 carl
  904. + more documentation of basic unit
  905. }