123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919 |
- {
- $Id$
- Copyright (c) 1998-2002 by Florian Klaempfl
- This unit implements some support functions
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published
- by the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- {# This unit contains some generic support functions which are used
- in the different parts of the compiler.
- }
- unit cutils;
- {$i fpcdefs.inc}
- interface
- type
- pstring = ^string;
- {# Returns the minimal value between @var(a) and @var(b) }
- function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
- {# Returns the maximum value between @var(a) and @var(b) }
- function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
- {# Returns the value in @var(x) swapped to different endian }
- function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
- {# Returns the value in @va(x) swapped to different endian }
- function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
- {# Return value @var(i) aligned on @var(a) boundary }
- function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
- function used_align(varalign,minalign,maxalign:longint):longint;
- function size_2_align(len : longint) : longint;
- procedure Replace(var s:string;s1:string;const s2:string);
- procedure ReplaceCase(var s:string;const s1,s2:string);
- function upper(const s : string) : string;
- function lower(const s : string) : string;
- function trimbspace(const s:string):string;
- function trimspace(const s:string):string;
- function space (b : longint): string;
- function PadSpace(const s:string;len:longint):string;
- function GetToken(var s:string;endchar:char):string;
- procedure uppervar(var s : string);
- function hexstr(val : cardinal;cnt : cardinal) : string;
- function tostru(i:cardinal) : string;{$ifdef USEINLINE}inline;{$endif}
- function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
- function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
- function int64tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
- function tostr_with_plus(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
- function DStr(l:longint):string;
- procedure valint(S : string;var V : longint;var code : integer);
- {# Returns true if the string s is a number }
- function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
- {# Returns true if value is a power of 2, the actual
- exponent value is returned in power.
- }
- function ispowerof2(value : int64;var power : longint) : boolean;
- function maybequoted(const s:string):string;
- function CompareText(S1, S2: string): longint;
- { releases the string p and assignes nil to p }
- { if p=nil then freemem isn't called }
- procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
- { allocates mem for a copy of s, copies s to this mem and returns }
- { a pointer to this mem }
- function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
- {# Allocates memory for the string @var(s) and copies s as zero
- terminated string to that allocated memory and returns a pointer
- to that mem
- }
- function strpnew(const s : string) : pchar;
- procedure strdispose(var p : pchar);
- {# makes the character @var(c) lowercase, with spanish, french and german
- character set
- }
- function lowercase(c : char) : char;
- { makes zero terminated string to a pascal string }
- { the data in p is modified and p is returned }
- function pchar2pstring(p : pchar) : pstring;
- { ambivalent to pchar2pstring }
- function pstring2pchar(p : pstring) : pchar;
- { Speed/Hash value }
- Function GetSpeedValue(Const s:String):cardinal;
- { Ansistring (pchar+length) support }
- procedure ansistringdispose(var p : pchar;length : longint);
- function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
- function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
- {*****************************************************************************
- File Functions
- *****************************************************************************}
- function DeleteFile(const fn:string):boolean;
- implementation
- uses
- {$ifdef delphi}
- sysutils
- {$else}
- strings
- {$endif}
- ;
- var
- uppertbl,
- lowertbl : array[char] of char;
- function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
- {
- return the minimal of a and b
- }
- begin
- if a>b then
- min:=b
- else
- min:=a;
- end;
- function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
- {
- return the maximum of a and b
- }
- begin
- if a<b then
- max:=b
- else
- max:=a;
- end;
- Function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
- var
- y : word;
- z : word;
- Begin
- y := x shr 16;
- y := word(longint(y) shl 8) or (y shr 8);
- z := x and $FFFF;
- z := word(longint(z) shl 8) or (z shr 8);
- SwapLong := (longint(z) shl 16) or longint(y);
- End;
- Function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
- var
- z : byte;
- Begin
- z := x shr 8;
- x := x and $ff;
- x := (x shl 8);
- SwapWord := x or z;
- End;
- function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
- {
- return value <i> aligned <a> boundary
- }
- begin
- { for 0 and 1 no aligning is needed }
- if a<=1 then
- align:=i
- else
- align:=((i+a-1) div a) * a;
- end;
- function size_2_align(len : longint) : longint;
- begin
- if len>16 then
- size_2_align:=32
- else if len>8 then
- size_2_align:=16
- else if len>4 then
- size_2_align:=8
- else if len>2 then
- size_2_align:=4
- else if len>1 then
- size_2_align:=2
- else
- size_2_align:=1;
- end;
- function used_align(varalign,minalign,maxalign:longint):longint;
- begin
- { varalign : minimum alignment required for the variable
- minalign : Minimum alignment of this structure, 0 = undefined
- maxalign : Maximum alignment of this structure, 0 = undefined }
- if (minalign>0) and
- (varalign<minalign) then
- used_align:=minalign
- else
- begin
- if (maxalign>0) and
- (varalign>maxalign) then
- used_align:=maxalign
- else
- used_align:=varalign;
- end;
- end;
- procedure Replace(var s:string;s1:string;const s2:string);
- var
- last,
- i : longint;
- begin
- s1:=upper(s1);
- last:=0;
- repeat
- i:=pos(s1,upper(s));
- if i=last then
- i:=0;
- if (i>0) then
- begin
- Delete(s,i,length(s1));
- Insert(s2,s,i);
- last:=i;
- end;
- until (i=0);
- end;
- procedure ReplaceCase(var s:string;const s1,s2:string);
- var
- last,
- i : longint;
- begin
- last:=0;
- repeat
- i:=pos(s1,s);
- if i=last then
- i:=0;
- if (i>0) then
- begin
- Delete(s,i,length(s1));
- Insert(s2,s,i);
- last:=i;
- end;
- until (i=0);
- end;
- function upper(const s : string) : string;
- {
- return uppercased string of s
- }
- var
- i : longint;
- begin
- for i:=1 to length(s) do
- upper[i]:=uppertbl[s[i]];
- upper[0]:=s[0];
- end;
- function lower(const s : string) : string;
- {
- return lowercased string of s
- }
- var
- i : longint;
- begin
- for i:=1 to length(s) do
- lower[i]:=lowertbl[s[i]];
- lower[0]:=s[0];
- end;
- procedure uppervar(var s : string);
- {
- uppercase string s
- }
- var
- i : longint;
- begin
- for i:=1 to length(s) do
- s[i]:=uppertbl[s[i]];
- end;
- procedure initupperlower;
- var
- c : char;
- begin
- for c:=#0 to #255 do
- begin
- lowertbl[c]:=c;
- uppertbl[c]:=c;
- case c of
- 'A'..'Z' :
- lowertbl[c]:=char(byte(c)+32);
- 'a'..'z' :
- uppertbl[c]:=char(byte(c)-32);
- end;
- end;
- end;
- function hexstr(val : cardinal;cnt : cardinal) : string;
- const
- HexTbl : array[0..15] of char='0123456789ABCDEF';
- var
- i,j : cardinal;
- begin
- { calculate required length }
- i:=0;
- j:=val;
- while (j>0) do
- begin
- inc(i);
- j:=j shr 4;
- end;
- { generate fillers }
- j:=0;
- while (i+j<cnt) do
- begin
- inc(j);
- hexstr[j]:='0';
- end;
- { generate hex }
- inc(j,i);
- hexstr[0]:=chr(j);
- while (val>0) do
- begin
- hexstr[j]:=hextbl[val and $f];
- dec(j);
- val:=val shr 4;
- end;
- end;
- function tostru(i:cardinal):string;{$ifdef USEINLINE}inline;{$endif}
- {
- return string of value i, but for cardinals
- }
- begin
- str(i,result);
- end;
- function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
- {
- return string of value i
- }
- begin
- str(i,result);
- end;
- function DStr(l:longint):string;
- var
- TmpStr : string[32];
- i : longint;
- begin
- Str(l,TmpStr);
- i:=Length(TmpStr);
- while (i>3) do
- begin
- dec(i,3);
- if TmpStr[i]<>'-' then
- insert('.',TmpStr,i+1);
- end;
- DStr:=TmpStr;
- end;
- function trimbspace(const s:string):string;
- {
- return s with all leading spaces and tabs removed
- }
- var
- i,j : longint;
- begin
- j:=1;
- i:=length(s);
- while (j<i) and (s[j] in [#9,' ']) do
- inc(j);
- trimbspace:=Copy(s,j,i-j+1);
- end;
- function trimspace(const s:string):string;
- {
- return s with all leading and ending spaces and tabs removed
- }
- var
- i,j : longint;
- begin
- i:=length(s);
- while (i>0) and (s[i] in [#9,' ']) do
- dec(i);
- j:=1;
- while (j<i) and (s[j] in [#9,' ']) do
- inc(j);
- trimspace:=Copy(s,j,i-j+1);
- end;
- function space (b : longint): string;
- var
- s: string;
- begin
- space[0] := chr(b);
- s[0] := chr(b);
- FillChar (S[1],b,' ');
- space:=s;
- end;
- function PadSpace(const s:string;len:longint):string;
- {
- return s with spaces add to the end
- }
- begin
- if length(s)<len then
- PadSpace:=s+Space(len-length(s))
- else
- PadSpace:=s;
- end;
- function GetToken(var s:string;endchar:char):string;
- var
- i : longint;
- begin
- GetToken:='';
- s:=TrimSpace(s);
- if s[1]='''' then
- begin
- i:=1;
- while (i<length(s)) do
- begin
- inc(i);
- if s[i]='''' then
- begin
- { Remove double quote }
- if (i<length(s)) and
- (s[i+1]='''') then
- begin
- Delete(s,i,1);
- inc(i);
- end
- else
- begin
- GetToken:=Copy(s,2,i-2);
- Delete(s,1,i);
- exit;
- end;
- end;
- end;
- GetToken:=s;
- s:='';
- end
- else
- begin
- i:=pos(EndChar,s);
- if i=0 then
- begin
- GetToken:=s;
- s:='';
- exit;
- end
- else
- begin
- GetToken:=Copy(s,1,i-1);
- Delete(s,1,i);
- exit;
- end;
- end;
- end;
- function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
- begin
- str(e,result);
- end;
- function int64tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
- {
- return string of value i
- }
- begin
- str(i,result);
- end;
- function tostr_with_plus(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}
- {
- return string of value i, but always include a + when i>=0
- }
- begin
- str(i,result);
- if i>=0 then
- result:='+'+result;
- end;
- procedure valint(S : string;var V : longint;var code : integer);
- {
- val() with support for octal, which is not supported under tp7
- }
- {$ifndef FPC}
- var
- vs : longint;
- c : byte;
- begin
- if s[1]='%' then
- begin
- vs:=0;
- longint(v):=0;
- for c:=2 to length(s) do
- begin
- if s[c]='0' then
- vs:=vs shl 1
- else
- if s[c]='1' then
- vs:=vs shl 1+1
- else
- begin
- code:=c;
- exit;
- end;
- end;
- code:=0;
- longint(v):=vs;
- end
- else
- system.val(S,V,code);
- end;
- {$else not FPC}
- begin
- system.val(S,V,code);
- end;
- {$endif not FPC}
- function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
- {
- is string a correct number ?
- }
- var
- w : integer;
- l : longint;
- begin
- valint(s,l,w);
- is_number:=(w=0);
- end;
- function ispowerof2(value : int64;var power : longint) : boolean;
- {
- return if value is a power of 2. And if correct return the power
- }
- var
- hl : int64;
- i : longint;
- begin
- if value and (value - 1) <> 0 then
- begin
- ispowerof2 := false;
- exit
- end;
- hl:=1;
- ispowerof2:=true;
- for i:=0 to 63 do
- begin
- if hl=value then
- begin
- power:=i;
- exit;
- end;
- hl:=hl shl 1;
- end;
- ispowerof2:=false;
- end;
- function maybequoted(const s:string):string;
- var
- s1 : string;
- i : integer;
- quoted : boolean;
- begin
- quoted:=false;
- s1:='"';
- for i:=1 to length(s) do
- begin
- case s[i] of
- '"' :
- begin
- quoted:=true;
- s1:=s1+'\"';
- end;
- ' ',
- #128..#255 :
- begin
- quoted:=true;
- s1:=s1+s[i];
- end;
- else
- s1:=s1+s[i];
- end;
- end;
- if quoted then
- maybequoted:=s1+'"'
- else
- maybequoted:=s;
- end;
- function pchar2pstring(p : pchar) : pstring;
- var
- w,i : longint;
- begin
- w:=strlen(p);
- for i:=w-1 downto 0 do
- p[i+1]:=p[i];
- p[0]:=chr(w);
- pchar2pstring:=pstring(p);
- end;
- function pstring2pchar(p : pstring) : pchar;
- var
- w,i : longint;
- begin
- w:=length(p^);
- for i:=1 to w do
- p^[i-1]:=p^[i];
- p^[w]:=#0;
- pstring2pchar:=pchar(p);
- end;
- function lowercase(c : char) : char;
- begin
- case c of
- #65..#90 : c := chr(ord (c) + 32);
- #154 : c:=#129; { german }
- #142 : c:=#132; { german }
- #153 : c:=#148; { german }
- #144 : c:=#130; { french }
- #128 : c:=#135; { french }
- #143 : c:=#134; { swedish/norge (?) }
- #165 : c:=#164; { spanish }
- #228 : c:=#229; { greek }
- #226 : c:=#231; { greek }
- #232 : c:=#227; { greek }
- end;
- lowercase := c;
- end;
- function strpnew(const s : string) : pchar;
- var
- p : pchar;
- begin
- getmem(p,length(s)+1);
- strpcopy(p,s);
- strpnew:=p;
- end;
- procedure strdispose(var p : pchar);
- begin
- if assigned(p) then
- begin
- freemem(p,strlen(p)+1);
- p:=nil;
- end;
- end;
- procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
- begin
- if assigned(p) then
- begin
- freemem(p,length(p^)+1);
- p:=nil;
- end;
- end;
- function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
- begin
- getmem(result,length(s)+1);
- result^:=s;
- end;
- function CompareText(S1, S2: string): longint;
- begin
- UpperVar(S1);
- UpperVar(S2);
- if S1<S2 then
- CompareText:=-1
- else
- if S1>S2 then
- CompareText:= 1
- else
- CompareText:=0;
- end;
- {*****************************************************************************
- GetSpeedValue
- *****************************************************************************}
- {$ifdef ver1_0}
- {$R-}
- {$endif}
- var
- Crc32Tbl : array[0..255] of cardinal;
- procedure MakeCRC32Tbl;
- var
- crc : cardinal;
- i,n : integer;
- begin
- for i:=0 to 255 do
- begin
- crc:=i;
- for n:=1 to 8 do
- if odd(longint(crc)) then
- crc:=cardinal(crc shr 1) xor cardinal($edb88320)
- else
- crc:=cardinal(crc shr 1);
- Crc32Tbl[i]:=crc;
- end;
- end;
- Function GetSpeedValue(Const s:String):cardinal;
- var
- i : integer;
- InitCrc : cardinal;
- begin
- if Crc32Tbl[1]=0 then
- MakeCrc32Tbl;
- InitCrc:=cardinal($ffffffff);
- for i:=1 to Length(s) do
- InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
- GetSpeedValue:=InitCrc;
- end;
- {*****************************************************************************
- Ansistring (PChar+Length)
- *****************************************************************************}
- procedure ansistringdispose(var p : pchar;length : longint);
- begin
- if assigned(p) then
- begin
- freemem(p,length+1);
- p:=nil;
- end;
- end;
- { enable ansistring comparison }
- { 0 means equal }
- { 1 means p1 > p2 }
- { -1 means p1 < p2 }
- function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
- var
- i,j : longint;
- begin
- compareansistrings:=0;
- j:=min(length1,length2);
- i:=0;
- while (i<j) do
- begin
- if p1[i]>p2[i] then
- begin
- compareansistrings:=1;
- exit;
- end
- else
- if p1[i]<p2[i] then
- begin
- compareansistrings:=-1;
- exit;
- end;
- inc(i);
- end;
- if length1>length2 then
- compareansistrings:=1
- else
- if length1<length2 then
- compareansistrings:=-1;
- end;
- function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
- var
- p : pchar;
- begin
- getmem(p,length1+length2+1);
- move(p1[0],p[0],length1);
- move(p2[0],p[length1],length2+1);
- concatansistrings:=p;
- end;
- {*****************************************************************************
- File Functions
- *****************************************************************************}
- function DeleteFile(const fn:string):boolean;
- var
- f : file;
- begin
- {$I-}
- assign(f,fn);
- erase(f);
- {$I-}
- DeleteFile:=(IOResult=0);
- end;
- initialization
- initupperlower;
- end.
- {
- $Log$
- Revision 1.29 2003-10-31 15:51:11 peter
- * USEINLINE directive added (not enabled yet)
- Revision 1.28 2003/09/03 15:55:00 peter
- * NEWRA branch merged
- Revision 1.27.2.2 2003/08/29 17:28:59 peter
- * next batch of updates
- Revision 1.27.2.1 2003/08/29 09:41:25 daniel
- * Further mkx86reg development
- Revision 1.27 2003/07/05 20:06:28 jonas
- * fixed some range check errors that occurred on big endian systems
- * slightly optimized the swap*() functions
- Revision 1.26 2003/04/04 15:34:25 peter
- * quote names with hi-ascii chars
- Revision 1.25 2003/01/09 21:42:27 peter
- * realtostr added
- Revision 1.24 2002/12/27 18:05:27 peter
- * support quotes in gettoken
- Revision 1.23 2002/10/05 12:43:24 carl
- * fixes for Delphi 6 compilation
- (warning : Some features do not work under Delphi)
- Revision 1.22 2002/09/05 19:29:42 peter
- * memdebug enhancements
- Revision 1.21 2002/07/26 11:16:35 jonas
- * fixed (actual and potential) range errors
- Revision 1.20 2002/07/07 11:13:34 carl
- * range check error fix (patch from Sergey)
- Revision 1.19 2002/07/07 09:52:32 florian
- * powerpc target fixed, very simple units can be compiled
- * some basic stuff for better callparanode handling, far from being finished
- Revision 1.18 2002/07/01 18:46:22 peter
- * internal linker
- * reorganized aasm layer
- Revision 1.17 2002/05/18 13:34:07 peter
- * readded missing revisions
- Revision 1.16 2002/05/16 19:46:36 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.14 2002/04/12 17:16:35 carl
- + more documentation of basic unit
- }
|