|
Guys regarding this bug.. http://www.freepascal.org/bugs/showrec.php3?ID=4855 I didn’t realize that pastebin.com would expire my pages
so quick.. Please find attached new code for this bug. I would update it in the bug report but it dosnt appear we
can edit bugs once reported. Also, Id love someone to confirm this bug for me, and
hopefully start work on it asap. I need to get our application compiling on free pascal and
port it to linux. And this bug is an absolute show stopper for us. Thanks Jay Binks |
This is the code that does not work
// =======================================================================
// This is the DLL... compiled in Delphi 2005
// =======================================================================
library Project1;
uses
SysUtils,
Classes;
{$R *.res}
type
iTest = interface
['{B1473B32-DDB5-452C-86BE-9C4D85E68495}']
function dotest( const aIn : Integer ): Integer;
end;
TTest = class( TInterfacedObject, iTest )
function dotest( const aIn : Integer ): Integer;
end;
function TTest.dotest( const aIn : Integer ): Integer;
begin
result := aIn + 1;
end;
Function test(): ITest;
begin
result := TTest.create();
end;
exports
test;
begin
end.
// =======================================================================
// This is the program (form)... compiled in Delphi 2005
// This works FINE with the Delphi DLL... 100%
// =======================================================================
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
iTest = interface
['{B1473B32-DDB5-452C-86BE-9C4D85E68495}']
function dotest( const aIn : Integer ): Integer;
end;
Ttest = Function(): ITest;
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
fTest : iTest;
doTest : Ttest;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if assigned( doTest ) then
begin
fTest := doTest();
showmessage( inttostr(fTest.dotest( 1 )) );
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
lLib : cardinal;
begin
lLib := loadlibrary( 'C:\TEST\Project1.dll' );
doTest := getprocaddress( lLib, 'test' );
end;
end.
// =======================================================================
// This is the program (form)... compiled in lazarus
// This loads ok, but errors at the highlited line
// when accessing the interface method ( "SigSegV" is the error )
// =======================================================================
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons, Windows;
type
iTest = interface
['{B1473B32-DDB5-452C-86BE-9C4D85E68495}']
function dotest( const aIn : Integer ): Integer;
end;
Ttest = Function(): ITest;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ private declarations }
fTest : iTest;
doTest : Ttest;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
lLib : cardinal;
begin
lLib := loadlibrary( 'C:\TEST\Project1.dll' );
pointer( doTest ) := getprocaddress( lLib, 'test' );
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if assigned( doTest ) then
begin
@@ fTest := doTest();
showmessage( inttostr(fTest.dotest( 1 )) );
end;
end;
initialization
{$I unit1.lrs}
end.
I modified above code to be like this, and it works
// =======================================================================
// This is the DLL... compiled in Delphi 2005
// =======================================================================
library Project1;
uses
SysUtils,
Classes;
{$R *.res}
type
// http://www.freepascal.org/docs-html/ref/refse35.html#x73-800007.3
// http://www.freepascal.org/docs-html/ref/refse36.html#x75-820007.4
iTest = interface
['{B1473B32-DDB5-452C-86BE-9C4D85E68495}']
function dotest( const aIn : Integer ): Integer; stdcall;
end;
TTest = class( TInterfacedObject, iTest )
function dotest( const aIn : Integer ): Integer; stdcall;
end;
function TTest.dotest( const aIn : Integer ): Integer;
begin
result := round( aIn * aIn );
end;
procedure test( var aTest : iTest );
begin
aTest := TTest.create();
end;
exports
test;
begin
end.
// =======================================================================
// This is the program (form)... compiled in lazarus
// This now works fine... if we use a procedure instead of the function
// in the DLL, also we may need to use stdcall and the $INTERFACES thing
// =======================================================================
unit Unit1;
{$mode delphi}
{$INTERFACES COM}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons, Windows;
type
iTest = interface
['{B1473B32-DDB5-452C-86BE-9C4D85E68495}']
function dotest( const aIn : Integer ): Integer; stdcall;
end;
Ttest = Procedure( var aTest : ITest );
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ private declarations }
fTest : iTest;
doTest : Ttest;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
lLib : cardinal;
begin
lLib := loadlibrary( 'C:\TEST\Project1.dll' );
doTest := getprocaddress( lLib, 'test' );
end;
procedure TForm1.Button2Click(Sender: TObject);
var
lTest : iTest;
begin
if assigned( doTest ) then
begin
doTest( fTest );
showmessage( inttostr(fTest.dotest( 4 )) );
end;
end;
initialization
{$I unit1.lrs}
end.
_______________________________________________ fpc-devel maillist - [email protected] http://lists.freepascal.org/mailman/listinfo/fpc-devel
