Branch data Line data Source code
1 : : /* m2treelib.cc provides call trees, modify_expr and miscelaneous.
2 : :
3 : : Copyright (C) 2012-2023 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 : 1366 : m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word,
44 : : tree bit, char *label)
45 : : {
46 : 1366 : word = m2convert_ToWord (location, word);
47 : 1366 : bit = m2convert_ToWord (location, bit);
48 : 1366 : 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 : 1366 : }
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 : 47797 : build_modify_expr (location_t location, tree lhs, enum tree_code modifycode,
77 : : tree rhs)
78 : : {
79 : 47797 : tree result;
80 : 47797 : tree newrhs;
81 : 47797 : tree rhs_semantic_type = NULL_TREE;
82 : 47797 : tree lhstype = TREE_TYPE (lhs);
83 : 47797 : tree olhstype = lhstype;
84 : :
85 : 47797 : ASSERT_CONDITION (modifycode == NOP_EXPR);
86 : :
87 : 47797 : 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 : 47797 : 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 : 47797 : 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 : 47797 : if (lhstype != TREE_TYPE (lhs))
110 : : {
111 : 0 : lhs = copy_node (lhs);
112 : 0 : TREE_TYPE (lhs) = lhstype;
113 : : }
114 : :
115 : 47797 : newrhs = fold (newrhs);
116 : :
117 : 47797 : if (rhs_semantic_type)
118 : 0 : newrhs = build1 (EXCESS_PRECISION_EXPR, rhs_semantic_type, newrhs);
119 : :
120 : : /* Scan operands. */
121 : :
122 : 47797 : result = build2 (MODIFY_EXPR, lhstype, lhs, newrhs);
123 : 47797 : TREE_SIDE_EFFECTS (result) = 1;
124 : 47797 : 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 : 47797 : 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 : 47797 : return result;
136 : : }
137 : :
138 : : /* m2treelib_build_modify_expr - wrapper function for
139 : : build_modify_expr. */
140 : :
141 : : tree
142 : 47797 : m2treelib_build_modify_expr (location_t location, tree des,
143 : : enum tree_code modifycode, tree copy)
144 : : {
145 : 47797 : 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 : 500 : nCount (tree t)
152 : : {
153 : 500 : int i = 0;
154 : :
155 : 1238 : while (t != NULL)
156 : : {
157 : 738 : i++;
158 : 738 : t = TREE_CHAIN (t);
159 : : }
160 : 500 : return i;
161 : : }
162 : :
163 : : /* DoCall - build a call tree arranging the parameter list as a
164 : : vector. */
165 : :
166 : : tree
167 : 500 : m2treelib_DoCall (location_t location, tree rettype, tree funcptr,
168 : : tree param_list)
169 : : {
170 : 500 : int n = nCount (param_list);
171 : 500 : tree *argarray = XALLOCAVEC (tree, n);
172 : 500 : tree l = param_list;
173 : 500 : int i;
174 : :
175 : 1238 : for (i = 0; i < n; i++)
176 : : {
177 : 738 : argarray[i] = TREE_VALUE (l);
178 : 738 : l = TREE_CHAIN (l);
179 : : }
180 : 500 : 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 : :
192 : 0 : return build_call_array_loc (location, rettype, funcptr, 0, argarray);
193 : : }
194 : :
195 : : /* DoCall1 - build a call tree with 1 parameter. */
196 : :
197 : : tree
198 : 6591 : m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr, tree arg0)
199 : : {
200 : 6591 : tree *argarray = XALLOCAVEC (tree, 1);
201 : :
202 : 6591 : argarray[0] = arg0;
203 : :
204 : 6591 : return build_call_array_loc (location, rettype, funcptr, 1, argarray);
205 : : }
206 : :
207 : : /* DoCall2 - build a call tree with 2 parameters. */
208 : :
209 : : tree
210 : 0 : m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr, tree arg0,
211 : : tree arg1)
212 : : {
213 : 0 : tree *argarray = XALLOCAVEC (tree, 2);
214 : :
215 : 0 : argarray[0] = arg0;
216 : 0 : argarray[1] = arg1;
217 : :
218 : 0 : return build_call_array_loc (location, rettype, funcptr, 2, argarray);
219 : : }
220 : :
221 : : /* DoCall3 - build a call tree with 3 parameters. */
222 : :
223 : : tree
224 : 5487 : m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0,
225 : : tree arg1, tree arg2)
226 : : {
227 : 5487 : tree *argarray = XALLOCAVEC (tree, 3);
228 : :
229 : 5487 : argarray[0] = arg0;
230 : 5487 : argarray[1] = arg1;
231 : 5487 : argarray[2] = arg2;
232 : :
233 : 5487 : return build_call_array_loc (location, rettype, funcptr, 3, argarray);
234 : : }
235 : :
236 : : /* get_rvalue - returns the rvalue of t. The, type, is the object
237 : : type to be copied upon indirection. */
238 : :
239 : : tree
240 : 6774 : m2treelib_get_rvalue (location_t location, tree t, tree type, bool is_lvalue)
241 : : {
242 : 6774 : if (is_lvalue)
243 : 488 : return m2expr_BuildIndirect (location, t, type);
244 : : else
245 : : return t;
246 : : }
247 : :
248 : : /* get_field_no - returns the field no for, op. The, op, is either a
249 : : constructor or a variable of type record. If, op, is a
250 : : constructor (a set constant in GNU Modula-2) then this function is
251 : : essentially a no-op and it returns op. Else we iterate over the
252 : : field list and return the appropriate field number. */
253 : :
254 : : tree
255 : 17202 : m2treelib_get_field_no (tree type, tree op, bool is_const, unsigned int fieldNo)
256 : : {
257 : 17202 : ASSERT_BOOL (is_const);
258 : 17202 : if (is_const)
259 : : return op;
260 : : else
261 : : {
262 : 10818 : tree list = TYPE_FIELDS (type);
263 : 140130 : while (fieldNo > 0 && list != NULL_TREE)
264 : : {
265 : 129312 : list = TREE_CHAIN (list);
266 : 129312 : fieldNo--;
267 : : }
268 : 10818 : return list;
269 : : }
270 : : }
271 : :
272 : : /* get_set_value - returns the value indicated by, field, in the set.
273 : : Either p->field or the constant(op.fieldNo) is returned. */
274 : :
275 : : tree
276 : 14976 : m2treelib_get_set_value (location_t location, tree p, tree field, bool is_const,
277 : : bool is_lvalue, tree op, unsigned int fieldNo)
278 : : {
279 : 14976 : tree value;
280 : 14976 : constructor_elt *ce;
281 : :
282 : 14976 : ASSERT_BOOL (is_const);
283 : 14976 : ASSERT_BOOL (is_lvalue);
284 : 14976 : if (is_const)
285 : : {
286 : 5832 : ASSERT_CONDITION (is_lvalue == FALSE);
287 : 5832 : gcc_assert (!vec_safe_is_empty (CONSTRUCTOR_ELTS (op)));
288 : 5832 : unsigned int size = vec_safe_length (CONSTRUCTOR_ELTS (op));
289 : 5832 : if (size < fieldNo)
290 : 0 : internal_error ("field number exceeds definition of set");
291 : 5832 : if (vec_safe_iterate (CONSTRUCTOR_ELTS (op), fieldNo, &ce))
292 : 5832 : value = ce->value;
293 : : else
294 : 0 : internal_error (
295 : : "field number out of range trying to access set element");
296 : : }
297 : 9144 : else if (is_lvalue)
298 : : {
299 : 576 : if (TREE_CODE (TREE_TYPE (p)) == POINTER_TYPE)
300 : 480 : value = m2expr_BuildComponentRef (
301 : 480 : location, m2expr_BuildIndirect (location, p, TREE_TYPE (p)),
302 : : field);
303 : : else
304 : : {
305 : 96 : ASSERT_CONDITION (TREE_CODE (TREE_TYPE (p)) == REFERENCE_TYPE);
306 : 96 : value = m2expr_BuildComponentRef (location, p, field);
307 : : }
308 : : }
309 : : else
310 : : {
311 : 8568 : tree type = TREE_TYPE (op);
312 : 8568 : enum tree_code code = TREE_CODE (type);
313 : :
314 : 8568 : ASSERT_CONDITION (code == RECORD_TYPE
315 : : || (code == POINTER_TYPE
316 : 8568 : && (TREE_CODE (TREE_TYPE (type)) == RECORD_TYPE)));
317 : 8568 : value = m2expr_BuildComponentRef (location, op, field);
318 : : }
319 : 14976 : value = m2convert_ToBitset (location, value);
320 : 14976 : return value;
321 : : }
322 : :
323 : : /* get_set_address - returns the address of op1. */
324 : :
325 : : tree
326 : 2008 : m2treelib_get_set_address (location_t location, tree op1, bool is_lvalue)
327 : : {
328 : 2008 : if (is_lvalue)
329 : : return op1;
330 : : else
331 : 1737 : return m2expr_BuildAddr (location, op1, FALSE);
332 : : }
333 : :
334 : : /* get_set_field_lhs - returns the address of p->field. */
335 : :
336 : : tree
337 : 0 : m2treelib_get_set_field_lhs (location_t location, tree p, tree field)
338 : : {
339 : 0 : return m2expr_BuildAddr (
340 : : location, m2convert_ToBitset (
341 : : location, m2expr_BuildComponentRef (location, p, field)),
342 : 0 : FALSE);
343 : : }
344 : :
345 : : /* get_set_field_rhs - returns the value of p->field. */
346 : :
347 : : tree
348 : 390 : m2treelib_get_set_field_rhs (location_t location, tree p, tree field)
349 : : {
350 : 390 : return m2convert_ToBitset (location,
351 : 390 : m2expr_BuildComponentRef (location, p, field));
352 : : }
353 : :
354 : : /* get_set_field_des - returns the p->field ready to be a (rhs)
355 : : designator. */
356 : :
357 : : tree
358 : 924 : m2treelib_get_set_field_des (location_t location, tree p, tree field)
359 : : {
360 : 924 : return m2expr_BuildIndirect (
361 : : location,
362 : : m2expr_BuildAddr (location,
363 : : m2expr_BuildComponentRef (location, p, field), FALSE),
364 : 924 : m2type_GetBitsetType ());
365 : : }
366 : :
367 : : /* get_set_address_if_var - returns the address of, op, providing it
368 : : is not a constant. NULL is returned if, op, is a constant. */
369 : :
370 : : tree
371 : 1284 : m2treelib_get_set_address_if_var (location_t location, tree op, bool is_lvalue,
372 : : bool is_const)
373 : : {
374 : 1284 : if (is_const)
375 : : return NULL;
376 : : else
377 : 732 : return m2treelib_get_set_address (location, op, is_lvalue);
378 : : }
379 : :
380 : : /* add_stmt - t is a statement. Add it to the statement-tree. */
381 : :
382 : : tree
383 : 1009612 : add_stmt (location_t location, tree t)
384 : : {
385 : 1009612 : return m2block_add_stmt (location, t);
386 : : }
387 : :
388 : : /* taken from gcc/c-semantics.cc. */
389 : :
390 : : /* Build a generic statement based on the given type of node and
391 : : arguments. Similar to `build_nt', except that we set EXPR_LOCATION
392 : : to LOC. */
393 : :
394 : : tree
395 : 506699 : build_stmt (location_t loc, enum tree_code code, ...)
396 : : {
397 : 506699 : tree ret;
398 : 506699 : int length, i;
399 : 506699 : va_list p;
400 : 506699 : bool side_effects;
401 : :
402 : 506699 : m2assert_AssertLocation (loc);
403 : : /* This function cannot be used to construct variably-sized nodes. */
404 : 506699 : gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp);
405 : :
406 : 506699 : va_start (p, code);
407 : :
408 : 506699 : ret = make_node (code);
409 : 506699 : TREE_TYPE (ret) = void_type_node;
410 : 506699 : length = TREE_CODE_LENGTH (code);
411 : 506699 : SET_EXPR_LOCATION (ret, loc);
412 : :
413 : : /* TREE_SIDE_EFFECTS will already be set for statements with implicit
414 : : side effects. Here we make sure it is set for other expressions by
415 : : checking whether the parameters have side effects. */
416 : :
417 : 506699 : side_effects = false;
418 : 1018130 : for (i = 0; i < length; i++)
419 : : {
420 : 511431 : tree t = va_arg (p, tree);
421 : 511431 : if (t && !TYPE_P (t))
422 : 502063 : side_effects |= TREE_SIDE_EFFECTS (t);
423 : 511431 : TREE_OPERAND (ret, i) = t;
424 : : }
425 : :
426 : 506699 : TREE_SIDE_EFFECTS (ret) |= side_effects;
427 : :
428 : 506699 : va_end (p);
429 : 506699 : return ret;
430 : : }
|
