source: trunk/ada-2012/src/semantic/gela-plain_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: 22.2 KB
Line 
1-- with Gela.Plain_Environments.Debug;
2
3package body Gela.Plain_Environments is
4
5 function Name_To_Region
6 (Self : access Environment_Set'Class;
7 Index : Gela.Semantic_Types.Env_Index;
8 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
9 return Region_Item_Count;
10
11 package Visible_Cursors is
12 -- Cursor over names in Local
13 type Defining_Name_Cursor is
14 new Gela.Defining_Name_Cursors.Defining_Name_Cursor with
15 record
16 Set : Plain_Environment_Set_Access;
17 Current : Gela.Name_List_Managers.Defining_Name_Cursor;
18 end record;
19
20 overriding function Has_Element
21 (Self : Defining_Name_Cursor) return Boolean;
22
23 overriding function Element
24 (Self : Defining_Name_Cursor)
25 return Gela.Elements.Defining_Names.Defining_Name_Access;
26
27 overriding procedure Next
28 (Self : in out Defining_Name_Cursor);
29
30 procedure Initialize
31 (Self : in out Defining_Name_Cursor'Class;
32 Symbol : Gela.Lexical_Types.Symbol;
33 Region : Region_Item_Index);
34 end Visible_Cursors;
35
36 package body Visible_Cursors is
37
38 overriding function Has_Element
39 (Self : Defining_Name_Cursor) return Boolean is
40 begin
41 return Self.Current.Has_Element;
42 end Has_Element;
43
44 overriding function Element
45 (Self : Defining_Name_Cursor)
46 return Gela.Elements.Defining_Names.Defining_Name_Access is
47 begin
48 return Self.Current.Element;
49 end Element;
50
51 overriding procedure Next (Self : in out Defining_Name_Cursor) is
52 begin
53 Self.Current.Next;
54 end Next;
55
56 procedure Initialize
57 (Self : in out Defining_Name_Cursor'Class;
58 Symbol : Gela.Lexical_Types.Symbol;
59 Region : Region_Item_Index)
60 is
61 Local : constant Gela.Name_List_Managers.List :=
62 Self.Set.Region.Head (Region).Local;
63 begin
64 Self.Current := Self.Set.Names.Find (Local, Symbol);
65 end Initialize;
66
67 end Visible_Cursors;
68
69 package Direct_Visible_Cursors is
70 -- Cursor over names in Local then go to enclosing region, etc
71 type Defining_Name_Cursor is
72 new Visible_Cursors.Defining_Name_Cursor with
73 record
74 Region : Region_Item_Index;
75 end record;
76
77 overriding procedure Next
78 (Self : in out Defining_Name_Cursor);
79
80 procedure Initialize
81 (Self : in out Defining_Name_Cursor;
82 Symbol : Gela.Lexical_Types.Symbol);
83 end Direct_Visible_Cursors;
84
85 ----------------------------
86 -- Direct_Visible_Cursors --
87 ----------------------------
88
89 package body Direct_Visible_Cursors is
90
91 overriding procedure Next (Self : in out Defining_Name_Cursor) is
92 Symbol : constant Gela.Lexical_Types.Symbol := Self.Current.Symbol;
93 Region : Region_Item_Count;
94 begin
95 Visible_Cursors.Defining_Name_Cursor (Self).Next;
96
97 while not Self.Has_Element loop
98 Region := Self.Set.Region.Tail (Self.Region);
99
100 if Region in Region_Item_Index then
101 Self.Region := Region;
102 Visible_Cursors.Initialize (Self, Symbol, Region);
103 else
104 return;
105 end if;
106 end loop;
107 end Next;
108
109 ----------------
110 -- Initialize --
111 ----------------
112
113 procedure Initialize
114 (Self : in out Defining_Name_Cursor;
115 Symbol : Gela.Lexical_Types.Symbol)
116 is
117 Region : Region_Item_Count := Self.Region;
118 begin
119 while Region in Region_Item_Index loop
120 Self.Region := Region;
121 Visible_Cursors.Initialize (Self, Symbol, Region);
122
123 exit when Self.Has_Element;
124 Region := Self.Set.Region.Tail (Self.Region);
125 end loop;
126 end Initialize;
127
128 end Direct_Visible_Cursors;
129
130 package Use_Package_Cursors is
131 -- Cursor over names in each used package
132 type Defining_Name_Cursor is
133 new Visible_Cursors.Defining_Name_Cursor with
134 record
135 Env : Env_Item_Index;
136 Region : Region_Item_Count;
137 -- Position in Env_Item.Nested_Region_List list
138 Use_Name : Defining_Name_Item_Count;
139 -- Position in Region.Use_Package list
140 end record;
141
142 overriding procedure Next
143 (Self : in out Defining_Name_Cursor);
144
145 function Name_To_Region
146 (Self : Defining_Name_Cursor;
147 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
148 return Region_Item_Count;
149
150 procedure Initialize
151 (Self : in out Defining_Name_Cursor;
152 Symbol : Gela.Lexical_Types.Symbol);
153
154 end Use_Package_Cursors;
155
156 -------------------------
157 -- Use_Package_Cursors --
158 -------------------------
159
160 package body Use_Package_Cursors is
161
162 overriding procedure Next (Self : in out Defining_Name_Cursor) is
163 use type Region_Item_Count;
164 use type Defining_Name_Item_Count;
165
166 Symbol : constant Gela.Lexical_Types.Symbol := Self.Current.Symbol;
167 Region : Region_Item_Count;
168 begin
169 Visible_Cursors.Defining_Name_Cursor (Self).Next;
170
171 while not Self.Current.Has_Element loop
172 Region := 0;
173
174 while Region = 0 loop
175 -- Next name in use clauses of Region
176 Self.Use_Name := Self.Set.Use_Package.Tail (Self.Use_Name);
177
178 while Self.Use_Name = 0 loop
179 Self.Region := Self.Set.Region.Tail (Self.Region);
180
181 if Self.Region = 0 then
182 return;
183 end if;
184
185 Self.Use_Name :=
186 Self.Set.Region.Head (Self.Region).Use_Package;
187 end loop;
188
189 Region := Self.Name_To_Region
190 (Self.Set.Use_Package.Head (Self.Use_Name));
191 end loop;
192
193 Visible_Cursors.Initialize (Self, Symbol, Region);
194 end loop;
195 end Next;
196
197 --------------------
198 -- Name_To_Region --
199 --------------------
200
201 function Name_To_Region
202 (Self : Defining_Name_Cursor;
203 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
204 return Region_Item_Count is
205 begin
206 return Name_To_Region (Self.Set, Self.Env, Name);
207 end Name_To_Region;
208
209 ----------------
210 -- Initialize --
211 ----------------
212
213 procedure Initialize
214 (Self : in out Defining_Name_Cursor;
215 Symbol : Gela.Lexical_Types.Symbol)
216 is
217 use type Region_Item_Count;
218 use type Defining_Name_Item_Count;
219
220 Env : constant Env_Item := Self.Set.Env.Element (Self.Env);
221 Target : Region_Item_Count;
222 Local : Gela.Name_List_Managers.List;
223 begin
224 Self.Region := Env.Region_List (Nested);
225
226 while Self.Region /= 0 loop
227 Self.Use_Name := Self.Set.Region.Head (Self.Region).Use_Package;
228
229 while Self.Use_Name /= 0 loop
230 Target := Self.Name_To_Region
231 (Self.Set.Use_Package.Head (Self.Use_Name));
232
233 if Target /= 0 then
234 Local := Self.Set.Region.Head (Target).Local;
235 Self.Current := Self.Set.Names.Find (Local, Symbol);
236
237 if Self.Has_Element then
238 return;
239 end if;
240 end if;
241
242 Self.Use_Name := Self.Set.Use_Package.Tail (Self.Use_Name);
243 end loop;
244
245 Self.Region := Self.Set.Region.Tail (Self.Region);
246 end loop;
247 end Initialize;
248
249 end Use_Package_Cursors;
250
251 -----------------------
252 -- Add_Defining_Name --
253 -----------------------
254
255 overriding function Add_Defining_Name
256 (Self : in out Environment_Set;
257 Index : Gela.Semantic_Types.Env_Index;
258 Symbol : Gela.Lexical_Types.Symbol;
259 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
260 return Gela.Semantic_Types.Env_Index
261 is
262 use type Region_Item_Count;
263
264 procedure Update_Lib_Unit_Env
265 (Old_Env : Gela.Semantic_Types.Env_Index;
266 New_Env : Env_Item_Index);
267
268 -------------------------
269 -- Update_Lib_Unit_Env --
270 -------------------------
271
272 procedure Update_Lib_Unit_Env
273 (Old_Env : Gela.Semantic_Types.Env_Index;
274 New_Env : Env_Item_Index)
275 is
276 Cursor : Env_Maps.Cursor := Self.Lib_Env.Find (Old_Env);
277 Symbol : Gela.Lexical_Types.Symbol;
278 begin
279 if Env_Maps.Has_Element (Cursor) then
280 Symbol := Env_Maps.Element (Cursor);
281 Self.Lib_Env.Delete (Cursor);
282 Self.Lib_Env.Insert (New_Env, Symbol);
283 Self.Units_Env.Replace (Symbol, New_Env);
284 end if;
285 end Update_Lib_Unit_Env;
286
287 Env : Env_Item;
288 Env_Index : Gela.Semantic_Types.Env_Index;
289 Reg : Region_Item;
290 begin
291 if Index in Env_Item_Index then
292 Env := Self.Env.Element (Index);
293 else
294 Env := (Region_List => (Nested => 0, Other => 0, Withed => 0));
295 end if;
296
297 if Env.Region_List (Nested) = 0 then
298 Reg := (Name => null,
299 Local => Self.Names.Empty_List,
300 Use_Package => 0);
301 else
302 Reg := Self.Region.Head (Env.Region_List (Nested));
303 end if;
304
305 Self.Names.Append
306 (Symbol => Symbol,
307 Name => Name,
308 Input => Reg.Local,
309 Output => Reg.Local);
310
311 if Env.Region_List (Nested) = 0 then
312 -- Create Nested_Region_List as (Reg)
313 Self.Region.Prepend
314 (Value => Reg,
315 Input => 0,
316 Output => Env.Region_List (Nested));
317 else
318 -- Replace head of Nested_Region_List with Reg
319 Self.Region.Prepend
320 (Value => Reg,
321 Input => Self.Region.Tail (Env.Region_List (Nested)),
322 Output => Env.Region_List (Nested));
323 end if;
324
325 Env_Index := Self.Env.Find_Index (Env);
326
327 if Env_Index = 0 then
328 Self.Env.Append (Env);
329 Env_Index := Self.Env.Last_Index;
330 end if;
331
332 Update_Lib_Unit_Env (Index, Env_Index);
333
334 return Env_Index;
335 end Add_Defining_Name;
336
337 ---------------------
338 -- Add_Use_Package --
339 ---------------------
340
341 overriding function Add_Use_Package
342 (Self : in out Environment_Set;
343 Index : Gela.Semantic_Types.Env_Index;
344 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
345 return Gela.Semantic_Types.Env_Index
346 is
347
348 Env_Index : Gela.Semantic_Types.Env_Index;
349 Env : Env_Item;
350 Reg : Region_Item;
351 begin
352 if Index in 0 | Self.Library_Level_Environment then
353 -- Fix constraint_error because library_bodies doesn have env yet
354 return Index;
355 end if;
356
357 Env := Self.Env.Element (Index);
358 Reg := Self.Region.Head (Env.Region_List (Nested));
359
360 Self.Use_Package.Prepend
361 (Value => Name,
362 Input => Reg.Use_Package,
363 Output => Reg.Use_Package);
364
365 -- Replace head of Nested_Region_List with Reg
366 Self.Region.Prepend
367 (Value => Reg,
368 Input => Self.Region.Tail (Env.Region_List (Nested)),
369 Output => Env.Region_List (Nested));
370
371 Env_Index := Self.Env.Find_Index (Env);
372
373 if Env_Index = 0 then
374 Self.Env.Append (Env);
375 Env_Index := Self.Env.Last_Index;
376 end if;
377
378 return Env_Index;
379 end Add_Use_Package;
380
381 ---------------------
382 -- Add_With_Clause --
383 ---------------------
384
385 overriding function Add_With_Clause
386 (Self : in out Environment_Set;
387 Index : Gela.Semantic_Types.Env_Index;
388 Symbol : Gela.Lexical_Types.Symbol)
389 return Gela.Semantic_Types.Env_Index
390 is
391 procedure Append (Item : Region_Item);
392
393 Env_Index : Gela.Semantic_Types.Env_Index;
394 Env : Env_Item := Self.Env.Element (Index);
395 Target : Gela.Semantic_Types.Env_Index :=
396 Self.Library_Unit_Environment (Symbol);
397 Target_Env : Env_Item;
398 List : Region_Item_Count;
399
400 procedure Append (Item : Region_Item) is
401 begin
402 Self.Region.Prepend
403 (Value => Item,
404 Input => Env.Region_List (Withed),
405 Output => Env.Region_List (Withed));
406 end Append;
407
408 begin
409 if Target in 0 | Self.Library_Level_Environment then
410 -- Fix constraint_error because library_bodies doesn have env yet
411 return Index;
412 end if;
413
414 Target := Self.Leave_Declarative_Region (Target);
415 Target_Env := Self.Env.Element (Target);
416 List := Target_Env.Region_List (Other);
417
418-- Gela.Plain_Environments.Debug
419-- (Self => Self'Access,
420-- Index => Target);
421--
422 Self.Region.For_Each (List, Append'Access);
423
424 Env_Index := Self.Env.Find_Index (Env);
425
426 if Env_Index = 0 then
427 Self.Env.Append (Env);
428 Env_Index := Self.Env.Last_Index;
429 end if;
430
431 return Env_Index;
432 end Add_With_Clause;
433
434 --------------------
435 -- Direct_Visible --
436 --------------------
437
438 overriding function Direct_Visible
439 (Self : access Environment_Set;
440 Index : Gela.Semantic_Types.Env_Index;
441 Symbol : Gela.Lexical_Types.Symbol)
442 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
443 is
444 use type Gela.Lexical_Types.Symbol;
445
446 Env : Env_Item;
447 begin
448 if Index = Gela.Library_Environments.Library_Env then
449 return Self.Lib.Direct_Visible (Index, Symbol);
450 elsif Index not in Env_Item_Index then
451 return None : constant Direct_Visible_Cursors.Defining_Name_Cursor :=
452 (others => <>);
453 end if;
454
455 Env := Self.Env.Element (Index);
456
457 return Result : Direct_Visible_Cursors.Defining_Name_Cursor :=
458 (Set => Plain_Environment_Set_Access (Self),
459 Region => Env.Region_List (Nested),
460 others => <>)
461 do
462 Result.Initialize (Symbol);
463 end return;
464 end Direct_Visible;
465
466 -----------------------
467 -- Empty_Environment --
468 -----------------------
469
470 overriding function Empty_Environment
471 (Self : Environment_Set)
472 return Gela.Semantic_Types.Env_Index is
473 begin
474 return Self.Lib.Empty_Environment;
475 end Empty_Environment;
476
477 -----------------------------
478 -- Enter_Completion_Region --
479 -----------------------------
480
481 overriding function Enter_Completion_Region
482 (Self : access Environment_Set;
483 Index : Gela.Semantic_Types.Env_Index;
484 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
485 return Gela.Semantic_Types.Env_Index
486 is
487 Env : Env_Item;
488 Found : Gela.Semantic_Types.Env_Index;
489 Spec : constant Region_Item_Count :=
490 Name_To_Region (Self, Index, Region);
491 Next : Region_Item :=
492 (Name => Region,
493 Local => Self.Names.Empty_List,
494 Use_Package => 0);
495 begin
496 if Index in Env_Item_Index then
497 Env := Self.Env.Element (Index);
498 else
499 Env := (Region_List => (Nested => 0, Other => 0, Withed => 0));
500 end if;
501
502 if Spec in Region_Item_Index then
503 Next := Self.Region.Head (Spec);
504 end if;
505
506-- Shall we delete region with the same Name from Other_Region_List?
507
508 Self.Region.Prepend
509 (Value => Next,
510 Input => Env.Region_List (Nested),
511 Output => Env.Region_List (Nested));
512
513 Found := Self.Env.Find_Index (Env);
514
515 if Found not in Env_Item_Index then
516 Self.Env.Append (Env);
517 Found := Self.Env.Last_Index;
518 end if;
519
520 return Found;
521 end Enter_Completion_Region;
522
523 ------------------------------
524 -- Enter_Declarative_Region --
525 ------------------------------
526
527 overriding function Enter_Declarative_Region
528 (Self : access Environment_Set;
529 Index : Gela.Semantic_Types.Env_Index;
530 Region : Gela.Elements.Defining_Names.Defining_Name_Access)
531 return Gela.Semantic_Types.Env_Index
532 is
533 Env : Env_Item;
534 Found : Gela.Semantic_Types.Env_Index;
535 Next : constant Region_Item :=
536 (Name => Region,
537 Local => Self.Names.Empty_List,
538 Use_Package => 0);
539 begin
540 if Index in Env_Item_Index then
541 Env := Self.Env.Element (Index);
542 else
543 Env := (Region_List => (Nested => 0, Other => 0, Withed => 0));
544 end if;
545
546 Self.Region.Prepend
547 (Value => Next,
548 Input => Env.Region_List (Nested),
549 Output => Env.Region_List (Nested));
550
551-- Shall we delete region with the same Name from Other_Region_List?
552-- Self.Region.Delete
553-- (Input => Env.Other_Region_List,
554-- Value => Next,
555-- Output => Env.Other_Region_List);
556
557 Found := Self.Env.Find_Index (Env);
558
559 if Found not in Env_Item_Index then
560 Self.Env.Append (Env);
561 Found := Self.Env.Last_Index;
562 end if;
563
564 return Found;
565 end Enter_Declarative_Region;
566
567 ----------
568 -- Hash --
569 ----------
570
571 function Hash
572 (X : Gela.Lexical_Types.Symbol) return Ada.Containers.Hash_Type is
573 begin
574 return Ada.Containers.Hash_Type (X);
575 end Hash;
576
577 ----------
578 -- Hash --
579 ----------
580
581 function Hash
582 (X : Gela.Semantic_Types.Env_Index) return Ada.Containers.Hash_Type is
583 begin
584 return Ada.Containers.Hash_Type (X);
585 end Hash;
586
587 ------------------------------
588 -- Leave_Declarative_Region --
589 ------------------------------
590
591 overriding function Leave_Declarative_Region
592 (Self : access Environment_Set;
593 Index : Gela.Semantic_Types.Env_Index)
594 return Gela.Semantic_Types.Env_Index
595 is
596 Found : Gela.Semantic_Types.Env_Index;
597 Env : Env_Item := Self.Env.Element (Index);
598 Region : constant Region_Item :=
599 Self.Region.Head (Env.Region_List (Nested));
600 begin
601 -- Push top region to Other_Region_List
602 Self.Region.Prepend
603 (Value => Region,
604 Input => Env.Region_List (Other),
605 Output => Env.Region_List (Other));
606
607 -- Pop top region from Nested_Region_List
608 Env.Region_List (Nested) := Self.Region.Tail (Env.Region_List (Nested));
609
610 Found := Self.Env.Find_Index (Env);
611
612 if Found not in Env_Item_Index then
613 Self.Env.Append (Env);
614 Found := Self.Env.Last_Index;
615 end if;
616
617 return Found;
618 end Leave_Declarative_Region;
619
620 -------------------------------
621 -- Library_Level_Environment --
622 -------------------------------
623
624 overriding function Library_Level_Environment
625 (Self : Environment_Set)
626 return Gela.Semantic_Types.Env_Index is
627 begin
628 return Self.Lib.Library_Level_Environment;
629 end Library_Level_Environment;
630
631 ------------------------------
632 -- Library_Unit_Environment --
633 ------------------------------
634
635 overriding function Library_Unit_Environment
636 (Self : access Environment_Set;
637 Symbol : Gela.Lexical_Types.Symbol)
638 return Gela.Semantic_Types.Env_Index
639 is
640 use type Gela.Lexical_Types.Symbol;
641 begin
642 if Symbol = 0 then
643 return 0;
644 else
645 return Self.Units_Env.Element (Symbol);
646 end if;
647 end Library_Unit_Environment;
648
649 --------------------
650 -- Name_To_Region --
651 --------------------
652
653 function Name_To_Region
654 (Self : access Environment_Set'Class;
655 Index : Gela.Semantic_Types.Env_Index;
656 Name : Gela.Elements.Defining_Names.Defining_Name_Access)
657 return Region_Item_Count
658 is
659 use type Region_Item_Count;
660 use type Gela.Elements.Defining_Names.Defining_Name_Access;
661
662 Env : constant Env_Item := Self.Env.Element (Index);
663 Next : Region_Item_Count;
664 begin
665 for J of Env.Region_List loop
666 Next := J;
667 while Next /= 0 loop
668 if Self.Region.Head (Next).Name = Name then
669 return Next;
670 end if;
671
672 Next := Self.Region.Tail (Next);
673 end loop;
674 end loop;
675
676 return 0;
677 end Name_To_Region;
678
679 ----------------------------------
680 -- Set_Library_Unit_Environment --
681 ----------------------------------
682
683 overriding procedure Set_Library_Unit_Environment
684 (Self : access Environment_Set;
685 Symbol : Gela.Lexical_Types.Symbol;
686 Value : Gela.Semantic_Types.Env_Index) is
687 begin
688 Self.Units_Env.Include (Symbol, Value);
689 Self.Lib_Env.Include (Value, Symbol);
690 end Set_Library_Unit_Environment;
691
692 -----------------
693 -- Use_Visible --
694 -----------------
695
696 overriding function Use_Visible
697 (Self : access Environment_Set;
698 Index : Gela.Semantic_Types.Env_Index;
699 Symbol : Gela.Lexical_Types.Symbol)
700 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class is
701 begin
702 if Index = Gela.Library_Environments.Library_Env then
703 return Self.Lib.Use_Visible (Index, Symbol);
704 end if;
705
706 return Result : Use_Package_Cursors.Defining_Name_Cursor :=
707 (Set => Plain_Environment_Set_Access (Self),
708 Env => Index,
709 Region => 0,
710 Use_Name => 0,
711 others => <>)
712 do
713 Result.Initialize (Symbol);
714 end return;
715 end Use_Visible;
716
717 -------------
718 -- Visible --
719 -------------
720
721 overriding function Visible
722 (Self : access Environment_Set;
723 Index : Gela.Semantic_Types.Env_Index;
724 Region : Gela.Elements.Defining_Names.Defining_Name_Access;
725 Symbol : Gela.Lexical_Types.Symbol;
726 Found : access Boolean)
727 return Gela.Defining_Name_Cursors.Defining_Name_Cursor'Class
728 is
729 use type Gela.Lexical_Types.Symbol;
730
731 Item : Region_Item_Count;
732 begin
733 if Index = Gela.Library_Environments.Library_Env then
734 return Self.Lib.Visible (Index, Region, Symbol, Found);
735 elsif Index not in Env_Item_Index then
736 return None : constant Visible_Cursors.Defining_Name_Cursor :=
737 (others => <>);
738 end if;
739
740 if Region.Assigned then
741 Item := Name_To_Region (Self, Index, Region);
742 else
743 declare
744 Env : constant Env_Item := Self.Env.Element (Index);
745 begin
746 Item := Env.Region_List (Nested);
747 end;
748 end if;
749
750 if Item not in Region_Item_Index then
751 return None : constant Visible_Cursors.Defining_Name_Cursor :=
752 (others => <>);
753 end if;
754
755 return Result : Visible_Cursors.Defining_Name_Cursor :=
756 (Set => Plain_Environment_Set_Access (Self),
757 others => <>)
758 do
759 Result.Initialize (Symbol, Item);
760 end return;
761 end Visible;
762
763end Gela.Plain_Environments;
Note: See TracBrowser for help on using the repository browser.