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 . Note that tcltypes.inc file is incomplete and assumes most types are opaque pointers. I will refine it as needed.
% load tclfpexample.dll % package require test 0.1
The code is split in a tcl unit file and a sample extension. The tcl unit is available from the github link above.
library tclsampleext;
{$mode objfpc}{$H+}
uses {$IFDEF UNIX} {$IFDEF UseCThreads}
cthreads, {$ENDIF} {$ENDIF}
Classes,
SysUtils,
ctypes,
tcl;
type
TMailingListRecord = record
FirstName: string;
end;
PMailingListRecord = ^TMailingListRecord;
procedure Square_Del_Cmd(clientData: ClientData); cdecl;
begin
WriteLn('Clearing Square clientData which had firstname: ' + PMailingListRecord(clientData)^.FirstName);
Dispose(PMailingListRecord(clientData));
end;
function Square_Cmd(clientData: ClientData; interp: PTcl_Interp;
objc: cint; objv: PPTcl_Obj): cint; cdecl;
var
i: cint;
ml: TMailingListRecord;
begin
ml := PMailingListRecord(clientData)^;
WriteLn('FirstName in ClientData ' + ml.FirstName);
if objc <> 2 then
begin
Tcl_WrongNumArgs(interp, 1, objv, 'value');
Exit(TCL_ERROR);
end;
WriteLn('objv[1]:' + Tcl_GetString(objv[1]));
if Tcl_GetIntFromObj(interp, objv[1], @i) <> TCL_OK then
begin
Exit(TCL_ERROR);
end;
Tcl_SetObjResult(interp, Tcl_NewIntObj(i * i));
Result := TCL_OK;
end;
function Tclsampleext_Init(interp: PTcl_Interp): cint; cdecl;
var
ptr: PMailingListRecord;
begin
ptr := New(PMailingListRecord);
ptr^.FirstName := 'Mark';
Tcl_InitStubs(interp, '8.5', 0);
Tcl_PkgProvideEx(interp, 'test', '0.1', nil);
Tcl_CreateObjCommand(interp, 'square', @Square_Cmd, ptr, @Square_Del_Cmd);
Result := TCL_OK;
end;
exports Tclsampleext_Init;
end.
And the test script:
load tclsampleext.dll
puts [package require test]
puts [square 12]
# Test cmd_del_proc callback
rename square {}
Which gives the outpu:
% tclkitsh testsample.tcl 0.1 FirstName in ClientData Mark objv[1]:12 144 Clearing Square clientData which had firstname: Mark