dbohdan 2016-10-02: This example shows how to write a Tcl extension in Free Pascal. It has been tested with FPC 2.6.2-8 2014/01/22 and 3.0.0 2015/11/20 for x86_64 on Ubuntu 14.04.
Note that the example does not use the Tcl80 unit. That unit is outdated and breaks if you have a recent version of Tcl or target x86_64. It also lacks bindings for the *Obj* functions of the Tcl C API. (E.g., it has the legacy Tcl_CreateCommand but not Tcl_CreateObjCommand.) Instead, the extension contains its own bindings just for the functions it uses.
To build and test on Linux, use the POSIX shell command
fpc tclfpexample.pas \ && echo 'load libtclfpexample.so; puts [hello]; puts [square 5]' | tclsh
library TclFPExample;
uses ctypes;
const
STUBS = 'tclstub8.6';
TCL_VERSION = '8.6';
TCL_OK = 0;
TCL_ERROR = 1;
type
PPTcl_Obj = ^PTcl_Obj;
PTcl_Interp = Pointer;
PTcl_Obj = Pointer;
Tcl_ClientData = Pointer;
Tcl_CmdDeleteProc = Pointer;
Tcl_ObjCmdProc = function(clientData: Tcl_ClientData;
interp: PTcl_Interp;
objc: cint;
objv: PPTcl_Obj): cint; cdecl;
Tcl_Command = Pointer;
function Tcl_CreateObjCommand(interp: PTcl_Interp;
cmdName: PChar;
proc: Tcl_ObjCmdProc;
clientData: Tcl_ClientData;
deleteProc: Tcl_CmdDeleteProc): Tcl_Command;
cdecl; external STUBS;
function Tcl_InitStubs(interp: PTcl_Interp;
version: PChar;
exact: cint): PChar;
cdecl; external STUBS;
function Tcl_GetIntFromObj(interp: PTcl_Interp;
objPtr: PTcl_Obj;
intPtr: pcint): cint;
cdecl; external STUBS;
function Tcl_NewIntObj(intValue: cint): PTcl_Obj;
cdecl; external STUBS;
function Tcl_NewStringObj(bytes: PChar; length: cint): PTcl_Obj;
cdecl; external STUBS;
procedure Tcl_SetObjResult(interp: PTcl_Interp;
resultObjPtr: PTcl_Obj);
cdecl; external STUBS;
procedure Tcl_WrongNumArgs(interp: PTcl_Interp;
objc: cint;
objv: PPTcl_Obj;
message: PChar);
cdecl; external STUBS;
function Hello_Cmd(clientData: Tcl_ClientData;
interp: PTcl_Interp;
objc: cint;
objv: PPTcl_Obj): cint; cdecl;
begin
if objc <> 1 then
begin
Tcl_WrongNumArgs(interp, 1, objv, nil);
Hello_Cmd := TCL_ERROR;
exit;
end;
Tcl_SetObjResult(interp, Tcl_NewStringObj('Hello, World!', -1));
Hello_Cmd := TCL_OK;
end;
function Square_Cmd(clientData: Tcl_ClientData;
interp: PTcl_Interp;
objc: cint;
objv: PPTcl_Obj): cint; cdecl;
var i: cint;
begin
if objc <> 2 then
begin
Tcl_WrongNumArgs(interp, 1, objv, 'value');
Square_Cmd := TCL_ERROR;
exit;
end;
if Tcl_GetIntFromObj(interp, objv[1], @i) <> TCL_OK then
begin
Square_Cmd := TCL_ERROR;
exit;
end;
Tcl_SetObjResult(interp, Tcl_NewIntObj(i*i));
Square_Cmd := TCL_OK;
end;
function Tclfpexample_Init(interp: PTcl_Interp): cint; cdecl;
begin
if Tcl_InitStubs(interp, TCL_VERSION, 0) = nil then
begin
Tclfpexample_Init := TCL_ERROR;
exit;
end;
Tcl_CreateObjCommand(interp, 'hello', Tcl_ObjCmdProc(@Hello_Cmd), nil, nil);
Tcl_CreateObjCommand(interp, 'square', Tcl_ObjCmdProc(@Square_Cmd), nil,
nil);
Tclfpexample_Init := TCL_OK;
end;
exports
Tclfpexample_Init;
end.arjen - 2016-10-06 06:40:48
You could use the technique I described in Interfacing with the Tcl C API from Fortran to generate the "complete" interface to the Tcl C functions.
MJ - 2017-08-05
Note that the code above doesn't actually use the stubs mechanism and therefore can only load in a specific Tcl version. To actually use the stubs mechanism, the code below demonstrates initializing the stubs pointer and using it to call the first stubbed Tcl procedure. As demonstrated by:
% load tclfpexample.dll % package require test 0.1
The code is split in a tcl unit file and a sample extension. Note that the unit file uses generic types for the Tcl commands instead of a single type per Tcl command in the hope that there are signature overlaps.
library tclsampleext;
{$mode objfpc}{$H+}
{$linklib libtclstub.a}
uses {$IFDEF UNIX} {$IFDEF UseCThreads}
cthreads, {$ENDIF} {$ENDIF}
Classes,
SysUtils,
ctypes,
tcl;
function Tclsampleext_Init(interp: PTcl_Interp): cint; cdecl;
begin
Tcl_InitStubs(interp,'8.5',0);
Tcl_PackageProvideEx(interp, 'test', '0.1', nil);
Result := TCL_OK;
end;
exports Tclsampleext_Init;
end.
And the unit file:
unit tcl;
{$mode objfpc}{$H+}
{$linklib libtclstub.a}
interface
uses {$IFDEF UNIX} {$IFDEF UseCThreads}
cthreads, {$ENDIF} {$ENDIF}
Classes,
SysUtils,
ctypes;
const
TCL_OK = 0;
TCL_ERROR = 1;
type
PPTcl_Obj = ^PTcl_Obj;
PTclStubs = ^TclStubs;
PTcl_Interp = Pointer;
PTcl_Obj = Pointer;
Tcl_ClientData = Pointer;
Tcl_CmdDeleteProc = Pointer;
Tcl_ObjCmdProc = function(clientData: Tcl_ClientData;
interp: PTcl_Interp; objc: cint; objv: PPTcl_Obj): cint; cdecl;
Tcl_Command = Pointer;
F_InterpStringStringClientdata_Integer = function(interp: PTcl_Interp; Name: PChar;
version: PChar; clientData: Tcl_ClientData): cint; cdecl;
TclStubs = record
magic: integer;
hooks: Pointer;
PackageProvideEx: F_InterpStringStringClientdata_Integer ;
end;
function Tcl_InitStubs(interp: PTcl_Interp; version: PChar; exact: cint): PChar;
var
Tcl_PackageProvideEx: F_InterpStringStringClientdata_Integer;
implementation
var
tclStubsPtr : PTclStubs ; cvar;external;
function tclInitStubs(interp: PTcl_Interp; version: PChar; exact: cint): PChar; cdecl; external name 'Tcl_InitStubs';
function Tcl_InitStubs(interp: PTcl_Interp; version: PChar; exact: cint): PChar;
begin
tclInitStubs(interp,version,exact);
Tcl_PackageProvideEx:=tclStubsPtr^.PackageProvideEx;
end;
end.