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

Last change on this file since 355 was 355, checked in by Maxim Reznik, 6 years ago

Sort compilation unit to be more stable

File size: 5.7 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.Elements;
12with Asis.Errors;
13with Asis.Exceptions;
14with Asis.Expressions;
15with Asis.Implementation;
16with Asis.Text;
17
18with League.Application;
19with League.Strings;
20with League.String_Vectors;
21
22procedure Def_Name is
23 procedure On_Unit (Unit : Asis.Compilation_Unit);
24 procedure On_Identifier (Item : Asis.Identifier);
25
26 function Less (Left, Right : Asis.Compilation_Unit) return Boolean;
27
28 procedure Sort is new Ada.Containers.Generic_Array_Sort
29 (Index_Type => Asis.List_Index,
30 Element_Type => Asis.Compilation_Unit,
31 Array_Type => Asis.Compilation_Unit_List,
32 "<" => Less);
33
34 Result : League.Strings.Universal_String;
35
36 ----------
37 -- Less --
38 ----------
39
40 function Less (Left, Right : Asis.Compilation_Unit) return Boolean is
41 use type Asis.Text.Line_Number;
42
43 Left_Line : constant Asis.Text.Line_Number :=
44 Asis.Text.First_Line_Number (Asis.Elements.Unit_Declaration (Left));
45 Right_Line : constant Asis.Text.Line_Number :=
46 Asis.Text.First_Line_Number (Asis.Elements.Unit_Declaration (Right));
47 Left_Name : constant Asis.Program_Text :=
48 Asis.Compilation_Units.Text_Name (Left);
49 Right_Name : constant Asis.Program_Text :=
50 Asis.Compilation_Units.Text_Name (Right);
51 begin
52 if Left_Name = Right_Name then
53 return Left_Line < Right_Line;
54 else
55 return Left_Name < Right_Name;
56 end if;
57 end Less;
58
59 -------------------
60 -- On_Identifier --
61 -------------------
62
63 procedure On_Identifier (Item : Asis.Identifier) is
64 Span : Asis.Text.Span;
65 Def : constant Asis.Defining_Name :=
66 Asis.Expressions.Corresponding_Name_Definition (Item);
67 begin
68 Result.Append
69 (League.Strings.From_UTF_16_Wide_String
70 (Asis.Expressions.Name_Image (Item)));
71
72 Span := Asis.Text.Element_Span (Item);
73 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
74 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
75 Span := Asis.Text.Element_Span (Def);
76 Result.Append (" =>");
77 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Line));
78 Result.Append (Asis.ASIS_Natural'Wide_Wide_Image (Span.First_Column));
79 Result.Append (Wide_Wide_Character'Val (10));
80 end On_Identifier;
81
82 -------------
83 -- On_Unit --
84 -------------
85
86 procedure On_Unit (Unit : Asis.Compilation_Unit) is
87 Withs : constant Asis.Element_List :=
88 Asis.Elements.Context_Clause_Elements (Unit);
89 begin
90 for J in Withs'Range loop
91 case Asis.Elements.Clause_Kind (Withs (J)) is
92 when Asis.A_With_Clause =>
93 declare
94 Names : constant Asis.Element_List :=
95 Asis.Clauses.Clause_Names (Withs (J));
96 begin
97 for K in Names'Range loop
98 case Asis.Elements.Expression_Kind (Names (K)) is
99 when Asis.An_Identifier =>
100 On_Identifier (Names (K));
101 when Asis.A_Selected_Component =>
102 On_Identifier
103 (Asis.Expressions.Selector (Names (K)));
104 when others =>
105 null;
106 end case;
107 end loop;
108 end;
109 when others =>
110 null;
111 end case;
112 end loop;
113 end On_Unit;
114
115 use type League.Hash_Type;
116
117 Args : League.String_Vectors.Universal_String_Vector;
118 Params : League.Strings.Universal_String;
119 Context : Asis.Context;
120 Hash : League.Hash_Type;
121begin
122 for J in 1 .. League.Application.Arguments.Length - 1 loop
123 Args.Append (League.Application.Arguments.Element (J));
124 end loop;
125
126 Hash := League.Hash_Type'Wide_Wide_Value
127 (League.Application.Arguments.Element
128 (League.Application.Arguments.Length).To_Wide_Wide_String);
129
130 Params := Args.Join (' ');
131
132 Asis.Implementation.Initialize ("");
133
134 Asis.Ada_Environments.Associate
135 (The_Context => Context,
136 Name => Asis.Ada_Environments.Default_Name,
137 Parameters => Params.To_UTF_16_Wide_String);
138
139 Asis.Ada_Environments.Open (Context);
140
141 declare
142 Name : constant Wide_String := "/" &
143 Args.Element (Args.Length).To_UTF_16_Wide_String;
144 List : Asis.Compilation_Unit_List :=
145 Asis.Compilation_Units.Compilation_Units (Context);
146 begin
147 Sort (List);
148
149 for J in List'Range loop
150 if Name = Ada.Strings.Wide_Fixed.Tail
151 (Source => Asis.Compilation_Units.Text_Name (List (J)),
152 Count => Name'Length)
153 then
154 On_Unit (List (J));
155 end if;
156 end loop;
157 end;
158
159 Asis.Ada_Environments.Close (Context);
160 Asis.Ada_Environments.Dissociate (Context);
161 Asis.Implementation.Finalize ("");
162
163 if Hash /= Result.Hash then
164 Ada.Wide_Wide_Text_IO.Put
165 (League.Hash_Type'Wide_Wide_Image (Result.Hash));
166 Ada.Wide_Wide_Text_IO.Put_Line (" ");
167 Ada.Wide_Wide_Text_IO.Put_Line (Result.To_Wide_Wide_String);
168 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
169 end if;
170
171exception
172 when Asis.Exceptions.ASIS_Failed =>
173 Ada.Wide_Text_IO.Put_Line
174 ("ASIS_Failed status: " &
175 Asis.Errors.Error_Kinds'Wide_Image
176 (Asis.Implementation.Status));
177 Ada.Wide_Text_IO.Put_Line (Asis.Implementation.Diagnosis);
178 Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
179end Def_Name;
Note: See TracBrowser for help on using the repository browser.