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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252 | with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers.Hashed_Maps;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Traceback.Symbolic;
with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse;
with GNATCOLL.Traces;
with Liblktlang_Support.Diagnostics; use Liblktlang_Support.Diagnostics;
with Liblktlang_Support.Diagnostics.Output;
use Liblktlang_Support.Diagnostics.Output;
with Liblktlang_Support.Slocs; use Liblktlang_Support.Slocs;
with Liblktlang_Support.Text; use Liblktlang_Support.Text;
with Liblktlang.Analysis; use Liblktlang.Analysis;
with Liblktlang.Common;
procedure Lkt_Toolbox is
package Arg is
Parser : Argument_Parser := Create_Argument_Parser
(Help => "Lkt toolbox. Toolbox like command line frontend for the "
& "LKT langkit library.");
package Files is new Parse_Positional_Arg_List
(Parser => Parser,
Name => "files",
Arg_Type => Unbounded_String,
Help => "The files to parse");
package Check_Only is new Parse_Flag
(Parser => Parser,
Short => "-C",
Long => "--check-only",
Help => "Only output the errors");
package Flag_Invalid is new Parse_Flag
(Parser => Parser,
Short => "-I",
Long => "--check-invalid-decls",
Help => "Flag decls that generate errors that are not annotated"
& " with the @invalid annotation. Also flag decls"
& " annotated with @invalid that don't trigger any errors");
end Arg;
use Liblktlang;
package Invalid_Decl_Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Analysis.Lkt_Node,
Element_Type => Boolean,
Hash => Analysis.Hash,
Equivalent_Keys => "=");
procedure Print_Semantic_Result
(S : Analysis.Semantic_Result; Unit : Analysis.Analysis_Unit);
-- Print a semantic result
function Format_Node (Decl_Node : Decl'Class) return String;
-- Format node for semantic result printing
procedure Print_Lkt_Toolbox_Diagnostic
(Node : Lkt_Node'Class; Message : Wide_Wide_String);
-- Internal wrapper to ``Print_Diagnostic`` used by lkt_toolbox to print
-- additional diagnostics.
function Populate_Invalid_Decl_Map
(Node : Analysis.Lkt_Node'Class) return Common.Visit_Status;
-- Populate ``Invalid_Decl_Map`` and reject declarations with ``@invalid``
-- annotations that are nested in another declaration annotated with
-- ``@invalid``.
Invalid_Decl_Map : Invalid_Decl_Maps.Map;
-- Map of declarations annotated with ``@invalid``. The boolean elements of
-- the map are initialized to ``False`` and set to ``True`` whenever a
-- diagnostic is emitted for the related declaration. Therefore, this map
-- is used to check that at least one diagnostic has been emitted for each
-- declaration annotated with ``@invalid``.
-----------------
-- Format_Node --
-----------------
function Format_Node (Decl_Node : Decl'Class) return String is
begin
-- Remove rebindings information as there is no easy way to filter
-- out/format rebindings information involving prelude declarations.
return Decl_Node.P_As_Bare_Decl.Image;
end Format_Node;
----------------------------------
-- Print_Lkt_Toolbox_Diagnostic --
----------------------------------
procedure Print_Lkt_Toolbox_Diagnostic
(Node : Lkt_Node'Class; Message : Wide_Wide_String)
is
Sloc_Range : constant Source_Location_Range := Node.Sloc_Range;
Unit : constant Analysis.Analysis_Unit := Node.Unit;
Path : constant String := Simple_Name (Unit.Get_Filename);
begin
Print_Diagnostic ((Sloc_Range, To_Unbounded_Text (Message)), Unit, Path);
end Print_Lkt_Toolbox_Diagnostic;
---------------------------
-- Print_Semantic_Result --
---------------------------
procedure Print_Semantic_Result
(S : Analysis.Semantic_Result; Unit : Analysis.Analysis_Unit)
is
Node : constant Lkt_Node'Class := Analysis.Node (S);
begin
if Analysis.Error_Message (S) /= "" then
declare
Diag : constant Diagnostic :=
(Node.Sloc_Range,
To_Unbounded_Text (Analysis.Error_Message (S)));
begin
if Arg.Flag_Invalid.Get then
-- Emit an error if the declaration including ``Node`` has no
-- ``@invalid`` annotation. Update ``Invalid_Decl_Map``
-- otherwise.
if Node.P_Topmost_Invalid_Decl.Is_Null then
Set_Exit_Status (1);
Print_Lkt_Toolbox_Diagnostic
(Node,
"unexpected diagnostic, is @invalid annotation missing?");
else
Invalid_Decl_Map (Node.P_Topmost_Invalid_Decl) := True;
end if;
end if;
Print_Diagnostic
(Diag, Unit, Simple_Name (Node.Unit.Get_Filename));
end;
elsif
not Arg.Check_Only.Get
and then not Analysis.Result_Type (S).Is_Null
then
Put_Line ("Expr " & Node.Image);
Put_Line (" has type " & Analysis.Result_Type (S).Image);
New_Line;
elsif
not Arg.Check_Only.Get
and then not Analysis.Result_Decl (S).Is_Null
then
Put_Line ("Id " & Node.Image);
Put_Line
(" references " & Format_Node (Analysis.Result_Decl (S)));
New_Line;
end if;
end Print_Semantic_Result;
-------------------------------
-- Populate_Invalid_Decl_Map --
-------------------------------
function Populate_Invalid_Decl_Map
(Node : Analysis.Lkt_Node'Class) return Common.Visit_Status
is
use type Common.Lkt_Node_Kind_Type;
begin
-- Populate ``Invalid_Decl_Map`` with declarations annotated with
-- ``@invalid``.
if Node.Kind = Common.Lkt_Full_Decl
and then Node.As_Full_Decl.P_Has_Annotation
(To_Unbounded_Text ("invalid"))
then
-- ``P_Topmost_Invalid_Decl`` should return the same node. In that
-- case, include this node in the map, otherwise nested ``@invalid``
-- declarations have been detected: emit a diagnostic.
if Invalid_Decl_Map.Contains (Node.P_Topmost_Invalid_Decl) then
Set_Exit_Status (1);
Print_Lkt_Toolbox_Diagnostic (Node, "nested @invalid declaration");
else
Invalid_Decl_Map.Include (Node.As_Lkt_Node, False);
end if;
end if;
return Common.Into;
end Populate_Invalid_Decl_Map;
Ctx : constant Analysis.Analysis_Context := Analysis.Create_Context;
begin
GNATCOLL.Traces.Parse_Config_File;
if Arg.Parser.Parse then
for File_Name of Arg.Files.Get loop
declare
File_Name_Str : constant String := To_String (File_Name);
Unit : constant Analysis.Analysis_Unit :=
Ctx.Get_From_File (File_Name_Str);
begin
if not Arg.Check_Only.Get then
Put_Line ("Resolving " & File_Name_Str);
Put_Line ((File_Name_Str'Length + 10) * "=");
end if;
if Unit.Diagnostics'Length > 0 then
for Diagnostic of Unit.Diagnostics loop
Print_Diagnostic
(Diagnostic, Unit, Simple_Name (Unit.Get_Filename));
end loop;
return;
end if;
if Arg.Flag_Invalid.Get then
Unit.Root.Traverse (Populate_Invalid_Decl_Map'Access);
end if;
declare
Diags : constant Analysis.Tree_Semantic_Result :=
Unit.Root.As_Langkit_Root.P_Check_Semantic;
begin
for D of Analysis.Results (Diags) loop
Print_Semantic_Result (D, Unit);
end loop;
end;
if Arg.Flag_Invalid.Get then
-- Ensure that all ``@invalid`` declarations in the map have
-- corresponding diagnostics. Otherwise, emit an error.
for E in Invalid_Decl_Map.Iterate loop
if not Invalid_Decl_Maps.Element (E) then
Set_Exit_Status (1);
Print_Lkt_Toolbox_Diagnostic
(Invalid_Decl_Maps.Key (E),
"@invalid declaration without diagnostic");
end if;
end loop;
end if;
end;
end loop;
end if;
exception
when E : Common.Property_Error =>
Put_Line (Ada.Exceptions.Exception_Message (E));
Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
end Lkt_Toolbox;
|