-- Copyright 2017-2022 Simon Wright <simon@pushface.org>
--
-- This unit is free software; you can redistribute it and/or modify
-- it as you wish. This unit is distributed in the hope that it will
-- be useful, but WITHOUT ANY WARRANTY; without even the implied
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-- This program (with watching.tcl) demonstrates the use of
-- Tcl_SetVar[2]() to get an Ada-domain value back into the Tcl
-- domain without the use of polling.
with CArgv;
with Interfaces.C.Strings;
with Tcl.Ada;
with Tcl.Async;
package body Watching_Support is
-- Handy wrapper for C.Strings.Free, so it can be used to free
-- results.
procedure Freeproc (BlockPtr : Interfaces.C.Strings.chars_ptr);
pragma Convention (C, Freeproc);
function Square
(Client_Data : Integer;
Interp : Tcl.Tcl_Interp;
Argc : Interfaces.C.int;
Argv : CArgv.Chars_Ptr_Ptr) return Interfaces.C.int;
pragma Convention (C, Square);
function Init (Interp : Tcl.Tcl_Interp) return Interfaces.C.int is
package CreateCommands is new Tcl.Ada.Generic_Command (Integer);
Command : Tcl.Tcl_Command;
pragma Unreferenced (Command);
use type Interfaces.C.int;
begin
if Tcl.Tcl_Init (Interp) = Tcl.TCL_ERROR then
return Tcl.TCL_ERROR;
end if;
Tcl.Async.Register (Interp);
Command := CreateCommands.Tcl_CreateCommand
(Interp,
"square",
Square'Unrestricted_Access,
0,
null);
return Tcl.TCL_OK;
end Init;
procedure Freeproc (BlockPtr : Interfaces.C.Strings.chars_ptr)
is
Tmp : Interfaces.C.Strings.chars_ptr := BlockPtr;
begin
Interfaces.C.Strings.Free (Tmp);
end Freeproc;
function Square
(Client_Data : Integer;
Interp : Tcl.Tcl_Interp;
Argc : Interfaces.C.int;
Argv : CArgv.Chars_Ptr_Ptr) return Interfaces.C.int
is
pragma Unreferenced (Client_Data);
Input : Integer;
Squared : Integer;
use type Interfaces.C.int;
begin
pragma Assert (Argc = 2, "'square' requires one integer argument");
Input := Integer'Value
(Interfaces.C.Strings.Value
(CArgv.Argv_Pointer.Value (Argv) (1)));
Squared := Input * Input;
Tcl.Tcl_SetResult
(Interp,
Interfaces.C.Strings.New_String (Integer'Image (Squared)),
Freeproc'Unrestricted_Access);
Tcl.Async.Set (Tcl_Array => "tellback",
Index => "42",
Value => Integer'Image (Squared));
return Tcl.TCL_OK;
end Square;
end Watching_Support;