source: trunk/ada-2012/src/asis/asis-declarations.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: 53.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 Asis.Elements;
13with Asis.Compilation_Units;
14
15with Gela.Compilations;
16with Gela.Element_Visiters;
17with Gela.Elements.Basic_Declarative_Items;
18with Gela.Elements.Component_Declarations;
19with Gela.Elements.Component_Definitions;
20with Gela.Elements.Declarative_Items;
21with Gela.Elements.Defining_Enumeration_Literals;
22with Gela.Elements.Defining_Identifiers;
23with Gela.Elements.Defining_Operator_Symbols;
24with Gela.Elements.Defining_Program_Unit_Names;
25with Gela.Elements.Discriminant_Specifications;
26with Gela.Elements.Entry_Bodies;
27with Gela.Elements.Formal_Object_Declarations;
28with Gela.Elements.Full_Type_Declarations;
29with Gela.Elements.Function_Bodies;
30with Gela.Elements.Function_Declarations;
31with Gela.Elements.Object_Declarations;
32with Gela.Elements.Object_Definitions;
33with Gela.Elements.Object_Renaming_Declarations;
34with Gela.Elements.Package_Bodies;
35with Gela.Elements.Package_Declarations;
36with Gela.Elements.Parameter_Specifications;
37with Gela.Elements.Procedure_Bodies;
38with Gela.Elements.Procedure_Declarations;
39with Gela.Elements.Protected_Definitions;
40with Gela.Elements.Single_Protected_Declarations;
41with Gela.Elements.Single_Task_Declarations;
42with Gela.Elements.Statements;
43with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
44with Gela.Elements.Task_Bodies;
45with Gela.Elements.Task_Definitions;
46with Gela.Elements.Type_Definitions;
47with Gela.Lexical_Types;
48
49package body Asis.Declarations is
50
51 --------------------------
52 -- Body_Block_Statement --
53 --------------------------
54
55 function Body_Block_Statement
56 (Declaration : in Asis.Declaration)
57 return Asis.Statement
58 is
59 begin
60 Check_Nil_Element (Declaration, "Body_Block_Statement");
61 Raise_Not_Implemented ("");
62 return Nil_Element;
63 end Body_Block_Statement;
64
65 ----------------------------
66 -- Body_Declarative_Items --
67 ----------------------------
68
69 function Body_Declarative_Items
70 (Declaration : in Asis.Declaration;
71 Include_Pragmas : in Boolean := False)
72 return Asis.Element_List
73 is
74 pragma Unreferenced (Include_Pragmas);
75
76 package Get is
77 type Visiter is new Gela.Element_Visiters.Visiter with record
78 Result : Gela.Elements.Declarative_Items.
79 Declarative_Item_Sequence_Access;
80 end record;
81
82 overriding procedure Entry_Body
83 (Self : in out Visiter;
84 Node : not null Gela.Elements.Entry_Bodies.Entry_Body_Access);
85
86 overriding procedure Function_Body
87 (Self : in out Visiter;
88 Node : not null Gela.Elements.Function_Bodies.
89 Function_Body_Access);
90
91 overriding procedure Package_Body
92 (Self : in out Visiter;
93 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access);
94
95 overriding procedure Procedure_Body
96 (Self : in out Visiter;
97 Node : not null Gela.Elements.Procedure_Bodies.
98 Procedure_Body_Access);
99
100 overriding procedure Task_Body
101 (Self : in out Visiter;
102 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access);
103
104 end Get;
105
106 package body Get is
107
108 overriding procedure Entry_Body
109 (Self : in out Visiter;
110 Node : not null Gela.Elements.Entry_Bodies.Entry_Body_Access) is
111 begin
112 Self.Result := Node.Body_Declarative_Items;
113 end Entry_Body;
114
115 overriding procedure Function_Body
116 (Self : in out Visiter;
117 Node : not null Gela.Elements.Function_Bodies.
118 Function_Body_Access) is
119 begin
120 Self.Result := Node.Body_Declarative_Items;
121 end Function_Body;
122
123 overriding procedure Package_Body
124 (Self : in out Visiter;
125 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access)
126 is
127 begin
128 Self.Result := Node.Body_Declarative_Items;
129 end Package_Body;
130
131 overriding procedure Procedure_Body
132 (Self : in out Visiter;
133 Node : not null Gela.Elements.Procedure_Bodies.
134 Procedure_Body_Access) is
135 begin
136 Self.Result := Node.Body_Declarative_Items;
137 end Procedure_Body;
138
139 overriding procedure Task_Body
140 (Self : in out Visiter;
141 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access) is
142 begin
143 Self.Result := Node.Body_Declarative_Items;
144 end Task_Body;
145
146 end Get;
147
148 V : Get.Visiter;
149 Result : Gela.Elements.Element_Sequence_Access;
150 begin
151 Check_Nil_Element (Declaration, "Body_Declarative_Items");
152 Declaration.Data.Visit (V);
153 Result := Gela.Elements.Element_Sequence_Access (V.Result);
154
155 return Asis.To_List (Result);
156 end Body_Declarative_Items;
157
158 -----------------------------
159 -- Body_Exception_Handlers --
160 -----------------------------
161
162 function Body_Exception_Handlers
163 (Declaration : in Asis.Declaration;
164 Include_Pragmas : in Boolean := False)
165 return Asis.Exception_Handler_List
166 is
167 pragma Unreferenced (Include_Pragmas);
168 begin
169 Check_Nil_Element (Declaration, "Body_Exception_Handlers");
170 Raise_Not_Implemented ("");
171 return Nil_Element_List;
172 end Body_Exception_Handlers;
173
174 ---------------------
175 -- Body_Statements --
176 ---------------------
177
178 function Body_Statements
179 (Declaration : in Asis.Declaration;
180 Include_Pragmas : in Boolean := False)
181 return Asis.Statement_List
182 is
183 pragma Unreferenced (Include_Pragmas);
184
185 package Get is
186 type Visiter is new Gela.Element_Visiters.Visiter with record
187 Result : Gela.Elements.Statements.Statement_Sequence_Access;
188 end record;
189
190 overriding procedure Entry_Body
191 (Self : in out Visiter;
192 Node : not null Gela.Elements.Entry_Bodies.Entry_Body_Access);
193
194 overriding procedure Function_Body
195 (Self : in out Visiter;
196 Node : not null Gela.Elements.Function_Bodies.
197 Function_Body_Access);
198
199 overriding procedure Package_Body
200 (Self : in out Visiter;
201 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access);
202
203 overriding procedure Procedure_Body
204 (Self : in out Visiter;
205 Node : not null Gela.Elements.Procedure_Bodies.
206 Procedure_Body_Access);
207
208 overriding procedure Task_Body
209 (Self : in out Visiter;
210 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access);
211
212 end Get;
213
214 package body Get is
215
216 overriding procedure Entry_Body
217 (Self : in out Visiter;
218 Node : not null Gela.Elements.Entry_Bodies.Entry_Body_Access) is
219 begin
220 Self.Result := Node.Body_Statements;
221 end Entry_Body;
222
223 overriding procedure Function_Body
224 (Self : in out Visiter;
225 Node : not null Gela.Elements.Function_Bodies.
226 Function_Body_Access) is
227 begin
228 Self.Result := Node.Body_Statements;
229 end Function_Body;
230
231 overriding procedure Package_Body
232 (Self : in out Visiter;
233 Node : not null Gela.Elements.Package_Bodies.Package_Body_Access)
234 is
235 begin
236 Self.Result := Node.Body_Statements;
237 end Package_Body;
238
239 overriding procedure Procedure_Body
240 (Self : in out Visiter;
241 Node : not null Gela.Elements.Procedure_Bodies.
242 Procedure_Body_Access) is
243 begin
244 Self.Result := Node.Body_Statements;
245 end Procedure_Body;
246
247 overriding procedure Task_Body
248 (Self : in out Visiter;
249 Node : not null Gela.Elements.Task_Bodies.Task_Body_Access) is
250 begin
251 Self.Result := Node.Body_Statements;
252 end Task_Body;
253
254 end Get;
255
256 V : Get.Visiter;
257 Result : Gela.Elements.Element_Sequence_Access;
258 begin
259 Check_Nil_Element (Declaration, "Body_Statements");
260 Declaration.Data.Visit (V);
261 Result := Gela.Elements.Element_Sequence_Access (V.Result);
262
263 return Asis.To_List (Result);
264 end Body_Statements;
265
266 -------------------------------
267 -- Corresponding_Base_Entity --
268 -------------------------------
269
270 function Corresponding_Base_Entity
271 (Declaration : in Asis.Declaration)
272 return Asis.Expression
273 is
274 begin
275 Check_Nil_Element (Declaration, "Corresponding_Base_Entity");
276 Raise_Not_Implemented ("");
277 return Nil_Element;
278 end Corresponding_Base_Entity;
279
280 ------------------------
281 -- Corresponding_Body --
282 ------------------------
283
284 function Corresponding_Body
285 (Declaration : in Asis.Declaration)
286 return Asis.Declaration
287 is
288 begin
289 case Asis.Elements.Declaration_Kind (Declaration) is
290 when
291 A_Function_Body_Declaration
292 | A_Function_Body_Stub
293 | A_Function_Renaming_Declaration
294 | A_Package_Body_Declaration
295 | A_Package_Body_Stub
296 | A_Package_Renaming_Declaration
297 | A_Procedure_Body_Declaration
298 | A_Procedure_Renaming_Declaration
299 | A_Procedure_Body_Stub
300 | A_Task_Body_Declaration
301 | A_Task_Body_Stub
302 | A_Protected_Body_Declaration
303 | A_Protected_Body_Stub
304 | A_Generic_Package_Renaming_Declaration
305 | A_Generic_Procedure_Renaming_Declaration
306 | A_Generic_Function_Renaming_Declaration
307 | An_Entry_Body_Declaration =>
308 return Declaration;
309 when others =>
310 null;
311 end case;
312
313 Check_Nil_Element (Declaration, "Corresponding_Body");
314 Raise_Not_Implemented ("");
315 return Nil_Element;
316 end Corresponding_Body;
317
318 ------------------------
319 -- Corresponding_Body --
320 ------------------------
321
322 function Corresponding_Body
323 (Declaration : in Asis.Declaration;
324 The_Context : in Asis.Context)
325 return Asis.Declaration
326 is
327 pragma Unreferenced (The_Context);
328 begin
329 Check_Nil_Element (Declaration, "Corresponding_Body");
330-- Check_Context (The_Context);
331 Raise_Not_Implemented ("");
332 return Corresponding_Body (Declaration);
333 end Corresponding_Body;
334
335 -----------------------------
336 -- Corresponding_Body_Stub --
337 -----------------------------
338
339 function Corresponding_Body_Stub
340 (Subunit : in Asis.Declaration)
341 return Asis.Declaration
342 is
343 begin
344 Check_Nil_Element (Subunit, "Corresponding_Body_Stub");
345 Raise_Not_Implemented ("");
346 return Nil_Element;
347 end Corresponding_Body_Stub;
348
349 -----------------------------
350 -- Corresponding_Body_Stub --
351 -----------------------------
352
353 function Corresponding_Body_Stub
354 (Subunit : in Asis.Declaration;
355 The_Context : in Asis.Context)
356 return Asis.Declaration
357 is
358 pragma Unreferenced (The_Context);
359 begin
360 Check_Nil_Element (Subunit, "Corresponding_Body_Stub");
361-- Check_Context (The_Context);
362 Raise_Not_Implemented ("");
363 return Corresponding_Body_Stub (Subunit);
364 end Corresponding_Body_Stub;
365
366 ----------------------------------------
367 -- Corresponding_Constant_Declaration --
368 ----------------------------------------
369
370 function Corresponding_Constant_Declaration
371 (Name : in Asis.Defining_Name)
372 return Asis.Declaration
373 is
374 begin
375 Check_Nil_Element (Name, "Corresponding_Constant_Declaration");
376 Raise_Not_Implemented ("");
377 return Nil_Element;
378 end Corresponding_Constant_Declaration;
379
380 -------------------------------
381 -- Corresponding_Declaration --
382 -------------------------------
383
384 function Corresponding_Declaration
385 (Declaration : in Asis.Declaration)
386 return Asis.Declaration
387 is
388 begin
389 case Asis.Elements.Declaration_Kind (Declaration) is
390 when
391 A_Function_Declaration
392 | A_Generic_Function_Declaration
393 | A_Generic_Package_Declaration
394 | A_Generic_Procedure_Declaration
395 -- | A_Package_Declaration return Limited_View or its completion
396 | A_Package_Renaming_Declaration
397 | A_Procedure_Declaration
398 | A_Single_Task_Declaration
399 | A_Task_Type_Declaration
400 | A_Protected_Type_Declaration
401 | A_Single_Protected_Declaration
402 | A_Generic_Package_Renaming_Declaration
403 | A_Generic_Procedure_Renaming_Declaration
404 | A_Generic_Function_Renaming_Declaration
405 | An_Entry_Declaration =>
406 return Declaration;
407 when others =>
408 null;
409 end case;
410
411 Check_Nil_Element (Declaration, "Corresponding_Declaration");
412 Raise_Not_Implemented ("");
413 return Nil_Element;
414 end Corresponding_Declaration;
415
416 -------------------------------
417 -- Corresponding_Declaration --
418 -------------------------------
419
420 function Corresponding_Declaration
421 (Declaration : in Asis.Declaration;
422 The_Context : in Asis.Context)
423 return Asis.Declaration
424 is
425 pragma Unreferenced (The_Context);
426 begin
427 Check_Nil_Element (Declaration, "Corresponding_Declaration");
428-- Check_Context (The_Context);
429 Raise_Not_Implemented ("");
430 return Corresponding_Declaration (Declaration);
431 end Corresponding_Declaration;
432
433 -------------------------------------
434 -- Corresponding_Equality_Operator --
435 -------------------------------------
436
437 function Corresponding_Equality_Operator
438 (Declaration : in Asis.Declaration)
439 return Asis.Declaration
440 is
441 begin
442 Check_Nil_Element (Declaration, "Corresponding_Equality_Operator");
443 Raise_Not_Implemented ("");
444 return Nil_Element;
445 end Corresponding_Equality_Operator;
446
447 ---------------------------------
448 -- Corresponding_First_Subtype --
449 ---------------------------------
450
451 function Corresponding_First_Subtype
452 (Declaration : in Asis.Declaration)
453 return Asis.Declaration
454 is
455 begin
456 Check_Nil_Element (Declaration, "Corresponding_First_Subtype");
457
458 case Asis.Elements.Declaration_Kind (Declaration) is
459 when An_Ordinary_Type_Declaration |
460 A_Task_Type_Declaration |
461 A_Protected_Type_Declaration |
462 A_Private_Type_Declaration |
463 A_Private_Extension_Declaration |
464 A_Formal_Type_Declaration =>
465 return Declaration;
466 when others =>
467 Raise_Not_Implemented ("");
468 return Nil_Element;
469 end case;
470 end Corresponding_First_Subtype;
471
472 -----------------------------------
473 -- Corresponding_Generic_Element --
474 -----------------------------------
475
476 function Corresponding_Generic_Element
477 (Reference : in Asis.Element)
478 return Asis.Defining_Name
479 is
480 begin
481 Check_Nil_Element (Reference, "Corresponding_Generic_Element");
482 Raise_Not_Implemented ("");
483 return Nil_Element;
484 end Corresponding_Generic_Element;
485
486 -----------------------------------
487 -- Corresponding_Last_Constraint --
488 -----------------------------------
489
490 function Corresponding_Last_Constraint
491 (Declaration : in Asis.Declaration)
492 return Asis.Declaration
493 is
494 begin
495 Check_Nil_Element (Declaration, "Corresponding_Last_Constraint");
496
497 case Asis.Elements.Declaration_Kind (Declaration) is
498 when An_Ordinary_Type_Declaration |
499 A_Task_Type_Declaration |
500 A_Protected_Type_Declaration |
501 A_Private_Type_Declaration |
502 A_Private_Extension_Declaration |
503 A_Formal_Type_Declaration =>
504 return Declaration;
505 when others =>
506 Raise_Not_Implemented ("");
507 return Nil_Element;
508 end case;
509 end Corresponding_Last_Constraint;
510
511 --------------------------------
512 -- Corresponding_Last_Subtype --
513 --------------------------------
514
515 function Corresponding_Last_Subtype
516 (Declaration : in Asis.Declaration)
517 return Asis.Declaration
518 is
519 begin
520 Check_Nil_Element (Declaration, "Corresponding_Last_Subtype");
521
522 case Asis.Elements.Declaration_Kind (Declaration) is
523 when An_Ordinary_Type_Declaration |
524 A_Task_Type_Declaration |
525 A_Protected_Type_Declaration |
526 A_Private_Type_Declaration |
527 A_Private_Extension_Declaration |
528 A_Formal_Type_Declaration =>
529 return Declaration;
530 when others =>
531 Raise_Not_Implemented ("");
532 return Nil_Element;
533 end case;
534 end Corresponding_Last_Subtype;
535
536 ------------------------------------------
537 -- Corresponding_Representation_Clauses --
538 ------------------------------------------
539
540 function Corresponding_Representation_Clauses
541 (Declaration : in Asis.Declaration)
542 return Asis.Representation_Clause_List
543 is
544 begin
545 Check_Nil_Element (Declaration, "Corresponding_Representation_Clauses");
546 Raise_Not_Implemented ("");
547 return Nil_Element_List;
548 end Corresponding_Representation_Clauses;
549
550 -----------------------------------------
551 -- Corresponding_Subprogram_Derivation --
552 -----------------------------------------
553
554 function Corresponding_Subprogram_Derivation
555 (Declaration : in Asis.Declaration)
556 return Asis.Declaration
557 is
558 begin
559 Check_Nil_Element (Declaration, "Corresponding_Subprogram_Derivation");
560 Raise_Not_Implemented ("");
561 return Nil_Element;
562 end Corresponding_Subprogram_Derivation;
563
564 ---------------------------
565 -- Corresponding_Subunit --
566 ---------------------------
567
568 function Corresponding_Subunit
569 (Body_Stub : in Asis.Declaration)
570 return Asis.Declaration
571 is
572 begin
573 Check_Nil_Element (Body_Stub, "Corresponding_Subunit");
574 Raise_Not_Implemented ("");
575 return Nil_Element;
576 end Corresponding_Subunit;
577
578 ---------------------------
579 -- Corresponding_Subunit --
580 ---------------------------
581
582 function Corresponding_Subunit
583 (Body_Stub : in Asis.Declaration;
584 The_Context : in Asis.Context)
585 return Asis.Declaration
586 is
587 pragma Unreferenced (The_Context);
588 begin
589 Check_Nil_Element (Body_Stub, "Corresponding_Subunit");
590-- Check_Context (The_Context);
591 Raise_Not_Implemented ("");
592 return Corresponding_Subunit (Body_Stub);
593 end Corresponding_Subunit;
594
595 ------------------------
596 -- Corresponding_Type --
597 ------------------------
598
599 function Corresponding_Type
600 (Declaration : in Asis.Declaration)
601 return Asis.Type_Definition
602 is
603 package Get is
604 type Visiter is new Gela.Element_Visiters.Visiter with record
605 Result : Gela.Elements.Element_Access;
606 end record;
607
608 overriding procedure Function_Declaration
609 (Self : in out Visiter;
610 Node : not null Gela.Elements.Function_Declarations.
611 Function_Declaration_Access);
612
613 overriding procedure Procedure_Declaration
614 (Self : in out Visiter;
615 Node : not null Gela.Elements.Procedure_Declarations.
616 Procedure_Declaration_Access);
617 end Get;
618
619 package body Get is
620
621 overriding procedure Function_Declaration
622 (Self : in out Visiter;
623 Node : not null Gela.Elements.Function_Declarations.
624 Function_Declaration_Access) is
625 begin
626 Self.Result := Node.Corresponding_Type;
627 end Function_Declaration;
628
629 overriding procedure Procedure_Declaration
630 (Self : in out Visiter;
631 Node : not null Gela.Elements.Procedure_Declarations.
632 Procedure_Declaration_Access) is
633 begin
634 Self.Result := Node.Corresponding_Type;
635 end Procedure_Declaration;
636 end Get;
637
638 V : Get.Visiter;
639 begin
640 Check_Nil_Element (Declaration, "Corresponding_Type");
641 Declaration.Data.Visit (V);
642 return Asis.Declarations.Type_Declaration_View ((Data => V.Result));
643 end Corresponding_Type;
644
645 ------------------------------------
646 -- Corresponding_Type_Declaration --
647 ------------------------------------
648
649 function Corresponding_Type_Declaration
650 (Declaration : in Asis.Declaration)
651 return Asis.Declaration
652 is
653 begin
654 Check_Nil_Element (Declaration, "Corresponding_Type_Declaration");
655 Raise_Not_Implemented ("");
656 return Nil_Element;
657 end Corresponding_Type_Declaration;
658
659 ------------------------------------
660 -- Corresponding_Type_Declaration --
661 ------------------------------------
662
663 function Corresponding_Type_Declaration
664 (Declaration : in Asis.Declaration;
665 The_Context : in Asis.Context)
666 return Asis.Declaration
667 is
668 pragma Unreferenced (The_Context);
669 begin
670 Check_Nil_Element (Declaration, "Corresponding_Type_Declaration");
671-- Check_Context (The_Context);
672 return Corresponding_Type_Declaration (Declaration);
673 end Corresponding_Type_Declaration;
674
675 ------------------------------
676 -- Declaration_Subtype_Mark --
677 ------------------------------
678
679 function Declaration_Subtype_Mark
680 (Declaration : in Asis.Declaration)
681 return Asis.Expression
682 is
683 Result : Asis.Definition;
684 begin
685 Check_Nil_Element (Declaration, "Declaration_Subtype_Mark");
686
687 case Asis.Elements.Declaration_Kind (Declaration) is
688 when A_Variable_Declaration |
689 A_Constant_Declaration |
690 A_Deferred_Constant_Declaration |
691 A_Single_Protected_Declaration |
692 A_Single_Task_Declaration |
693 A_Component_Declaration
694 =>
695-- Raise_Inappropriate_Element ("Declaration_Subtype_Mark");
696 Raise_Not_Implemented ("");
697 return Nil_Element;
698 when others =>
699 null;
700 end case;
701
702 Result := Object_Declaration_Subtype (Declaration);
703
704 if Assigned (Result) then
705 case Asis.Elements.Definition_Kind (Result) is
706 when A_Subtype_Indication =>
707 Raise_Not_Implemented ("");
708 return Nil_Element;
709-- return Get_Subtype_Mark (Result.all);
710 when An_Access_Definition =>
711 case Asis.Elements.Access_Definition_Kind (Result) is
712 when An_Anonymous_Access_To_Object_Definition =>
713 Raise_Not_Implemented ("");
714 return Nil_Element;
715-- return
716-- Anonymous_Access_To_Object_Subtype_Mark (Result.all);
717 when others =>
718 Raise_Not_Implemented ("");
719 return Nil_Element;
720 end case;
721 when others =>
722 Raise_Not_Implemented ("");
723 return Nil_Element;
724 end case;
725 end if;
726
727 return Result;
728 end Declaration_Subtype_Mark;
729
730 -------------------------
731 -- Defining_Name_Image --
732 -------------------------
733
734 function Defining_Name_Image
735 (Defining_Name : in Asis.Defining_Name)
736 return Program_Text
737 is
738 package Get is
739 type Visiter is new Gela.Element_Visiters.Visiter with record
740 Symbol : Gela.Lexical_Types.Symbol := 0;
741 end record;
742
743 overriding procedure Defining_Enumeration_Literal
744 (Self : in out Visiter;
745 Node : not null Gela.Elements.Defining_Enumeration_Literals.
746 Defining_Enumeration_Literal_Access);
747
748 overriding procedure Defining_Identifier
749 (Self : in out Visiter;
750 Node : not null Gela.Elements.Defining_Identifiers.
751 Defining_Identifier_Access);
752
753 overriding procedure Defining_Operator_Symbol
754 (Self : in out Visiter;
755 Node : not null Gela.Elements.Defining_Operator_Symbols.
756 Defining_Operator_Symbol_Access);
757 end Get;
758
759 package body Get is
760
761 overriding procedure Defining_Enumeration_Literal
762 (Self : in out Visiter;
763 Node : not null Gela.Elements.Defining_Enumeration_Literals.
764 Defining_Enumeration_Literal_Access)
765 is
766 Token : constant Gela.Lexical_Types.Token_Count :=
767 Node.Identifier;
768 Comp : constant Gela.Compilations.Compilation_Access :=
769 Node.Enclosing_Compilation;
770 begin
771 Self.Symbol := Comp.Get_Token (Token).Symbol;
772 end Defining_Enumeration_Literal;
773
774 overriding procedure Defining_Identifier
775 (Self : in out Visiter;
776 Node : not null Gela.Elements.Defining_Identifiers.
777 Defining_Identifier_Access)
778 is
779 Token : constant Gela.Lexical_Types.Token_Count :=
780 Node.Identifier_Token;
781 Comp : constant Gela.Compilations.Compilation_Access :=
782 Node.Enclosing_Compilation;
783 begin
784 Self.Symbol := Comp.Get_Token (Token).Symbol;
785 end Defining_Identifier;
786
787 overriding procedure Defining_Operator_Symbol
788 (Self : in out Visiter;
789 Node : not null Gela.Elements.Defining_Operator_Symbols.
790 Defining_Operator_Symbol_Access)
791 is
792 Token : constant Gela.Lexical_Types.Token_Count :=
793 Node.Operator_Symbol_Token;
794 Comp : constant Gela.Compilations.Compilation_Access :=
795 Node.Enclosing_Compilation;
796 begin
797 Self.Symbol := Comp.Get_Token (Token).Symbol;
798 end Defining_Operator_Symbol;
799 end Get;
800
801 V : Get.Visiter;
802 Comp : Gela.Compilations.Compilation_Access;
803 Context : Gela.Contexts.Context_Access;
804 begin
805 Check_Nil_Element (Defining_Name, "Defining_Name_Image");
806 Defining_Name.Data.Visit (V);
807 Comp := Defining_Name.Data.Enclosing_Compilation;
808 Context := Comp.Context;
809 return Context.Symbols.Image (V.Symbol).To_UTF_16_Wide_String;
810 end Defining_Name_Image;
811
812 ---------------------
813 -- Defining_Prefix --
814 ---------------------
815
816 function Defining_Prefix
817 (Defining_Name : in Asis.Defining_Name)
818 return Asis.Name
819 is
820 begin
821 Check_Nil_Element (Defining_Name, "Defining_Prefix");
822 Raise_Not_Implemented ("");
823 return Nil_Element;
824 end Defining_Prefix;
825
826 -----------------------
827 -- Defining_Selector --
828 -----------------------
829
830 function Defining_Selector
831 (Defining_Name : in Asis.Defining_Name)
832 return Asis.Defining_Name
833 is
834 begin
835 Check_Nil_Element (Defining_Name, "Defining_Selector");
836 Raise_Not_Implemented ("");
837 return Nil_Element;
838 end Defining_Selector;
839
840 -----------------------
841 -- Discriminant_Part --
842 -----------------------
843
844 function Discriminant_Part
845 (Declaration : in Asis.Declaration)
846 return Asis.Definition
847 is
848 begin
849 Check_Nil_Element (Declaration, "Discriminant_Part");
850 Raise_Not_Implemented ("");
851 return Nil_Element;
852 end Discriminant_Part;
853
854 -------------------
855 -- Entry_Barrier --
856 -------------------
857
858 function Entry_Barrier
859 (Declaration : in Asis.Declaration)
860 return Asis.Expression
861 is
862 begin
863 Check_Nil_Element (Declaration, "Entry_Barrier");
864 Raise_Not_Implemented ("");
865 return Nil_Element;
866 end Entry_Barrier;
867
868 -----------------------------
869 -- Entry_Family_Definition --
870 -----------------------------
871
872 function Entry_Family_Definition
873 (Declaration : in Asis.Declaration)
874 return Asis.Discrete_Subtype_Definition
875 is
876 begin
877 Check_Nil_Element (Declaration, "Entry_Family_Definition");
878 Raise_Not_Implemented ("");
879 return Nil_Element;
880 end Entry_Family_Definition;
881
882 -------------------------------
883 -- Entry_Index_Specification --
884 -------------------------------
885
886 function Entry_Index_Specification
887 (Declaration : in Asis.Declaration)
888 return Asis.Declaration
889 is
890 begin
891 Check_Nil_Element (Declaration, "Entry_Index_Specification");
892 Raise_Not_Implemented ("");
893 return Nil_Element;
894 end Entry_Index_Specification;
895
896 -------------------------------
897 -- Formal_Subprogram_Default --
898 -------------------------------
899
900 function Formal_Subprogram_Default
901 (Declaration : in Asis.Generic_Formal_Parameter)
902 return Asis.Expression
903 is
904 begin
905 Check_Nil_Element (Declaration, "Formal_Subprogram_Default");
906 Raise_Not_Implemented ("");
907 return Nil_Element;
908 end Formal_Subprogram_Default;
909
910 -------------------------
911 -- Generic_Actual_Part --
912 -------------------------
913
914 function Generic_Actual_Part
915 (Declaration : in Asis.Declaration;
916 Normalized : in Boolean := False)
917 return Asis.Association_List
918 is
919 begin
920 Check_Nil_Element (Declaration, "Generic_Actual_Part");
921 if Normalized then
922 Raise_Not_Implemented ("");
923 return Nil_Element_List;
924 else
925 Raise_Not_Implemented ("");
926 return Nil_Element_List;
927 end if;
928 end Generic_Actual_Part;
929
930 -------------------------
931 -- Generic_Formal_Part --
932 -------------------------
933
934 function Generic_Formal_Part
935 (Declaration : in Asis.Declaration;
936 Include_Pragmas : in Boolean := False)
937 return Asis.Element_List
938 is
939 pragma Unreferenced (Include_Pragmas);
940 begin
941 Check_Nil_Element (Declaration, "Generic_Formal_Part");
942 Raise_Not_Implemented ("");
943 return Nil_Element_List;
944 end Generic_Formal_Part;
945
946 -----------------------
947 -- Generic_Unit_Name --
948 -----------------------
949
950 function Generic_Unit_Name
951 (Declaration : in Asis.Declaration)
952 return Asis.Expression
953 is
954 begin
955 Check_Nil_Element (Declaration, "Generic_Unit_Name");
956 Raise_Not_Implemented ("");
957 return Nil_Element;
958 end Generic_Unit_Name;
959
960 -------------------------------
961 -- Initialization_Expression --
962 -------------------------------
963
964 function Initialization_Expression
965 (Declaration : in Asis.Declaration)
966 return Asis.Expression
967 is
968 begin
969 Check_Nil_Element (Declaration, "Initialization_Expression");
970 Raise_Not_Implemented ("");
971 return Nil_Element;
972 end Initialization_Expression;
973
974 ------------------------------
975 -- Is_Dispatching_Operation --
976 ------------------------------
977
978 function Is_Dispatching_Operation
979 (Declaration : in Asis.Element)
980 return Boolean
981 is
982 begin
983 Check_Nil_Element (Declaration, "Is_Dispatching_Operation");
984 Raise_Not_Implemented ("");
985 return False;
986 end Is_Dispatching_Operation;
987
988 ----------------------
989 -- Is_Name_Repeated --
990 ----------------------
991
992 function Is_Name_Repeated
993 (Declaration : in Asis.Declaration)
994 return Boolean
995 is
996 begin
997 Check_Nil_Element (Declaration, "Is_Name_Repeated");
998 Raise_Not_Implemented ("");
999 return False;
1000 end Is_Name_Repeated;
1001
1002 ------------------------
1003 -- Is_Private_Present --
1004 ------------------------
1005
1006 function Is_Private_Present
1007 (Declaration : in Asis.Declaration)
1008 return Boolean
1009 is
1010 begin
1011 Check_Nil_Element (Declaration, "Is_Private_Present");
1012 Raise_Not_Implemented ("");
1013 return False;
1014 end Is_Private_Present;
1015
1016 ----------------
1017 -- Is_Subunit --
1018 ----------------
1019
1020 function Is_Subunit (Declaration : in Asis.Declaration) return Boolean is
1021 Enclosing_Unit : constant Compilation_Unit :=
1022 Asis.Elements.Enclosing_Compilation_Unit (Declaration);
1023 begin
1024 if Assigned (Declaration) then
1025 return Asis.Elements.Is_Equal
1026 (Declaration,
1027 Asis.Elements.Unit_Declaration (Enclosing_Unit))
1028 and Asis.Compilation_Units.Unit_Kind (Enclosing_Unit) in A_Subunit;
1029 else
1030 return False;
1031 end if;
1032 end Is_Subunit;
1033
1034 -----------
1035 -- Names --
1036 -----------
1037
1038 function Names
1039 (Declaration : in Asis.Declaration)
1040 return Asis.Defining_Name_List
1041 is
1042 package Get is
1043 type Visiter is new Gela.Element_Visiters.Visiter with record
1044 Name : Gela.Elements.Element_Access;
1045 Names : Gela.Elements.Element_Sequence_Access;
1046 end record;
1047
1048 overriding procedure Full_Type_Declaration
1049 (Self : in out Visiter;
1050 Node : not null Gela.Elements.Full_Type_Declarations.
1051 Full_Type_Declaration_Access);
1052
1053 overriding procedure Object_Declaration
1054 (Self : in out Visiter;
1055 Node : not null Gela.Elements.Object_Declarations.
1056 Object_Declaration_Access);
1057
1058 overriding procedure Procedure_Body
1059 (Self : in out Visiter;
1060 Node : not null Gela.Elements.Procedure_Bodies.
1061 Procedure_Body_Access);
1062
1063 overriding procedure Procedure_Declaration
1064 (Self : in out Visiter;
1065 Node : not null Gela.Elements.Procedure_Declarations.
1066 Procedure_Declaration_Access);
1067
1068 end Get;
1069
1070 package body Get is
1071
1072 overriding procedure Full_Type_Declaration
1073 (Self : in out Visiter;
1074 Node : not null Gela.Elements.Full_Type_Declarations.
1075 Full_Type_Declaration_Access)
1076 is
1077 Name : constant Gela.Elements.Defining_Identifiers.
1078 Defining_Identifier_Access := Node.Names;
1079 begin
1080 Self.Name := Gela.Elements.Element_Access (Name);
1081 end Full_Type_Declaration;
1082
1083 overriding procedure Object_Declaration
1084 (Self : in out Visiter;
1085 Node : not null Gela.Elements.Object_Declarations.
1086 Object_Declaration_Access)
1087 is
1088 Names : constant Gela.Elements.Defining_Identifiers.
1089 Defining_Identifier_Sequence_Access := Node.Names;
1090 begin
1091 Self.Names := Gela.Elements.Element_Sequence_Access (Names);
1092 end Object_Declaration;
1093
1094 overriding procedure Procedure_Body
1095 (Self : in out Visiter;
1096 Node : not null Gela.Elements.Procedure_Bodies.
1097 Procedure_Body_Access)
1098 is
1099 Name : constant Gela.Elements.Defining_Program_Unit_Names.
1100 Defining_Program_Unit_Name_Access := Node.Names;
1101 begin
1102 Self.Name := Gela.Elements.Element_Access (Name);
1103 end Procedure_Body;
1104
1105 overriding procedure Procedure_Declaration
1106 (Self : in out Visiter;
1107 Node : not null Gela.Elements.Procedure_Declarations.
1108 Procedure_Declaration_Access)
1109 is
1110 Name : constant Gela.Elements.Defining_Program_Unit_Names.
1111 Defining_Program_Unit_Name_Access := Node.Names;
1112 begin
1113 Self.Name := Gela.Elements.Element_Access (Name);
1114 end Procedure_Declaration;
1115
1116 end Get;
1117
1118 use type Gela.Elements.Element_Access;
1119 use type Gela.Elements.Element_Sequence_Access;
1120 V : Get.Visiter;
1121 begin
1122 Check_Nil_Element (Declaration, "Names");
1123 Declaration.Data.Visit (V);
1124
1125 if V.Name /= null then
1126 return (1 => (Data => V.Name));
1127 elsif V.Names /= null then
1128 return Asis.To_List (V.Names);
1129 else
1130 Raise_Not_Implemented ("");
1131 return Asis.Nil_Element_List;
1132 end if;
1133 end Names;
1134
1135 -----------------------------
1136 -- Object_Declaration_View --
1137 -----------------------------
1138
1139 function Object_Declaration_View
1140 (Declaration : in Asis.Declaration)
1141 return Asis.Definition
1142 is
1143 Result : Asis.Definition;
1144 begin
1145 Check_Nil_Element (Declaration, "Object_Declaration_View");
1146
1147 case Asis.Elements.Declaration_Kind (Declaration) is
1148 when A_Discriminant_Specification |
1149 A_Parameter_Specification |
1150 A_Formal_Object_Declaration |
1151 An_Object_Renaming_Declaration
1152 =>
1153-- Raise_Inappropriate_Element ("Object_Declaration_View");
1154 Raise_Not_Implemented ("");
1155 return Nil_Element;
1156 when others =>
1157 null;
1158 end case;
1159
1160 Result := Object_Declaration_Subtype (Declaration);
1161
1162 if Assigned (Result) and then
1163 Asis.Elements.Definition_Kind (Result) = An_Access_Definition
1164 then
1165 Raise_Not_Implemented ("");
1166 return Nil_Element;
1167 end if;
1168
1169 return Result;
1170 end Object_Declaration_View;
1171
1172 --------------------------------
1173 -- Object_Declaration_Subtype --
1174 --------------------------------
1175
1176 function Object_Declaration_Subtype
1177 (Declaration : in Asis.Declaration) return Asis.Definition
1178 is
1179
1180 package Get is
1181 type Visiter is new Gela.Element_Visiters.Visiter with record
1182 Result : Gela.Elements.Element_Access;
1183 end record;
1184
1185 overriding procedure Component_Declaration
1186 (Self : in out Visiter;
1187 Node : not null Gela.Elements.Component_Declarations.
1188 Component_Declaration_Access);
1189
1190 overriding procedure Discriminant_Specification
1191 (Self : in out Visiter;
1192 Node : not null Gela.Elements.Discriminant_Specifications.
1193 Discriminant_Specification_Access);
1194
1195 overriding procedure Formal_Object_Declaration
1196 (Self : in out Visiter;
1197 Node : not null Gela.Elements.Formal_Object_Declarations.
1198 Formal_Object_Declaration_Access);
1199
1200 overriding procedure Object_Declaration
1201 (Self : in out Visiter;
1202 Node : not null Gela.Elements.Object_Declarations.
1203 Object_Declaration_Access);
1204
1205 overriding procedure Object_Renaming_Declaration
1206 (Self : in out Visiter;
1207 Node : not null Gela.Elements.Object_Renaming_Declarations.
1208 Object_Renaming_Declaration_Access);
1209
1210 overriding procedure Parameter_Specification
1211 (Self : in out Visiter;
1212 Node : not null Gela.Elements.Parameter_Specifications.
1213 Parameter_Specification_Access);
1214
1215 overriding procedure Single_Protected_Declaration
1216 (Self : in out Visiter;
1217 Node : not null Gela.Elements.Single_Protected_Declarations.
1218 Single_Protected_Declaration_Access);
1219
1220 overriding procedure Single_Task_Declaration
1221 (Self : in out Visiter;
1222 Node : not null Gela.Elements.Single_Task_Declarations.
1223 Single_Task_Declaration_Access);
1224 end Get;
1225
1226 package body Get is
1227
1228 overriding procedure Component_Declaration
1229 (Self : in out Visiter;
1230 Node : not null Gela.Elements.Component_Declarations.
1231 Component_Declaration_Access)
1232 is
1233 X : constant Gela.Elements.Component_Definitions.
1234 Component_Definition_Access := Node.Object_Declaration_Subtype;
1235 begin
1236 Self.Result := Gela.Elements.Element_Access (X);
1237 end Component_Declaration;
1238
1239 overriding procedure Discriminant_Specification
1240 (Self : in out Visiter;
1241 Node : not null Gela.Elements.Discriminant_Specifications.
1242 Discriminant_Specification_Access)
1243 is
1244 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1245 Subtype_Mark_Or_Access_Definition_Access :=
1246 Node.Object_Declaration_Subtype;
1247 begin
1248 Self.Result := Gela.Elements.Element_Access (X);
1249 end Discriminant_Specification;
1250
1251 overriding procedure Formal_Object_Declaration
1252 (Self : in out Visiter;
1253 Node : not null Gela.Elements.Formal_Object_Declarations.
1254 Formal_Object_Declaration_Access)
1255 is
1256 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1257 Subtype_Mark_Or_Access_Definition_Access :=
1258 Node.Object_Declaration_Subtype;
1259 begin
1260 Self.Result := Gela.Elements.Element_Access (X);
1261 end Formal_Object_Declaration;
1262
1263 overriding procedure Object_Declaration
1264 (Self : in out Visiter;
1265 Node : not null Gela.Elements.Object_Declarations.
1266 Object_Declaration_Access)
1267 is
1268 X : constant Gela.Elements.Object_Definitions.
1269 Object_Definition_Access := Node.Object_Declaration_Subtype;
1270 begin
1271 Self.Result := Gela.Elements.Element_Access (X);
1272 end Object_Declaration;
1273
1274 overriding procedure Object_Renaming_Declaration
1275 (Self : in out Visiter;
1276 Node : not null Gela.Elements.Object_Renaming_Declarations.
1277 Object_Renaming_Declaration_Access)
1278 is
1279 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1280 Subtype_Mark_Or_Access_Definition_Access :=
1281 Node.Object_Declaration_Subtype;
1282 begin
1283 Self.Result := Gela.Elements.Element_Access (X);
1284 end Object_Renaming_Declaration;
1285
1286 overriding procedure Parameter_Specification
1287 (Self : in out Visiter;
1288 Node : not null Gela.Elements.Parameter_Specifications.
1289 Parameter_Specification_Access)
1290 is
1291 X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
1292 Subtype_Mark_Or_Access_Definition_Access :=
1293 Node.Object_Declaration_Subtype;
1294 begin
1295 Self.Result := Gela.Elements.Element_Access (X);
1296 end Parameter_Specification;
1297
1298 overriding procedure Single_Protected_Declaration
1299 (Self : in out Visiter;
1300 Node : not null Gela.Elements.Single_Protected_Declarations.
1301 Single_Protected_Declaration_Access)
1302 is
1303 X : constant Gela.Elements.Protected_Definitions.
1304 Protected_Definition_Access := Node.Object_Declaration_Subtype;
1305 begin
1306 Self.Result := Gela.Elements.Element_Access (X);
1307 end Single_Protected_Declaration;
1308
1309 overriding procedure Single_Task_Declaration
1310 (Self : in out Visiter;
1311 Node : not null Gela.Elements.Single_Task_Declarations.
1312 Single_Task_Declaration_Access)
1313 is
1314 X : constant Gela.Elements.Task_Definitions.
1315 Task_Definition_Access := Node.Object_Declaration_Subtype;
1316 begin
1317 Self.Result := Gela.Elements.Element_Access (X);
1318 end Single_Task_Declaration;
1319
1320 end Get;
1321
1322 V : Get.Visiter;
1323 begin
1324 Check_Nil_Element (Declaration, "Object_Declaration_Subtype");
1325 Declaration.Data.Visit (V);
1326
1327 return (Data => V.Result);
1328 end Object_Declaration_Subtype;
1329
1330 -------------------------------
1331 -- Overriding_Indicator_Kind --
1332 -------------------------------
1333
1334 function Overriding_Indicator_Kind
1335 (Declaration : Asis.Declaration)
1336 return Asis.Overriding_Indicator_Kinds
1337 is
1338 begin
1339 if Assigned (Declaration) then
1340 Raise_Not_Implemented ("");
1341 return Not_An_Overriding_Indicator;
1342 else
1343 return Not_An_Overriding_Indicator;
1344 end if;
1345 end Overriding_Indicator_Kind;
1346
1347 -----------------------
1348 -- Parameter_Profile --
1349 -----------------------
1350
1351 function Parameter_Profile
1352 (Declaration : in Asis.Declaration)
1353 return Asis.Parameter_Specification_List
1354 is
1355 package Get is
1356 type Visiter is new Gela.Element_Visiters.Visiter with record
1357 List : Gela.Elements.Element_Sequence_Access;
1358 end record;
1359
1360 overriding procedure Procedure_Declaration
1361 (Self : in out Visiter;
1362 Node : not null Gela.Elements.Procedure_Declarations.
1363 Procedure_Declaration_Access);
1364
1365 end Get;
1366
1367 package body Get is
1368
1369 overriding procedure Procedure_Declaration
1370 (Self : in out Visiter;
1371 Node : not null Gela.Elements.Procedure_Declarations.
1372 Procedure_Declaration_Access)
1373 is
1374 List : constant Gela.Elements.Parameter_Specifications.
1375 Parameter_Specification_Sequence_Access :=
1376 Node.Parameter_Profile;
1377 begin
1378 Self.List := Gela.Elements.Element_Sequence_Access (List);
1379 end Procedure_Declaration;
1380
1381 end Get;
1382
1383 V : Get.Visiter;
1384 begin
1385 Check_Nil_Element (Declaration, "Parameter_Profile");
1386 Declaration.Data.Visit (V);
1387
1388 return Asis.To_List (V.List);
1389 end Parameter_Profile;
1390
1391 ---------------------------
1392 -- Position_Number_Image --
1393 ---------------------------
1394
1395 function Position_Number_Image
1396 (Defining_Name : in Asis.Defining_Name)
1397 return Wide_String
1398 is
1399 begin
1400 Check_Nil_Element (Defining_Name, "Position_Number_Image");
1401 Raise_Not_Implemented ("");
1402 return "";
1403 end Position_Number_Image;
1404
1405 ------------------------------------
1406 -- Private_Part_Declarative_Items --
1407 ------------------------------------
1408
1409 function Private_Part_Declarative_Items
1410 (Declaration : in Asis.Declaration;
1411 Include_Pragmas : in Boolean := False)
1412 return Asis.Declarative_Item_List
1413 is
1414 pragma Unreferenced (Include_Pragmas);
1415 package Get is
1416 type Visiter is new Gela.Element_Visiters.Visiter with record
1417 List : Gela.Elements.Element_Sequence_Access;
1418 end record;
1419
1420 overriding procedure Package_Declaration
1421 (Self : in out Visiter;
1422 Node : not null Gela.Elements.Package_Declarations.
1423 Package_Declaration_Access);
1424
1425 end Get;
1426
1427 package body Get is
1428
1429 overriding procedure Package_Declaration
1430 (Self : in out Visiter;
1431 Node : not null Gela.Elements.Package_Declarations.
1432 Package_Declaration_Access)
1433 is
1434 List : constant Gela.Elements.Basic_Declarative_Items.
1435 Basic_Declarative_Item_Sequence_Access :=
1436 Node.Private_Part_Declarative_Items;
1437 begin
1438 Self.List := Gela.Elements.Element_Sequence_Access (List);
1439 end Package_Declaration;
1440
1441 end Get;
1442
1443 V : Get.Visiter;
1444 begin
1445 Check_Nil_Element (Declaration, "Private_Part_Declarative_Items");
1446 Declaration.Data.Visit (V);
1447
1448 return Asis.To_List (V.List);
1449 end Private_Part_Declarative_Items;
1450
1451 ---------------------
1452 -- Progenitor_List --
1453 ---------------------
1454
1455 function Progenitor_List
1456 (Declaration : Asis.Declaration)
1457 return Asis.Name_List is
1458 begin
1459 Check_Nil_Element (Declaration, "Progenitor_List");
1460 Raise_Not_Implemented ("");
1461 return Nil_Element_List;
1462 end Progenitor_List;
1463
1464 -------------------------------
1465 -- Protected_Operation_Items --
1466 -------------------------------
1467
1468 function Protected_Operation_Items
1469 (Declaration : in Asis.Declaration;
1470 Include_Pragmas : in Boolean := False)
1471 return Asis.Declaration_List
1472 is
1473 pragma Unreferenced (Include_Pragmas);
1474 begin
1475 Check_Nil_Element (Declaration, "Protected_Operation_Items");
1476 Raise_Not_Implemented ("");
1477 return Nil_Element_List;
1478 end Protected_Operation_Items;
1479
1480 --------------------
1481 -- Renamed_Entity --
1482 --------------------
1483
1484 function Renamed_Entity
1485 (Declaration : in Asis.Declaration)
1486 return Asis.Expression
1487 is
1488 begin
1489 Check_Nil_Element (Declaration, "Renamed_Entity");
1490 Raise_Not_Implemented ("");
1491 return Nil_Element;
1492 end Renamed_Entity;
1493
1494 --------------------------------
1495 -- Representation_Value_Image --
1496 --------------------------------
1497
1498 function Representation_Value_Image
1499 (Defining_Name : in Asis.Defining_Name)
1500 return Wide_String
1501 is
1502 begin
1503 Check_Nil_Element (Defining_Name, "Representation_Value_Image");
1504 Raise_Not_Implemented ("");
1505 return "";
1506 end Representation_Value_Image;
1507
1508 --------------------
1509 -- Result_Profile --
1510 --------------------
1511
1512 function Result_Profile
1513 (Declaration : in Asis.Declaration)
1514 return Asis.Expression
1515 is
1516 Result : Asis.Definition;
1517 begin
1518 Check_Nil_Element (Declaration, "Result_Profile");
1519-- Result := Result_Subtype (Declaration);
1520
1521 if Assigned (Result) then
1522 case Asis.Elements.Definition_Kind (Result) is
1523 when A_Subtype_Indication =>
1524 Raise_Not_Implemented ("");
1525 return Nil_Element;
1526-- return Asis.Definitions.Subtype_Mark (Result);
1527 when others =>
1528 Raise_Not_Implemented ("");
1529 return Nil_Element;
1530 end case;
1531 end if;
1532
1533 return Result;
1534 end Result_Profile;
1535
1536 --------------------
1537 -- Result_Subtype --
1538 --------------------
1539
1540 function Result_Subtype
1541 (Declaration : in Asis.Declaration)
1542 return Asis.Definition is
1543 begin
1544 Check_Nil_Element (Declaration, "Result_Subtype");
1545 Raise_Not_Implemented ("");
1546 return Nil_Element;
1547 end Result_Subtype;
1548
1549 --------------------------------------
1550 -- Specification_Subtype_Definition --
1551 --------------------------------------
1552
1553 function Specification_Subtype_Definition
1554 (Specification : in Asis.Declaration)
1555 return Asis.Discrete_Subtype_Definition
1556 is
1557 begin
1558 Check_Nil_Element (Specification, "Specification_Subtype_Definition");
1559 Raise_Not_Implemented ("");
1560 return Nil_Element;
1561 end Specification_Subtype_Definition;
1562
1563 ---------------------------
1564 -- Type_Declaration_View --
1565 ---------------------------
1566
1567 function Type_Declaration_View
1568 (Declaration : in Asis.Declaration)
1569 return Asis.Definition
1570 is
1571 package Get is
1572 type Visiter is new Gela.Element_Visiters.Visiter with record
1573 Result : Gela.Elements.Element_Access;
1574 end record;
1575
1576 overriding procedure Full_Type_Declaration
1577 (Self : in out Visiter;
1578 Node : not null Gela.Elements.Full_Type_Declarations.
1579 Full_Type_Declaration_Access);
1580 end Get;
1581
1582 package body Get is
1583
1584 overriding procedure Full_Type_Declaration
1585 (Self : in out Visiter;
1586 Node : not null Gela.Elements.Full_Type_Declarations.
1587 Full_Type_Declaration_Access)
1588 is
1589 X : constant Gela.Elements.Type_Definitions.Type_Definition_Access
1590 := Node.Type_Declaration_View;
1591 begin
1592 Self.Result := Gela.Elements.Element_Access (X);
1593 end Full_Type_Declaration;
1594 end Get;
1595
1596 V : Get.Visiter;
1597 begin
1598 Check_Nil_Element (Declaration, "Type_Declaration_View");
1599 Declaration.Data.Visit (V);
1600 return (Data => V.Result);
1601 end Type_Declaration_View;
1602
1603 ------------------------------------
1604 -- Visible_Part_Declarative_Items --
1605 ------------------------------------
1606
1607 function Visible_Part_Declarative_Items
1608 (Declaration : in Asis.Declaration;
1609 Include_Pragmas : in Boolean := False)
1610 return Asis.Declarative_Item_List
1611 is
1612 pragma Unreferenced (Include_Pragmas);
1613
1614 package Get is
1615 type Visiter is new Gela.Element_Visiters.Visiter with record
1616 List : Gela.Elements.Element_Sequence_Access;
1617 end record;
1618
1619 overriding procedure Package_Declaration
1620 (Self : in out Visiter;
1621 Node : not null Gela.Elements.Package_Declarations.
1622 Package_Declaration_Access);
1623
1624 end Get;
1625
1626 package body Get is
1627
1628 overriding procedure Package_Declaration
1629 (Self : in out Visiter;
1630 Node : not null Gela.Elements.Package_Declarations.
1631 Package_Declaration_Access)
1632 is
1633 List : constant Gela.Elements.Basic_Declarative_Items.
1634 Basic_Declarative_Item_Sequence_Access :=
1635 Node.Visible_Part_Declarative_Items;
1636 begin
1637 Self.List := Gela.Elements.Element_Sequence_Access (List);
1638 end Package_Declaration;
1639
1640 end Get;
1641
1642 V : Get.Visiter;
1643 begin
1644 Check_Nil_Element (Declaration, "Visible_Part_Declarative_Items");
1645 Declaration.Data.Visit (V);
1646
1647 return Asis.To_List (V.List);
1648 end Visible_Part_Declarative_Items;
1649
1650end Asis.Declarations;
1651
1652
1653------------------------------------------------------------------------------
1654-- Copyright (c) 2006-2013, Maxim Reznik
1655-- All rights reserved.
1656--
1657-- Redistribution and use in source and binary forms, with or without
1658-- modification, are permitted provided that the following conditions are met:
1659--
1660-- * Redistributions of source code must retain the above copyright notice,
1661-- this list of conditions and the following disclaimer.
1662-- * Redistributions in binary form must reproduce the above copyright
1663-- notice, this list of conditions and the following disclaimer in the
1664-- documentation and/or other materials provided with the distribution.
1665-- * Neither the name of the Maxim Reznik, IE nor the names of its
1666-- contributors may be used to endorse or promote products derived from
1667-- this software without specific prior written permission.
1668--
1669-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
1670-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
1671-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1672-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
1673-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
1674-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
1675-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
1676-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
1677-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
1678-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1679-- POSSIBILITY OF SUCH DAMAGE.
1680------------------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.