[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, it 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_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_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
    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.
======

<<categories>> Foreign Interfaces | Example