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.