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

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

Create completion region for package_body

File size: 26.2 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.Full_Type_Declarations;
19with Gela.Elements.Function_Declarations;
20with Gela.Elements.Identifiers;
21with Gela.Elements.Package_Declarations;
22with Gela.Elements.Parameter_Specifications;
23with Gela.Elements.Procedure_Bodies;
24with Gela.Elements.Program_Unit_Names;
25with Gela.Elements.Selected_Identifiers;
26with Gela.Elements.Selector_Names;
27with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
28with Gela.Elements.Type_Definitions;
29with Gela.Elements.With_Clauses;
30with Gela.Environments;
31with Gela.Nodes;
32with Gela.Plain_Type_Managers;
33with Gela.Symbol_Sets;
34with Gela.Elements.Defining_Operator_Symbols;
35with Gela.Defining_Name_Cursors;
36
37package body Gela.Pass_Utils is
38
39 procedure Preprocess_Standard
40 (Comp : Gela.Compilations.Compilation_Access;
41 Unit : Gela.Elements.Element_Access);
42
43 procedure Postprocess_Standard
44 (Comp : Gela.Compilations.Compilation_Access;
45 Unit : Gela.Elements.Compilation_Unit_Declarations.
46 Compilation_Unit_Declaration_Access;
47 Env : in out Gela.Semantic_Types.Env_Index);
48
49 function Is_Enumeration
50 (Decl : Gela.Elements.Element_Access) return Boolean;
51
52 procedure Add_Library_Level_Use_Clauses
53 (Comp : Gela.Compilations.Compilation_Access;
54 Decl : Gela.Elements.Element_Access;
55 Env : in out Gela.Semantic_Types.Env_Index);
56
57 package Each_Use_Package is
58 -- Iterate over each name in use package clause and add it to Env
59
60 type Visiter is new Gela.Element_Visiters.Visiter with record
61 Set : Gela.Environments.Environment_Set_Access;
62 Env : Gela.Semantic_Types.Env_Index;
63 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
64 end record;
65
66 overriding procedure Identifier
67 (Self : in out Visiter;
68 Node : not null Gela.Elements.Identifiers.Identifier_Access);
69
70 overriding procedure Selected_Identifier
71 (Self : in out Visiter;
72 Node : not null Gela.Elements.Selected_Identifiers.
73 Selected_Identifier_Access);
74
75 overriding procedure Use_Package_Clause
76 (Self : in out Visiter;
77 Node : not null Gela.Elements.Use_Package_Clauses.
78 Use_Package_Clause_Access);
79 end Each_Use_Package;
80
81 package body Each_Use_Package is
82 overriding procedure Identifier
83 (Self : in out Visiter;
84 Node : not null Gela.Elements.Identifiers.Identifier_Access) is
85 begin
86 Self.Name := Node.Defining_Name;
87 end Identifier;
88
89 overriding procedure Selected_Identifier
90 (Self : in out Visiter;
91 Node : not null Gela.Elements.Selected_Identifiers.
92 Selected_Identifier_Access)
93 is
94 Selector : constant Gela.Elements.Selector_Names.
95 Selector_Name_Access := Node.Selector;
96 begin
97 Selector.Visit (Self);
98 end Selected_Identifier;
99
100 overriding procedure Use_Package_Clause
101 (Self : in out Visiter;
102 Node : not null Gela.Elements.Use_Package_Clauses.
103 Use_Package_Clause_Access)
104 is
105 List : constant Gela.Elements.Program_Unit_Names.
106 Program_Unit_Name_Sequence_Access := Node.Clause_Names;
107 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
108 begin
109 while Cursor.Has_Element loop
110 Cursor.Element.Visit (Self);
111
112 Self.Env := Self.Set.Add_Use_Package
113 (Index => Self.Env,
114 Name => Self.Name);
115
116 Cursor.Next;
117 end loop;
118 end Use_Package_Clause;
119
120 end Each_Use_Package;
121
122 procedure Add_Library_Level_Use_Clauses
123 (Comp : Gela.Compilations.Compilation_Access;
124 Decl : Gela.Elements.Element_Access;
125 Env : in out Gela.Semantic_Types.Env_Index)
126 is
127
128 package Get is
129
130 type Visiter is new Each_Use_Package.Visiter with null record;
131
132 overriding procedure Compilation_Unit_Body
133 (Self : in out Visiter;
134 Node : not null Gela.Elements.Compilation_Unit_Bodies.
135 Compilation_Unit_Body_Access);
136
137 overriding procedure Compilation_Unit_Declaration
138 (Self : in out Visiter;
139 Node : not null Gela.Elements.Compilation_Unit_Declarations.
140 Compilation_Unit_Declaration_Access);
141
142 overriding procedure Package_Declaration
143 (Self : in out Visiter;
144 Node : not null Gela.Elements.Package_Declarations.
145 Package_Declaration_Access);
146
147 overriding procedure Procedure_Body
148 (Self : in out Visiter;
149 Node : not null Gela.Elements.Procedure_Bodies.
150 Procedure_Body_Access);
151
152 overriding procedure With_Clause -- Use env.out instead
153 (Self : in out Visiter;
154 Node : not null Gela.Elements.With_Clauses.With_Clause_Access);
155 end Get;
156
157 package body Get is
158
159 overriding procedure Compilation_Unit_Body
160 (Self : in out Visiter;
161 Node : not null Gela.Elements.Compilation_Unit_Bodies.
162 Compilation_Unit_Body_Access)
163 is
164 List : constant Gela.Elements.Context_Items.
165 Context_Item_Sequence_Access := Node.Context_Clause_Elements;
166
167 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
168 begin
169 while Cursor.Has_Element loop
170 Cursor.Element.Visit (Self);
171 Cursor.Next;
172 end loop;
173 end Compilation_Unit_Body;
174
175 overriding procedure Compilation_Unit_Declaration
176 (Self : in out Visiter;
177 Node : not null Gela.Elements.Compilation_Unit_Declarations.
178 Compilation_Unit_Declaration_Access)
179 is
180 List : constant Gela.Elements.Context_Items.
181 Context_Item_Sequence_Access := Node.Context_Clause_Elements;
182
183 Cursor : Gela.Elements.Element_Sequence_Cursor'Class := List.First;
184 begin
185 while Cursor.Has_Element loop
186 Cursor.Element.Visit (Self);
187 Cursor.Next;
188 end loop;
189 end Compilation_Unit_Declaration;
190
191 overriding procedure Package_Declaration
192 (Self : in out Visiter;
193 Node : not null Gela.Elements.Package_Declarations.
194 Package_Declaration_Access) is
195 begin
196 Node.Enclosing_Element.Visit (Self);
197 end Package_Declaration;
198
199 overriding procedure Procedure_Body
200 (Self : in out Visiter;
201 Node : not null Gela.Elements.Procedure_Bodies.
202 Procedure_Body_Access) is
203 begin
204 Node.Enclosing_Element.Visit (Self);
205 end Procedure_Body;
206
207 overriding procedure With_Clause -- Use env.out instead
208 (Self : in out Visiter;
209 Node : not null Gela.Elements.With_Clauses.With_Clause_Access)
210 is
211 use type Gela.Lexical_Types.Symbol_List;
212
213 List : Gela.Lexical_Types.Symbol_List := Node.With_List;
214 begin
215 while List /= Gela.Lexical_Types.Empty_Symbol_List loop
216 Self.Env := Self.Set.Add_With_Clause
217 (Index => Self.Env,
218 Symbol => Comp.Context.Symbols.Head (List));
219 List := Comp.Context.Symbols.Tail (List);
220 end loop;
221 end With_Clause;
222
223 end Get;
224
225 Set : constant Gela.Environments.Environment_Set_Access :=
226 Comp.Context.Environment_Set;
227 Visiter : Get.Visiter := (Set, Env, null);
228 begin
229 Decl.Visit (Visiter);
230 Env := Visiter.Env;
231 end Add_Library_Level_Use_Clauses;
232
233 ----------------------------
234 -- Add_Name_Create_Region --
235 ----------------------------
236
237 function Add_Name_Create_Region
238 (Comp : Gela.Compilations.Compilation_Access;
239 Env : Gela.Semantic_Types.Env_Index;
240 Symbol : Gela.Lexical_Types.Symbol;
241 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
242 Decl : Gela.Elements.Element_Access)
243 return Gela.Semantic_Types.Env_Index
244 is
245 use type Gela.Semantic_Types.Env_Index;
246 use type Gela.Lexical_Types.Symbol;
247
248 Library_Level : constant Boolean :=
249 Env = Comp.Context.Environment_Set.Library_Level_Environment;
250
251 Env_0 : Gela.Semantic_Types.Env_Index;
252 Env_1 : Gela.Semantic_Types.Env_Index;
253 Env_2 : Gela.Semantic_Types.Env_Index;
254 begin
255 if Library_Level then
256 Env_0 := Parents_Declarative_Region (Comp, Symbol);
257
258 if Symbol = Gela.Lexical_Types.Predefined_Symbols.Standard then
259 Preprocess_Standard (Comp, Decl);
260 end if;
261
262 else
263 Env_0 := Env;
264 end if;
265
266 Env_1 := Comp.Context.Environment_Set.Add_Defining_Name
267 (Index => Env_0,
268 Symbol => Symbol,
269 Name => Name);
270
271 if Is_Enumeration (Decl) then
272 return Env_1;
273 end if;
274
275 Env_2 := Comp.Context.Environment_Set.Enter_Declarative_Region
276 (Index => Env_1,
277 Region => Name);
278
279 if Library_Level then
280 Add_Library_Level_Use_Clauses (Comp, Decl, Env_2);
281 end if;
282
283 return Env_2;
284 end Add_Name_Create_Region;
285
286 ---------------
287 -- Add_Names --
288 ---------------
289
290 function Add_Names
291 (Comp : Gela.Compilations.Compilation_Access;
292 Env : Gela.Semantic_Types.Env_Index;
293 List : Gela.Lexical_Types.Symbol_List;
294 Names : Gela.Elements.Defining_Identifiers
295 .Defining_Identifier_Sequence_Access)
296 return Gela.Semantic_Types.Env_Index
297 is
298 Tail : Gela.Lexical_Types.Symbol_List := List;
299 Env_1 : Gela.Semantic_Types.Env_Index := Env;
300 Symbol : Gela.Lexical_Types.Symbol;
301 Name : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
302 Cursor : Gela.Elements.Defining_Identifiers
303 .Defining_Identifier_Sequence_Cursor := Names.First;
304 Set : constant Gela.Symbol_Sets.Symbol_Set_Access :=
305 Comp.Context.Symbols;
306 begin
307 while Cursor.Has_Element loop
308 Name := Cursor.Element;
309 Symbol := Set.Head (Tail);
310 Tail := Set.Tail (Tail);
311 Cursor.Next;
312
313 Env_1 := Comp.Context.Environment_Set.Add_Defining_Name
314 (Index => Env_1,
315 Symbol => Symbol,
316 Name => Gela.Elements.Defining_Names
317 .Defining_Name_Access (Name));
318 end loop;
319
320 return Env_1;
321 end Add_Names;
322
323 -----------------------------
324 -- Add_Names_Create_Region --
325 -----------------------------
326
327 function Add_Names_Create_Region
328 (Comp : Gela.Compilations.Compilation_Access;
329 Env : Gela.Semantic_Types.Env_Index;
330 List : Gela.Lexical_Types.Symbol_List;
331 Names : Gela.Elements.Defining_Identifiers
332 .Defining_Identifier_Sequence_Access)
333 return Gela.Semantic_Types.Env_Index
334 is
335 Env_1 : Gela.Semantic_Types.Env_Index;
336 Env_2 : Gela.Semantic_Types.Env_Index;
337 Name : Gela.Elements.Defining_Identifiers.Defining_Identifier_Access;
338 Cursor : constant Gela.Elements.Defining_Identifiers
339 .Defining_Identifier_Sequence_Cursor := Names.First;
340 begin
341 Name := Cursor.Element;
342 Env_1 := Add_Names (Comp, Env, List, Names);
343
344 Env_2 := Comp.Context.Environment_Set.Enter_Declarative_Region
345 (Index => Env_1,
346 Region => Gela.Elements.Defining_Names.Defining_Name_Access (Name));
347
348 return Env_2;
349 end Add_Names_Create_Region;
350
351 ---------------------
352 -- Add_Use_Package --
353 ---------------------
354
355 function Add_Use_Package
356 (Comp : Gela.Compilations.Compilation_Access;
357 Env : Gela.Semantic_Types.Env_Index;
358 Node : not null Gela.Elements.Use_Package_Clauses.
359 Use_Package_Clause_Access)
360 return Gela.Semantic_Types.Env_Index
361 is
362 Set : constant Gela.Environments.Environment_Set_Access :=
363 Comp.Context.Environment_Set;
364 Visiter : Each_Use_Package.Visiter := (Set, Env, null);
365 begin
366 Node.Visit (Visiter);
367
368 return Visiter.Env;
369 end Add_Use_Package;
370
371 ------------------------------
372 -- Create_Completion_Region --
373 ------------------------------
374
375 function Create_Completion_Region
376 (Comp : Gela.Compilations.Compilation_Access;
377 Env : Gela.Semantic_Types.Env_Index;
378 Symbol : Gela.Lexical_Types.Symbol)
379 return Gela.Semantic_Types.Env_Index
380 is
381 Set : constant Gela.Environments.Environment_Set_Access :=
382 Comp.Context.Environment_Set;
383 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
384 Found : aliased Boolean := False;
385 Pos : constant Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class :=
386 Set.Visible (Env, null, Symbol, Found'Access);
387 begin
388 if Pos.Has_Element then
389 Name := Pos.Element;
390 return Set.Enter_Completion_Region (Env, Name);
391 else
392 return Env;
393 end if;
394 end Create_Completion_Region;
395
396 --------------------------------
397 -- Create_Function_Call_Value --
398 --------------------------------
399
400 function Create_Function_Call_Value
401 (Comp : Gela.Compilations.Compilation_Access;
402 Name : Gela.Semantic_Types.Value_Index;
403 Arguments : Gela.Semantic_Types.Value_Index)
404 return Gela.Semantic_Types.Value_Index
405 is
406 Result : Gela.Semantic_Types.Value_Index;
407 begin
408 Comp.Context.Values.Apply
409 (Name => Name,
410 Args => Arguments,
411 Value => Result);
412
413 return Result;
414 end Create_Function_Call_Value;
415
416 function Create_Numeric_Value
417 (Comp : Gela.Compilations.Compilation_Access;
418 Value : Gela.Lexical_Types.Token_Index)
419 return Gela.Semantic_Types.Value_Index
420 is
421 Token : constant Gela.Lexical_Types.Token := Comp.Get_Token (Value);
422 Source : constant League.Strings.Universal_String := Comp.Source;
423 Image : constant League.Strings.Universal_String :=
424 Source.Slice (Token.First, Token.Last);
425 Result : Gela.Semantic_Types.Value_Index;
426 begin
427 Comp.Context.Values.Numeric_Literal (Image, Result);
428
429 return Result;
430 end Create_Numeric_Value;
431
432 -------------------------
433 -- Create_String_Value --
434 -------------------------
435
436 function Create_String_Value
437 (Comp : Gela.Compilations.Compilation_Access;
438 Full_Name : Gela.Lexical_Types.Token_Index)
439 return Gela.Semantic_Types.Value_Index
440 is
441 Token : constant Gela.Lexical_Types.Token := Comp.Get_Token (Full_Name);
442 Source : constant League.Strings.Universal_String := Comp.Source;
443 Image : constant League.Strings.Universal_String :=
444 Source.Slice (Token.First, Token.Last);
445 Result : Gela.Semantic_Types.Value_Index;
446 begin
447 Comp.Context.Values.String_Literal
448 (Image.Slice (2, Image.Length - 1), Result);
449
450 return Result;
451 end Create_String_Value;
452
453 procedure End_Of_Compilation_Unit_Declaration
454 (Comp : Gela.Compilations.Compilation_Access;
455 Unit : Gela.Elements.Compilation_Unit_Declarations.
456 Compilation_Unit_Declaration_Access;
457 Symbol : Gela.Lexical_Types.Symbol;
458 Env : in out Gela.Semantic_Types.Env_Index)
459 is
460 use type Gela.Lexical_Types.Symbol;
461 begin
462 if Symbol = Gela.Lexical_Types.Predefined_Symbols.Standard then
463 Postprocess_Standard (Comp, Unit, Env);
464 end if;
465 end End_Of_Compilation_Unit_Declaration;
466
467 --------------------
468 -- Is_Enumeration --
469 --------------------
470
471 function Is_Enumeration
472 (Decl : Gela.Elements.Element_Access) return Boolean
473 is
474 package Get is
475
476 type Visiter is new Gela.Element_Visiters.Visiter with record
477 Result : Boolean := False;
478 end record;
479
480 overriding procedure Full_Type_Declaration
481 (Self : in out Visiter;
482 Node : not null Gela.Elements.Full_Type_Declarations.
483 Full_Type_Declaration_Access);
484
485 overriding procedure Enumeration_Type_Definition
486 (Self : in out Visiter;
487 Node : not null Gela.Elements.Enumeration_Type_Definitions.
488 Enumeration_Type_Definition_Access);
489
490 end Get;
491
492 package body Get is
493
494 overriding procedure Full_Type_Declaration
495 (Self : in out Visiter;
496 Node : not null Gela.Elements.Full_Type_Declarations.
497 Full_Type_Declaration_Access)
498 is
499 View : constant Gela.Elements.Type_Definitions.
500 Type_Definition_Access := Node.Type_Declaration_View;
501 begin
502 View.Visit (Self);
503 end Full_Type_Declaration;
504
505 overriding procedure Enumeration_Type_Definition
506 (Self : in out Visiter;
507 Node : not null Gela.Elements.Enumeration_Type_Definitions.
508 Enumeration_Type_Definition_Access)
509 is
510 pragma Unreferenced (Node);
511 begin
512 Self.Result := True;
513 end Enumeration_Type_Definition;
514
515 end Get;
516
517 use type Gela.Elements.Element_Access;
518 V : Get.Visiter;
519 begin
520 if Decl /= null then
521 Decl.Visit (V);
522 end if;
523
524 return V.Result;
525 end Is_Enumeration;
526
527 ------------------------------
528 -- Leave_Declarative_Region --
529 ------------------------------
530
531 function Leave_Declarative_Region
532 (Comp : Gela.Compilations.Compilation_Access;
533 Index : Gela.Semantic_Types.Env_Index;
534 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
535 return Gela.Semantic_Types.Env_Index is
536 begin
537 if Is_Enumeration (Name.Enclosing_Element) then
538 return Index;
539 else
540 return Comp.Context.Environment_Set.Leave_Declarative_Region (Index);
541 end if;
542 end Leave_Declarative_Region;
543
544 --------------------------------
545 -- Parents_Declarative_Region --
546 --------------------------------
547
548 function Parents_Declarative_Region
549 (Comp : Gela.Compilations.Compilation_Access;
550 Full_Name : Gela.Lexical_Types.Symbol)
551 return Gela.Semantic_Types.Env_Index
552 is
553 use type Gela.Lexical_Types.Symbol;
554
555 Set : constant Gela.Symbol_Sets.Symbol_Set_Access :=
556 Comp.Context.Symbols;
557 Parent : constant Gela.Lexical_Types.Symbol := Set.Parent (Full_Name);
558 Result : Gela.Semantic_Types.Env_Index;
559 begin
560 if Parent = Gela.Lexical_Types.No_Symbol then
561 return 0;
562 end if;
563
564 Result := Comp.Context.Environment_Set.Library_Unit_Environment (Parent);
565
566 return Result;
567 end Parents_Declarative_Region;
568
569 --------------------------
570 -- Postprocess_Standard --
571 --------------------------
572
573 procedure Postprocess_Standard
574 (Comp : Gela.Compilations.Compilation_Access;
575 Unit : Gela.Elements.Compilation_Unit_Declarations.
576 Compilation_Unit_Declaration_Access;
577 Env : in out Gela.Semantic_Types.Env_Index)
578 is
579 pragma Unreferenced (Unit);
580
581 function Create_Operator
582 (Operator_Symbol : Gela.Lexical_Types.Symbol;
583 Type_Symbol : Gela.Lexical_Types.Symbol)
584 return Gela.Elements.Function_Declarations.
585 Function_Declaration_Access;
586
587 function Create_Subtype
588 (Type_Symbol : Gela.Lexical_Types.Symbol)
589 return Gela.Elements.Subtype_Mark_Or_Access_Definitions.
590 Subtype_Mark_Or_Access_Definition_Access;
591
592 function Get_Type
593 (Type_Symbol : Gela.Lexical_Types.Symbol)
594 return Gela.Elements.Defining_Names.Defining_Name_Access;
595
596 procedure Set_Part_Of_Implicit
597 (Element : access Gela.Elements.Element'Class);
598
599 Env_Set : constant Gela.Environments.Environment_Set_Access :=
600 Comp.Context.Environment_Set;
601
602 Factory : constant Gela.Element_Factories.Element_Factory_Access :=
603 Comp.Factory;
604
605 ---------------------
606 -- Create_Operator --
607 ---------------------
608
609 function Create_Operator
610 (Operator_Symbol : Gela.Lexical_Types.Symbol;
611 Type_Symbol : Gela.Lexical_Types.Symbol)
612 return Gela.Elements.Function_Declarations.
613 Function_Declaration_Access
614 is
615 FD : Gela.Elements.Function_Declarations.Function_Declaration_Access;
616
617 Oper : constant Gela.Elements.Defining_Operator_Symbols.
618 Defining_Operator_Symbol_Access :=
619 Factory.Defining_Operator_Symbol
620 (Operator_Symbol_Token => 0);
621
622 Name : Gela.Elements.Defining_Designators.Defining_Designator_Access;
623
624 Param : Gela.Elements.Parameter_Specifications.
625 Parameter_Specification_Access;
626
627 Params : constant Gela.Elements.Parameter_Specifications.
628 Parameter_Specification_Sequence_Access :=
629 Factory.Parameter_Specification_Sequence;
630
631 Mark : Gela.Elements.Subtype_Mark_Or_Access_Definitions.
632 Subtype_Mark_Or_Access_Definition_Access;
633 begin
634 Oper.Set_Full_Name (Operator_Symbol);
635 Set_Part_Of_Implicit (Oper);
636
637 Name := Gela.Elements.Defining_Designators.Defining_Designator_Access
638 (Oper);
639
640 for J in 1 .. 2 loop
641 Mark := Create_Subtype (Type_Symbol);
642
643 Param := Factory.Parameter_Specification
644 (Names =>
645 Factory.Defining_Identifier_Sequence,
646 Colon_Token => 0,
647 Aliased_Token => 0,
648 In_Token => 0,
649 Out_Token => 0,
650 Not_Token => 0,
651 Null_Token => 0,
652 Object_Declaration_Subtype => Mark,
653 Assignment_Token => 0,
654 Initialization_Expression => null);
655 Params.Append (Param);
656
657 Set_Part_Of_Implicit (Param);
658 end loop;
659
660 Mark := Create_Subtype (Type_Symbol);
661
662 FD := Factory.Function_Declaration
663 (Not_Token => 0,
664 Overriding_Token => 0,
665 Function_Token => 0,
666 Names => Name,
667 Lp_Token => 0,
668 Parameter_Profile => Params,
669 Rp_Token => 0,
670 Return_Token => 0,
671 Return_Not_Token => 0,
672 Return_Null_Token => 0,
673 Result_Subtype => Mark,
674 Is_Token => 0,
675 Abstract_Token => 0,
676 Result_Expression => null,
677 Renames_Token => 0,
678 Renamed_Entity => null,
679 Separate_Token => 0,
680 Aspect_Specifications => Factory.Aspect_Specification_Sequence,
681 Semicolon_Token => 0);
682
683 Set_Part_Of_Implicit (FD);
684 FD.Set_Corresponding_Type (Get_Type (Type_Symbol).Enclosing_Element);
685
686 Env := Env_Set.Add_Defining_Name
687 (Index => Env,
688 Symbol => Operator_Symbol,
689 Name => Gela.Elements.Defining_Names.Defining_Name_Access
690 (Name));
691
692 return FD;
693 end Create_Operator;
694
695 --------------------
696 -- Create_Subtype --
697 --------------------
698
699 function Create_Subtype
700 (Type_Symbol : Gela.Lexical_Types.Symbol)
701 return Gela.Elements.Subtype_Mark_Or_Access_Definitions.
702 Subtype_Mark_Or_Access_Definition_Access
703 is
704 Identifier : Gela.Elements.Identifiers.Identifier_Access;
705
706 Mark : Gela.Elements.Subtype_Mark_Or_Access_Definitions.
707 Subtype_Mark_Or_Access_Definition_Access;
708 begin
709 Identifier := Factory.Identifier (Identifier_Token => 0);
710 Identifier.Set_Full_Name (Type_Symbol);
711 Identifier.Set_Defining_Name (Get_Type (Type_Symbol));
712 Set_Part_Of_Implicit (Identifier);
713
714 Mark := Gela.Elements.Subtype_Mark_Or_Access_Definitions.
715 Subtype_Mark_Or_Access_Definition_Access (Identifier);
716
717 return Mark;
718 end Create_Subtype;
719
720 --------------
721 -- Get_Type --
722 --------------
723
724 function Get_Type
725 (Type_Symbol : Gela.Lexical_Types.Symbol)
726 return Gela.Elements.Defining_Names.Defining_Name_Access
727 is
728 Pos : constant Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
729 := Env_Set.Direct_Visible (Env, Type_Symbol);
730 begin
731 if Pos.Has_Element then
732 return Pos.Element;
733 else
734 raise Constraint_Error;
735 end if;
736 end Get_Type;
737
738 --------------------------
739 -- Set_Part_Of_Implicit --
740 --------------------------
741
742 procedure Set_Part_Of_Implicit
743 (Element : access Gela.Elements.Element'Class)
744 is
745 Node : constant Gela.Nodes.Node_Access :=
746 Gela.Nodes.Node_Access (Element);
747 begin
748 Node.Set_Part_Of_Implicit;
749 end Set_Part_Of_Implicit;
750
751 FD : Gela.Elements.Function_Declarations.Function_Declaration_Access;
752 pragma Unreferenced (FD);
753 begin
754 FD := Create_Operator
755 (Operator_Symbol => Gela.Lexical_Types.Operators.Hyphen_Operator,
756 Type_Symbol => Gela.Lexical_Types.Predefined_Symbols.Integer);
757
758 FD := Create_Operator
759 (Operator_Symbol => Gela.Lexical_Types.Operators.Ampersand_Operator,
760 Type_Symbol => Gela.Lexical_Types.Predefined_Symbols.String);
761 end Postprocess_Standard;
762
763 -------------------------
764 -- Preprocess_Standard --
765 -------------------------
766
767 procedure Preprocess_Standard
768 (Comp : Gela.Compilations.Compilation_Access;
769 Unit : Gela.Elements.Element_Access) is
770 begin
771 Gela.Plain_Type_Managers.Type_Manager_Access
772 (Comp.Context.Types).Initialize (Unit);
773 end Preprocess_Standard;
774
775end Gela.Pass_Utils;
Note: See TracBrowser for help on using the repository browser.