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

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

Improve def_name test to print each name

If def_name is started with last argument in form "+hash" then
traverse all elements for given compilation unit and print
Corresponding_Name_Definition where appropriate.

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