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

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

Keep package_renaming_declaration in Env

to be able expand selected names in Visible call.

  • Property svn:keywords set to Author Date Revision
File size: 27.4 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 overriding function Add_Completion
573 (Self : in out Environment_Set;
574 Index : Gela.Semantic_Types.Env_Index;
575 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
576 Completion : Gela.Elements.Defining_Names.Defining_Name_Access)
577 return Gela.Semantic_Types.Env_Index is
578 begin
579 raise Program_Error;
580 return Index;
581 end Add_Completion;
582
583 -----------------------
584 -- Add_Defining_Name --
585 -----------------------
586
587 overriding function Add_Defining_Name
588 (Self : in out Environment_Set;
589 Index : Gela.Semantic_Types.Env_Index;
590 Symbol : Gela.Lexical_Types.Symbol;
591 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
592 return Gela.Semantic_Types.Env_Index is
593 begin
594 raise Program_Error;
595 return 0;
596 end Add_Defining_Name;
597
598 ------------------------
599 -- Add_Rename_Package --
600 ------------------------
601
602 overriding function Add_Rename_Package
603 (Self : in out Environment_Set;
604 Index : Gela.Semantic_Types.Env_Index;
605 Region : Gela.Elements.Defining_Names.Defining_Name_Access;
606 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
607 return Gela.Semantic_Types.Env_Index is
608 begin
609 raise Program_Error;
610 return 0;
611 end Add_Rename_Package;
612
613 ---------------------
614 -- Add_Use_Package --
615 ---------------------
616
617 overriding function Add_Use_Package
618 (Self : in out Environment_Set;
619 Index : Gela.Semantic_Types.Env_Index;
620 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
621 return Gela.Semantic_Types.Env_Index is
622 begin
623 raise Program_Error;
624 return 0;
625 end Add_Use_Package;
626
627 overriding function Add_With_Clause
628 (Self : in out Environment_Set;
629 Index : Gela.Semantic_Types.Env_Index;
630 Symbol : Gela.Lexical_Types.Symbol)
631 return Gela.Semantic_Types.Env_Index
632 is
633 pragma Unreferenced (Self);
634 pragma Unreferenced (Symbol);
635 begin
636 return Index;
637 end Add_With_Clause;
638
639 ----------------
640 -- Completion --
641 ----------------
642
643 overriding function Completions
644 (Self : in out Environment_Set;
645 Index : Gela.Semantic_Types.Env_Index;
646 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
647 return Gela.Environments.Completion_List
648 is
649 pragma Unreferenced (Self, Index, Name);
650 begin
651 return (Length => 0, Data => <>);
652 end Completions;
653
654 --------------------
655 -- Direct_Visible --
656 --------------------
657
658 overriding function Direct_Visible
659 (Self : access Environment_Set;
660 Index : Gela.Semantic_Types.Env_Index;
661 Symbol : Gela.Lexical_Types.Symbol)
662 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
663 is
664 use type Gela.Semantic_Types.Env_Index;
665 use type Gela.Compilation_Units.Compilation_Unit_Access;
666 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
667 Units : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
668 begin
669 if Index /= Library_Env then
670 return Library_Cursor.Defining_Name_Cursor'(Name => null);
671 end if;
672
673 Units := Self.Context.Library_Unit_Declarations;
674 Unit := Units.Find (Symbol);
675
676 if Unit = null then
677 Units := Self.Context.Compilation_Unit_Bodies;
678 Unit := Units.Find (Symbol);
679 end if;
680
681 return Result : Library_Cursor.Defining_Name_Cursor do
682 if Unit /= null then
683 declare
684 V : Get_Defining_Name_Visiter.Visiter;
685 begin
686 Unit.Tree.Visit (V);
687 Result.Name := V.Name;
688 end;
689 end if;
690 end return;
691 end Direct_Visible;
692
693 -----------------------
694 -- Empty_Environment --
695 -----------------------
696
697 overriding function Empty_Environment
698 (Self : Environment_Set) return Gela.Semantic_Types.Env_Index
699 is
700 pragma Unreferenced (Self);
701 begin
702 return 0;
703 end Empty_Environment;
704
705 -----------------------------
706 -- Enter_Completion_Region --
707 -----------------------------
708
709 overriding function Enter_Completion_Region
710 (Self : access Environment_Set;
711 Index : Gela.Semantic_Types.Env_Index;
712 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
713 return Gela.Semantic_Types.Env_Index is
714 begin
715 raise Program_Error;
716 return Self.Enter_Completion_Region (Index, Region);
717 end Enter_Completion_Region;
718
719 ------------------------------
720 -- Enter_Declarative_Region --
721 ------------------------------
722
723 overriding function Enter_Declarative_Region
724 (Self : access Environment_Set;
725 Index : Gela.Semantic_Types.Env_Index;
726 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
727 return Gela.Semantic_Types.Env_Index is
728 begin
729 raise Program_Error;
730 return Self.Enter_Declarative_Region (Index, Region);
731 end Enter_Declarative_Region;
732
733 ------------------------------
734 -- Leave_Declarative_Region --
735 ------------------------------
736
737 overriding function Leave_Declarative_Region
738 (Self : access Environment_Set;
739 Index : Gela.Semantic_Types.Env_Index)
740 return Gela.Semantic_Types.Env_Index is
741 begin
742 raise Program_Error;
743 return Self.Leave_Declarative_Region (Index);
744 end Leave_Declarative_Region;
745
746 -------------------------------
747 -- Library_Level_Environment --
748 -------------------------------
749
750 overriding function Library_Level_Environment
751 (Self : Environment_Set)
752 return Gela.Semantic_Types.Env_Index
753 is
754 pragma Unreferenced (Self);
755 begin
756 return Library_Env;
757 end Library_Level_Environment;
758
759 ------------------------------
760 -- Library_Unit_Environment --
761 ------------------------------
762
763 overriding function Library_Unit_Environment
764 (Self : access Environment_Set;
765 Symbol : Gela.Lexical_Types.Symbol)
766 return Gela.Semantic_Types.Env_Index
767 is
768 pragma Unreferenced (Self);
769 pragma Unreferenced (Symbol);
770 begin
771 return 0;
772 end Library_Unit_Environment;
773
774 ----------------------------------
775 -- Set_Library_Unit_Environment --
776 ----------------------------------
777
778 overriding procedure Set_Library_Unit_Environment
779 (Self : access Environment_Set;
780 Symbol : Gela.Lexical_Types.Symbol;
781 Value : Gela.Semantic_Types.Env_Index) is
782 begin
783 raise Constraint_Error;
784 end Set_Library_Unit_Environment;
785
786 -----------------
787 -- Use_Visible --
788 -----------------
789
790 overriding function Use_Visible
791 (Self : access Environment_Set;
792 Index : Gela.Semantic_Types.Env_Index;
793 Symbol : Gela.Lexical_Types.Symbol)
794 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
795 is
796 pragma Unreferenced (Self);
797 pragma Unreferenced (Index);
798 pragma Unreferenced (Symbol);
799
800 -- No use clause considered at library level
801 Result : Library_Cursor.Defining_Name_Cursor;
802 begin
803 return Result;
804 end Use_Visible;
805
806 -------------
807 -- Visible --
808 -------------
809
810 overriding function Visible
811 (Self : access Environment_Set;
812 Index : Gela.Semantic_Types.Env_Index;
813 Region : Gela.Elements.Defining_Names.Defining_Name_Access;
814 Symbol : Gela.Lexical_Types.Symbol;
815 Found : access Boolean)
816 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
817 is
818 use type Gela.Semantic_Types.Env_Index;
819 use type Gela.Compilation_Units.Compilation_Unit_Access;
820 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
821 Units : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
822 Name : Gela.Lexical_Types.Symbol;
823 Set : Gela.Symbol_Sets.Symbol_Set_Access;
824 begin
825 if Index /= Library_Env or not Region.Assigned then
826 return Library_Cursor.Defining_Name_Cursor'(Name => null);
827 end if;
828
829 Set := Self.Context.Symbols;
830 Units := Self.Context.Library_Unit_Declarations;
831
832 Name := Region.Full_Name;
833 Unit := Units.Find (Name);
834
835 if Unit = null then
836 Found.all := False;
837 return Library_Cursor.Defining_Name_Cursor'(Name => null);
838 end if;
839
840 Found.all := True;
841 Set.Join (Left => Name, Right => Symbol, Value => Name);
842 Unit := Units.Find (Name);
843
844 if Unit = null then
845 Units := Self.Context.Compilation_Unit_Bodies;
846 Unit := Units.Find (Symbol);
847 end if;
848
849 return Result : Library_Cursor.Defining_Name_Cursor do
850 if Unit /= null then
851 declare
852 V : Get_Defining_Name_Visiter.Visiter;
853 begin
854 Unit.Tree.Visit (V);
855 Result.Name := V.Name;
856 end;
857 end if;
858 end return;
859 end Visible;
860
861end Gela.Library_Environments;
Note: See TracBrowser for help on using the repository browser.