source: trunk/ada-2012/src/semantic/gela-plain_interpretations.adb@ 363

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

Express function_call overload resolution rules

New type of interpretation required for this: Tuple.
This interpretation used to gather interpretations of parameter_associations.
Tuples connect sets of interpretations of each param together.
Then we iterate over them and choose matched for function prefix.
Chosen interpretation them get index by call Get_Tuple_Index function.
This function return linked structure of tuples suitable to unwind
during traverse parameter_associations when propagating Down attribute.

File size: 13.7 KB
Line 
1with Gela.Int.Attr_Functions;
2with Gela.Int.Defining_Names;
3with Gela.Int.Expressions;
4with Gela.Int.Visiters;
5with Gela.Int.Tuples;
6
7package body Gela.Plain_Interpretations is
8
9 package Empty_Cursors is
10 type Cursor is new Gela.Interpretations.Cursor with null record;
11
12 overriding function Has_Element (Self : Cursor) return Boolean;
13
14 overriding procedure Next (Self : in out Cursor) is null;
15
16 overriding procedure Visit
17 (Self : Cursor;
18 Target : access Gela.Interpretations.Visiter'Class) is null;
19
20 overriding function Get_Index
21 (Self : Cursor) return Gela.Interpretations.Interpretation_Index;
22
23 end Empty_Cursors;
24
25 package body Empty_Cursors is
26
27 overriding function Has_Element (Self : Cursor) return Boolean is
28 pragma Unreferenced (Self);
29 begin
30 return False;
31 end Has_Element;
32
33 overriding function Get_Index
34 (Self : Cursor) return Gela.Interpretations.Interpretation_Index
35 is
36 pragma Unreferenced (Self);
37 begin
38 return 0;
39 end Get_Index;
40
41 end Empty_Cursors;
42
43 -----------------------
44 -- Add_Attr_Function --
45 -----------------------
46
47 overriding procedure Add_Attr_Function
48 (Self : in out Interpretation_Manager;
49 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
50 Down : Gela.Interpretations.Interpretation_Index_Array;
51 Result : in out Gela.Interpretations.Interpretation_Set_Index)
52 is
53 Item : constant Gela.Int.Interpretation_Access :=
54 new Gela.Int.Attr_Functions.Attr_Function'
55 (Gela.Int.Attr_Functions.Create
56 (Down => Down,
57 Kind => Kind));
58 begin
59 Self.Plian_Int_Set.Add (Result, Item);
60 end Add_Attr_Function;
61
62 -----------------------
63 -- Add_Defining_Name --
64 -----------------------
65
66 overriding procedure Add_Defining_Name
67 (Self : in out Interpretation_Manager;
68 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
69 Down : Gela.Interpretations.Interpretation_Index_Array;
70 Result : in out Gela.Interpretations.Interpretation_Set_Index)
71 is
72 Item : constant Gela.Int.Interpretation_Access :=
73 new Gela.Int.Defining_Names.Defining_Name'
74 (Gela.Int.Defining_Names.Create
75 (Down => Down,
76 Name => Name));
77 begin
78 Self.Plian_Int_Set.Add (Result, Item);
79 end Add_Defining_Name;
80
81 --------------------
82 -- Add_Expression --
83 --------------------
84
85 overriding procedure Add_Expression
86 (Self : in out Interpretation_Manager;
87 Tipe : Gela.Semantic_Types.Type_Index;
88 Down : Gela.Interpretations.Interpretation_Index_Array;
89 Result : in out Gela.Interpretations.Interpretation_Set_Index)
90 is
91 Item : constant Gela.Int.Interpretation_Access :=
92 new Gela.Int.Expressions.Expression'
93 (Gela.Int.Expressions.Create
94 (Down => Down,
95 Expression_Type => Tipe));
96 begin
97 Self.Plian_Int_Set.Add (Result, Item);
98 end Add_Expression;
99
100 ---------------
101 -- Add_Tuple --
102 ---------------
103
104 overriding procedure Add_Tuple
105 (Self : in out Interpretation_Manager;
106 Left : Gela.Interpretations.Interpretation_Set_Index;
107 Right : Gela.Interpretations.Interpretation_Set_Index;
108 Result : in out Gela.Interpretations.Interpretation_Set_Index)
109 is
110 package Each is
111 type Visiter is new Gela.Interpretations.Visiter with null record;
112 -- Only tuples are expected here
113
114 overriding procedure On_Defining_Name
115 (Self : in out Visiter;
116 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
117 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
118
119 overriding procedure On_Expression
120 (Self : in out Visiter;
121 Tipe : Gela.Semantic_Types.Type_Index;
122 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
123
124 overriding procedure On_Attr_Function
125 (Self : in out Visiter;
126 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
127 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
128
129 overriding procedure On_Tuple
130 (V : in out Visiter;
131 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
132 Down : Gela.Interpretations.Interpretation_Index_Array);
133
134 end Each;
135
136 package body Each is
137
138 overriding procedure On_Tuple
139 (V : in out Visiter;
140 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
141 Down : Gela.Interpretations.Interpretation_Index_Array)
142 is
143 pragma Unreferenced (V, Down);
144 use type Gela.Interpretations.Interpretation_Set_Index_Array;
145
146 Item : constant Gela.Int.Interpretation_Access :=
147 new Gela.Int.Tuples.Tuple'
148 (Gela.Int.Tuples.Create (Left & Value));
149 begin
150 Self.Plian_Int_Set.Add (Result, Item);
151 end On_Tuple;
152
153 end Each;
154
155 Item : Gela.Int.Interpretation_Access;
156 V : aliased Each.Visiter;
157 begin
158 if Right = 0 then
159 Item := new Gela.Int.Tuples.Tuple'
160 (Gela.Int.Tuples.Create (Value => (1 => Left)));
161
162 Self.Plian_Int_Set.Add (Result, Item);
163 else
164 declare
165 Cursor : Gela.Interpretations.Cursor'Class :=
166 Self.Get_Cursor (Right);
167 begin
168 while Cursor.Has_Element loop
169 Cursor.Visit (V'Access);
170 Cursor.Next;
171 end loop;
172 end;
173 end if;
174 end Add_Tuple;
175
176 -----------------------
177 -- Get_Defining_Name --
178 -----------------------
179
180 overriding procedure Get_Defining_Name
181 (Self : in out Interpretation_Manager;
182 Value : Gela.Interpretations.Interpretation_Index;
183 Result : out Gela.Elements.Defining_Names.Defining_Name_Access)
184 is
185 package Each is
186 type Visiter is new Gela.Interpretations.Visiter with record
187 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
188 end record;
189
190 overriding procedure On_Defining_Name
191 (Self : in out Visiter;
192 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
193 Down : Gela.Interpretations.Interpretation_Index_Array);
194
195 overriding procedure On_Expression
196 (Self : in out Visiter;
197 Tipe : Gela.Semantic_Types.Type_Index;
198 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
199
200 overriding procedure On_Attr_Function
201 (Self : in out Visiter;
202 Tipe : Gela.Lexical_Types.Predefined_Symbols.Attribute;
203 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
204
205 overriding procedure On_Tuple
206 (Self : in out Visiter;
207 Value : Gela.Interpretations.Interpretation_Set_Index_Array;
208 Down : Gela.Interpretations.Interpretation_Index_Array)
209 is null;
210 end Each;
211
212 ----------
213 -- Each --
214 ----------
215
216 package body Each is
217
218 overriding procedure On_Defining_Name
219 (Self : in out Visiter;
220 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
221 Down : Gela.Interpretations.Interpretation_Index_Array)
222 is
223 pragma Unreferenced (Down);
224 begin
225 Self.Name := Name;
226 end On_Defining_Name;
227
228 end Each;
229
230 Visiter : Each.Visiter;
231 begin
232 Self.Visit (Value, Visiter);
233 Result := Visiter.Name;
234 end Get_Defining_Name;
235
236 -----------------------------
237 -- Get_Down_Interpretation --
238 -----------------------------
239
240 overriding procedure Get_Down_Interpretation
241 (Self : in out Interpretation_Manager;
242 Value : Gela.Interpretations.Interpretation_Index;
243 Index : Positive;
244 Result : out Gela.Interpretations.Interpretation_Index)
245 is
246 Item : Gela.Int.Interpretation_Access;
247 begin
248 Result := 0;
249
250 if Value = 0 then
251 return;
252 end if;
253
254 Item := Self.Item_Batches.Element (Value / Batch_Size).Element (Value);
255
256 if Index in Item.Down'Range then
257 Result := Item.Down (Index);
258 end if;
259 end Get_Down_Interpretation;
260
261 ----------------
262 -- Get_Cursor --
263 ----------------
264
265 overriding function Get_Cursor
266 (Self : in out Interpretation_Manager;
267 Set : Gela.Interpretations.Interpretation_Set_Index)
268 return Gela.Interpretations.Cursor'Class is
269 begin
270 if Set = 0 then
271 return None : Empty_Cursors.Cursor;
272 else
273 return Self.Set_Batches.Element (Set / Batch_Size).Get_Cursor (Set);
274 end if;
275 end Get_Cursor;
276
277 ---------------------
278 -- Get_Tuple_Index --
279 ---------------------
280
281 overriding procedure Get_Tuple_Index
282 (Self : in out Interpretation_Manager;
283 Left : Gela.Interpretations.Interpretation_Index;
284 Right : Gela.Interpretations.Interpretation_Index;
285 Result : out Gela.Interpretations.Interpretation_Index)
286 is
287 use type Gela.Interpretations.Interpretation_Index_Array;
288
289 Item : constant Gela.Int.Interpretation_Access :=
290 new Gela.Int.Tuples.Chosen_Tuple'
291 (Length => 2, Index => 0, Down => Left & Right);
292 begin
293 Self.Plian_Int_Set.Add (Result, Item);
294 end Get_Tuple_Index;
295
296 ---------------------
297 -- Reserve_Indexes --
298 ---------------------
299
300 overriding procedure Reserve_Indexes
301 (Self : in out Interpretation_Manager;
302 Set : Gela.Int_Sets.Interpretation_Set_Access;
303 From : out Gela.Interpretations.Interpretation_Set_Index;
304 To : out Gela.Interpretations.Interpretation_Set_Index) is
305 begin
306 Self.Set_Batches.Append (Set);
307 From := Self.Set_Batches.Last_Index * Batch_Size;
308 To := From + Batch_Size - 1;
309 From := Gela.Interpretations.Interpretation_Set_Index'Max (1, From);
310 end Reserve_Indexes;
311
312 ---------------------
313 -- Reserve_Indexes --
314 ---------------------
315
316 overriding procedure Reserve_Indexes
317 (Self : in out Interpretation_Manager;
318 Set : Gela.Int_Sets.Interpretation_Set_Access;
319 From : out Gela.Interpretations.Interpretation_Index;
320 To : out Gela.Interpretations.Interpretation_Index) is
321 begin
322 Self.Item_Batches.Append (Set);
323 From := Self.Item_Batches.Last_Index * Batch_Size;
324 To := From + Batch_Size - 1;
325 From := Gela.Interpretations.Interpretation_Index'Max (1, From);
326 end Reserve_Indexes;
327
328 -----------
329 -- Visit --
330 -----------
331
332 overriding procedure Visit
333 (Self : in out Interpretation_Manager;
334 Index : Gela.Interpretations.Interpretation_Index;
335 Target : in out Gela.Interpretations.Visiter'Class)
336 is
337 package Switch is
338 type Visiter is new Gela.Int.Visiters.Visiter with null record;
339
340 overriding procedure Defining_Name
341 (Self : access Visiter;
342 Value : Gela.Int.Defining_Names.Defining_Name);
343
344 overriding procedure Expression
345 (Self : access Visiter;
346 Value : Gela.Int.Expressions.Expression);
347
348 overriding procedure Attr_Function
349 (Self : access Visiter;
350 Value : Gela.Int.Attr_Functions.Attr_Function);
351
352 overriding procedure Tuple
353 (Self : access Visiter;
354 Value : Gela.Int.Tuples.Tuple);
355
356 overriding procedure Chosen_Tuple
357 (Self : access Visiter;
358 Value : Gela.Int.Tuples.Chosen_Tuple);
359
360 end Switch;
361
362 ------------
363 -- Switch --
364 ------------
365
366 package body Switch is
367
368 -------------------
369 -- Attr_Function --
370 -------------------
371
372 overriding procedure Attr_Function
373 (Self : access Visiter;
374 Value : Gela.Int.Attr_Functions.Attr_Function)
375 is
376 pragma Unreferenced (Self);
377 begin
378 Target.On_Attr_Function
379 (Kind => Value.Kind,
380 Down => Value.Down);
381 end Attr_Function;
382
383 -------------------
384 -- Defining_Name --
385 -------------------
386
387 overriding procedure Defining_Name
388 (Self : access Visiter;
389 Value : Gela.Int.Defining_Names.Defining_Name)
390 is
391 pragma Unreferenced (Self);
392 begin
393 Target.On_Defining_Name
394 (Name => Value.Name,
395 Down => Value.Down);
396 end Defining_Name;
397
398 ----------------
399 -- Expression --
400 ----------------
401
402 overriding procedure Expression
403 (Self : access Visiter;
404 Value : Gela.Int.Expressions.Expression)
405 is
406 pragma Unreferenced (Self);
407 begin
408 Target.On_Expression
409 (Tipe => Value.Expression_Type,
410 Down => Value.Down);
411 end Expression;
412
413 -----------
414 -- Tuple --
415 -----------
416
417 overriding procedure Tuple
418 (Self : access Visiter;
419 Value : Gela.Int.Tuples.Tuple)
420 is
421 pragma Unreferenced (Self);
422 begin
423 Target.On_Tuple (Value.Value, (1 .. 0 => 0));
424 end Tuple;
425
426 ------------------
427 -- Chosen_Tuple --
428 ------------------
429
430 overriding procedure Chosen_Tuple
431 (Self : access Visiter;
432 Value : Gela.Int.Tuples.Chosen_Tuple)
433 is
434 pragma Unreferenced (Self);
435 begin
436 Target.On_Tuple ((1 .. 0 => 0), Value.Down);
437 end Chosen_Tuple;
438
439 end Switch;
440
441 V : aliased Switch.Visiter;
442 begin
443 if Index /= 0 then
444 Self.Item_Batches.Element (Index / Batch_Size).Element (Index).Visit
445 (V'Access);
446 end if;
447 end Visit;
448
449end Gela.Plain_Interpretations;
Note: See TracBrowser for help on using the repository browser.