source: trunk/ada-2012/src/semantic/gela-plain_environments.adb@ 318

Last change on this file since 318 was 318, checked in by Maxim Reznik, 6 years ago

Move Ada 2012 code to trunk

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