mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-23 06:51:44 +02:00
b9f6efc85b
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
640 lines
15 KiB
PHP
640 lines
15 KiB
PHP
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by the Free Pascal development team
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************
|
|
subroutines for string handling
|
|
****************************************************************************}
|
|
|
|
{$I real2str.inc}
|
|
|
|
{$ifndef INTERNSETLENGTH}
|
|
procedure SetLength(var s:shortstring;len:StrLenInt);
|
|
{$else INTERNSETLENGTH}
|
|
procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
{$endif INTERNSETLENGTH}
|
|
begin
|
|
if Len>255 then
|
|
Len:=255;
|
|
s[0]:=chr(len);
|
|
end;
|
|
|
|
function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring;
|
|
begin
|
|
if count<0 then
|
|
count:=0;
|
|
if index>1 then
|
|
dec(index)
|
|
else
|
|
index:=0;
|
|
if index>length(s) then
|
|
count:=0
|
|
else
|
|
if count>length(s)-index then
|
|
count:=length(s)-index;
|
|
Copy[0]:=chr(Count);
|
|
Move(s[Index+1],Copy[1],Count);
|
|
end;
|
|
|
|
|
|
procedure delete(var s : shortstring;index : StrLenInt;count : StrLenInt);
|
|
begin
|
|
if index<=0 then
|
|
begin
|
|
inc(count,index-1);
|
|
index:=1;
|
|
end;
|
|
if (Index<=Length(s)) and (Count>0) then
|
|
begin
|
|
if Count>length(s)-Index then
|
|
Count:=length(s)-Index+1;
|
|
s[0]:=Chr(length(s)-Count);
|
|
if Index<=Length(s) then
|
|
Move(s[Index+Count],s[Index],Length(s)-Index+1);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure insert(const source : shortstring;var s : shortstring;index : StrLenInt);
|
|
var
|
|
cut,srclen,indexlen : longint;
|
|
begin
|
|
if index<1 then
|
|
index:=1;
|
|
if index>length(s) then
|
|
index:=length(s)+1;
|
|
indexlen:=Length(s)-Index+1;
|
|
srclen:=length(Source);
|
|
if length(source)+length(s)>=sizeof(s) then
|
|
begin
|
|
cut:=length(source)+length(s)-sizeof(s)+1;
|
|
if cut>indexlen then
|
|
begin
|
|
dec(srclen,cut-indexlen);
|
|
indexlen:=0;
|
|
end
|
|
else
|
|
dec(indexlen,cut);
|
|
end;
|
|
move(s[Index],s[Index+srclen],indexlen);
|
|
move(Source[1],s[Index],srclen);
|
|
s[0]:=chr(index+srclen+indexlen-1);
|
|
end;
|
|
|
|
|
|
procedure insert(source : Char;var s : shortstring;index : StrLenInt);
|
|
var
|
|
indexlen : longint;
|
|
begin
|
|
if index<1 then
|
|
index:=1;
|
|
if index>length(s) then
|
|
index:=length(s)+1;
|
|
indexlen:=Length(s)-Index+1;
|
|
if (length(s)+1=sizeof(s)) and (indexlen>0) then
|
|
dec(indexlen);
|
|
move(s[Index],s[Index+1],indexlen);
|
|
s[Index]:=Source;
|
|
s[0]:=chr(index+indexlen);
|
|
end;
|
|
|
|
|
|
function pos(const substr : shortstring;const s : shortstring):StrLenInt;
|
|
var
|
|
i,MaxLen : StrLenInt;
|
|
pc : pchar;
|
|
begin
|
|
Pos:=0;
|
|
if Length(SubStr)>0 then
|
|
begin
|
|
MaxLen:=Length(s)-Length(SubStr);
|
|
i:=0;
|
|
pc:=@s[1];
|
|
while (i<=MaxLen) do
|
|
begin
|
|
inc(i);
|
|
if (SubStr[1]=pc^) and
|
|
(CompareChar(Substr[1],pc^,Length(SubStr))=0) then
|
|
begin
|
|
Pos:=i;
|
|
exit;
|
|
end;
|
|
inc(pc);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{Faster when looking for a single char...}
|
|
function pos(c:char;const s:shortstring):StrLenInt;
|
|
var
|
|
i : StrLenInt;
|
|
pc : pchar;
|
|
begin
|
|
pc:=@s[1];
|
|
for i:=1 to length(s) do
|
|
begin
|
|
if pc^=c then
|
|
begin
|
|
pos:=i;
|
|
exit;
|
|
end;
|
|
inc(pc);
|
|
end;
|
|
pos:=0;
|
|
end;
|
|
|
|
|
|
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
|
|
begin
|
|
if (index=1) and (Count>0) then
|
|
Copy:=c
|
|
else
|
|
Copy:='';
|
|
end;
|
|
|
|
|
|
function pos(const substr : shortstring;c:char): StrLenInt;
|
|
begin
|
|
if (length(substr)=1) and (substr[1]=c) then
|
|
Pos:=1
|
|
else
|
|
Pos:=0;
|
|
end;
|
|
|
|
|
|
{$ifdef IBM_CHAR_SET}
|
|
const
|
|
UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165;
|
|
LoCaseTbl : shortstring[7]=#129#132#148#130#135#134#164;
|
|
{$endif}
|
|
|
|
function upcase(c : char) : char;
|
|
{$IFDEF IBM_CHAR_SET}
|
|
var
|
|
i : longint;
|
|
{$ENDIF}
|
|
begin
|
|
if (c in ['a'..'z']) then
|
|
upcase:=char(byte(c)-32)
|
|
else
|
|
{$IFDEF IBM_CHAR_SET}
|
|
begin
|
|
i:=Pos(c,LoCaseTbl);
|
|
if i>0 then
|
|
upcase:=UpCaseTbl[i]
|
|
else
|
|
upcase:=c;
|
|
end;
|
|
{$ELSE}
|
|
upcase:=c;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
function upcase(const s : shortstring) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
upcase[0]:=s[0];
|
|
for i := 1 to length (s) do
|
|
upcase[i] := upcase (s[i]);
|
|
end;
|
|
|
|
|
|
function lowercase(c : char) : char;
|
|
{$IFDEF IBM_CHAR_SET}
|
|
var
|
|
i : longint;
|
|
{$ENDIF}
|
|
begin
|
|
if (c in ['A'..'Z']) then
|
|
lowercase:=char(byte(c)+32)
|
|
else
|
|
{$IFDEF IBM_CHAR_SET}
|
|
begin
|
|
i:=Pos(c,UpCaseTbl);
|
|
if i>0 then
|
|
lowercase:=LoCaseTbl[i]
|
|
else
|
|
lowercase:=c;
|
|
end;
|
|
{$ELSE}
|
|
lowercase:=c;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
function lowercase(const s : shortstring) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
lowercase [0]:=s[0];
|
|
for i:=1 to length(s) do
|
|
lowercase[i]:=lowercase (s[i]);
|
|
end;
|
|
|
|
|
|
const
|
|
HexTbl : array[0..15] of char='0123456789ABCDEF';
|
|
|
|
function hexstr(val : longint;cnt : byte) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
hexstr[0]:=char(cnt);
|
|
for i:=cnt downto 1 do
|
|
begin
|
|
hexstr[i]:=hextbl[val and $f];
|
|
val:=val shr 4;
|
|
end;
|
|
end;
|
|
|
|
|
|
function binstr(val : longint;cnt : byte) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
binstr[0]:=char(cnt);
|
|
for i:=cnt downto 1 do
|
|
begin
|
|
binstr[i]:=char(48+val and 1);
|
|
val:=val shr 1;
|
|
end;
|
|
end;
|
|
|
|
|
|
function hexstr(val : int64;cnt : byte) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
hexstr[0]:=char(cnt);
|
|
for i:=cnt downto 1 do
|
|
begin
|
|
hexstr[i]:=hextbl[val and $f];
|
|
val:=val shr 4;
|
|
end;
|
|
end;
|
|
|
|
|
|
function binstr(val : int64;cnt : byte) : shortstring;
|
|
var
|
|
i : longint;
|
|
begin
|
|
binstr[0]:=char(cnt);
|
|
for i:=cnt downto 1 do
|
|
begin
|
|
binstr[i]:=char(48+val and 1);
|
|
val:=val shr 1;
|
|
end;
|
|
end;
|
|
|
|
|
|
function space (b : byte): shortstring;
|
|
begin
|
|
space[0] := chr(b);
|
|
FillChar (Space[1],b,' ');
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Str() Helpers
|
|
*****************************************************************************}
|
|
|
|
procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; {$ifdef hascompilerproc}compilerproc;{$endif hascompilerproc}
|
|
begin
|
|
str_real(len,fr,d,treal_type(rt),s);
|
|
end;
|
|
|
|
|
|
procedure fpc_shortstr_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
int_str(v,s);
|
|
if length(s)<len then
|
|
s:=space(len-length(s))+s;
|
|
end;
|
|
|
|
|
|
procedure fpc_shortstr_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
begin
|
|
int_str(v,s);
|
|
if length(s)<len then
|
|
s:=space(len-length(s))+s;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Val() Functions
|
|
*****************************************************************************}
|
|
|
|
Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):ValSInt;
|
|
var
|
|
Code : Longint;
|
|
begin
|
|
{Skip Spaces and Tab}
|
|
code:=1;
|
|
while (code<=length(s)) and (s[code] in [' ',#9]) do
|
|
inc(code);
|
|
{Sign}
|
|
negativ:=false;
|
|
case s[code] of
|
|
'-' : begin
|
|
negativ:=true;
|
|
inc(code);
|
|
end;
|
|
'+' : inc(code);
|
|
end;
|
|
{Base}
|
|
base:=10;
|
|
if code<=length(s) then
|
|
begin
|
|
case s[code] of
|
|
'$' : begin
|
|
base:=16;
|
|
repeat
|
|
inc(code);
|
|
until (code>=length(s)) or (s[code]<>'0');
|
|
end;
|
|
'%' : begin
|
|
base:=2;
|
|
inc(code);
|
|
end;
|
|
end;
|
|
end;
|
|
InitVal:=code;
|
|
end;
|
|
|
|
Function fpc_Val_SInt_ShortStr(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
var
|
|
u, temp, prev, maxValue: ValUInt;
|
|
base : byte;
|
|
negative : boolean;
|
|
begin
|
|
fpc_Val_SInt_ShortStr := 0;
|
|
Temp:=0;
|
|
Code:=InitVal(s,negative,base);
|
|
if Code>length(s) then
|
|
exit;
|
|
maxValue := ValUInt(MaxUIntValue) div ValUInt(Base);
|
|
while Code<=Length(s) do
|
|
begin
|
|
case s[Code] of
|
|
'0'..'9' : u:=Ord(S[Code])-Ord('0');
|
|
'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
|
|
'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
|
|
else
|
|
u:=16;
|
|
end;
|
|
Prev := Temp;
|
|
Temp := Temp*ValUInt(base);
|
|
If (u >= base) or
|
|
((base = 10) and
|
|
(ValUInt(MaxSIntValue-u+ord(negative)) < Temp)) or
|
|
((base <> 10) and
|
|
(ValUInt(MaxUIntValue-Temp) < u)) or
|
|
(prev > maxValue) Then
|
|
Begin
|
|
fpc_Val_SInt_ShortStr := 0;
|
|
Exit
|
|
End;
|
|
Temp:=Temp+u;
|
|
inc(code);
|
|
end;
|
|
code := 0;
|
|
fpc_Val_SInt_ShortStr := ValSInt(Temp);
|
|
If Negative Then
|
|
fpc_Val_SInt_ShortStr := -fpc_Val_SInt_ShortStr;
|
|
If Not(Negative) and (base <> 10) Then
|
|
{sign extend the result to allow proper range checking}
|
|
Case DestSize of
|
|
1: fpc_Val_SInt_ShortStr := shortint(fpc_Val_SInt_ShortStr);
|
|
2: fpc_Val_SInt_ShortStr := smallint(fpc_Val_SInt_ShortStr);
|
|
{ Uncomment the folling once full 64bit support is in place
|
|
4: fpc_Val_SInt_ShortStr := longint(fpc_Val_SInt_ShortStr);}
|
|
End;
|
|
end;
|
|
|
|
{$ifdef hascompilerproc}
|
|
{ we need this for fpc_Val_SInt_Ansistr and fpc_Val_SInt_WideStr because }
|
|
{ we have to pass the DestSize parameter on (JM) }
|
|
Function fpc_Val_SInt_ShortStr(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [external name 'FPC_VAL_SINT_SHORTSTR'];
|
|
{$endif hascompilerproc}
|
|
|
|
|
|
Function fpc_Val_UInt_Shortstr(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
var
|
|
u, prev : ValUInt;
|
|
base : byte;
|
|
negative : boolean;
|
|
begin
|
|
fpc_Val_UInt_Shortstr:=0;
|
|
Code:=InitVal(s,negative,base);
|
|
If Negative or (Code>length(s)) Then
|
|
Exit;
|
|
while Code<=Length(s) do
|
|
begin
|
|
case s[Code] of
|
|
'0'..'9' : u:=Ord(S[Code])-Ord('0');
|
|
'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
|
|
'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
|
|
else
|
|
u:=16;
|
|
end;
|
|
prev := fpc_Val_UInt_Shortstr;
|
|
If (u>=base) or
|
|
(ValUInt(MaxUIntValue-u) div ValUInt(Base)<prev) then
|
|
begin
|
|
fpc_Val_UInt_Shortstr:=0;
|
|
exit;
|
|
end;
|
|
fpc_Val_UInt_Shortstr:=fpc_Val_UInt_Shortstr*ValUInt(base) + u;
|
|
inc(code);
|
|
end;
|
|
code := 0;
|
|
end;
|
|
|
|
|
|
Function fpc_Val_Real_ShortStr(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; {$ifdef hascompilerproc} compilerproc; {$endif}
|
|
var
|
|
hd,
|
|
esign,sign : valreal;
|
|
exponent,i : longint;
|
|
flags : byte;
|
|
begin
|
|
fpc_Val_Real_ShortStr:=0.0;
|
|
code:=1;
|
|
exponent:=0;
|
|
esign:=1;
|
|
flags:=0;
|
|
sign:=1;
|
|
while (code<=length(s)) and (s[code] in [' ',#9]) do
|
|
inc(code);
|
|
case s[code] of
|
|
'+' : inc(code);
|
|
'-' : begin
|
|
sign:=-1;
|
|
inc(code);
|
|
end;
|
|
end;
|
|
while (Code<=Length(s)) and (s[code] in ['0'..'9']) do
|
|
begin
|
|
{ Read integer part }
|
|
flags:=flags or 1;
|
|
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*10+(ord(s[code])-ord('0'));
|
|
inc(code);
|
|
end;
|
|
{ Decimal ? }
|
|
if (s[code]='.') and (length(s)>=code) then
|
|
begin
|
|
hd:=1.0;
|
|
inc(code);
|
|
while (s[code] in ['0'..'9']) and (length(s)>=code) do
|
|
begin
|
|
{ Read fractional part. }
|
|
flags:=flags or 2;
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*10+(ord(s[code])-ord('0'));
|
|
hd:=hd*10.0;
|
|
inc(code);
|
|
end;
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
|
|
end;
|
|
{ Again, read integer and fractional part}
|
|
if flags=0 then
|
|
begin
|
|
fpc_Val_Real_ShortStr:=0.0;
|
|
exit;
|
|
end;
|
|
{ Exponent ? }
|
|
if (upcase(s[code])='E') and (length(s)>=code) then
|
|
begin
|
|
inc(code);
|
|
if s[code]='+' then
|
|
inc(code)
|
|
else
|
|
if s[code]='-' then
|
|
begin
|
|
esign:=-1;
|
|
inc(code);
|
|
end;
|
|
if not(s[code] in ['0'..'9']) or (length(s)<code) then
|
|
begin
|
|
fpc_Val_Real_ShortStr:=0.0;
|
|
exit;
|
|
end;
|
|
while (s[code] in ['0'..'9']) and (length(s)>=code) do
|
|
begin
|
|
exponent:=exponent*10;
|
|
exponent:=exponent+ord(s[code])-ord('0');
|
|
inc(code);
|
|
end;
|
|
end;
|
|
{ Calculate Exponent }
|
|
{
|
|
if esign>0 then
|
|
for i:=1 to exponent do
|
|
fpc_Val_Real_ShortStr:=Val_Real_ShortStr*10
|
|
else
|
|
for i:=1 to exponent do
|
|
fpc_Val_Real_ShortStr:=Val_Real_ShortStr/10; }
|
|
hd:=1.0;
|
|
for i:=1 to exponent do
|
|
hd:=hd*10.0;
|
|
if esign>0 then
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*hd
|
|
else
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr/hd;
|
|
{ Not all characters are read ? }
|
|
if length(s)>=code then
|
|
begin
|
|
fpc_Val_Real_ShortStr:=0.0;
|
|
exit;
|
|
end;
|
|
{ evaluate sign }
|
|
fpc_Val_Real_ShortStr:=fpc_Val_Real_ShortStr*sign;
|
|
{ success ! }
|
|
code:=0;
|
|
end;
|
|
|
|
|
|
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
|
|
begin
|
|
Move (Buf[0],S[1],Len);
|
|
S[0]:=chr(len);
|
|
end;
|
|
|
|
{
|
|
$Log$
|
|
Revision 1.15 2001-08-01 15:00:10 jonas
|
|
+ "compproc" helpers
|
|
* renamed several helpers so that their name is the same as their
|
|
"public alias", which should facilitate the conversion of processor
|
|
specific code in the code generator to processor independent code
|
|
* some small fixes to the val_ansistring and val_widestring helpers
|
|
(always immediately exit if the source string is longer than 255
|
|
chars)
|
|
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
|
|
still nil (used to crash, now return resp -1 and 0)
|
|
|
|
Revision 1.14 2001/07/08 21:00:18 peter
|
|
* various widestring updates, it works now mostly without charset
|
|
mapping supported
|
|
|
|
Revision 1.13 2001/07/04 12:02:14 jonas
|
|
* fixed bug in ValSignedInt (it accepted some values slightly larger than
|
|
high(cardinal) such as 4294967297) (merged)
|
|
|
|
Revision 1.12 2001/06/04 11:43:51 peter
|
|
* Formal const to var fixes
|
|
* Hexstr(int64) added
|
|
|
|
Revision 1.11 2001/04/13 22:30:04 peter
|
|
* remove warnings
|
|
|
|
Revision 1.10 2001/04/13 18:06:28 peter
|
|
* removed rtllite define
|
|
|
|
Revision 1.9 2001/03/03 12:38:53 jonas
|
|
* made val for longints a bit faster
|
|
|
|
Revision 1.8 2000/12/09 20:52:41 florian
|
|
* val for dword and qword didn't handle the max values
|
|
correctly
|
|
* val for qword works again
|
|
+ val with int64/qword and ansistring implemented
|
|
|
|
Revision 1.7 2000/11/23 11:41:56 jonas
|
|
* fix for web bug 1265 by Peter (merged)
|
|
|
|
Revision 1.6 2000/11/17 17:01:23 jonas
|
|
* fixed bug for val when processing -2147483648 and low(int64) (merged)
|
|
|
|
Revision 1.5 2000/11/06 20:34:24 peter
|
|
* changed ver1_0 defines to temporary defs
|
|
|
|
Revision 1.4 2000/10/21 18:20:17 florian
|
|
* a lot of small changes:
|
|
- setlength is internal
|
|
- win32 graph unit extended
|
|
....
|
|
|
|
Revision 1.3 2000/07/28 12:29:49 jonas
|
|
* fixed web bug1069
|
|
* fixed similar (and other) problems in val() for int64 and qword
|
|
(both merged from fixes branch)
|
|
|
|
Revision 1.2 2000/07/13 11:33:45 michael
|
|
+ removed logs
|
|
|
|
}
|