source: trunk/ada-2012/src/asis/asis-elements.adb@ 400

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

fix Access_Type_Kind and add next test

  • Property svn:keywords set to Date Revision
File size: 46.9 KB
Line 
1------------------------------------------------------------------------------
2-- G E L A A S I S --
3-- ASIS implementation for Gela project, a portable Ada compiler --
4-- http://gela.ada-ru.org --
5-- - - - - - - - - - - - - - - - --
6-- Read copyright and license at the end of this file --
7------------------------------------------------------------------------------
8-- $Revision: 400 $ $Date: 2015-02-16 17:05:24 +0000 (Mon, 16 Feb 2015) $
9-- Purpose:
10-- Procedural wrapper over Object-Oriented ASIS implementation
11
12with Ada.Containers;
13
14with Gela.Compilations;
15with Gela.Compilation_Unit_Sets;
16with Gela.Elements.Compilation_Units;
17with Gela.Element_Visiters;
18with Gela.Elements.Compilation_Unit_Bodies;
19with Gela.Elements.Compilation_Unit_Declarations;
20with Gela.Elements.Subunits;
21with Gela.Elements.Context_Items;
22with Asis.Extensions.Flat_Kinds;
23with Gela.Elements.Library_Unit_Bodies;
24with Gela.Elements.Library_Unit_Declarations;
25with Gela.Elements.Proper_Bodies;
26with Gela.Lexical_Types;
27
28package body Asis.Elements is
29
30 package F renames Asis.Extensions.Flat_Kinds;
31
32 ----------------------------
33 -- Access_Definition_Kind --
34 ----------------------------
35
36 function Access_Definition_Kind
37 (Definition : Asis.Definition)
38 return Asis.Access_Definition_Kinds
39 is
40 Map : constant array (F.An_Access_Definition)
41 of Asis.Access_Definition_Kinds :=
42 (F.An_Anonymous_Access_To_Variable =>
43 Asis.An_Anonymous_Access_To_Variable,
44 F.An_Anonymous_Access_To_Constant =>
45 Asis.An_Anonymous_Access_To_Constant,
46 F.An_Anonymous_Access_To_Procedure =>
47 Asis.An_Anonymous_Access_To_Procedure,
48 F.An_Anonymous_Access_To_Protected_Procedure =>
49 Asis.An_Anonymous_Access_To_Protected_Procedure,
50 F.An_Anonymous_Access_To_Function =>
51 Asis.An_Anonymous_Access_To_Function,
52 F.An_Anonymous_Access_To_Protected_Function =>
53 Asis.An_Anonymous_Access_To_Protected_Function);
54
55 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
56 Asis.Extensions.Flat_Kinds.Flat_Kind (Definition);
57 begin
58 if Kind in Map'Range then
59 return Map (Kind);
60 else
61 return Not_An_Access_Definition;
62 end if;
63 end Access_Definition_Kind;
64
65 ----------------------
66 -- Access_Type_Kind --
67 ----------------------
68
69 function Access_Type_Kind
70 (Definition : in Asis.Access_Type_Definition)
71 return Asis.Access_Type_Kinds
72 is
73 Map : constant array (F.An_Access_Type_Definition)
74 of Asis.Access_Type_Kinds :=
75 (F.A_Pool_Specific_Access_To_Variable =>
76 Asis.A_Pool_Specific_Access_To_Variable,
77 F.An_Access_To_Variable =>
78 Asis.An_Access_To_Variable,
79 F.An_Access_To_Constant =>
80 Asis.An_Access_To_Constant,
81 F.An_Access_To_Procedure =>
82 Asis.An_Access_To_Procedure,
83 F.An_Access_To_Protected_Procedure =>
84 Asis.An_Access_To_Protected_Procedure,
85 F.An_Access_To_Function =>
86 Asis.An_Access_To_Function,
87 F.An_Access_To_Protected_Function =>
88 Asis.An_Access_To_Protected_Function);
89
90 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
91 Asis.Extensions.Flat_Kinds.Flat_Kind (Definition);
92 begin
93 if Kind in Map'Range then
94 return Map (Kind);
95 else
96 return Not_An_Access_Type_Definition;
97 end if;
98 end Access_Type_Kind;
99
100 ----------------------
101 -- Association_Kind --
102 ----------------------
103
104 function Association_Kind
105 (Association : in Asis.Association)
106 return Asis.Association_Kinds
107 is
108 Map : constant array (F.An_Association) of Asis.Association_Kinds :=
109 (F.A_Pragma_Argument_Association => Asis.A_Pragma_Argument_Association,
110 F.A_Discriminant_Association => Asis.A_Discriminant_Association,
111 F.A_Record_Component_Association =>
112 Asis.A_Record_Component_Association,
113 F.An_Array_Component_Association =>
114 Asis.An_Array_Component_Association,
115 F.A_Parameter_Association => Asis.A_Parameter_Association,
116 F.A_Generic_Association => Asis.A_Generic_Association);
117
118 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
119 Asis.Extensions.Flat_Kinds.Flat_Kind (Association);
120 begin
121 if Kind in Map'Range then
122 return Map (Kind);
123 else
124 return Not_An_Association;
125 end if;
126 end Association_Kind;
127
128 --------------------
129 -- Attribute_Kind --
130 --------------------
131
132 function Attribute_Kind
133 (Expression : in Asis.Expression)
134 return Asis.Attribute_Kinds
135 is
136 begin
137 if Assigned (Expression) then
138 Raise_Not_Implemented ("");
139 return Not_An_Attribute;
140 else
141 return Not_An_Attribute;
142 end if;
143 end Attribute_Kind;
144
145 -----------------
146 -- Clause_Kind --
147 -----------------
148
149 function Clause_Kind (Clause : in Asis.Clause) return Asis.Clause_Kinds is
150 begin
151 case F.Flat_Kind (Clause) is
152 when F.A_Use_Package_Clause =>
153 return A_Use_Package_Clause;
154 when F.A_Use_Type_Clause =>
155 return A_Use_Type_Clause;
156 when F.A_With_Clause =>
157 return A_With_Clause;
158 when F.A_Representation_Clause =>
159 return A_Representation_Clause;
160 when F.A_Component_Clause =>
161 return A_Component_Clause;
162 when others =>
163 return Not_A_Clause;
164 end case;
165 end Clause_Kind;
166
167 -------------------------
168 -- Compilation_Pragmas --
169 -------------------------
170
171 function Compilation_Pragmas
172 (Compilation_Unit : in Asis.Compilation_Unit)
173 return Asis.Pragma_Element_List
174 is
175 begin
176 Check_Nil_Unit (Compilation_Unit, "Compilation_Pragmas");
177 Raise_Not_Implemented ("");
178 return Asis.Nil_Element_List;
179 end Compilation_Pragmas;
180
181 ---------------------------
182 -- Configuration_Pragmas --
183 ---------------------------
184
185 function Configuration_Pragmas
186 (The_Context : in Asis.Context)
187 return Asis.Pragma_Element_List
188 is
189 pragma Unreferenced (The_Context);
190 begin
191 -- Check_Context (The_Context);
192 Raise_Not_Implemented ("");
193 return Asis.Nil_Element_List;
194 end Configuration_Pragmas;
195
196 ---------------------
197 -- Constraint_Kind --
198 ---------------------
199
200 function Constraint_Kind
201 (Definition : in Asis.Constraint)
202 return Asis.Constraint_Kinds
203 is
204 Map : constant array (F.A_Constraint) of Asis.Constraint_Kinds :=
205 (F.A_Range_Attribute_Reference => Asis.A_Range_Attribute_Reference,
206 F.A_Simple_Expression_Range => Asis.A_Simple_Expression_Range,
207 F.A_Digits_Constraint => Asis.A_Digits_Constraint,
208 F.A_Delta_Constraint => Asis.A_Delta_Constraint,
209 F.An_Index_Constraint => Asis.An_Index_Constraint,
210 F.A_Discriminant_Constraint => Asis.A_Discriminant_Constraint);
211
212 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
213 Asis.Extensions.Flat_Kinds.Flat_Kind (Definition);
214 begin
215 if Kind in Map'Range then
216 return Map (Kind);
217 else
218 return Not_A_Constraint;
219 end if;
220 end Constraint_Kind;
221
222 -----------------------------
223 -- Context_Clause_Elements --
224 -----------------------------
225
226 function Context_Clause_Elements
227 (Compilation_Unit : in Asis.Compilation_Unit;
228 Include_Pragmas : in Boolean := False)
229 return Asis.Context_Clause_List
230 is
231 pragma Unreferenced (Include_Pragmas);
232
233 package Get is
234
235 type Visiter is new Gela.Element_Visiters.Visiter with record
236 Result : Gela.Elements.Context_Items.Context_Item_Sequence_Access;
237 end record;
238
239 overriding procedure Compilation_Unit_Body
240 (Self : in out Visiter;
241 Node : not null Gela.Elements.Compilation_Unit_Bodies.
242 Compilation_Unit_Body_Access);
243
244 overriding procedure Compilation_Unit_Declaration
245 (Self : in out Visiter;
246 Node : not null Gela.Elements.Compilation_Unit_Declarations.
247 Compilation_Unit_Declaration_Access);
248
249 overriding procedure Subunit
250 (Self : in out Visiter;
251 Node : not null Gela.Elements.Subunits.Subunit_Access);
252
253 end Get;
254
255 package body Get is
256
257 overriding procedure Compilation_Unit_Body
258 (Self : in out Visiter;
259 Node : not null Gela.Elements.Compilation_Unit_Bodies.
260 Compilation_Unit_Body_Access) is
261 begin
262 Self.Result := Node.Context_Clause_Elements;
263 end Compilation_Unit_Body;
264
265 overriding procedure Compilation_Unit_Declaration
266 (Self : in out Visiter;
267 Node : not null Gela.Elements.Compilation_Unit_Declarations.
268 Compilation_Unit_Declaration_Access) is
269 begin
270 Self.Result := Node.Context_Clause_Elements;
271 end Compilation_Unit_Declaration;
272
273 overriding procedure Subunit
274 (Self : in out Visiter;
275 Node : not null Gela.Elements.Subunits.Subunit_Access) is
276 begin
277 Self.Result := Node.Context_Clause_Elements;
278 end Subunit;
279
280 end Get;
281
282 Tree : Gela.Elements.Compilation_Units.Compilation_Unit_Access;
283 V : aliased Get.Visiter;
284 begin
285 Check_Nil_Unit (Compilation_Unit, "Context_Clause_Elements");
286 Tree := Compilation_Unit.Data.Tree;
287 Tree.Visit (V);
288
289 declare
290 Result : Asis.Element_List (1 .. Asis.ASIS_Natural (V.Result.Length));
291 C : Gela.Elements.Context_Items.Context_Item_Sequence_Cursor :=
292 V.Result.First;
293 begin
294 for J in Result'Range loop
295 Result (J) := (Data => Gela.Elements.Element_Access (C.Element));
296 C.Next;
297 end loop;
298
299 return Result;
300 end;
301 end Context_Clause_Elements;
302
303 ---------------------------
304 -- Corresponding_Pragmas --
305 ---------------------------
306
307 function Corresponding_Pragmas
308 (Element : in Asis.Element)
309 return Asis.Pragma_Element_List
310 is
311 begin
312 Check_Nil_Element (Element, "Corresponding_Pragmas");
313 Raise_Not_Implemented ("");
314 return Asis.Nil_Element_List;
315 end Corresponding_Pragmas;
316
317 -----------------
318 -- Debug_Image --
319 -----------------
320
321 function Debug_Image (Element : in Asis.Element) return Wide_String is
322 pragma Unreferenced (Element);
323 begin
324 return "";
325 end Debug_Image;
326
327 ----------------------
328 -- Declaration_Kind --
329 ----------------------
330
331 function Declaration_Kind
332 (Declaration : in Asis.Declaration)
333 return Asis.Declaration_Kinds
334 is
335 Map : constant array (F.A_Declaration) of Asis.Declaration_Kinds :=
336 (F.An_Ordinary_Type_Declaration => Asis.An_Ordinary_Type_Declaration,
337 F.A_Task_Type_Declaration => Asis.A_Task_Type_Declaration,
338 F.A_Protected_Type_Declaration => Asis.A_Protected_Type_Declaration,
339 F.An_Incomplete_Type_Declaration =>
340 Asis.An_Incomplete_Type_Declaration,
341 F.A_Private_Type_Declaration => Asis.A_Private_Type_Declaration,
342 F.A_Private_Extension_Declaration =>
343 Asis.A_Private_Extension_Declaration,
344 F.A_Subtype_Declaration => Asis.A_Subtype_Declaration,
345 F.A_Variable_Declaration => Asis.A_Variable_Declaration,
346 F.A_Constant_Declaration => Asis.A_Constant_Declaration,
347 F.A_Deferred_Constant_Declaration =>
348 Asis.A_Deferred_Constant_Declaration,
349 F.A_Single_Task_Declaration => Asis.A_Single_Task_Declaration,
350 F.A_Single_Protected_Declaration =>
351 Asis.A_Single_Protected_Declaration,
352 F.An_Integer_Number_Declaration => Asis.An_Integer_Number_Declaration,
353 F.A_Real_Number_Declaration => Asis.A_Real_Number_Declaration,
354 F.An_Enumeration_Literal_Specification =>
355 Asis.An_Enumeration_Literal_Specification,
356 F.A_Discriminant_Specification => Asis.A_Discriminant_Specification,
357 F.A_Component_Declaration => Asis.A_Component_Declaration,
358 F.A_Return_Object_Specification => Asis.A_Return_Object_Specification,
359 F.A_Loop_Parameter_Specification =>
360 Asis.A_Loop_Parameter_Specification,
361 F.A_Procedure_Declaration => Asis.A_Procedure_Declaration,
362 F.A_Function_Declaration => Asis.A_Function_Declaration,
363 F.A_Parameter_Specification => Asis.A_Parameter_Specification,
364 F.A_Procedure_Body_Declaration => Asis.A_Procedure_Body_Declaration,
365 F.A_Function_Body_Declaration => Asis.A_Function_Body_Declaration,
366 F.A_Package_Declaration => Asis.A_Package_Declaration,
367 F.A_Package_Body_Declaration => Asis.A_Package_Body_Declaration,
368 F.An_Object_Renaming_Declaration =>
369 Asis.An_Object_Renaming_Declaration,
370 F.An_Exception_Renaming_Declaration =>
371 Asis.An_Exception_Renaming_Declaration,
372 F.A_Package_Renaming_Declaration =>
373 Asis.A_Package_Renaming_Declaration,
374 F.A_Procedure_Renaming_Declaration =>
375 Asis.A_Procedure_Renaming_Declaration,
376 F.A_Function_Renaming_Declaration =>
377 Asis.A_Function_Renaming_Declaration,
378 F.A_Generic_Package_Renaming_Declaration =>
379 Asis.A_Generic_Package_Renaming_Declaration,
380 F.A_Generic_Procedure_Renaming_Declaration =>
381 Asis.A_Generic_Procedure_Renaming_Declaration,
382 F.A_Generic_Function_Renaming_Declaration =>
383 Asis.A_Generic_Function_Renaming_Declaration,
384 F.A_Task_Body_Declaration => Asis.A_Task_Body_Declaration,
385 F.A_Protected_Body_Declaration => Asis.A_Protected_Body_Declaration,
386 F.An_Entry_Declaration => Asis.An_Entry_Declaration,
387 F.An_Entry_Body_Declaration => Asis.An_Entry_Body_Declaration,
388 F.An_Entry_Index_Specification => Asis.An_Entry_Index_Specification,
389 F.A_Procedure_Body_Stub => Asis.A_Procedure_Body_Stub,
390 F.A_Function_Body_Stub => Asis.A_Function_Body_Stub,
391 F.A_Package_Body_Stub => Asis.A_Package_Body_Stub,
392 F.A_Task_Body_Stub => Asis.A_Task_Body_Stub,
393 F.A_Protected_Body_Stub => Asis.A_Protected_Body_Stub,
394 F.An_Exception_Declaration => Asis.An_Exception_Declaration,
395 F.A_Choice_Parameter_Specification =>
396 Asis.A_Choice_Parameter_Specification,
397 F.A_Generic_Procedure_Declaration =>
398 Asis.A_Generic_Procedure_Declaration,
399 F.A_Generic_Function_Declaration =>
400 Asis.A_Generic_Function_Declaration,
401 F.A_Generic_Package_Declaration => Asis.A_Generic_Package_Declaration,
402 F.A_Package_Instantiation => Asis.A_Package_Instantiation,
403 F.A_Procedure_Instantiation => Asis.A_Procedure_Instantiation,
404 F.A_Function_Instantiation => Asis.A_Function_Instantiation,
405 F.A_Formal_Object_Declaration => Asis.A_Formal_Object_Declaration,
406 F.A_Formal_Type_Declaration => Asis.A_Formal_Type_Declaration,
407 F.A_Formal_Procedure_Declaration =>
408 Asis.A_Formal_Procedure_Declaration,
409 F.A_Formal_Function_Declaration => Asis.A_Formal_Function_Declaration,
410 F.A_Formal_Package_Declaration => Asis.A_Formal_Package_Declaration,
411 F.A_Formal_Package_Declaration_With_Box =>
412 Asis.A_Formal_Package_Declaration_With_Box);
413
414 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
415 Asis.Extensions.Flat_Kinds.Flat_Kind (Declaration);
416 begin
417 if Kind in Map'Range then
418 return Map (Kind);
419 else
420 return Not_A_Declaration;
421 end if;
422 end Declaration_Kind;
423
424 ------------------------
425 -- Declaration_Origin --
426 ------------------------
427
428 function Declaration_Origin
429 (Declaration : in Asis.Declaration)
430 return Asis.Declaration_Origins
431 is
432 begin
433 if Assigned (Declaration) then
434 Raise_Not_Implemented ("");
435 return Not_A_Declaration_Origin;
436 else
437 return Not_A_Declaration_Origin;
438 end if;
439 end Declaration_Origin;
440
441 ------------------
442 -- Default_Kind --
443 ------------------
444
445 function Default_Kind
446 (Declaration : in Asis.Generic_Formal_Parameter)
447 return Asis.Subprogram_Default_Kinds
448 is
449 begin
450 if Assigned (Declaration) then
451 Raise_Not_Implemented ("");
452 return Not_A_Default;
453 else
454 return Not_A_Default;
455 end if;
456 end Default_Kind;
457
458 ------------------------
459 -- Defining_Name_Kind --
460 ------------------------
461
462 function Defining_Name_Kind
463 (Defining_Name : in Asis.Defining_Name)
464 return Asis.Defining_Name_Kinds
465 is
466 begin
467 case F.Flat_Kind (Defining_Name) is
468 when F.A_Defining_Identifier =>
469 return Asis.A_Defining_Identifier;
470 when F.A_Defining_Character_Literal =>
471 return Asis.A_Defining_Character_Literal;
472 when F.A_Defining_Enumeration_Literal =>
473 return Asis.A_Defining_Enumeration_Literal;
474 when F.A_Defining_Operator_Symbol =>
475 return Asis.A_Defining_Operator_Symbol;
476 when F.A_Defining_Expanded_Name =>
477 return Asis.A_Defining_Expanded_Name;
478 when others =>
479 return Not_A_Defining_Name;
480 end case;
481 end Defining_Name_Kind;
482
483 ---------------------
484 -- Definition_Kind --
485 ---------------------
486
487 function Definition_Kind
488 (Definition : in Asis.Definition)
489 return Asis.Definition_Kinds
490 is
491 begin
492 case F.Flat_Kind (Definition) is
493 when F.A_Type_Definition =>
494 return Asis.A_Type_Definition;
495 when F.A_Subtype_Indication =>
496 return Asis.A_Subtype_Indication;
497 when F.A_Constraint =>
498 return Asis.A_Constraint;
499 when F.A_Component_Definition =>
500 return Asis.A_Component_Definition;
501 when F.A_Discrete_Subtype_Definition =>
502 return Asis.A_Discrete_Subtype_Definition;
503 when F.A_Discrete_Range =>
504 return Asis.A_Discrete_Range;
505 when F.An_Unknown_Discriminant_Part =>
506 return Asis.An_Unknown_Discriminant_Part;
507 when F.A_Known_Discriminant_Part =>
508 return Asis.A_Known_Discriminant_Part;
509 when F.A_Record_Definition =>
510 return Asis.A_Record_Definition;
511 when F.A_Null_Record_Definition =>
512 return Asis.A_Null_Record_Definition;
513 when F.A_Null_Component =>
514 return Asis.A_Null_Component;
515 when F.A_Variant_Part =>
516 return Asis.A_Variant_Part;
517 when F.A_Variant =>
518 return Asis.A_Variant;
519 when F.An_Others_Choice =>
520 return Asis.An_Others_Choice;
521 when F.An_Access_Definition =>
522 return Asis.An_Access_Definition;
523 when F.An_Incomplete_Type_Definition =>
524 return Asis.An_Incomplete_Type_Definition;
525 when F.A_Tagged_Incomplete_Type_Definition =>
526 return Asis.A_Tagged_Incomplete_Type_Definition;
527 when F.A_Private_Type_Definition =>
528 return Asis.A_Private_Type_Definition;
529 when F.A_Tagged_Private_Type_Definition =>
530 return Asis.A_Tagged_Private_Type_Definition;
531 when F.A_Private_Extension_Definition =>
532 return Asis.A_Private_Extension_Definition;
533 when F.A_Task_Definition =>
534 return Asis.A_Task_Definition;
535 when F.A_Protected_Definition =>
536 return Asis.A_Protected_Definition;
537 when F.A_Formal_Type_Definition =>
538 return Asis.A_Formal_Type_Definition;
539 when others =>
540 return Asis.Not_A_Definition;
541 end case;
542 end Definition_Kind;
543
544 -------------------------
545 -- Discrete_Range_Kind --
546 -------------------------
547
548 function Discrete_Range_Kind
549 (Definition : in Asis.Discrete_Range)
550 return Asis.Discrete_Range_Kinds
551 is
552 Map : constant array (F.A_Discrete_Range) of Asis.Discrete_Range_Kinds
553 := (F.A_Discrete_Subtype_Indication_DR =>
554 A_Discrete_Subtype_Indication,
555 F.A_Discrete_Range_Attribute_Reference_DR =>
556 A_Discrete_Range_Attribute_Reference,
557 F.A_Discrete_Simple_Expression_Range_DR =>
558 A_Discrete_Simple_Expression_Range);
559
560 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
561 Asis.Extensions.Flat_Kinds.Flat_Kind (Definition);
562 begin
563 if Kind in Map'Range then
564 return Map (Kind);
565 else
566 return Not_A_Discrete_Range;
567 end if;
568 end Discrete_Range_Kind;
569
570 ------------------
571 -- Element_Kind --
572 ------------------
573
574 function Element_Kind
575 (Element : in Asis.Element) return Asis.Element_Kinds is
576 begin
577 case F.Flat_Kind (Element) is
578 when F.A_Pragma =>
579 return A_Pragma;
580 when F.A_Defining_Name =>
581 return A_Defining_Name;
582 when F.A_Declaration =>
583 return A_Declaration;
584 when F.A_Definition =>
585 return A_Definition;
586 when F.An_Expression =>
587 return An_Expression;
588 when F.An_Association =>
589 return An_Association;
590 when F.A_Statement =>
591 return A_Statement;
592 when F.A_Path =>
593 return A_Path;
594 when F.A_Clause =>
595 return A_Clause;
596 when F.An_Exception_Handler =>
597 return An_Exception_Handler;
598 when others =>
599 return Not_An_Element;
600 end case;
601 end Element_Kind;
602
603 --------------------------------
604 -- Enclosing_Compilation_Unit --
605 --------------------------------
606
607 function Enclosing_Compilation_Unit
608 (Element : in Asis.Element)
609 return Asis.Compilation_Unit
610 is
611 use type Gela.Compilation_Units.Compilation_Unit_Access;
612
613 procedure Find
614 (List : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
615 Unit : out Gela.Compilation_Units.Compilation_Unit_Access);
616
617 Comp : Gela.Compilations.Compilation_Access;
618 From : Gela.Lexical_Types.Token_Count;
619 To : Gela.Lexical_Types.Token_Count;
620
621 ----------
622 -- Find --
623 ----------
624
625 procedure Find
626 (List : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
627 Unit : out Gela.Compilation_Units.Compilation_Unit_Access)
628 is
629 use Gela.Compilations;
630 use type Gela.Lexical_Types.Token_Count;
631 Tree : Gela.Elements.Compilation_Units.Compilation_Unit_Access;
632 Cursor : Gela.Compilation_Unit_Sets.Compilation_Unit_Cursor'Class :=
633 List.First;
634 begin
635 while Cursor.Has_Element loop
636 Unit := Cursor.Element;
637 Tree := Unit.Tree;
638
639 if Unit.Compilation = Comp
640 and then Tree.First_Token <= From
641 and then Tree.Last_Token >= To
642 then
643 return;
644 end if;
645
646 Cursor.Next;
647 end loop;
648
649 Unit := null;
650 end Find;
651
652 Context : Gela.Contexts.Context_Access;
653 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
654
655 begin
656 Check_Nil_Element (Element, "Enclosing_Compilation_Unit");
657 Comp := Element.Data.Enclosing_Compilation;
658 Context := Comp.Context;
659 From := Element.Data.First_Token;
660 To := Element.Data.Last_Token;
661 Find (Context.Library_Unit_Declarations, Unit);
662
663 if Unit = null then
664 Find (Context.Compilation_Unit_Bodies, Unit);
665 end if;
666
667 -- Raise_Not_Implemented ("");
668 return (Data => Unit);
669 end Enclosing_Compilation_Unit;
670
671 -----------------------
672 -- Enclosing_Element --
673 -----------------------
674
675 function Enclosing_Element
676 (Element : in Asis.Element)
677 return Asis.Element
678 is
679 Next : Asis.Element := Element;
680 begin
681 Check_Nil_Element (Element, "Enclosing_Element");
682 loop
683 Next := (Data => Next.Data.Enclosing_Element);
684
685 if not Assigned (Next) or else not Auxilary (Next) then
686 return Next;
687 end if;
688 end loop;
689 end Enclosing_Element;
690
691 -----------------------
692 -- Enclosing_Element --
693 -----------------------
694
695 function Enclosing_Element
696 (Element : in Asis.Element;
697 Expected_Enclosing_Element : in Asis.Element)
698 return Asis.Element
699 is
700 pragma Unreferenced (Expected_Enclosing_Element);
701 begin
702 return Enclosing_Element (Element);
703 end Enclosing_Element;
704
705 ---------------------
706 -- Expression_Kind --
707 ---------------------
708
709 function Expression_Kind
710 (Expression : in Asis.Expression) return Asis.Expression_Kinds is
711 begin
712 case F.Flat_Kind (Expression) is
713 when F.A_Box_Expression =>
714 return Asis.A_Box_Expression;
715 when F.An_Integer_Literal =>
716 return Asis.An_Integer_Literal;
717 when F.A_Real_Literal =>
718 return Asis.A_Real_Literal;
719 when F.A_String_Literal =>
720 return Asis.A_String_Literal;
721 when F.An_Identifier =>
722 return Asis.An_Identifier;
723 when F.An_Operator_Symbol =>
724 return Asis.An_Operator_Symbol;
725 when F.A_Character_Literal =>
726 return Asis.A_Character_Literal;
727 when F.An_Enumeration_Literal =>
728 return Asis.An_Enumeration_Literal;
729 when F.An_Explicit_Dereference =>
730 return Asis.An_Explicit_Dereference;
731 when F.A_Function_Call =>
732 return Asis.A_Function_Call;
733 when F.An_Indexed_Component =>
734 return Asis.An_Indexed_Component;
735 when F.A_Slice =>
736 return Asis.A_Slice;
737 when F.A_Selected_Component =>
738 return Asis.A_Selected_Component;
739 when F.An_Attribute_Reference =>
740 return Asis.An_Attribute_Reference;
741 when F.A_Record_Aggregate =>
742 return Asis.A_Record_Aggregate;
743 when F.An_Extension_Aggregate =>
744 return Asis.An_Extension_Aggregate;
745 when F.A_Positional_Array_Aggregate =>
746 return Asis.A_Positional_Array_Aggregate;
747 when F.A_Named_Array_Aggregate =>
748 return Asis.A_Named_Array_Aggregate;
749 when F.An_And_Then_Short_Circuit =>
750 return Asis.An_And_Then_Short_Circuit;
751 when F.An_Or_Else_Short_Circuit =>
752 return Asis.An_Or_Else_Short_Circuit;
753 when F.An_In_Range_Membership_Test =>
754 return Asis.An_In_Range_Membership_Test;
755 when F.A_Not_In_Range_Membership_Test =>
756 return Asis.A_Not_In_Range_Membership_Test;
757 when F.An_In_Type_Membership_Test =>
758 return Asis.An_In_Type_Membership_Test;
759 when F.A_Not_In_Type_Membership_Test =>
760 return Asis.A_Not_In_Type_Membership_Test;
761 when F.A_Null_Literal =>
762 return Asis.A_Null_Literal;
763 when F.A_Parenthesized_Expression =>
764 return Asis.A_Parenthesized_Expression;
765 when F.A_Type_Conversion =>
766 return Asis.A_Type_Conversion;
767 when F.A_Qualified_Expression =>
768 return Asis.A_Qualified_Expression;
769 when F.An_Allocation_From_Subtype =>
770 return Asis.An_Allocation_From_Subtype;
771 when F.An_Allocation_From_Qualified_Expression =>
772 return Asis.An_Allocation_From_Qualified_Expression;
773 when others =>
774 return Not_An_Expression;
775 end case;
776 end Expression_Kind;
777
778 ----------------------
779 -- Formal_Type_Kind --
780 ----------------------
781
782 function Formal_Type_Kind
783 (Definition : in Asis.Formal_Type_Definition)
784 return Asis.Formal_Type_Kinds
785 is
786 begin
787 if Assigned (Definition) then
788 Raise_Not_Implemented ("");
789 return Not_A_Formal_Type_Definition;
790 else
791 return Not_A_Formal_Type_Definition;
792 end if;
793 end Formal_Type_Kind;
794
795 -----------------
796 -- Has_Limited --
797 -----------------
798
799 function Has_Limited (Element : in Asis.Element) return Boolean is
800 begin
801 if Assigned (Element) then
802 Raise_Not_Implemented ("");
803 return False;
804 else
805 return False;
806 end if;
807 end Has_Limited;
808
809 -----------------
810 -- Has_Private --
811 -----------------
812
813 function Has_Private (Element : in Asis.Element) return Boolean is
814 begin
815 if Assigned (Element) then
816 Raise_Not_Implemented ("");
817 return False;
818 else
819 return False;
820 end if;
821 end Has_Private;
822
823 ------------------
824 -- Has_Abstract --
825 ------------------
826
827 function Has_Abstract (Element : in Asis.Element) return Boolean is
828 begin
829 if Assigned (Element) then
830 Raise_Not_Implemented ("");
831 return False;
832 else
833 return False;
834 end if;
835 end Has_Abstract;
836
837 -----------------
838 -- Has_Reverse --
839 -----------------
840
841 function Has_Reverse (Element : in Asis.Element) return Boolean is
842 begin
843 return Trait_Kind (Element) = A_Reverse_Trait;
844 end Has_Reverse;
845
846 -----------------
847 -- Has_Aliased --
848 -----------------
849
850 function Has_Aliased (Element : in Asis.Element) return Boolean is
851 begin
852 return Trait_Kind (Element) = An_Aliased_Trait;
853 end Has_Aliased;
854
855 ----------------------
856 -- Has_Synchronized --
857 ----------------------
858
859 function Has_Synchronized (Element : in Asis.Element) return Boolean is
860 begin
861 if Assigned (Element) then
862 Raise_Not_Implemented ("");
863 return False;
864 else
865 return False;
866 end if;
867 end Has_Synchronized;
868
869 -------------------
870 -- Has_Protected --
871 -------------------
872
873 function Has_Protected (Element : in Asis.Element) return Boolean is
874 begin
875 if Assigned (Element) then
876 Raise_Not_Implemented ("");
877 return False;
878 else
879 return False;
880 end if;
881 end Has_Protected;
882
883 ----------------
884 -- Has_Tagged --
885 ----------------
886
887 function Has_Tagged (Element : in Asis.Element) return Boolean is
888 begin
889 if Assigned (Element) then
890 Raise_Not_Implemented ("");
891 return False;
892 else
893 return False;
894 end if;
895 end Has_Tagged;
896
897 --------------
898 -- Has_Task --
899 --------------
900
901 function Has_Task (Element : in Asis.Element) return Boolean is
902 begin
903 if Assigned (Element) then
904 Raise_Not_Implemented ("");
905 return False;
906 else
907 return False;
908 end if;
909 end Has_Task;
910
911 ------------------------
912 -- Has_Null_Exclusion --
913 ------------------------
914
915 function Has_Null_Exclusion (Element : Asis.Element) return Boolean is
916 begin
917 if Assigned (Element) then
918 Raise_Not_Implemented ("");
919 return False;
920 else
921 return False;
922 end if;
923 end Has_Null_Exclusion;
924
925 ----------
926 -- Hash --
927 ----------
928
929 function Hash (Element : in Asis.Element) return Asis.ASIS_Integer is
930 use type Ada.Containers.Hash_Type;
931
932 X : Ada.Containers.Hash_Type;
933 begin
934 if Assigned (Element) then
935 X := Element.Data.Hash;
936 X := X and Ada.Containers.Hash_Type (ASIS_Integer'Last);
937 return ASIS_Integer (X);
938 else
939 return 0;
940 end if;
941 end Hash;
942
943 --------------------
944 -- Interface_Kind --
945 --------------------
946
947 function Interface_Kind
948 (Definition : Asis.Definition)
949 return Asis.Interface_Kinds is
950 begin
951 if Assigned (Definition) then
952 if Type_Kind (Definition) = An_Interface_Type_Definition or
953 Formal_Type_Kind (Definition) =
954 A_Formal_Interface_Type_Definition
955 then
956 if Has_Task (Definition) then
957 return A_Task_Interface;
958 elsif Has_Limited (Definition) then
959 return A_Limited_Interface;
960 elsif Has_Protected (Definition) then
961 return A_Protected_Interface;
962 elsif Has_Synchronized (Definition) then
963 return A_Synchronized_Interface;
964 else
965 return An_Ordinary_Interface;
966 end if;
967 end if;
968 end if;
969
970 return Not_An_Interface;
971 end Interface_Kind;
972
973 ----------------------------
974 -- Is_Abstract_Subprogram --
975 ----------------------------
976
977 function Is_Abstract_Subprogram
978 (Element : in Asis.Element)
979 return Boolean
980 is
981 begin
982 case Declaration_Kind (Element) is
983 when A_Procedure_Declaration |
984 A_Function_Declaration |
985 A_Formal_Procedure_Declaration |
986 A_Formal_Function_Declaration =>
987 return Has_Abstract (Element);
988 when others =>
989 return False;
990 end case;
991 end Is_Abstract_Subprogram;
992
993 --------------
994 -- Is_Equal --
995 --------------
996
997 function Is_Equal
998 (Left : in Asis.Element;
999 Right : in Asis.Element)
1000 return Boolean
1001 is
1002 pragma Unreferenced (Left);
1003 pragma Unreferenced (Right);
1004 begin
1005 Raise_Not_Implemented ("");
1006 return False;
1007 end Is_Equal;
1008
1009 ------------------
1010 -- Is_Identical --
1011 ------------------
1012
1013 function Is_Identical
1014 (Left : in Asis.Element;
1015 Right : in Asis.Element)
1016 return Boolean
1017 is
1018 use type Gela.Elements.Element_Access;
1019 begin
1020 return Left.Data = Right.Data;
1021 end Is_Identical;
1022
1023 ------------
1024 -- Is_Nil --
1025 ------------
1026
1027 function Is_Nil (Right : in Asis.Element) return Boolean is
1028 begin
1029 return not Assigned (Right);
1030 end Is_Nil;
1031
1032 ------------
1033 -- Is_Nil --
1034 ------------
1035
1036 function Is_Nil (Right : in Asis.Element_List) return Boolean is
1037 begin
1038 return Right'Length = 0;
1039 end Is_Nil;
1040
1041 -----------------------
1042 -- Is_Null_Procedure --
1043 -----------------------
1044
1045 function Is_Null_Procedure (Element : in Asis.Element) return Boolean is
1046 begin
1047 if Assigned (Element) then
1048 Raise_Not_Implemented ("");
1049 return False;
1050 else
1051 return False;
1052 end if;
1053 end Is_Null_Procedure;
1054
1055 -------------------------
1056 -- Is_Part_Of_Implicit --
1057 -------------------------
1058
1059 function Is_Part_Of_Implicit (Element : in Asis.Element) return Boolean is
1060 begin
1061 if Assigned (Element) then
1062 return Element.Data.Is_Part_Of_Implicit;
1063 else
1064 return False;
1065 end if;
1066 end Is_Part_Of_Implicit;
1067
1068 --------------------------
1069 -- Is_Part_Of_Inherited --
1070 --------------------------
1071
1072 function Is_Part_Of_Inherited
1073 (Element : in Asis.Element)
1074 return Boolean
1075 is
1076 begin
1077 if Assigned (Element) then
1078 return Element.Data.Is_Part_Of_Inherited;
1079 else
1080 return False;
1081 end if;
1082 end Is_Part_Of_Inherited;
1083
1084 -------------------------
1085 -- Is_Part_Of_Instance --
1086 -------------------------
1087
1088 function Is_Part_Of_Instance (Element : in Asis.Element) return Boolean is
1089 begin
1090 if Assigned (Element) then
1091 return Element.Data.Is_Part_Of_Instance;
1092 else
1093 return False;
1094 end if;
1095 end Is_Part_Of_Instance;
1096
1097 ---------------
1098 -- Mode_Kind --
1099 ---------------
1100
1101 function Mode_Kind
1102 (Declaration : in Asis.Declaration)
1103 return Asis.Mode_Kinds
1104 is
1105 begin
1106 if Assigned (Declaration) then
1107 Raise_Not_Implemented ("");
1108 return Not_A_Mode;
1109 else
1110 return Not_A_Mode;
1111 end if;
1112 end Mode_Kind;
1113
1114 -------------------
1115 -- Operator_Kind --
1116 -------------------
1117
1118 function Operator_Kind
1119 (Element : in Asis.Element)
1120 return Asis.Operator_Kinds
1121 is
1122 begin
1123 if Assigned (Element) then
1124 Raise_Not_Implemented ("");
1125 return Not_An_Operator;
1126 else
1127 return Not_An_Operator;
1128 end if;
1129 end Operator_Kind;
1130
1131 ---------------
1132 -- Path_Kind --
1133 ---------------
1134
1135 function Path_Kind (Path : in Asis.Path) return Asis.Path_Kinds is
1136 Map : constant array (F.A_Path) of Asis.Path_Kinds
1137 := (F.An_If_Path => Asis.An_If_Path,
1138 F.An_Elsif_Path => Asis.An_Elsif_Path,
1139 F.An_Else_Path => Asis.An_Else_Path,
1140 F.A_Case_Path => Asis.A_Case_Path,
1141 F.A_Select_Path => Asis.A_Select_Path,
1142 F.An_Or_Path => Asis.An_Or_Path,
1143 F.A_Then_Abort_Path => Asis.A_Then_Abort_Path);
1144
1145 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
1146 Asis.Extensions.Flat_Kinds.Flat_Kind (Path);
1147 begin
1148 if Kind in Map'Range then
1149 return Map (Kind);
1150 else
1151 return Not_A_Path;
1152 end if;
1153 end Path_Kind;
1154
1155 ----------------------------------
1156 -- Pragma_Argument_Associations --
1157 ----------------------------------
1158
1159 function Pragma_Argument_Associations
1160 (Pragma_Element : in Asis.Pragma_Element)
1161 return Asis.Association_List
1162 is
1163 begin
1164 Check_Nil_Element (Pragma_Element, "Pragma_Argument_Associations");
1165 Raise_Not_Implemented ("");
1166 return Asis.Nil_Element_List;
1167 end Pragma_Argument_Associations;
1168
1169 -----------------
1170 -- Pragma_Kind --
1171 -----------------
1172
1173 function Pragma_Kind
1174 (Pragma_Element : in Asis.Pragma_Element)
1175 return Asis.Pragma_Kinds
1176 is
1177 begin
1178 if Assigned (Pragma_Element) then
1179 return Not_A_Pragma;
1180 else
1181 return Not_A_Pragma;
1182 end if;
1183 end Pragma_Kind;
1184
1185 -----------------------
1186 -- Pragma_Name_Image --
1187 -----------------------
1188
1189 function Pragma_Name_Image
1190 (Pragma_Element : in Asis.Pragma_Element)
1191 return Program_Text
1192 is
1193 begin
1194 Check_Nil_Element (Pragma_Element, "Pragma_Name_Image");
1195 Raise_Not_Implemented ("");
1196 return "";
1197 end Pragma_Name_Image;
1198
1199 -------------
1200 -- Pragmas --
1201 -------------
1202
1203 function Pragmas
1204 (The_Element : in Asis.Element)
1205 return Asis.Pragma_Element_List
1206 is
1207 begin
1208 Check_Nil_Element (The_Element, "Pragmas");
1209 Raise_Not_Implemented ("");
1210 return Asis.Nil_Element_List;
1211 end Pragmas;
1212
1213 --------------------------------
1214 -- Representation_Clause_Kind --
1215 --------------------------------
1216
1217 function Representation_Clause_Kind
1218 (Clause : in Asis.Representation_Clause)
1219 return Asis.Representation_Clause_Kinds
1220 is
1221 begin
1222 if Assigned (Clause) then
1223 Raise_Not_Implemented ("");
1224 return Not_A_Representation_Clause;
1225 else
1226 return Not_A_Representation_Clause;
1227 end if;
1228 end Representation_Clause_Kind;
1229
1230 --------------------
1231 -- Root_Type_Kind --
1232 --------------------
1233
1234 function Root_Type_Kind
1235 (Definition : in Asis.Root_Type_Definition)
1236 return Asis.Root_Type_Kinds
1237 is
1238 begin
1239 if Assigned (Definition) then
1240 Raise_Not_Implemented ("");
1241 return Not_A_Root_Type_Definition;
1242 else
1243 return Not_A_Root_Type_Definition;
1244 end if;
1245 end Root_Type_Kind;
1246
1247 --------------------
1248 -- Statement_Kind --
1249 --------------------
1250
1251 function Statement_Kind
1252 (Statement : in Asis.Statement)
1253 return Asis.Statement_Kinds
1254 is
1255 Map : constant array (F.A_Statement) of Asis.Statement_Kinds :=
1256 (F.A_Null_Statement => Asis.A_Null_Statement,
1257 F.An_Assignment_Statement => Asis.An_Assignment_Statement,
1258 F.An_If_Statement => Asis.An_If_Statement,
1259 F.A_Case_Statement => Asis.A_Case_Statement,
1260 F.A_Loop_Statement => Asis.A_Loop_Statement,
1261 F.A_While_Loop_Statement => Asis.A_While_Loop_Statement,
1262 F.A_For_Loop_Statement => Asis.A_For_Loop_Statement,
1263 F.A_Block_Statement => Asis.A_Block_Statement,
1264 F.An_Exit_Statement => Asis.An_Exit_Statement,
1265 F.A_Goto_Statement => Asis.A_Goto_Statement,
1266 F.A_Procedure_Call_Statement => Asis.A_Procedure_Call_Statement,
1267 F.A_Simple_Return_Statement => Asis.A_Simple_Return_Statement,
1268 F.An_Extended_Return_Statement => Asis.An_Extended_Return_Statement,
1269 F.An_Accept_Statement => Asis.An_Accept_Statement,
1270 F.An_Entry_Call_Statement => Asis.An_Entry_Call_Statement,
1271 F.A_Requeue_Statement => Asis.A_Requeue_Statement,
1272 F.A_Requeue_Statement_With_Abort =>
1273 Asis.A_Requeue_Statement_With_Abort,
1274 F.A_Delay_Until_Statement => Asis.A_Delay_Until_Statement,
1275 F.A_Delay_Relative_Statement => Asis.A_Delay_Relative_Statement,
1276 F.A_Terminate_Alternative_Statement =>
1277 Asis.A_Terminate_Alternative_Statement,
1278 F.A_Selective_Accept_Statement => Asis.A_Selective_Accept_Statement,
1279 F.A_Timed_Entry_Call_Statement => Asis.A_Timed_Entry_Call_Statement,
1280 F.A_Conditional_Entry_Call_Statement =>
1281 Asis.A_Conditional_Entry_Call_Statement,
1282 F.An_Asynchronous_Select_Statement =>
1283 Asis.An_Asynchronous_Select_Statement,
1284 F.An_Abort_Statement => Asis.An_Abort_Statement,
1285 F.A_Raise_Statement => Asis.A_Raise_Statement,
1286 F.A_Code_Statement => Asis.A_Code_Statement);
1287
1288 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
1289 Asis.Extensions.Flat_Kinds.Flat_Kind (Statement);
1290 begin
1291 if Kind in Map'Range then
1292 return Map (Kind);
1293 else
1294 return Not_A_Statement;
1295 end if;
1296 end Statement_Kind;
1297
1298 ----------------
1299 -- Trait_Kind --
1300 ----------------
1301
1302 function Trait_Kind
1303 (Element : in Asis.Element)
1304 return Asis.Trait_Kinds
1305 is
1306 begin
1307 if Assigned (Element) then
1308-- Raise_Not_Implemented ("");
1309 return Not_A_Trait;
1310 else
1311 return Not_A_Trait;
1312 end if;
1313 end Trait_Kind;
1314
1315 ---------------
1316 -- Type_Kind --
1317 ---------------
1318
1319 function Type_Kind
1320 (Definition : in Asis.Type_Definition)
1321 return Asis.Type_Kinds
1322 is
1323 begin
1324 case F.Flat_Kind (Definition) is
1325 when F.A_Derived_Type_Definition =>
1326 return Asis.A_Derived_Type_Definition;
1327 when F.A_Derived_Record_Extension_Definition =>
1328 return Asis.A_Derived_Record_Extension_Definition;
1329 when F.An_Enumeration_Type_Definition =>
1330 return Asis.An_Enumeration_Type_Definition;
1331 when F.A_Signed_Integer_Type_Definition =>
1332 return Asis.A_Signed_Integer_Type_Definition;
1333 when F.A_Modular_Type_Definition =>
1334 return Asis.A_Modular_Type_Definition;
1335 when F.A_Root_Type_Definition =>
1336 return Asis.A_Root_Type_Definition;
1337 when F.A_Floating_Point_Definition =>
1338 return A_Floating_Point_Definition;
1339 when F.An_Ordinary_Fixed_Point_Definition =>
1340 return An_Ordinary_Fixed_Point_Definition;
1341 when F.A_Decimal_Fixed_Point_Definition =>
1342 return A_Decimal_Fixed_Point_Definition;
1343 when F.An_Unconstrained_Array_Definition =>
1344 return An_Unconstrained_Array_Definition;
1345 when F.A_Constrained_Array_Definition =>
1346 return A_Constrained_Array_Definition;
1347 when F.A_Record_Type_Definition =>
1348 return A_Record_Type_Definition;
1349 when F.A_Tagged_Record_Type_Definition =>
1350 return A_Tagged_Record_Type_Definition;
1351 when F.An_Interface_Type_Definition =>
1352 return Asis.An_Interface_Type_Definition;
1353 when F.An_Access_Type_Definition =>
1354 return Asis.An_Access_Type_Definition;
1355 when others =>
1356 return Not_A_Type_Definition;
1357 end case;
1358 end Type_Kind;
1359
1360 ----------------------
1361 -- Unit_Declaration --
1362 ----------------------
1363
1364 function Unit_Declaration
1365 (Compilation_Unit : in Asis.Compilation_Unit)
1366 return Asis.Declaration
1367 is
1368 package Get is
1369
1370 type Visiter is new Gela.Element_Visiters.Visiter with record
1371 Unit : Gela.Elements.Element_Access;
1372 end record;
1373
1374 overriding procedure Compilation_Unit_Body
1375 (Self : in out Visiter;
1376 Node : not null Gela.Elements.Compilation_Unit_Bodies.
1377 Compilation_Unit_Body_Access);
1378
1379 overriding procedure Compilation_Unit_Declaration
1380 (Self : in out Visiter;
1381 Node : not null Gela.Elements.Compilation_Unit_Declarations.
1382 Compilation_Unit_Declaration_Access);
1383
1384 overriding procedure Subunit
1385 (Self : in out Visiter;
1386 Node : not null Gela.Elements.Subunits.Subunit_Access);
1387
1388 end Get;
1389
1390 package body Get is
1391
1392 overriding procedure Compilation_Unit_Body
1393 (Self : in out Visiter;
1394 Node : not null Gela.Elements.Compilation_Unit_Bodies.
1395 Compilation_Unit_Body_Access)
1396 is
1397 Result : constant Gela.Elements.Library_Unit_Bodies.
1398 Library_Unit_Body_Access := Node.Unit_Declaration;
1399 begin
1400 Self.Unit := Gela.Elements.Element_Access (Result);
1401 end Compilation_Unit_Body;
1402
1403 overriding procedure Compilation_Unit_Declaration
1404 (Self : in out Visiter;
1405 Node : not null Gela.Elements.Compilation_Unit_Declarations.
1406 Compilation_Unit_Declaration_Access)
1407 is
1408 Result : constant Gela.Elements.Library_Unit_Declarations.
1409 Library_Unit_Declaration_Access := Node.Unit_Declaration;
1410 begin
1411 Self.Unit := Gela.Elements.Element_Access (Result);
1412 end Compilation_Unit_Declaration;
1413
1414 overriding procedure Subunit
1415 (Self : in out Visiter;
1416 Node : not null Gela.Elements.Subunits.Subunit_Access)
1417 is
1418 Result : constant Gela.Elements.Proper_Bodies.Proper_Body_Access :=
1419 Node.Unit_Declaration;
1420 begin
1421 Self.Unit := Gela.Elements.Element_Access (Result);
1422 end Subunit;
1423
1424 end Get;
1425
1426 Tree : Gela.Elements.Compilation_Units.Compilation_Unit_Access;
1427 V : aliased Get.Visiter;
1428 begin
1429 Check_Nil_Unit (Compilation_Unit, "Unit_Declaration");
1430 Tree := Compilation_Unit.Data.Tree;
1431 Tree.Visit (V);
1432
1433 return (Data => V.Unit);
1434 end Unit_Declaration;
1435
1436end Asis.Elements;
1437
1438
1439------------------------------------------------------------------------------
1440-- Copyright (c) 2006-2013, Maxim Reznik
1441-- All rights reserved.
1442--
1443-- Redistribution and use in source and binary forms, with or without
1444-- modification, are permitted provided that the following conditions are met:
1445--
1446-- * Redistributions of source code must retain the above copyright notice,
1447-- this list of conditions and the following disclaimer.
1448-- * Redistributions in binary form must reproduce the above copyright
1449-- notice, this list of conditions and the following disclaimer in the
1450-- documentation and/or other materials provided with the distribution.
1451-- * Neither the name of the Maxim Reznik, IE nor the names of its
1452-- contributors may be used to endorse or promote products derived from
1453-- this software without specific prior written permission.
1454--
1455-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
1456-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
1457-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1458-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
1459-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
1460-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
1461-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
1462-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
1463-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
1464-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1465-- POSSIBILITY OF SUCH DAMAGE.
1466------------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.