cutils.pas 19 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809
  1. {
  2. $Id$
  3. Copyright (C) 1998-2000 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 by
  7. 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. unit cutils;
  19. {$i defines.inc}
  20. interface
  21. {$ifdef delphi}
  22. type
  23. dword = cardinal;
  24. qword = int64;
  25. {$endif}
  26. type
  27. pstring = ^string;
  28. function min(a,b : longint) : longint;
  29. function max(a,b : longint) : longint;
  30. function SwapLong(x : longint): longint;
  31. function SwapWord(x : word): word;
  32. function align(i,a:longint):longint;
  33. function used_align(varalign,minalign,maxalign:longint):longint;
  34. function size_2_align(len : longint) : longint;
  35. procedure Replace(var s:string;s1:string;const s2:string);
  36. procedure ReplaceCase(var s:string;const s1,s2:string);
  37. function upper(const s : string) : string;
  38. function lower(const s : string) : string;
  39. function trimbspace(const s:string):string;
  40. function trimspace(const s:string):string;
  41. function GetToken(var s:string;endchar:char):string;
  42. procedure uppervar(var s : string);
  43. function hexstr(val : cardinal;cnt : byte) : string;
  44. function tostru(i:cardinal) : string;
  45. function tostr(i : longint) : string;
  46. function int64tostr(i : int64) : string;
  47. function tostr_with_plus(i : longint) : string;
  48. procedure valint(S : string;var V : longint;var code : integer);
  49. function is_number(const s : string) : boolean;
  50. function ispowerof2(value : int64;var power : longint) : boolean;
  51. function maybequoted(const s:string):string;
  52. function CompareText(S1, S2: string): longint;
  53. { releases the string p and assignes nil to p }
  54. { if p=nil then freemem isn't called }
  55. procedure stringdispose(var p : pstring);
  56. { allocates mem for a copy of s, copies s to this mem and returns }
  57. { a pointer to this mem }
  58. function stringdup(const s : string) : pstring;
  59. { allocates memory for s and copies s as zero terminated string
  60. to that mem and returns a pointer to that mem }
  61. function strpnew(const s : string) : pchar;
  62. procedure strdispose(var p : pchar);
  63. { makes a char lowercase, with spanish, french and german char set }
  64. function lowercase(c : char) : char;
  65. { makes zero terminated string to a pascal string }
  66. { the data in p is modified and p is returned }
  67. function pchar2pstring(p : pchar) : pstring;
  68. { ambivalent to pchar2pstring }
  69. function pstring2pchar(p : pstring) : pchar;
  70. { Speed/Hash value }
  71. Function GetSpeedValue(Const s:String):cardinal;
  72. { Ansistring (pchar+length) support }
  73. procedure ansistringdispose(var p : pchar;length : longint);
  74. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  75. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  76. {*****************************************************************************
  77. File Functions
  78. *****************************************************************************}
  79. function DeleteFile(const fn:string):boolean;
  80. implementation
  81. uses
  82. {$ifdef delphi}
  83. sysutils
  84. {$else}
  85. strings
  86. {$endif}
  87. ;
  88. var
  89. uppertbl,
  90. lowertbl : array[char] of char;
  91. function min(a,b : longint) : longint;
  92. {
  93. return the minimal of a and b
  94. }
  95. begin
  96. if a>b then
  97. min:=b
  98. else
  99. min:=a;
  100. end;
  101. function max(a,b : longint) : longint;
  102. {
  103. return the maximum of a and b
  104. }
  105. begin
  106. if a<b then
  107. max:=b
  108. else
  109. max:=a;
  110. end;
  111. Function SwapLong(x : longint): longint;
  112. var
  113. y : word;
  114. z : word;
  115. Begin
  116. y := (x shr 16) and $FFFF;
  117. y := ((y shl 8) and $FFFF) or ((y shr 8) and $ff);
  118. z := x and $FFFF;
  119. z := ((z shl 8) and $FFFF) or ((z shr 8) and $ff);
  120. SwapLong := (longint(z) shl 16) or longint(y);
  121. End;
  122. Function SwapWord(x : word): word;
  123. var
  124. z : byte;
  125. Begin
  126. z := (x shr 8) and $ff;
  127. x := x and $ff;
  128. x := (x shl 8);
  129. SwapWord := x or z;
  130. End;
  131. function align(i,a:longint):longint;
  132. {
  133. return value <i> aligned <a> boundary
  134. }
  135. begin
  136. { for 0 and 1 no aligning is needed }
  137. if a<=1 then
  138. align:=i
  139. else
  140. align:=((i+a-1) div a) * a;
  141. end;
  142. function size_2_align(len : longint) : longint;
  143. begin
  144. if len>16 then
  145. size_2_align:=32
  146. else if len>8 then
  147. size_2_align:=16
  148. else if len>4 then
  149. size_2_align:=8
  150. else if len>2 then
  151. size_2_align:=4
  152. else if len>1 then
  153. size_2_align:=2
  154. else
  155. size_2_align:=1;
  156. end;
  157. function used_align(varalign,minalign,maxalign:longint):longint;
  158. begin
  159. { varalign : minimum alignment required for the variable
  160. minalign : Minimum alignment of this structure, 0 = undefined
  161. maxalign : Maximum alignment of this structure, 0 = undefined }
  162. if (minalign>0) and
  163. (varalign<minalign) then
  164. used_align:=minalign
  165. else
  166. begin
  167. if (maxalign>0) and
  168. (varalign>maxalign) then
  169. used_align:=maxalign
  170. else
  171. used_align:=varalign;
  172. end;
  173. end;
  174. procedure Replace(var s:string;s1:string;const s2:string);
  175. var
  176. last,
  177. i : longint;
  178. begin
  179. s1:=upper(s1);
  180. last:=0;
  181. repeat
  182. i:=pos(s1,upper(s));
  183. if i=last then
  184. i:=0;
  185. if (i>0) then
  186. begin
  187. Delete(s,i,length(s1));
  188. Insert(s2,s,i);
  189. last:=i;
  190. end;
  191. until (i=0);
  192. end;
  193. procedure ReplaceCase(var s:string;const s1,s2:string);
  194. var
  195. last,
  196. i : longint;
  197. begin
  198. last:=0;
  199. repeat
  200. i:=pos(s1,s);
  201. if i=last then
  202. i:=0;
  203. if (i>0) then
  204. begin
  205. Delete(s,i,length(s1));
  206. Insert(s2,s,i);
  207. last:=i;
  208. end;
  209. until (i=0);
  210. end;
  211. function upper(const s : string) : string;
  212. {
  213. return uppercased string of s
  214. }
  215. var
  216. i : longint;
  217. begin
  218. for i:=1 to length(s) do
  219. upper[i]:=uppertbl[s[i]];
  220. upper[0]:=s[0];
  221. end;
  222. function lower(const s : string) : string;
  223. {
  224. return lowercased string of s
  225. }
  226. var
  227. i : longint;
  228. begin
  229. for i:=1 to length(s) do
  230. lower[i]:=lowertbl[s[i]];
  231. lower[0]:=s[0];
  232. end;
  233. procedure uppervar(var s : string);
  234. {
  235. uppercase string s
  236. }
  237. var
  238. i : longint;
  239. begin
  240. for i:=1 to length(s) do
  241. s[i]:=uppertbl[s[i]];
  242. end;
  243. procedure initupperlower;
  244. var
  245. c : char;
  246. begin
  247. for c:=#0 to #255 do
  248. begin
  249. lowertbl[c]:=c;
  250. uppertbl[c]:=c;
  251. case c of
  252. 'A'..'Z' :
  253. lowertbl[c]:=char(byte(c)+32);
  254. 'a'..'z' :
  255. uppertbl[c]:=char(byte(c)-32);
  256. end;
  257. end;
  258. end;
  259. function hexstr(val : cardinal;cnt : byte) : string;
  260. const
  261. HexTbl : array[0..15] of char='0123456789ABCDEF';
  262. var
  263. i : longint;
  264. begin
  265. hexstr[0]:=char(cnt);
  266. for i:=cnt downto 1 do
  267. begin
  268. hexstr[i]:=hextbl[val and $f];
  269. val:=val shr 4;
  270. end;
  271. end;
  272. function tostru(i:cardinal):string;
  273. {
  274. return string of value i, but for cardinals
  275. }
  276. var
  277. hs : string;
  278. begin
  279. str(i,hs);
  280. tostru:=hs;
  281. end;
  282. function trimbspace(const s:string):string;
  283. {
  284. return s with all leading spaces and tabs removed
  285. }
  286. var
  287. i,j : longint;
  288. begin
  289. j:=1;
  290. i:=length(s);
  291. while (j<i) and (s[j] in [#9,' ']) do
  292. inc(j);
  293. trimbspace:=Copy(s,j,i-j+1);
  294. end;
  295. function trimspace(const s:string):string;
  296. {
  297. return s with all leading and ending spaces and tabs removed
  298. }
  299. var
  300. i,j : longint;
  301. begin
  302. i:=length(s);
  303. while (i>0) and (s[i] in [#9,' ']) do
  304. dec(i);
  305. j:=1;
  306. while (j<i) and (s[j] in [#9,' ']) do
  307. inc(j);
  308. trimspace:=Copy(s,j,i-j+1);
  309. end;
  310. function GetToken(var s:string;endchar:char):string;
  311. var
  312. i : longint;
  313. begin
  314. s:=TrimSpace(s);
  315. i:=pos(EndChar,s);
  316. if i=0 then
  317. begin
  318. GetToken:=s;
  319. s:='';
  320. end
  321. else
  322. begin
  323. GetToken:=Copy(s,1,i-1);
  324. Delete(s,1,i);
  325. end;
  326. end;
  327. function tostr(i : longint) : string;
  328. {
  329. return string of value i
  330. }
  331. var
  332. hs : string;
  333. begin
  334. str(i,hs);
  335. tostr:=hs;
  336. end;
  337. function int64tostr(i : int64) : string;
  338. {
  339. return string of value i
  340. }
  341. var
  342. hs : string;
  343. begin
  344. str(i,hs);
  345. int64tostr:=hs;
  346. end;
  347. function tostr_with_plus(i : longint) : string;
  348. {
  349. return string of value i, but always include a + when i>=0
  350. }
  351. var
  352. hs : string;
  353. begin
  354. str(i,hs);
  355. if i>=0 then
  356. tostr_with_plus:='+'+hs
  357. else
  358. tostr_with_plus:=hs;
  359. end;
  360. procedure valint(S : string;var V : longint;var code : integer);
  361. {
  362. val() with support for octal, which is not supported under tp7
  363. }
  364. {$ifndef FPC}
  365. var
  366. vs : longint;
  367. c : byte;
  368. begin
  369. if s[1]='%' then
  370. begin
  371. vs:=0;
  372. longint(v):=0;
  373. for c:=2 to length(s) do
  374. begin
  375. if s[c]='0' then
  376. vs:=vs shl 1
  377. else
  378. if s[c]='1' then
  379. vs:=vs shl 1+1
  380. else
  381. begin
  382. code:=c;
  383. exit;
  384. end;
  385. end;
  386. code:=0;
  387. longint(v):=vs;
  388. end
  389. else
  390. system.val(S,V,code);
  391. end;
  392. {$else not FPC}
  393. begin
  394. system.val(S,V,code);
  395. end;
  396. {$endif not FPC}
  397. function is_number(const s : string) : boolean;
  398. {
  399. is string a correct number ?
  400. }
  401. var
  402. w : integer;
  403. l : longint;
  404. begin
  405. valint(s,l,w);
  406. is_number:=(w=0);
  407. end;
  408. function ispowerof2(value : int64;var power : longint) : boolean;
  409. {
  410. return if value is a power of 2. And if correct return the power
  411. }
  412. var
  413. hl : int64;
  414. i : longint;
  415. begin
  416. if value and (value - 1) <> 0 then
  417. begin
  418. ispowerof2 := false;
  419. exit
  420. end;
  421. hl:=1;
  422. ispowerof2:=true;
  423. for i:=0 to 63 do
  424. begin
  425. if hl=value then
  426. begin
  427. power:=i;
  428. exit;
  429. end;
  430. hl:=hl shl 1;
  431. end;
  432. ispowerof2:=false;
  433. end;
  434. function maybequoted(const s:string):string;
  435. var
  436. s1 : string;
  437. i : integer;
  438. begin
  439. if (pos('"',s)>0) then
  440. begin
  441. s1:='"';
  442. for i:=1 to length(s) do
  443. begin
  444. if s[i]='"' then
  445. s1:=s1+'\"'
  446. else
  447. s1:=s1+s[i];
  448. end;
  449. maybequoted:=s1+'"';
  450. end
  451. else if (pos(' ',s)>0) then
  452. maybequoted:='"'+s+'"'
  453. else
  454. maybequoted:=s;
  455. end;
  456. function pchar2pstring(p : pchar) : pstring;
  457. var
  458. w,i : longint;
  459. begin
  460. w:=strlen(p);
  461. for i:=w-1 downto 0 do
  462. p[i+1]:=p[i];
  463. p[0]:=chr(w);
  464. pchar2pstring:=pstring(p);
  465. end;
  466. function pstring2pchar(p : pstring) : pchar;
  467. var
  468. w,i : longint;
  469. begin
  470. w:=length(p^);
  471. for i:=1 to w do
  472. p^[i-1]:=p^[i];
  473. p^[w]:=#0;
  474. pstring2pchar:=pchar(p);
  475. end;
  476. function lowercase(c : char) : char;
  477. begin
  478. case c of
  479. #65..#90 : c := chr(ord (c) + 32);
  480. #154 : c:=#129; { german }
  481. #142 : c:=#132; { german }
  482. #153 : c:=#148; { german }
  483. #144 : c:=#130; { french }
  484. #128 : c:=#135; { french }
  485. #143 : c:=#134; { swedish/norge (?) }
  486. #165 : c:=#164; { spanish }
  487. #228 : c:=#229; { greek }
  488. #226 : c:=#231; { greek }
  489. #232 : c:=#227; { greek }
  490. end;
  491. lowercase := c;
  492. end;
  493. function strpnew(const s : string) : pchar;
  494. var
  495. p : pchar;
  496. begin
  497. getmem(p,length(s)+1);
  498. strpcopy(p,s);
  499. strpnew:=p;
  500. end;
  501. procedure strdispose(var p : pchar);
  502. begin
  503. if assigned(p) then
  504. begin
  505. freemem(p,strlen(p)+1);
  506. p:=nil;
  507. end;
  508. end;
  509. procedure stringdispose(var p : pstring);
  510. begin
  511. if assigned(p) then
  512. freemem(p,length(p^)+1);
  513. p:=nil;
  514. end;
  515. function stringdup(const s : string) : pstring;
  516. var
  517. p : pstring;
  518. begin
  519. getmem(p,length(s)+1);
  520. p^:=s;
  521. stringdup:=p;
  522. end;
  523. function CompareText(S1, S2: string): longint;
  524. begin
  525. UpperVar(S1);
  526. UpperVar(S2);
  527. if S1<S2 then
  528. CompareText:=-1
  529. else
  530. if S1>S2 then
  531. CompareText:= 1
  532. else
  533. CompareText:=0;
  534. end;
  535. {*****************************************************************************
  536. GetSpeedValue
  537. *****************************************************************************}
  538. {$ifdef ver1_0}
  539. {$R-}
  540. {$endif}
  541. var
  542. Crc32Tbl : array[0..255] of cardinal;
  543. procedure MakeCRC32Tbl;
  544. var
  545. crc : cardinal;
  546. i,n : integer;
  547. begin
  548. for i:=0 to 255 do
  549. begin
  550. crc:=i;
  551. for n:=1 to 8 do
  552. if odd(longint(crc)) then
  553. crc:=cardinal(crc shr 1) xor cardinal($edb88320)
  554. else
  555. crc:=cardinal(crc shr 1);
  556. Crc32Tbl[i]:=crc;
  557. end;
  558. end;
  559. Function GetSpeedValue(Const s:String):cardinal;
  560. var
  561. i : integer;
  562. InitCrc : cardinal;
  563. begin
  564. if Crc32Tbl[1]=0 then
  565. MakeCrc32Tbl;
  566. InitCrc:=cardinal($ffffffff);
  567. for i:=1 to Length(s) do
  568. InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
  569. GetSpeedValue:=InitCrc;
  570. end;
  571. {*****************************************************************************
  572. Ansistring (PChar+Length)
  573. *****************************************************************************}
  574. procedure ansistringdispose(var p : pchar;length : longint);
  575. begin
  576. if assigned(p) then
  577. freemem(p,length+1);
  578. p:=nil;
  579. end;
  580. { enable ansistring comparison }
  581. { 0 means equal }
  582. { 1 means p1 > p2 }
  583. { -1 means p1 < p2 }
  584. function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
  585. var
  586. i,j : longint;
  587. begin
  588. compareansistrings:=0;
  589. j:=min(length1,length2);
  590. i:=0;
  591. while (i<j) do
  592. begin
  593. if p1[i]>p2[i] then
  594. begin
  595. compareansistrings:=1;
  596. exit;
  597. end
  598. else
  599. if p1[i]<p2[i] then
  600. begin
  601. compareansistrings:=-1;
  602. exit;
  603. end;
  604. inc(i);
  605. end;
  606. if length1>length2 then
  607. compareansistrings:=1
  608. else
  609. if length1<length2 then
  610. compareansistrings:=-1;
  611. end;
  612. function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
  613. var
  614. p : pchar;
  615. begin
  616. getmem(p,length1+length2+1);
  617. move(p1[0],p[0],length1);
  618. move(p2[0],p[length1],length2+1);
  619. concatansistrings:=p;
  620. end;
  621. {*****************************************************************************
  622. File Functions
  623. *****************************************************************************}
  624. function DeleteFile(const fn:string):boolean;
  625. var
  626. f : file;
  627. begin
  628. {$I-}
  629. assign(f,fn);
  630. erase(f);
  631. {$I-}
  632. DeleteFile:=(IOResult=0);
  633. end;
  634. initialization
  635. initupperlower;
  636. end.
  637. {
  638. $Log$
  639. Revision 1.13 2002-04-02 17:11:28 peter
  640. * tlocation,treference update
  641. * LOC_CONSTANT added for better constant handling
  642. * secondadd splitted in multiple routines
  643. * location_force_reg added for loading a location to a register
  644. of a specified size
  645. * secondassignment parses now first the right and then the left node
  646. (this is compatible with Kylix). This saves a lot of push/pop especially
  647. with string operations
  648. * adapted some routines to use the new cg methods
  649. Revision 1.12 2001/11/18 18:43:13 peter
  650. * overloading supported in child classes
  651. * fixed parsing of classes with private and virtual and overloaded
  652. so it is compatible with delphi
  653. Revision 1.11 2001/09/05 15:20:26 jonas
  654. * ispowerf2 now works with 64bit ints and should be faster
  655. Revision 1.10 2001/08/04 11:06:30 peter
  656. * browcol has no depends on ide/fv
  657. Revision 1.9 2001/07/30 20:59:27 peter
  658. * m68k updates from v10 merged
  659. Revision 1.8 2001/07/01 20:16:15 peter
  660. * alignmentinfo record added
  661. * -Oa argument supports more alignment settings that can be specified
  662. per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN
  663. RECORDMAX,LOCALMIN,LOCALMAX. It is possible to set the mimimum
  664. required alignment and the maximum usefull alignment. The final
  665. alignment will be choosen per variable size dependent on these
  666. settings
  667. Revision 1.7 2001/06/18 20:36:23 peter
  668. * -Ur switch (merged)
  669. * masm fixes (merged)
  670. * quoted filenames for go32v2 and win32
  671. Revision 1.6 2001/05/09 14:11:10 jonas
  672. * range check error fixes from Peter
  673. Revision 1.5 2000/12/24 12:25:31 peter
  674. + cstreams unit
  675. * dynamicarray object to class
  676. Revision 1.4 2000/11/28 00:17:43 pierre
  677. + int64tostr function added
  678. Revision 1.3 2000/11/07 20:47:35 peter
  679. * use tables for upper/lower
  680. Revision 1.2 2000/09/24 15:06:14 peter
  681. * use defines.inc
  682. Revision 1.1 2000/08/27 16:11:50 peter
  683. * moved some util functions from globals,cobjects to cutils
  684. * splitted files into finput,fmodule
  685. }