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

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

Fix Asis.Elements and add next test

  • Property svn:keywords set to Date Revision
File size: 47.4 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: 401 $ $Date: 2015-02-16 17:31:23 +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 Map_2 : constant array (F.A_Discrete_Subtype_Definition)
561 of Asis.Discrete_Range_Kinds
562 := (F.A_Discrete_Subtype_Indication =>
563 A_Discrete_Subtype_Indication,
564 F.A_Discrete_Range_Attribute_Reference =>
565 A_Discrete_Range_Attribute_Reference,
566 F.A_Discrete_Simple_Expression_Range =>
567 A_Discrete_Simple_Expression_Range);
568
569 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
570 Asis.Extensions.Flat_Kinds.Flat_Kind (Definition);
571 begin
572 if Kind in Map'Range then
573 return Map (Kind);
574 elsif Kind in Map_2'Range then
575 return Map_2 (Kind);
576 else
577 return Not_A_Discrete_Range;
578 end if;
579 end Discrete_Range_Kind;
580
581 ------------------
582 -- Element_Kind --
583 ------------------
584
585 function Element_Kind
586 (Element : in Asis.Element) return Asis.Element_Kinds is
587 begin
588 case F.Flat_Kind (Element) is
589 when F.A_Pragma =>
590 return A_Pragma;
591 when F.A_Defining_Name =>
592 return A_Defining_Name;
593 when F.A_Declaration =>
594 return A_Declaration;
595 when F.A_Definition =>
596 return A_Definition;
597 when F.An_Expression =>
598 return An_Expression;
599 when F.An_Association =>
600 return An_Association;
601 when F.A_Statement =>
602 return A_Statement;
603 when F.A_Path =>
604 return A_Path;
605 when F.A_Clause =>
606 return A_Clause;
607 when F.An_Exception_Handler =>
608 return An_Exception_Handler;
609 when others =>
610 return Not_An_Element;
611 end case;
612 end Element_Kind;
613
614 --------------------------------
615 -- Enclosing_Compilation_Unit --
616 --------------------------------
617
618 function Enclosing_Compilation_Unit
619 (Element : in Asis.Element)
620 return Asis.Compilation_Unit
621 is
622 use type Gela.Compilation_Units.Compilation_Unit_Access;
623
624 procedure Find
625 (List : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
626 Unit : out Gela.Compilation_Units.Compilation_Unit_Access);
627
628 Comp : Gela.Compilations.Compilation_Access;
629 From : Gela.Lexical_Types.Token_Count;
630 To : Gela.Lexical_Types.Token_Count;
631
632 ----------
633 -- Find --
634 ----------
635
636 procedure Find
637 (List : Gela.Compilation_Unit_Sets.Compilation_Unit_Set_Access;
638 Unit : out Gela.Compilation_Units.Compilation_Unit_Access)
639 is
640 use Gela.Compilations;
641 use type Gela.Lexical_Types.Token_Count;
642 Tree : Gela.Elements.Compilation_Units.Compilation_Unit_Access;
643 Cursor : Gela.Compilation_Unit_Sets.Compilation_Unit_Cursor'Class :=
644 List.First;
645 begin
646 while Cursor.Has_Element loop
647 Unit := Cursor.Element;
648 Tree := Unit.Tree;
649
650 if Unit.Compilation = Comp
651 and then Tree.First_Token <= From
652 and then Tree.Last_Token >= To
653 then
654 return;
655 end if;
656
657 Cursor.Next;
658 end loop;
659
660 Unit := null;
661 end Find;
662
663 Context : Gela.Contexts.Context_Access;
664 Unit : Gela.Compilation_Units.Compilation_Unit_Access;
665
666 begin
667 Check_Nil_Element (Element, "Enclosing_Compilation_Unit");
668 Comp := Element.Data.Enclosing_Compilation;
669 Context := Comp.Context;
670 From := Element.Data.First_Token;
671 To := Element.Data.Last_Token;
672 Find (Context.Library_Unit_Declarations, Unit);
673
674 if Unit = null then
675 Find (Context.Compilation_Unit_Bodies, Unit);
676 end if;
677
678 -- Raise_Not_Implemented ("");
679 return (Data => Unit);
680 end Enclosing_Compilation_Unit;
681
682 -----------------------
683 -- Enclosing_Element --
684 -----------------------
685
686 function Enclosing_Element
687 (Element : in Asis.Element)
688 return Asis.Element
689 is
690 Next : Asis.Element := Element;
691 begin
692 Check_Nil_Element (Element, "Enclosing_Element");
693 loop
694 Next := (Data => Next.Data.Enclosing_Element);
695
696 if not Assigned (Next) or else not Auxilary (Next) then
697 return Next;
698 end if;
699 end loop;
700 end Enclosing_Element;
701
702 -----------------------
703 -- Enclosing_Element --
704 -----------------------
705
706 function Enclosing_Element
707 (Element : in Asis.Element;
708 Expected_Enclosing_Element : in Asis.Element)
709 return Asis.Element
710 is
711 pragma Unreferenced (Expected_Enclosing_Element);
712 begin
713 return Enclosing_Element (Element);
714 end Enclosing_Element;
715
716 ---------------------
717 -- Expression_Kind --
718 ---------------------
719
720 function Expression_Kind
721 (Expression : in Asis.Expression) return Asis.Expression_Kinds is
722 begin
723 case F.Flat_Kind (Expression) is
724 when F.A_Box_Expression =>
725 return Asis.A_Box_Expression;
726 when F.An_Integer_Literal =>
727 return Asis.An_Integer_Literal;
728 when F.A_Real_Literal =>
729 return Asis.A_Real_Literal;
730 when F.A_String_Literal =>
731 return Asis.A_String_Literal;
732 when F.An_Identifier =>
733 return Asis.An_Identifier;
734 when F.An_Operator_Symbol =>
735 return Asis.An_Operator_Symbol;
736 when F.A_Character_Literal =>
737 return Asis.A_Character_Literal;
738 when F.An_Enumeration_Literal =>
739 return Asis.An_Enumeration_Literal;
740 when F.An_Explicit_Dereference =>
741 return Asis.An_Explicit_Dereference;
742 when F.A_Function_Call =>
743 return Asis.A_Function_Call;
744 when F.An_Indexed_Component =>
745 return Asis.An_Indexed_Component;
746 when F.A_Slice =>
747 return Asis.A_Slice;
748 when F.A_Selected_Component =>
749 return Asis.A_Selected_Component;
750 when F.An_Attribute_Reference =>
751 return Asis.An_Attribute_Reference;
752 when F.A_Record_Aggregate =>
753 return Asis.A_Record_Aggregate;
754 when F.An_Extension_Aggregate =>
755 return Asis.An_Extension_Aggregate;
756 when F.A_Positional_Array_Aggregate =>
757 return Asis.A_Positional_Array_Aggregate;
758 when F.A_Named_Array_Aggregate =>
759 return Asis.A_Named_Array_Aggregate;
760 when F.An_And_Then_Short_Circuit =>
761 return Asis.An_And_Then_Short_Circuit;
762 when F.An_Or_Else_Short_Circuit =>
763 return Asis.An_Or_Else_Short_Circuit;
764 when F.An_In_Range_Membership_Test =>
765 return Asis.An_In_Range_Membership_Test;
766 when F.A_Not_In_Range_Membership_Test =>
767 return Asis.A_Not_In_Range_Membership_Test;
768 when F.An_In_Type_Membership_Test =>
769 return Asis.An_In_Type_Membership_Test;
770 when F.A_Not_In_Type_Membership_Test =>
771 return Asis.A_Not_In_Type_Membership_Test;
772 when F.A_Null_Literal =>
773 return Asis.A_Null_Literal;
774 when F.A_Parenthesized_Expression =>
775 return Asis.A_Parenthesized_Expression;
776 when F.A_Type_Conversion =>
777 return Asis.A_Type_Conversion;
778 when F.A_Qualified_Expression =>
779 return Asis.A_Qualified_Expression;
780 when F.An_Allocation_From_Subtype =>
781 return Asis.An_Allocation_From_Subtype;
782 when F.An_Allocation_From_Qualified_Expression =>
783 return Asis.An_Allocation_From_Qualified_Expression;
784 when others =>
785 return Not_An_Expression;
786 end case;
787 end Expression_Kind;
788
789 ----------------------
790 -- Formal_Type_Kind --
791 ----------------------
792
793 function Formal_Type_Kind
794 (Definition : in Asis.Formal_Type_Definition)
795 return Asis.Formal_Type_Kinds
796 is
797 begin
798 if Assigned (Definition) then
799 Raise_Not_Implemented ("");
800 return Not_A_Formal_Type_Definition;
801 else
802 return Not_A_Formal_Type_Definition;
803 end if;
804 end Formal_Type_Kind;
805
806 -----------------
807 -- Has_Limited --
808 -----------------
809
810 function Has_Limited (Element : in Asis.Element) return Boolean is
811 begin
812 if Assigned (Element) then
813 Raise_Not_Implemented ("");
814 return False;
815 else
816 return False;
817 end if;
818 end Has_Limited;
819
820 -----------------
821 -- Has_Private --
822 -----------------
823
824 function Has_Private (Element : in Asis.Element) return Boolean is
825 begin
826 if Assigned (Element) then
827 Raise_Not_Implemented ("");
828 return False;
829 else
830 return False;
831 end if;
832 end Has_Private;
833
834 ------------------
835 -- Has_Abstract --
836 ------------------
837
838 function Has_Abstract (Element : in Asis.Element) return Boolean is
839 begin
840 if Assigned (Element) then
841 Raise_Not_Implemented ("");
842 return False;
843 else
844 return False;
845 end if;
846 end Has_Abstract;
847
848 -----------------
849 -- Has_Reverse --
850 -----------------
851
852 function Has_Reverse (Element : in Asis.Element) return Boolean is
853 begin
854 return Trait_Kind (Element) = A_Reverse_Trait;
855 end Has_Reverse;
856
857 -----------------
858 -- Has_Aliased --
859 -----------------
860
861 function Has_Aliased (Element : in Asis.Element) return Boolean is
862 begin
863 return Trait_Kind (Element) = An_Aliased_Trait;
864 end Has_Aliased;
865
866 ----------------------
867 -- Has_Synchronized --
868 ----------------------
869
870 function Has_Synchronized (Element : in Asis.Element) return Boolean is
871 begin
872 if Assigned (Element) then
873 Raise_Not_Implemented ("");
874 return False;
875 else
876 return False;
877 end if;
878 end Has_Synchronized;
879
880 -------------------
881 -- Has_Protected --
882 -------------------
883
884 function Has_Protected (Element : in Asis.Element) return Boolean is
885 begin
886 if Assigned (Element) then
887 Raise_Not_Implemented ("");
888 return False;
889 else
890 return False;
891 end if;
892 end Has_Protected;
893
894 ----------------
895 -- Has_Tagged --
896 ----------------
897
898 function Has_Tagged (Element : in Asis.Element) return Boolean is
899 begin
900 if Assigned (Element) then
901 Raise_Not_Implemented ("");
902 return False;
903 else
904 return False;
905 end if;
906 end Has_Tagged;
907
908 --------------
909 -- Has_Task --
910 --------------
911
912 function Has_Task (Element : in Asis.Element) return Boolean is
913 begin
914 if Assigned (Element) then
915 Raise_Not_Implemented ("");
916 return False;
917 else
918 return False;
919 end if;
920 end Has_Task;
921
922 ------------------------
923 -- Has_Null_Exclusion --
924 ------------------------
925
926 function Has_Null_Exclusion (Element : Asis.Element) return Boolean is
927 begin
928 if Assigned (Element) then
929 Raise_Not_Implemented ("");
930 return False;
931 else
932 return False;
933 end if;
934 end Has_Null_Exclusion;
935
936 ----------
937 -- Hash --
938 ----------
939
940 function Hash (Element : in Asis.Element) return Asis.ASIS_Integer is
941 use type Ada.Containers.Hash_Type;
942
943 X : Ada.Containers.Hash_Type;
944 begin
945 if Assigned (Element) then
946 X := Element.Data.Hash;
947 X := X and Ada.Containers.Hash_Type (ASIS_Integer'Last);
948 return ASIS_Integer (X);
949 else
950 return 0;
951 end if;
952 end Hash;
953
954 --------------------
955 -- Interface_Kind --
956 --------------------
957
958 function Interface_Kind
959 (Definition : Asis.Definition)
960 return Asis.Interface_Kinds is
961 begin
962 if Assigned (Definition) then
963 if Type_Kind (Definition) = An_Interface_Type_Definition or
964 Formal_Type_Kind (Definition) =
965 A_Formal_Interface_Type_Definition
966 then
967 if Has_Task (Definition) then
968 return A_Task_Interface;
969 elsif Has_Limited (Definition) then
970 return A_Limited_Interface;
971 elsif Has_Protected (Definition) then
972 return A_Protected_Interface;
973 elsif Has_Synchronized (Definition) then
974 return A_Synchronized_Interface;
975 else
976 return An_Ordinary_Interface;
977 end if;
978 end if;
979 end if;
980
981 return Not_An_Interface;
982 end Interface_Kind;
983
984 ----------------------------
985 -- Is_Abstract_Subprogram --
986 ----------------------------
987
988 function Is_Abstract_Subprogram
989 (Element : in Asis.Element)
990 return Boolean
991 is
992 begin
993 case Declaration_Kind (Element) is
994 when A_Procedure_Declaration |
995 A_Function_Declaration |
996 A_Formal_Procedure_Declaration |
997 A_Formal_Function_Declaration =>
998 return Has_Abstract (Element);
999 when others =>
1000 return False;
1001 end case;
1002 end Is_Abstract_Subprogram;
1003
1004 --------------
1005 -- Is_Equal --
1006 --------------
1007
1008 function Is_Equal
1009 (Left : in Asis.Element;
1010 Right : in Asis.Element)
1011 return Boolean
1012 is
1013 pragma Unreferenced (Left);
1014 pragma Unreferenced (Right);
1015 begin
1016 Raise_Not_Implemented ("");
1017 return False;
1018 end Is_Equal;
1019
1020 ------------------
1021 -- Is_Identical --
1022 ------------------
1023
1024 function Is_Identical
1025 (Left : in Asis.Element;
1026 Right : in Asis.Element)
1027 return Boolean
1028 is
1029 use type Gela.Elements.Element_Access;
1030 begin
1031 return Left.Data = Right.Data;
1032 end Is_Identical;
1033
1034 ------------
1035 -- Is_Nil --
1036 ------------
1037
1038 function Is_Nil (Right : in Asis.Element) return Boolean is
1039 begin
1040 return not Assigned (Right);
1041 end Is_Nil;
1042
1043 ------------
1044 -- Is_Nil --
1045 ------------
1046
1047 function Is_Nil (Right : in Asis.Element_List) return Boolean is
1048 begin
1049 return Right'Length = 0;
1050 end Is_Nil;
1051
1052 -----------------------
1053 -- Is_Null_Procedure --
1054 -----------------------
1055
1056 function Is_Null_Procedure (Element : in Asis.Element) return Boolean is
1057 begin
1058 if Assigned (Element) then
1059 Raise_Not_Implemented ("");
1060 return False;
1061 else
1062 return False;
1063 end if;
1064 end Is_Null_Procedure;
1065
1066 -------------------------
1067 -- Is_Part_Of_Implicit --
1068 -------------------------
1069
1070 function Is_Part_Of_Implicit (Element : in Asis.Element) return Boolean is
1071 begin
1072 if Assigned (Element) then
1073 return Element.Data.Is_Part_Of_Implicit;
1074 else
1075 return False;
1076 end if;
1077 end Is_Part_Of_Implicit;
1078
1079 --------------------------
1080 -- Is_Part_Of_Inherited --
1081 --------------------------
1082
1083 function Is_Part_Of_Inherited
1084 (Element : in Asis.Element)
1085 return Boolean
1086 is
1087 begin
1088 if Assigned (Element) then
1089 return Element.Data.Is_Part_Of_Inherited;
1090 else
1091 return False;
1092 end if;
1093 end Is_Part_Of_Inherited;
1094
1095 -------------------------
1096 -- Is_Part_Of_Instance --
1097 -------------------------
1098
1099 function Is_Part_Of_Instance (Element : in Asis.Element) return Boolean is
1100 begin
1101 if Assigned (Element) then
1102 return Element.Data.Is_Part_Of_Instance;
1103 else
1104 return False;
1105 end if;
1106 end Is_Part_Of_Instance;
1107
1108 ---------------
1109 -- Mode_Kind --
1110 ---------------
1111
1112 function Mode_Kind
1113 (Declaration : in Asis.Declaration)
1114 return Asis.Mode_Kinds
1115 is
1116 begin
1117 if Assigned (Declaration) then
1118 Raise_Not_Implemented ("");
1119 return Not_A_Mode;
1120 else
1121 return Not_A_Mode;
1122 end if;
1123 end Mode_Kind;
1124
1125 -------------------
1126 -- Operator_Kind --
1127 -------------------
1128
1129 function Operator_Kind
1130 (Element : in Asis.Element)
1131 return Asis.Operator_Kinds
1132 is
1133 begin
1134 if Assigned (Element) then
1135 Raise_Not_Implemented ("");
1136 return Not_An_Operator;
1137 else
1138 return Not_An_Operator;
1139 end if;
1140 end Operator_Kind;
1141
1142 ---------------
1143 -- Path_Kind --
1144 ---------------
1145
1146 function Path_Kind (Path : in Asis.Path) return Asis.Path_Kinds is
1147 Map : constant array (F.A_Path) of Asis.Path_Kinds
1148 := (F.An_If_Path => Asis.An_If_Path,
1149 F.An_Elsif_Path => Asis.An_Elsif_Path,
1150 F.An_Else_Path => Asis.An_Else_Path,
1151 F.A_Case_Path => Asis.A_Case_Path,
1152 F.A_Select_Path => Asis.A_Select_Path,
1153 F.An_Or_Path => Asis.An_Or_Path,
1154 F.A_Then_Abort_Path => Asis.A_Then_Abort_Path);
1155
1156 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
1157 Asis.Extensions.Flat_Kinds.Flat_Kind (Path);
1158 begin
1159 if Kind in Map'Range then
1160 return Map (Kind);
1161 else
1162 return Not_A_Path;
1163 end if;
1164 end Path_Kind;
1165
1166 ----------------------------------
1167 -- Pragma_Argument_Associations --
1168 ----------------------------------
1169
1170 function Pragma_Argument_Associations
1171 (Pragma_Element : in Asis.Pragma_Element)
1172 return Asis.Association_List
1173 is
1174 begin
1175 Check_Nil_Element (Pragma_Element, "Pragma_Argument_Associations");
1176 Raise_Not_Implemented ("");
1177 return Asis.Nil_Element_List;
1178 end Pragma_Argument_Associations;
1179
1180 -----------------
1181 -- Pragma_Kind --
1182 -----------------
1183
1184 function Pragma_Kind
1185 (Pragma_Element : in Asis.Pragma_Element)
1186 return Asis.Pragma_Kinds
1187 is
1188 begin
1189 if Assigned (Pragma_Element) then
1190 return Not_A_Pragma;
1191 else
1192 return Not_A_Pragma;
1193 end if;
1194 end Pragma_Kind;
1195
1196 -----------------------
1197 -- Pragma_Name_Image --
1198 -----------------------
1199
1200 function Pragma_Name_Image
1201 (Pragma_Element : in Asis.Pragma_Element)
1202 return Program_Text
1203 is
1204 begin
1205 Check_Nil_Element (Pragma_Element, "Pragma_Name_Image");
1206 Raise_Not_Implemented ("");
1207 return "";
1208 end Pragma_Name_Image;
1209
1210 -------------
1211 -- Pragmas --
1212 -------------
1213
1214 function Pragmas
1215 (The_Element : in Asis.Element)
1216 return Asis.Pragma_Element_List
1217 is
1218 begin
1219 Check_Nil_Element (The_Element, "Pragmas");
1220 Raise_Not_Implemented ("");
1221 return Asis.Nil_Element_List;
1222 end Pragmas;
1223
1224 --------------------------------
1225 -- Representation_Clause_Kind --
1226 --------------------------------
1227
1228 function Representation_Clause_Kind
1229 (Clause : in Asis.Representation_Clause)
1230 return Asis.Representation_Clause_Kinds
1231 is
1232 begin
1233 if Assigned (Clause) then
1234 Raise_Not_Implemented ("");
1235 return Not_A_Representation_Clause;
1236 else
1237 return Not_A_Representation_Clause;
1238 end if;
1239 end Representation_Clause_Kind;
1240
1241 --------------------
1242 -- Root_Type_Kind --
1243 --------------------
1244
1245 function Root_Type_Kind
1246 (Definition : in Asis.Root_Type_Definition)
1247 return Asis.Root_Type_Kinds
1248 is
1249 begin
1250 if Assigned (Definition) then
1251 Raise_Not_Implemented ("");
1252 return Not_A_Root_Type_Definition;
1253 else
1254 return Not_A_Root_Type_Definition;
1255 end if;
1256 end Root_Type_Kind;
1257
1258 --------------------
1259 -- Statement_Kind --
1260 --------------------
1261
1262 function Statement_Kind
1263 (Statement : in Asis.Statement)
1264 return Asis.Statement_Kinds
1265 is
1266 Map : constant array (F.A_Statement) of Asis.Statement_Kinds :=
1267 (F.A_Null_Statement => Asis.A_Null_Statement,
1268 F.An_Assignment_Statement => Asis.An_Assignment_Statement,
1269 F.An_If_Statement => Asis.An_If_Statement,
1270 F.A_Case_Statement => Asis.A_Case_Statement,
1271 F.A_Loop_Statement => Asis.A_Loop_Statement,
1272 F.A_While_Loop_Statement => Asis.A_While_Loop_Statement,
1273 F.A_For_Loop_Statement => Asis.A_For_Loop_Statement,
1274 F.A_Block_Statement => Asis.A_Block_Statement,
1275 F.An_Exit_Statement => Asis.An_Exit_Statement,
1276 F.A_Goto_Statement => Asis.A_Goto_Statement,
1277 F.A_Procedure_Call_Statement => Asis.A_Procedure_Call_Statement,
1278 F.A_Simple_Return_Statement => Asis.A_Simple_Return_Statement,
1279 F.An_Extended_Return_Statement => Asis.An_Extended_Return_Statement,
1280 F.An_Accept_Statement => Asis.An_Accept_Statement,
1281 F.An_Entry_Call_Statement => Asis.An_Entry_Call_Statement,
1282 F.A_Requeue_Statement => Asis.A_Requeue_Statement,
1283 F.A_Requeue_Statement_With_Abort =>
1284 Asis.A_Requeue_Statement_With_Abort,
1285 F.A_Delay_Until_Statement => Asis.A_Delay_Until_Statement,
1286 F.A_Delay_Relative_Statement => Asis.A_Delay_Relative_Statement,
1287 F.A_Terminate_Alternative_Statement =>
1288 Asis.A_Terminate_Alternative_Statement,
1289 F.A_Selective_Accept_Statement => Asis.A_Selective_Accept_Statement,
1290 F.A_Timed_Entry_Call_Statement => Asis.A_Timed_Entry_Call_Statement,
1291 F.A_Conditional_Entry_Call_Statement =>
1292 Asis.A_Conditional_Entry_Call_Statement,
1293 F.An_Asynchronous_Select_Statement =>
1294 Asis.An_Asynchronous_Select_Statement,
1295 F.An_Abort_Statement => Asis.An_Abort_Statement,
1296 F.A_Raise_Statement => Asis.A_Raise_Statement,
1297 F.A_Code_Statement => Asis.A_Code_Statement);
1298
1299 Kind : constant Asis.Extensions.Flat_Kinds.Element_Flat_Kind :=
1300 Asis.Extensions.Flat_Kinds.Flat_Kind (Statement);
1301 begin
1302 if Kind in Map'Range then
1303 return Map (Kind);
1304 else
1305 return Not_A_Statement;
1306 end if;
1307 end Statement_Kind;
1308
1309 ----------------
1310 -- Trait_Kind --
1311 ----------------
1312
1313 function Trait_Kind
1314 (Element : in Asis.Element)
1315 return Asis.Trait_Kinds
1316 is
1317 begin
1318 if Assigned (Element) then
1319-- Raise_Not_Implemented ("");
1320 return Not_A_Trait;
1321 else
1322 return Not_A_Trait;
1323 end if;
1324 end Trait_Kind;
1325
1326 ---------------
1327 -- Type_Kind --
1328 ---------------
1329
1330 function Type_Kind
1331 (Definition : in Asis.Type_Definition)
1332 return Asis.Type_Kinds
1333 is
1334 begin
1335 case F.Flat_Kind (Definition) is
1336 when F.A_Derived_Type_Definition =>
1337 return Asis.A_Derived_Type_Definition;
1338 when F.A_Derived_Record_Extension_Definition =>
1339 return Asis.A_Derived_Record_Extension_Definition;
1340 when F.An_Enumeration_Type_Definition =>
1341 return Asis.An_Enumeration_Type_Definition;
1342 when F.A_Signed_Integer_Type_Definition =>
1343 return Asis.A_Signed_Integer_Type_Definition;
1344 when F.A_Modular_Type_Definition =>
1345 return Asis.A_Modular_Type_Definition;
1346 when F.A_Root_Type_Definition =>
1347 return Asis.A_Root_Type_Definition;
1348 when F.A_Floating_Point_Definition =>
1349 return A_Floating_Point_Definition;
1350 when F.An_Ordinary_Fixed_Point_Definition =>
1351 return An_Ordinary_Fixed_Point_Definition;
1352 when F.A_Decimal_Fixed_Point_Definition =>
1353 return A_Decimal_Fixed_Point_Definition;
1354 when F.An_Unconstrained_Array_Definition =>
1355 return An_Unconstrained_Array_Definition;
1356 when F.A_Constrained_Array_Definition =>
1357 return A_Constrained_Array_Definition;
1358 when F.A_Record_Type_Definition =>
1359 return A_Record_Type_Definition;
1360 when F.A_Tagged_Record_Type_Definition =>
1361 return A_Tagged_Record_Type_Definition;
1362 when F.An_Interface_Type_Definition =>
1363 return Asis.An_Interface_Type_Definition;
1364 when F.An_Access_Type_Definition =>
1365 return Asis.An_Access_Type_Definition;
1366 when others =>
1367 return Not_A_Type_Definition;
1368 end case;
1369 end Type_Kind;
1370
1371 ----------------------
1372 -- Unit_Declaration --
1373 ----------------------
1374
1375 function Unit_Declaration
1376 (Compilation_Unit : in Asis.Compilation_Unit)
1377 return Asis.Declaration
1378 is
1379 package Get is
1380
1381 type Visiter is new Gela.Element_Visiters.Visiter with record
1382 Unit : Gela.Elements.Element_Access;
1383 end record;
1384
1385 overriding procedure Compilation_Unit_Body
1386 (Self : in out Visiter;
1387 Node : not null Gela.Elements.Compilation_Unit_Bodies.
1388 Compilation_Unit_Body_Access);
1389
1390 overriding procedure Compilation_Unit_Declaration
1391 (Self : in out Visiter;
1392 Node : not null Gela.Elements.Compilation_Unit_Declarations.
1393 Compilation_Unit_Declaration_Access);
1394
1395 overriding procedure Subunit
1396 (Self : in out Visiter;
1397 Node : not null Gela.Elements.Subunits.Subunit_Access);
1398
1399 end Get;
1400
1401 package body Get is
1402
1403 overriding procedure Compilation_Unit_Body
1404 (Self : in out Visiter;
1405 Node : not null Gela.Elements.Compilation_Unit_Bodies.
1406 Compilation_Unit_Body_Access)
1407 is
1408 Result : constant Gela.Elements.Library_Unit_Bodies.
1409 Library_Unit_Body_Access := Node.Unit_Declaration;
1410 begin
1411 Self.Unit := Gela.Elements.Element_Access (Result);
1412 end Compilation_Unit_Body;
1413
1414 overriding procedure Compilation_Unit_Declaration
1415 (Self : in out Visiter;
1416 Node : not null Gela.Elements.Compilation_Unit_Declarations.
1417 Compilation_Unit_Declaration_Access)
1418 is
1419 Result : constant Gela.Elements.Library_Unit_Declarations.
1420 Library_Unit_Declaration_Access := Node.Unit_Declaration;
1421 begin
1422 Self.Unit := Gela.Elements.Element_Access (Result);
1423 end Compilation_Unit_Declaration;
1424
1425 overriding procedure Subunit
1426 (Self : in out Visiter;
1427 Node : not null Gela.Elements.Subunits.Subunit_Access)
1428 is
1429 Result : constant Gela.Elements.Proper_Bodies.Proper_Body_Access :=
1430 Node.Unit_Declaration;
1431 begin
1432 Self.Unit := Gela.Elements.Element_Access (Result);
1433 end Subunit;
1434
1435 end Get;
1436
1437 Tree : Gela.Elements.Compilation_Units.Compilation_Unit_Access;
1438 V : aliased Get.Visiter;
1439 begin
1440 Check_Nil_Unit (Compilation_Unit, "Unit_Declaration");
1441 Tree := Compilation_Unit.Data.Tree;
1442 Tree.Visit (V);
1443
1444 return (Data => V.Unit);
1445 end Unit_Declaration;
1446
1447end Asis.Elements;
1448
1449
1450------------------------------------------------------------------------------
1451-- Copyright (c) 2006-2013, Maxim Reznik
1452-- All rights reserved.
1453--
1454-- Redistribution and use in source and binary forms, with or without
1455-- modification, are permitted provided that the following conditions are met:
1456--
1457-- * Redistributions of source code must retain the above copyright notice,
1458-- this list of conditions and the following disclaimer.
1459-- * Redistributions in binary form must reproduce the above copyright
1460-- notice, this list of conditions and the following disclaimer in the
1461-- documentation and/or other materials provided with the distribution.
1462-- * Neither the name of the Maxim Reznik, IE nor the names of its
1463-- contributors may be used to endorse or promote products derived from
1464-- this software without specific prior written permission.
1465--
1466-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
1467-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
1468-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1469-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
1470-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
1471-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
1472-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
1473-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
1474-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
1475-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1476-- POSSIBILITY OF SUCH DAMAGE.
1477------------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.