[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. ====== % 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 uses generic types for the Tcl commands instead of a single type per Tcl command in the hope that there are signature overlaps. **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. ====== <> Foreign Interfaces | Example