[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:

======

% 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 will probably use generic types for the Tcl commands instead of a single type per Tcl command. 

**tclsampleext.pas**

======none

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:

** tcl.pas**

======none

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.



======

<<categories>> Foreign Interfaces | Example