paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-23 13:09:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* More pluggability of the RTL. Mantis 15124

Browse Source 
git-svn-id: trunk@14212 -
This commit is contained in:
marco 2009-11-18 21:16:12 +00:00
parent 17062d667c
commit 4104d9f481
5 changed files with 97 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
rtl/inc/compproc.inc
View File

@ -589,7 +589,9 @@ procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TG
function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface; compilerproc; function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface; compilerproc;
function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface; compilerproc; function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface; compilerproc;
function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer; compilerproc; function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer; compilerproc;
{$ifdef FPC_HAS_FEATURE_VARIANTS}
procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc: Pointer; Params: Pointer); compilerproc; procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc: Pointer; Params: Pointer); compilerproc;
{$endif FPC_HAS_FEATURE_VARIANTS}
{$endif FPC_HAS_FEATURE_CLASSES} {$endif FPC_HAS_FEATURE_CLASSES}

2
rtl/inc/objpas.inc
View File

@ -13,6 +13,7 @@
**********************************************************************} **********************************************************************}
{$ifdef FPC_HAS_FEATURE_VARIANTS}
procedure DoDispCallByIDError(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer); procedure DoDispCallByIDError(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
begin begin
handleerrorframe(RuntimeErrorExitCodes[reVarDispatch],get_frame); handleerrorframe(RuntimeErrorExitCodes[reVarDispatch],get_frame);
@ -26,6 +27,7 @@
begin begin
TDispProc(DispCallByIDProc)(Result,IDispatch(Dispatch),DispDesc,Params); TDispProc(DispCallByIDProc)(Result,IDispatch(Dispatch),DispDesc,Params);
end; end;
{$endif FPC_HAS_FEATURE_VARIANTS}
{**************************************************************************** {****************************************************************************
Internal Routines called from the Compiler Internal Routines called from the Compiler

87
rtl/inc/rtti.inc
View File

@ -133,15 +133,28 @@ end;
Procedure fpc_Initialize (Data,TypeInfo : pointer);[Public,Alias : 'FPC_INITIALIZE']; compilerproc; Procedure fpc_Initialize (Data,TypeInfo : pointer);[Public,Alias : 'FPC_INITIALIZE']; compilerproc;
begin begin
case PByte(TypeInfo)^ of case PByte(TypeInfo)^ of
tkAstring,tkWstring,tkUString,tkInterface,tkDynArray: {$ifdef FPC_HAS_FEATURE_DYNARRAYS}
tkDynArray,
{$endif FPC_HAS_FEATURE_DYNARRAYS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
tkAstring,
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
tkWstring,tkUString,
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkInterface:
PPchar(Data)^:=Nil; PPchar(Data)^:=Nil;
tkArray: tkArray:
arrayrtti(data,typeinfo,@int_initialize); arrayrtti(data,typeinfo,@int_initialize);
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkObject, tkObject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkRecord: tkRecord:
recordrtti(data,typeinfo,@int_initialize); recordrtti(data,typeinfo,@int_initialize);
{$ifdef FPC_HAS_FEATURE_VARIANTS}
tkVariant: tkVariant:
variant_init(PVarData(Data)^); variant_init(PVarData(Data)^);
{$endif FPC_HAS_FEATURE_VARIANTS}
end; end;
end; end;
@ -149,28 +162,34 @@ end;
Procedure fpc_finalize (Data,TypeInfo: Pointer);[Public,Alias : 'FPC_FINALIZE']; compilerproc; Procedure fpc_finalize (Data,TypeInfo: Pointer);[Public,Alias : 'FPC_FINALIZE']; compilerproc;
begin begin
case PByte(TypeInfo)^ of case PByte(TypeInfo)^ of
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
tkAstring : tkAstring :
begin begin
fpc_AnsiStr_Decr_Ref(PPointer(Data)^); fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil; PPointer(Data)^:=nil;
end; end;
{$ifndef VER2_2} {$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef VER2_2}
tkUstring : tkUstring :
begin begin
fpc_UnicodeStr_Decr_Ref(PPointer(Data)^); fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil; PPointer(Data)^:=nil;
end; end;
{$endif VER2_2} {$endif VER2_2}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
tkWstring : tkWstring :
begin begin
fpc_WideStr_Decr_Ref(PPointer(Data)^); fpc_WideStr_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil; PPointer(Data)^:=nil;
end; end;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkArray : tkArray :
arrayrtti(data,typeinfo,@int_finalize); arrayrtti(data,typeinfo,@int_finalize);
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkObject, tkObject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkRecord: tkRecord:
recordrtti(data,typeinfo,@int_finalize); recordrtti(data,typeinfo,@int_finalize);
tkInterface: tkInterface:
@ -178,13 +197,17 @@ begin
Intf_Decr_Ref(PPointer(Data)^); Intf_Decr_Ref(PPointer(Data)^);
PPointer(Data)^:=nil; PPointer(Data)^:=nil;
end; end;
{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
tkDynArray: tkDynArray:
begin begin
fpc_dynarray_decr_ref(PPointer(Data)^,TypeInfo); fpc_dynarray_decr_ref(PPointer(Data)^,TypeInfo);
PPointer(Data)^:=nil; PPointer(Data)^:=nil;
end; end;
{$endif FPC_HAS_FEATURE_DYNARRAYS}
{$ifdef FPC_HAS_FEATURE_VARIANTS}
tkVariant: tkVariant:
variant_clear(PVarData(Data)^); variant_clear(PVarData(Data)^);
{$endif FPC_HAS_FEATURE_VARIANTS}
end; end;
end; end;
@ -192,27 +215,37 @@ end;
Procedure fpc_Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF']; compilerproc; Procedure fpc_Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF']; compilerproc;
begin begin
case PByte(TypeInfo)^ of case PByte(TypeInfo)^ of
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
tkAstring : tkAstring :
fpc_AnsiStr_Incr_Ref(PPointer(Data)^); fpc_AnsiStr_Incr_Ref(PPointer(Data)^);
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
tkWstring : tkWstring :
fpc_WideStr_Incr_Ref(PPointer(Data)^); fpc_WideStr_Incr_Ref(PPointer(Data)^);
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$ifndef VER2_2} {$ifndef VER2_2}
tkUstring : tkUstring :
fpc_UnicodeStr_Incr_Ref(PPointer(Data)^); fpc_UnicodeStr_Incr_Ref(PPointer(Data)^);
{$endif VER2_2} {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkArray : tkArray :
arrayrtti(data,typeinfo,@int_addref); arrayrtti(data,typeinfo,@int_addref);
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkobject, tkobject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkrecord : tkrecord :
recordrtti(data,typeinfo,@int_addref); recordrtti(data,typeinfo,@int_addref);
{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
tkDynArray: tkDynArray:
fpc_dynarray_incr_ref(PPointer(Data)^); fpc_dynarray_incr_ref(PPointer(Data)^);
{$endif FPC_HAS_FEATURE_DYNARRAYS}
tkInterface: tkInterface:
Intf_Incr_Ref(PPointer(Data)^); Intf_Incr_Ref(PPointer(Data)^);
{$ifdef FPC_HAS_FEATURE_VARIANTS}
tkVariant: tkVariant:
variant_addref(pvardata(Data)^); variant_addref(pvardata(Data)^);
{$endif FPC_HAS_FEATURE_DYNARRAYS}
end; end;
end; end;
@ -225,27 +258,37 @@ Procedure fpc_DecRef (Data, TypeInfo : Pointer);[Public,alias : 'FPC_DECREF'];
begin begin
case PByte(TypeInfo)^ of case PByte(TypeInfo)^ of
{ see AddRef for comment about below construct (JM) } { see AddRef for comment about below construct (JM) }
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
tkAstring: tkAstring:
fpc_AnsiStr_Decr_Ref(PPointer(Data)^); fpc_AnsiStr_Decr_Ref(PPointer(Data)^);
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
tkWstring: tkWstring:
fpc_WideStr_Decr_Ref(PPointer(Data)^); fpc_WideStr_Decr_Ref(PPointer(Data)^);
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$ifndef VER2_2} {$ifndef VER2_2}
tkUString: tkUString:
fpc_UnicodeStr_Decr_Ref(PPointer(Data)^); fpc_UnicodeStr_Decr_Ref(PPointer(Data)^);
{$endif VER2_2} {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkArray: tkArray:
arrayrtti(data,typeinfo,@fpc_systemDecRef); arrayrtti(data,typeinfo,@fpc_systemDecRef);
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkobject, tkobject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkrecord: tkrecord:
recordrtti(data,typeinfo,@fpc_systemDecRef); recordrtti(data,typeinfo,@fpc_systemDecRef);
{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
tkDynArray: tkDynArray:
fpc_dynarray_decr_ref(PPointer(Data)^,TypeInfo); fpc_dynarray_decr_ref(PPointer(Data)^,TypeInfo);
{$endif FPC_HAS_FEATURE_DYNARRAYS}
tkInterface: tkInterface:
Intf_Decr_Ref(PPointer(Data)^); Intf_Decr_Ref(PPointer(Data)^);
{$ifdef FPC_HAS_FEATURE_VARIANTS}
tkVariant: tkVariant:
variant_clear(pvardata(data)^); variant_clear(pvardata(data)^);
{$endif FPC_HAS_FEATURE_VARIANTS}
end; end;
end; end;
@ -266,20 +309,24 @@ var
begin begin
result:=sizeof(pointer); result:=sizeof(pointer);
case PByte(TypeInfo)^ of case PByte(TypeInfo)^ of
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
tkAstring: tkAstring:
begin begin
fpc_AnsiStr_Incr_Ref(PPointer(Src)^); fpc_AnsiStr_Incr_Ref(PPointer(Src)^);
fpc_AnsiStr_Decr_Ref(PPointer(Dest)^); fpc_AnsiStr_Decr_Ref(PPointer(Dest)^);
PPointer(Dest)^:=PPointer(Src)^; PPointer(Dest)^:=PPointer(Src)^;
end; end;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
tkWstring: tkWstring:
fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^); fpc_WideStr_Assign(PPointer(Dest)^,PPointer(Src)^);
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$ifndef VER2_2} {$ifndef VER2_2}
tkUstring: tkUstring:
fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^); fpc_UnicodeStr_Assign(PPointer(Dest)^,PPointer(Src)^);
{$endif VER2_2} {$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
tkArray: tkArray:
begin begin
Temp:=PByte(TypeInfo); Temp:=PByte(TypeInfo);
@ -303,7 +350,9 @@ begin
fpc_Copy_internal(Src+(I*size),Dest+(I*size),Info); fpc_Copy_internal(Src+(I*size),Dest+(I*size),Info);
Result:=size*count; Result:=size*count;
end; end;
{$ifdef FPC_HAS_FEATURE_OBJECTS}
tkobject, tkobject,
{$endif FPC_HAS_FEATURE_OBJECTS}
tkrecord: tkrecord:
begin begin
Temp:=PByte(TypeInfo); Temp:=PByte(TypeInfo);
@ -338,23 +387,27 @@ begin
if result>expectedoffset then if result>expectedoffset then
move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset); move((Src+expectedoffset)^,(Dest+expectedoffset)^,Result-expectedoffset);
end; end;
{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
tkDynArray: tkDynArray:
begin begin
fpc_dynarray_Incr_Ref(PPointer(Src)^); fpc_dynarray_Incr_Ref(PPointer(Src)^);
fpc_dynarray_Decr_Ref(PPointer(Dest)^,typeinfo); fpc_dynarray_Decr_Ref(PPointer(Dest)^,typeinfo);
PPointer(Dest)^:=PPointer(Src)^; PPointer(Dest)^:=PPointer(Src)^;
end; end;
{$endif FPC_HAS_FEATURE_DYNARRAYS}
tkInterface: tkInterface:
begin begin
Intf_Incr_Ref(PPointer(Src)^); Intf_Incr_Ref(PPointer(Src)^);
Intf_Decr_Ref(PPointer(Dest)^); Intf_Decr_Ref(PPointer(Dest)^);
PPointer(Dest)^:=PPointer(Src)^; PPointer(Dest)^:=PPointer(Src)^;
end; end;
{$ifdef FPC_HAS_FEATURE_VARIANTS}
tkVariant: tkVariant:
begin begin
VarCopyProc(pvardata(dest)^,pvardata(src)^); VarCopyProc(pvardata(dest)^,pvardata(src)^);
result:=sizeof(tvardata); result:=sizeof(tvardata);
end; end;
{$endif FPC_HAS_FEATURE_VARIANTS}
end; end;
end; end;

4
rtl/inc/system.inc
View File

@ -378,7 +378,7 @@ function aligntoptr(p : pointer) : pointer;inline;
{$ifdef FPC_HAS_FEATURE_RTTI} {$ifdef FPC_HAS_FEATURE_RTTI}
{$i rtti.inc} {$i rtti.inc}
{$endif FPC_HAS_FEATURE_VARIANTS} {$endif FPC_HAS_FEATURE_RTTI}
{$if defined(FPC_HAS_FEATURE_RANDOM)} {$if defined(FPC_HAS_FEATURE_RANDOM)}
@ -1322,8 +1322,10 @@ end;
Directory Handling Directory Handling
*****************************************************************************} *****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ OS dependent dir functions } { OS dependent dir functions }
{$i sysdir.inc} {$i sysdir.inc}
{$endif FPC_HAS_FEATURE_FILEIO}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)} {$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
Procedure getdir(drivenr:byte;Var dir:ansistring); Procedure getdir(drivenr:byte;Var dir:ansistring);

20
rtl/objpas/objpas.pp
View File

@ -48,31 +48,41 @@ Var
Compatibility routines. Compatibility routines.
****************************************************************************} ****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Untyped file support } { Untyped file support }
Procedure AssignFile(out f:File;const Name:string); Procedure AssignFile(out f:File;const Name:string);
Procedure AssignFile(out f:File;p:pchar); Procedure AssignFile(out f:File;p:pchar);
Procedure AssignFile(out f:File;c:char); Procedure AssignFile(out f:File;c:char);
Procedure CloseFile(var f:File); Procedure CloseFile(var f:File);
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
{ Text file support } { Text file support }
Procedure AssignFile(out t:Text;const s:string); Procedure AssignFile(out t:Text;const s:string);
Procedure AssignFile(out t:Text;p:pchar); Procedure AssignFile(out t:Text;p:pchar);
Procedure AssignFile(out t:Text;c:char); Procedure AssignFile(out t:Text;c:char);
Procedure CloseFile(Var t:Text); Procedure CloseFile(Var t:Text);
{$endif FPC_HAS_FEATURE_TEXTIO}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Typed file supoort } { Typed file supoort }
Procedure AssignFile(out f:TypedFile;const Name:string); Procedure AssignFile(out f:TypedFile;const Name:string);
Procedure AssignFile(out f:TypedFile;p:pchar); Procedure AssignFile(out f:TypedFile;p:pchar);
Procedure AssignFile(out f:TypedFile;c:char); Procedure AssignFile(out f:TypedFile;c:char);
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
{ ParamStr should return also an ansistring } { ParamStr should return also an ansistring }
Function ParamStr(Param : Integer) : Ansistring; Function ParamStr(Param : Integer) : Ansistring;
{$endif FPC_HAS_FEATURE_COMMANDARGS}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure MkDir(const s:ansistring);overload; Procedure MkDir(const s:ansistring);overload;
Procedure RmDir(const s:ansistring);overload; Procedure RmDir(const s:ansistring);overload;
Procedure ChDir(const s:ansistring);overload; Procedure ChDir(const s:ansistring);overload;
{$endif FPC_HAS_FEATURE_FILEIO}
{**************************************************************************** {****************************************************************************
Resource strings. Resource strings.
@ -108,6 +118,7 @@ Var
Compatibility routines. Compatibility routines.
****************************************************************************} ****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure MkDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_MKDIR'; Procedure MkDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_MKDIR';
Procedure ChDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_CHDIR'; Procedure ChDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_CHDIR';
Procedure RmDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_RMDIR'; Procedure RmDirpchar(s: pchar;len:sizeuint);[IOCheck]; external name 'FPC_SYS_RMDIR';
@ -138,7 +149,9 @@ begin
{ Catch Runtime error/Exception } { Catch Runtime error/Exception }
System.Close(f); System.Close(f);
end; end;
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
{ Text file support } { Text file support }
Procedure AssignFile(out t:Text;const s:string); Procedure AssignFile(out t:Text;const s:string);
@ -165,7 +178,9 @@ begin
{ Catch Runtime error/Exception } { Catch Runtime error/Exception }
System.Close(T); System.Close(T);
end; end;
{$endif FPC_HAS_FEATURE_TEXTIO}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Typed file support } { Typed file support }
Procedure AssignFile(out f:TypedFile;const Name:string); Procedure AssignFile(out f:TypedFile;const Name:string);
@ -185,7 +200,9 @@ Procedure AssignFile(out f:TypedFile;c:char);
begin begin
system.Assign (F,C); system.Assign (F,C);
end; end;
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
Function ParamStr(Param : Integer) : Ansistring; Function ParamStr(Param : Integer) : Ansistring;
Var Len : longint; Var Len : longint;
@ -213,8 +230,10 @@ begin
else else
paramstr:=''; paramstr:='';
end; end;
{$endif FPC_HAS_FEATURE_COMMANDARGS}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure MkDir(const s:ansistring); Procedure MkDir(const s:ansistring);
begin begin
mkdirpchar(pchar(s),length(s)); mkdirpchar(pchar(s),length(s));
@ -229,6 +248,7 @@ Procedure ChDir(const s:ansistring);
begin begin
ChDirpchar(pchar(s),length(s)); ChDirpchar(pchar(s),length(s));
end; end;
{$endif FPC_HAS_FEATURE_FILEIO}
{ --------------------------------------------------------------------- { ---------------------------------------------------------------------
ResourceString support ResourceString support