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

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

More implementation code for Asis.Elements.*_Kind

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