paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-28 13:43:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
869769c502
fpc/rtl/inc/astrings.pp
michael 869769c502 Fixed assignment of NIL string.
1998-10-30 21:42:48 +00:00

789 lines
17 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by Michael Van Canneyt,
member of 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.
**********************************************************************}
{ ---------------------------------------------------------------------
This file implements AnsiStrings for FPC
---------------------------------------------------------------------}
{
This file contains the implementation of the LongString type,
and all things that are needed for it.
AnsiSTring is defined as a 'silent' pchar :
a pchar that points to :
@-12 : Longint for maximum size;
@-8 : Longint for size;
@-4 : Longint for reference count;
@ : String + Terminating #0;
Pchar(Ansistring) is a valid typecast.
So AS[i] is converted to the address @AS+i-1.
Constants should be assigned a reference count of -1
Meaning that they can't be disposed of.
}
// Type shortstring=string;
Function NewAnsiString (Len : Longint) : Pointer; forward;
Procedure DisposeAnsiString (Var S : Pointer); forward;
Procedure Decr_Ansi_Ref (Var S : Pointer); forward;
Procedure Incr_Ansi_Ref (Var S : Pointer); forward;
Procedure AssignAnsiString (Var S1 : Pointer; S2 : Pointer); forward;
Function Ansi_String_Concat (S1,S2 : Pointer): Pointer; forward;
Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Var S2 : ShortString); forward;
Procedure Ansi_To_ShortString (Var S1 : ShortString; S2 : Pointer; maxlen : longint); forward;
Procedure Short_To_AnsiString (Var S1 : Pointer; Const S2 : ShortString); forward;
Function AnsiCompare (S1,S2 : Pointer): Longint; forward;
Function AnsiCompare (var S1 : Pointer; Var S2 : ShortString): Longint; forward;
Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar); forward;
{$PACKRECORDS 1}
Type TAnsiRec = Record
Maxlen, len, ref : Longint;
First : Char;
end;
PAnsiRec = ^TAnsiRec;
Const AnsiRecLen = SizeOf(TAnsiRec);
FirstOff = SizeOf(TAnsiRec)-1;
{ ---------------------------------------------------------------------
Internal functions, not in interface.
---------------------------------------------------------------------}
Procedure DumpAnsiRec(S : Pointer);
begin
If S=Nil then
Writeln ('String is nil')
Else
Begin
With PAnsiRec(S-Firstoff)^ do
begin
Write ('(Maxlen: ',maxlen);
Write (' Len:',len);
Writeln (' Ref: ',ref,')');
end;
end;
end;
Function NewAnsiString(Len : Longint) : Pointer;
{
Allocate a new AnsiString on the heap.
initialize it to zero length and reference count 1.
}
Var P : Pointer;
begin
GetMem(P,Len+AnsiRecLen);
If P<>Nil then
begin
PAnsiRec(P)^.Maxlen:=Len; { Maximal length }
PAnsiRec(P)^.Len:=0; { Initial length }
PAnsiRec(P)^.Ref:=1; { Set reference count }
PAnsiRec(P)^.First:=#0; { Terminating #0 }
P:=P+FirstOff; { Points to string now }
end;
NewAnsiString:=P;
end;
Procedure DisposeAnsiString(Var S : Pointer);
{
Deallocates a AnsiString From the heap.
}
begin
// Writeln ('In disposeAnsiSTring');
If S=Nil
then exit;
Dec (Longint(S),FirstOff);
FreeMem (S,PAnsiRec(S)^.Maxlen+AnsiRecLen);
S:=Nil;
end;
Procedure Decr_Ansi_Ref (Var S : Pointer);
[Public,Alias : 'FPC_DECR_ANSI_REF'];
{
Decreases the ReferenceCount of a non constant ansistring;
If the reference count is zero, deallocate the string;
}
Type plongint = ^longint;
Var l : plongint;
Begin
// dumpansirec(s);
{ Zero string }
If S=Nil then
exit;
{ check for constant strings ...}
l:=S-FirstOff+8;
If l^<0 then exit;
Dec(l^);
// dumpansirec(s);
If l^=0 then
{ Ref count dropped to zero }
begin
// Writeln ('Calling disposestring');
DisposeAnsiString (S); { Remove...}
end
end;
Procedure Incr_Ansi_Ref (Var S : Pointer);
[Public,Alias : 'FPC_INCR_ANSI_REF'];
Begin
If S=Nil then
exit;
{ Let's be paranoid : Constant string ??}
If PAnsiRec(S-FirstOff)^.Ref<0 then exit;
Inc(PAnsiRec(S-FirstOff)^.Ref);
end;
Procedure UniqueAnsiString (Var S : AnsiString); [Public,Alias : 'FPC_UNIQUE_ANSISTRING'];
{
Make sure reference count of S is 1,
using copy-on-write semantics.
}
Var SNew : Pointer;
begin
If Pointer(S)=Nil
then exit;
if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then
begin
SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len);
Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1);
PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len;
Decr_Ansi_Ref (Pointer(S)); { Thread safe }
Pointer(S):=SNew;
end;
end;
Procedure AssignAnsiString (Var S1 : Pointer;S2 : Pointer);
[Public, Alias : 'FPC_ASSIGN_ANSI_STRING'];
{
Assigns S2 to S1 (S1:=S2), taking in account reference counts.
}
begin
If S2<>nil then
If PAnsiRec(S2-FirstOff)^.Ref>0 then
Inc(PAnsiRec(S2-FirstOff)^.ref);
{ Decrease the reference count on the old S1 }
Decr_Ansi_Ref (S1);
{ And finally, have S1 pointing to S2 (or its copy) }
S1:=S2;
end;
function Ansi_String_Concat (S1,S2 : Pointer) : pointer;
[Public, alias: 'FPC_ANSICAT'];
{
Concatenates 2 AnsiStrings : S1+S2.
Result Goes to S3;
}
Var
Size,Location : Longint;
S3 : pointer;
begin
if S2=Nil then exit;
if (S1=Nil) then
AssignAnsiString(S3,S2)
else
begin
S3:=Nil;
Size:=PAnsiRec(S2-FirstOff)^.Len;
Location:=Length(AnsiString(S1));
{ Setlength takes case of uniqueness
and allocated memory. We need to use length,
to take into account possibility of S1=Nil }
SetLength (AnsiString(S3),Size+Location);
Move (S1^,S3^,PAnsiRec(S1-FirstOff)^.Len);
Move (S2^,(S3+location)^,Size+1);
end;
Ansi_String_Concat:=S3;
end;
Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Var S2 : ShortString);
{
Concatenates a Ansi with a short string; : S2 + S2
}
Var Size,Location : Longint;
begin
Size:=byte(S2[0]);
Location:=Length(S1);
If Size=0 then exit;
{ Setlength takes case of uniqueness
and alllocated memory. We need to use length,
to take into account possibility of S1=Nil }
SetLength (S1,Size+Length(S1));
Move (S2[1],Pointer(Pointer(S1)+Location)^,Size);
PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
end;
Procedure Ansi_To_ShortString (Var S1 : ShortString;S2 : Pointer; Maxlen : Longint);
[Public, alias: 'FPC_ANSI2SHORT'];
{
Converts a AnsiString to a ShortString;
}
Var Size : Longint;
begin
Size:=PAnsiRec(S2-FirstOff)^.Len;
If Size>maxlen then Size:=maxlen;
Move (S2^,S1[1],Size);
byte(S1[0]):=Size;
end;
Procedure Short_To_AnsiString (Var S1 : Pointer; Const S2 : ShortString);
[Public, alias: 'FPC_SHORT2ANSI'];
{
Converts a ShortString to a AnsiString;
}
Var Size : Longint;
begin
Size:=Byte(S2[0]);
Setlength (AnsiString(S1),Size);
Move (S2[1],Pointer(S1)^,Size);
{ Terminating Zero }
PByte(Pointer(S1)+Size)^:=0;
end;
Procedure PChar2Ansi(var a : ansistring;p : pchar);[Public,Alias : 'FPC_PCHAR_TO_ANSISTRING'];
begin
//!!!!!!!!! needs to be fixed (FK)
if p[0]=#0 Then
Pointer(a):=nil
else
Pointer(a):=p;
end;
{ the compiler generates inline code for that
Const EmptyChar : char = #0;
Function Ansi2pchar (S : Pointer) : Pchar; [Alias : 'FPC_ANSI2PCHAR'];
begin
If S<>Nil then
Ansi2Pchar:=S
else
Ansi2Pchar:=@emptychar;
end;
}
{ stupid solution, could be done with public,name in later versions }
{$ASMMODE DIRECT}
procedure dummy;assembler;
asm
.globl FPC_EMPTYCHAR
FPC_EMPTYCHAR:
.byte 0
end;
{$ASMMODE ATT}
Function AnsiCompare(S1,S2 : Pointer): Longint;[Public,Alias : 'FPC_ANSICOMPARE'];
{
Compares 2 AnsiStrings;
The result is
<0 if S1<S2
0 if S1=S2
>0 if S1>S2
}
Var i,MaxI,Temp : Longint;
begin
i:=0;
Maxi:=Length(AnsiString(S1));
temp:=Length(AnsiString(S2));
If MaxI>Temp then MaxI:=Temp;
Temp:=0;
While (i<MaxI) and (Temp=0) do
begin
Temp:= PByte(S1+I)^ - PByte(S2+i)^;
inc(i);
end;
if temp=0 then temp:=Length(AnsiString(S1))-Length(AnsiString(S2));
AnsiCompare:=Temp;
end;
Function AnsiCompare (Var S1 : Pointer; Var S2 : ShortString): Longint;
{
Compares a AnsiString with a ShortString;
The result is
<0 if S1<S2
0 if S1=S2
>0 if S1>S2
}
Var i,MaxI,Temp : Longint;
begin
Temp:=0;
i:=0;
MaxI:=Length(AnsiString(S1));
if MaxI>byte(S2[0]) then MaxI:=Byte(S2[0]);
While (i<MaxI) and (Temp=0) do
begin
Temp:= PByte(S1+I)^ - Byte(S2[i+1]);
inc(i);
end;
AnsiCompare:=Temp;
end;
{ Not used, can be removed. }
Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar);
begin
if Index<=Length(S) then
begin
UniqueAnsiString(S);
Pbyte(Pointer(S)+index-1)^:=Byte(C);
end;
end;
{ ---------------------------------------------------------------------
Public functions, In interface.
---------------------------------------------------------------------}
Function Length (Const S : AnsiString) : Longint;
{
Returns the length of an AnsiString.
Takes in acount that zero strings are NIL;
}
begin
If Pointer(S)=Nil then
Length:=0
else
Length:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
end;
Procedure SetLength (Var S : AnsiString; l : Longint);
{
Sets The length of string S to L.
Makes sure S is unique, and contains enough room.
}
Var Temp : Pointer;
begin
If (Pointer(S)=Nil) and (l>0) then
begin
{ Need a complete new string...}
Pointer(s):=NewAnsiString(l);
PAnsiRec(Pointer(S)-FirstOff)^.Len:=l;
PAnsiRec(Pointer(S)-FirstOff)^.MaxLen:=l;
PByte (Pointer(S)+l)^:=0;
end
else if l>0 then
begin
If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or
(PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then
begin
{ Reallocation is needed... }
Temp:=Pointer(NewAnsiString(L));
if Length(S)>0 then
Move (Pointer(S)^,Temp^,Length(S)+1);
Decr_Ansi_ref (Pointer(S));
Pointer(S):=Temp;
end
else
//!! Force nil termination in case it gets shorter
PByte(Pointer(S)+l)^:=0;
PAnsiRec(Pointer(S)-FirstOff)^.Len:=l;
end
else
{ Length=0 }
begin
Decr_Ansi_Ref (Pointer(S));
Pointer(S):=Nil;
end;
end;
Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
var ResultAddress : Pointer;
begin
ResultAddress:=Nil;
dec(index);
{ Check Size. Accounts for Zero-length S }
if Length(S)<Index+Size then
Size:=Length(S)-Index;
If Size>0 then
begin
ResultAddress:=Pointer(NewAnsiString (Size));
if ResultAddress<>Nil then
begin
Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size);
PAnsiRec(ResultAddress-FirstOff)^.Len:=Size;
PByte(ResultAddress+Size)^:=0;
end;
end;
Copy:=AnsiString(ResultAddress);
end;
Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
var i,j : longint;
e : boolean;
s,se : Pointer;
begin
i := 0;
j := 0;
e := true;
if Plongint(substr)^=0 then e := false;
while (e) and (i <= length (Source) - length (substr)) do
begin
inc (i);
S:=Pointer(copy(Source,i,length(Substr)));
Se:=pointer(substr);
if AnsiCompare(se,S)=0 then
begin
j := i;
e := false;
end;
DisposeAnsiString(S);
end;
pos := j;
end;
Procedure Val (Const S : AnsiString; var R : real; Var Code : Integer);
Var SS : String;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,R,Code);
end;
{
Procedure Val (var S : AnsiString; var D : Double; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,S,255);
Val(SS,D,Code);
end;
}
Procedure Val (Const S : AnsiString; var E : Extended; Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,E,Code);
end;
Procedure Val (Const S : AnsiString; var C : Cardinal; Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,C,Code);
end;
Procedure Val (Const S : AnsiString; var L : Longint; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,L,Code);
end;
Procedure Val (Const S : AnsiString; var W : Word; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,W,Code);
end;
Procedure Val (Const S : AnsiString; var I : Integer; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,I,Code);
end;
Procedure Val (Const S : AnsiString; var B : Byte; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,B,Code);
end;
Procedure Val (Const S : AnsiString; var SI : ShortInt; Var Code : Integer);
Var SS : ShortString;
begin
Ansi_To_ShortString (SS,Pointer(S),255);
Val(SS,SI,Code);
end;
{
Procedure Str (Const R : Real;Len,fr : Longint; Const S : AnsiString);
Var SS : ShortString;
begin
{int_Str_Real (R,Len,fr,SS);}
Short_To_AnsiString (Pointer(S),SS);
end;
{
Procedure Str (Var D : Double;Len,fr: Longint; Var S : AnsiString);
Var SS : ShortString;
begin
{int_Str_Double (D,Len,fr,SS);}
Short_To_AnsiString (S,SS);
end;
}
Procedure Str (E : Extended;Lenf,Fr: Longint; Var S : AnsiString);
Var SS : ShortString;
begin
{int_Str_Extended (E,Len,fr,SS);}
Short_To_AnsiString (S,SS);
end;
Procedure Str (C : Cardinal;Len : Longint; Var S : AnsiString);
begin
end;
Procedure Str (L : Longint; Len : Longint; Var S : AnsiString);
Var SS : ShortString;
begin
{int_Str_Longint (L,Len,fr,SS);}
Short_To_AnsiString (S,SS);
end;
Procedure Str (Var W : Word;Len : Longint; Var S : AnsiString);
begin
end;
Procedure Str (Var I : Integer;Len : Longint; Var S : AnsiString);
begin
end;
Procedure Str (Var B : Byte; Len : Longint; Var S : AnsiString);
begin
end;
Procedure Str (Var SI : ShortInt; Len : Longint; Var S : AnsiString);
begin
end;
}
Procedure Delete (Var S : AnsiString; Index,Size: Longint);
begin
if index<=0 then
begin
Size:=Size+index-1;
index:=1;
end;
if (Index<=length(s)) and (Size>0) then
begin
UniqueAnsiString (S);
if Size+Index>Length(S) then
Size:=Length(s)-Index+1;
Setlength(s,Length(s)-Size);
if Index<=Length(s) then
Move(Pointer(Pointer(S)+Index+Size-1)^,
Pointer(Pointer(s)+Index-1)^,Length(s)-Index+2)
else
Pbyte(Pointer(S)+Length(S))^:=0;
end;
end;
Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint);
var s3,s4,s5 : Pointer;
begin
If Length(Source)=0 then exit;
if index <= 0 then index := 1;
s3 := Pointer(copy(s,index,length(s)));
if index > Length(s) then
index := Length(S)+1;
SetLength(s,index - 1);
s4 := Pointer ( NewAnsiString(PansiRec(Pointer(Source)-Firstoff)^.len) );
S5:=Pointer(Source);
Ansi_String_Concat(s4,s5);
if S4<>Nil then
Ansi_String_Concat(S4,s3);
Ansi_String_Concat(Pointer(S),S4);
Decr_ansi_ref (S3);
Decr_ansi_ref (S4);
end;
{
$Log$
Revision 1.25 1998-10-30 21:42:48 michael
Fixed assignment of NIL string.
Revision 1.24 1998/10/22 11:32:23 michael
+ AssignAnsistring no longer copies constant ansistrings;
+ CompareAnsiString is now faster (1 call to length less)
+ UniqueAnsiString is fixed.
Revision 1.23 1998/10/21 23:01:54 michael
+ Some more corrections
Revision 1.22 1998/10/21 09:03:11 michael
+ more fixes so it compiles
Revision 1.21 1998/10/21 08:56:58 michael
+ Fix so it compiles
Revision 1.20 1998/10/21 08:38:46 florian
* ansistringconcat fixed
Revision 1.19 1998/10/20 12:46:11 florian
* small fixes to ansicompare
Revision 1.18 1998/09/28 14:02:34 michael
+ AnsiString changes
Revision 1.17 1998/09/27 22:44:50 florian
* small fixes
* made UniqueAnsistring public
* ...
Revision 1.16 1998/09/20 17:49:08 florian
* some ansistring fixes
Revision 1.15 1998/09/19 08:33:17 florian
* some internal procedures take now an pointer instead of a
ansistring
Revision 1.14 1998/09/14 10:48:14 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.13 1998/08/23 20:58:51 florian
+ rtti for objects and classes
+ TObject.GetClassName implemented
Revision 1.12 1998/08/22 09:32:12 michael
+ minor fixes typos, and ansi2pchar
Revision 1.11 1998/08/08 12:28:10 florian
* a lot small fixes to the extended data type work
Revision 1.10 1998/07/29 21:44:34 michael
+ Implemented reading/writing of ansistrings
Revision 1.9 1998/07/20 23:36:56 michael
changes for ansistrings
Revision 1.8 1998/07/13 21:19:09 florian
* some problems with ansi string support fixed
Revision 1.7 1998/07/06 14:29:08 michael
+ Added Public,Alias directives for some calls
Revision 1.6 1998/06/25 08:41:44 florian
* better rtti
Revision 1.5 1998/06/12 07:39:13 michael
+ Added aliases for Incr/Decr ref.
Revision 1.4 1998/06/08 19:35:02 michael
Some changes to integrate in system unit
Revision 1.3 1998/06/08 12:38:22 michael
Implemented rtti, inserted ansistrings again
Revision 1.2 1998/05/12 10:42:44 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