将成员函数指针转换为 FreePascal 中的函数指针

Posted 2023-02-22

【中文标题】将成员函数指针转换为 FreePascal 中的函数指针

【英文标题】：Convert member function pointer to function pointer in FreePascal

【发布时间】：2015-03-04 07:59:57

【问题描述】：

我想将一个指向成员函数 (TDisplayer.GlKeyboard) 的指针传递给 GLUT 函数 (glutKeyboardFunc)。 GLUT 回调只接受函数指针。有没有办法将自指针“打包”到函数中？

unit UDisplayer;

$mode objfpc

interface

type
   TDisplayer = class(TObject)

public
   constructor Create(x, y : Integer; caption : AnsiString);
   destructor Destroy; override;

   procedure GlKeyboard(key : Byte; x, y : Longint); cdecl; 

private
   winX : Integer;
   winY : Integer;
end;

implementation

uses gl, glut, glext, UTools;

constructor TDisplayer.Create(x, y : Integer; caption : AnsiString);
var
   cmd          : array of PChar;
   cmdCount     : Integer;
   keyboardCallback : pointer;
begin
   winX := x;
   winY := y;
   cmdCount := 1;
   SetLength(cmd, cmdCount);
   cmd[0] := PChar(ParamStr(0));
   glutInit(@cmdCount, @cmd);
   glutInitDisplayMode(GLUT_DOUBLE or GLUT_RGB or GLUT_DEPTH);
   glutInitWindowSize(x, y);
   glutCreateWindow(PChar(caption));

   glClearColor(0.0, 0.0, 0.0, 0);

   //glutKeyBoardFunc(@self.glKeyBoard); <--- HERE

   glutMainLoop;
end;

destructor TDisplayer.Destroy;
begin
   inherited;
end;

procedure TDisplayer.GlKeyboard(key : Byte; x, y : Longint); cdecl;
begin
end;

end.

【问题讨论】：

请提供您的代码。哪个GLUT函数？什么是“成员函数”？

我以键盘回调为例（GlKeyboard()）。我的代码：pastie.org/9998941

1) 如果在编译时知道回调的数量，那么您可以创建传递给 OpenGL 的简单函数，然后将调用重定向到存储在全局变量 2) 如果在运行时才知道回调的数量，那么您可以使用类似于 MakeObjectInstance 技巧的代码，它会动态生成小型包装机器代码，请参阅 svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/rtl/win32/…细节 3) 也许已经有一些面向对象的 OpenGL 包装器可以处理这个问题

【参考方案1】：

没有。一个方法指针是两个指针大，而一个简单的函数指针只有一个，所以根本放不下。

如果回调系统提供了一些“上下文”，您有时可以将实例传递到上下文中，并制作一个更通用的 thunk 之类的

function callme(context:pointer;x,y:integer);integer; cdecl;
begin
  TTheClass(context).callme(x,y);
end;

然后在注册回调时将“Self”作为上下文传递。但看起来这个回调设置器没有一个上下文，当它被调用时会传回回调。

【参考方案2】：

第一次，将回调声明为全局过程。 这将是一种与上下文无关的方法，不依赖于 Self

 type TDisplayer = class(TObject)
 public
   constructor Create(x, y : Integer; caption : AnsiString);
   destructor Destroy; override;
 private
   winX : Integer;
   winY : Integer;
 end;  

 procedure GlKeyboard(key : Byte; x, y : Longint); cdecl;

然后由于 glutCreateWindow() 返回一个唯一的上下文，您可以使用它将它与您的类实例相关联。因此，您定义了一个关联数组，它允许使用 GLUT 窗口作为键来检索 TDisplayer 实例：

type TCtxtArr = specialize TFPGMap<Integer,TForm>;  

您添加一个作为全局变量，它将在 initialization 和 finalization 部分中创建和释放：

var
  ctxtarray: TCtxtArr; 
initialization
  ctxtarray:= TCtxtArr.create;
finalization
  ctxtarray.free;
end. 

然后在 TDisplayer.Create() 中向 AA 添加一个条目：

// id is a local integer.
id = glutCreateWindow(PChar(caption));
ctxtarray.Add(id, Self);
// assign the callback here or elsewhere
glutKeyBoardFunc(@glKeyBoard);

当您的回调被调用时，您可以检索 TDisplayer 实例，以便您可以访问它的变量和方法：

procedure GlKeyboard(key : Byte; x, y : Longint); cdecl;
var
  disp: TDisplayer;
  id: integer;
begin
  glutGetWindow(id);
  disp := ctxtarray[id];
end;

不幸的是，我无法测试答案，因为它似乎是更大程序的一部分。但是，此示例以模拟方式工作：

unit Unit1;
$mode objfpc$H+
interface
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, dialogs, fgl;

type
  TForm1 = class;
  TProc = procedure(x,y: integer);
  TCtxtArr = specialize TFPGMap<Integer,TForm1>;

  TForm1 = class(TForm)
    constructor Create(TheOwner: TComponent); override;
    procedure hello;
  end;

  procedure callback(x,y: integer);

var
  Form1: TForm1; Proc: TProc;
  ctxtarray: TCtxtArr;

implementation
$R *.lfm

constructor TForm1.Create(TheOwner: TComponent);
begin
  inherited;
  proc := @callback;
  ctxtarray.Add(0,Self);
  proc(0,0);
end;

procedure TForm1.hello;
begin
  showmessage('hello');
end;

procedure callback(x, y: integer);
var
  frm: TForm1;
begin
  frm := ctxtarray.Data[0];
  frm.hello;
end;

initialization
  ctxtarray:= TCtxtArr.create;
finalization
  ctxtarray.free;
end.    

作为脚注：理论上 FPC 允许定义 静态 类方法（类似于全局过程），但由于某种原因，它们似乎不能分配给全局过程指针，至少它FPC 2.6.4 失败

【参考方案3】：

您必须组装一些字节码并使用“硬编码”自指针保存包装器，该指针管理调用堆栈：

procOfObj = packed record
    method : pointer;
    this   : pointer; 
    end;

obj = packed object
    procedure ASIOBufferSwitch(
      ip: pointer; the added IP artifact 
      doubleBufferIndex: longint; directProcess: longbool); cdecl;
    end;

cdeclProxy = packed object
    procedure  build( const src: procOfObj );    
    private
    push         : byte; push_arg: pointer;
    call         : byte; call_arg: pointer;
    add_ret      : longint;
    end;

procedure cdeclProxy.build( const src: procOfObj );
begin
    push := $68; push_arg := src.this;
    call := $e8; call_arg := pointer( src.method - @call - 5 );
    add_ret := $c304c483;
    result := @push;
end;

var cdp : cdeclProxy;
    o   : obj;
begin
    cdp.build( procOfObj( @o.ASIOBufferSwitch ))
    pointer(... procedure var ...) := @cdp;
end.

请注意，提供的示例在方法签名中需要额外的 arg，但它允许在不知道 arg 计数的情况下构建包装器。如果您不想要 ip arg，则必须在调用实际方法之前再次重新推送所有 args，然后清理包装器内的堆栈。