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

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

Add Is_String function for check static values

File size: 8.3 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 others =>
76 raise Constraint_Error with "unimplemeneted";
77 end case;
78 end;
79 end Apply;
80
81 ----------
82 -- List --
83 ----------
84
85 overriding procedure List
86 (Self : in out Value_Set;
87 Head : Gela.Semantic_Types.Value_Index;
88 Tail : Gela.Semantic_Types.Value_Index;
89 Value : out Gela.Semantic_Types.Value_Index)
90 is
91 use type Gela.Semantic_Types.Value_Index;
92 begin
93 if Tail = 0 then
94 Value := Head;
95 elsif Head = 0 then
96 Value := 0;
97 else
98 Self.Put_Value ((List_Value, Head, Tail), Value);
99 end if;
100 end List;
101
102 ----------
103 -- Name --
104 ----------
105
106 overriding procedure Name
107 (Self : in out Value_Set;
108 Name : Gela.Elements.Defining_Names.Defining_Name_Access;
109 Value : out Gela.Semantic_Types.Value_Index)
110 is
111
112 package Get is
113 type Visiter is new Gela.Element_Visiters.Visiter with record
114 Result : Gela.Semantic_Types.Value_Index := 0;
115 end record;
116
117 overriding procedure Defining_Operator_Symbol
118 (V : in out Visiter;
119 Node : not null Gela.Elements.Defining_Operator_Symbols.
120 Defining_Operator_Symbol_Access);
121
122 overriding procedure Function_Declaration
123 (Self : in out Visiter;
124 Node : not null Gela.Elements.Function_Declarations.
125 Function_Declaration_Access);
126
127 end Get;
128
129 package body Get is
130
131 overriding procedure Defining_Operator_Symbol
132 (V : in out Visiter;
133 Node : not null Gela.Elements.Defining_Operator_Symbols.
134 Defining_Operator_Symbol_Access)
135 is
136 use type Gela.Lexical_Types.Symbol;
137
138 Symbol : constant Gela.Lexical_Types.Symbol := Node.Full_Name;
139 Op : constant Gela.Semantic_Types.Static_Operator :=
140 Gela.Semantic_Types.Static_Operator'Val (Symbol - 1);
141 Item : constant Gela.Plain_Value_Sets.Value :=
142 (Denote_Function, Op);
143 begin
144 Put_Value (Self => Self,
145 Item => Item,
146 Value => V.Result);
147 end Defining_Operator_Symbol;
148
149 overriding procedure Function_Declaration
150 (Self : in out Visiter;
151 Node : not null Gela.Elements.Function_Declarations.
152 Function_Declaration_Access)
153 is
154 Name : constant Gela.Elements.Defining_Designators.
155 Defining_Designator_Access := Node.Names;
156 begin
157 Name.Visit (Self);
158 end Function_Declaration;
159
160 end Get;
161
162 use type Gela.Elements.Element_Access;
163 use type Gela.Elements.Defining_Names.Defining_Name_Access;
164
165 V : aliased Get.Visiter;
166 begin
167 if Name /= null and then Name.Enclosing_Element /= null then
168 Name.Enclosing_Element.Visit (V);
169 else
170 -- FIXME stub until name resolution ready
171 declare
172 Item : constant Gela.Plain_Value_Sets.Value :=
173 (Denote_Function, Gela.Semantic_Types.Ampersand_Operator);
174 begin
175 Put_Value (Self => Self,
176 Item => Item,
177 Value => V.Result);
178 end;
179 end if;
180
181 Value := V.Result;
182 end Name;
183
184 ----------
185 -- Hash --
186 ----------
187
188 function Hash (X : Value) return Ada.Containers.Hash_Type is
189 use type Ada.Containers.Hash_Type;
190 begin
191 case X.Kind is
192 when Denote_Function =>
193 return Gela.Semantic_Types.Static_Operator'Pos (X.Op);
194 when Integer_Value =>
195 return Gela.Arithmetic.Integers.Hash (X.Integer);
196 when String_Value =>
197 return League.Strings.Hash (X.String);
198 when List_Value =>
199 return 65_213 * Ada.Containers.Hash_Type (X.Head) +
200 Ada.Containers.Hash_Type (X.Tail);
201 end case;
202 end Hash;
203
204 -----------
205 -- Image --
206 -----------
207
208 overriding function Image
209 (Self : Value_Set;
210 Value : Gela.Semantic_Types.Value_Index)
211 return League.Strings.Universal_String
212 is
213 Item : constant Gela.Plain_Value_Sets.Value :=
214 Self.Vector.Element (Value);
215 begin
216 case Item.Kind is
217 when String_Value =>
218 return Item.String;
219 when Integer_Value =>
220 return League.Strings.From_UTF_8_String
221 (Gela.Arithmetic.Integers.Image (Item.Integer));
222 when others =>
223 raise Constraint_Error;
224 end case;
225 end Image;
226
227 ---------------
228 -- Is_String --
229 ---------------
230
231 overriding function Is_String
232 (Self : Value_Set;
233 Value : Gela.Semantic_Types.Value_Index) return Boolean is
234 begin
235 return Self.Vector.Element (Value).Kind = String_Value;
236 end Is_String;
237
238 ---------------------
239 -- Numeric_Literal --
240 ---------------------
241
242 overriding procedure Numeric_Literal
243 (Self : in out Value_Set;
244 Image : League.Strings.Universal_String;
245 Value : out Gela.Semantic_Types.Value_Index)
246 is
247 X : constant Gela.Arithmetic.Integers.Value :=
248 Gela.Arithmetic.Integers.Literal (Image.To_UTF_8_String);
249 Item : constant Gela.Plain_Value_Sets.Value := (Integer_Value, X);
250 begin
251 Self.Put_Value (Item, Value);
252 end Numeric_Literal;
253
254 ---------------
255 -- Put_Value --
256 ---------------
257
258 not overriding procedure Put_Value
259 (Self : in out Value_Set;
260 Item : Value;
261 Value : out Gela.Semantic_Types.Value_Index)
262 is
263 Pos : constant Hash_Maps.Cursor := Self.Map.Find (Item);
264 begin
265 if Hash_Maps.Has_Element (Pos) then
266 Value := Hash_Maps.Element (Pos);
267 else
268 Self.Vector.Append (Item);
269 Value := Self.Vector.Last_Index;
270 Self.Map.Insert (Item, Value);
271 end if;
272 end Put_Value;
273
274 --------------------
275 -- String_Literal --
276 --------------------
277
278 overriding procedure String_Literal
279 (Self : in out Value_Set;
280 Image : League.Strings.Universal_String;
281 Value : out Gela.Semantic_Types.Value_Index)
282 is
283 Item : constant Gela.Plain_Value_Sets.Value := (String_Value, Image);
284 begin
285 Self.Put_Value (Item, Value);
286 end String_Literal;
287
288
289end Gela.Plain_Value_Sets;
Note: See TracBrowser for help on using the repository browser.