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

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

Make distinction between index and disriminant constraint

File size: 8.5 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 Asis.An_Enumeration_Literal =>
94 On_Identifier (Item);
95 when others =>
96 null;
97 end case;
98 end On_Element;
99
100 -------------------
101 -- On_Identifier --
102 -------------------
103
104 procedure On_Identifier (Item : Asis.Identifier) is
105 Span : Asis.Text.Span;
106 Tipe : Asis.Type_Definition;
107 Decl : Asis.Declaration;
108 Unit : Asis.Compilation_Unit;
109 Def : constant Asis.Defining_Name :=
110 Asis.Expressions.Corresponding_Name_Definition (Item);
111 begin
112 Result.Append
113 (League.Strings.From_UTF_16_Wide_String
114 (Asis.Expressions.Name_Image (Item)));
115
116 Span := Asis.Text.Element_Span (Item);
117 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
118 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
119 Result.Append (" => ");
120
121 if Asis.Elements.Is_Nil (Def) then
122 null;
123 elsif Asis.Elements.Is_Part_Of_Implicit (Def) then
124 Result.Append ("Is_Part_Of_Implicit ");
125 Decl := Asis.Elements.Enclosing_Element (Def);
126
127 if Asis.Elements.Declaration_Kind (Decl) in
128 Asis.A_Function_Declaration | Asis.A_Procedure_Declaration
129 then
130 Tipe := Asis.Declarations.Corresponding_Type (Decl);
131
132 if not Asis.Elements.Is_Nil (Tipe) then
133 Decl := Asis.Elements.Enclosing_Element (Tipe);
134 declare
135 Names : constant Asis.Defining_Name_List :=
136 Asis.Declarations.Names (Decl);
137 begin
138 Result.Append
139 (League.Strings.From_UTF_16_Wide_String
140 (Asis.Declarations.Defining_Name_Image
141 (Names (Names'First))));
142 end;
143 end if;
144 end if;
145 else
146 Unit := Asis.Elements.Enclosing_Compilation_Unit (Def);
147 Result.Append
148 (League.Strings.From_UTF_16_Wide_String
149 (Asis.Compilation_Units.Unit_Full_Name (Unit)));
150 Span := Asis.Text.Element_Span (Def);
151 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
152 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
153 end if;
154
155 Result.Append (Wide_Wide_Character'Val (10));
156 end On_Identifier;
157
158 -------------
159 -- On_Unit --
160 -------------
161
162 procedure On_Unit (Unit : Asis.Compilation_Unit) is
163 Control : Asis.Traverse_Control := Asis.Continue;
164
165 Withs : constant Asis.Element_List :=
166 Asis.Elements.Context_Clause_Elements (Unit);
167 begin
168 for J in Withs'Range loop
169 case Asis.Elements.Clause_Kind (Withs (J)) is
170 when Asis.A_With_Clause | Asis.A_Use_Package_Clause =>
171 declare
172 Names : constant Asis.Element_List :=
173 Asis.Clauses.Clause_Names (Withs (J));
174 begin
175 for K in Names'Range loop
176 On_Element (Names (K));
177 end loop;
178 end;
179 when others =>
180 null;
181 end case;
182 end loop;
183
184 if Deep then
185 Iterate (Asis.Elements.Unit_Declaration (Unit), Control, Result);
186 end if;
187 end On_Unit;
188
189 -------------------
190 -- Pre_Operation --
191 -------------------
192
193 procedure Pre_Operation
194 (Element : in Asis.Element;
195 Control : in out Asis.Traverse_Control;
196 State : in out League.Strings.Universal_String)
197 is
198 pragma Unreferenced (Control);
199 pragma Unreferenced (State);
200 begin
201 On_Element (Element);
202 end Pre_Operation;
203
204 use type League.Hash_Type;
205
206 Args : League.String_Vectors.Universal_String_Vector;
207 Last_Arg : League.Strings.Universal_String;
208 Params : League.Strings.Universal_String;
209 Context : Asis.Context;
210 Hash : League.Hash_Type;
211begin
212 for J in 1 .. League.Application.Arguments.Length - 1 loop
213 Args.Append (League.Application.Arguments.Element (J));
214 end loop;
215
216 Last_Arg := League.Application.Arguments.Element
217 (League.Application.Arguments.Length);
218
219 Hash := League.Hash_Type'Wide_Wide_Value (Last_Arg.To_Wide_Wide_String);
220
221 Deep := Last_Arg.Starts_With ("+");
222
223 Params := Args.Join (' ');
224
225 Asis.Implementation.Initialize ("");
226
227 Asis.Ada_Environments.Associate
228 (The_Context => Context,
229 Name => Asis.Ada_Environments.Default_Name,
230 Parameters => Params.To_UTF_16_Wide_String);
231
232 Asis.Ada_Environments.Open (Context);
233
234 declare
235 Name : constant Wide_String := "/" &
236 Args.Element (Args.Length).To_UTF_16_Wide_String;
237 List : Asis.Compilation_Unit_List :=
238 Asis.Compilation_Units.Compilation_Units (Context);
239 begin
240 Sort (List);
241
242 for J in List'Range loop
243 if Name = Ada.Strings.Wide_Fixed.Tail
244 (Source => Asis.Compilation_Units.Text_Name (List (J)),
245 Count => Name'Length)
246 then
247 On_Unit (List (J));
248 end if;
249 end loop;
250 end;
251
252 Asis.Ada_Environments.Close (Context);
253 Asis.Ada_Environments.Dissociate (Context);
254 Asis.Implementation.Finalize ("");
255
256 if Hash /= Result.Hash then
257 Ada.Wide_Wide_Text_IO.Put
258 (League.Hash_Type'Wide_Wide_Image (Result.Hash));
259 Ada.Wide_Wide_Text_IO.Put_Line (" ");
260 Ada.Wide_Wide_Text_IO.Put_Line (Result.To_Wide_Wide_String);
261 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
262 end if;
263
264exception
265 when Asis.Exceptions.ASIS_Failed =>
266 Ada.Wide_Text_IO.Put_Line
267 ("ASIS_Failed status: " &
268 Asis.Errors.Error_Kinds'Wide_Image
269 (Asis.Implementation.Status));
270 Ada.Wide_Text_IO.Put_Line (Asis.Implementation.Diagnosis);
271 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
272end Def_Name;
Note: See TracBrowser for help on using the repository browser.