paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 19:41:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

* hopefully fpc_intf_assign_by_iid improved

Browse Source 
git-svn-id: trunk@5842 -
This commit is contained in:
florian 2007-01-07 17:59:46 +00:00
parent fa493c7898
commit 4c7c5e5adf
3 changed files with 46 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -7904,6 +7904,7 @@ tests/webtbs/tw6735.pp svneol=native#text/plain
tests/webtbs/tw6742.pp svneol=native#text/plain tests/webtbs/tw6742.pp svneol=native#text/plain
tests/webtbs/tw6767.pp svneol=native#text/plain tests/webtbs/tw6767.pp svneol=native#text/plain
tests/webtbs/tw6865.pp svneol=native#text/plain tests/webtbs/tw6865.pp svneol=native#text/plain
tests/webtbs/tw6868.pp svneol=native#text/plain
tests/webtbs/tw6960.pp svneol=native#text/plain tests/webtbs/tw6960.pp svneol=native#text/plain
tests/webtbs/tw6977.pp svneol=native#text/plain tests/webtbs/tw6977.pp svneol=native#text/plain
tests/webtbs/tw6980.pp svneol=native#text/plain tests/webtbs/tw6980.pp svneol=native#text/plain

20
rtl/inc/objpas.inc
View File

@ -78,13 +78,25 @@
end; end;
procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc; procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc;
var
tmp : pointer;
begin
if assigned(S) then
begin
if IUnknown(S).QueryInterface(iid,tmp)<>S_OK then
handleerror(219);
if assigned(tmp) then
IUnknown(tmp)._AddRef;
if assigned(D) then
IUnknown(D)._Release;
D:=tmp;
end
else
begin begin
if assigned(D) then if assigned(D) then
IUnknown(D)._Release; IUnknown(D)._Release;
if assigned(S) then D:=nil;
IUnknown(S).QueryInterface(iid, D) end;
else
D := nil;
end; end;

29
tests/webtbs/tw6868.pp Normal file
View File

@ -0,0 +1,29 @@
program project1;
{$mode objfpc}{$H+}
uses Classes, SysUtils;
type IHelpSystem = interface(IInterface) end;
THelpManager = class(TInterfacedObject, IHelpSystem) end;
var HelpManager : THelpManager = nil;
function GetHelpSystem(out H: IHelpSystem) : Integer;
begin
if HelpManager = nil then HelpManager := THelpManager.Create; // if help manager is not created here, it works
H := HelpManager; // <-- remove this and it works
result := 0;
end;
procedure FreeHelpSystem;
begin
if HelpManager <> nil then
HelpManager._Release;
HelpManager := nil;
end;
var h : IHelpSystem;
begin
GetHelpSystem(h);
FreeHelpSystem;
end.