source: trunk/ada-2012/src/semantic/gela-plain_value_sets.adb@ 552

Last change on this file since 552 was 415, checked in by Maxim Reznik, 7 years ago

Set svn:keywords

  • Property svn:keywords set to Author Date Revision
File size: 9.7 KB
Line 
1with League.Strings.Hash;
2
3with Gela.Element_Visiters;
4with Gela.Elements.Defining_Designators;
5with Gela.Elements.Defining_Operator_Symbols;
6with Gela.Elements.Function_Declarations;
7with Gela.Lexical_Types;
8
9package body Gela.Plain_Value_Sets is
10
11 ------------
12 -- Concat --
13 ------------
14
15 overriding procedure Apply
16 (Self : in out Value_Set;
17 Name : Gela.Semantic_Types.Value_Index;
18 Args : Gela.Semantic_Types.Value_Index;
19 Value : out Gela.Semantic_Types.Value_Index)
20 is
21 use type League.Strings.Universal_String;
22 use type Gela.Semantic_Types.Value_Index;
23 Op : Gela.Semantic_Types.Static_Operator;
24 begin
25 Value := 0;
26
27 if Args = 0 or Name = 0 then
28 return;
29 end if;
30
31 declare
32 Item : constant Gela.Plain_Value_Sets.Value :=
33 Self.Vector.Element (Name);
34 begin
35 if Item.Kind = Denote_Function then
36 Op := Item.Op;
37 else
38 return;
39 end if;
40 end;
41
42 declare
43 use type Gela.Arithmetic.Integers.Value;
44
45 Item : constant Gela.Plain_Value_Sets.Value :=
46 Self.Vector.Element (Args);
47 Left : Gela.Plain_Value_Sets.Value;
48 Right : Gela.Plain_Value_Sets.Value;
49 begin
50 if Item.Kind /= List_Value then
51 Self.String_Literal
52 (League.Strings.To_Universal_String ("???"),
53 Value);
54 return;
55 end if;
56
57 Left := Self.Vector.Element (Item.Head);
58 Right := Self.Vector.Element (Item.Tail);
59 case Op is
60 when Gela.Semantic_Types.Ampersand_Operator =>
61 if Left.Kind = String_Value and then
62 Right.Kind = String_Value
63 then
64 Self.String_Literal
65 (Left.String & Right.String,
66 Value);
67 end if;
68 when Gela.Semantic_Types.Hyphen_Operator =>
69 if Left.Kind = Integer_Value and then
70 Right.Kind = Integer_Value
71 then
72 Self.Put_Value
73 ((Integer_Value, Left.Integer - Right.Integer), Value);
74 end if;
75 when Gela.Semantic_Types.Plus_Operator =>
76 if Left.Kind = Integer_Value and then
77 Right.Kind = Integer_Value
78 then
79 Self.Put_Value
80 ((Integer_Value, Left.Integer + Right.Integer), Value);
81 end if;
82 when Gela.Semantic_Types.Star_Operator =>
83 if Left.Kind = Integer_Value and then
84 Right.Kind = Integer_Value
85 then
86 Self.Put_Value
87 ((Integer_Value, Left.Integer * Right.Integer), Value);
88 end if;
89 when Gela.Semantic_Types.Slash_Operator =>
90 if Left.Kind = Integer_Value and then
91 Right.Kind = Integer_Value and then
92 Right.Integer /= Gela.Arithmetic.Integers.Zero -- FIXME
93 then
94 Self.Put_Value
95 ((Integer_Value, Left.Integer / Right.Integer), Value);
96 end if;
97 when Gela.Semantic_Types.Rem_Operator =>
98 if Left.Kind = Integer_Value and then
99 Right.Kind = Integer_Value and then
100 Right.Integer /= Gela.Arithmetic.Integers.Zero -- FIXME
101 then
102 Self.Put_Value
103 ((Integer_Value, Left.Integer rem Right.Integer), Value);
104 end if;
105 when others =>
106 raise Constraint_Error with "unimplemeneted";
107 end case;
108 end;
109 end Apply;
110
111 ----------
112 -- List --
113 ----------
114
115 overriding procedure List
116 (Self : in out Value_Set;
117 Head : Gela.Semantic_Types.Value_Index;
118 Tail : Gela.Semantic_Types.Value_Index;
119 Value : out Gela.Semantic_Types.Value_Index)
120 is
121 use type Gela.Semantic_Types.Value_Index;
122 begin
123 if Tail = 0 then
124 Value := Head;
125 elsif Head = 0 then
126 Value := 0;
127 else
128 Self.Put_Value ((List_Value, Head, Tail), Value);
129 end if;
130 end List;
131
132 ----------
133 -- Name --
134 ----------
135
136 overriding procedure Name
137 (Self : in out Value_Set;
138 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
139 Value : out Gela.Semantic_Types.Value_Index)
140 is
141
142 package Get is
143 type Visiter is new Gela.Element_Visiters.Visiter with record
144 Result : Gela.Semantic_Types.Value_Index := 0;
145 end record;
146
147 overriding procedure Defining_Operator_Symbol
148 (V : in out Visiter;
149 Node : not null Gela.Elements.Defining_Operator_Symbols.
150 Defining_Operator_Symbol_Access);
151
152 overriding procedure Function_Declaration
153 (Self : in out Visiter;
154 Node : not null Gela.Elements.Function_Declarations.
155 Function_Declaration_Access);
156
157 end Get;
158
159 package body Get is
160
161 overriding procedure Defining_Operator_Symbol
162 (V : in out Visiter;
163 Node : not null Gela.Elements.Defining_Operator_Symbols.
164 Defining_Operator_Symbol_Access)
165 is
166 use type Gela.Lexical_Types.Symbol;
167
168 Symbol : constant Gela.Lexical_Types.Symbol := Node.Full_Name;
169 Op : constant Gela.Semantic_Types.Static_Operator :=
170 Gela.Semantic_Types.Static_Operator'Val (Symbol - 1);
171 Item : constant Gela.Plain_Value_Sets.Value :=
172 (Denote_Function, Op);
173 begin
174 Put_Value (Self => Self,
175 Item => Item,
176 Value => V.Result);
177 end Defining_Operator_Symbol;
178
179 overriding procedure Function_Declaration
180 (Self : in out Visiter;
181 Node : not null Gela.Elements.Function_Declarations.
182 Function_Declaration_Access)
183 is
184 Name : constant Gela.Elements.Defining_Designators.
185 Defining_Designator_Access := Node.Names;
186 begin
187 Name.Visit (Self);
188 end Function_Declaration;
189
190 end Get;
191
192 use type Gela.Elements.Element_Access;
193 use type Gela.Elements.Defining_Names.Defining_Name_Access;
194
195 V : aliased Get.Visiter;
196 begin
197 if Name /= null and then Name.Enclosing_Element /= null then
198 Name.Enclosing_Element.Visit (V);
199 else
200 -- FIXME stub until name resolution ready
201 declare
202 Item : constant Gela.Plain_Value_Sets.Value :=
203 (Denote_Function, Gela.Semantic_Types.Ampersand_Operator);
204 begin
205 Put_Value (Self => Self,
206 Item => Item,
207 Value => V.Result);
208 end;
209 end if;
210
211 Value := V.Result;
212 end Name;
213
214 ----------
215 -- Hash --
216 ----------
217
218 function Hash (X : Value) return Ada.Containers.Hash_Type is
219 use type Ada.Containers.Hash_Type;
220 begin
221 case X.Kind is
222 when Denote_Function =>
223 return Gela.Semantic_Types.Static_Operator'Pos (X.Op);
224 when Integer_Value =>
225 return Gela.Arithmetic.Integers.Hash (X.Integer);
226 when String_Value =>
227 return League.Strings.Hash (X.String);
228 when List_Value =>
229 return 65_213 * Ada.Containers.Hash_Type (X.Head) +
230 Ada.Containers.Hash_Type (X.Tail);
231 end case;
232 end Hash;
233
234 -----------
235 -- Image --
236 -----------
237
238 overriding function Image
239 (Self : Value_Set;
240 Value : Gela.Semantic_Types.Value_Index)
241 return League.Strings.Universal_String
242 is
243 Item : constant Gela.Plain_Value_Sets.Value :=
244 Self.Vector.Element (Value);
245 begin
246 case Item.Kind is
247 when String_Value =>
248 return Item.String;
249 when Integer_Value =>
250 return League.Strings.From_UTF_8_String
251 (Gela.Arithmetic.Integers.Image (Item.Integer));
252 when others =>
253 raise Constraint_Error;
254 end case;
255 end Image;
256
257 ---------------
258 -- Is_String --
259 ---------------
260
261 overriding function Is_String
262 (Self : Value_Set;
263 Value : Gela.Semantic_Types.Value_Index) return Boolean is
264 begin
265 return Self.Vector.Element (Value).Kind = String_Value;
266 end Is_String;
267
268 ---------------------
269 -- Numeric_Literal --
270 ---------------------
271
272 overriding procedure Numeric_Literal
273 (Self : in out Value_Set;
274 Image : League.Strings.Universal_String;
275 Value : out Gela.Semantic_Types.Value_Index)
276 is
277 X : constant Gela.Arithmetic.Integers.Value :=
278 Gela.Arithmetic.Integers.Literal (Image.To_UTF_8_String);
279 Item : constant Gela.Plain_Value_Sets.Value := (Integer_Value, X);
280 begin
281 Self.Put_Value (Item, Value);
282 end Numeric_Literal;
283
284 ---------------
285 -- Put_Value --
286 ---------------
287
288 not overriding procedure Put_Value
289 (Self : in out Value_Set;
290 Item : Value;
291 Value : out Gela.Semantic_Types.Value_Index)
292 is
293 Pos : constant Hash_Maps.Cursor := Self.Map.Find (Item);
294 begin
295 if Hash_Maps.Has_Element (Pos) then
296 Value := Hash_Maps.Element (Pos);
297 else
298 Self.Vector.Append (Item);
299 Value := Self.Vector.Last_Index;
300 Self.Map.Insert (Item, Value);
301 end if;
302 end Put_Value;
303
304 --------------------
305 -- String_Literal --
306 --------------------
307
308 overriding procedure String_Literal
309 (Self : in out Value_Set;
310 Image : League.Strings.Universal_String;
311 Value : out Gela.Semantic_Types.Value_Index)
312 is
313 Item : constant Gela.Plain_Value_Sets.Value := (String_Value, Image);
314 begin
315 Self.Put_Value (Item, Value);
316 end String_Literal;
317
318
319end Gela.Plain_Value_Sets;
Note: See TracBrowser for help on using the repository browser.