source: trunk/ada-2012/src/semantic/gela-profiles-names.adb@ 552

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

Add chosen_interpretation to an identifier

If an identifier is used as a function call (without parameters)
set its chosen_interpretation to function call and create an empty
parameter list.

Add next test to asis2xml test list.

  • Property svn:keywords set to Author Date Revision
File size: 10.6 KB
Line 
1with Gela.Compilations;
2with Gela.Element_Visiters;
3with Gela.Elements.Defining_Identifiers;
4with Gela.Elements.Function_Bodies;
5with Gela.Elements.Function_Declarations;
6with Gela.Elements.Parameter_Specifications;
7with Gela.Elements.Procedure_Bodies;
8with Gela.Elements.Procedure_Declarations;
9with Gela.Type_Managers;
10
11package body Gela.Profiles.Names is
12
13 -------------------------------
14 -- Allow_Empty_Argument_List --
15 -------------------------------
16
17 overriding function Allow_Empty_Argument_List
18 (Self : Profile) return Boolean is
19 begin
20 return Self.Empty;
21 end Allow_Empty_Argument_List;
22
23 ------------
24 -- Create --
25 ------------
26
27 function Create
28 (Env : Gela.Semantic_Types.Env_Index;
29 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
30 return Gela.Profiles.Profile'Class
31 is
32 package Get_Length is
33 type Visiter is new Gela.Element_Visiters.Visiter with record
34 Length : Natural := 0;
35 end record;
36
37 procedure Add
38 (Self : in out Visiter;
39 List : Gela.Elements.Parameter_Specifications.
40 Parameter_Specification_Sequence_Access);
41
42 overriding procedure Function_Body
43 (Self : in out Visiter;
44 Node : not null Gela.Elements.Function_Bodies.
45 Function_Body_Access);
46
47 overriding procedure Function_Declaration
48 (Self : in out Visiter;
49 Node : not null Gela.Elements.Function_Declarations.
50 Function_Declaration_Access);
51
52 overriding procedure Procedure_Body
53 (Self : in out Visiter;
54 Node : not null Gela.Elements.Procedure_Bodies.
55 Procedure_Body_Access);
56
57 overriding procedure Procedure_Declaration
58 (Self : in out Visiter;
59 Node : not null Gela.Elements.Procedure_Declarations.
60 Procedure_Declaration_Access);
61
62 end Get_Length;
63
64 package body Get_Length is
65
66 procedure Add
67 (Self : in out Visiter;
68 List : Gela.Elements.Parameter_Specifications.
69 Parameter_Specification_Sequence_Access)
70 is
71 Cursor : Gela.Elements.Parameter_Specifications.
72 Parameter_Specification_Sequence_Cursor := List.First;
73
74 begin
75 while Cursor.Has_Element loop
76 declare
77 Param : constant Gela.Elements.Parameter_Specifications.
78 Parameter_Specification_Access := Cursor.Element;
79 Names : constant Gela.Elements.Defining_Identifiers.
80 Defining_Identifier_Sequence_Access := Param.Names;
81 Pos : Gela.Elements.Defining_Identifiers.
82 Defining_Identifier_Sequence_Cursor := Names.First;
83 begin
84 if not Pos.Has_Element then
85 Self.Length := Self.Length + 1;
86 end if;
87
88 while Pos.Has_Element loop
89 Self.Length := Self.Length + 1;
90 Pos.Next;
91 end loop;
92
93 Cursor.Next;
94 end;
95 end loop;
96 end Add;
97
98 overriding procedure Function_Body
99 (Self : in out Visiter;
100 Node : not null Gela.Elements.Function_Bodies.
101 Function_Body_Access) is
102 begin
103 Self.Add (Node.Parameter_Profile);
104 end Function_Body;
105
106 overriding procedure Function_Declaration
107 (Self : in out Visiter;
108 Node : not null Gela.Elements.Function_Declarations.
109 Function_Declaration_Access) is
110 begin
111 Self.Add (Node.Parameter_Profile);
112 end Function_Declaration;
113
114 overriding procedure Procedure_Body
115 (Self : in out Visiter;
116 Node : not null Gela.Elements.Procedure_Bodies.
117 Procedure_Body_Access) is
118 begin
119 Self.Add (Node.Parameter_Profile);
120 end Procedure_Body;
121
122 overriding procedure Procedure_Declaration
123 (Self : in out Visiter;
124 Node : not null Gela.Elements.Procedure_Declarations.
125 Procedure_Declaration_Access) is
126 begin
127 Self.Add (Node.Parameter_Profile);
128 end Procedure_Declaration;
129
130 end Get_Length;
131
132 Comp : constant Gela.Compilations.Compilation_Access :=
133 Name.Enclosing_Compilation;
134
135 TM : constant Gela.Type_Managers.Type_Manager_Access :=
136 Comp.Context.Types;
137
138 package Get is
139 type Visiter is new Gela.Element_Visiters.Visiter with record
140 Result : access Profile;
141 Index : Natural := 0;
142 end record;
143
144 procedure Add
145 (Self : in out Visiter;
146 List : Gela.Elements.Parameter_Specifications.
147 Parameter_Specification_Sequence_Access);
148
149 overriding procedure Function_Body
150 (Self : in out Visiter;
151 Node : not null Gela.Elements.Function_Bodies.
152 Function_Body_Access);
153
154 overriding procedure Function_Declaration
155 (Self : in out Visiter;
156 Node : not null Gela.Elements.Function_Declarations.
157 Function_Declaration_Access);
158
159 overriding procedure Procedure_Body
160 (Self : in out Visiter;
161 Node : not null Gela.Elements.Procedure_Bodies.
162 Procedure_Body_Access);
163
164 overriding procedure Procedure_Declaration
165 (Self : in out Visiter;
166 Node : not null Gela.Elements.Procedure_Declarations.
167 Procedure_Declaration_Access);
168 end Get;
169
170 package body Get is
171
172 procedure Add
173 (Self : in out Visiter;
174 List : Gela.Elements.Parameter_Specifications.
175 Parameter_Specification_Sequence_Access)
176 is
177 Cursor : Gela.Elements.Parameter_Specifications.
178 Parameter_Specification_Sequence_Cursor := List.First;
179 begin
180 while Cursor.Has_Element loop
181 declare
182 Name : Gela.Elements.Defining_Identifiers.
183 Defining_Identifier_Access;
184 Param : constant Gela.Elements.Parameter_Specifications.
185 Parameter_Specification_Access := Cursor.Element;
186 Tipe : constant Gela.Semantic_Types.Type_Index :=
187 TM.Type_Of_Object_Declaration
188 (Env, Gela.Elements.Element_Access (Param));
189 Names : constant Gela.Elements.Defining_Identifiers.
190 Defining_Identifier_Sequence_Access := Param.Names;
191 Pos : Gela.Elements.Defining_Identifiers.
192 Defining_Identifier_Sequence_Cursor := Names.First;
193 begin
194 if not Pos.Has_Element then
195 Self.Index := Self.Index + 1;
196 Self.Result.Params (Self.Index).Tipe := Tipe;
197 end if;
198
199 while Pos.Has_Element loop
200 Name := Pos.Element;
201 Self.Index := Self.Index + 1;
202 Self.Result.Params (Self.Index).Name :=
203 Gela.Elements.Defining_Names.Defining_Name_Access
204 (Name);
205 Self.Result.Params (Self.Index).Tipe := Tipe;
206
207 Pos.Next;
208 end loop;
209
210 Cursor.Next;
211 end;
212 end loop;
213 end Add;
214
215 overriding procedure Function_Body
216 (Self : in out Visiter;
217 Node : not null Gela.Elements.Function_Bodies.
218 Function_Body_Access) is
219 begin
220 Self.Add (Node.Parameter_Profile);
221
222 Self.Result.Funct := True;
223 Self.Result.Result :=
224 TM.Type_From_Subtype_Mark (Env, Node.Result_Subtype);
225 end Function_Body;
226
227 overriding procedure Function_Declaration
228 (Self : in out Visiter;
229 Node : not null Gela.Elements.Function_Declarations.
230 Function_Declaration_Access) is
231 begin
232 Self.Add (Node.Parameter_Profile);
233
234 Self.Result.Funct := True;
235 Self.Result.Result :=
236 TM.Type_From_Subtype_Mark (Env, Node.Result_Subtype);
237 end Function_Declaration;
238
239 overriding procedure Procedure_Body
240 (Self : in out Visiter;
241 Node : not null Gela.Elements.Procedure_Bodies.
242 Procedure_Body_Access) is
243 begin
244 Self.Add (Node.Parameter_Profile);
245 end Procedure_Body;
246
247 overriding procedure Procedure_Declaration
248 (Self : in out Visiter;
249 Node : not null Gela.Elements.Procedure_Declarations.
250 Procedure_Declaration_Access) is
251 begin
252 Self.Add (Node.Parameter_Profile);
253 end Procedure_Declaration;
254
255 end Get;
256
257 VL : Get_Length.Visiter;
258
259 begin
260 Name.Enclosing_Element.Visit (VL);
261
262 return Result : aliased Profile (VL.Length) do
263 declare
264 V : Get.Visiter;
265 begin
266 Result.Name := Name;
267 V.Result := Result'Unchecked_Access;
268 Name.Enclosing_Element.Visit (V);
269 Result.Empty := (VL.Length = 0); -- FIXME
270 end;
271 end return;
272 end Create;
273
274 -----------------
275 -- Is_Function --
276 -----------------
277
278 overriding function Is_Function (Self : Profile) return Boolean is
279 begin
280 return Self.Funct;
281 end Is_Function;
282
283 ------------
284 -- Length --
285 ------------
286
287 overriding function Length (Self : Profile) return Natural is
288 begin
289 return Self.Length;
290 end Length;
291
292 -----------------
293 -- Return_Type --
294 -----------------
295
296 overriding function Return_Type
297 (Self : Profile) return Gela.Semantic_Types.Type_Index is
298 begin
299 return Self.Result;
300 end Return_Type;
301
302 --------------
303 -- Get_Type --
304 --------------
305
306 overriding function Get_Type
307 (Self : Profile;
308 Index : Positive)
309 return Gela.Semantic_Types.Type_Index is
310 begin
311 return Self.Params (Index).Tipe;
312 end Get_Type;
313
314 --------------
315 -- Get_Name --
316 --------------
317
318 overriding function Get_Name
319 (Self : Profile;
320 Index : Positive)
321 return Gela.Elements.Defining_Names.Defining_Name_Access is
322 begin
323 return Self.Params (Index).Name;
324 end Get_Name;
325
326 ---------------
327 -- Get_Index --
328 ---------------
329
330 overriding function Get_Index
331 (Self : Profile;
332 Symbol : Gela.Lexical_Types.Symbol)
333 return Natural
334 is
335 begin
336 raise Constraint_Error with "Unimplemented function Get_Index";
337 return 0;
338 end Get_Index;
339
340end Gela.Profiles.Names;
Note: See TracBrowser for help on using the repository browser.