paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 06:08:55 +02:00
Code Issues Packages Projects Releases Wiki Activity
basemath
fpc/rtl/inc/sstrings.inc
Rika Ichinose fc3d71bba3 Check bounds in SetLength(shortstring).
2024-04-10 21:06:14 +03:00

1914 lines
47 KiB
PHP
Raw Permalink Blame History

{
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
****************************************************************************}
{$ifndef FPC_HAS_SHORTSTR_SETLENGTH}
{$define FPC_HAS_SHORTSTR_SETLENGTH}
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH']; compilerproc;
begin
if len<0 then
len:=0;
if len>high(s) then
len:=high(s);
s[0]:=chr(len);
end;
{$endif FPC_HAS_SHORTSTR_SETLENGTH}
{$ifndef FPC_HAS_SHORTSTR_COPY}
{$define FPC_HAS_SHORTSTR_COPY}
function fpc_shortstr_copy(const s : shortstring;index : SizeInt;count : SizeInt): shortstring;compilerproc;
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;
fpc_shortstr_Copy[0]:=chr(Count);
fpc_shortstr_shortstr_intern_charmove(s,Index+1,fpc_shortstr_Copy,1,Count);
end;
{$endif FPC_HAS_SHORTSTR_COPY}
{$ifndef FPC_HAS_SHORTSTR_DELETE}
{$define FPC_HAS_SHORTSTR_DELETE}
procedure {$ifdef VER3_0}delete{$else}fpc_shortstr_delete{$endif}(var s : shortstring;index : SizeInt;count : SizeInt);
begin
if index<=0 then
exit;
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
fpc_shortstr_shortstr_intern_charmove(s,Index+Count,s,Index,Length(s)-Index+1);
end;
end;
{$endif FPC_HAS_SHORTSTR_DELETE}
{$ifndef FPC_HAS_SHORTSTR_INSERT}
{$define FPC_HAS_SHORTSTR_INSERT}
procedure {$ifdef ver3_0}insert{$else}fpc_shortstr_insert{$endif}(const source : shortstring;var s : shortstring;index : SizeInt);
var
cut,srclen,indexlen : SizeInt;
begin
if index<1 then
index:=1;
if index>length(s) then
begin
index:=length(s)+1;
if index>high(s) then
exit;
end;
indexlen:=Length(s)-Index+1;
srclen:=length(Source);
if sizeInt(length(source))+sizeint(length(s))>=sizeof(s) then
begin
cut:=sizeInt(length(source))+sizeint(length(s))-sizeof(s)+1;
if cut>indexlen then
begin
dec(srclen,cut-indexlen);
indexlen:=0;
end
else
dec(indexlen,cut);
end;
fpc_shortstr_shortstr_intern_charmove(s,Index,s,Index+srclen,indexlen);
fpc_shortstr_shortstr_intern_charmove(Source,1,s,Index,srclen);
s[0]:=chr(index+srclen+indexlen-1);
end;
{$endif FPC_HAS_SHORTSTR_INSERT}
{$ifndef FPC_HAS_SHORTSTR_INSERT_CHAR}
{$define FPC_HAS_SHORTSTR_INSERT_CHAR}
procedure {$ifdef ver3_0}insert{$else}fpc_shortstr_insert_char{$endif}(source : AnsiChar;var s : shortstring;index : SizeInt);
var
indexlen : SizeInt;
begin
if index<1 then
index:=1;
if index>length(s) then
begin
index:=length(s)+1;
if index>high(s) then
exit;
end;
indexlen:=Length(s)-Index+1;
if (sizeint(length(s))+1=sizeof(s)) and (indexlen>0) then
dec(indexlen);
fpc_shortstr_shortstr_intern_charmove(s,Index,s,Index+1,indexlen);
s[Index]:=Source;
s[0]:=chr(index+indexlen);
end;
{$endif FPC_HAS_SHORTSTR_INSERT_CHAR}
{$ifndef FPC_HAS_SHORTSTR_POS_SHORTSTR}
{$define FPC_HAS_SHORTSTR_POS_SHORTSTR}
function pos(const substr : shortstring;const s : shortstring; Offset : Sizeint = 1):SizeInt;
var
i,MaxLen,d : SizeInt;
begin
Pos:=0;
if (Length(SubStr)>0) and (Offset>0) and (Offset<=Length(S)) then
begin
MaxLen:=sizeint(Length(s))-Length(SubStr)+1;
i:=Offset;
while (i<=MaxLen) do
begin
d:=IndexByte(s[i],MaxLen-i+1,byte(substr[1]));
if d<0 then
exit;
if (CompareByte(Substr[1],s[i+d],Length(SubStr))=0) then
exit(i+d);
i:=i+d+1;
end;
end;
end;
{$endif FPC_HAS_SHORTSTR_POS_SHORTSTR}
{$ifndef FPC_HAS_SHORTSTR_POS_CHAR}
{$define FPC_HAS_SHORTSTR_POS_CHAR}
{Faster when looking for a single AnsiChar...}
function pos(c:ansichar;const s:shortstring; Offset : Sizeint = 1 ):SizeInt;
var
idx : SizeInt;
begin
Pos:=0;
if (Offset<1) or (Offset>Length(S)) then
exit;
idx:=IndexByte(s[Offset],length(s)-Offset+1,byte(c));
if idx>=0 then
Pos:=Offset+idx;
end;
{$endif FPC_HAS_SHORTSTR_POS_CHAR}
function fpc_char_copy(c:ansichar;index : SizeInt;count : SizeInt): shortstring;compilerproc;
begin
if (index=1) and (Count>0) then
fpc_char_Copy:=c
else
fpc_char_Copy:='';
end;
function pos(const substr : shortstring;c:Ansichar; Offset : Sizeint = 1): SizeInt;
begin
if (length(substr)=1) and (substr[1]=c) and (Offset=1) then
Pos:=1
else
Pos:=0;
end;
{$if not defined(FPC_UPCASE_CHAR) or not defined(FPC_LOWERCASE_CHAR)}
{$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}
{$endif}
{$ifndef FPC_UPCASE_CHAR}
{$define FPC_UPCASE_CHAR}
function upcase(c : Ansichar) : Ansichar;
{$IFDEF IBM_CHAR_SET}
var
i : ObjpasInt;
{$ENDIF}
begin
if (c in ['a'..'z']) then
upcase:=AnsiChar(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;
{$endif FPC_UPCASE_CHAR}
{$ifndef FPC_UPCASE_SHORTSTR}
{$define FPC_UPCASE_SHORTSTR}
function upcase(const s : shortstring) : shortstring;
var
i : ObjpasInt;
begin
upcase[0]:=s[0];
for i := 1 to length (s) do
upcase[i] := upcase (s[i]);
end;
{$endif FPC_UPCASE_SHORTSTR}
{$ifndef FPC_LOWERCASE_CHAR}
{$define FPC_LOWERCASE_CHAR}
function lowercase(c : AnsiChar) : AnsiChar;overload;
{$IFDEF IBM_CHAR_SET}
var
i : ObjpasInt;
{$ENDIF}
begin
if (c in ['A'..'Z']) then
lowercase:=AnsiChar(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;
{$endif FPC_LOWERCASE_CHAR}
{$ifndef FPC_LOWERCASE_SHORTSTR}
{$define FPC_LOWERCASE_SHORTSTR}
function lowercase(const s : shortstring) : shortstring; overload;
var
i : ObjpasInt;
begin
lowercase [0]:=s[0];
for i:=1 to length(s) do
lowercase[i]:=lowercase (s[i]);
end;
{$endif FPC_LOWERCASE_SHORTSTR}
const
HexTbl : array[0..15] of AnsiChar='0123456789ABCDEF';
function hexstr(val : longint;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
hexstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
hexstr[i]:=hextbl[val and $f];
val:=val shr 4;
end;
end;
function octstr(val : longint;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
octstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
octstr[i]:=hextbl[val and 7];
val:=val shr 3;
end;
end;
function binstr(val : longint;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
binstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
binstr[i]:=AnsiChar(48+val and 1);
val:=val shr 1;
end;
end;
function hexstr(val : int64;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
hexstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
hexstr[i]:=hextbl[val and $f];
val:=val shr 4;
end;
end;
function octstr(val : int64;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
octstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
octstr[i]:=hextbl[val and 7];
val:=val shr 3;
end;
end;
function binstr(val : int64;cnt : byte) : shortstring;
var
i : ObjpasInt;
begin
binstr[0]:=AnsiChar(cnt);
for i:=cnt downto 1 do
begin
binstr[i]:=AnsiChar(48+val and 1);
val:=val shr 1;
end;
end;
{$ifndef FPC_HAS_QWORD_HEX_SHORTSTR}
{$define FPC_HAS_QWORD_HEX_SHORTSTR}
Function hexStr(Val:qword;cnt:byte):shortstring;
begin
hexStr:=hexStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_HEX_SHORTSTR}
{$ifndef FPC_HAS_QWORD_OCT_SHORTSTR}
{$define FPC_HAS_QWORD_OCT_SHORTSTR}
Function OctStr(Val:qword;cnt:byte):shortstring;
begin
OctStr:=OctStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_OCT_SHORTSTR}
{$ifndef FPC_HAS_QWORD_BIN_SHORTSTR}
{$define FPC_HAS_QWORD_BIN_SHORTSTR}
Function binStr(Val:qword;cnt:byte):shortstring;
begin
binStr:=binStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_BIN_SHORTSTR}
{$ifndef FPC_HAS_HEXSTR_POINTER_SHORTSTR}
{$define FPC_HAS_HEXSTR_POINTER_SHORTSTR}
function hexstr(val : pointer) : shortstring;
var
i : ObjpasInt;
v : ptruint;
begin
v:=ptruint(val);
hexstr[0]:=chr(sizeof(pointer)*2);
for i:=sizeof(pointer)*2 downto 1 do
begin
hexstr[i]:=hextbl[v and $f];
v:=v shr 4;
end;
end;
{$endif FPC_HAS_HEXSTR_POINTER_SHORTSTR}
{$ifndef FPC_HAS_SPACE_SHORTSTR}
{$define FPC_HAS_SPACE_SHORTSTR}
function space (b : byte): shortstring;
begin
space[0] := chr(b);
FillChar (Space[1],b,' ');
end;
{$endif FPC_HAS_SPACE_SHORTSTR}
{*****************************************************************************
Str() Helpers
*****************************************************************************}
procedure fpc_shortstr_SInt(v : valSInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_SINT']; compilerproc;
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_UInt(v : valUInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_UINT']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
{$ifndef CPU64}
procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64']; compilerproc;
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
procedure fpc_shortstr_longword(v : longword;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_LONGWORD']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_longint(v : longint;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT']; compilerproc;
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_word(v : word;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_WORD']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_smallint(v : smallint;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_SMALLINT']; compilerproc;
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
{$endif CPU16 or CPU8}
{ fpc_shortstr_sInt must appear before this file is included, because }
{ it's used inside real2str.inc and otherwise the searching via the }
{ compilerproc name will fail (JM) }
{$ifndef FPUNONE}
{$I flt_conv.inc}
{$endif}
{$ifndef FPUNONE}
procedure fpc_shortstr_float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT']; compilerproc;
begin
str_real(len,fr,d,treal_type(rt),s);
end;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_shortstr_enum_intern(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring): longint;
{$ifndef FPC_HAS_FEATURE_RTTI}
begin
int_str(ordinal,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
{$else with RTTI feature}
{ The following contains the TTypeInfo/TTypeData records from typinfo.pp
specialized for the tkEnumeration case (and stripped of unused things). }
type
PPstring=^Pstring;
Penum_typeinfo=^Tenum_typeinfo;
Tenum_typeinfo={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
kind:TTypeKind; { always tkEnumeration }
num_chars:byte;
chars:array[0..0] of AnsiChar; { variable length with size of num_chars }
end;
{$push}
{$packrecords c}
Penum_typedata=^Tenum_typedata;
Tenum_typedata={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
{$if declared(TRttiDataCommon)}
Common: TRttiDataCommon;
{$endif}
case TTypeKind of
{$ifndef VER3_0}
tkInt64,tkQWord,
{$endif VER3_0}
tkInteger,tkChar,tkEnumeration,tkBool,tkWChar: (
OrdType : Byte;
case TTypeKind of
tkInteger,tkChar,tkEnumeration,tkBool,tkWChar: (
MinValue,MaxValue : Longint;
case TTypeKind of
tkEnumeration: (
BaseTypeRef : pointer
);
{$ifndef VER3_0}
{tkBool with OrdType=otSQWord }
tkInt64:
(MinInt64Value, MaxInt64Value: Int64);
{tkBool with OrdType=otUQWord }
tkQWord:
(MinQWordValue, MaxQWordValue: QWord);
{$endif VER3_0}
);
);
{ more data here, but not needed }
end;
{ Pascal data types for the ordinal enum value to string table. It consists of a header
that indicates what type of data the table stores, either a direct lookup table (when
o = lookup) or a set of ordered (ordinal value, string) tuples (when o = search). }
{ A single entry in the set of ordered tuples }
Psearch_data=^Tsearch_data;
Tsearch_data={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
value:longint;
name:Pstring;
end;
Penum_ord_to_string=^Tenum_ord_to_string;
Tenum_ord_to_string={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
o:(lookup,search);
case integer of
0: (lookup_data:array[0..0] of Pstring);
1: (num_entries:longint;
search_data:array[0..0] of Tsearch_data);
end;
{$pop}
var
enum_o2s : Penum_ord_to_string;
header:Penum_typeinfo;
body:Penum_typedata;
res:Pshortstring;
sorted_data:Psearch_data;
spaces,i,m,h,l:longint;
begin
{ set default return value }
fpc_shortstr_enum_intern:=107;
enum_o2s:=Penum_ord_to_string(ord2strindex);
{ depending on the type of table in ord2strindex retrieve the data }
if (enum_o2s^.o=lookup) then
begin
{ direct lookup table }
header:=Penum_typeinfo(typinfo);
{ calculate address of enum rtti body: add the actual size of the
enum_rtti_header, and then align. Use an alignment of 1 (which
does nothing) in case FPC_REQUIRES_PROPER_ALIGNMENT is not set
to avoid the need for an if in this situation }
{$ifdef VER3_0}
body:=Penum_typedata(aligntoptr(pointer(header) + 2 * sizeof(byte) { kind, num_chars } + header^.num_chars));
{$else VER3_0}
body:=Penum_typedata(aligntoqword(pointer(header) + 2 * sizeof(byte) { kind, num_chars } + header^.num_chars));
{$endif VER3_0}
with body^ do
begin
{ Bounds check for the ordinal value for this enum }
if (ordinal<minvalue) or (ordinal>maxvalue) then
exit;
{ make the ordinal index for lookup zero-based }
dec(ordinal,minvalue);
end;
{ temporarily disable range checking because of the access to the array[0..0]
member of Tenum_ord_to_string_lookup }
{$push}{$R-}
res:=enum_o2s^.lookup_data[ordinal];
{$pop}
if (not assigned(res)) then
exit;
s:=res^;
end
else
begin
{ The compiler did generate a sorted array of (ordvalue,Pstring) tuples }
sorted_data:=@enum_o2s^.search_data;
{ Use a binary search to get the string }
l:=0;
{ temporarily disable range checking because of the access to the array[0..0]
member of Tenum_ord_to_string_search }
{$push}{$R-}
h:=enum_o2s^.num_entries-1;
repeat
m:=(l+h) div 2;
if ordinal>sorted_data[m].value then
l:=m+1
else if ordinal<sorted_data[m].value then
h:=m-1
else
break;
if l>h then
exit; { Ordinal value not found? Exit }
until false;
{$pop}
s:=sorted_data[m].name^;
end;
{ Pad the string with spaces if necessary }
if (len>length(s)) then
begin
spaces:=len-length(s);
for i:=1 to spaces do
s[length(s)+i]:=' ';
inc(byte(s[0]),spaces);
end;
fpc_shortstr_enum_intern:=0;
end;
{$endif with RTTI feature}
procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring);[public,alias:'FPC_SHORTSTR_ENUM'];compilerproc;
var
res: longint;
begin
res:=fpc_shortstr_enum_intern(ordinal,len,typinfo,ord2strindex,s);
if (res<>0) then
runerror(107);
end;
{ also define alias for internal use in the system unit }
procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring);external name 'FPC_SHORTSTR_ENUM';
{$endif FPC_SHORTSTR_ENUM_INTERN}
procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);[public,alias:'FPC_SHORTSTR_BOOL'];compilerproc;
begin
if b then
s:='TRUE'
else
s:='FALSE';
if length(s)<len then
s:=space(len-length(s))+s;
end;
{ also define alias for internal use in the system unit }
procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);external {$ifndef cpujvm}name 'FPC_SHORTSTR_BOOL'{$endif};
procedure fpc_shortstr_currency({$ifdef cpujvm}constref{$endif} c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
const
MinLen = 8; { Minimal string length in scientific format }
var
buf : array[1..19] of AnsiChar;
i,j,k,reslen,tlen,sign,r,point : ObjpasInt;
ic : qword;
begin
fillchar(buf,length(buf),'0');
{ default value for length is -32767 }
if len=-32767 then
len:=25;
if PInt64(@c)^ >= 0 then
begin
ic:=QWord(PInt64(@c)^);
sign:=0;
end
else
begin
sign:=1;
ic:=QWord(-PInt64(@c)^);
end;
{ converting to integer string }
tlen:=0;
repeat
Inc(tlen);
buf[tlen]:=Chr(ic mod 10 + $30);
ic:=ic div 10;
until ic = 0;
{ calculating:
reslen - length of result string,
r - rounding or appending zeroes,
point - place of decimal point }
reslen:=tlen;
if f <> 0 then
Inc(reslen); { adding decimal point length }
if f < 0 then
begin
{ scientific format }
Inc(reslen,5); { adding length of sign and exponent }
if len < MinLen then
len:=MinLen;
r:=reslen-len;
if reslen < len then
reslen:=len;
if r > 0 then
begin
reslen:=len;
point:=tlen - r;
end
else
point:=tlen;
end
else
begin
{ fixed format }
Inc(reslen, sign);
{ prepending fractional part with zeroes }
while tlen < 5 do
begin
Inc(reslen);
Inc(tlen);
buf[tlen]:='0';
end;
{ Currency have 4 digits in fractional part }
r:=4 - f;
point:=f;
if point <> 0 then
begin
if point > 4 then
point:=4;
Inc(point);
end;
Dec(reslen,r);
end;
{ rounding string if r > 0 }
if r > 0 then
begin
k := 0;
i := r+2;
if i > tlen then
i := tlen+1;
if buf[i-2] >= '5' then
begin
if buf[i-1] < '9' then
buf[i-1] := chr(ord(buf[i-1])+1)
else
begin
buf[i-1] := '0';
k := 1;
end;
end;
If (k=1) and (buf[i-1]='0') then
begin
{ 1.9996 rounded to two decimal digits after the decimal separator must result in
2.00, i.e. the rounding is propagated
}
while buf[i]='9' do
begin
buf[i]:='0';
inc(i);
end;
buf[i]:=chr(Ord(buf[i])+1);
{ did we add another digit? This happens when rounding
e.g. 99.9996 to two decimal digits after the decimal separator which should result in
100.00
}
if i>tlen then
begin
inc(reslen);
inc(tlen);
end;
end;
end;
{ preparing result string }
if reslen<len then
reslen:=len;
if reslen>High(s) then
begin
if r < 0 then
Inc(r, reslen - High(s));
reslen:=High(s);
end;
SetLength(s,reslen);
j:=reslen;
if f<0 then
begin
{ writing power of 10 part }
if PInt64(@c)^ = 0 then
k:=0
else
k:=tlen-5;
if k >= 0 then
s[j-2]:='+'
else
begin
s[j-2]:='-';
k:=-k;
end;
s[j]:=Chr(k mod 10 + $30);
Dec(j);
s[j]:=Chr(k div 10 + $30);
Dec(j,2);
s[j]:='E';
Dec(j);
end;
{ writing extra zeroes if r < 0 }
while r < 0 do
begin
s[j]:='0';
Dec(j);
Inc(r);
end;
{ writing digits and decimal point }
for i:=r + 1 to tlen do
begin
Dec(point);
if point = 0 then
begin
s[j]:='.';
Dec(j);
end;
s[j]:=buf[i];
Dec(j);
end;
{ writing sign }
if sign = 1 then
begin
s[j]:='-';
Dec(j);
end;
{ writing spaces }
while j > 0 do
begin
s[j]:=' ';
Dec(j);
end;
end;
{
Array Of AnsiChar Str() helpers
}
procedure fpc_chararray_sint(v : valsint;len : SizeInt;out a:array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
procedure fpc_chararray_uint(v : valuint;len : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str_unsigned(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$ifndef CPU64}
procedure fpc_chararray_qword(v : qword;len : SizeInt;out a : array of AnsiChar);compilerproc;
{$ifdef EXCLUDE_COMPLEX_PROCS}
begin
runerror(219);
end;
{$else EXCLUDE_COMPLEX_PROCS}
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str_unsigned(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif EXCLUDE_COMPLEX_PROCS}
procedure fpc_chararray_int64(v : int64;len : SizeInt;out a : array of AnsiChar);compilerproc;
{$ifdef EXCLUDE_COMPLEX_PROCS}
begin
runerror(219);
end;
{$else EXCLUDE_COMPLEX_PROCS}
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif EXCLUDE_COMPLEX_PROCS}
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
procedure fpc_chararray_longword(v : longword;len : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str_unsigned(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
procedure fpc_chararray_longint(v : longint;len : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
procedure fpc_chararray_word(v : word;len : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str_unsigned(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
procedure fpc_chararray_smallint(v : smallint;len : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
int_str(v,ss);
if length(ss)<len then
ss:=space(len-length(ss))+ss;
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif CPU16 or CPU8}
{$ifndef FPUNONE}
procedure fpc_chararray_Float(d : ValReal;len,fr,rt : SizeInt;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
str_real(len,fr,d,treal_type(rt),ss);
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
{ currently, the avr code generator fails on this procedure, so we disable it,
this is not a good solution but fixing compilation of this procedure for
avr is hard, requires significant changes to the register allocator to take
care of different register classes }
procedure fpc_chararray_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
{$ifdef EXCLUDE_COMPLEX_PROCS}
runerror(219);
{$else EXCLUDE_COMPLEX_PROCS}
fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss);
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
{$endif EXCLUDE_COMPLEX_PROCS}
end;
{$endif not FPC_STR_ENUM_INTERN}
procedure fpc_chararray_bool(b : boolean;len:sizeint;out a : array of AnsiChar);compilerproc;
var
ss : shortstring;
maxlen : SizeInt;
begin
fpc_shortstr_bool(b,len,ss);
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$ifndef FPC_HAS_CHARARRAY_CURRENCY}
{$define FPC_HAS_CHARARRAY_CURRENCY}
procedure fpc_chararray_Currency(c : Currency;len,fr : SizeInt;out a : array of AnsiChar);compilerproc;
{$ifdef EXCLUDE_COMPLEX_PROCS}
begin
runerror(217);
end;
{$else EXCLUDE_COMPLEX_PROCS}
var
ss : shortstring;
maxlen : SizeInt;
begin
str(c:len:fr,ss);
if length(ss)<high(a)+1 then
maxlen:=length(ss)
else
maxlen:=high(a)+1;
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif EXCLUDE_COMPLEX_PROCS}
{$endif FPC_HAS_CHARARRAY_CURRENCY}
{*****************************************************************************
Val() Functions
*****************************************************************************}
Function InitVal(const s:shortstring;out negativ:boolean;out base:byte):ValSInt;
var
Code : SizeInt;
begin
code:=1;
negativ:=false;
base:=10;
if length(s)=0 then
begin
InitVal:=code;
Exit;
end;
{Skip Spaces and Tab}
while (code<=length(s)) and (s[code] in [' ',#9]) do
inc(code);
{Sign}
case s[code] of
'-' : begin
negativ:=true;
inc(code);
end;
'+' : inc(code);
end;
{Base}
if code<=length(s) then
begin
case s[code] of
'$',
'X',
'x' : begin
base:=16;
inc(code);
end;
'%' : begin
base:=2;
inc(code);
end;
'&' : begin
Base:=8;
inc(code);
end;
'0' : begin
if (code < length(s)) and (s[code+1] in ['x', 'X']) then
begin
inc(code, 2);
base := 16;
end;
end;
end;
end;
{ strip leading zeros }
while ((code < length(s)) and (s[code] = '0')) do begin
inc(code);
end;
InitVal:=code;
end;
const
ValValueArray : array['0'..'f'] of byte = (0,1,2,3,4,5,6,7,8,9,$FF,$FF,$FF,$FF,$FF,$FF,$FF,10,11,12,13,14,15,
$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,
10,11,12,13,14,15);
Function fpc_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR']; compilerproc;
var
temp, prev, maxPrevValue: ValUInt;
base,u : byte;
negative: boolean;
UnsignedUpperLimit: ValUInt;
begin
fpc_Val_SInt_ShortStr := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
{ avoid error about being uninitialized }
UnsignedUpperLimit := 0;
if (base=10) or negative then
begin //always limit to either Low(DestType) or High(DestType)
case DestSize of
1: UnsignedUpperLimit := ValUInt(High(ShortInt))+Ord(negative);
2: UnsignedUpperLimit := ValUInt(High(SmallInt))+Ord(negative);
4: UnsignedUpperLimit := ValUInt(High(LongInt))+Ord(negative);
{$ifdef CPU64}
8: UnsignedUpperLimit := ValUInt(High(Int64))+Ord(negative);
{$endif CPU64}
end;
end
else
begin //not decimal and not negative
case DestSize of
1: UnsignedUpperLimit := High(Byte);
2: UnsignedUpperLimit := High(Word);
4: UnsignedUpperLimit := High(DWord);
{$ifdef CPU64}
8: UnsignedUpperLimit := High(UInt64);
{$endif CPU64}
end;
end;
if Code>length(s) then
exit;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
maxPrevValue := ValUInt(MaxUIntValue) div ValUInt(Base);
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
Prev := Temp;
Temp := Temp*ValUInt(base);
If (u >= base) or
(prev > maxPrevValue)
or ((Temp)>(UnsignedUpperLimit-u)) 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);
{$ifdef cpu64}
4: fpc_Val_SInt_ShortStr := longint(fpc_Val_SInt_ShortStr);
{$endif cpu64}
End;
end;
{$ifndef FPC_HAS_INT_VAL_SINT_SHORTSTR}
{$define FPC_HAS_INT_VAL_SINT_SHORTSTR}
{ we need this for fpc_Val_SInt_Ansistr and fpc_Val_SInt_WideStr because }
{ we have to pass the DestSize parameter on (JM) }
Function int_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; [external name 'FPC_VAL_SINT_SHORTSTR'];
{$endif FPC_HAS_INT_VAL_SINT_SHORTSTR}
Function fpc_Val_UInt_Shortstr({$ifndef VER3_2}DestSize: SizeInt;{$endif VER3_2} Const S: ShortString; out Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR']; compilerproc;
var
base,u : byte;
negative : boolean;
UpperLimit: ValUInt;
begin
fpc_Val_UInt_Shortstr:=0;
Code:=InitVal(s,negative,base);
If Negative or (Code>length(s)) Then
begin
if Negative then Code:=Pos('-',S);
Exit;
end;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
{$ifndef VER3_2}
case DestSize of
1: UpperLimit:=High(Byte);
2: UpperLimit:=High(Word);
4: UpperLimit:=High(DWord);
{$ifdef CPU64}
8: UpperLimit:=High(QWord);
{$endif CPU64}
else
{ avoid error about being uninitialized }
UpperLimit:=0;
end;
{$else VER3_2}
UpperLimit:=High(ValUInt); //this preserves 3.2 (and earlier) behaviour
{$ENDIF}
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
If (u>=base) or
(ValUInt(UpperLimit-u) div ValUInt(Base)<fpc_val_uint_shortstr) 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;
{$ifndef VER3_2}
case DestSize of
1: fpc_Val_UInt_Shortstr:=Byte(fpc_Val_UInt_Shortstr);
2: fpc_Val_UInt_Shortstr:=Word(fpc_Val_UInt_Shortstr);
4: fpc_Val_UInt_Shortstr:=DWord(fpc_Val_UInt_Shortstr);
//8: no typecast needed for QWord
end;
{$ENDIF}
end;
{$ifndef CPU64}
Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; [public, alias:'FPC_VAL_INT64_SHORTSTR']; compilerproc;
var u : sizeuint;
temp, prev, maxprevvalue, maxnewvalue : qword;
base : byte;
negative : boolean;
const maxint64=qword($7fffffffffffffff);
minint64_unsigned=qword($8000000000000000);
maxqword=qword($ffffffffffffffff);
begin
{$ifdef EXCLUDE_COMPLEX_PROCS}
runerror(219);
{$else EXCLUDE_COMPLEX_PROCS}
fpc_val_int64_shortstr := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
if Code>length(s) then
exit;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
maxprevvalue := maxqword div base;
if (base = 10) then
maxnewvalue := maxint64 + ord(negative)
else
maxnewvalue := maxqword;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
Prev:=Temp;
Temp:=Temp*qword(base);
If (u >= base) or
(qword(maxnewvalue-u) < temp) or
(prev > maxprevvalue) or
((base<>10) and (negative) and ((Temp+u)>minint64_unsigned)) Then
Begin
fpc_val_int64_shortstr := 0;
Exit
End;
Temp:=Temp+u;
inc(code);
end;
code:=0;
fpc_val_int64_shortstr:=int64(Temp);
If Negative Then
fpc_val_int64_shortstr:=-fpc_val_int64_shortstr;
{$endif EXCLUDE_COMPLEX_PROCS}
end;
Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; [public, alias:'FPC_VAL_QWORD_SHORTSTR']; compilerproc;
var u : sizeuint;
base : byte;
negative : boolean;
const maxqword=qword($ffffffffffffffff);
begin
fpc_val_qword_shortstr:=0;
Code:=InitVal(s,negative,base);
If Negative or (Code>length(s)) Then
begin
if Negative then Code:=Pos('-',S);
Exit;
end;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
If (u>=base) or
((QWord(maxqword-u) div QWord(base))<fpc_val_qword_shortstr) then
Begin
fpc_val_qword_shortstr := 0;
Exit
End;
fpc_val_qword_shortstr:=fpc_val_qword_shortstr*QWord(base) + u;
inc(code);
end;
code := 0;
end;
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
Function fpc_val_longint_shortstr(Const S: ShortString; out Code: ValSInt): LongInt; [public, alias:'FPC_VAL_LONGINT_SHORTSTR']; compilerproc;
var u, temp, prev, maxprevvalue, maxnewvalue : longword;
base : byte;
negative : boolean;
const maxlongint=longword($7fffffff);
maxlongword=longword($ffffffff);
begin
fpc_val_longint_shortstr := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
if Code>length(s) then
exit;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
maxprevvalue := maxlongword div base;
if (base = 10) then
maxnewvalue := maxlongint + ord(negative)
else
maxnewvalue := maxlongword;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
Prev:=Temp;
Temp:=Temp*longword(base);
If (u >= base) or
(longword(maxnewvalue-u) < temp) or
(prev > maxprevvalue) Then
Begin
fpc_val_longint_shortstr := 0;
Exit;
End;
Temp:=Temp+u;
inc(code);
end;
code:=0;
fpc_val_longint_shortstr:=longint(Temp);
If Negative Then
fpc_val_longint_shortstr:=-fpc_val_longint_shortstr;
end;
Function fpc_val_longword_shortstr(Const S: ShortString; out Code: ValSInt): LongWord; [public, alias:'FPC_VAL_LONGWORD_SHORTSTR']; compilerproc;
var u, prev: LongWord;
base : byte;
negative : boolean;
const UpperLimit=High(longword);
begin
fpc_val_longword_shortstr:=0;
Code:=InitVal(s,negative,base);
If Negative or (Code>length(s)) Then
Exit;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
If (u>=base) or
(LongWord(UpperLimit-u) div LongWord(Base)<fpc_val_longword_shortstr) then
begin
fpc_val_longword_shortstr:=0;
exit;
end;
fpc_val_longword_shortstr:=fpc_val_longword_shortstr*base + u;
inc(code);
end;
code := 0;
end;
Function fpc_val_smallint_shortstr(Const S: ShortString; out Code: ValSInt): SmallInt; [public, alias:'FPC_VAL_SMALLINT_SHORTSTR']; compilerproc;
var u, temp, prev, maxprevvalue : word;
base : byte;
negative : boolean;
UnsignedUpperLimit: ValUInt;
begin
fpc_val_smallint_shortstr := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
if (base=10) or negative then
UnsignedUpperLimit := Word(High(SmallInt))+Ord(negative)
else
UnsignedUpperLimit := High(Word);
if Code>length(s) then
exit;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
maxprevvalue := High(Word) div base;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
Prev:=Temp;
Temp:=Temp*longword(base);
If (u >= base) or
(prev > maxPrevValue) or
((Temp)>(UnsignedUpperLimit-u)) Then
Begin
fpc_val_smallint_shortstr := 0;
Exit
End;
Temp:=Temp+u;
inc(code);
end;
code:=0;
fpc_val_smallint_shortstr:=SmallInt(Temp);
If Negative Then
fpc_val_smallint_shortstr:=-fpc_val_smallint_shortstr;
end;
Function fpc_val_word_shortstr(Const S: ShortString; out Code: ValSInt): Word; [public, alias:'FPC_VAL_WORD_SHORTSTR']; compilerproc;
var u, prev: word;
base : byte;
negative : boolean;
const UpperLimit=High(Word); //this preserves 3.2 (and earlier) behaviour
begin
fpc_val_word_shortstr:=0;
Code:=InitVal(s,negative,base);
If Negative or (Code>length(s)) Then
begin
if Negative then Code:=Pos('-',S);
Exit;
end;
if (s[Code]=#0) then
begin
if (Code>1) and (s[Code-1]='0') then
Code:=0;
exit;
end;
while Code<=Length(s) do
begin
u:=16;
case s[code] of
'0'..'f' : u:=ValValueArray[S[Code]];
#0 : break;
else
;
end;
If (u>=base) or
(Word(UpperLimit-u) div Word(Base)<fpc_val_word_shortstr) then
begin
fpc_val_word_shortstr:=0;
exit;
end;
fpc_val_word_shortstr:=fpc_val_word_shortstr*base + u;
inc(code);
end;
code := 0;
end;
{$endif CPU16 or CPU8}
{$ifndef FPUNONE}
Function fpc_Val_Real_ShortStr(const s : shortstring; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR']; compilerproc;
begin
fpc_Val_Real_ShortStr := val_real( s, code );
end;
{$endif FPUNONE}
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint; [public, alias:'FPC_VAL_ENUM_SHORTSTR']; compilerproc;
function string_compare(const s1,s2:shortstring):sizeint;
{We cannot use the > and < operators to compare a string here, because we if the string is
not found in the enum, we need to return the position of error in "code". Code equals the
highest matching character of all string compares, which is only known inside the string
comparison.}
var i,l:byte;
c1,c2:AnsiChar;
begin
l:=length(s1);
if length(s1)>length(s2) then
l:=length(s2);
i:=1;
while i<=l do
begin
c1:=s1[i];
c2:=s2[i];
if c1<>c2 then
break;
inc(i);
end;
if i>code then
code:=i;
if i<=l then
string_compare:=byte(c1)-byte(c2)
else
string_compare:=length(s1)-length(s2);
end;
type Psorted_array=^Tsorted_array;
Tsorted_array={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
o:longint;
s:Pstring;
end;
Pstring_to_ord=^Tstring_to_ord;
Tstring_to_ord={$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
count:longint;
data:array[0..0] of Tsorted_array;
end;
var l,h,m:cardinal;
c:sizeint;
sorted_array:^Tsorted_array;
spaces:byte;
t:shortstring;
begin
{Val for numbers accepts spaces at the start, so lets do the same
for enums. Skip spaces at the start of the string.}
spaces:=1;
code:=1;
while (spaces<=length(s)) and (s[spaces]=' ') do
inc(spaces);
t:=upcase(copy(s,spaces,255));
sorted_array:=pointer(@Pstring_to_ord(str2ordindex)^.data);
{Use a binary search to get the string.}
l:=1;
h:=Pstring_to_ord(str2ordindex)^.count;
repeat
m:=(l+h) div 2;
c:=string_compare(t,upcase(sorted_array[m-1].s^));
if c>0 then
l:=m+1
else if c<0 then
h:=m-1
else
break;
if l>h then
begin
{Not found...}
inc(code,spaces-1); {Add skipped spaces again.}
{The result of val in case of error is undefined, don't assign a function result.}
exit;
end;
until false;
code:=0;
fpc_val_enum_shortstr:=sorted_array[m-1].o;
end;
{Redeclare fpc_val_enum_shortstr for internal use in the system unit.}
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint;external name 'FPC_VAL_ENUM_SHORTSTR';
{$endif FPC_STR_ENUM_INTERN}
function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
{$ifdef EXCLUDE_COMPLEX_PROCS}
begin
runerror(217);
end;
{$else EXCLUDE_COMPLEX_PROCS}
const
MinInt64 : Int64 =-$8000000000000000;
MinInt64Edge : Int64 = (-$8000000000000000 + 10) div 10;
var
{ to enable taking the address on the JVM target }
res : array[0..0] of Int64;
i,j,power,sign,len : longint;
FracOverflow : boolean;
begin
fpc_Val_Currency_ShortStr:=0;
res[0]:=0;
len:=Length(s);
Code:=1;
sign:=-1;
power:=0;
while True do
if Code > len then
exit
else
if s[Code] in [' ', #9] then
Inc(Code)
else
break;
{ Read sign }
case s[Code] of
'+' : begin
Inc(Code);
end;
'-' : begin
sign:=+1;
Inc(Code);
end;
end;
{ Read digits }
FracOverflow:=False;
i:=0;
while Code <= len do
begin
case s[Code] of
'0'..'9':
begin
j:=Ord(s[code])-Ord('0');
{ check overflow }
if (res[0] >= MinInt64Edge) or (res[0] >= (MinInt64 + j) div 10) then
begin
res[0]:=res[0]*10 - j;
Inc(i);
end
else
if power = 0 then
{ exit if integer part overflow }
exit
else
begin
if not FracOverflow and (j >= 5) and (res[0] > MinInt64) then
{ round if first digit of fractional part overflow }
Dec(res[0]);
FracOverflow:=True;
end;
end;
'.':
begin
if power = 0 then
begin
power:=1;
i:=0;
end
else
exit;
end;
else
break;
end;
Inc(Code);
end;
if (i = 0) and (power = 0) then
exit;
if power <> 0 then
power:=i;
power:=4 - power;
{ Exponent? }
if Code <= len then
if s[Code] in ['E', 'e'] then
begin
Inc(Code);
if Code > len then
exit;
i:=1;
case s[Code] of
'+':
Inc(Code);
'-':
begin
i:=-1;
Inc(Code);
end;
end;
{ read exponent }
j:=0;
while Code <= len do
if s[Code] in ['0'..'9'] then
begin
if j > 4951 then
exit;
j:=j*10 + (Ord(s[code])-Ord('0'));
Inc(Code);
end
else
exit;
power:=power + j*i;
end
else
exit;
if power > 0 then
begin
for i:=1 to power do
if res[0] >= MinInt64 div 10 then
res[0]:=res[0]*10
else
exit;
end
else
for i:=1 to -power do
begin
if res[0] >= MinInt64 + 5 then
Dec(res[0], 5);
res[0]:=res[0] div 10;
end;
if sign <> 1 then
if res[0] > MinInt64 then
res[0]:=res[0]*sign
else
exit;
fpc_Val_Currency_ShortStr:=PCurrency(@res[0])^;
Code:=0;
end;
{$endif EXCLUDE_COMPLEX_PROCS}
{$ifndef FPC_HAS_SETSTRING_SHORTSTR}
{$define FPC_HAS_SETSTRING_SHORTSTR}
Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_shortstr{$else}SetString{$endif}(Out S : Shortstring; Buf : PAnsiChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
If Len > High(S) then
Len := High(S);
SetLength(S,Len);
If Buf<>Nil then
begin
Move (Buf[0],S[1],Len);
end;
end;
{$endif FPC_HAS_SETSTRING_SHORTSTR}
{$ifndef FPC_HAS_COMPARETEXT_SHORTSTR}
{$define FPC_HAS_COMPARETEXT_SHORTSTR}
function ShortCompareText(const S1, S2: shortstring): SizeInt;
var
c1, c2: Byte;
i: SizeInt;
L1, L2, Count: SizeInt;
P1, P2: PAnsiChar;
begin
L1 := Length(S1);
L2 := Length(S2);
if L1 > L2 then
Count := L2
else
Count := L1;
i := 0;
P1 := @S1[1];
P2 := @S2[1];
while i < count do
begin
c1 := byte(p1^);
c2 := byte(p2^);
if c1 <> c2 then
begin
if c1 in [97..122] then
Dec(c1, 32);
if c2 in [97..122] then
Dec(c2, 32);
if c1 <> c2 then
Break;
end;
Inc(P1); Inc(P2); Inc(I);
end;
if i < count then
ShortCompareText := c1 - c2
else
ShortCompareText := L1 - L2;
end;
{$endif FPC_HAS_COMPARETEXT_SHORTSTR}
Reference in New Issue View Git Blame Copy Permalink