source: trunk/ada-2012/src/semantic/gela-plain_interpretations.adb@ 358

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

Fix regressions

Drop (left) expicit convertions from Interpretation_Index to
Interpretation_Set_Index and replace them with iteration over
cursors.

File size: 9.3 KB
Line 
1with Gela.Int.Attr_Functions;
2with Gela.Int.Defining_Names;
3with Gela.Int.Expressions;
4with Gela.Int.Visiters;
5
6package body Gela.Plain_Interpretations is
7
8 package Empty_Cursors is
9 type Cursor is new Gela.Interpretations.Cursor with null record;
10
11 overriding function Has_Element (Self : Cursor) return Boolean;
12
13 overriding procedure Next (Self : in out Cursor) is null;
14
15 overriding procedure Visit
16 (Self : Cursor;
17 Target : access Gela.Interpretations.Visiter'Class) is null;
18
19 overriding function Get_Index
20 (Self : Cursor) return Gela.Interpretations.Interpretation_Index;
21
22 end Empty_Cursors;
23
24 package body Empty_Cursors is
25
26 overriding function Has_Element (Self : Cursor) return Boolean is
27 pragma Unreferenced (Self);
28 begin
29 return False;
30 end Has_Element;
31
32 overriding function Get_Index
33 (Self : Cursor) return Gela.Interpretations.Interpretation_Index
34 is
35 pragma Unreferenced (Self);
36 begin
37 return 0;
38 end Get_Index;
39
40 end Empty_Cursors;
41
42 -----------------------
43 -- Add_Attr_Function --
44 -----------------------
45
46 overriding procedure Add_Attr_Function
47 (Self : in out Interpretation_Manager;
48 Kind : Gela.Lexical_Types.Predefined_Symbols.Attribute;
49 Down : Gela.Interpretations.Interpretation_Index_Array;
50 Result : in out Gela.Interpretations.Interpretation_Set_Index)
51 is
52 Item : constant Gela.Int.Interpretation_Access :=
53 new Gela.Int.Attr_Functions.Attr_Function'
54 (Gela.Int.Attr_Functions.Create
55 (Down => Down,
56 Kind => Kind));
57 begin
58 Self.Plian_Int_Set.Add (Result, Item);
59 end Add_Attr_Function;
60
61 -----------------------
62 -- Add_Defining_Name --
63 -----------------------
64
65 overriding procedure Add_Defining_Name
66 (Self : in out Interpretation_Manager;
67 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
68 Down : Gela.Interpretations.Interpretation_Index_Array;
69 Result : in out Gela.Interpretations.Interpretation_Set_Index)
70 is
71 Item : constant Gela.Int.Interpretation_Access :=
72 new Gela.Int.Defining_Names.Defining_Name'
73 (Gela.Int.Defining_Names.Create
74 (Down => Down,
75 Name => Name));
76 begin
77 Self.Plian_Int_Set.Add (Result, Item);
78 end Add_Defining_Name;
79
80 --------------------
81 -- Add_Expression --
82 --------------------
83
84 overriding procedure Add_Expression
85 (Self : in out Interpretation_Manager;
86 Tipe : Gela.Semantic_Types.Type_Index;
87 Down : Gela.Interpretations.Interpretation_Index_Array;
88 Result : in out Gela.Interpretations.Interpretation_Set_Index)
89 is
90 Item : constant Gela.Int.Interpretation_Access :=
91 new Gela.Int.Expressions.Expression'
92 (Gela.Int.Expressions.Create
93 (Down => Down,
94 Expression_Type => Tipe));
95 begin
96 Self.Plian_Int_Set.Add (Result, Item);
97 end Add_Expression;
98
99 -----------------------
100 -- Get_Defining_Name --
101 -----------------------
102
103 overriding procedure Get_Defining_Name
104 (Self : in out Interpretation_Manager;
105 Value : Gela.Interpretations.Interpretation_Index;
106 Result : out Gela.Elements.Defining_Names.Defining_Name_Access)
107 is
108 package Each is
109 type Visiter is new Gela.Interpretations.Visiter with record
110 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
111 end record;
112
113 overriding procedure On_Defining_Name
114 (Self : in out Visiter;
115 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
116 Down : Gela.Interpretations.Interpretation_Index_Array);
117
118 overriding procedure On_Expression
119 (Self : in out Visiter;
120 Tipe : Gela.Semantic_Types.Type_Index;
121 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
122
123 overriding procedure On_Attr_Function
124 (Self : in out Visiter;
125 Tipe : Gela.Lexical_Types.Predefined_Symbols.Attribute;
126 Down : Gela.Interpretations.Interpretation_Index_Array) is null;
127 end Each;
128
129 ----------
130 -- Each --
131 ----------
132
133 package body Each is
134
135 overriding procedure On_Defining_Name
136 (Self : in out Visiter;
137 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
138 Down : Gela.Interpretations.Interpretation_Index_Array)
139 is
140 pragma Unreferenced (Down);
141 begin
142 Self.Name := Name;
143 end On_Defining_Name;
144
145 end Each;
146
147 Visiter : Each.Visiter;
148 begin
149 Self.Visit (Value, Visiter);
150 Result := Visiter.Name;
151 end Get_Defining_Name;
152
153 -----------------------------
154 -- Get_Down_Interpretation --
155 -----------------------------
156
157 overriding procedure Get_Down_Interpretation
158 (Self : in out Interpretation_Manager;
159 Value : Gela.Interpretations.Interpretation_Index;
160 Index : Positive;
161 Result : out Gela.Interpretations.Interpretation_Index)
162 is
163 Item : Gela.Int.Interpretation_Access;
164 begin
165 Result := 0;
166
167 if Value = 0 then
168 return;
169 end if;
170
171 Item := Self.Item_Batches.Element (Value / Batch_Size).Element (Value);
172
173 if Index in Item.Down'Range then
174 Result := Item.Down (Index);
175 end if;
176 end Get_Down_Interpretation;
177
178 ----------------
179 -- Get_Cursor --
180 ----------------
181
182 overriding function Get_Cursor
183 (Self : in out Interpretation_Manager;
184 Set : Gela.Interpretations.Interpretation_Set_Index)
185 return Gela.Interpretations.Cursor'Class is
186 begin
187 if Set = 0 then
188 return None : Empty_Cursors.Cursor;
189 else
190 return Self.Set_Batches.Element (Set / Batch_Size).Get_Cursor (Set);
191 end if;
192 end Get_Cursor;
193
194 ---------------------
195 -- Reserve_Indexes --
196 ---------------------
197
198 overriding procedure Reserve_Indexes
199 (Self : in out Interpretation_Manager;
200 Set : Gela.Int_Sets.Interpretation_Set_Access;
201 From : out Gela.Interpretations.Interpretation_Set_Index;
202 To : out Gela.Interpretations.Interpretation_Set_Index) is
203 begin
204 Self.Set_Batches.Append (Set);
205 From := Self.Set_Batches.Last_Index * Batch_Size;
206 To := From + Batch_Size - 1;
207 From := Gela.Interpretations.Interpretation_Set_Index'Max (1, From);
208 end Reserve_Indexes;
209
210 ---------------------
211 -- Reserve_Indexes --
212 ---------------------
213
214 overriding procedure Reserve_Indexes
215 (Self : in out Interpretation_Manager;
216 Set : Gela.Int_Sets.Interpretation_Set_Access;
217 From : out Gela.Interpretations.Interpretation_Index;
218 To : out Gela.Interpretations.Interpretation_Index) is
219 begin
220 Self.Item_Batches.Append (Set);
221 From := Self.Item_Batches.Last_Index * Batch_Size;
222 To := From + Batch_Size - 1;
223 From := Gela.Interpretations.Interpretation_Index'Max (1, From);
224 end Reserve_Indexes;
225
226 -----------
227 -- Visit --
228 -----------
229
230 overriding procedure Visit
231 (Self : in out Interpretation_Manager;
232 Index : Gela.Interpretations.Interpretation_Index;
233 Target : in out Gela.Interpretations.Visiter'Class)
234 is
235 package Switch is
236 type Visiter is new Gela.Int.Visiters.Visiter with null record;
237
238 overriding procedure Defining_Name
239 (Self : access Visiter;
240 Value : Gela.Int.Defining_Names.Defining_Name);
241
242 overriding procedure Expression
243 (Self : access Visiter;
244 Value : Gela.Int.Expressions.Expression);
245
246 overriding procedure Attr_Function
247 (Self : access Visiter;
248 Value : Gela.Int.Attr_Functions.Attr_Function);
249
250 end Switch;
251
252 ------------
253 -- Switch --
254 ------------
255
256 package body Switch is
257
258 -------------------
259 -- Attr_Function --
260 -------------------
261
262 overriding procedure Attr_Function
263 (Self : access Visiter;
264 Value : Gela.Int.Attr_Functions.Attr_Function)
265 is
266 pragma Unreferenced (Self);
267 begin
268 Target.On_Attr_Function
269 (Kind => Value.Kind,
270 Down => Value.Down);
271 end Attr_Function;
272
273 -------------------
274 -- Defining_Name --
275 -------------------
276
277 overriding procedure Defining_Name
278 (Self : access Visiter;
279 Value : Gela.Int.Defining_Names.Defining_Name)
280 is
281 pragma Unreferenced (Self);
282 begin
283 Target.On_Defining_Name
284 (Name => Value.Name,
285 Down => Value.Down);
286 end Defining_Name;
287
288 ----------------
289 -- Expression --
290 ----------------
291
292 overriding procedure Expression
293 (Self : access Visiter;
294 Value : Gela.Int.Expressions.Expression)
295 is
296 pragma Unreferenced (Self);
297 begin
298 Target.On_Expression
299 (Tipe => Value.Expression_Type,
300 Down => Value.Down);
301 end Expression;
302
303 end Switch;
304
305 V : aliased Switch.Visiter;
306 begin
307 if Index /= 0 then
308 Self.Item_Batches.Element (Index / Batch_Size).Element (Index).Visit
309 (V'Access);
310 end if;
311 end Visit;
312
313end Gela.Plain_Interpretations;
Note: See TracBrowser for help on using the repository browser.