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

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

Implement more queries in ASIS.Elements

File size: 6.3 KB
Line 
1with Asis.Errors;
2with Asis.Exceptions;
3with Asis.Implementation;
4
5with Gela.Element_Visiters;
6with Gela.Elements.Associations;
7with Gela.Elements.Auxiliary_Applies;
8with Gela.Elements.Composite_Constraints;
9with Gela.Elements.Procedure_Call_Statements;
10with Gela.Elements.Record_Aggregates;
11
12package body Asis is
13
14 ----------------------------------
15 -- Assert_Inappropriate_Element --
16 ----------------------------------
17
18 procedure Assert_Inappropriate_Element (Ok : Boolean; From : Wide_String) is
19 begin
20 if not Ok then
21 Asis.Implementation.Set_Status
22 (Asis.Errors.Value_Error, "Inappropriate element in " & From);
23 raise Asis.Exceptions.ASIS_Inappropriate_Element;
24 end if;
25 end Assert_Inappropriate_Element;
26
27 --------------
28 -- Assigned --
29 --------------
30
31 function Assigned (Unit : in Asis.Compilation_Unit) return Boolean is
32 use type Gela.Compilation_Units.Compilation_Unit_Access;
33 begin
34 return Unit.Data /= null;
35 end Assigned;
36
37 --------------
38 -- Assigned --
39 --------------
40
41 function Assigned (Element : in Asis.Element) return Boolean is
42 use type Gela.Elements.Element_Access;
43 begin
44 return Element.Data /= null;
45 end Assigned;
46
47 --------------
48 -- Auxilary --
49 --------------
50
51 function Auxilary (Element : in Asis.Element) return Boolean is
52 package Get is
53 type Flag is (Is_Association, Is_Function_Call, Is_Record_Aggregate);
54 type Flag_Array is array (Flag) of Boolean;
55 None : constant Flag_Array := (others => False);
56
57 type Visiter is new Gela.Element_Visiters.Visiter with record
58 Result : Boolean := False;
59 Flags : Flag_Array := None;
60 end record;
61
62 overriding procedure Association
63 (Self : in out Visiter;
64 Node : not null Gela.Elements.Associations.Association_Access);
65
66 overriding procedure Auxiliary_Apply
67 (Self : in out Visiter;
68 Node : not null Gela.Elements.Auxiliary_Applies.
69 Auxiliary_Apply_Access);
70
71 overriding procedure Composite_Constraint
72 (Self : in out Visiter;
73 Node : not null Gela.Elements.Composite_Constraints.
74 Composite_Constraint_Access);
75
76 overriding procedure Procedure_Call_Statement
77 (Self : in out Visiter;
78 Node : not null Gela.Elements.Procedure_Call_Statements.
79 Procedure_Call_Statement_Access);
80
81 overriding procedure Record_Aggregate
82 (Self : in out Visiter;
83 Node : not null Gela.Elements.Record_Aggregates.
84 Record_Aggregate_Access);
85
86 end Get;
87
88 package body Get is
89
90 overriding procedure Association
91 (Self : in out Visiter;
92 Node : not null Gela.Elements.Associations.Association_Access) is
93 begin
94 if Self.Flags = None then
95 Self.Flags (Is_Association) := True;
96 Node.Enclosing_Element.Visit (Self);
97 end if;
98 end Association;
99
100 overriding procedure Auxiliary_Apply
101 (Self : in out Visiter;
102 Node : not null Gela.Elements.Auxiliary_Applies.
103 Auxiliary_Apply_Access) is
104 begin
105 if Self.Flags = None then
106 Self.Flags (Is_Function_Call) := True;
107 Node.Enclosing_Element.Visit (Self);
108 else
109 Self.Result := Self.Flags (Is_Record_Aggregate);
110 end if;
111 end Auxiliary_Apply;
112
113 overriding procedure Composite_Constraint
114 (Self : in out Visiter;
115 Node : not null Gela.Elements.Composite_Constraints.
116 Composite_Constraint_Access)
117 is
118 pragma Unreferenced (Node);
119 begin
120 Self.Result := Self.Flags (Is_Association);
121 end Composite_Constraint;
122
123 overriding procedure Procedure_Call_Statement
124 (Self : in out Visiter;
125 Node : not null Gela.Elements.Procedure_Call_Statements.
126 Procedure_Call_Statement_Access)
127 is
128 pragma Unreferenced (Node);
129 begin
130 Self.Result := Self.Flags (Is_Function_Call);
131 end Procedure_Call_Statement;
132
133 overriding procedure Record_Aggregate
134 (Self : in out Visiter;
135 Node : not null Gela.Elements.Record_Aggregates.
136 Record_Aggregate_Access) is
137 begin
138 if Self.Flags = None then
139 Self.Flags (Is_Record_Aggregate) := True;
140 Node.Enclosing_Element.Visit (Self);
141 end if;
142 end Record_Aggregate;
143
144 end Get;
145
146 V : Get.Visiter;
147 begin
148 Element.Data.Visit (V);
149 return V.Result;
150 end Auxilary;
151
152 --------------------
153 -- Check_Nil_Unit --
154 --------------------
155
156 procedure Check_Nil_Unit
157 (Unit : Asis.Compilation_Unit;
158 From : Wide_String) is
159 begin
160 if not Assigned (Unit) then
161 Asis.Implementation.Set_Status
162 (Asis.Errors.Value_Error, "Null compilation unit in " & From);
163 raise Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit;
164 end if;
165 end Check_Nil_Unit;
166
167 -----------------------
168 -- Check_Nil_Element --
169 -----------------------
170
171 procedure Check_Nil_Element
172 (Element : Asis.Element;
173 From : Wide_String) is
174 begin
175 if not Assigned (Element) then
176 Asis.Implementation.Set_Status
177 (Asis.Errors.Value_Error, "Null element in " & From);
178 raise Asis.Exceptions.ASIS_Inappropriate_Element;
179 end if;
180 end Check_Nil_Element;
181
182 ---------------------------
183 -- Raise_Not_Implemented --
184 ---------------------------
185
186 procedure Raise_Not_Implemented (From : Wide_String) is
187 begin
188 Asis.Implementation.Set_Status
189 (Asis.Errors.Not_Implemented_Error, "Not_Implemented:" & From);
190 raise Asis.Exceptions.ASIS_Failed;
191 end Raise_Not_Implemented;
192
193 -------------
194 -- To_List --
195 -------------
196
197 function To_List
198 (X : Gela.Elements.Element_Sequence_Access) return Asis.Element_List
199 is
200 Result : Asis.Element_List (1 .. ASIS_Natural (X.Length));
201 Cursor : Gela.Elements.Element_Sequence_Cursor := X.First;
202 begin
203 for J in Result'Range loop
204 Result (J) := (Data => Cursor.Element);
205 Cursor.Next;
206 end loop;
207
208 return Result;
209 end To_List;
210
211end Asis;
Note: See TracBrowser for help on using the repository browser.