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