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

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

Drop Cursor and Visiter for up interpretation set.

Replace it with Any_Cursor and iterator.

  • Property svn:keywords set to Author Date Revision
File size: 19.6 KB
Line 
1with Gela.Int.Attr_Functions;
2with Gela.Int.Categories;
3with Gela.Int.Defining_Names;
4with Gela.Int.Expressions;
5with Gela.Int.Placeholders;
6with Gela.Int.Symbols;
7with Gela.Int.Tuples;
8with Gela.Int.Visiters;
9
10package body Gela.Plain_Interpretations is
11
12 -----------------------
13 -- Add_Attr_Function --
14 -----------------------
15
16 overriding procedure Add_Attr_Function
17 (Self : in out Interpretation_Manager;
18 Tipe : Gela.Semantic_Types.Type_Index;
19 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
20 Down : Gela.Interpretations.Interpretation_Index_Array;
21 Result : in out Gela.Interpretations.Interpretation_Set_Index)
22 is
23 Item : constant Gela.Int.Interpretation_Access :=
24 new Gela.Int.Attr_Functions.Attr_Function'
25 (Gela.Int.Attr_Functions.Create
26 (Down => Down,
27 Tipe => Tipe,
28 Kind => Kind));
29 begin
30 Self.Plain_Int_Set.Add (Result, Item);
31 end Add_Attr_Function;
32
33 -----------------------
34 -- Add_Defining_Name --
35 -----------------------
36
37 overriding procedure Add_Defining_Name
38 (Self : in out Interpretation_Manager;
39 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
40 Down : Gela.Interpretations.Interpretation_Index_Array;
41 Result : in out Gela.Interpretations.Interpretation_Set_Index)
42 is
43 Item : constant Gela.Int.Interpretation_Access :=
44 new Gela.Int.Defining_Names.Defining_Name'
45 (Gela.Int.Defining_Names.Create
46 (Down => Down,
47 Name => Name));
48 begin
49 Self.Plain_Int_Set.Add (Result, Item);
50 end Add_Defining_Name;
51
52 --------------------
53 -- Add_Expression --
54 --------------------
55
56 overriding procedure Add_Expression
57 (Self : in out Interpretation_Manager;
58 Tipe : Gela.Semantic_Types.Type_Index;
59 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds :=
60 Gela.Interpretations.Unknown;
61 Down : Gela.Interpretations.Interpretation_Index_Array;
62 Result : in out Gela.Interpretations.Interpretation_Set_Index)
63 is
64 Item : constant Gela.Int.Interpretation_Access :=
65 new Gela.Int.Expressions.Expression'
66 (Gela.Int.Expressions.Create
67 (Down => Down,
68 Expression_Type => Tipe,
69 Expression_Kind => Kind));
70 begin
71 Self.Plain_Int_Set.Add (Result, Item);
72 end Add_Expression;
73
74 -----------------------------
75 -- Add_Expression_Category --
76 -----------------------------
77
78 overriding procedure Add_Expression_Category
79 (Self : in out Interpretation_Manager;
80 Match : not null Gela.Interpretations.Type_Matcher_Access;
81 Down : Gela.Interpretations.Interpretation_Index_Array;
82 Result : in out Gela.Interpretations.Interpretation_Set_Index)
83 is
84 Item : constant Gela.Int.Interpretation_Access :=
85 new Gela.Int.Categories.Category'
86 (Gela.Int.Categories.Create
87 (Down => Down,
88 Match => Match));
89 begin
90 Self.Plain_Int_Set.Add (Result, Item);
91 end Add_Expression_Category;
92
93 ---------------------
94 -- Add_Placeholder --
95 ---------------------
96
97 overriding procedure Add_Placeholder
98 (Self : in out Interpretation_Manager;
99 Kind : Gela.Interpretations.Placeholder_Kind;
100 Result : in out Gela.Interpretations.Interpretation_Set_Index)
101 is
102 Item : constant Gela.Int.Interpretation_Access :=
103 new Gela.Int.Placeholders.Placeholder'
104 (Gela.Int.Placeholders.Create
105 (Down => (1 .. 0 => 0),
106 Kind => Kind));
107 begin
108 Self.Plain_Int_Set.Add (Result, Item);
109 end Add_Placeholder;
110
111 ----------------
112 -- Add_Symbol --
113 ----------------
114
115 overriding procedure Add_Symbol
116 (Self : in out Interpretation_Manager;
117 Symbol : Gela.Lexical_Types.Symbol;
118 Result : in out Gela.Interpretations.Interpretation_Set_Index)
119 is
120 Item : constant Gela.Int.Interpretation_Access :=
121 new Gela.Int.Symbols.Symbol'
122 (Gela.Int.Symbols.Create
123 (Down => (1 .. 0 => 0),
124 Value => Symbol));
125 begin
126 Self.Plain_Int_Set.Add (Result, Item);
127 end Add_Symbol;
128
129 ---------------
130 -- Add_Tuple --
131 ---------------
132
133 overriding procedure Add_Tuple
134 (Self : in out Interpretation_Manager;
135 Left : Gela.Interpretations.Interpretation_Set_Index;
136 Right : Gela.Interpretations.Interpretation_Tuple_Index;
137 Result : out Gela.Interpretations.Interpretation_Tuple_Index)
138 is
139 use type Gela.Interpretations.Interpretation_Tuple_Index;
140 use type Gela.Interpretations.Interpretation_Set_Index_Array;
141
142 Value : Gela.Interpretations.Interpretation_Index;
143 Item : Gela.Int.Interpretation_Access;
144 begin
145 if Right = 0 then
146 Item := new Gela.Int.Tuples.Tuple'
147 (Gela.Int.Tuples.Create (Value => (1 => Left)));
148
149 else
150 declare
151 List : constant Gela.Interpretations.Interpretation_Set_Index_Array
152 := Left & Self.Get_Tuple (Right);
153 begin
154 Item := new Gela.Int.Tuples.Tuple'
155 (Gela.Int.Tuples.Create (Value => List));
156 end;
157 end if;
158
159 Self.Plain_Int_Set.Add (Value, Item);
160
161 Result := Gela.Interpretations.Interpretation_Tuple_Index (Value);
162 end Add_Tuple;
163
164 --------------------
165 -- Add_Tuple_List --
166 --------------------
167
168 overriding procedure Add_Tuple_List
169 (Self : in out Interpretation_Manager;
170 Left : Gela.Interpretations.Interpretation_Tuple_Index;
171 Right : Gela.Interpretations.Interpretation_Tuple_List_Index;
172 Result : out Gela.Interpretations.Interpretation_Tuple_List_Index)
173 is
174 begin
175 Self.Add_Tuple
176 (Left => Gela.Interpretations.Interpretation_Set_Index (Left),
177 Right => Gela.Interpretations.Interpretation_Tuple_Index (Right),
178 Result => Gela.Interpretations.Interpretation_Tuple_Index (Result));
179 end Add_Tuple_List;
180
181 -----------------------
182 -- Get_Defining_Name --
183 -----------------------
184
185 overriding procedure Get_Defining_Name
186 (Self : in out Interpretation_Manager;
187 Value : Gela.Interpretations.Interpretation_Index;
188 Result : out Gela.Elements.Defining_Names.Defining_Name_Access)
189 is
190 package Each is
191 type Visiter is new Gela.Interpretations.Down_Visiter with record
192 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
193 end record;
194
195 overriding procedure On_Defining_Name
196 (Self : in out Visiter;
197 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
198 Down : Gela.Interpretations.Interpretation_Index_Array);
199
200 end Each;
201
202 ----------
203 -- Each --
204 ----------
205
206 package body Each is
207
208 overriding procedure On_Defining_Name
209 (Self : in out Visiter;
210 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
211 Down : Gela.Interpretations.Interpretation_Index_Array)
212 is
213 pragma Unreferenced (Down);
214 begin
215 Self.Name := Name;
216 end On_Defining_Name;
217
218 end Each;
219
220 Visiter : Each.Visiter;
221 begin
222 Self.Visit (Value, Visiter);
223 Result := Visiter.Name;
224 end Get_Defining_Name;
225
226 -----------------------------
227 -- Get_Down_Interpretation --
228 -----------------------------
229
230 overriding procedure Get_Down_Interpretation
231 (Self : in out Interpretation_Manager;
232 Value : Gela.Interpretations.Interpretation_Index;
233 Index : Positive;
234 Result : out Gela.Interpretations.Interpretation_Index)
235 is
236 Item : Gela.Int.Interpretation_Access;
237 begin
238 Result := 0;
239
240 if Value = 0 then
241 return;
242 end if;
243
244 Item := Self.Item_Batches.Element (Value / Batch_Size).Element (Value);
245
246 if Index in Item.Down'Range then
247 Result := Item.Down (Index);
248 end if;
249 end Get_Down_Interpretation;
250
251 ----------------
252 -- Categories --
253 ----------------
254
255 overriding function Categories
256 (Self : in out Interpretation_Manager;
257 Set : Gela.Interpretations.Interpretation_Set_Index)
258 return Gela.Interpretations.Category_Iterators
259 .Forward_Iterator'Class is
260 begin
261 return Self.Set_Batches.Element (Set / Batch_Size).Categories (Set);
262 end Categories;
263
264 --------------------
265 -- Defining_Names --
266 --------------------
267
268 overriding function Defining_Names
269 (Self : in out Interpretation_Manager;
270 Set : Gela.Interpretations.Interpretation_Set_Index)
271 return Gela.Interpretations.Defining_Name_Iterators
272 .Forward_Iterator'Class is
273 begin
274 return Self.Set_Batches.Element (Set / Batch_Size).Defining_Names (Set);
275 end Defining_Names;
276
277 ----------
278 -- Each --
279 ----------
280
281 overriding function Each
282 (Self : in out Interpretation_Manager;
283 Set : Gela.Interpretations.Interpretation_Set_Index)
284 return Gela.Interpretations.Any_Iterators
285 .Forward_Iterator'Class is
286 begin
287 return Self.Set_Batches.Element (Set / Batch_Size).Each (Set);
288 end Each;
289
290 -----------------
291 -- Expressions --
292 -----------------
293
294 overriding function Expressions
295 (Self : in out Interpretation_Manager;
296 Set : Gela.Interpretations.Interpretation_Set_Index)
297 return Gela.Interpretations.Expression_Iterators
298 .Forward_Iterator'Class is
299 begin
300 return Self.Set_Batches.Element (Set / Batch_Size).Expressions (Set);
301 end Expressions;
302
303 -----------------------------
304 -- Get_Defining_Name_Index --
305 -----------------------------
306
307 overriding procedure Get_Defining_Name_Index
308 (Self : in out Interpretation_Manager;
309 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
310 Result : out Gela.Interpretations.Interpretation_Index)
311 is
312 Item : constant Gela.Int.Interpretation_Access :=
313 new Gela.Int.Defining_Names.Defining_Name'
314 (Gela.Int.Defining_Names.Create
315 (Down => (1 .. 0 => 0), Name => Name));
316 begin
317 Self.Plain_Int_Set.Add (Result, Item);
318 end Get_Defining_Name_Index;
319
320 --------------------------
321 -- Get_Expression_Index --
322 --------------------------
323
324 overriding procedure Get_Expression_Index
325 (Self : in out Interpretation_Manager;
326 Tipe : Gela.Semantic_Types.Type_Index;
327 Result : out Gela.Interpretations.Interpretation_Index)
328 is
329 Item : constant Gela.Int.Interpretation_Access :=
330 new Gela.Int.Expressions.Expression'
331 (Gela.Int.Expressions.Create
332 (Down => (1 .. 0 => 0),
333 Expression_Type => Tipe,
334 Expression_Kind => Gela.Interpretations.Unknown));
335 begin
336 Self.Plain_Int_Set.Add (Result, Item);
337 end Get_Expression_Index;
338
339 ---------------
340 -- Get_Tuple --
341 ---------------
342
343 overriding function Get_Tuple
344 (Self : in out Interpretation_Manager;
345 Index : Gela.Interpretations.Interpretation_Tuple_Index)
346 return Gela.Interpretations.Interpretation_Set_Index_Array
347 is
348 Value : constant Gela.Interpretations.Interpretation_Index :=
349 Gela.Interpretations.Interpretation_Index (Index);
350 Item : Gela.Int.Interpretation_Access;
351 begin
352 if Value = 0 then
353 return (1 .. 0 => 0);
354 else
355 Item :=
356 Self.Item_Batches.Element (Value / Batch_Size).Element (Value);
357
358 return Gela.Int.Tuples.Tuple (Item.all).Value;
359 end if;
360 end Get_Tuple;
361
362 ---------------------
363 -- Get_Tuple_Index --
364 ---------------------
365
366 overriding procedure Get_Tuple_Index
367 (Self : in out Interpretation_Manager;
368 Left : Gela.Interpretations.Interpretation_Index;
369 Right : Gela.Interpretations.Interpretation_Index;
370 Result : out Gela.Interpretations.Interpretation_Index)
371 is
372 use type Gela.Interpretations.Interpretation_Index_Array;
373
374 Item : constant Gela.Int.Interpretation_Access :=
375 new Gela.Int.Tuples.Chosen_Tuple'
376 (Length => 2, Index => 0, Down => Left & Right);
377 begin
378 Self.Plain_Int_Set.Add (Result, Item);
379 end Get_Tuple_Index;
380
381 --------------------
382 -- Get_Tuple_List --
383 --------------------
384
385 overriding function Get_Tuple_List
386 (Self : in out Interpretation_Manager;
387 Index : Gela.Interpretations.Interpretation_Tuple_List_Index)
388 return Gela.Interpretations.Interpretation_Tuple_Index_Array
389 is
390 Temp : constant Gela.Interpretations.Interpretation_Set_Index_Array :=
391 Self.Get_Tuple
392 (Gela.Interpretations.Interpretation_Tuple_Index (Index));
393 Result : Gela.Interpretations.Interpretation_Tuple_Index_Array
394 (Temp'Range);
395 begin
396 for J in Temp'Range loop
397 Result (J) :=
398 Gela.Interpretations.Interpretation_Tuple_Index (Temp (J));
399 end loop;
400
401 return Result;
402 end Get_Tuple_List;
403
404 --------------
405 -- Profiles --
406 --------------
407
408 overriding function Profiles
409 (Self : in out Interpretation_Manager;
410 Set : Gela.Interpretations.Interpretation_Set_Index)
411 return Gela.Interpretations.Profile_Iterators
412 .Forward_Iterator'Class is
413 begin
414 return Self.Set_Batches.Element (Set / Batch_Size).Profiles (Set);
415 end Profiles;
416
417 ---------------------
418 -- Reserve_Indexes --
419 ---------------------
420
421 overriding procedure Reserve_Indexes
422 (Self : in out Interpretation_Manager;
423 Set : Gela.Int_Sets.Interpretation_Set_Access;
424 From : out Gela.Interpretations.Interpretation_Set_Index;
425 To : out Gela.Interpretations.Interpretation_Set_Index) is
426 begin
427 Self.Set_Batches.Append (Set);
428 From := Self.Set_Batches.Last_Index * Batch_Size;
429 To := From + Batch_Size - 1;
430 From := Gela.Interpretations.Interpretation_Set_Index'Max (1, From);
431 end Reserve_Indexes;
432
433 ---------------------
434 -- Reserve_Indexes --
435 ---------------------
436
437 overriding procedure Reserve_Indexes
438 (Self : in out Interpretation_Manager;
439 Set : Gela.Int_Sets.Interpretation_Set_Access;
440 From : out Gela.Interpretations.Interpretation_Index;
441 To : out Gela.Interpretations.Interpretation_Index) is
442 begin
443 Self.Item_Batches.Append (Set);
444 From := Self.Item_Batches.Last_Index * Batch_Size;
445 To := From + Batch_Size - 1;
446 From := Gela.Interpretations.Interpretation_Index'Max (1, From);
447 end Reserve_Indexes;
448
449 -------------
450 -- Symbols --
451 -------------
452
453 overriding function Symbols
454 (Self : in out Interpretation_Manager;
455 Set : Gela.Interpretations.Interpretation_Set_Index)
456 return Gela.Interpretations.Symbol_Iterators
457 .Forward_Iterator'Class is
458 begin
459 return Self.Set_Batches.Element (Set / Batch_Size).Symbols (Set);
460 end Symbols;
461
462 -----------
463 -- Visit --
464 -----------
465
466 overriding procedure Visit
467 (Self : in out Interpretation_Manager;
468 Index : Gela.Interpretations.Interpretation_Index;
469 Target : in out Gela.Interpretations.Down_Visiter'Class)
470 is
471 package Switch is
472 type Visiter is new Gela.Int.Visiters.Visiter with null record;
473
474 overriding procedure Attr_Function
475 (Self : access Visiter;
476 Value : Gela.Int.Attr_Functions.Attr_Function);
477
478 overriding procedure Chosen_Tuple
479 (Self : access Visiter;
480 Value : Gela.Int.Tuples.Chosen_Tuple);
481
482 overriding procedure Defining_Name
483 (Self : access Visiter;
484 Value : Gela.Int.Defining_Names.Defining_Name);
485
486 overriding procedure Expression
487 (Self : access Visiter;
488 Value : Gela.Int.Expressions.Expression);
489
490 overriding procedure Expression_Category
491 (Self : access Visiter;
492 Value : Gela.Int.Categories.Category);
493
494 overriding procedure Placeholder
495 (Self : access Visiter;
496 Value : Gela.Int.Placeholders.Placeholder);
497
498 overriding procedure Symbol
499 (Self : access Visiter;
500 Value : Gela.Int.Symbols.Symbol);
501
502 overriding procedure Tuple
503 (Self : access Visiter;
504 Value : Gela.Int.Tuples.Tuple);
505
506 end Switch;
507
508 ------------
509 -- Switch --
510 ------------
511
512 package body Switch is
513
514 -------------------
515 -- Attr_Function --
516 -------------------
517
518 overriding procedure Attr_Function
519 (Self : access Visiter;
520 Value : Gela.Int.Attr_Functions.Attr_Function)
521 is
522 pragma Unreferenced (Self);
523 begin
524 Target.On_Attr_Function
525 (Kind => Value.Kind,
526 Tipe => Value.Tipe,
527 Down => Value.Down);
528 end Attr_Function;
529
530 -------------------
531 -- Defining_Name --
532 -------------------
533
534 overriding procedure Defining_Name
535 (Self : access Visiter;
536 Value : Gela.Int.Defining_Names.Defining_Name)
537 is
538 pragma Unreferenced (Self);
539 begin
540 Target.On_Defining_Name
541 (Name => Value.Name,
542 Down => Value.Down);
543 end Defining_Name;
544
545 ----------------
546 -- Expression --
547 ----------------
548
549 overriding procedure Expression
550 (Self : access Visiter;
551 Value : Gela.Int.Expressions.Expression)
552 is
553 pragma Unreferenced (Self);
554 begin
555 Target.On_Expression
556 (Tipe => Value.Expression_Type,
557 Kind => Value.Expression_Kind,
558 Down => Value.Down);
559 end Expression;
560
561 -------------------------
562 -- Expression_Category --
563 -------------------------
564
565 overriding procedure Expression_Category
566 (Self : access Visiter;
567 Value : Gela.Int.Categories.Category)
568 is
569 pragma Unreferenced (Self);
570 begin
571 Target.On_Expression_Category
572 (Match => Value.Match,
573 Down => Value.Down);
574 end Expression_Category;
575
576 -----------------
577 -- Placeholder --
578 -----------------
579
580 overriding procedure Placeholder
581 (Self : access Visiter;
582 Value : Gela.Int.Placeholders.Placeholder)
583 is
584 pragma Unreferenced (Self);
585 begin
586 Target.On_Placeholder
587 (Kind => Value.Placeholder_Kind,
588 Down => Value.Down);
589 end Placeholder;
590
591 ------------
592 -- Symbol --
593 ------------
594
595 overriding procedure Symbol
596 (Self : access Visiter;
597 Value : Gela.Int.Symbols.Symbol)
598 is
599 pragma Unreferenced (Self);
600 begin
601 null;
602 -- raise Program_Er with "Unexpected up interpretation in down";
603 end Symbol;
604
605 -----------
606 -- Tuple --
607 -----------
608
609 overriding procedure Tuple
610 (Self : access Visiter;
611 Value : Gela.Int.Tuples.Tuple)
612 is
613 pragma Unreferenced (Self);
614 begin
615 raise Program_Error with "Unexpected up interpretation in down";
616 end Tuple;
617
618 ------------------
619 -- Chosen_Tuple --
620 ------------------
621
622 overriding procedure Chosen_Tuple
623 (Self : access Visiter;
624 Value : Gela.Int.Tuples.Chosen_Tuple)
625 is
626 pragma Unreferenced (Self);
627 begin
628 Target.On_Tuple (Value.Down);
629 end Chosen_Tuple;
630
631 end Switch;
632
633 V : aliased Switch.Visiter;
634 begin
635 if Index /= 0 then
636 Self.Item_Batches.Element (Index / Batch_Size).Element (Index).Visit
637 (V'Access);
638 end if;
639 end Visit;
640
641end Gela.Plain_Interpretations;
Note: See TracBrowser for help on using the repository browser.