Branch data Line data Source code
1 : : /* m2treelib.cc provides call trees, modify_expr and miscelaneous.
2 : :
3 : : Copyright (C) 2012-2025 Free Software Foundation, Inc.
4 : : Contributed by Gaius Mulley <gaius@glam.ac.uk>.
5 : :
6 : : This file is part of GNU Modula-2.
7 : :
8 : : GNU Modula-2 is free software; you can redistribute it and/or modify
9 : : it under the terms of the GNU General Public License as published by
10 : : the Free Software Foundation; either version 3, or (at your option)
11 : : any later version.
12 : :
13 : : GNU Modula-2 is distributed in the hope that it will be useful, but
14 : : WITHOUT ANY WARRANTY; without even the implied warranty of
15 : : MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 : : General Public License for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GNU Modula-2; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : #include "gcc-consolidation.h"
23 : :
24 : : #include "../gm2-lang.h"
25 : : #include "../m2-tree.h"
26 : :
27 : : #define m2treelib_c
28 : : #include "m2assert.h"
29 : : #include "m2block.h"
30 : : #include "m2convert.h"
31 : : #include "m2decl.h"
32 : : #include "m2expr.h"
33 : : #include "m2statement.h"
34 : : #include "m2tree.h"
35 : : #include "m2treelib.h"
36 : : #include "m2treelib.h"
37 : : #include "m2type.h"
38 : :
39 : : /* do_jump_if_bit - tests bit in word against integer zero using
40 : : operator, code. If the result is true then jump to label. */
41 : :
42 : : void
43 : 1528 : m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word,
44 : : tree bit, char *label)
45 : : {
46 : 1528 : word = m2convert_ToWord (location, word);
47 : 1528 : bit = m2convert_ToWord (location, bit);
48 : 1528 : m2statement_DoJump (
49 : : location,
50 : : m2expr_build_binary_op (
51 : : location, code,
52 : : m2expr_build_binary_op (
53 : : location, BIT_AND_EXPR, word,
54 : : m2expr_BuildLSL (location, m2expr_GetWordOne (location), bit,
55 : : FALSE),
56 : : FALSE),
57 : : m2expr_GetWordZero (location), FALSE),
58 : : NULL, label);
59 : 1528 : }
60 : :
61 : : /* build_modify_expr - taken from c-typeck.cc and heavily pruned.
62 : :
63 : : Build an assignment expression of lvalue LHS from value RHS. If
64 : : LHS_ORIGTYPE is not NULL, it is the original type of LHS, which
65 : : may differ from TREE_TYPE (LHS) for an enum bitfield. MODIFYCODE
66 : : is the code for a binary operator that we use to combine the old
67 : : value of LHS with RHS to get the new value. Or else MODIFYCODE is
68 : : NOP_EXPR meaning do a simple assignment. If RHS_ORIGTYPE is not
69 : : NULL_TREE, it is the original type of RHS, which may differ from
70 : : TREE_TYPE (RHS) for an enum value.
71 : :
72 : : LOCATION is the location of the MODIFYCODE operator. RHS_LOC is the
73 : : location of the RHS. */
74 : :
75 : : static tree
76 : 64044 : build_modify_expr (location_t location, tree lhs, enum tree_code modifycode,
77 : : tree rhs)
78 : : {
79 : 64044 : tree result;
80 : 64044 : tree newrhs;
81 : 64044 : tree rhs_semantic_type = NULL_TREE;
82 : 64044 : tree lhstype = TREE_TYPE (lhs);
83 : 64044 : tree olhstype = lhstype;
84 : :
85 : 64044 : ASSERT_CONDITION (modifycode == NOP_EXPR);
86 : :
87 : 64044 : if (TREE_CODE (rhs) == EXCESS_PRECISION_EXPR)
88 : : {
89 : 0 : rhs_semantic_type = TREE_TYPE (rhs);
90 : 0 : rhs = TREE_OPERAND (rhs, 0);
91 : : }
92 : :
93 : 64044 : newrhs = rhs;
94 : :
95 : : /* If storing into a structure or union member, it has probably been
96 : : given type `int'. Compute the type that would go with the actual
97 : : amount of storage the member occupies. */
98 : :
99 : 64044 : if (TREE_CODE (lhs) == COMPONENT_REF
100 : 0 : && (TREE_CODE (lhstype) == INTEGER_TYPE
101 : 0 : || TREE_CODE (lhstype) == BOOLEAN_TYPE
102 : 0 : || SCALAR_FLOAT_TYPE_P (lhstype)
103 : 0 : || TREE_CODE (lhstype) == ENUMERAL_TYPE))
104 : 0 : lhstype = TREE_TYPE (get_unwidened (lhs, 0));
105 : :
106 : : /* If storing in a field that is in actuality a short or narrower
107 : : than one, we must store in the field in its actual type. */
108 : :
109 : 64044 : if (lhstype != TREE_TYPE (lhs))
110 : : {
111 : 0 : lhs = copy_node (lhs);
112 : 0 : TREE_TYPE (lhs) = lhstype;
113 : : }
114 : :
115 : 64044 : newrhs = fold (newrhs);
116 : :
117 : 64044 : if (rhs_semantic_type)
118 : 0 : newrhs = build1 (EXCESS_PRECISION_EXPR, rhs_semantic_type, newrhs);
119 : :
120 : : /* Scan operands. */
121 : :
122 : 64044 : result = build2 (MODIFY_EXPR, lhstype, lhs, newrhs);
123 : 64044 : TREE_SIDE_EFFECTS (result) = 1;
124 : 64044 : protected_set_expr_location (result, location);
125 : :
126 : : /* If we got the LHS in a different type for storing in, convert the
127 : : result back to the nominal type of LHS so that the value we return
128 : : always has the same type as the LHS argument. */
129 : :
130 : 64044 : ASSERT_CONDITION (olhstype == TREE_TYPE (result));
131 : : /* In Modula-2 I'm assuming this will be true this maybe wrong, but
132 : : at least I'll know about it soon. If true then we do not need to
133 : : implement convert_for_assignment - which is a huge win. */
134 : :
135 : 64044 : return result;
136 : : }
137 : :
138 : : /* m2treelib_build_modify_expr - wrapper function for
139 : : build_modify_expr. */
140 : :
141 : : tree
142 : 64044 : m2treelib_build_modify_expr (location_t location, tree des,
143 : : enum tree_code modifycode, tree copy)
144 : : {
145 : 64044 : return build_modify_expr (location, des, modifycode, copy);
146 : : }
147 : :
148 : : /* nCount - return the number of trees chained on, t. */
149 : :
150 : : static int
151 : 1068 : nCount (tree t)
152 : : {
153 : 1068 : int i = 0;
154 : :
155 : 2470 : while (t != NULL)
156 : : {
157 : 1402 : i++;
158 : 1402 : t = TREE_CHAIN (t);
159 : : }
160 : 1068 : return i;
161 : : }
162 : :
163 : : /* DoCall - build a call tree arranging the parameter list as a
164 : : vector. */
165 : :
166 : : tree
167 : 1068 : m2treelib_DoCall (location_t location, tree rettype, tree funcptr,
168 : : tree param_list)
169 : : {
170 : 1068 : int n = nCount (param_list);
171 : 1068 : tree *argarray = XALLOCAVEC (tree, n);
172 : 1068 : tree l = param_list;
173 : 1068 : int i;
174 : :
175 : 2470 : for (i = 0; i < n; i++)
176 : : {
177 : 1402 : argarray[i] = TREE_VALUE (l);
178 : 1402 : l = TREE_CHAIN (l);
179 : : }
180 : 1068 : return build_call_array_loc (location, rettype, funcptr, n, argarray);
181 : : }
182 : :
183 : : /* DoCall0 - build a call tree with no parameters. */
184 : :
185 : : tree
186 : 0 : m2treelib_DoCall0 (location_t location, tree rettype, tree funcptr)
187 : : {
188 : 0 : tree *argarray = XALLOCAVEC (tree, 1);
189 : :
190 : 0 : argarray[0] = NULL_TREE;
191 : 0 : return build_call_array_loc (location, rettype, funcptr, 0, argarray);
192 : : }
193 : :
194 : : /* DoCall1 - build a call tree with 1 parameter. */
195 : :
196 : : tree
197 : 7552 : m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr, tree arg0)
198 : : {
199 : 7552 : tree *argarray = XALLOCAVEC (tree, 1);
200 : :
201 : 7552 : argarray[0] = arg0;
202 : 7552 : return build_call_array_loc (location, rettype, funcptr, 1, argarray);
203 : : }
204 : :
205 : : /* DoCall2 - build a call tree with 2 parameters. */
206 : :
207 : : tree
208 : 0 : m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr, tree arg0,
209 : : tree arg1)
210 : : {
211 : 0 : tree *argarray = XALLOCAVEC (tree, 2);
212 : :
213 : 0 : argarray[0] = arg0;
214 : 0 : argarray[1] = arg1;
215 : 0 : return build_call_array_loc (location, rettype, funcptr, 2, argarray);
216 : : }
217 : :
218 : : /* DoCall3 - build a call tree with 3 parameters. */
219 : :
220 : : tree
221 : 5926 : m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0,
222 : : tree arg1, tree arg2)
223 : : {
224 : 5926 : tree *argarray = XALLOCAVEC (tree, 3);
225 : :
226 : 5926 : argarray[0] = arg0;
227 : 5926 : argarray[1] = arg1;
228 : 5926 : argarray[2] = arg2;
229 : 5926 : return build_call_array_loc (location, rettype, funcptr, 3, argarray);
230 : : }
231 : :
232 : : /* get_rvalue - returns the rvalue of t. The, type, is the object
233 : : type to be copied upon indirection. */
234 : :
235 : : tree
236 : 7740 : m2treelib_get_rvalue (location_t location, tree t, tree type, bool is_lvalue)
237 : : {
238 : 7740 : if (is_lvalue)
239 : 488 : return m2expr_BuildIndirect (location, t, type);
240 : : else
241 : : return t;
242 : : }
243 : :
244 : : /* get_field_no - returns the field no for, op. The, op, is either a
245 : : constructor or a variable of type record. If, op, is a
246 : : constructor (a set constant in GNU Modula-2) then this function is
247 : : essentially a no-op and it returns op. Else we iterate over the
248 : : field list and return the appropriate field number. */
249 : :
250 : : tree
251 : 26162 : m2treelib_get_field_no (tree type, tree op, bool is_const, unsigned int fieldNo)
252 : : {
253 : 26162 : ASSERT_BOOL (is_const);
254 : 26162 : if (is_const)
255 : : return op;
256 : : else
257 : : {
258 : 19778 : tree list = TYPE_FIELDS (type);
259 : 248900 : while (fieldNo > 0 && list != NULL_TREE)
260 : : {
261 : 229122 : list = TREE_CHAIN (list);
262 : 229122 : fieldNo--;
263 : : }
264 : : return list;
265 : : }
266 : : }
267 : :
268 : : /* get_set_value - returns the value indicated by, field, in the set.
269 : : Either p->field or the constant(op.fieldNo) is returned. */
270 : :
271 : : tree
272 : 14976 : m2treelib_get_set_value (location_t location, tree p, tree field, bool is_const,
273 : : bool is_lvalue, tree op, unsigned int fieldNo)
274 : : {
275 : 14976 : tree value;
276 : 14976 : constructor_elt *ce;
277 : :
278 : 14976 : ASSERT_BOOL (is_const);
279 : 14976 : ASSERT_BOOL (is_lvalue);
280 : 14976 : if (is_const)
281 : : {
282 : 5832 : ASSERT_CONDITION (is_lvalue == FALSE);
283 : 5832 : gcc_assert (!vec_safe_is_empty (CONSTRUCTOR_ELTS (op)));
284 : 5832 : unsigned int size = vec_safe_length (CONSTRUCTOR_ELTS (op));
285 : 5832 : if (size < fieldNo)
286 : 0 : internal_error ("field number exceeds definition of set");
287 : 5832 : if (vec_safe_iterate (CONSTRUCTOR_ELTS (op), fieldNo, &ce))
288 : 5832 : value = ce->value;
289 : : else
290 : 0 : internal_error (
291 : : "field number out of range trying to access set element");
292 : : }
293 : 9144 : else if (is_lvalue)
294 : : {
295 : 576 : if (TREE_CODE (TREE_TYPE (p)) == POINTER_TYPE)
296 : 480 : value = m2expr_BuildComponentRef (
297 : 480 : location, m2expr_BuildIndirect (location, p, TREE_TYPE (p)),
298 : : field);
299 : : else
300 : : {
301 : 96 : ASSERT_CONDITION (TREE_CODE (TREE_TYPE (p)) == REFERENCE_TYPE);
302 : 96 : value = m2expr_BuildComponentRef (location, p, field);
303 : : }
304 : : }
305 : : else
306 : : {
307 : 8568 : tree type = TREE_TYPE (op);
308 : 8568 : enum tree_code code = TREE_CODE (type);
309 : :
310 : 8568 : ASSERT_CONDITION (code == RECORD_TYPE
311 : : || (code == POINTER_TYPE
312 : 8568 : && (TREE_CODE (TREE_TYPE (type)) == RECORD_TYPE)));
313 : 8568 : value = m2expr_BuildComponentRef (location, op, field);
314 : : }
315 : 14976 : value = m2convert_ToBitset (location, value);
316 : 14976 : return value;
317 : : }
318 : :
319 : : /* get_set_address - returns the address of op1. */
320 : :
321 : : tree
322 : 2080 : m2treelib_get_set_address (location_t location, tree op1, bool is_lvalue)
323 : : {
324 : 2080 : if (is_lvalue)
325 : : return op1;
326 : : else
327 : 1806 : return m2expr_BuildAddr (location, op1, FALSE);
328 : : }
329 : :
330 : : /* get_set_field_lhs - returns the address of p->field. */
331 : :
332 : : tree
333 : 0 : m2treelib_get_set_field_lhs (location_t location, tree p, tree field)
334 : : {
335 : 0 : return m2expr_BuildAddr (
336 : : location, m2convert_ToBitset (
337 : : location, m2expr_BuildComponentRef (location, p, field)),
338 : 0 : FALSE);
339 : : }
340 : :
341 : : /* get_set_field_rhs - returns the value of p->field. */
342 : :
343 : : tree
344 : 390 : m2treelib_get_set_field_rhs (location_t location, tree p, tree field)
345 : : {
346 : 390 : return m2convert_ToBitset (location,
347 : 390 : m2expr_BuildComponentRef (location, p, field));
348 : : }
349 : :
350 : : /* get_set_field_des - returns the p->field ready to be a (rhs)
351 : : designator. */
352 : :
353 : : tree
354 : 924 : m2treelib_get_set_field_des (location_t location, tree p, tree field)
355 : : {
356 : 924 : return m2expr_BuildIndirect (
357 : : location,
358 : : m2expr_BuildAddr (location,
359 : : m2expr_BuildComponentRef (location, p, field), FALSE),
360 : 924 : m2type_GetBitsetType ());
361 : : }
362 : :
363 : : /* get_set_address_if_var - returns the address of, op, providing it
364 : : is not a constant. NULL is returned if, op, is a constant. */
365 : :
366 : : tree
367 : 1284 : m2treelib_get_set_address_if_var (location_t location, tree op, bool is_lvalue,
368 : : bool is_const)
369 : : {
370 : 1284 : if (is_const)
371 : : return NULL;
372 : : else
373 : 732 : return m2treelib_get_set_address (location, op, is_lvalue);
374 : : }
375 : :
376 : : /* add_stmt add stmt to the statement-tree. */
377 : :
378 : : tree
379 : 1139733 : add_stmt (location_t location, tree stmt)
380 : : {
381 : 1139733 : return m2block_add_stmt (location, stmt);
382 : : }
383 : :
384 : : /* taken from gcc/c-semantics.cc. */
385 : :
386 : : /* Build a generic statement based on the given type of node and
387 : : arguments. Similar to `build_nt', except that we set EXPR_LOCATION
388 : : to LOC. */
389 : :
390 : : tree
391 : 583859 : build_stmt (location_t loc, enum tree_code code, ...)
392 : : {
393 : 583859 : tree ret;
394 : 583859 : int length, i;
395 : 583859 : va_list p;
396 : 583859 : bool side_effects;
397 : :
398 : 583859 : m2assert_AssertLocation (loc);
399 : : /* This function cannot be used to construct variably-sized nodes. */
400 : 583859 : gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp);
401 : :
402 : 583859 : va_start (p, code);
403 : :
404 : 583859 : ret = make_node (code);
405 : 583859 : TREE_TYPE (ret) = void_type_node;
406 : 583859 : length = TREE_CODE_LENGTH (code);
407 : 583859 : SET_EXPR_LOCATION (ret, loc);
408 : :
409 : : /* TREE_SIDE_EFFECTS will already be set for statements with implicit
410 : : side effects. Here we make sure it is set for other expressions by
411 : : checking whether the parameters have side effects. */
412 : :
413 : 583859 : side_effects = false;
414 : 1173338 : for (i = 0; i < length; i++)
415 : : {
416 : 589479 : tree t = va_arg (p, tree);
417 : 589479 : if (t && !TYPE_P (t))
418 : 578359 : side_effects |= TREE_SIDE_EFFECTS (t);
419 : 589479 : TREE_OPERAND (ret, i) = t;
420 : : }
421 : :
422 : 583859 : TREE_SIDE_EFFECTS (ret) |= side_effects;
423 : :
424 : 583859 : va_end (p);
425 : 583859 : return ret;
426 : : }
|
