[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 http://lists.freepascal.org/pipermail/fpc-devel/2014-May/033851.html%|%outdated%|% and breaks if you have a recent version of Tcl or target x86_64. It also lacks bindings for the [Tcl_Obj%|%*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

======none
fpc tclfpexample.pas \
&& echo 'load libtclfpexample.so; puts [hello]; puts [square 5]' | tclsh
======

** tclfpexample.pas **

======none
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.
======

** Discussion **

'''[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. 

**tclsampleext.pas**

======none

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:

** testsample.tcl **

======

load tclsampleext.dll

puts [package require test]

puts [square 12]

# Test cmd_del_proc callback

rename square {}


======

Which gives the outpu:

======none

% tclkitsh testsample.tcl
0.1
FirstName in ClientData Mark
objv[1]:12
144
Clearing Square clientData which had firstname: Mark

======

<<categories>> Foreign Interfaces | Example