1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
------------------------------------------------------------------------------
-- G P S --
-- --
-- Copyright (C) 2003-2015, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.Scripts; use GNATCOLL.Scripts;
package body Testsuite_Export is
procedure On_Hello (Data : in out Callback_Data'Class; Command : String);
procedure On_Print_Float
(Data : in out Callback_Data'Class; Command : String);
procedure C1_Handler (Data : in out Callback_Data'Class; Command : String);
procedure Custom_List_Handler
(Data : in out Callback_Data'Class; Command : String);
Prop : Integer := 0;
Ro_Prop : Integer := 0;
Wo_Prop : Integer := 0;
-- Imagine these are fields of a class. We simplify the test case by
-- using global variables
--------------------
-- On_Print_Float --
--------------------
procedure On_Print_Float
(Data : in out Callback_Data'Class; Command : String)
is
pragma Unreferenced (Command);
Param : constant Float := Nth_Arg (Data, 1);
begin
Put_Line ("Parameter was" & Float'Image (Param));
Set_Return_Value (Data, Param + 1.0);
end On_Print_Float;
--------------
-- On_Hello --
--------------
procedure On_Hello (Data : in out Callback_Data'Class; Command : String) is
pragma Unreferenced (Command);
begin
Set_Return_Value (Data, "Hello " & Nth_Arg (Data, 1, "world") & " !");
end On_Hello;
-------------------------
-- Custom_List_Handler --
-------------------------
procedure Custom_List_Handler
(Data : in out Callback_Data'Class; Command : String)
is
begin
Set_Return_Value (Data, "Executing command '" & Command & "'");
end Custom_List_Handler;
----------------
-- C1_Handler --
----------------
procedure C1_Handler
(Data : in out Callback_Data'Class; Command : String)
is
-- This could also be kept as a variable somewhere, but fetching it
-- is relatively cheap
C1 : constant Class_Type := New_Class (Get_Repository (Data), "C1");
Inst : Class_Instance;
begin
if Command = Constructor_Method then
Inst := Nth_Arg (Data, 1, C1);
Set_Data (Inst, C1, Integer'(Nth_Arg (Data, 2)));
Set_Property (Inst, "id", 2);
Set_Property (Inst, "name", "the_name");
elsif Command = "method" then
Inst := Nth_Arg (Data, 1, C1);
Set_Return_Value
(Data, "Method applied to class"
& Integer'Image (Get_Data (Inst, C1)) & " with param "
& Nth_Arg (Data, 2));
elsif Command = "prop" then
if Number_Of_Arguments (Data) = 1 then
Set_Return_Value (Data, Prop);
else
Prop := Nth_Arg (Data, 2) + 1; -- Offset to make sure we were here
end if;
elsif Command = "ro_prop" then
Set_Return_Value (Data, Ro_Prop);
elsif Command = "wo_prop" then
Wo_Prop := Nth_Arg (Data, 2);
end if;
end C1_Handler;
------------------------
-- Register_Functions --
------------------------
procedure Register_Functions (Repo : Scripts_Repository) is
C1 : Class_Type;
Custom_List : constant Class_Type := New_Class
(Repo, "MyList", Lookup_Class (Repo, "list"));
begin
Register_Command
(Repo, "hello", 0, 1,
Handler => On_Hello'Access);
Register_Command
(Repo, "print_float", 1, 1,
Handler => On_Print_Float'Access);
C1 := New_Class (Repo, "C1");
Register_Command
(Repo, Constructor_Method, 1, 1,
Class => C1,
Handler => C1_Handler'Access);
Register_Command
(Repo, "method", 0, 1,
Class => C1,
Handler => C1_Handler'Access);
Register_Property
(Repo, "prop", Class => C1,
Setter => C1_Handler'Access,
Getter => C1_Handler'Access);
Register_Property
(Repo, "ro_prop", Class => C1,
Getter => C1_Handler'Access);
Register_Property
(Repo, "wo_prop", Class => C1,
Setter => C1_Handler'Access);
Register_Command
(Repo, "dump", Class => Custom_List,
Handler => Custom_List_Handler'Access);
end Register_Functions;
end Testsuite_Export;
|
