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 the code below.
A full stubs enabled wrapper for Tcl 8.6 can be found on https://github.com/mpcjanssen/fpc-tcl .
% 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.