paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-03 07:13:45 +02:00
Code Issues Packages Projects Releases Wiki Activity
ebd738f2f5
fpc/rtl/inc/sstrings.inc
peter ebd738f2f5 * removed temp defines
1999-07-05 20:04:21 +00:00

661 lines
15 KiB
PHP
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 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}
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 index+count>length(s) 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+Index>length(s) 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,j : StrLenInt;
e : boolean;
begin
i := 0;
j := 0;
e:=(length(SubStr)>0);
while e and (i<=Length(s)-Length(SubStr)) do
begin
inc(i);
if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then
begin
j:=i;
e:=false;
end;
end;
Pos:=j;
end;
{Faster when looking for a single char...}
function pos(c:char;const s:shortstring):StrLenInt;
var
i : StrLenInt;
begin
for i:=1 to length(s) do
if s[i]=c then
begin
pos:=i;
exit;
end;
pos:=0;
end;
procedure SetLength(var s:shortstring;len:StrLenInt);
begin
if Len>255 then
Len:=255;
s[0]:=chr(len);
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;
{ removed must be internal to be accepted in const expr !! PM
function length(c:char):StrLenInt;
begin
Length:=1;
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;
{$ifndef RTLLITE}
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;
function hexstr(val : longint;cnt : byte) : shortstring;
const
HexTbl : array[0..15] of char='0123456789ABCDEF';
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;
{$endif RTLLITE}
function space (b : byte): shortstring;
begin
space[0] := chr(b);
FillChar (Space[1],b,' ');
end;
{*****************************************************************************
Str() Helpers
*****************************************************************************}
procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT'];
begin
str_real(len,fr,d,treal_type(rt),s);
end;
procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT'];
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL'];
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 ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
var
u: ValSInt;
base : byte;
negative : boolean;
temp, prev: ValUInt;
begin
ValSignedInt := 0;
Temp:=0;
Code:=InitVal(s,negative,base);
if Code>length(s) then
exit;
if negative and (s='-2147483648') then
begin
Code:=0;
ValSignedInt:=$80000000;
exit;
end;
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 ((base = 10) and
(prev > MaxSIntValue div ValUInt(Base))) or
(Temp < prev) Then
Begin
ValSignedInt := 0;
Exit
End;
if (u>=base) or
((base = 10) and
(MaxSIntValue-Temp < u)) or
((base <> 10) and
(MaxUIntValue-Temp < u)) then
begin
ValSignedInt:=0;
exit;
end;
Temp:=Temp+u;
inc(code);
end;
code := 0;
ValSignedInt := ValSInt(Temp);
If Negative Then
ValSignedInt := -ValSignedInt;
If Not(Negative) and (base <> 10) Then
{sign extend the result to allow proper range checking}
Case DestSize of
1: If (ValSignedInt > High(ShortInt)) and (ValSignedInt <= High(Byte)) Then
ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Byte));
2: If (ValSignedInt > High(Integer)) and (ValSignedInt <= High(Word)) Then
ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Word));
{ Uncomment the folling once full 64bit support is in place
4: If (ValSignedInt > High(Longint)) and (ValSignedInt <= High(Cardinal)) Then
ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Cardinal));}
End;
end;
Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
var
u: ValUInt;
base : byte;
negative : boolean;
prev: ValUInt;
begin
ValUnSignedInt:=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 := ValUnsignedInt;
ValUnsignedInt:=ValUnsignedInt*ValUInt(base);
If prev > ValUnsignedInt Then
{we've had an overflow. Can't check this with
"If ValUnsignedInt <= (MaxUIntValue div ValUInt(Base)) Then"
because this division always overflows! (JM)}
Begin
ValUnsignedInt := 0;
Exit
End;
if (u>=base) or (MaxUIntValue-ValUnsignedInt < u) then
begin
ValUnsignedInt:=0;
exit;
end;
ValUnsignedInt:=ValUnsignedInt+u;
inc(code);
end;
code := 0;
end;
Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
var
hd,
esign,sign : valreal;
exponent,i : longint;
flags : byte;
begin
ValFloat:=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;
valfloat:=valfloat*10;
valfloat:=valfloat+(ord(s[code])-ord('0'));
inc(code);
end;
{ Decimal ? }
if (s[code]='.') and (length(s)>=code) then
begin
hd:=0.1;
inc(code);
while (s[code] in ['0'..'9']) and (length(s)>=code) do
begin
{ Read fractional part. }
flags:=flags or 2;
valfloat:=valfloat+hd*(ord(s[code])-ord('0'));
hd:=hd/10.0;
inc(code);
end;
end;
{ Again, read integer and fractional part}
if flags=0 then
begin
valfloat:=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
valfloat:=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
valfloat:=valfloat*10
else
for i:=1 to exponent do
valfloat:=valfloat/10;
{ Not all characters are read ? }
if length(s)>=code then
begin
valfloat:=0.0;
exit;
end;
{ evaluate sign }
valfloat:=valfloat*sign;
{ success ! }
code:=0;
end;
{$ifdef SUPPORT_FIXED}
Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
begin
ValFixed := Fixed(ValFloat(s,code));
end;
{$endif SUPPORT_FIXED}
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
begin
Move (Buf[0],S[1],Len);
S[0]:=chr(len);
end;
{
$Log$
Revision 1.29 1999-07-05 20:04:26 peter
* removed temp defines
Revision 1.28 1999/05/06 09:05:13 peter
* generic write_float str_float
Revision 1.27 1999/04/08 15:57:54 peter
+ subrange checking for readln()
Revision 1.26 1999/04/05 12:28:27 michael
+ Fixed insert with char. length byte wrapped around in some cases.
Revision 1.25 1999/04/01 22:11:50 peter
* fixed '1.' parsing of val
Revision 1.24 1999/04/01 22:00:49 peter
* universal names for str/val (ansistr instead of stransi)
* '1.' support for val() this is compatible with tp7
Revision 1.23 1999/03/26 00:24:16 peter
* last para changed to long for easier pushing with 4 byte aligns
Revision 1.22 1999/03/16 17:49:36 jonas
* changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
* in text.inc: changed RTE 106 when read integer values are out of bounds to RTE 201
* in systemh.inc: disabled "support_fixed" for the i386 because it gave internal errors,
Revision 1.21 1999/03/10 21:49:03 florian
* str and val for extended use now int constants to minimize
rounding error
Revision 1.20 1999/03/03 15:23:57 michael
+ Added setstring for Delphi compatibility
Revision 1.19 1999/01/25 20:24:28 peter
* fixed insert to support again the max string length
Revision 1.18 1999/01/11 19:26:55 jonas
* made inster(string,string,index) a bit faster
+ overloaded insert(char,string,index)
Revision 1.17 1998/12/15 22:43:02 peter
* removed temp symbols
Revision 1.16 1998/11/05 10:29:34 pierre
* fix for length(char) in const expressions
Revision 1.15 1998/11/04 10:20:50 peter
* ansistring fixes
Revision 1.14 1998/10/11 14:30:19 peter
* small typo :(
Revision 1.13 1998/10/10 15:28:46 peter
+ read single,fixed
+ val with code:longint
+ val for fixed
Revision 1.12 1998/09/14 10:48:19 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.11 1998/08/11 21:39:07 peter
* splitted default_extended from support_extended
Revision 1.10 1998/08/08 12:28:13 florian
* a lot small fixes to the extended data type work
Revision 1.9 1998/07/18 17:14:23 florian
* strlenint type implemented
Revision 1.8 1998/07/10 11:02:38 peter
* support_fixed, becuase fixed is not 100% yet for the m68k
Revision 1.7 1998/07/02 12:14:19 carl
* No SINGLE type for non-intel processors!!
Revision 1.6 1998/06/25 09:44:19 daniel
+ RTLLITE directive to compile minimal RTL.
Revision 1.5 1998/06/04 23:45:59 peter
* comp,extended are only i386 added support_comp,support_extended
Revision 1.4 1998/05/31 14:14:52 peter
* removed warnings using comp()
Revision 1.3 1998/05/12 10:42:45 peter
* moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit
* removed logs
* removed $ifdef ver_above
}
Reference in New Issue View Git Blame Copy Permalink