paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 15:29:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ AfterConstruction and BeforeDestruction implemented

Browse Source 
+ TInterfacedObject implemented
This commit is contained in:
florian 2000-11-07 23:42:21 +00:00
parent f89ea69e76
commit f79644d9ca
4 changed files with 144 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
rtl/i386/i386.inc
View File

@ -1117,14 +1117,59 @@ end;
{$ifdef SYSTEMDEBUG}
end;
{$endif def SYSTEMDEBUG}
{$ifdef HASINTF}
{ do a thread save inc/dec }
procedure declocked(var l : longint);assembler;
asm
{$ifdef MTRTL}
{ this check should be done because a lock takes a lot }
{ of time! }
cmpb $0,IsMultithreaded
jz .Ldeclockednolock
movl l,%edi
lock
decl (%edi)
jmp .Ldeclockedend
.Ldeclockednolock:
{$endif MTRTL}
movl l,%edi
decl (%edi);
.Ldeclockedend:
end ['EDI'];
procedure inclocked(var l : longint);assembler;
asm
{$ifdef MTRTL}
{ this check should be done because a lock takes a lot }
{ of time! }
cmpb $0,IsMultithreaded
jz .Linclockednolock
movl l,%edi
lock
incl (%edi)
jmp .Linclockedend
.Linclockednolock:
{$endif MTRTL}
movl l,%edi
incl (%edi);
.Linclockedend:
end ['EDI'];
{$endif HASINTF}
{
$Log$
Revision 1.3 2000-07-14 10:33:09 michael
Revision 1.4 2000-11-07 23:42:21 florian
+ AfterConstruction and BeforeDestruction implemented
+ TInterfacedObject implemented
Revision 1.3 2000/07/14 10:33:09 michael
+ Conditionals fixed
Revision 1.2 2000/07/13 11:33:41 michael
+ removed logs
}
}

9
rtl/inc/dynarr.inc
View File

@ -132,10 +132,13 @@ function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
{
$Log$
Revision 1.2 2000-11-06 21:35:59 peter
Revision 1.3 2000-11-07 23:42:21 florian
+ AfterConstruction and BeforeDestruction implemented
+ TInterfacedObject implemented
Revision 1.2 2000/11/06 21:35:59 peter
* removed some warnings
Revision 1.1 2000/11/04 17:52:46 florian
* fixed linker errors
}
}

58
rtl/inc/objpas.inc
View File

@ -595,6 +595,58 @@ Procedure Finalize (Data,TypeInfo: Pointer);forward;
begin
getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
end;
{****************************************************************************
TINTERFACEDOBJECT
****************************************************************************}
function TInterfacedObject.QueryInterface(
const iid : tguid;out obj) : longint;stdcall;
begin
if getinterface(iid,obj) then
result:=0
else
result:=$80004002;
end;
function TInterfacedObject._AddRef : longint;stdcall;
begin
inclocked(frefcount);
_addref:=frefcount;
end;
function TInterfacedObject._Release : longint;stdcall;
begin
declocked(frefcount);
_release:=frefcount;
if frefcount=0 then
destroy;
end;
procedure TInterfacedObject.AfterConstruction;
begin
{ we need to fix the refcount we forced in newinstance }
{ further, it must be done in a thread safe way }
declocked(frefcount);
end;
procedure TInterfacedObject.BeforeDestruction;
begin
if frefcount<>0 then
HandleError(204);
end;
class function TInterfacedObject.NewInstance : TObject;
begin
NewInstance:=inherited NewInstance;
TInterfacedObject(NewInstance).frefcount:=1;
end;
{$endif HASINTF}
{****************************************************************************
@ -609,7 +661,11 @@ Procedure Finalize (Data,TypeInfo: Pointer);forward;
{
$Log$
Revision 1.9 2000-11-06 22:03:12 florian
Revision 1.10 2000-11-07 23:42:21 florian
+ AfterConstruction and BeforeDestruction implemented
+ TInterfacedObject implemented
Revision 1.9 2000/11/06 22:03:12 florian
* another fix
Revision 1.8 2000/11/06 21:53:38 florian

47
rtl/inc/objpash.inc
View File

@ -151,23 +151,38 @@
{$ifdef HASINTF}
IUnknown = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const iid: tguid; out obj): LongInt; stdcall;
function _AddRef: LongInt; stdcall;
function _Release: LongInt; stdcall;
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
end;
{ for native dispinterface support }
IDispatch = interface(IUnknown)
['{00020400-0000-0000-C000-000000000046}']
function GetTypeInfoCount(out count: LongInt): LongInt; stdcall;
function GetTypeInfo(Index, LocaleID: LongInt;
out TypeInfo): LongInt; stdcall;
function GetIDsOfNames(const iid: TGUID; names: Pointer;
NameCount, LocaleID: LongInt; DispIDs: Pointer): LongInt; stdcall;
function Invoke(DispID: LongInt; const iid: TGUID;
LocaleID: LongInt; Flags: Word; var params;
VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
['{00020400-0000-0000-C000-000000000046}']
function GetTypeInfoCount(out count : longint) : longint;stdcall;
function GetTypeInfo(Index,LocaleID : longint;
out TypeInfo): LongInt;stdcall;
function GetIDsOfNames(const iid: TGUID; names: Pointer;
NameCount, LocaleID: LongInt; DispIDs: Pointer) : longint;stdcall;
function Invoke(DispID: LongInt;const iid : TGUID;
LocaleID : longint; Flags: Word;var params;
VarResult,ExcepInfo,ArgErr : pointer) : longint;stdcall;
end;
TInterfacedObject = class(TObject,IUnknown)
protected
frefcount : longint;
{ implement methods of IUnknown }
function QueryInterface(const iid : tguid;out obj) : longint;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
public
procedure AfterConstruction;override;
procedure BeforeDestruction;override;
class function NewInstance : TObject;override;
property RefCount : longint read frefcount;
end;
{$endif HASINTF}
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
@ -258,7 +273,11 @@
end;
{
$Log$
Revision 1.7 2000-11-06 20:34:24 peter
Revision 1.8 2000-11-07 23:42:21 florian
+ AfterConstruction and BeforeDestruction implemented
+ TInterfacedObject implemented
Revision 1.7 2000/11/06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.6 2000/11/04 17:31:50 florian
@ -277,4 +296,4 @@
Revision 1.2 2000/07/13 11:33:45 michael
+ removed logs
}
}