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

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

Add chosen_interpretation to number_declaration

to distinguish integer and real numbers.

  • Property svn:keywords set to Author Date Revision
File size: 36.4 KB
Line 
1------------------------------------------------------------------------------
2-- G E L A A S I S --
3-- ASIS implementation for Gela project, a portable Ada compiler --
4-- a portable Ada compiler --
5-- http://gela.ada-ru.org/ --
6-- - - - - - - - - - - - - - - - --
7-- Read copyright and license in gela.ads file --
8------------------------------------------------------------------------------
9
10with League.Strings;
11
12with Gela.Element_Factories;
13with Gela.Element_Visiters;
14with Gela.Elements.Compilation_Unit_Bodies;
15with Gela.Elements.Context_Items;
16with Gela.Elements.Defining_Designators;
17with Gela.Elements.Enumeration_Type_Definitions;
18with Gela.Elements.Expressions;
19with Gela.Elements.Full_Type_Declarations;
20with Gela.Elements.Function_Declarations;
21with Gela.Elements.Identifiers;
22with Gela.Elements.Package_Declarations;
23with Gela.Elements.Parameter_Specifications;
24with Gela.Elements.Procedure_Bodies;
25with Gela.Elements.Program_Unit_Names;
26with Gela.Elements.Selected_Identifiers;
27with Gela.Elements.Selector_Names;
28with Gela.Elements.Subtype_Indications;
29with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
30with Gela.Elements.Type_Definitions;
31with Gela.Elements.With_Clauses;
32with Gela.Environments;
33with Gela.Nodes;
34with Gela.Plain_Type_Managers;
35with Gela.Symbol_Sets;
36with Gela.Elements.Defining_Operator_Symbols;
37with Gela.Defining_Name_Cursors;
38with Gela.Type_Managers;
39with Gela.Types.Arrays;
40with Gela.Types.Visitors;
41with Gela.Types.Simple;
42
43package body Gela.Pass_Utils is
44
45 procedure Preprocess_Standard
46 (Comp : Gela.Compilations.Compilation_Access;
47 Unit : Gela.Elements.Element_Access);
48
49 procedure Postprocess_Standard
50 (Comp : Gela.Compilations.Compilation_Access;
51 Unit : Gela.Elements.Compilation_Unit_Declarations.
52 Compilation_Unit_Declaration_Access;
53 Env : in Gela.Semantic_Types.Env_Index);
54
55 function Is_Enumeration
56 (Decl : Gela.Elements.Element_Access) return Boolean;
57
58 procedure Add_Library_Level_Use_Clauses
59 (Comp : Gela.Compilations.Compilation_Access;
60 Decl : Gela.Elements.Element_Access;
61 Env : in out Gela.Semantic_Types.Env_Index);
62
63 package Implicits is
64 function Create_Operator
65 (Factory : Gela.Element_Factories.Element_Factory_Access;
66 Operator_Symbol : Gela.Lexical_Types.Symbol;
67 Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
68 Left_Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
69 Right_Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
70 Arity : Positive := 2)
71 return Gela.Elements.Defining_Names.Defining_Name_Access;
72 end Implicits;
73
74 package Each_Use_Package is
75 -- Iterate over each name in use package clause and add it to Env
76
77 type Visiter is new Gela.Element_Visiters.Visiter with record
78 Set : Gela.Environments.Environment_Set_Access;
79 Env : Gela.Semantic_Types.Env_Index;
80 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
81 end record;
82
83 overriding procedure Identifier
84 (Self : in out Visiter;
85 Node : not null Gela.Elements.Identifiers.Identifier_Access);
86
87 overriding procedure Selected_Identifier
88 (Self : in out Visiter;
89 Node : not null Gela.Elements.Selected_Identifiers.
90 Selected_Identifier_Access);
91
92 overriding procedure Use_Package_Clause
93 (Self : in out Visiter;
94 Node : not null Gela.Elements.Use_Package_Clauses.
95 Use_Package_Clause_Access);
96 end Each_Use_Package;
97
98 ----------------------
99 -- Each_Use_Package --
100 ----------------------
101
102 package body Each_Use_Package is
103 overriding procedure Identifier
104 (Self : in out Visiter;
105 Node : not null Gela.Elements.Identifiers.Identifier_Access) is
106 begin
107 Self.Name := Node.Defining_Name;
108 end Identifier;
109
110 overriding procedure Selected_Identifier
111 (Self : in out Visiter;
112 Node : not null Gela.Elements.Selected_Identifiers.
113 Selected_Identifier_Access)
114 is
115 Selector : constant Gela.Elements.Selector_Names.
116 Selector_Name_Access := Node.Selector;
117 begin
118 Selector.Visit (Self);
119 end Selected_Identifier;
120
121 overriding procedure Use_Package_Clause
122 (Self : in out Visiter;
123 Node : not null Gela.Elements.Use_Package_Clauses.
124 Use_Package_Clause_Access)
125 is
126 List : constant Gela.Elements.Program_Unit_Names.
127 Program_Unit_Name_Sequence_Access := Node.Clause_Names;
128 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
129 begin
130 while Cursor.Has_Element loop
131 Cursor.Element.Visit (Self);
132
133 Self.Env := Self.Set.Add_Use_Package
134 (Index => Self.Env,
135 Name => Self.Name);
136
137 Cursor.Next;
138 end loop;
139 end Use_Package_Clause;
140
141 end Each_Use_Package;
142
143 -------------------------------
144 -- Add_Implicit_Declarations --
145 -------------------------------
146
147 procedure Add_Implicit_Declarations
148 (Comp : Gela.Compilations.Compilation_Access;
149 Tipe : Gela.Elements.Element_Access;
150 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
151 Env : in out Gela.Semantic_Types.Env_Index)
152 is
153 package Visitors is
154 type Type_Visitor is new Gela.Types.Visitors.Type_Visitor with record
155 Set : Gela.Environments.Environment_Set_Access :=
156 Comp.Context.Environment_Set;
157 Factory : Gela.Element_Factories.Element_Factory_Access :=
158 Comp.Factory;
159 Is_Root_Real : Boolean;
160 end record;
161
162 procedure Add
163 (Self : in out Type_Visitor'Class;
164 Name : Gela.Elements.Defining_Names.Defining_Name_Access);
165
166 overriding procedure Signed_Integer_Type
167 (Self : in out Type_Visitor;
168 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
169
170 overriding procedure Floating_Point_Type
171 (Self : in out Type_Visitor;
172 Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
173
174 overriding procedure Array_Type
175 (Self : in out Type_Visitor;
176 Value : not null Gela.Types.Arrays.Array_Type_Access);
177
178 end Visitors;
179
180 TM : constant Gela.Type_Managers.Type_Manager_Access :=
181 Comp.Context.Types;
182
183 package body Visitors is
184
185 type Symbol_List is array (Positive range <>) of
186 Gela.Lexical_Types.Symbol;
187
188 procedure Create_Operators
189 (Self : in out Type_Visitor'Class;
190 List : Symbol_List);
191
192 procedure Create_Operators
193 (Self : in out Type_Visitor'Class;
194 List : Symbol_List) is
195 begin
196 for Symbol of List loop
197 Self.Add
198 (Implicits.Create_Operator
199 (Self.Factory,
200 Symbol,
201 Name, Name, Name,
202 Arity => 2));
203 end loop;
204 end Create_Operators;
205
206 ---------
207 -- Add --
208 ---------
209
210 procedure Add
211 (Self : in out Type_Visitor'Class;
212 Name : Gela.Elements.Defining_Names.Defining_Name_Access) is
213 begin
214 Env := Self.Set.Add_Defining_Name
215 (Index => Env,
216 Symbol => Name.Full_Name,
217 Name => Name);
218 end Add;
219
220 overriding procedure Array_Type
221 (Self : in out Type_Visitor;
222 Value : not null Gela.Types.Arrays.Array_Type_Access)
223 is
224 pragma Unreferenced (Value);
225 begin
226 Self.Add
227 (Implicits.Create_Operator
228 (Self.Factory,
229 Gela.Lexical_Types.Operators.Ampersand_Operator,
230 Name, Name, Name,
231 Arity => 2));
232 end Array_Type;
233
234 overriding procedure Floating_Point_Type
235 (Self : in out Type_Visitor;
236 Value : not null Gela.Types.Simple.Floating_Point_Type_Access)
237 is
238 pragma Unreferenced (Value);
239 begin
240 Self.Add
241 (Implicits.Create_Operator
242 (Self.Factory,
243 Gela.Lexical_Types.Operators.Hyphen_Operator,
244 Name, Name, Name,
245 Arity => 1));
246
247 Self.Add
248 (Implicits.Create_Operator
249 (Self.Factory,
250 Gela.Lexical_Types.Operators.Plus_Operator,
251 Name, Name, Name,
252 Arity => 2));
253
254 if Self.Is_Root_Real then
255 declare
256 Root_Integer : constant Gela.Types.Type_View_Access :=
257 TM.Get (TM.Root_Integer);
258 begin
259 Self.Add
260 (Implicits.Create_Operator
261 (Self.Factory,
262 Gela.Lexical_Types.Operators.Star_Operator,
263 Type_Name => Name,
264 Left_Type_Name => Root_Integer.Defining_Name,
265 Right_Type_Name => Name,
266 Arity => 2));
267 end;
268 end if;
269 end Floating_Point_Type;
270
271 overriding procedure Signed_Integer_Type
272 (Self : in out Type_Visitor;
273 Value : not null Gela.Types.Simple.Signed_Integer_Type_Access)
274 is
275 pragma Unreferenced (Value);
276 begin
277 Create_Operators
278 (Self,
279 (Gela.Lexical_Types.Operators.Plus_Operator,
280 Gela.Lexical_Types.Operators.Hyphen_Operator));
281 end Signed_Integer_Type;
282
283 end Visitors;
284
285 Type_Index : constant Gela.Semantic_Types.Type_Index :=
286 TM.Type_From_Declaration (Env, Tipe);
287 Type_View : constant Gela.Types.Type_View_Access :=
288 TM.Get (Type_Index);
289
290 begin
291 if not Type_View.Assigned then
292 return;
293 end if;
294
295 declare
296 Visitor : Visitors.Type_Visitor :=
297 (Is_Root_Real => Type_Index in TM.Root_Real,
298 others => <>);
299 begin
300 Type_View.Visit (Visitor);
301 end;
302 end Add_Implicit_Declarations;
303
304 -----------------------------------
305 -- Add_Library_Level_Use_Clauses --
306 -----------------------------------
307
308 procedure Add_Library_Level_Use_Clauses
309 (Comp : Gela.Compilations.Compilation_Access;
310 Decl : Gela.Elements.Element_Access;
311 Env : in out Gela.Semantic_Types.Env_Index)
312 is
313
314 package Get is
315
316 type Visiter is new Each_Use_Package.Visiter with null record;
317
318 overriding procedure Compilation_Unit_Body
319 (Self : in out Visiter;
320 Node : not null Gela.Elements.Compilation_Unit_Bodies.
321 Compilation_Unit_Body_Access);
322
323 overriding procedure Compilation_Unit_Declaration
324 (Self : in out Visiter;
325 Node : not null Gela.Elements.Compilation_Unit_Declarations.
326 Compilation_Unit_Declaration_Access);
327
328 overriding procedure Package_Declaration
329 (Self : in out Visiter;
330 Node : not null Gela.Elements.Package_Declarations.
331 Package_Declaration_Access);
332
333 overriding procedure Procedure_Body
334 (Self : in out Visiter;
335 Node : not null Gela.Elements.Procedure_Bodies.
336 Procedure_Body_Access);
337
338 overriding procedure With_Clause -- Use env.out instead
339 (Self : in out Visiter;
340 Node : not null Gela.Elements.With_Clauses.With_Clause_Access);
341 end Get;
342
343 package body Get is
344
345 overriding procedure Compilation_Unit_Body
346 (Self : in out Visiter;
347 Node : not null Gela.Elements.Compilation_Unit_Bodies.
348 Compilation_Unit_Body_Access)
349 is
350 List : constant Gela.Elements.Context_Items.
351 Context_Item_Sequence_Access := Node.Context_Clause_Elements;
352
353 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
354 begin
355 while Cursor.Has_Element loop
356 Cursor.Element.Visit (Self);
357 Cursor.Next;
358 end loop;
359 end Compilation_Unit_Body;
360
361 overriding procedure Compilation_Unit_Declaration
362 (Self : in out Visiter;
363 Node : not null Gela.Elements.Compilation_Unit_Declarations.
364 Compilation_Unit_Declaration_Access)
365 is
366 List : constant Gela.Elements.Context_Items.
367 Context_Item_Sequence_Access := Node.Context_Clause_Elements;
368
369 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
370 begin
371 while Cursor.Has_Element loop
372 Cursor.Element.Visit (Self);
373 Cursor.Next;
374 end loop;
375 end Compilation_Unit_Declaration;
376
377 overriding procedure Package_Declaration
378 (Self : in out Visiter;
379 Node : not null Gela.Elements.Package_Declarations.
380 Package_Declaration_Access) is
381 begin
382 Node.Enclosing_Element.Visit (Self);
383 end Package_Declaration;
384
385 overriding procedure Procedure_Body
386 (Self : in out Visiter;
387 Node : not null Gela.Elements.Procedure_Bodies.
388 Procedure_Body_Access) is
389 begin
390 Node.Enclosing_Element.Visit (Self);
391 end Procedure_Body;
392
393 overriding procedure With_Clause -- Use env.out instead
394 (Self : in out Visiter;
395 Node : not null Gela.Elements.With_Clauses.With_Clause_Access)
396 is
397 use type Gela.Lexical_Types.Symbol_List;
398
399 List : Gela.Lexical_Types.Symbol_List := Node.With_List;
400 begin
401 while List /= Gela.Lexical_Types.Empty_Symbol_List loop
402 Self.Env := Self.Set.Add_With_Clause
403 (Index => Self.Env,
404 Symbol => Comp.Context.Symbols.Head (List));
405 List := Comp.Context.Symbols.Tail (List);
406 end loop;
407 end With_Clause;
408
409 end Get;
410
411 Set : constant Gela.Environments.Environment_Set_Access :=
412 Comp.Context.Environment_Set;
413 Visiter : Get.Visiter := (Set, Env, null);
414 begin
415 Decl.Visit (Visiter);
416 Env := Visiter.Env;
417 end Add_Library_Level_Use_Clauses;
418
419 ----------------------------
420 -- Add_Name_Create_Region --
421 ----------------------------
422
423 function Add_Name_Create_Region
424 (Comp : Gela.Compilations.Compilation_Access;
425 Env : Gela.Semantic_Types.Env_Index;
426 Symbol : Gela.Lexical_Types.Symbol;
427 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
428 Decl : Gela.Elements.Element_Access)
429 return Gela.Semantic_Types.Env_Index
430 is
431 use type Gela.Semantic_Types.Env_Index;
432 use type Gela.Lexical_Types.Symbol;
433
434 Library_Level : constant Boolean :=
435 Env = Comp.Context.Environment_Set.Library_Level_Environment;
436
437 Env_0 : Gela.Semantic_Types.Env_Index;
438 Env_1 : Gela.Semantic_Types.Env_Index;
439 Env_2 : Gela.Semantic_Types.Env_Index;
440 begin
441 if Library_Level then
442 Env_0 := Parents_Declarative_Region (Comp, Symbol);
443
444 if Symbol = Gela.Lexical_Types.Predefined_Symbols.Standard then
445 Preprocess_Standard (Comp, Decl);
446 end if;
447
448 else
449 Env_0 := Env;
450 end if;
451
452 Env_1 := Comp.Context.Environment_Set.Add_Defining_Name
453 (Index => Env_0,
454 Symbol => Symbol,
455 Name => Name);
456
457 if Is_Enumeration (Decl) then
458 return Env_1;
459 end if;
460
461 Env_2 := Comp.Context.Environment_Set.Enter_Declarative_Region
462 (Index => Env_1,
463 Region => Name);
464
465 if Library_Level then
466 Add_Library_Level_Use_Clauses (Comp, Decl, Env_2);
467 end if;
468
469 return Env_2;
470 end Add_Name_Create_Region;
471
472 ---------------
473 -- Add_Names --
474 ---------------
475
476 function Add_Names
477 (Comp : Gela.Compilations.Compilation_Access;
478 Env : Gela.Semantic_Types.Env_Index;
479 List : Gela.Lexical_Types.Symbol_List;
480 Names : Gela.Elements.Defining_Identifiers
481 .Defining_Identifier_Sequence_Access)
482 return Gela.Semantic_Types.Env_Index
483 is
484 Tail : Gela.Lexical_Types.Symbol_List := List;
485 Env_1 : Gela.Semantic_Types.Env_Index := Env;
486 Symbol : Gela.Lexical_Types.Symbol;
487 Name : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
488 Cursor : Gela.Elements.Defining_Identifiers
489 .Defining_Identifier_Sequence_Cursor := Names.First;
490 Set : constant Gela.Symbol_Sets.Symbol_Set_Access :=
491 Comp.Context.Symbols;
492 begin
493 while Cursor.Has_Element loop
494 Name := Cursor.Element;
495 Symbol := Set.Head (Tail);
496 Tail := Set.Tail (Tail);
497 Cursor.Next;
498
499 Env_1 := Comp.Context.Environment_Set.Add_Defining_Name
500 (Index => Env_1,
501 Symbol => Symbol,
502 Name => Gela.Elements.Defining_Names
503 .Defining_Name_Access (Name));
504 end loop;
505
506 return Env_1;
507 end Add_Names;
508
509 -----------------------------
510 -- Add_Names_Create_Region --
511 -----------------------------
512
513 function Add_Names_Create_Region
514 (Comp : Gela.Compilations.Compilation_Access;
515 Env : Gela.Semantic_Types.Env_Index;
516 List : Gela.Lexical_Types.Symbol_List;
517 Names : Gela.Elements.Defining_Identifiers
518 .Defining_Identifier_Sequence_Access)
519 return Gela.Semantic_Types.Env_Index
520 is
521 Env_1 : Gela.Semantic_Types.Env_Index;
522 Env_2 : Gela.Semantic_Types.Env_Index;
523 Name : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
524 Cursor : constant Gela.Elements.Defining_Identifiers
525 .Defining_Identifier_Sequence_Cursor := Names.First;
526 begin
527 Name := Cursor.Element;
528 Env_1 := Add_Names (Comp, Env, List, Names);
529
530 Env_2 := Comp.Context.Environment_Set.Enter_Declarative_Region
531 (Index => Env_1,
532 Region => Gela.Elements.Defining_Names.Defining_Name_Access (Name));
533
534 return Env_2;
535 end Add_Names_Create_Region;
536
537 ---------------------
538 -- Add_Use_Package --
539 ---------------------
540
541 function Add_Use_Package
542 (Comp : Gela.Compilations.Compilation_Access;
543 Env : Gela.Semantic_Types.Env_Index;
544 Node : not null Gela.Elements.Use_Package_Clauses.
545 Use_Package_Clause_Access)
546 return Gela.Semantic_Types.Env_Index
547 is
548 Set : constant Gela.Environments.Environment_Set_Access :=
549 Comp.Context.Environment_Set;
550 Visiter : Each_Use_Package.Visiter := (Set, Env, null);
551 begin
552 Node.Visit (Visiter);
553
554 return Visiter.Env;
555 end Add_Use_Package;
556
557 -------------------------------------------
558 -- Choose_Auxiliary_Apply_Interpretation --
559 -------------------------------------------
560
561 procedure Choose_Auxiliary_Apply_Interpretation
562 (Comp : Gela.Compilations.Compilation_Access;
563 Down : Gela.Interpretations.Interpretation_Index;
564 Result : in out Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds)
565 is
566 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
567 Comp.Context.Interpretation_Manager;
568
569 package Visiters is
570 type Visiter is new Gela.Interpretations.Down_Visiter with record
571 Result : Gela.Interpretations.Interpretation_Kinds;
572 end record;
573
574 overriding procedure On_Expression
575 (Self : in out Visiter;
576 Tipe : Gela.Semantic_Types.Type_Index;
577 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
578 Down : Gela.Interpretations.Interpretation_Index_Array);
579
580 end Visiters;
581
582 package body Visiters is
583
584 overriding procedure On_Expression
585 (Self : in out Visiter;
586 Tipe : Gela.Semantic_Types.Type_Index;
587 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
588 Down : Gela.Interpretations.Interpretation_Index_Array)
589 is
590 pragma Unreferenced (Down, Tipe);
591 begin
592 if Kind in Gela.Interpretations.Auxiliary_Apply_Kinds then
593 Self.Result := Kind;
594 end if;
595 end On_Expression;
596
597 end Visiters;
598
599 V : Visiters.Visiter := (Result => Result);
600 begin
601 IM.Visit (Down, V);
602 Result := V.Result;
603 end Choose_Auxiliary_Apply_Interpretation;
604
605 ------------------------------------------------
606 -- Choose_Composite_Constraint_Interpretation --
607 ------------------------------------------------
608
609 procedure Choose_Composite_Constraint_Interpretation
610 (Comp : Gela.Compilations.Compilation_Access;
611 Node : access Gela.Elements.Element'Class;
612 Result : out Gela.Interpretations.Constraint_Kinds)
613 is
614 use type Gela.Types.Type_View_Access;
615
616 TM : constant Gela.Type_Managers.Type_Manager_Access :=
617 Comp.Context.Types;
618
619 Subtype_Indication : constant Gela.Elements.Subtype_Indications.
620 Subtype_Indication_Access :=
621 Gela.Elements.Subtype_Indications.Subtype_Indication_Access
622 (Node.Enclosing_Element);
623
624 Type_Index : constant Gela.Semantic_Types.Type_Index :=
625 TM.Type_From_Subtype_Indication
626 (Subtype_Indication.Env_In, Subtype_Indication);
627
628 Type_View : constant Gela.Types.Type_View_Access :=
629 TM.Get (Type_Index);
630 begin
631 if Type_View /= null and then Type_View.Is_Array then
632 Result := Gela.Interpretations.Index_Constraint;
633 else
634 Result := Gela.Interpretations.Discriminant_Constraint;
635 end if;
636 end Choose_Composite_Constraint_Interpretation;
637
638 ----------------------------------------------
639 -- Choose_Number_Declaration_Interpretation --
640 ----------------------------------------------
641
642 procedure Choose_Number_Declaration_Interpretation
643 (Comp : Gela.Compilations.Compilation_Access;
644 Node : access Gela.Elements.Number_Declarations.
645 Number_Declaration'Class;
646 Result : out Gela.Interpretations.Number_Declaration_Kinds)
647 is
648 IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
649 Comp.Context.Interpretation_Manager;
650
651 TM : constant Gela.Type_Managers.Type_Manager_Access :=
652 Comp.Context.Types;
653
654 Init : constant Gela.Elements.Expressions.Expression_Access :=
655 Node.Initialization_Expression;
656
657 Down : constant Gela.Interpretations.Interpretation_Index := Init.Down;
658
659 package Visiters is
660 type Visiter is new Gela.Interpretations.Down_Visiter with record
661 Result : Gela.Interpretations.Number_Declaration_Kinds;
662 end record;
663
664 overriding procedure On_Expression
665 (Self : in out Visiter;
666 Tipe : Gela.Semantic_Types.Type_Index;
667 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
668 Down : Gela.Interpretations.Interpretation_Index_Array);
669
670 end Visiters;
671
672 package body Visiters is
673
674 overriding procedure On_Expression
675 (Self : in out Visiter;
676 Tipe : Gela.Semantic_Types.Type_Index;
677 Kind : Gela.Interpretations.Unknown_Auxiliary_Apply_Kinds;
678 Down : Gela.Interpretations.Interpretation_Index_Array)
679 is
680 pragma Unreferenced (Down, Kind);
681 use type Gela.Types.Type_View_Access;
682
683 Type_View : constant Gela.Types.Type_View_Access := TM.Get (Tipe);
684 begin
685 if Type_View /= null and then Type_View.Is_Integer then
686 Self.Result := Gela.Interpretations.Integer_Number;
687 end if;
688 end On_Expression;
689
690 end Visiters;
691
692 V : Visiters.Visiter := (Result => Gela.Interpretations.Real_Number);
693 begin
694 IM.Visit (Down, V);
695 Result := V.Result;
696 end Choose_Number_Declaration_Interpretation;
697
698 ------------------------------
699 -- Create_Completion_Region --
700 ------------------------------
701
702 function Create_Completion_Region
703 (Comp : Gela.Compilations.Compilation_Access;
704 Env : Gela.Semantic_Types.Env_Index;
705 Symbol : Gela.Lexical_Types.Symbol;
706 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
707 Decl : Gela.Elements.Element_Access)
708 return Gela.Semantic_Types.Env_Index
709 is
710 Set : constant Gela.Environments.Environment_Set_Access :=
711 Comp.Context.Environment_Set;
712 Found : aliased Boolean := False;
713 Env_1 : Gela.Semantic_Types.Env_Index;
714 Pos : constant Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
715 Set.Visible (Env, null, Symbol, Found'Access);
716 begin
717 if Pos.Has_Element then
718 Env_1 := Set.Add_Completion
719 (Index => Env,
720 Name => Pos.Element,
721 Completion => Name);
722
723 return Set.Enter_Completion_Region (Env_1, Pos.Element);
724 else
725 return Add_Name_Create_Region (Comp, Env, Symbol, Name, Decl);
726 end if;
727 end Create_Completion_Region;
728
729 --------------------------------
730 -- Create_Function_Call_Value --
731 --------------------------------
732
733 function Create_Function_Call_Value
734 (Comp : Gela.Compilations.Compilation_Access;
735 Name : Gela.Semantic_Types.Value_Index;
736 Arguments : Gela.Semantic_Types.Value_Index)
737 return Gela.Semantic_Types.Value_Index
738 is
739 Result : Gela.Semantic_Types.Value_Index;
740 begin
741 Comp.Context.Values.Apply
742 (Name => Name,
743 Args => Arguments,
744 Value => Result);
745
746 return Result;
747 end Create_Function_Call_Value;
748
749 function Create_Numeric_Value
750 (Comp : Gela.Compilations.Compilation_Access;
751 Value : Gela.Lexical_Types.Token_Index)
752 return Gela.Semantic_Types.Value_Index
753 is
754 Token : constant Gela.Lexical_Types.Token := Comp.Get_Token (Value);
755 Source : constant League.Strings.Universal_String := Comp.Source;
756 Image : constant League.Strings.Universal_String :=
757 Source.Slice (Token.First, Token.Last);
758 Result : Gela.Semantic_Types.Value_Index;
759 begin
760 Comp.Context.Values.Numeric_Literal (Image, Result);
761
762 return Result;
763 end Create_Numeric_Value;
764
765 -------------------------
766 -- Create_String_Value --
767 -------------------------
768
769 function Create_String_Value
770 (Comp : Gela.Compilations.Compilation_Access;
771 Full_Name : Gela.Lexical_Types.Token_Index)
772 return Gela.Semantic_Types.Value_Index
773 is
774 Token : constant Gela.Lexical_Types.Token := Comp.Get_Token (Full_Name);
775 Source : constant League.Strings.Universal_String := Comp.Source;
776 Image : constant League.Strings.Universal_String :=
777 Source.Slice (Token.First, Token.Last);
778 Result : Gela.Semantic_Types.Value_Index;
779 begin
780 Comp.Context.Values.String_Literal
781 (Image.Slice (2, Image.Length - 1), Result);
782
783 return Result;
784 end Create_String_Value;
785
786 procedure End_Of_Compilation_Unit_Declaration
787 (Comp : Gela.Compilations.Compilation_Access;
788 Unit : Gela.Elements.Compilation_Unit_Declarations.
789 Compilation_Unit_Declaration_Access;
790 Symbol : Gela.Lexical_Types.Symbol;
791 Env : Gela.Semantic_Types.Env_Index)
792 is
793 use type Gela.Lexical_Types.Symbol;
794 begin
795 if Symbol = Gela.Lexical_Types.Predefined_Symbols.Standard then
796 Postprocess_Standard (Comp, Unit, Env);
797 end if;
798 end End_Of_Compilation_Unit_Declaration;
799
800 ---------------
801 -- Implicits --
802 ---------------
803
804 package body Implicits is
805
806 procedure Set_Part_Of_Implicit
807 (Element : access Gela.Elements.Element'Class);
808
809 function Create_Subtype
810 (Factory : Gela.Element_Factories.Element_Factory_Access;
811 Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access)
812 return Gela.Elements.Subtype_Mark_Or_Access_Definitions.
813 Subtype_Mark_Or_Access_Definition_Access;
814
815 function Create_Operator
816 (Factory : Gela.Element_Factories.Element_Factory_Access;
817 Operator_Symbol : Gela.Lexical_Types.Symbol;
818 Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
819 Left_Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
820 Right_Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access;
821 Arity : Positive := 2)
822 return Gela.Elements.Defining_Names.Defining_Name_Access
823 is
824 FD : Gela.Elements.Function_Declarations.Function_Declaration_Access;
825
826 Name : Gela.Elements.Defining_Designators.Defining_Designator_Access;
827
828 Oper : constant Gela.Elements.Defining_Operator_Symbols.
829 Defining_Operator_Symbol_Access :=
830 Factory.Defining_Operator_Symbol
831 (Operator_Symbol_Token => 0);
832
833 Param : Gela.Elements.Parameter_Specifications.
834 Parameter_Specification_Access;
835
836 Params : constant Gela.Elements.Parameter_Specifications.
837 Parameter_Specification_Sequence_Access :=
838 Factory.Parameter_Specification_Sequence;
839
840 Mark : Gela.Elements.Subtype_Mark_Or_Access_Definitions.
841 Subtype_Mark_Or_Access_Definition_Access;
842 begin
843 Oper.Set_Full_Name (Operator_Symbol);
844 Set_Part_Of_Implicit (Oper);
845
846 Name := Gela.Elements.Defining_Designators.Defining_Designator_Access
847 (Oper);
848
849 for J in 1 .. Arity loop
850 if J = 1 then
851 Mark := Create_Subtype (Factory, Left_Type_Name);
852 else
853 Mark := Create_Subtype (Factory, Right_Type_Name);
854 end if;
855
856 Param := Factory.Parameter_Specification
857 (Names =>
858 Factory.Defining_Identifier_Sequence,
859 Colon_Token => 0,
860 Aliased_Token => 0,
861 In_Token => 0,
862 Out_Token => 0,
863 Not_Token => 0,
864 Null_Token => 0,
865 Object_Declaration_Subtype => Mark,
866 Assignment_Token => 0,
867 Initialization_Expression => null);
868
869 Params.Append (Param);
870
871 Set_Part_Of_Implicit (Param);
872 end loop;
873
874 Mark := Create_Subtype (Factory, Type_Name);
875
876 FD := Factory.Function_Declaration
877 (Not_Token => 0,
878 Overriding_Token => 0,
879 Function_Token => 0,
880 Names => Name,
881 Lp_Token => 0,
882 Parameter_Profile => Params,
883 Rp_Token => 0,
884 Return_Token => 0,
885 Return_Not_Token => 0,
886 Return_Null_Token => 0,
887 Result_Subtype => Mark,
888 Is_Token => 0,
889 Abstract_Token => 0,
890 Result_Expression => null,
891 Renames_Token => 0,
892 Renamed_Entity => null,
893 Separate_Token => 0,
894 Aspect_Specifications => Factory.Aspect_Specification_Sequence,
895 Semicolon_Token => 0);
896
897 Set_Part_Of_Implicit (FD);
898 FD.Set_Corresponding_Type (Left_Type_Name.Enclosing_Element);
899
900 return Gela.Elements.Defining_Names.Defining_Name_Access (Name);
901 end Create_Operator;
902
903 --------------------
904 -- Create_Subtype --
905 --------------------
906
907 function Create_Subtype
908 (Factory : Gela.Element_Factories.Element_Factory_Access;
909 Type_Name : Gela.Elements.Defining_Names.Defining_Name_Access)
910 return Gela.Elements.Subtype_Mark_Or_Access_Definitions.
911 Subtype_Mark_Or_Access_Definition_Access
912 is
913 Identifier : Gela.Elements.Identifiers.Identifier_Access;
914
915 Mark : Gela.Elements.Subtype_Mark_Or_Access_Definitions.
916 Subtype_Mark_Or_Access_Definition_Access;
917 begin
918 Identifier := Factory.Identifier (Identifier_Token => 0);
919 Identifier.Set_Full_Name (Type_Name.Full_Name);
920 Identifier.Set_Defining_Name (Type_Name);
921 Set_Part_Of_Implicit (Identifier);
922
923 Mark := Gela.Elements.Subtype_Mark_Or_Access_Definitions.
924 Subtype_Mark_Or_Access_Definition_Access (Identifier);
925
926 return Mark;
927 end Create_Subtype;
928
929 procedure Set_Part_Of_Implicit
930 (Element : access Gela.Elements.Element'Class)
931 is
932 Node : constant Gela.Nodes.Node_Access :=
933 Gela.Nodes.Node_Access (Element);
934 begin
935 Node.Set_Part_Of_Implicit;
936 end Set_Part_Of_Implicit;
937
938 end Implicits;
939
940 --------------------
941 -- Is_Enumeration --
942 --------------------
943
944 function Is_Enumeration
945 (Decl : Gela.Elements.Element_Access) return Boolean
946 is
947 package Get is
948
949 type Visiter is new Gela.Element_Visiters.Visiter with record
950 Result : Boolean := False;
951 end record;
952
953 overriding procedure Full_Type_Declaration
954 (Self : in out Visiter;
955 Node : not null Gela.Elements.Full_Type_Declarations.
956 Full_Type_Declaration_Access);
957
958 overriding procedure Enumeration_Type_Definition
959 (Self : in out Visiter;
960 Node : not null Gela.Elements.Enumeration_Type_Definitions.
961 Enumeration_Type_Definition_Access);
962
963 end Get;
964
965 package body Get is
966
967 overriding procedure Full_Type_Declaration
968 (Self : in out Visiter;
969 Node : not null Gela.Elements.Full_Type_Declarations.
970 Full_Type_Declaration_Access)
971 is
972 View : constant Gela.Elements.Type_Definitions.
973 Type_Definition_Access := Node.Type_Declaration_View;
974 begin
975 View.Visit (Self);
976 end Full_Type_Declaration;
977
978 overriding procedure Enumeration_Type_Definition
979 (Self : in out Visiter;
980 Node : not null Gela.Elements.Enumeration_Type_Definitions.
981 Enumeration_Type_Definition_Access)
982 is
983 pragma Unreferenced (Node);
984 begin
985 Self.Result := True;
986 end Enumeration_Type_Definition;
987
988 end Get;
989
990 use type Gela.Elements.Element_Access;
991 V : Get.Visiter;
992 begin
993 if Decl /= null then
994 Decl.Visit (V);
995 end if;
996
997 return V.Result;
998 end Is_Enumeration;
999
1000 ------------------------------
1001 -- Leave_Declarative_Region --
1002 ------------------------------
1003
1004 function Leave_Declarative_Region
1005 (Comp : Gela.Compilations.Compilation_Access;
1006 Index : Gela.Semantic_Types.Env_Index;
1007 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
1008 return Gela.Semantic_Types.Env_Index
1009 is
1010 Result : Gela.Semantic_Types.Env_Index := Index;
1011 begin
1012 if not Is_Enumeration (Name.Enclosing_Element) then
1013 Result :=
1014 Comp.Context.Environment_Set.Leave_Declarative_Region (Index);
1015 end if;
1016
1017 return Result;
1018 end Leave_Declarative_Region;
1019
1020 --------------------------------
1021 -- Parents_Declarative_Region --
1022 --------------------------------
1023
1024 function Parents_Declarative_Region
1025 (Comp : Gela.Compilations.Compilation_Access;
1026 Full_Name : Gela.Lexical_Types.Symbol)
1027 return Gela.Semantic_Types.Env_Index
1028 is
1029 use type Gela.Lexical_Types.Symbol;
1030
1031 Set : constant Gela.Symbol_Sets.Symbol_Set_Access :=
1032 Comp.Context.Symbols;
1033 Parent : constant Gela.Lexical_Types.Symbol := Set.Parent (Full_Name);
1034 Result : Gela.Semantic_Types.Env_Index;
1035 begin
1036 if Parent = Gela.Lexical_Types.No_Symbol then
1037 return 0;
1038 end if;
1039
1040 Result := Comp.Context.Environment_Set.Library_Unit_Environment (Parent);
1041
1042 return Result;
1043 end Parents_Declarative_Region;
1044
1045 --------------------------
1046 -- Postprocess_Standard --
1047 --------------------------
1048
1049 procedure Postprocess_Standard
1050 (Comp : Gela.Compilations.Compilation_Access;
1051 Unit : Gela.Elements.Compilation_Unit_Declarations.
1052 Compilation_Unit_Declaration_Access;
1053 Env : in Gela.Semantic_Types.Env_Index) is
1054 begin
1055 null;
1056 end Postprocess_Standard;
1057
1058 -------------------------
1059 -- Preprocess_Standard --
1060 -------------------------
1061
1062 procedure Preprocess_Standard
1063 (Comp : Gela.Compilations.Compilation_Access;
1064 Unit : Gela.Elements.Element_Access) is
1065 begin
1066 Gela.Plain_Type_Managers.Type_Manager_Access
1067 (Comp.Context.Types).Initialize (Unit);
1068 end Preprocess_Standard;
1069
1070end Gela.Pass_Utils;
Note: See TracBrowser for help on using the repository browser.