summaryrefslogtreecommitdiff
path: root/rtl/inc
diff options
context:
space:
mode:
Diffstat (limited to 'rtl/inc')
-rw-r--r--rtl/inc/aliases.inc2
-rw-r--r--rtl/inc/astrings.inc17
-rw-r--r--rtl/inc/compproc.inc15
-rw-r--r--rtl/inc/dynarr.inc7
-rw-r--r--rtl/inc/exeinfo.pp143
-rw-r--r--rtl/inc/rtti.inc207
-rw-r--r--rtl/inc/sstrings.inc4
-rw-r--r--rtl/inc/system.fpd6
-rw-r--r--rtl/inc/system.inc16
-rw-r--r--rtl/inc/systemh.inc1
-rw-r--r--rtl/inc/threadvr.inc33
-rw-r--r--rtl/inc/ucomplex.pp6
-rw-r--r--rtl/inc/ustrings.inc10
-rw-r--r--rtl/inc/variants.pp46
-rw-r--r--rtl/inc/wstrings.inc10
15 files changed, 261 insertions, 262 deletions
diff --git a/rtl/inc/aliases.inc b/rtl/inc/aliases.inc
index e9431cc5b8..7a7e90794c 100644
--- a/rtl/inc/aliases.inc
+++ b/rtl/inc/aliases.inc
@@ -28,5 +28,5 @@ Procedure int_Finalize (Data,TypeInfo: Pointer); [external name 'FPC_FINALIZE'];
Procedure int_Addref (Data,TypeInfo : Pointer); [external name 'FPC_ADDREF'];
Procedure int_DecRef (Data, TypeInfo : Pointer); [external name 'FPC_DECREF'];
Procedure int_Initialize (Data,TypeInfo: Pointer); [external name 'FPC_INITIALIZE'];
-procedure int_FinalizeArray(data,typeinfo : pointer;count,size : longint); [external name 'FPC_FINALIZEARRAY'];
+procedure int_FinalizeArray(data,typeinfo : pointer;count : longint); [external name 'FPC_FINALIZE_ARRAY'];
diff --git a/rtl/inc/astrings.inc b/rtl/inc/astrings.inc
index 1d6d4253c1..bf509c1dab 100644
--- a/rtl/inc/astrings.inc
+++ b/rtl/inc/astrings.inc
@@ -539,16 +539,10 @@ begin
end;
-Procedure fpc_AnsiStr_CheckZero(p : pointer);[Public,Alias : 'FPC_ANSISTR_CHECKZERO']; compilerproc;
-begin
- if p=nil then
- HandleErrorFrame(201,get_frame);
-end;
-
-Procedure fpc_AnsiStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_ANSISTR_RANGECHECK']; compilerproc;
+Procedure fpc_AnsiStr_CheckRange(p: Pointer; index: SizeInt);[Public,Alias : 'FPC_ANSISTR_RANGECHECK']; compilerproc;
begin
- if (index>len) or (Index<1) then
+ if (p=nil) or (index>PAnsiRec(p-FirstOff)^.Len) or (Index<1) then
HandleErrorFrame(201,get_frame);
end;
@@ -1060,6 +1054,13 @@ begin
Move (Buf^,Pointer(S)^,Len);
end;
+Procedure SetString (Out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+begin
+ if (Buf<>nil) and (Len>0) then
+ widestringmanager.Wide2AnsiMoveProc(Buf,S,Len)
+ else
+ SetLength(S, Len);
+end;
function upcase(const s : ansistring) : ansistring;
var
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index 6b81ffa6d3..0f6126f25a 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -278,8 +278,7 @@ procedure fpc_ansistr_to_chararray(out res: array of char; const src: ansistring
{$endif ndef FPC_STRTOCHARARRAYPROC}
Function fpc_AnsiStr_Compare(const S1,S2 : AnsiString): SizeInt; compilerproc;
Function fpc_AnsiStr_Compare_equal(const S1,S2 : AnsiString): SizeInt; compilerproc;
-Procedure fpc_AnsiStr_CheckZero(p : pointer); compilerproc;
-Procedure fpc_AnsiStr_CheckRange(len,index : SizeInt); compilerproc;
+Procedure fpc_AnsiStr_CheckRange(p : Pointer; index : SizeInt); compilerproc;
Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : SizeInt); compilerproc;
Function fpc_ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiString;compilerproc;
{$ifdef EXTRAANSISHORT}
@@ -327,8 +326,7 @@ procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: Wi
{$endif ndef FPC_STRTOCHARARRAYPROC}
Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt; compilerproc;
Function fpc_WideStr_Compare_equal(const S1,S2 : WideString): SizeInt; compilerproc;
-Procedure fpc_WideStr_CheckZero(p : pointer); compilerproc;
-Procedure fpc_WideStr_CheckRange(len,index : SizeInt); compilerproc;
+Procedure fpc_WideStr_CheckRange(p: Pointer; index : SizeInt); compilerproc;
Procedure fpc_WideStr_SetLength (Var S : WideString; l : SizeInt); compilerproc;
Function fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
{$ifndef FPC_WINLIKEWIDESTRING}
@@ -413,8 +411,7 @@ procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src:
{$endif VER2_2}
Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt; compilerproc;
Function fpc_UnicodeStr_Compare_equal(const S1,S2 : UnicodeString): SizeInt; compilerproc;
-Procedure fpc_UnicodeStr_CheckZero(p : pointer); compilerproc;
-Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt); compilerproc;
+Procedure fpc_UnicodeStr_CheckRange(p: Pointer; index : SizeInt); compilerproc;
Procedure fpc_UnicodeStr_SetLength (Var S : UnicodeString; l : SizeInt); compilerproc;
Function fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc;
function fpc_unicodestr_Unique(Var S : Pointer): Pointer; compilerproc;
@@ -678,8 +675,10 @@ Procedure fpc_Initialize (Data,TypeInfo : pointer); compilerproc;
Procedure fpc_finalize (Data,TypeInfo: Pointer); compilerproc;
Procedure fpc_Addref (Data,TypeInfo : Pointer); compilerproc;
Procedure fpc_DecRef (Data,TypeInfo : Pointer); compilerproc;
-procedure fpc_initialize_array(data,typeinfo : pointer;count,size : SizeInt); compilerproc;
-procedure fpc_finalize_array(data,typeinfo : pointer;count,size : SizeInt); compilerproc;
+procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
+procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); compilerproc;
+procedure fpc_addref_array(data,typeinfo: pointer; count: SizeInt); compilerproc;
+procedure fpc_decref_array(data,typeinfo: pointer; count: sizeint); compilerproc;
Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc;
Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
{$endif FPC_HAS_FEATURE_RTTI}
diff --git a/rtl/inc/dynarr.inc b/rtl/inc/dynarr.inc
index 33fca66d96..78eb834d70 100644
--- a/rtl/inc/dynarr.inc
+++ b/rtl/inc/dynarr.inc
@@ -53,7 +53,6 @@ function fpc_dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNA
{ releases and finalizes the data of a dyn. array and sets p to nil }
procedure fpc_dynarray_clear_internal(p : pointer;ti : pointer);
var
- elesize : sizeint;
eletype : pdynarraytypeinfo;
begin
if p=nil then
@@ -64,12 +63,10 @@ procedure fpc_dynarray_clear_internal(p : pointer;ti : pointer);
ti:=aligntoptr(ti);
- elesize:=psizeint(ti)^;
eletype:=pdynarraytypeinfo(pointer(pdynarraytypeinfo(pointer(ti)+sizeof(sizeint)))^);
{ finalize all data }
- int_finalizearray(p+sizeof(tdynarray),eletype,pdynarray(p)^.high+1,
- elesize);
+ int_finalizearray(p+sizeof(tdynarray),eletype,pdynarray(p)^.high+1);
{ release the data }
freemem(p);
@@ -243,7 +240,7 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
begin
int_finalizearray(pointer(realp)+sizeof(tdynarray)+
elesize*dims[dimcount-1],
- eletype,realp^.high-dims[dimcount-1]+1,elesize);
+ eletype,realp^.high-dims[dimcount-1]+1);
reallocmem(realp,size);
end
else if dims[dimcount-1]>realp^.high+1 then
diff --git a/rtl/inc/exeinfo.pp b/rtl/inc/exeinfo.pp
index 40b4105bfb..87b66de5ca 100644
--- a/rtl/inc/exeinfo.pp
+++ b/rtl/inc/exeinfo.pp
@@ -170,38 +170,54 @@ type
{$ifdef netware}
+function getByte(var f:file):byte;
+ begin
+ BlockRead (f,getByte,1);
+ end;
+
+ procedure Skip (var f:file; bytes : longint);
+ var i : longint;
+ begin
+ for i := 1 to bytes do getbyte(f);
+ end;
+
+ function get0String (var f:file) : string;
+ var c : char;
+ begin
+ get0String := '';
+ c := char (getbyte(f));
+ while (c <> #0) do
+ begin
+ get0String := get0String + c;
+ c := char (getbyte(f));
+ end;
+ end;
+
+ function getint32 (var f:file): longint;
+ begin
+ blockread (F, getint32, 4);
+ end;
+
+
const SIZE_OF_NLM_INTERNAL_FIXED_HEADER = 130;
SIZE_OF_NLM_INTERNAL_VERSION_HEADER = 32;
SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER = 124;
-function loadNetwareNLM:boolean;
+function openNetwareNLM(var e:TExeFile):boolean;
var valid : boolean;
name : string;
- StabLength,
- StabStrLength,
- alignAmount,
hdrLength,
dataOffset,
dataLength : longint;
-
- function getByte:byte;
- begin
- BlockRead (f,getByte,1);
- end;
-
- procedure Skip (bytes : longint);
- var i : longint;
- begin
- for i := 1 to bytes do getbyte;
- end;
+
function getLString : String;
var Res:string;
begin
- blockread (F, res, 1);
+ blockread (e.F, res, 1);
if length (res) > 0 THEN
- blockread (F, res[1], length (res));
- getbyte;
+ blockread (e.F, res[1], length (res));
+ getbyte(e.f);
getLString := res;
end;
@@ -210,42 +226,27 @@ var valid : boolean;
begin
getFixString := '';
for I := 1 to Len do
- getFixString := getFixString + char (getbyte);
+ getFixString := getFixString + char (getbyte(e.f));
end;
- function get0String : string;
- var c : char;
- begin
- get0String := '';
- c := char (getbyte);
- while (c <> #0) do
- begin
- get0String := get0String + c;
- c := char (getbyte);
- end;
- end;
function getword : word;
begin
- blockread (F, getword, 2);
+ blockread (e.F, getword, 2);
end;
- function getint32 : longint;
- begin
- blockread (F, getint32, 4);
- end;
+
begin
- processaddress := 0;
- LoadNetwareNLM:=false;
- stabofs:=-1;
- stabstrofs:=-1;
- { read and check header }
- Skip (SIZE_OF_NLM_INTERNAL_FIXED_HEADER);
+ e.sechdrofs := 0;
+ openNetwareNLM:=false;
+
+ // read and check header
+ Skip (e.f,SIZE_OF_NLM_INTERNAL_FIXED_HEADER);
getLString; // NLM Description
- getInt32; // Stacksize
- getInt32; // Reserved
- skip(5); // old Thread Name
+ getInt32(e.f); // Stacksize
+ getInt32(e.f); // Reserved
+ skip(e.f,5); // old Thread Name
getLString; // Screen Name
getLString; // Thread Name
hdrLength := -1;
@@ -256,7 +257,7 @@ begin
name := getFixString (8);
if (name = 'VeRsIoN#') then
begin
- Skip (SIZE_OF_NLM_INTERNAL_VERSION_HEADER-8);
+ Skip (e.f,SIZE_OF_NLM_INTERNAL_VERSION_HEADER-8);
end else
if (name = 'CoPyRiGh') then
begin
@@ -265,50 +266,50 @@ begin
end else
if (name = 'MeSsAgEs') then
begin
- skip (SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER - 8);
+ skip (e.f,SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER - 8);
end else
if (name = 'CuStHeAd') then
begin
- hdrLength := getInt32;
- dataOffset := getInt32;
- dataLength := getInt32;
- Skip (8); // dataStamp
+ hdrLength := getInt32(e.f);
+ dataOffset := getInt32(e.f);
+ dataLength := getInt32(e.f);
+ Skip (e.f,8); // dateStamp
Valid := false;
end else
Valid := false;
until not valid;
if (hdrLength = -1) or (dataOffset = -1) or (dataLength = -1) then
exit;
- (* The format of the section information is:
+
+ Seek (e.F, dataOffset);
+ e.sechdrofs := dataOffset;
+ openNetwareNLM := (e.sechdrofs > 0);
+end;
+
+function FindSectionNetwareNLM(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
+var name : string;
+ alignAmount : longint;
+begin
+ seek(e.f,e.sechdrofs);
+ (* The format of the section information is:
null terminated section name
zeroes to adjust to 4 byte boundary
4 byte section data file pointer
4 byte section size *)
- Seek (F, dataOffset);
- stabOfs := 0;
- stabStrOfs := 0;
Repeat
- Name := Get0String;
+ Name := Get0String(e.f);
alignAmount := 4 - ((length (Name) + 1) MOD 4);
- Skip (alignAmount);
- if (Name = '.stab') then
+ Skip (e.f,AlignAmount);
+ if (Name = asecname) then
begin
- stabOfs := getInt32;
- stabLength := getInt32;
- stabcnt:=stabLength div sizeof(tstab);
+ secOfs := getInt32(e.f);
+ secLen := getInt32(e.f);
end else
- if (Name = '.stabstr') then
- begin
- stabStrOfs := getInt32;
- stabStrLength := getInt32;
- end else
- Skip (8);
- until (Name = '') or ((StabOfs <> 0) and (stabStrOfs <> 0));
- Seek (F,stabOfs);
- //if (StabOfs = 0) then __ConsolePrintf ('StabOfs = 0');
- //if (StabStrOfs = 0) then __ConsolePrintf ('StabStrOfs = 0');
- LoadNetwareNLM := ((stabOfs > 0) and (stabStrOfs > 0));
+ Skip(e.f,8);
+ until (Name = '') or (Name = asecname);
+ FindSectionNetwareNLM := (Name=asecname);
end;
+
{$endif}
diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
index 904b1a965c..2ec8e37c1d 100644
--- a/rtl/inc/rtti.inc
+++ b/rtl/inc/rtti.inc
@@ -19,85 +19,85 @@
type
TRTTIProc=procedure(Data,TypeInfo:Pointer);
+ PRecordElement=^TRecordElement;
+ TRecordElement=packed record
+ TypeInfo: Pointer;
+ Offset: Longint;
+ end;
+
+ PRecordInfo=^TRecordInfo;
+ TRecordInfo=packed record
+ Size: Longint;
+ Count: Longint;
+ { Elements: array[count] of TRecordElement }
+ end;
+
+ PArrayInfo=^TArrayInfo;
+ TArrayInfo=packed record
+ ElSize: SizeInt;
+ ElCount: SizeInt;
+ ElInfo: Pointer;
+ end;
+
+
+function RTTIArraySize(typeInfo: Pointer): SizeInt;
+begin
+ typeInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+ result:=PArrayInfo(typeInfo)^.ElSize * PArrayInfo(typeInfo)^.ElCount;
+end;
+
+function RTTIRecordSize(typeInfo: Pointer): SizeInt;
+begin
+ typeInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+ result:=PRecordInfo(typeInfo)^.Size;
+end;
+
+function RTTISize(typeInfo: Pointer): SizeInt;
+begin
+ case PByte(typeinfo)^ of
+ tkAString,tkWString,tkUString,
+ tkInterface,tkDynarray:
+ result:=sizeof(Pointer);
+{$ifdef FPC_HAS_FEATURE_VARIANTS}
+ tkVariant:
+ result:=sizeof(TVarData);
+{$endif FPC_HAS_FEATURE_VARIANTS}
+ tkArray:
+ result:=RTTIArraySize(typeinfo);
+ tkObject,tkRecord:
+ result:=RTTIRecordSize(typeinfo);
+ else
+ result:=-1;
+ end;
+end;
+
{ if you modify this procedure, fpc_copy must be probably modified as well }
procedure RecordRTTI(Data,TypeInfo:Pointer;rttiproc:TRTTIProc);
-{
- A record is designed as follows :
- 1 : tkrecord
- 2 : Length of name string (n);
- 3 : name string;
- 3+n : record size;
- 7+n : number of elements (N)
- 11+n : N times : Pointer to type info
- Offset in record
-}
var
- Temp : pbyte;
- namelen : byte;
count,
- offset,
i : longint;
- info : pointer;
begin
- Temp:=PByte(TypeInfo);
- inc(Temp);
- { Skip Name }
- namelen:=Temp^;
- inc(temp,namelen+1);
- temp:=aligntoptr(temp);
- { Skip size }
- inc(Temp,4);
- { Element count }
- Count:=PLongint(Temp)^;
- inc(Temp,sizeof(Count));
+ typeInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+ Count:=PRecordInfo(typeInfo)^.Count;
+ Inc(PRecordInfo(typeInfo));
{ Process elements }
for i:=1 to count Do
begin
- Info:=PPointer(Temp)^;
- inc(Temp,sizeof(Info));
- Offset:=PLongint(Temp)^;
- inc(Temp,sizeof(Offset));
- rttiproc (Data+Offset,Info);
+ rttiproc (Data+PRecordElement(typeInfo)^.Offset,PRecordElement(typeInfo)^.TypeInfo);
+ Inc(PRecordElement(typeInfo));
end;
end;
{ if you modify this procedure, fpc_copy must be probably modified as well }
procedure ArrayRTTI(Data,TypeInfo:Pointer;rttiproc:TRTTIProc);
-{
- An array is designed as follows :
- 1 : tkArray;
- 2 : length of name string (n);
- 3 : NAme string
- 3+n : Element Size
- 7+n : Number of elements
- 11+n : Pointer to type of elements
-}
var
- Temp : pbyte;
- namelen : byte;
- count,
- size,
i : SizeInt;
- info : pointer;
begin
- Temp:=PByte(TypeInfo);
- inc(Temp);
- { Skip Name }
- namelen:=Temp^;
- inc(temp,namelen+1);
- temp:=aligntoptr(temp);
- { Element size }
- size:=PSizeInt(Temp)^;
- inc(Temp,sizeof(Size));
- { Element count }
- Count:=PSizeInt(Temp)^;
- inc(Temp,sizeof(Count));
- Info:=PPointer(Temp)^;
- inc(Temp,sizeof(Info));
+ typeInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
{ Process elements }
- for I:=0 to Count-1 do
- rttiproc(Data+(I*size),Info);
+ for I:=0 to PArrayInfo(typeInfo)^.ElCount-1 do
+ rttiproc(Data+(I*PArrayInfo(typeInfo)^.ElSize),PArrayInfo(typeInfo)^.ElInfo);
end;
@@ -268,13 +268,12 @@ Function fpc_Copy_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external n
Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt;[Public,alias : 'FPC_COPY']; compilerproc;
var
+ ArrayInfo: PArrayInfo;
Temp : pbyte;
- namelen : byte;
copiedsize,
expectedoffset,
count,
offset,
- size,
i : SizeInt;
info : pointer;
begin
@@ -300,57 +299,31 @@ begin
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkArray:
begin
- Temp:=PByte(TypeInfo);
- inc(Temp);
- { Skip Name }
- namelen:=Temp^;
- inc(temp,namelen+1);
- temp:=aligntoptr(temp);
-
- { Element size }
- size:=PSizeInt(Temp)^;
- inc(Temp,sizeof(Size));
-
- { Element count }
- Count:=PSizeInt(Temp)^;
- inc(Temp,sizeof(Count));
- Info:=PPointer(Temp)^;
- inc(Temp,sizeof(Info));
+ ArrayInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
{ Process elements }
- for I:=0 to Count-1 do
- fpc_Copy_internal(Src+(I*size),Dest+(I*size),Info);
- Result:=size*count;
+ for I:=0 to ArrayInfo^.ElCount-1 do
+ fpc_Copy_internal(Src+(I*ArrayInfo^.ElSize),Dest+(I*ArrayInfo^.ElSize),ArrayInfo^.ElInfo);
+ Result:=ArrayInfo^.ElSize*ArrayInfo^.ElCount;
end;
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkobject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkrecord:
begin
- Temp:=PByte(TypeInfo);
- inc(Temp);
- { Skip Name }
- namelen:=Temp^;
- inc(temp,namelen+1);
- temp:=aligntoptr(temp);
-
- Result:=plongint(temp)^;
+ Temp:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
- { Skip size }
- inc(Temp,4);
-
- { Element count }
- Count:=PLongint(Temp)^;
- inc(Temp,sizeof(longint));
+ Result:=PRecordInfo(Temp)^.Size;
+ Count:=PRecordInfo(Temp)^.Count;
+ Inc(PRecordInfo(Temp));
expectedoffset:=0;
{ Process elements with rtti }
for i:=1 to count Do
begin
- Info:=PPointer(Temp)^;
- inc(Temp,sizeof(Info));
- Offset:=PLongint(Temp)^;
+ Info:=PRecordElement(Temp)^.TypeInfo;
+ Offset:=PRecordElement(Temp)^.Offset;
+ Inc(PRecordElement(Temp));
if Offset>expectedoffset then
move((Src+expectedoffset)^,(Dest+expectedoffset)^,Offset-expectedoffset);
- inc(Temp,sizeof(longint));
copiedsize:=fpc_Copy_internal(Src+Offset,Dest+Offset,Info);
expectedoffset:=Offset+copiedsize;
end;
@@ -392,24 +365,44 @@ begin
end;
-procedure fpc_initialize_array(data,typeinfo : pointer;count,size : SizeInt); compilerproc;
+procedure fpc_initialize_array(data,typeinfo : pointer;count : SizeInt); [public,alias:'FPC_INITIALIZE_ARRAY'] compilerproc;
var
- i : SizeInt;
+ i, size : SizeInt;
begin
- if not(PByte(typeinfo)^ in [tkInteger,tkChar,tkEnumeration,tkFloat,tkSet,
- tkMethod,tkSString,tkLString,tkWChar,tkBool,tkInt64,tkQWord]) then
+ size:=RTTISize(typeinfo);
+ if size>0 then
for i:=0 to count-1 do
int_initialize(data+size*i,typeinfo);
end;
-procedure fpc_finalize_array(data,typeinfo : pointer;count,size : SizeInt); [Public,Alias:'FPC_FINALIZEARRAY']; compilerproc;
+procedure fpc_finalize_array(data,typeinfo : pointer;count : SizeInt); [Public,Alias:'FPC_FINALIZE_ARRAY']; compilerproc;
var
- i : SizeInt;
+ i, size: SizeInt;
begin
- if not(PByte(typeinfo)^ in [tkInteger,tkChar,tkEnumeration,tkFloat,tkSet,
- tkMethod,tkSString,tkLString,tkWChar,tkBool,tkInt64,tkQWord]) then
+ size:=RTTISize(typeinfo);
+ if size>0 then
for i:=0 to count-1 do
int_finalize(data+size*i,typeinfo);
end;
+procedure fpc_addref_array(data,typeinfo: pointer; count: SizeInt); [public,alias:'FPC_ADDREF_ARRAY']; compilerproc;
+ var
+ i, size: SizeInt;
+ begin
+ size:=RTTISize(typeinfo);
+ if size>0 then
+ for i:=0 to count-1 do
+ int_addref(data+size*i,typeinfo);
+ end;
+
+procedure fpc_decref_array(data,typeinfo: pointer; count: SizeInt); [public,alias:'FPC_DECREF_ARRAY']; compilerproc;
+ var
+ i, size: SizeInt;
+ begin
+ size:=RTTISize(typeinfo);
+ if size>0 then
+ for i:=0 to count-1 do
+ int_decref(data+size*i,typeinfo);
+ end;
+
diff --git a/rtl/inc/sstrings.inc b/rtl/inc/sstrings.inc
index c8ada78043..ae9cc4cd7e 100644
--- a/rtl/inc/sstrings.inc
+++ b/rtl/inc/sstrings.inc
@@ -455,8 +455,6 @@ type
end;
var
- p:Pstring;
-
enum_o2s : Penum_ord_to_string;
header:Penum_typeinfo;
body:Penum_typedata;
@@ -1340,8 +1338,6 @@ var l,h,m:cardinal;
spaces:byte;
t:shortstring;
-label error;
-
begin
{Val for numbers accepts spaces at the start, so lets do the same
for enums. Skip spaces at the start of the string.}
diff --git a/rtl/inc/system.fpd b/rtl/inc/system.fpd
index 5f2eea9736..f373414f42 100644
--- a/rtl/inc/system.fpd
+++ b/rtl/inc/system.fpd
@@ -62,3 +62,9 @@ Procedure ReadStr(Const S : String; Args : Arguments);
Procedure Pack(Const A : UnpackedArrayType; StartIndex : TIndexType; Out Z : PackedArrayType);
Procedure UnPack(Const Z : PackedArrayType; Out A : UnpackedArrayType; StartIndex : TIndexType);
+{$IFNDEF GO32V2}
+Var
+ mem : array[0..$7fffffff-1] of byte;
+ memw : array[0..($7fffffff div sizeof(word))-1] of word;
+ meml : array[0..($7fffffff div sizeof(longint))-1] of longint;
+{$ENDIF}
diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc
index 72163f415a..b911c5115d 100644
--- a/rtl/inc/system.inc
+++ b/rtl/inc/system.inc
@@ -786,9 +786,11 @@ var
begin
{ call cpu/fpu initialisation routine }
fpc_cpuinit;
- with {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PInitFinalTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- InitFinalTable
- {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} do
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with PInitFinalTable(EntryInformation.InitFinalTable)^ do
+{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with InitFinalTable do
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
begin
for i:=1 to TableCount do
begin
@@ -815,9 +817,11 @@ end;
procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS'];
begin
- with {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PInitFinalTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- InitFinalTable
- {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} do
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with PInitFinalTable(EntryInformation.InitFinalTable)^ do
+{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with InitFinalTable do
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
begin
while (InitCount>0) do
begin
diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc
index 1b3cfe6bb1..b1fe1e4a5a 100644
--- a/rtl/inc/systemh.inc
+++ b/rtl/inc/systemh.inc
@@ -820,6 +820,7 @@ Function Pos(C:Char;const s:shortstring):SizeInt;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function Pos (const Substr : ShortString; const Source : AnsiString) : SizeInt;
Procedure SetString (out S : AnsiString; Buf : PChar; Len : SizeInt);
+Procedure SetString (out S : AnsiString; Buf : PWideChar; Len : SizeInt);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure SetString (out S : Shortstring; Buf : PChar; Len : SizeInt);
function ShortCompareText(const S1, S2: shortstring): SizeInt;
diff --git a/rtl/inc/threadvr.inc b/rtl/inc/threadvr.inc
index 538b99eac2..02af72e96d 100644
--- a/rtl/inc/threadvr.inc
+++ b/rtl/inc/threadvr.inc
@@ -52,15 +52,18 @@ procedure init_all_unit_threadvars;
var
i : integer;
begin
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
+{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with ThreadvarTablesTable do
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ begin
{$ifdef DEBUG_MT}
- WriteLn ('init_all_unit_threadvars (',
- {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.count,') units');
+ WriteLn ('init_all_unit_threadvars (',count,') units');
{$endif}
- for i := 1 to {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.count do
- init_unit_threadvars ({$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.tables[i]);
+ for i := 1 to count do
+ init_unit_threadvars (tables[i]);
+ end;
end;
@@ -83,14 +86,18 @@ procedure copy_all_unit_threadvars;
var
i : integer;
begin
+{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
+{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ with ThreadvarTablesTable do
+{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
+ begin
{$ifdef DEBUG_MT}
- WriteLn ('copy_all_unit_threadvars (',{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.count,') units');
+ WriteLn ('copy_all_unit_threadvars (',count,') units');
{$endif}
- for i := 1 to {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.count do
- copy_unit_threadvars ({$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}PltvInitTablesTable(EntryInformation.{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
- ThreadvarTablesTable{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION})^{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}.tables[i]);
+ for i := 1 to count do
+ copy_unit_threadvars (tables[i]);
+ end;
end;
procedure InitThreadVars(RelocProc : Pointer);
diff --git a/rtl/inc/ucomplex.pp b/rtl/inc/ucomplex.pp
index c9b304c0d0..0a4613cd75 100644
--- a/rtl/inc/ucomplex.pp
+++ b/rtl/inc/ucomplex.pp
@@ -344,7 +344,7 @@ Unit UComplex;
z.re := (znum.im + znum.re * tmp) / denom;
z.im := (-znum.re + znum.im * tmp) / denom;
end;
- end;
+ end;
operator / (znum : complex; r : real) z : complex;
{ division : z := znum / r }
@@ -572,7 +572,7 @@ Unit UComplex;
{ _________ }
{ argch(z) = -/+ ln(z + i.V 1 - z.z) }
begin
- carg_ch:=-cln(z+i*csqrt(z*z-1.0));
+ carg_ch:=-cln(z+i*csqrt(1.0-z*z));
end;
function carg_sh (z : complex) : complex;
@@ -587,7 +587,7 @@ Unit UComplex;
{ hyperbolic arc tangent }
{ argth(z) = 1/2 ln((z + 1) / (1 - z)) }
begin
- carg_th:=cln((z+1.0)/(z-1.0))/2.0;
+ carg_th:=cln((z+1.0)/(1.0-z))/2.0;
end;
{ functions to write out a complex value }
diff --git a/rtl/inc/ustrings.inc b/rtl/inc/ustrings.inc
index f805d376f1..ed7e3583a9 100644
--- a/rtl/inc/ustrings.inc
+++ b/rtl/inc/ustrings.inc
@@ -1304,16 +1304,10 @@ begin
exit(CompareWord(S1[1],S2[1],MaxI));
end;
-Procedure fpc_UnicodeStr_CheckZero(p : pointer);[Public,Alias : 'FPC_UNICODESTR_CHECKZERO']; compilerproc;
-begin
- if p=nil then
- HandleErrorFrame(201,get_frame);
-end;
-
-Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_UNICODESTR_RANGECHECK']; compilerproc;
+Procedure fpc_UnicodeStr_CheckRange(p: Pointer; index: SizeInt);[Public,Alias : 'FPC_UNICODESTR_RANGECHECK']; compilerproc;
begin
- if (index>len div 2) or (Index<1) then
+ if (p=nil) or (index>PUnicodeRec(p-UnicodeFirstOff)^.len div 2) or (Index<1) then
HandleErrorFrame(201,get_frame);
end;
diff --git a/rtl/inc/variants.pp b/rtl/inc/variants.pp
index fdd34ece40..75d89a042b 100644
--- a/rtl/inc/variants.pp
+++ b/rtl/inc/variants.pp
@@ -670,6 +670,7 @@ begin
VarCastError(varNull, varDouble)
else
Result := 0
+ { TODO: performance: custom variants must be handled after standard ones }
else if FindCustomVariantType(TVarData(v).vType, Handler) then
begin
VariantInit(dest);
@@ -693,6 +694,21 @@ begin
Result := VariantToCurrency(TVarData(V));
end;
+function CustomVarToLStr(const v: TVarData; out s: AnsiString): Boolean;
+var
+ handler: TCustomVariantType;
+ temp: TVarData;
+begin
+ result := FindCustomVariantType(v.vType, handler);
+ if result then
+ begin
+ VariantInit(temp);
+ handler.CastTo(temp, v, varString);
+ { out-semantic ensures that s is finalized,
+ so just copy the pointer and don't finalize the temp }
+ Pointer(s) := temp.vString;
+ end;
+end;
procedure sysvartolstr (var s : AnsiString; const v : Variant);
begin
@@ -701,7 +717,8 @@ begin
VarCastError(varNull, varString)
else
s := NullAsStringValue
- else
+ { TODO: performance: custom variants must be handled after standard ones }
+ else if not CustomVarToLStr(TVarData(v), s) then
S := VariantToAnsiString(TVarData(V));
end;
@@ -2643,7 +2660,6 @@ var
valuevtype,
arrayelementtype : TVarType;
tempvar : Variant;
- variantmanager : tvariantmanager;
begin
Dest:=TVarData(a);
{ get final Variant }
@@ -2686,8 +2702,7 @@ begin
end
else
begin
- GetVariantManager(variantmanager);
- variantmanager.varcast(tempvar,value,arrayelementtype);
+ VarCast(tempvar,value,arrayelementtype);
if arrayelementtype in [varOleStr,varDispatch,varUnknown] then
VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),TVarData(tempvar).vPointer))
else
@@ -3328,17 +3343,13 @@ function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
var
customvarianttype : TCustomVariantType;
begin
- if FindCustomVariantType(aVarType,customvarianttype) then
- Result:=true
- else
- begin
- Result:=(aVarType and not(varByRef) and not(varArray)) in [varEmpty,varNull,varSmallInt,varInteger,
+ Result:=((aVarType and not(varByRef) and not(varArray)) in [varEmpty,varNull,varSmallInt,varInteger,
{$ifndef FPUNONE}
- varSingle,varDouble,varDate,
+ varSingle,varDouble,varDate,
{$endif}
- varCurrency,varOleStr,varDispatch,varError,varBoolean,
- varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64];
- end;
+ varCurrency,varOleStr,varDispatch,varError,varBoolean,
+ varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64]) or
+ FindCustomVariantType(aVarType,customvarianttype);
end;
@@ -3383,7 +3394,6 @@ procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: P
dynarriter : tdynarrayiter;
p : Pointer;
temp : Variant;
- variantmanager : tvariantmanager;
dynarraybounds : tdynarraybounds;
type
TDynArray = array of Pointer;
@@ -3398,8 +3408,6 @@ procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: P
if (Dims>1) and not(DynamicArrayIsRectangular(DynArray,TypeInfo)) then
exit;
- GetVariantManager(variantmanager);
-
{ retrieve Bounds array }
Setlength(dynarraybounds,Dims);
GetMem(vararraybounds,Dims*SizeOf(TVarArrayBound));
@@ -3466,7 +3474,7 @@ procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: P
VarClear(temp);
end;
dynarriter.next;
- variantmanager.VarArrayPut(V,temp,Dims,PLongint(iter.Coords));
+ VarArrayPut(V,temp,Slice(iter.Coords^,Dims));
until not(iter.next);
finally
iter.done;
@@ -3487,7 +3495,6 @@ procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo:
dynarriter : tdynarrayiter;
temp : Variant;
dynarrvartype : LongInt;
- variantmanager : tvariantmanager;
vararraybounds : PVarArrayBoundArray;
dynarraybounds : tdynarraybounds;
i : SizeInt;
@@ -3513,14 +3520,13 @@ procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo:
dynarraybounds[i]:=vararraybounds^[i].ElementCount;
end;
DynArraySetLength(DynArray,TypeInfo,VarArrayDims,PSizeInt(dynarraybounds));
- GetVariantManager(variantmanager);
VarArrayLock(V);
try
iter.init(VarArrayDims,PVarArrayBoundArray(vararraybounds));
dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds);
if not iter.AtEnd then
repeat
- temp:=variantmanager.VarArrayGet(V,VarArrayDims,PLongint(iter.Coords));
+ temp:=VarArrayGet(V,Slice(iter.Coords^,VarArrayDims));
case dynarrvartype of
varSmallInt:
PSmallInt(dynarriter.data)^:=temp;
diff --git a/rtl/inc/wstrings.inc b/rtl/inc/wstrings.inc
index fe573bf12c..f0fa4572a4 100644
--- a/rtl/inc/wstrings.inc
+++ b/rtl/inc/wstrings.inc
@@ -729,16 +729,10 @@ begin
exit(CompareWord(S1[1],S2[1],MaxI));
end;
-Procedure fpc_WideStr_CheckZero(p : pointer);[Public,Alias : 'FPC_WIDESTR_CHECKZERO']; compilerproc;
-begin
- if p=nil then
- HandleErrorFrame(201,get_frame);
-end;
-
-Procedure fpc_WideStr_CheckRange(len,index : SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
+Procedure fpc_WideStr_CheckRange(p: Pointer; index: SizeInt);[Public,Alias : 'FPC_WIDESTR_RANGECHECK']; compilerproc;
begin
- if (index>len div 2) or (Index<1) then
+ if (p=nil) or (index>PWideRec(p-WideFirstOff)^.len div 2) or (Index<1) then
HandleErrorFrame(201,get_frame);
end;
View Lorry Controller Status