Updated 2016-10-06 15:46:50 by dbohdan

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

tclfpexample.pas  edit

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  edit

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.