source: trunk/ada-2012/src/asis/asis-declarations.adb@ 402

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

Fix Defining_Character_Literal and add next test

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