source: trunk/ada-2012/src/semantic/gela-library_environments.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.1 KB
Line 
1-- with Gela.Defining_Name_Cursors;
2with Gela.Compilation_Units;
3with Gela.Compilation_Unit_Sets;
4with Gela.Element_Visiters;
5
6with Gela.Elements.Compilation_Unit_Bodies;
7with Gela.Elements.Compilation_Unit_Declarations;
8with Gela.Elements.Subunits;
9with Gela.Elements.Library_Unit_Bodies;
10with Gela.Elements.Library_Unit_Declarations;
11with Gela.Elements.Proper_Bodies;
12with Gela.Elements.Function_Bodies;
13with Gela.Elements.Package_Bodies;
14with Gela.Elements.Procedure_Bodies;
15with Gela.Elements.Function_Declarations;
16with Gela.Elements.Function_Instantiations;
17with Gela.Elements.Generic_Function_Declarations;
18with Gela.Elements.Generic_Function_Renamings;
19with Gela.Elements.Generic_Package_Declarations;
20with Gela.Elements.Generic_Package_Renamings;
21with Gela.Elements.Generic_Procedure_Declarations;
22with Gela.Elements.Generic_Procedure_Renamings;
23with Gela.Elements.Package_Declarations;
24with Gela.Elements.Package_Instantiations;
25with Gela.Elements.Package_Renaming_Declarations;
26with Gela.Elements.Procedure_Declarations;
27with Gela.Elements.Procedure_Instantiations;
28with Gela.Elements.Protected_Bodies;
29with Gela.Elements.Task_Bodies;
30with Gela.Elements.Defining_Designators;
31with Gela.Elements.Defining_Program_Unit_Names;
32with Gela.Elements.Defining_Identifiers;
33with Gela.Elements.Defining_Expanded_Unit_Names;
34with Gela.Elements.Defining_Operator_Symbols;
35with Gela.Symbol_Sets;
36
37package body Gela.Library_Environments is
38
39 package Library_Cursor is
40 type Defining_Name_Cursor is
41 new Gela.Defining_Name_Cursors.Defining_Name_Cursor
42 with record
43 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
44 end record;
45
46 overriding function Has_Element
47 (Self : Defining_Name_Cursor) return Boolean;
48
49 overriding function Element
50 (Self : Defining_Name_Cursor)
51 return Gela.Elements.Defining_Names.Defining_Name_Access;
52
53 overriding procedure Next (Self : in out Defining_Name_Cursor);
54
55 end Library_Cursor;
56
57 package Get_Defining_Name_Visiter is
58
59 type Visiter is new Gela.Element_Visiters.Visiter with record
60 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
61 end record;
62
63 overriding procedure Compilation_Unit_Body
64 (Self : in out Visiter;
65 Node : not null Gela.Elements.Compilation_Unit_Bodies.
66 Compilation_Unit_Body_Access);
67
68 overriding procedure Compilation_Unit_Declaration
69 (Self : in out Visiter;
70 Node : not null Gela.Elements.Compilation_Unit_Declarations.
71 Compilation_Unit_Declaration_Access);
72
73 overriding procedure Defining_Expanded_Unit_Name
74 (Self : in out Visiter;
75 Node : not null Gela.Elements.Defining_Expanded_Unit_Names.
76 Defining_Expanded_Unit_Name_Access);
77
78 overriding procedure Defining_Identifier
79 (Self : in out Visiter;
80 Node : not null Gela.Elements.Defining_Identifiers.
81 Defining_Identifier_Access);
82
83 overriding procedure Defining_Operator_Symbol
84 (Self : in out Visiter;
85 Node : not null Gela.Elements.Defining_Operator_Symbols.
86 Defining_Operator_Symbol_Access);
87
88 overriding procedure Function_Body
89 (Self : in out Visiter;
90 Node : not null Gela.Elements.Function_Bodies.Function_Body_Access);
91
92 overriding procedure Function_Declaration
93 (Self : in out Visiter;
94 Node : not null Gela.Elements.Function_Declarations.
95 Function_Declaration_Access);
96
97 overriding procedure Function_Instantiation
98 (Self : in out Visiter;
99 Node : not null Gela.Elements.Function_Instantiations.
100 Function_Instantiation_Access);
101
102 overriding procedure Generic_Function_Declaration
103 (Self : in out Visiter;
104 Node : not null Gela.Elements.Generic_Function_Declarations.
105 Generic_Function_Declaration_Access);
106
107 overriding procedure Generic_Function_Renaming
108 (Self : in out Visiter;
109 Node : not null Gela.Elements.Generic_Function_Renamings.
110 Generic_Function_Renaming_Access);
111
112 overriding procedure Generic_Package_Declaration
113 (Self : in out Visiter;
114 Node : not null Gela.Elements.Generic_Package_Declarations.
115 Generic_Package_Declaration_Access);
116
117 overriding procedure Generic_Package_Renaming
118 (Self : in out Visiter;
119 Node : not null Gela.Elements.Generic_Package_Renamings.
120 Generic_Package_Renaming_Access);
121
122 overriding procedure Generic_Procedure_Declaration
123 (Self : in out Visiter;
124 Node : not null Gela.Elements.Generic_Procedure_Declarations.
125 Generic_Procedure_Declaration_Access);
126
127 overriding procedure Generic_Procedure_Renaming
128 (Self : in out Visiter;
129 Node : not null Gela.Elements.Generic_Procedure_Renamings.
130 Generic_Procedure_Renaming_Access);
131
132 overriding procedure Package_Body
133 (Self : in out Visiter;
134 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access);
135
136 overriding procedure Package_Declaration
137 (Self : in out Visiter;
138 Node : not null Gela.Elements.Package_Declarations.
139 Package_Declaration_Access);
140
141 overriding procedure Package_Instantiation
142 (Self : in out Visiter;
143 Node : not null Gela.Elements.Package_Instantiations.
144 Package_Instantiation_Access);
145
146 overriding procedure Package_Renaming_Declaration
147 (Self : in out Visiter;
148 Node : not null Gela.Elements.Package_Renaming_Declarations.
149 Package_Renaming_Declaration_Access);
150
151 overriding procedure Procedure_Body
152 (Self : in out Visiter;
153 Node : not null Gela.Elements.Procedure_Bodies.Procedure_Body_Access);
154
155 overriding procedure Procedure_Declaration
156 (Self : in out Visiter;
157 Node : not null Gela.Elements.Procedure_Declarations.
158 Procedure_Declaration_Access);
159
160 overriding procedure Procedure_Instantiation
161 (Self : in out Visiter;
162 Node : not null Gela.Elements.Procedure_Instantiations.
163 Procedure_Instantiation_Access);
164
165 overriding procedure Protected_Body
166 (Self : in out Visiter;
167 Node : not null Gela.Elements.Protected_Bodies.Protected_Body_Access);
168
169 overriding procedure Subunit
170 (Self : in out Visiter;
171 Node : not null Gela.Elements.Subunits.Subunit_Access);
172
173 overriding procedure Task_Body
174 (Self : in out Visiter;
175 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access);
176
177 end Get_Defining_Name_Visiter;
178
179 -------------------------------
180 -- Get_Defining_Name_Visiter --
181 -------------------------------
182
183 package body Get_Defining_Name_Visiter is
184
185 ---------------------------
186 -- Compilation_Unit_Body --
187 ---------------------------
188
189 overriding procedure Compilation_Unit_Body
190 (Self : in out Visiter;
191 Node : not null Gela.Elements.Compilation_Unit_Bodies.
192 Compilation_Unit_Body_Access)
193 is
194 Decl : constant Gela.Elements.Library_Unit_Bodies.
195 Library_Unit_Body_Access := Node.Unit_Declaration;
196 begin
197 Decl.Visit (Self);
198 end Compilation_Unit_Body;
199
200 ----------------------------------
201 -- Compilation_Unit_Declaration --
202 ----------------------------------
203
204 overriding procedure Compilation_Unit_Declaration
205 (Self : in out Visiter;
206 Node : not null Gela.Elements.Compilation_Unit_Declarations.
207 Compilation_Unit_Declaration_Access)
208 is
209 Decl : constant Gela.Elements.Library_Unit_Declarations.
210 Library_Unit_Declaration_Access := Node.Unit_Declaration;
211 begin
212 Decl.Visit (Self);
213 end Compilation_Unit_Declaration;
214
215 ---------------------------------
216 -- Defining_Expanded_Unit_Name --
217 ---------------------------------
218
219 overriding procedure Defining_Expanded_Unit_Name
220 (Self : in out Visiter;
221 Node : not null Gela.Elements.Defining_Expanded_Unit_Names.
222 Defining_Expanded_Unit_Name_Access) is
223 begin
224 Self.Name := Gela.Elements.Defining_Names.Defining_Name_Access (Node);
225 end Defining_Expanded_Unit_Name;
226
227 -------------------------
228 -- Defining_Identifier --
229 -------------------------
230
231 overriding procedure Defining_Identifier
232 (Self : in out Visiter;
233 Node : not null Gela.Elements.Defining_Identifiers.
234 Defining_Identifier_Access) is
235 begin
236 Self.Name := Gela.Elements.Defining_Names.Defining_Name_Access (Node);
237 end Defining_Identifier;
238
239 ------------------------------
240 -- Defining_Operator_Symbol --
241 ------------------------------
242
243 overriding procedure Defining_Operator_Symbol
244 (Self : in out Visiter;
245 Node : not null Gela.Elements.Defining_Operator_Symbols.
246 Defining_Operator_Symbol_Access) is
247 begin
248 Self.Name := Gela.Elements.Defining_Names.Defining_Name_Access (Node);
249 end Defining_Operator_Symbol;
250
251 -------------------
252 -- Function_Body --
253 -------------------
254
255 overriding procedure Function_Body
256 (Self : in out Visiter;
257 Node : not null Gela.Elements.Function_Bodies.Function_Body_Access)
258 is
259 Name : constant Gela.Elements.Defining_Designators.
260 Defining_Designator_Access := Node.Names;
261 begin
262 Name.Visit (Self);
263 end Function_Body;
264
265 --------------------------
266 -- Function_Declaration --
267 --------------------------
268
269 overriding procedure Function_Declaration
270 (Self : in out Visiter;
271 Node : not null Gela.Elements.Function_Declarations.
272 Function_Declaration_Access)
273 is
274 Name : constant Gela.Elements.Defining_Designators.
275 Defining_Designator_Access := Node.Names;
276 begin
277 Name.Visit (Self);
278 end Function_Declaration;
279
280 ----------------------------
281 -- Function_Instantiation --
282 ----------------------------
283
284 overriding procedure Function_Instantiation
285 (Self : in out Visiter;
286 Node : not null Gela.Elements.Function_Instantiations.
287 Function_Instantiation_Access)
288 is
289 Name : constant Gela.Elements.Defining_Designators.
290 Defining_Designator_Access := Node.Names;
291 begin
292 Name.Visit (Self);
293 end Function_Instantiation;
294
295 ----------------------------------
296 -- Generic_Function_Declaration --
297 ----------------------------------
298
299 overriding procedure Generic_Function_Declaration
300 (Self : in out Visiter;
301 Node : not null Gela.Elements.Generic_Function_Declarations.
302 Generic_Function_Declaration_Access)
303 is
304 Name : constant Gela.Elements.Defining_Designators.
305 Defining_Designator_Access := Node.Names;
306 begin
307 Name.Visit (Self);
308 end Generic_Function_Declaration;
309
310 -------------------------------
311 -- Generic_Function_Renaming --
312 -------------------------------
313
314 overriding procedure Generic_Function_Renaming
315 (Self : in out Visiter;
316 Node : not null Gela.Elements.Generic_Function_Renamings.
317 Generic_Function_Renaming_Access)
318 is
319 Name : constant Gela.Elements.Defining_Program_Unit_Names.
320 Defining_Program_Unit_Name_Access := Node.Names;
321 begin
322 Name.Visit (Self);
323 end Generic_Function_Renaming;
324
325 ---------------------------------
326 -- Generic_Package_Declaration --
327 ---------------------------------
328
329 overriding procedure Generic_Package_Declaration
330 (Self : in out Visiter;
331 Node : not null Gela.Elements.Generic_Package_Declarations.
332 Generic_Package_Declaration_Access)
333 is
334 Name : constant Gela.Elements.Defining_Program_Unit_Names.
335 Defining_Program_Unit_Name_Access := Node.Names;
336 begin
337 Name.Visit (Self);
338 end Generic_Package_Declaration;
339
340 ------------------------------
341 -- Generic_Package_Renaming --
342 ------------------------------
343
344 overriding procedure Generic_Package_Renaming
345 (Self : in out Visiter;
346 Node : not null Gela.Elements.Generic_Package_Renamings.
347 Generic_Package_Renaming_Access)
348 is
349 Name : constant Gela.Elements.Defining_Program_Unit_Names.
350 Defining_Program_Unit_Name_Access := Node.Names;
351 begin
352 Name.Visit (Self);
353 end Generic_Package_Renaming;
354
355 -----------------------------------
356 -- Generic_Procedure_Declaration --
357 -----------------------------------
358
359 overriding procedure Generic_Procedure_Declaration
360 (Self : in out Visiter;
361 Node : not null Gela.Elements.Generic_Procedure_Declarations.
362 Generic_Procedure_Declaration_Access)
363 is
364 Name : constant Gela.Elements.Defining_Program_Unit_Names.
365 Defining_Program_Unit_Name_Access := Node.Names;
366 begin
367 Name.Visit (Self);
368 end Generic_Procedure_Declaration;
369
370 --------------------------------
371 -- Generic_Procedure_Renaming --
372 --------------------------------
373
374 overriding procedure Generic_Procedure_Renaming
375 (Self : in out Visiter;
376 Node : not null Gela.Elements.Generic_Procedure_Renamings.
377 Generic_Procedure_Renaming_Access)
378 is
379 Name : constant Gela.Elements.Defining_Program_Unit_Names.
380 Defining_Program_Unit_Name_Access := Node.Names;
381 begin
382 Name.Visit (Self);
383 end Generic_Procedure_Renaming;
384
385 ------------------
386 -- Package_Body --
387 ------------------
388
389 overriding procedure Package_Body
390 (Self : in out Visiter;
391 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access)
392 is
393 Name : constant Gela.Elements.Defining_Program_Unit_Names.
394 Defining_Program_Unit_Name_Access := Node.Names;
395 begin
396 Name.Visit (Self);
397 end Package_Body;
398
399 -------------------------
400 -- Package_Declaration --
401 -------------------------
402
403 overriding procedure Package_Declaration
404 (Self : in out Visiter;
405 Node : not null Gela.Elements.Package_Declarations.
406 Package_Declaration_Access)
407 is
408 Name : constant Gela.Elements.Defining_Program_Unit_Names.
409 Defining_Program_Unit_Name_Access := Node.Names;
410 begin
411 Name.Visit (Self);
412 end Package_Declaration;
413
414 ---------------------------
415 -- Package_Instantiation --
416 ---------------------------
417
418 overriding procedure Package_Instantiation
419 (Self : in out Visiter;
420 Node : not null Gela.Elements.Package_Instantiations.
421 Package_Instantiation_Access)
422 is
423 Name : constant Gela.Elements.Defining_Program_Unit_Names.
424 Defining_Program_Unit_Name_Access := Node.Names;
425 begin
426 Name.Visit (Self);
427 end Package_Instantiation;
428
429 ----------------------------------
430 -- Package_Renaming_Declaration --
431 ----------------------------------
432
433 overriding procedure Package_Renaming_Declaration
434 (Self : in out Visiter;
435 Node : not null Gela.Elements.Package_Renaming_Declarations.
436 Package_Renaming_Declaration_Access)
437 is
438 Name : constant Gela.Elements.Defining_Program_Unit_Names.
439 Defining_Program_Unit_Name_Access := Node.Names;
440 begin
441 Name.Visit (Self);
442 end Package_Renaming_Declaration;
443
444 --------------------
445 -- Procedure_Body --
446 --------------------
447
448 overriding procedure Procedure_Body
449 (Self : in out Visiter;
450 Node : not null Gela.Elements.Procedure_Bodies.Procedure_Body_Access)
451 is
452 Name : constant Gela.Elements.Defining_Program_Unit_Names.
453 Defining_Program_Unit_Name_Access := Node.Names;
454 begin
455 Name.Visit (Self);
456 end Procedure_Body;
457
458 ---------------------------
459 -- Procedure_Declaration --
460 ---------------------------
461
462 overriding procedure Procedure_Declaration
463 (Self : in out Visiter;
464 Node : not null Gela.Elements.Procedure_Declarations.
465 Procedure_Declaration_Access)
466 is
467 Name : constant Gela.Elements.Defining_Program_Unit_Names.
468 Defining_Program_Unit_Name_Access := Node.Names;
469 begin
470 Name.Visit (Self);
471 end Procedure_Declaration;
472
473 -----------------------------
474 -- Procedure_Instantiation --
475 -----------------------------
476
477 overriding procedure Procedure_Instantiation
478 (Self : in out Visiter;
479 Node : not null Gela.Elements.Procedure_Instantiations.
480 Procedure_Instantiation_Access)
481 is
482 Name : constant Gela.Elements.Defining_Program_Unit_Names.
483 Defining_Program_Unit_Name_Access := Node.Names;
484 begin
485 Name.Visit (Self);
486 end Procedure_Instantiation;
487
488 --------------------
489 -- Protected_Body --
490 --------------------
491
492 overriding procedure Protected_Body
493 (Self : in out Visiter;
494 Node : not null Gela.Elements.Protected_Bodies.Protected_Body_Access)
495 is
496 Name : constant Gela.Elements.Defining_Identifiers.
497 Defining_Identifier_Access := Node.Names;
498 begin
499 Name.Visit (Self);
500 end Protected_Body;
501
502 -------------
503 -- Subunit --
504 -------------
505
506 overriding procedure Subunit
507 (Self : in out Visiter;
508 Node : not null Gela.Elements.Subunits.Subunit_Access)
509 is
510 Decl : constant Gela.Elements.Proper_Bodies.Proper_Body_Access :=
511 Node.Unit_Declaration;
512 begin
513 Decl.Visit (Self);
514 end Subunit;
515
516 ---------------
517 -- Task_Body --
518 ---------------
519
520 overriding procedure Task_Body
521 (Self : in out Visiter;
522 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access)
523 is
524 Name : constant Gela.Elements.Defining_Identifiers.
525 Defining_Identifier_Access := Node.Names;
526 begin
527 Name.Visit (Self);
528 end Task_Body;
529
530 end Get_Defining_Name_Visiter;
531
532 --------------------
533 -- Library_Cursor --
534 --------------------
535
536 package body Library_Cursor is
537
538 -----------------
539 -- Has_Element --
540 -----------------
541
542 overriding function Has_Element
543 (Self : Defining_Name_Cursor) return Boolean
544 is
545 use type Gela.Elements.Defining_Names.Defining_Name_Access;
546 begin
547 return Self.Name /= null;
548 end Has_Element;
549
550 -------------
551 -- Element --
552 -------------
553
554 overriding function Element
555 (Self : Defining_Name_Cursor)
556 return Gela.Elements.Defining_Names.Defining_Name_Access is
557 begin
558 return Self.Name;
559 end Element;
560
561 ----------
562 -- Next --
563 ----------
564
565 overriding procedure Next (Self : in out Defining_Name_Cursor) is
566 begin
567 Self.Name := null;
568 end Next;
569
570 end Library_Cursor;
571
572 -----------------------
573 -- Add_Defining_Name --
574 -----------------------
575
576 overriding function Add_Defining_Name
577 (Self : in out Environment_Set;
578 Index : Gela.Semantic_Types.Env_Index;
579 Symbol : Gela.Lexical_Types.Symbol;
580 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
581 return Gela.Semantic_Types.Env_Index is
582 begin
583 raise Program_Error;
584 return 0;
585 end Add_Defining_Name;
586
587 ---------------------
588 -- Add_Use_Package --
589 ---------------------
590
591 overriding function Add_Use_Package
592 (Self : in out Environment_Set;
593 Index : Gela.Semantic_Types.Env_Index;
594 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
595 return Gela.Semantic_Types.Env_Index is
596 begin
597 raise Program_Error;
598 return 0;
599 end Add_Use_Package;
600
601 overriding function Add_With_Clause
602 (Self : in out Environment_Set;
603 Index : Gela.Semantic_Types.Env_Index;
604 Symbol : Gela.Lexical_Types.Symbol)
605 return Gela.Semantic_Types.Env_Index
606 is
607 pragma Unreferenced (Self);
608 pragma Unreferenced (Symbol);
609 begin
610 return Index;
611 end Add_With_Clause;
612
613 --------------------
614 -- Direct_Visible --
615 --------------------
616
617 overriding function Direct_Visible
618 (Self : access Environment_Set;
619 Index : Gela.Semantic_Types.Env_Index;
620 Symbol : Gela.Lexical_Types.Symbol)
621 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
622 is
623 use type Gela.Semantic_Types.Env_Index;
624 use type Gela.Compilation_Units.Compilation_Unit_Access;
625 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
626 Units : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
627 begin
628 if Index /= Library_Env then
629 return Library_Cursor.Defining_Name_Cursor'(Name => null);
630 end if;
631
632 Units := Self.Context.Library_Unit_Declarations;
633 Unit := Units.Find (Symbol);
634
635 if Unit = null then
636 Units := Self.Context.Compilation_Unit_Bodies;
637 Unit := Units.Find (Symbol);
638 end if;
639
640 return Result : Library_Cursor.Defining_Name_Cursor do
641 if Unit /= null then
642 declare
643 V : Get_Defining_Name_Visiter.Visiter;
644 begin
645 Unit.Tree.Visit (V);
646 Result.Name := V.Name;
647 end;
648 end if;
649 end return;
650 end Direct_Visible;
651
652 -----------------------
653 -- Empty_Environment --
654 -----------------------
655
656 overriding function Empty_Environment
657 (Self : Environment_Set) return Gela.Semantic_Types.Env_Index
658 is
659 pragma Unreferenced (Self);
660 begin
661 return 0;
662 end Empty_Environment;
663
664 -----------------------------
665 -- Enter_Completion_Region --
666 -----------------------------
667
668 overriding function Enter_Completion_Region
669 (Self : access Environment_Set;
670 Index : Gela.Semantic_Types.Env_Index;
671 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
672 return Gela.Semantic_Types.Env_Index is
673 begin
674 raise Program_Error;
675 return Self.Enter_Completion_Region (Index, Region);
676 end Enter_Completion_Region;
677
678 ------------------------------
679 -- Enter_Declarative_Region --
680 ------------------------------
681
682 overriding function Enter_Declarative_Region
683 (Self : access Environment_Set;
684 Index : Gela.Semantic_Types.Env_Index;
685 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
686 return Gela.Semantic_Types.Env_Index is
687 begin
688 raise Program_Error;
689 return Self.Enter_Declarative_Region (Index, Region);
690 end Enter_Declarative_Region;
691
692 ------------------------------
693 -- Leave_Declarative_Region --
694 ------------------------------
695
696 overriding function Leave_Declarative_Region
697 (Self : access Environment_Set;
698 Index : Gela.Semantic_Types.Env_Index)
699 return Gela.Semantic_Types.Env_Index is
700 begin
701 raise Program_Error;
702 return Self.Leave_Declarative_Region (Index);
703 end Leave_Declarative_Region;
704
705 -------------------------------
706 -- Library_Level_Environment --
707 -------------------------------
708
709 overriding function Library_Level_Environment
710 (Self : Environment_Set)
711 return Gela.Semantic_Types.Env_Index
712 is
713 pragma Unreferenced (Self);
714 begin
715 return Library_Env;
716 end Library_Level_Environment;
717
718 ------------------------------
719 -- Library_Unit_Environment --
720 ------------------------------
721
722 overriding function Library_Unit_Environment
723 (Self : access Environment_Set;
724 Symbol : Gela.Lexical_Types.Symbol)
725 return Gela.Semantic_Types.Env_Index
726 is
727 pragma Unreferenced (Self);
728 pragma Unreferenced (Symbol);
729 begin
730 return 0;
731 end Library_Unit_Environment;
732
733 ----------------------------------
734 -- Set_Library_Unit_Environment --
735 ----------------------------------
736
737 overriding procedure Set_Library_Unit_Environment
738 (Self : access Environment_Set;
739 Symbol : Gela.Lexical_Types.Symbol;
740 Value : Gela.Semantic_Types.Env_Index) is
741 begin
742 raise Constraint_Error;
743 end Set_Library_Unit_Environment;
744
745 -----------------
746 -- Use_Visible --
747 -----------------
748
749 overriding function Use_Visible
750 (Self : access Environment_Set;
751 Index : Gela.Semantic_Types.Env_Index;
752 Symbol : Gela.Lexical_Types.Symbol)
753 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
754 is
755 pragma Unreferenced (Self);
756 pragma Unreferenced (Index);
757 pragma Unreferenced (Symbol);
758
759 -- No use clause considered at library level
760 Result : Library_Cursor.Defining_Name_Cursor;
761 begin
762 return Result;
763 end Use_Visible;
764
765 -------------
766 -- Visible --
767 -------------
768
769 overriding function Visible
770 (Self : access Environment_Set;
771 Index : Gela.Semantic_Types.Env_Index;
772 Region : Gela.Elements.Defining_Names.Defining_Name_Access;
773 Symbol : Gela.Lexical_Types.Symbol;
774 Found : access Boolean)
775 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
776 is
777 use type Gela.Semantic_Types.Env_Index;
778 use type Gela.Compilation_Units.Compilation_Unit_Access;
779 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
780 Units : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
781 Name : Gela.Lexical_Types.Symbol;
782 Set : Gela.Symbol_Sets.Symbol_Set_Access;
783 begin
784 if Index /= Library_Env or not Region.Assigned then
785 return Library_Cursor.Defining_Name_Cursor'(Name => null);
786 end if;
787
788 Set := Self.Context.Symbols;
789 Units := Self.Context.Library_Unit_Declarations;
790
791 Name := Region.Full_Name;
792 Unit := Units.Find (Name);
793
794 if Unit = null then
795 Found.all := False;
796 return Library_Cursor.Defining_Name_Cursor'(Name => null);
797 end if;
798
799 Found.all := True;
800 Set.Join (Left => Name, Right => Symbol, Value => Name);
801 Unit := Units.Find (Name);
802
803 if Unit = null then
804 Units := Self.Context.Compilation_Unit_Bodies;
805 Unit := Units.Find (Symbol);
806 end if;
807
808 return Result : Library_Cursor.Defining_Name_Cursor do
809 if Unit /= null then
810 declare
811 V : Get_Defining_Name_Visiter.Visiter;
812 begin
813 Unit.Tree.Visit (V);
814 Result.Name := V.Name;
815 end;
816 end if;
817 end return;
818 end Visible;
819
820end Gela.Library_Environments;
Note: See TracBrowser for help on using the repository browser.