source: trunk/ada-2012/tests/asis/def_name/def_name.adb@ 383

Last change on this file since 383 was 383, checked in by Maxim Reznik, 5 years ago

Improve def_name test to print each name

If def_name is started with last argument in form "+hash" then
traverse all elements for given compilation unit and print
Corresponding_Name_Definition where appropriate.

File size: 8.4 KB
Line 
1with Ada.Command_Line;
2with Ada.Strings.Wide_Fixed;
3with Ada.Wide_Text_IO;
4with Ada.Wide_Wide_Text_IO;
5with Ada.Containers.Generic_Array_Sort;
6
7with Asis;
8with Asis.Ada_Environments;
9with Asis.Clauses;
10with Asis.Compilation_Units;
11with Asis.Declarations;
12with Asis.Elements;
13with Asis.Errors;
14with Asis.Exceptions;
15with Asis.Expressions;
16with Asis.Implementation;
17with Asis.Iterator;
18with Asis.Text;
19
20with League.Application;
21with League.Strings;
22with League.String_Vectors;
23
24procedure Def_Name is
25 procedure On_Unit (Unit : Asis.Compilation_Unit);
26 procedure On_Identifier (Item : Asis.Identifier);
27
28 function Less (Left, Right : Asis.Compilation_Unit) return Boolean;
29
30 procedure Sort is new Ada.Containers.Generic_Array_Sort
31 (Index_Type => Asis.List_Index,
32 Element_Type => Asis.Compilation_Unit,
33 Array_Type => Asis.Compilation_Unit_List,
34 "<" => Less);
35
36 procedure On_Element (Item : Asis.Element);
37
38 procedure Pre_Operation
39 (Element : in Asis.Element;
40 Control : in out Asis.Traverse_Control;
41 State : in out League.Strings.Universal_String);
42
43 procedure Post_Operation
44 (Element : in Asis.Element;
45 Control : in out Asis.Traverse_Control;
46 State : in out League.Strings.Universal_String) is null;
47
48 procedure Iterate is new Asis.Iterator.Traverse_Element
49 (State_Information => League.Strings.Universal_String,
50 Pre_Operation => Pre_Operation,
51 Post_Operation => Post_Operation);
52
53 Result : League.Strings.Universal_String;
54 Deep : Boolean;
55
56 ----------
57 -- Less --
58 ----------
59
60 function Less (Left, Right : Asis.Compilation_Unit) return Boolean is
61 use type Asis.Text.Line_Number;
62
63 Left_Line : constant Asis.Text.Line_Number :=
64 Asis.Text.First_Line_Number (Asis.Elements.Unit_Declaration (Left));
65 Right_Line : constant Asis.Text.Line_Number :=
66 Asis.Text.First_Line_Number (Asis.Elements.Unit_Declaration (Right));
67 Left_Name : constant Asis.Program_Text :=
68 Asis.Compilation_Units.Text_Name (Left);
69 Right_Name : constant Asis.Program_Text :=
70 Asis.Compilation_Units.Text_Name (Right);
71 begin
72 if Left_Name = Right_Name then
73 return Left_Line < Right_Line;
74 else
75 return Left_Name < Right_Name;
76 end if;
77 end Less;
78
79 ----------------
80 -- On_Element --
81 ----------------
82
83 procedure On_Element (Item : Asis.Element) is
84 begin
85 case Asis.Elements.Expression_Kind (Item) is
86 when Asis.An_Identifier =>
87 On_Identifier (Item);
88 when Asis.A_Selected_Component =>
89 On_Identifier
90 (Asis.Expressions.Selector (Item));
91 when Asis.An_Operator_Symbol =>
92 On_Identifier (Item);
93 when others =>
94 null;
95 end case;
96 end On_Element;
97
98 -------------------
99 -- On_Identifier --
100 -------------------
101
102 procedure On_Identifier (Item : Asis.Identifier) is
103 Span : Asis.Text.Span;
104 Tipe : Asis.Type_Definition;
105 Decl : Asis.Declaration;
106 Unit : Asis.Compilation_Unit;
107 Def : constant Asis.Defining_Name :=
108 Asis.Expressions.Corresponding_Name_Definition (Item);
109 begin
110 Result.Append
111 (League.Strings.From_UTF_16_Wide_String
112 (Asis.Expressions.Name_Image (Item)));
113
114 Span := Asis.Text.Element_Span (Item);
115 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
116 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
117 Result.Append (" => ");
118
119 if Asis.Elements.Is_Nil (Def) then
120 null;
121 elsif Asis.Elements.Is_Part_Of_Implicit (Def) then
122 Result.Append ("Is_Part_Of_Implicit ");
123 Decl := Asis.Elements.Enclosing_Element (Def);
124
125 if Asis.Elements.Declaration_Kind (Decl) in
126 Asis.A_Function_Declaration | Asis.A_Procedure_Declaration
127 then
128 Tipe := Asis.Declarations.Corresponding_Type (Decl);
129
130 if not Asis.Elements.Is_Nil (Tipe) then
131 Decl := Asis.Elements.Enclosing_Element (Tipe);
132 declare
133 Names : constant Asis.Defining_Name_List :=
134 Asis.Declarations.Names (Decl);
135 begin
136 Result.Append
137 (League.Strings.From_UTF_16_Wide_String
138 (Asis.Declarations.Defining_Name_Image
139 (Names (Names'First))));
140 end;
141 end if;
142 end if;
143 else
144 Unit := Asis.Elements.Enclosing_Compilation_Unit (Def);
145 Result.Append
146 (League.Strings.From_UTF_16_Wide_String
147 (Asis.Compilation_Units.Unit_Full_Name (Unit)));
148 Span := Asis.Text.Element_Span (Def);
149 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
150 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
151 end if;
152
153 Result.Append (Wide_Wide_Character'Val (10));
154 end On_Identifier;
155
156 -------------
157 -- On_Unit --
158 -------------
159
160 procedure On_Unit (Unit : Asis.Compilation_Unit) is
161 Control : Asis.Traverse_Control := Asis.Continue;
162
163 Withs : constant Asis.Element_List :=
164 Asis.Elements.Context_Clause_Elements (Unit);
165 begin
166 for J in Withs'Range loop
167 case Asis.Elements.Clause_Kind (Withs (J)) is
168 when Asis.A_With_Clause | Asis.A_Use_Package_Clause =>
169 declare
170 Names : constant Asis.Element_List :=
171 Asis.Clauses.Clause_Names (Withs (J));
172 begin
173 for K in Names'Range loop
174 On_Element (Names (K));
175 end loop;
176 end;
177 when others =>
178 null;
179 end case;
180 end loop;
181
182 if Deep then
183 Iterate (Asis.Elements.Unit_Declaration (Unit), Control, Result);
184 end if;
185 end On_Unit;
186
187 -------------------
188 -- Pre_Operation --
189 -------------------
190
191 procedure Pre_Operation
192 (Element : in Asis.Element;
193 Control : in out Asis.Traverse_Control;
194 State : in out League.Strings.Universal_String)
195 is
196 pragma Unreferenced (Control);
197 pragma Unreferenced (State);
198 begin
199 On_Element (Element);
200 end Pre_Operation;
201
202 use type League.Hash_Type;
203
204 Args : League.String_Vectors.Universal_String_Vector;
205 Last_Arg : League.Strings.Universal_String;
206 Params : League.Strings.Universal_String;
207 Context : Asis.Context;
208 Hash : League.Hash_Type;
209begin
210 for J in 1 .. League.Application.Arguments.Length - 1 loop
211 Args.Append (League.Application.Arguments.Element (J));
212 end loop;
213
214 Last_Arg := League.Application.Arguments.Element
215 (League.Application.Arguments.Length);
216
217 Hash := League.Hash_Type'Wide_Wide_Value (Last_Arg.To_Wide_Wide_String);
218
219 Deep := Last_Arg.Starts_With ("+");
220
221 Params := Args.Join (' ');
222
223 Asis.Implementation.Initialize ("");
224
225 Asis.Ada_Environments.Associate
226 (The_Context => Context,
227 Name => Asis.Ada_Environments.Default_Name,
228 Parameters => Params.To_UTF_16_Wide_String);
229
230 Asis.Ada_Environments.Open (Context);
231
232 declare
233 Name : constant Wide_String := "/" &
234 Args.Element (Args.Length).To_UTF_16_Wide_String;
235 List : Asis.Compilation_Unit_List :=
236 Asis.Compilation_Units.Compilation_Units (Context);
237 begin
238 Sort (List);
239
240 for J in List'Range loop
241 if Name = Ada.Strings.Wide_Fixed.Tail
242 (Source => Asis.Compilation_Units.Text_Name (List (J)),
243 Count => Name'Length)
244 then
245 On_Unit (List (J));
246 end if;
247 end loop;
248 end;
249
250 Asis.Ada_Environments.Close (Context);
251 Asis.Ada_Environments.Dissociate (Context);
252 Asis.Implementation.Finalize ("");
253
254 if Hash /= Result.Hash then
255 Ada.Wide_Wide_Text_IO.Put
256 (League.Hash_Type'Wide_Wide_Image (Result.Hash));
257 Ada.Wide_Wide_Text_IO.Put_Line (" ");
258 Ada.Wide_Wide_Text_IO.Put_Line (Result.To_Wide_Wide_String);
259 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
260 end if;
261
262exception
263 when Asis.Exceptions.ASIS_Failed =>
264 Ada.Wide_Text_IO.Put_Line
265 ("ASIS_Failed status: " &
266 Asis.Errors.Error_Kinds'Wide_Image
267 (Asis.Implementation.Status));
268 Ada.Wide_Text_IO.Put_Line (Asis.Implementation.Diagnosis);
269 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
270end Def_Name;
Note: See TracBrowser for help on using the repository browser.