Branch data Line data Source code
1 : : /* Code translation -- generate GCC trees from gfc_code.
2 : : Copyright (C) 2002-2024 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "tree.h"
26 : : #include "gfortran.h"
27 : : #include "gimple-expr.h" /* For create_tmp_var_raw. */
28 : : #include "trans.h"
29 : : #include "stringpool.h"
30 : : #include "fold-const.h"
31 : : #include "tree-iterator.h"
32 : : #include "trans-stmt.h"
33 : : #include "trans-array.h"
34 : : #include "trans-types.h"
35 : : #include "trans-const.h"
36 : :
37 : : /* Naming convention for backend interface code:
38 : :
39 : : gfc_trans_* translate gfc_code into STMT trees.
40 : :
41 : : gfc_conv_* expression conversion
42 : :
43 : : gfc_get_* get a backend tree representation of a decl or type */
44 : :
45 : : static gfc_file *gfc_current_backend_file;
46 : :
47 : : const char gfc_msg_fault[] = N_("Array reference out of bounds");
48 : :
49 : :
50 : : /* Return a location_t suitable for 'tree' for a gfortran locus. The way the
51 : : parser works in gfortran, loc->lb->location contains only the line number
52 : : and LOCATION_COLUMN is 0; hence, the column has to be added when generating
53 : : locations for 'tree'. Cf. error.cc's gfc_format_decoder. */
54 : :
55 : : location_t
56 : 3036009 : gfc_get_location (locus *loc)
57 : : {
58 : 3036009 : return linemap_position_for_loc_and_offset (line_table, loc->lb->location,
59 : 3036009 : loc->nextc - loc->lb->line);
60 : : }
61 : :
62 : : /* Advance along TREE_CHAIN n times. */
63 : :
64 : : tree
65 : 4576910 : gfc_advance_chain (tree t, int n)
66 : : {
67 : 13142465 : for (; n > 0; n--)
68 : : {
69 : 8565555 : gcc_assert (t != NULL_TREE);
70 : 8565555 : t = DECL_CHAIN (t);
71 : : }
72 : 4576910 : return t;
73 : : }
74 : :
75 : : static int num_var;
76 : :
77 : : #define MAX_PREFIX_LEN 20
78 : :
79 : : static tree
80 : 0 : create_var_debug_raw (tree type, const char *prefix)
81 : : {
82 : : /* Space for prefix + "_" + 10-digit-number + \0. */
83 : 0 : char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1];
84 : 0 : tree t;
85 : 0 : int i;
86 : :
87 : 0 : if (prefix == NULL)
88 : : prefix = "gfc";
89 : : else
90 : 0 : gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN);
91 : :
92 : 0 : for (i = 0; prefix[i] != 0; i++)
93 : 0 : name_buf[i] = gfc_wide_toupper (prefix[i]);
94 : :
95 : 0 : snprintf (name_buf + i, sizeof (name_buf) - i, "_%d", num_var++);
96 : :
97 : 0 : t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type);
98 : :
99 : : /* Not setting this causes some regressions. */
100 : 0 : DECL_ARTIFICIAL (t) = 1;
101 : :
102 : : /* We want debug info for it. */
103 : 0 : DECL_IGNORED_P (t) = 0;
104 : : /* It should not be nameless. */
105 : 0 : DECL_NAMELESS (t) = 0;
106 : :
107 : : /* Make the variable writable. */
108 : 0 : TREE_READONLY (t) = 0;
109 : :
110 : 0 : DECL_EXTERNAL (t) = 0;
111 : 0 : TREE_STATIC (t) = 0;
112 : 0 : TREE_USED (t) = 1;
113 : :
114 : 0 : return t;
115 : : }
116 : :
117 : : /* Creates a variable declaration with a given TYPE. */
118 : :
119 : : tree
120 : 1138256 : gfc_create_var_np (tree type, const char *prefix)
121 : : {
122 : 1138256 : tree t;
123 : :
124 : 1138256 : if (flag_debug_aux_vars)
125 : 0 : return create_var_debug_raw (type, prefix);
126 : :
127 : 1138256 : t = create_tmp_var_raw (type, prefix);
128 : :
129 : : /* No warnings for anonymous variables. */
130 : 1138256 : if (prefix == NULL)
131 : 645714 : suppress_warning (t);
132 : :
133 : : return t;
134 : : }
135 : :
136 : :
137 : : /* Like above, but also adds it to the current scope. */
138 : :
139 : : tree
140 : 1030241 : gfc_create_var (tree type, const char *prefix)
141 : : {
142 : 1030241 : tree tmp;
143 : :
144 : 1030241 : tmp = gfc_create_var_np (type, prefix);
145 : :
146 : 1030241 : pushdecl (tmp);
147 : :
148 : 1030241 : return tmp;
149 : : }
150 : :
151 : :
152 : : /* If the expression is not constant, evaluate it now. We assign the
153 : : result of the expression to an artificially created variable VAR, and
154 : : return a pointer to the VAR_DECL node for this variable. */
155 : :
156 : : tree
157 : 1596408 : gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
158 : : {
159 : 1596408 : tree var;
160 : :
161 : 1596408 : if (CONSTANT_CLASS_P (expr))
162 : : return expr;
163 : :
164 : 523558 : var = gfc_create_var (TREE_TYPE (expr), NULL);
165 : 523558 : gfc_add_modify_loc (loc, pblock, var, expr);
166 : :
167 : 523558 : return var;
168 : : }
169 : :
170 : :
171 : : tree
172 : 1571895 : gfc_evaluate_now (tree expr, stmtblock_t * pblock)
173 : : {
174 : 1571895 : return gfc_evaluate_now_loc (input_location, expr, pblock);
175 : : }
176 : :
177 : :
178 : : /* Returns a fresh pointer variable pointing to the same data as EXPR, adding
179 : : in BLOCK the initialization code that makes it point to EXPR. */
180 : :
181 : : tree
182 : 666 : gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block)
183 : : {
184 : 666 : tree t = expr;
185 : :
186 : 666 : STRIP_NOPS (t);
187 : :
188 : : /* If EXPR can be used as lhs of an assignment, we have to take the address
189 : : of EXPR. Otherwise, reassigning the pointer would retarget it to some
190 : : other data without EXPR being retargetted as well. */
191 : 666 : bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t);
192 : :
193 : 143 : tree value;
194 : 143 : if (lvalue_p)
195 : : {
196 : 523 : value = gfc_build_addr_expr (NULL_TREE, expr);
197 : 523 : value = gfc_evaluate_now (value, block);
198 : 523 : return build_fold_indirect_ref_loc (input_location, value);
199 : : }
200 : : else
201 : 143 : return gfc_evaluate_now (expr, block);
202 : : }
203 : :
204 : :
205 : : /* Like gfc_evaluate_now, but add the created variable to the
206 : : function scope. */
207 : :
208 : : tree
209 : 66 : gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock)
210 : : {
211 : 66 : tree var;
212 : 66 : var = gfc_create_var_np (TREE_TYPE (expr), NULL);
213 : 66 : gfc_add_decl_to_function (var);
214 : 66 : gfc_add_modify (pblock, var, expr);
215 : :
216 : 66 : return var;
217 : : }
218 : :
219 : : /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
220 : : A MODIFY_EXPR is an assignment:
221 : : LHS <- RHS. */
222 : :
223 : : void
224 : 2745214 : gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
225 : : {
226 : 2745214 : tree tmp;
227 : :
228 : 2745214 : tree t1, t2;
229 : 2745214 : t1 = TREE_TYPE (rhs);
230 : 2745214 : t2 = TREE_TYPE (lhs);
231 : : /* Make sure that the types of the rhs and the lhs are compatible
232 : : for scalar assignments. We should probably have something
233 : : similar for aggregates, but right now removing that check just
234 : : breaks everything. */
235 : 2745214 : gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)
236 : : || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
237 : :
238 : 2745214 : tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
239 : : rhs);
240 : 2745214 : gfc_add_expr_to_block (pblock, tmp);
241 : 2745214 : }
242 : :
243 : :
244 : : void
245 : 2167738 : gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
246 : : {
247 : 2167738 : gfc_add_modify_loc (input_location, pblock, lhs, rhs);
248 : 2167738 : }
249 : :
250 : :
251 : : /* Create a new scope/binding level and initialize a block. Care must be
252 : : taken when translating expressions as any temporaries will be placed in
253 : : the innermost scope. */
254 : :
255 : : void
256 : 1818626 : gfc_start_block (stmtblock_t * block)
257 : : {
258 : : /* Start a new binding level. */
259 : 1818626 : pushlevel ();
260 : 1818626 : block->has_scope = 1;
261 : :
262 : : /* The block is empty. */
263 : 1818626 : block->head = NULL_TREE;
264 : 1818626 : }
265 : :
266 : :
267 : : /* Initialize a block without creating a new scope. */
268 : :
269 : : void
270 : 13089541 : gfc_init_block (stmtblock_t * block)
271 : : {
272 : 13089541 : block->head = NULL_TREE;
273 : 13089541 : block->has_scope = 0;
274 : 13089541 : }
275 : :
276 : :
277 : : /* Sometimes we create a scope but it turns out that we don't actually
278 : : need it. This function merges the scope of BLOCK with its parent.
279 : : Only variable decls will be merged, you still need to add the code. */
280 : :
281 : : void
282 : 100 : gfc_merge_block_scope (stmtblock_t * block)
283 : : {
284 : 100 : tree decl;
285 : 100 : tree next;
286 : :
287 : 100 : gcc_assert (block->has_scope);
288 : 100 : block->has_scope = 0;
289 : :
290 : : /* Remember the decls in this scope. */
291 : 100 : decl = getdecls ();
292 : 100 : poplevel (0, 0);
293 : :
294 : : /* Add them to the parent scope. */
295 : 353 : while (decl != NULL_TREE)
296 : : {
297 : 153 : next = DECL_CHAIN (decl);
298 : 153 : DECL_CHAIN (decl) = NULL_TREE;
299 : :
300 : 153 : pushdecl (decl);
301 : 153 : decl = next;
302 : : }
303 : 100 : }
304 : :
305 : :
306 : : /* Finish a scope containing a block of statements. */
307 : :
308 : : tree
309 : 3187058 : gfc_finish_block (stmtblock_t * stmtblock)
310 : : {
311 : 3187058 : tree decl;
312 : 3187058 : tree expr;
313 : 3187058 : tree block;
314 : :
315 : 3187058 : expr = stmtblock->head;
316 : 3187058 : if (!expr)
317 : 433230 : expr = build_empty_stmt (input_location);
318 : :
319 : 3187058 : stmtblock->head = NULL_TREE;
320 : :
321 : 3187058 : if (stmtblock->has_scope)
322 : : {
323 : 1818388 : decl = getdecls ();
324 : :
325 : 1818388 : if (decl)
326 : : {
327 : 440045 : block = poplevel (1, 0);
328 : 440045 : expr = build3_v (BIND_EXPR, decl, expr, block);
329 : : }
330 : : else
331 : 1378343 : poplevel (0, 0);
332 : : }
333 : :
334 : 3187058 : return expr;
335 : : }
336 : :
337 : :
338 : : /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
339 : : natural type is used. */
340 : :
341 : : tree
342 : 1397234 : gfc_build_addr_expr (tree type, tree t)
343 : : {
344 : 1397234 : tree base_type = TREE_TYPE (t);
345 : 1397234 : tree natural_type;
346 : :
347 : 607753 : if (type && POINTER_TYPE_P (type)
348 : 607753 : && TREE_CODE (base_type) == ARRAY_TYPE
349 : 1945067 : && TYPE_MAIN_VARIANT (TREE_TYPE (type))
350 : 547833 : == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
351 : : {
352 : 378314 : tree min_val = size_zero_node;
353 : 378314 : tree type_domain = TYPE_DOMAIN (base_type);
354 : 378314 : if (type_domain && TYPE_MIN_VALUE (type_domain))
355 : 378314 : min_val = TYPE_MIN_VALUE (type_domain);
356 : 378314 : t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
357 : : t, min_val, NULL_TREE, NULL_TREE));
358 : 378314 : natural_type = type;
359 : : }
360 : : else
361 : 1018920 : natural_type = build_pointer_type (base_type);
362 : :
363 : 1397234 : if (INDIRECT_REF_P (t))
364 : : {
365 : 138423 : if (!type)
366 : 69185 : type = natural_type;
367 : 138423 : t = TREE_OPERAND (t, 0);
368 : 138423 : natural_type = TREE_TYPE (t);
369 : : }
370 : : else
371 : : {
372 : 1258811 : tree base = get_base_address (t);
373 : 1258811 : if (base && DECL_P (base))
374 : 869073 : TREE_ADDRESSABLE (base) = 1;
375 : 1258811 : t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
376 : : }
377 : :
378 : 1397234 : if (type && natural_type != type)
379 : 171375 : t = convert (type, t);
380 : :
381 : 1397234 : return t;
382 : : }
383 : :
384 : :
385 : : static tree
386 : 17480 : get_array_span (tree type, tree decl)
387 : : {
388 : 17480 : tree span;
389 : :
390 : : /* Component references are guaranteed to have a reliable value for
391 : : 'span'. Likewise indirect references since they emerge from the
392 : : conversion of a CFI descriptor or the hidden dummy descriptor. */
393 : 17480 : if (TREE_CODE (decl) == COMPONENT_REF
394 : 17480 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
395 : 2499 : return gfc_conv_descriptor_span_get (decl);
396 : 14981 : else if (INDIRECT_REF_P (decl)
397 : 14981 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
398 : 2321 : return gfc_conv_descriptor_span_get (decl);
399 : :
400 : : /* Return the span for deferred character length array references. */
401 : 12660 : if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type))
402 : : {
403 : 6221 : if (TREE_CODE (decl) == PARM_DECL)
404 : 359 : decl = build_fold_indirect_ref_loc (input_location, decl);
405 : 6221 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
406 : 4511 : span = gfc_conv_descriptor_span_get (decl);
407 : : else
408 : 1710 : span = gfc_get_character_len_in_bytes (type);
409 : 6221 : span = (span && !integer_zerop (span))
410 : 12442 : ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE);
411 : : }
412 : : /* Likewise for class array or pointer array references. */
413 : 6439 : else if (TREE_CODE (decl) == FIELD_DECL
414 : : || VAR_OR_FUNCTION_DECL_P (decl)
415 : : || TREE_CODE (decl) == PARM_DECL)
416 : : {
417 : 6439 : if (GFC_DECL_CLASS (decl))
418 : : {
419 : : /* When a temporary is in place for the class array, then the
420 : : original class' declaration is stored in the saved
421 : : descriptor. */
422 : 0 : if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
423 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
424 : : else
425 : : {
426 : : /* Allow for dummy arguments and other good things. */
427 : 0 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
428 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
429 : :
430 : : /* Check if '_data' is an array descriptor. If it is not,
431 : : the array must be one of the components of the class
432 : : object, so return a null span. */
433 : 0 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
434 : : gfc_class_data_get (decl))))
435 : : return NULL_TREE;
436 : : }
437 : 0 : span = gfc_class_vtab_size_get (decl);
438 : : /* For unlimited polymorphic entities then _len component needs
439 : : to be multiplied with the size. */
440 : 0 : span = gfc_resize_class_size_with_len (NULL, decl, span);
441 : : }
442 : 6439 : else if (GFC_DECL_PTR_ARRAY_P (decl))
443 : : {
444 : 6269 : if (TREE_CODE (decl) == PARM_DECL)
445 : 1652 : decl = build_fold_indirect_ref_loc (input_location, decl);
446 : 6269 : span = gfc_conv_descriptor_span_get (decl);
447 : : }
448 : : else
449 : : span = NULL_TREE;
450 : : }
451 : : else
452 : : span = NULL_TREE;
453 : :
454 : : return span;
455 : : }
456 : :
457 : :
458 : : tree
459 : 23296 : gfc_build_spanned_array_ref (tree base, tree offset, tree span)
460 : : {
461 : 23296 : tree type;
462 : 23296 : tree tmp;
463 : 23296 : type = TREE_TYPE (TREE_TYPE (base));
464 : 23296 : offset = fold_build2_loc (input_location, MULT_EXPR,
465 : : gfc_array_index_type,
466 : : offset, span);
467 : 23296 : tmp = gfc_build_addr_expr (pvoid_type_node, base);
468 : 23296 : tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
469 : 23296 : tmp = fold_convert (build_pointer_type (type), tmp);
470 : 19012 : if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
471 : 31719 : || !TYPE_STRING_FLAG (type))
472 : 14873 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
473 : 23296 : return tmp;
474 : : }
475 : :
476 : :
477 : : /* Build an ARRAY_REF with its natural type.
478 : : NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative,
479 : : and thus that an ARRAY_REF can safely be generated. If it’s false, we
480 : : have to play it safe and use pointer arithmetic. */
481 : :
482 : : tree
483 : 1121772 : gfc_build_array_ref (tree base, tree offset, tree decl,
484 : : bool non_negative_offset, tree vptr)
485 : : {
486 : 1121772 : tree type = TREE_TYPE (base);
487 : 1121772 : tree span = NULL_TREE;
488 : :
489 : 1121772 : if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
490 : : {
491 : 70 : gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
492 : :
493 : 70 : return fold_convert (TYPE_MAIN_VARIANT (type), base);
494 : : }
495 : :
496 : : /* Scalar coarray, there is nothing to do. */
497 : 1121702 : if (TREE_CODE (type) != ARRAY_TYPE)
498 : : {
499 : 4 : gcc_assert (decl == NULL_TREE);
500 : 4 : gcc_assert (integer_zerop (offset));
501 : : return base;
502 : : }
503 : :
504 : 1121698 : type = TREE_TYPE (type);
505 : :
506 : 1121698 : if (DECL_P (base))
507 : 170949 : TREE_ADDRESSABLE (base) = 1;
508 : :
509 : : /* Strip NON_LVALUE_EXPR nodes. */
510 : 1149099 : STRIP_TYPE_NOPS (offset);
511 : :
512 : : /* If decl or vptr are non-null, pointer arithmetic for the array reference
513 : : is likely. Generate the 'span' for the array reference. */
514 : 1121698 : if (vptr)
515 : : {
516 : 2940 : span = gfc_vptr_size_get (vptr);
517 : :
518 : : /* Check if this is an unlimited polymorphic object carrying a character
519 : : payload. In this case, the 'len' field is non-zero. */
520 : 2940 : if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
521 : 68 : span = gfc_resize_class_size_with_len (NULL, decl, span);
522 : : }
523 : 1118758 : else if (decl)
524 : 17480 : span = get_array_span (type, decl);
525 : :
526 : : /* If a non-null span has been generated reference the element with
527 : : pointer arithmetic. */
528 : 20420 : if (span != NULL_TREE)
529 : 20250 : return gfc_build_spanned_array_ref (base, offset, span);
530 : : /* Else use a straightforward array reference if possible. */
531 : 1101448 : else if (non_negative_offset)
532 : 1058557 : return build4_loc (input_location, ARRAY_REF, type, base, offset,
533 : 1058557 : NULL_TREE, NULL_TREE);
534 : : /* Otherwise use pointer arithmetic. */
535 : : else
536 : : {
537 : 42891 : gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
538 : 42891 : tree min = NULL_TREE;
539 : 42891 : if (TYPE_DOMAIN (TREE_TYPE (base))
540 : 42891 : && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)))))
541 : 299 : min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)));
542 : :
543 : 299 : tree zero_based_index
544 : 299 : = min ? fold_build2_loc (input_location, MINUS_EXPR,
545 : : gfc_array_index_type,
546 : : fold_convert (gfc_array_index_type, offset),
547 : : fold_convert (gfc_array_index_type, min))
548 : 42592 : : fold_convert (gfc_array_index_type, offset);
549 : :
550 : 42891 : tree elt_size = fold_convert (gfc_array_index_type,
551 : : TYPE_SIZE_UNIT (type));
552 : :
553 : 42891 : tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR,
554 : : gfc_array_index_type,
555 : : zero_based_index, elt_size);
556 : :
557 : 42891 : tree base_addr = gfc_build_addr_expr (pvoid_type_node, base);
558 : :
559 : 42891 : tree ptr = fold_build_pointer_plus_loc (input_location, base_addr,
560 : : offset_bytes);
561 : 42891 : return build1_loc (input_location, INDIRECT_REF, type,
562 : 42891 : fold_convert (build_pointer_type (type), ptr));
563 : : }
564 : : }
565 : :
566 : :
567 : : /* Generate a call to print a runtime error possibly including multiple
568 : : arguments and a locus. */
569 : :
570 : : static tree
571 : 73572 : trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid,
572 : : va_list ap)
573 : : {
574 : 73572 : stmtblock_t block;
575 : 73572 : tree tmp;
576 : 73572 : tree arg, arg2;
577 : 73572 : tree *argarray;
578 : 73572 : tree fntype;
579 : 73572 : char *message;
580 : 73572 : const char *p;
581 : 73572 : int line, nargs, i;
582 : 73572 : location_t loc;
583 : :
584 : : /* Compute the number of extra arguments from the format string. */
585 : 3962977 : for (p = msgid, nargs = 0; *p; p++)
586 : 3889405 : if (*p == '%')
587 : : {
588 : 108371 : p++;
589 : 108371 : if (*p != '%')
590 : 108019 : nargs++;
591 : : }
592 : :
593 : : /* The code to generate the error. */
594 : 73572 : gfc_start_block (&block);
595 : :
596 : 73572 : if (where)
597 : : {
598 : 57107 : line = LOCATION_LINE (where->lb->location);
599 : 57107 : message = xasprintf ("At line %d of file %s", line,
600 : 57107 : where->lb->file->filename);
601 : : }
602 : : else
603 : 49395 : message = xasprintf ("In file '%s', around line %d",
604 : 16465 : gfc_source_file, LOCATION_LINE (input_location) + 1);
605 : :
606 : 73572 : arg = gfc_build_addr_expr (pchar_type_node,
607 : : gfc_build_localized_cstring_const (message));
608 : 73572 : free (message);
609 : :
610 : 73572 : message = xasprintf ("%s", _(msgid));
611 : 73572 : arg2 = gfc_build_addr_expr (pchar_type_node,
612 : : gfc_build_localized_cstring_const (message));
613 : 73572 : free (message);
614 : :
615 : : /* Build the argument array. */
616 : 73572 : argarray = XALLOCAVEC (tree, nargs + 2);
617 : 73572 : argarray[0] = arg;
618 : 73572 : argarray[1] = arg2;
619 : 181591 : for (i = 0; i < nargs; i++)
620 : 108019 : argarray[2 + i] = va_arg (ap, tree);
621 : :
622 : : /* Build the function call to runtime_(warning,error)_at; because of the
623 : : variable number of arguments, we can't use build_call_expr_loc dinput_location,
624 : : irectly. */
625 : 73572 : fntype = TREE_TYPE (errorfunc);
626 : :
627 : 73572 : loc = where ? gfc_get_location (where) : input_location;
628 : 73572 : tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
629 : : fold_build1_loc (loc, ADDR_EXPR,
630 : : build_pointer_type (fntype),
631 : : errorfunc),
632 : : nargs + 2, argarray);
633 : 73572 : gfc_add_expr_to_block (&block, tmp);
634 : :
635 : 73572 : return gfc_finish_block (&block);
636 : : }
637 : :
638 : :
639 : : tree
640 : 20426 : gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
641 : : {
642 : 20426 : va_list ap;
643 : 20426 : tree result;
644 : :
645 : 20426 : va_start (ap, msgid);
646 : 20426 : result = trans_runtime_error_vararg (error
647 : : ? gfor_fndecl_runtime_error_at
648 : : : gfor_fndecl_runtime_warning_at,
649 : : where, msgid, ap);
650 : 20426 : va_end (ap);
651 : 20426 : return result;
652 : : }
653 : :
654 : :
655 : : /* Generate a runtime error if COND is true. */
656 : :
657 : : void
658 : 161060 : gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
659 : : locus * where, const char * msgid, ...)
660 : : {
661 : 161060 : va_list ap;
662 : 161060 : stmtblock_t block;
663 : 161060 : tree body;
664 : 161060 : tree tmp;
665 : 161060 : tree tmpvar = NULL;
666 : :
667 : 161060 : if (integer_zerop (cond))
668 : 124349 : return;
669 : :
670 : 36711 : if (once)
671 : : {
672 : 888 : tmpvar = gfc_create_var (boolean_type_node, "print_warning");
673 : 888 : TREE_STATIC (tmpvar) = 1;
674 : 888 : DECL_INITIAL (tmpvar) = boolean_true_node;
675 : 888 : gfc_add_expr_to_block (pblock, tmpvar);
676 : : }
677 : :
678 : 36711 : gfc_start_block (&block);
679 : :
680 : : /* For error, runtime_error_at already implies PRED_NORETURN. */
681 : 36711 : if (!error && once)
682 : 888 : gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
683 : : NOT_TAKEN));
684 : :
685 : : /* The code to generate the error. */
686 : 36711 : va_start (ap, msgid);
687 : 36711 : gfc_add_expr_to_block (&block,
688 : : trans_runtime_error_vararg
689 : : (error ? gfor_fndecl_runtime_error_at
690 : : : gfor_fndecl_runtime_warning_at,
691 : : where, msgid, ap));
692 : 36711 : va_end (ap);
693 : :
694 : 36711 : if (once)
695 : 888 : gfc_add_modify (&block, tmpvar, boolean_false_node);
696 : :
697 : 36711 : body = gfc_finish_block (&block);
698 : :
699 : 36711 : if (integer_onep (cond))
700 : : {
701 : 892 : gfc_add_expr_to_block (pblock, body);
702 : : }
703 : : else
704 : : {
705 : 35819 : if (once)
706 : 20 : cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
707 : : boolean_type_node, tmpvar,
708 : : fold_convert (boolean_type_node, cond));
709 : :
710 : 35819 : tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
711 : : cond, body,
712 : : build_empty_stmt (gfc_get_location (where)));
713 : 35819 : gfc_add_expr_to_block (pblock, tmp);
714 : : }
715 : : }
716 : :
717 : :
718 : : static tree
719 : 16435 : trans_os_error_at (locus* where, const char* msgid, ...)
720 : : {
721 : 16435 : va_list ap;
722 : 16435 : tree result;
723 : :
724 : 16435 : va_start (ap, msgid);
725 : 16435 : result = trans_runtime_error_vararg (gfor_fndecl_os_error_at,
726 : : where, msgid, ap);
727 : 16435 : va_end (ap);
728 : 16435 : return result;
729 : : }
730 : :
731 : :
732 : :
733 : : /* Call malloc to allocate size bytes of memory, with special conditions:
734 : : + if size == 0, return a malloced area of size 1,
735 : : + if malloc returns NULL, issue a runtime error. */
736 : : tree
737 : 18060 : gfc_call_malloc (stmtblock_t * block, tree type, tree size)
738 : : {
739 : 18060 : tree tmp, malloc_result, null_result, res, malloc_tree;
740 : 18060 : stmtblock_t block2;
741 : :
742 : : /* Create a variable to hold the result. */
743 : 18060 : res = gfc_create_var (prvoid_type_node, NULL);
744 : :
745 : : /* Call malloc. */
746 : 18060 : gfc_start_block (&block2);
747 : :
748 : 18060 : if (size == NULL_TREE)
749 : 1 : size = build_int_cst (size_type_node, 1);
750 : :
751 : 18060 : size = fold_convert (size_type_node, size);
752 : 18060 : size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
753 : 18060 : build_int_cst (size_type_node, 1));
754 : :
755 : 18060 : malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
756 : 18060 : gfc_add_modify (&block2, res,
757 : : fold_convert (prvoid_type_node,
758 : : build_call_expr_loc (input_location,
759 : : malloc_tree, 1, size)));
760 : :
761 : : /* Optionally check whether malloc was successful. */
762 : 18060 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
763 : : {
764 : 105 : null_result = fold_build2_loc (input_location, EQ_EXPR,
765 : : logical_type_node, res,
766 : 105 : build_int_cst (pvoid_type_node, 0));
767 : 105 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
768 : : null_result,
769 : : trans_os_error_at (NULL,
770 : : "Error allocating %lu bytes",
771 : : fold_convert
772 : : (long_unsigned_type_node,
773 : : size)),
774 : : build_empty_stmt (input_location));
775 : 105 : gfc_add_expr_to_block (&block2, tmp);
776 : : }
777 : :
778 : 18060 : malloc_result = gfc_finish_block (&block2);
779 : 18060 : gfc_add_expr_to_block (block, malloc_result);
780 : :
781 : 18060 : if (type != NULL)
782 : 13743 : res = fold_convert (type, res);
783 : 18060 : return res;
784 : : }
785 : :
786 : :
787 : : /* Allocate memory, using an optional status argument.
788 : :
789 : : This function follows the following pseudo-code:
790 : :
791 : : void *
792 : : allocate (size_t size, integer_type stat)
793 : : {
794 : : void *newmem;
795 : :
796 : : if (stat requested)
797 : : stat = 0;
798 : :
799 : : // if cond == NULL_NULL:
800 : : newmem = malloc (MAX (size, 1));
801 : : // otherwise:
802 : : newmem = <cond> ? <alt_alloc> : malloc (MAX (size, 1))
803 : : if (newmem == NULL)
804 : : {
805 : : if (stat)
806 : : *stat = LIBERROR_NO_MEMORY;
807 : : else
808 : : runtime_error ("Allocation would exceed memory limit");
809 : : }
810 : : return newmem;
811 : : } */
812 : : void
813 : 15520 : gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
814 : : tree size, tree status, tree cond, tree alt_alloc,
815 : : tree extra_success_expr)
816 : : {
817 : 15520 : tree tmp, error_cond;
818 : 15520 : stmtblock_t on_error;
819 : 15520 : tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
820 : :
821 : : /* If successful and stat= is given, set status to 0. */
822 : 267 : if (status != NULL_TREE)
823 : 267 : gfc_add_expr_to_block (block,
824 : : fold_build2_loc (input_location, MODIFY_EXPR, status_type,
825 : 267 : status, build_int_cst (status_type, 0)));
826 : :
827 : : /* The allocation itself. */
828 : 15520 : size = fold_convert (size_type_node, size);
829 : 15520 : tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
830 : 15520 : size, build_int_cst (size_type_node, 1));
831 : :
832 : 15520 : tmp = build_call_expr_loc (input_location,
833 : : builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp);
834 : 15520 : if (cond == boolean_true_node)
835 : : tmp = alt_alloc;
836 : 15462 : else if (cond)
837 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
838 : : alt_alloc, tmp);
839 : :
840 : 15520 : gfc_add_modify (block, pointer, fold_convert (TREE_TYPE (pointer), tmp));
841 : :
842 : : /* What to do in case of error. */
843 : 15520 : gfc_start_block (&on_error);
844 : 15520 : if (status != NULL_TREE)
845 : : {
846 : 267 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
847 : 267 : build_int_cst (status_type, LIBERROR_NO_MEMORY));
848 : 267 : gfc_add_expr_to_block (&on_error, tmp);
849 : : }
850 : : else
851 : : {
852 : : /* Here, os_error_at already implies PRED_NORETURN. */
853 : 15253 : tree lusize = fold_convert (long_unsigned_type_node, size);
854 : 15253 : tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize);
855 : 15253 : gfc_add_expr_to_block (&on_error, tmp);
856 : : }
857 : :
858 : 15520 : error_cond = fold_build2_loc (input_location, EQ_EXPR,
859 : : logical_type_node, pointer,
860 : 15520 : build_int_cst (prvoid_type_node, 0));
861 : 30982 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
862 : : gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
863 : : gfc_finish_block (&on_error),
864 : : extra_success_expr
865 : : ? extra_success_expr
866 : 15462 : : build_empty_stmt (input_location));
867 : :
868 : 15520 : gfc_add_expr_to_block (block, tmp);
869 : 15520 : }
870 : :
871 : :
872 : : /* Allocate memory, using an optional status argument.
873 : :
874 : : This function follows the following pseudo-code:
875 : :
876 : : void *
877 : : allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
878 : : {
879 : : void *newmem;
880 : :
881 : : newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
882 : : return newmem;
883 : : } */
884 : : void
885 : 611 : gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
886 : : tree token, tree status, tree errmsg, tree errlen,
887 : : gfc_coarray_regtype alloc_type)
888 : : {
889 : 611 : tree tmp, pstat;
890 : :
891 : 611 : gcc_assert (token != NULL_TREE);
892 : :
893 : : /* The allocation itself. */
894 : 611 : if (status == NULL_TREE)
895 : 599 : pstat = null_pointer_node;
896 : : else
897 : 12 : pstat = gfc_build_addr_expr (NULL_TREE, status);
898 : :
899 : 611 : if (errmsg == NULL_TREE)
900 : : {
901 : 599 : gcc_assert(errlen == NULL_TREE);
902 : 599 : errmsg = null_pointer_node;
903 : 599 : errlen = integer_zero_node;
904 : : }
905 : :
906 : 611 : size = fold_convert (size_type_node, size);
907 : 611 : tmp = build_call_expr_loc (input_location,
908 : : gfor_fndecl_caf_register, 7,
909 : : fold_build2_loc (input_location,
910 : : MAX_EXPR, size_type_node, size, size_one_node),
911 : : build_int_cst (integer_type_node, alloc_type),
912 : : token, gfc_build_addr_expr (pvoid_type_node, pointer),
913 : : pstat, errmsg, errlen);
914 : :
915 : 611 : gfc_add_expr_to_block (block, tmp);
916 : :
917 : : /* It guarantees memory consistency within the same segment */
918 : 611 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
919 : 611 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
920 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
921 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
922 : 611 : ASM_VOLATILE_P (tmp) = 1;
923 : 611 : gfc_add_expr_to_block (block, tmp);
924 : 611 : }
925 : :
926 : :
927 : : /* Generate code for an ALLOCATE statement when the argument is an
928 : : allocatable variable. If the variable is currently allocated, it is an
929 : : error to allocate it again.
930 : :
931 : : This function follows the following pseudo-code:
932 : :
933 : : void *
934 : : allocate_allocatable (void *mem, size_t size, integer_type stat)
935 : : {
936 : : if (mem == NULL)
937 : : return allocate (size, stat);
938 : : else
939 : : {
940 : : if (stat)
941 : : stat = LIBERROR_ALLOCATION;
942 : : else
943 : : runtime_error ("Attempting to allocate already allocated variable");
944 : : }
945 : : }
946 : :
947 : : expr must be set to the original expression being allocated for its locus
948 : : and variable name in case a runtime error has to be printed. */
949 : : void
950 : 11299 : gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
951 : : tree token, tree status, tree errmsg, tree errlen,
952 : : tree label_finish, gfc_expr* expr, int corank,
953 : : tree cond, tree alt_alloc, tree extra_success_expr)
954 : : {
955 : 11299 : stmtblock_t alloc_block;
956 : 11299 : tree tmp, null_mem, alloc, error;
957 : 11299 : tree type = TREE_TYPE (mem);
958 : 11299 : symbol_attribute caf_attr;
959 : 11299 : bool need_assign = false, refs_comp = false;
960 : 11299 : gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
961 : :
962 : 11299 : size = fold_convert (size_type_node, size);
963 : 11299 : null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
964 : : logical_type_node, mem,
965 : 11299 : build_int_cst (type, 0)),
966 : : PRED_FORTRAN_REALLOC);
967 : :
968 : : /* If mem is NULL, we call gfc_allocate_using_malloc or
969 : : gfc_allocate_using_lib. */
970 : 11299 : gfc_start_block (&alloc_block);
971 : :
972 : 11299 : if (flag_coarray == GFC_FCOARRAY_LIB)
973 : 352 : caf_attr = gfc_caf_attr (expr, true, &refs_comp);
974 : :
975 : 11299 : if (flag_coarray == GFC_FCOARRAY_LIB
976 : 352 : && (corank > 0 || caf_attr.codimension))
977 : : {
978 : 320 : tree cond2, sub_caf_tree;
979 : 320 : gfc_se se;
980 : 320 : bool compute_special_caf_types_size = false;
981 : :
982 : 320 : if (expr->ts.type == BT_DERIVED
983 : 90 : && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
984 : 90 : && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
985 : : {
986 : : compute_special_caf_types_size = true;
987 : : caf_alloc_type = GFC_CAF_LOCK_ALLOC;
988 : : }
989 : 316 : else if (expr->ts.type == BT_DERIVED
990 : 86 : && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
991 : 86 : && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
992 : : {
993 : : compute_special_caf_types_size = true;
994 : : caf_alloc_type = GFC_CAF_EVENT_ALLOC;
995 : : }
996 : 315 : else if (!caf_attr.coarray_comp && refs_comp)
997 : : /* Only allocatable components in a derived type coarray can be
998 : : allocate only. */
999 : 320 : caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
1000 : :
1001 : 320 : gfc_init_se (&se, NULL);
1002 : 320 : sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
1003 : 320 : if (sub_caf_tree == NULL_TREE)
1004 : 123 : sub_caf_tree = token;
1005 : :
1006 : : /* When mem is an array ref, then strip the .data-ref. */
1007 : 320 : if (TREE_CODE (mem) == COMPONENT_REF
1008 : 320 : && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
1009 : 320 : tmp = TREE_OPERAND (mem, 0);
1010 : : else
1011 : : tmp = mem;
1012 : :
1013 : 320 : if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
1014 : 47 : && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
1015 : 367 : && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1016 : : {
1017 : 105 : symbol_attribute attr;
1018 : :
1019 : 105 : gfc_clear_attr (&attr);
1020 : 105 : tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
1021 : 105 : need_assign = true;
1022 : : }
1023 : 320 : gfc_add_block_to_block (&alloc_block, &se.pre);
1024 : :
1025 : : /* In the front end, we represent the lock variable as pointer. However,
1026 : : the FE only passes the pointer around and leaves the actual
1027 : : representation to the library. Hence, we have to convert back to the
1028 : : number of elements. */
1029 : 320 : if (compute_special_caf_types_size)
1030 : 5 : size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
1031 : 5 : size, TYPE_SIZE_UNIT (ptr_type_node));
1032 : :
1033 : 320 : gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
1034 : : status, errmsg, errlen, caf_alloc_type);
1035 : 320 : if (need_assign)
1036 : 105 : gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
1037 : : gfc_conv_descriptor_data_get (tmp)));
1038 : 320 : if (status != NULL_TREE)
1039 : : {
1040 : 12 : TREE_USED (label_finish) = 1;
1041 : 12 : tmp = build1_v (GOTO_EXPR, label_finish);
1042 : 12 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1043 : 12 : status, build_zero_cst (TREE_TYPE (status)));
1044 : 12 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1045 : : gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1046 : : tmp, build_empty_stmt (input_location));
1047 : 12 : gfc_add_expr_to_block (&alloc_block, tmp);
1048 : : }
1049 : 320 : }
1050 : : else
1051 : 10979 : gfc_allocate_using_malloc (&alloc_block, mem, size, status,
1052 : : cond, alt_alloc, extra_success_expr);
1053 : :
1054 : 11299 : alloc = gfc_finish_block (&alloc_block);
1055 : :
1056 : : /* If mem is not NULL, we issue a runtime error or set the
1057 : : status variable. */
1058 : 11299 : if (expr)
1059 : : {
1060 : 11299 : tree varname;
1061 : :
1062 : 11299 : gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
1063 : 11299 : varname = gfc_build_cstring_const (expr->symtree->name);
1064 : 11299 : varname = gfc_build_addr_expr (pchar_type_node, varname);
1065 : :
1066 : 11299 : error = gfc_trans_runtime_error (true, &expr->where,
1067 : : "Attempting to allocate already"
1068 : : " allocated variable '%s'",
1069 : : varname);
1070 : : }
1071 : : else
1072 : 0 : error = gfc_trans_runtime_error (true, NULL,
1073 : : "Attempting to allocate already allocated"
1074 : : " variable");
1075 : :
1076 : 11299 : if (status != NULL_TREE)
1077 : : {
1078 : 252 : tree status_type = TREE_TYPE (status);
1079 : :
1080 : 252 : error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1081 : 252 : status, build_int_cst (status_type, LIBERROR_ALLOCATION));
1082 : : }
1083 : :
1084 : 11299 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
1085 : : error, alloc);
1086 : 11299 : gfc_add_expr_to_block (block, tmp);
1087 : 11299 : }
1088 : :
1089 : :
1090 : : /* Free a given variable. */
1091 : :
1092 : : tree
1093 : 19064 : gfc_call_free (tree var)
1094 : : {
1095 : 19064 : return build_call_expr_loc (input_location,
1096 : : builtin_decl_explicit (BUILT_IN_FREE),
1097 : 19064 : 1, fold_convert (pvoid_type_node, var));
1098 : : }
1099 : :
1100 : :
1101 : : /* Generate the data reference to the finalization procedure pointer associated
1102 : : with the expression passed as argument in EXPR. */
1103 : :
1104 : : static void
1105 : 3906 : get_final_proc_ref (gfc_se *se, gfc_expr *expr, tree class_container)
1106 : : {
1107 : 3906 : gfc_expr *final_wrapper = NULL;
1108 : :
1109 : 3906 : gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1110 : :
1111 : 3906 : bool using_class_container = false;
1112 : 3906 : if (expr->ts.type == BT_DERIVED)
1113 : 669 : gfc_is_finalizable (expr->ts.u.derived, &final_wrapper);
1114 : 3237 : else if (class_container)
1115 : : {
1116 : 266 : using_class_container = true;
1117 : 266 : se->expr = gfc_class_vtab_final_get (class_container);
1118 : : }
1119 : : else
1120 : : {
1121 : 2971 : final_wrapper = gfc_copy_expr (expr);
1122 : 2971 : gfc_add_vptr_component (final_wrapper);
1123 : 2971 : gfc_add_final_component (final_wrapper);
1124 : : }
1125 : :
1126 : 3906 : if (!using_class_container)
1127 : : {
1128 : 3640 : gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
1129 : :
1130 : 3640 : gfc_conv_expr (se, final_wrapper);
1131 : : }
1132 : :
1133 : 3906 : if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
1134 : 935 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1135 : 3906 : }
1136 : :
1137 : :
1138 : : /* Generate the code to obtain the value of the element size of the expression
1139 : : passed as argument in EXPR. */
1140 : :
1141 : : static void
1142 : 3906 : get_elem_size (gfc_se *se, gfc_expr *expr, tree class_container)
1143 : : {
1144 : 3906 : gcc_assert (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS);
1145 : :
1146 : 3906 : if (expr->ts.type == BT_DERIVED)
1147 : : {
1148 : 669 : se->expr = gfc_typenode_for_spec (&expr->ts);
1149 : 669 : se->expr = TYPE_SIZE_UNIT (se->expr);
1150 : 669 : se->expr = fold_convert (gfc_array_index_type, se->expr);
1151 : : }
1152 : 3237 : else if (class_container)
1153 : 266 : se->expr = gfc_class_vtab_size_get (class_container);
1154 : : else
1155 : : {
1156 : 2971 : gfc_expr *class_size = gfc_copy_expr (expr);
1157 : 2971 : gfc_add_vptr_component (class_size);
1158 : 2971 : gfc_add_size_component (class_size);
1159 : :
1160 : 2971 : gfc_conv_expr (se, class_size);
1161 : 2971 : gcc_assert (se->post.head == NULL_TREE);
1162 : : }
1163 : 3906 : }
1164 : :
1165 : :
1166 : : /* Generate the data reference (array) descriptor corresponding to the
1167 : : expression passed as argument in VAR. */
1168 : :
1169 : : static void
1170 : 3906 : get_var_descr (gfc_se *se, gfc_expr *var, tree class_container)
1171 : : {
1172 : 3906 : gfc_se tmp_se;
1173 : :
1174 : 3906 : gcc_assert (var);
1175 : :
1176 : 3906 : gfc_init_se (&tmp_se, NULL);
1177 : :
1178 : 3906 : if (var->ts.type == BT_DERIVED)
1179 : : {
1180 : 669 : tmp_se.want_pointer = 1;
1181 : 669 : if (var->rank)
1182 : : {
1183 : 164 : tmp_se.descriptor_only = 1;
1184 : 164 : gfc_conv_expr_descriptor (&tmp_se, var);
1185 : : }
1186 : : else
1187 : 505 : gfc_conv_expr (&tmp_se, var);
1188 : : }
1189 : 3237 : else if (class_container)
1190 : 266 : tmp_se.expr = gfc_class_data_get (class_container);
1191 : : else
1192 : : {
1193 : 2971 : gfc_expr *array_expr;
1194 : :
1195 : 2971 : array_expr = gfc_copy_expr (var);
1196 : :
1197 : 2971 : tmp_se.want_pointer = 1;
1198 : 2971 : if (array_expr->rank)
1199 : : {
1200 : 1457 : gfc_add_class_array_ref (array_expr);
1201 : 1457 : tmp_se.descriptor_only = 1;
1202 : 1457 : gfc_conv_expr_descriptor (&tmp_se, array_expr);
1203 : : }
1204 : : else
1205 : : {
1206 : 1514 : gfc_add_data_component (array_expr);
1207 : 1514 : gfc_conv_expr (&tmp_se, array_expr);
1208 : 1514 : gcc_assert (tmp_se.post.head == NULL_TREE);
1209 : : }
1210 : 2971 : gfc_free_expr (array_expr);
1211 : : }
1212 : :
1213 : 3906 : if (var->rank == 0)
1214 : : {
1215 : 2175 : if (var->ts.type == BT_DERIVED
1216 : 2175 : || !gfc_is_coarray (var))
1217 : : {
1218 : : /* No copy back needed, hence set attr's allocatable/pointer
1219 : : to zero. */
1220 : 2135 : symbol_attribute attr;
1221 : 2135 : gfc_clear_attr (&attr);
1222 : 2135 : tmp_se.expr = gfc_conv_scalar_to_descriptor (&tmp_se, tmp_se.expr,
1223 : : attr);
1224 : : }
1225 : 2175 : gcc_assert (tmp_se.post.head == NULL_TREE);
1226 : : }
1227 : :
1228 : 3906 : if (!POINTER_TYPE_P (TREE_TYPE (tmp_se.expr)))
1229 : 2245 : tmp_se.expr = gfc_build_addr_expr (NULL, tmp_se.expr);
1230 : :
1231 : 3906 : gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1232 : 3906 : gfc_add_block_to_block (&se->post, &tmp_se.post);
1233 : 3906 : se->expr = tmp_se.expr;
1234 : 3906 : }
1235 : :
1236 : :
1237 : : static void
1238 : 689 : get_vptr (gfc_se *se, gfc_expr *expr, tree class_container)
1239 : : {
1240 : 689 : if (class_container)
1241 : 42 : se->expr = gfc_class_vptr_get (class_container);
1242 : : else
1243 : : {
1244 : 647 : gfc_expr *vptr_expr = gfc_copy_expr (expr);
1245 : 647 : gfc_add_vptr_component (vptr_expr);
1246 : :
1247 : 647 : gfc_se tmp_se;
1248 : 647 : gfc_init_se (&tmp_se, NULL);
1249 : 647 : tmp_se.want_pointer = 1;
1250 : 647 : gfc_conv_expr (&tmp_se, vptr_expr);
1251 : 647 : gfc_free_expr (vptr_expr);
1252 : :
1253 : 647 : gfc_add_block_to_block (&se->pre, &tmp_se.pre);
1254 : 647 : gfc_add_block_to_block (&se->post, &tmp_se.post);
1255 : 647 : se->expr = tmp_se.expr;
1256 : : }
1257 : 689 : }
1258 : :
1259 : :
1260 : : bool
1261 : 2475 : gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
1262 : : bool fini_coarray)
1263 : : {
1264 : 2475 : gfc_se se;
1265 : 2475 : stmtblock_t block2;
1266 : 2475 : tree final_fndecl, size, array, tmp, cond;
1267 : 2475 : symbol_attribute attr;
1268 : 2475 : gfc_expr *final_expr = NULL;
1269 : :
1270 : 2475 : if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
1271 : : return false;
1272 : :
1273 : 2475 : gfc_init_block (&block2);
1274 : :
1275 : 2475 : if (comp->ts.type == BT_DERIVED)
1276 : : {
1277 : 1683 : if (comp->attr.pointer)
1278 : : return false;
1279 : :
1280 : 1683 : gfc_is_finalizable (comp->ts.u.derived, &final_expr);
1281 : 1683 : if (!final_expr)
1282 : : return false;
1283 : :
1284 : 27 : gfc_init_se (&se, NULL);
1285 : 27 : gfc_conv_expr (&se, final_expr);
1286 : 27 : final_fndecl = se.expr;
1287 : 27 : size = gfc_typenode_for_spec (&comp->ts);
1288 : 27 : size = TYPE_SIZE_UNIT (size);
1289 : 27 : size = fold_convert (gfc_array_index_type, size);
1290 : :
1291 : 27 : array = decl;
1292 : : }
1293 : : else /* comp->ts.type == BT_CLASS. */
1294 : : {
1295 : 792 : if (CLASS_DATA (comp)->attr.class_pointer)
1296 : : return false;
1297 : :
1298 : 792 : gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1299 : 792 : final_fndecl = gfc_class_vtab_final_get (decl);
1300 : 792 : size = gfc_class_vtab_size_get (decl);
1301 : 792 : array = gfc_class_data_get (decl);
1302 : : }
1303 : :
1304 : 819 : if (comp->attr.allocatable
1305 : 792 : || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1306 : : {
1307 : 819 : tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1308 : 819 : ? gfc_conv_descriptor_data_get (array) : array;
1309 : 819 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1310 : 819 : tmp, fold_convert (TREE_TYPE (tmp),
1311 : : null_pointer_node));
1312 : : }
1313 : : else
1314 : 0 : cond = logical_true_node;
1315 : :
1316 : 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1317 : : {
1318 : 441 : gfc_clear_attr (&attr);
1319 : 441 : gfc_init_se (&se, NULL);
1320 : 441 : array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1321 : 441 : gfc_add_block_to_block (&block2, &se.pre);
1322 : 441 : gcc_assert (se.post.head == NULL_TREE);
1323 : : }
1324 : :
1325 : 819 : if (!POINTER_TYPE_P (TREE_TYPE (array)))
1326 : 819 : array = gfc_build_addr_expr (NULL, array);
1327 : :
1328 : 819 : if (!final_expr)
1329 : : {
1330 : 790 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1331 : : final_fndecl,
1332 : 790 : fold_convert (TREE_TYPE (final_fndecl),
1333 : : null_pointer_node));
1334 : 790 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1335 : : logical_type_node, cond, tmp);
1336 : : }
1337 : :
1338 : 819 : if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1339 : 819 : final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1340 : :
1341 : 819 : tmp = build_call_expr_loc (input_location,
1342 : : final_fndecl, 3, array,
1343 : : size, fini_coarray ? boolean_true_node
1344 : : : boolean_false_node);
1345 : 819 : gfc_add_expr_to_block (&block2, tmp);
1346 : 819 : tmp = gfc_finish_block (&block2);
1347 : :
1348 : 819 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1349 : : build_empty_stmt (input_location));
1350 : 819 : gfc_add_expr_to_block (block, tmp);
1351 : :
1352 : 819 : return true;
1353 : : }
1354 : :
1355 : :
1356 : : /* Add a call to the finalizer, using the passed *expr. Returns
1357 : : true when a finalizer call has been inserted. */
1358 : :
1359 : : bool
1360 : 20958 : gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2,
1361 : : tree class_container)
1362 : : {
1363 : 20958 : tree tmp;
1364 : 20958 : gfc_ref *ref;
1365 : 20958 : gfc_expr *expr;
1366 : :
1367 : 20958 : if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1368 : : return false;
1369 : :
1370 : : /* Finalization of these temporaries is made by explicit calls in
1371 : : resolve.cc(generate_component_assignments). */
1372 : 5439 : if (expr2->expr_type == EXPR_VARIABLE
1373 : 5439 : && expr2->symtree->n.sym->name[0] == '_'
1374 : 78 : && expr2->ts.type == BT_DERIVED
1375 : 24 : && expr2->ts.u.derived->attr.defined_assign_comp)
1376 : : return false;
1377 : :
1378 : 5421 : if (expr2->ts.type == BT_DERIVED
1379 : 5421 : && !gfc_is_finalizable (expr2->ts.u.derived, NULL))
1380 : : return false;
1381 : :
1382 : : /* If we have a class array, we need go back to the class
1383 : : container. */
1384 : 3906 : expr = gfc_copy_expr (expr2);
1385 : :
1386 : 3906 : if (expr->ref && expr->ref->next && !expr->ref->next->next
1387 : 793 : && expr->ref->next->type == REF_ARRAY
1388 : 744 : && expr->ref->type == REF_COMPONENT
1389 : 744 : && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1390 : : {
1391 : 743 : gfc_free_ref_list (expr->ref);
1392 : 743 : expr->ref = NULL;
1393 : : }
1394 : : else
1395 : 4647 : for (ref = expr->ref; ref; ref = ref->next)
1396 : 1484 : if (ref->next && ref->next->next && !ref->next->next->next
1397 : 298 : && ref->next->next->type == REF_ARRAY
1398 : 285 : && ref->next->type == REF_COMPONENT
1399 : 285 : && strcmp (ref->next->u.c.component->name, "_data") == 0)
1400 : : {
1401 : 285 : gfc_free_ref_list (ref->next);
1402 : 285 : ref->next = NULL;
1403 : : }
1404 : :
1405 : 3906 : if (expr->ts.type == BT_CLASS
1406 : 3237 : && !expr2->rank
1407 : 1670 : && !expr2->ref
1408 : 1358 : && CLASS_DATA (expr2->symtree->n.sym)->as)
1409 : 3 : expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1410 : :
1411 : 3906 : stmtblock_t tmp_block;
1412 : 3906 : gfc_start_block (&tmp_block);
1413 : :
1414 : 3906 : gfc_se final_se;
1415 : 3906 : gfc_init_se (&final_se, NULL);
1416 : 3906 : get_final_proc_ref (&final_se, expr, class_container);
1417 : 3906 : gfc_add_block_to_block (block, &final_se.pre);
1418 : :
1419 : 3906 : gfc_se size_se;
1420 : 3906 : gfc_init_se (&size_se, NULL);
1421 : 3906 : get_elem_size (&size_se, expr, class_container);
1422 : 3906 : gfc_add_block_to_block (&tmp_block, &size_se.pre);
1423 : :
1424 : 3906 : gfc_se desc_se;
1425 : 3906 : gfc_init_se (&desc_se, NULL);
1426 : 3906 : get_var_descr (&desc_se, expr, class_container);
1427 : 3906 : gfc_add_block_to_block (&tmp_block, &desc_se.pre);
1428 : :
1429 : 3906 : tmp = build_call_expr_loc (input_location, final_se.expr, 3,
1430 : : desc_se.expr, size_se.expr,
1431 : : boolean_false_node);
1432 : :
1433 : 3906 : gfc_add_expr_to_block (&tmp_block, tmp);
1434 : :
1435 : 3906 : gfc_add_block_to_block (&tmp_block, &desc_se.post);
1436 : 3906 : gfc_add_block_to_block (&tmp_block, &size_se.post);
1437 : :
1438 : 3906 : tmp = gfc_finish_block (&tmp_block);
1439 : :
1440 : 3906 : if (expr->ts.type == BT_CLASS
1441 : 3906 : && !gfc_is_finalizable (expr->ts.u.derived, NULL))
1442 : : {
1443 : 3237 : tree cond;
1444 : :
1445 : 3237 : tree ptr = gfc_build_addr_expr (NULL_TREE, final_se.expr);
1446 : :
1447 : 3237 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1448 : 3237 : ptr, build_int_cst (TREE_TYPE (ptr), 0));
1449 : :
1450 : : /* For CLASS(*) not only sym->_vtab->_final can be NULL
1451 : : but already sym->_vtab itself. */
1452 : 3237 : if (UNLIMITED_POLY (expr))
1453 : : {
1454 : 689 : tree cond2;
1455 : 689 : gfc_se vptr_se;
1456 : :
1457 : 689 : gfc_init_se (&vptr_se, NULL);
1458 : 689 : get_vptr (&vptr_se, expr, class_container);
1459 : :
1460 : 689 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1461 : : vptr_se.expr,
1462 : 689 : build_int_cst (TREE_TYPE (vptr_se.expr), 0));
1463 : 689 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1464 : : logical_type_node, cond2, cond);
1465 : : }
1466 : :
1467 : 3237 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1468 : : cond, tmp, build_empty_stmt (input_location));
1469 : : }
1470 : :
1471 : 3906 : gfc_add_expr_to_block (block, tmp);
1472 : 3906 : gfc_add_block_to_block (block, &final_se.post);
1473 : :
1474 : 3906 : return true;
1475 : : }
1476 : :
1477 : :
1478 : : /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
1479 : : (10.2.1.3), if the variable is not an unallocated allocatable variable,
1480 : : it is finalized after evaluation of expr and before the definition of
1481 : : the variable. If the variable is an allocated allocatable variable, or
1482 : : has an allocated allocatable subobject, that would be deallocated by
1483 : : intrinsic assignment, the finalization occurs before the deallocation */
1484 : :
1485 : : bool
1486 : 194009 : gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
1487 : : {
1488 : 194009 : symbol_attribute lhs_attr;
1489 : 194009 : tree final_expr;
1490 : 194009 : tree ptr;
1491 : 194009 : tree cond;
1492 : 194009 : gfc_se se;
1493 : 194009 : gfc_symbol *sym = expr1->symtree->n.sym;
1494 : 194009 : gfc_ref *ref = expr1->ref;
1495 : 194009 : stmtblock_t final_block;
1496 : 194009 : gfc_init_block (&final_block);
1497 : 194009 : gfc_expr *finalize_expr;
1498 : 194009 : bool class_array_ref;
1499 : :
1500 : : /* We have to exclude vtable procedures (_copy and _final especially), uses
1501 : : of gfc_trans_assignment_1 in initialization and allocation before trying
1502 : : to build a final call. */
1503 : 194009 : if (!expr1->must_finalize
1504 : 773 : || sym->attr.artificial
1505 : 773 : || sym->ns->proc_name->attr.artificial
1506 : 773 : || init_flag)
1507 : : return false;
1508 : :
1509 : 436 : class_array_ref = ref && ref->type == REF_COMPONENT
1510 : 359 : && !strcmp (ref->u.c.component->name, "_data")
1511 : 309 : && ref->next && ref->next->type == REF_ARRAY
1512 : 1082 : && !ref->next->next;
1513 : :
1514 : 773 : if (class_array_ref)
1515 : : {
1516 : 297 : finalize_expr = gfc_lval_expr_from_sym (sym);
1517 : 297 : finalize_expr->must_finalize = 1;
1518 : 297 : ref = NULL;
1519 : : }
1520 : : else
1521 : 476 : finalize_expr = gfc_copy_expr (expr1);
1522 : :
1523 : : /* F2018 7.5.6.2: Only finalizable entities are finalized. */
1524 : 220 : if (!(expr1->ts.type == BT_DERIVED
1525 : 220 : && gfc_is_finalizable (expr1->ts.u.derived, NULL))
1526 : 773 : && expr1->ts.type != BT_CLASS)
1527 : : return false;
1528 : :
1529 : 773 : if (!gfc_may_be_finalized (sym->ts))
1530 : : return false;
1531 : :
1532 : 735 : gfc_init_block (&final_block);
1533 : 735 : bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
1534 : 735 : gfc_free_expr (finalize_expr);
1535 : :
1536 : 735 : if (!finalizable)
1537 : : return false;
1538 : :
1539 : 735 : lhs_attr = gfc_expr_attr (expr1);
1540 : :
1541 : : /* Check allocatable/pointer is allocated/associated. */
1542 : 735 : if (lhs_attr.allocatable || lhs_attr.pointer)
1543 : : {
1544 : 593 : if (expr1->ts.type == BT_CLASS)
1545 : : {
1546 : 515 : ptr = gfc_get_class_from_gfc_expr (expr1);
1547 : 515 : gcc_assert (ptr != NULL_TREE);
1548 : 515 : ptr = gfc_class_data_get (ptr);
1549 : 515 : if (lhs_attr.dimension)
1550 : 330 : ptr = gfc_conv_descriptor_data_get (ptr);
1551 : : }
1552 : : else
1553 : : {
1554 : 78 : gfc_init_se (&se, NULL);
1555 : 78 : if (expr1->rank)
1556 : : {
1557 : 30 : gfc_conv_expr_descriptor (&se, expr1);
1558 : 30 : ptr = gfc_conv_descriptor_data_get (se.expr);
1559 : : }
1560 : : else
1561 : : {
1562 : 48 : gfc_conv_expr (&se, expr1);
1563 : 48 : ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
1564 : : }
1565 : : }
1566 : :
1567 : 593 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1568 : 593 : ptr, build_zero_cst (TREE_TYPE (ptr)));
1569 : 593 : final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
1570 : : cond, gfc_finish_block (&final_block),
1571 : : build_empty_stmt (input_location));
1572 : : }
1573 : : else
1574 : 142 : final_expr = gfc_finish_block (&final_block);
1575 : :
1576 : : /* Check optional present. */
1577 : 735 : if (sym->attr.optional)
1578 : : {
1579 : 0 : cond = gfc_conv_expr_present (sym);
1580 : 0 : final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
1581 : : cond, final_expr,
1582 : : build_empty_stmt (input_location));
1583 : : }
1584 : :
1585 : 735 : gfc_add_expr_to_block (&lse->finalblock, final_expr);
1586 : :
1587 : 735 : return true;
1588 : : }
1589 : :
1590 : :
1591 : : /* Finalize a TREE expression using the finalizer wrapper. The result is
1592 : : fixed in order to prevent repeated calls. */
1593 : :
1594 : : void
1595 : 507 : gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
1596 : : symbol_attribute attr, int rank)
1597 : : {
1598 : 507 : tree vptr, final_fndecl, desc, tmp, size, is_final;
1599 : 507 : tree data_ptr, data_null, cond;
1600 : 507 : gfc_symbol *vtab;
1601 : 507 : gfc_se post_se;
1602 : 507 : bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
1603 : :
1604 : 507 : if (attr.pointer)
1605 : 52 : return;
1606 : :
1607 : : /* Derived type function results with components that have defined
1608 : : assignements are handled in resolve.cc(generate_component_assignments) */
1609 : 504 : if (derived && (derived->attr.is_c_interop
1610 : : || derived->attr.is_iso_c
1611 : 205 : || derived->attr.is_bind_c
1612 : 205 : || derived->attr.defined_assign_comp))
1613 : : return;
1614 : :
1615 : 498 : if (is_class)
1616 : : {
1617 : 280 : if (!VAR_P (se->expr))
1618 : : {
1619 : 0 : desc = gfc_evaluate_now (se->expr, &se->pre);
1620 : 0 : se->expr = desc;
1621 : : }
1622 : 280 : desc = gfc_class_data_get (se->expr);
1623 : 280 : vptr = gfc_class_vptr_get (se->expr);
1624 : : }
1625 : 218 : else if (derived && gfc_is_finalizable (derived, NULL))
1626 : : {
1627 : 179 : if (!derived->components && (!rank || attr.elemental))
1628 : : {
1629 : : /* Any attempt to assign zero length entities, causes the gimplifier
1630 : : all manner of problems. Instead, a variable is created to act as
1631 : : as the argument for the final call. */
1632 : 4 : desc = gfc_create_var (TREE_TYPE (se->expr), "zero");
1633 : : }
1634 : 175 : else if (se->direct_byref)
1635 : : {
1636 : 0 : desc = gfc_evaluate_now (se->expr, &se->finalblock);
1637 : 0 : if (derived->attr.alloc_comp)
1638 : : {
1639 : : /* Need to copy allocated components and not finalize. */
1640 : 0 : tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1641 : 0 : gfc_add_expr_to_block (&se->finalblock, tmp);
1642 : : }
1643 : : }
1644 : : else
1645 : : {
1646 : 175 : desc = gfc_evaluate_now (se->expr, &se->pre);
1647 : 175 : se->expr = gfc_evaluate_now (desc, &se->pre);
1648 : 175 : if (derived->attr.alloc_comp)
1649 : : {
1650 : : /* Need to copy allocated components and not finalize. */
1651 : 37 : tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0);
1652 : 37 : gfc_add_expr_to_block (&se->pre, tmp);
1653 : : }
1654 : : }
1655 : :
1656 : 179 : vtab = gfc_find_derived_vtab (derived);
1657 : 179 : if (vtab->backend_decl == NULL_TREE)
1658 : 0 : vptr = gfc_get_symbol_decl (vtab);
1659 : : else
1660 : : vptr = vtab->backend_decl;
1661 : 179 : vptr = gfc_build_addr_expr (NULL, vptr);
1662 : : }
1663 : : else
1664 : 39 : return;
1665 : :
1666 : 459 : size = gfc_vptr_size_get (vptr);
1667 : 459 : final_fndecl = gfc_vptr_final_get (vptr);
1668 : 459 : is_final = fold_build2_loc (input_location, NE_EXPR,
1669 : : logical_type_node,
1670 : : final_fndecl,
1671 : 459 : fold_convert (TREE_TYPE (final_fndecl),
1672 : : null_pointer_node));
1673 : :
1674 : 459 : final_fndecl = build_fold_indirect_ref_loc (input_location,
1675 : : final_fndecl);
1676 : 459 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
1677 : : {
1678 : 265 : if (is_class || attr.elemental)
1679 : 150 : desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
1680 : : else
1681 : : {
1682 : 115 : gfc_init_se (&post_se, NULL);
1683 : 115 : desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
1684 : 115 : gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
1685 : : }
1686 : : }
1687 : :
1688 : 459 : if (derived && !derived->components)
1689 : : {
1690 : : /* All the conditions below break down for zero length derived types. */
1691 : 4 : tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1692 : : gfc_build_addr_expr (NULL, desc),
1693 : : size, boolean_false_node);
1694 : 4 : gfc_add_expr_to_block (&se->finalblock, tmp);
1695 : 4 : return;
1696 : : }
1697 : :
1698 : 455 : if (!VAR_P (desc))
1699 : : {
1700 : 170 : tmp = gfc_create_var (TREE_TYPE (desc), "res");
1701 : 170 : if (se->direct_byref)
1702 : 0 : gfc_add_modify (&se->finalblock, tmp, desc);
1703 : : else
1704 : 170 : gfc_add_modify (&se->pre, tmp, desc);
1705 : : desc = tmp;
1706 : : }
1707 : :
1708 : 455 : data_ptr = gfc_conv_descriptor_data_get (desc);
1709 : 455 : data_null = fold_convert (TREE_TYPE (data_ptr), null_pointer_node);
1710 : 455 : cond = fold_build2_loc (input_location, NE_EXPR,
1711 : : logical_type_node, data_ptr, data_null);
1712 : 455 : is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1713 : : logical_type_node, is_final, cond);
1714 : 455 : tmp = build_call_expr_loc (input_location, final_fndecl, 3,
1715 : : gfc_build_addr_expr (NULL, desc),
1716 : : size, boolean_false_node);
1717 : 455 : tmp = fold_build3_loc (input_location, COND_EXPR,
1718 : : void_type_node, is_final, tmp,
1719 : : build_empty_stmt (input_location));
1720 : :
1721 : 455 : if (is_class && se->ss && se->ss->loop)
1722 : : {
1723 : 122 : gfc_add_expr_to_block (&se->loop->post, tmp);
1724 : 122 : tmp = fold_build3_loc (input_location, COND_EXPR,
1725 : : void_type_node, cond,
1726 : : gfc_call_free (data_ptr),
1727 : : build_empty_stmt (input_location));
1728 : 122 : gfc_add_expr_to_block (&se->loop->post, tmp);
1729 : 122 : gfc_add_modify (&se->loop->post, data_ptr, data_null);
1730 : : }
1731 : : else
1732 : : {
1733 : 333 : gfc_add_expr_to_block (&se->finalblock, tmp);
1734 : :
1735 : : /* Let the scalarizer take care of freeing of temporary arrays. */
1736 : 333 : if (attr.allocatable && !(se->loop && se->loop->temp_dim))
1737 : : {
1738 : 158 : tmp = fold_build3_loc (input_location, COND_EXPR,
1739 : : void_type_node, cond,
1740 : : gfc_call_free (data_ptr),
1741 : : build_empty_stmt (input_location));
1742 : 158 : gfc_add_expr_to_block (&se->finalblock, tmp);
1743 : 158 : gfc_add_modify (&se->finalblock, data_ptr, data_null);
1744 : : }
1745 : : }
1746 : : }
1747 : :
1748 : :
1749 : : /* User-deallocate; we emit the code directly from the front-end, and the
1750 : : logic is the same as the previous library function:
1751 : :
1752 : : void
1753 : : deallocate (void *pointer, GFC_INTEGER_4 * stat)
1754 : : {
1755 : : if (!pointer)
1756 : : {
1757 : : if (stat)
1758 : : *stat = 1;
1759 : : else
1760 : : runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1761 : : }
1762 : : else
1763 : : {
1764 : : free (pointer);
1765 : : if (stat)
1766 : : *stat = 0;
1767 : : }
1768 : : }
1769 : :
1770 : : In this front-end version, status doesn't have to be GFC_INTEGER_4.
1771 : : Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1772 : : even when no status variable is passed to us (this is used for
1773 : : unconditional deallocation generated by the front-end at end of
1774 : : each procedure).
1775 : :
1776 : : If a runtime-message is possible, `expr' must point to the original
1777 : : expression being deallocated for its locus and variable name.
1778 : :
1779 : : For coarrays, "pointer" must be the array descriptor and not its
1780 : : "data" component.
1781 : :
1782 : : COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1783 : : the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1784 : : analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1785 : : be deallocated. */
1786 : : tree
1787 : 15160 : gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1788 : : tree errlen, tree label_finish,
1789 : : bool can_fail, gfc_expr* expr,
1790 : : int coarray_dealloc_mode, tree class_container,
1791 : : tree add_when_allocated, tree caf_token)
1792 : : {
1793 : 15160 : stmtblock_t null, non_null;
1794 : 15160 : tree cond, tmp, error;
1795 : 15160 : tree status_type = NULL_TREE;
1796 : 15160 : tree token = NULL_TREE;
1797 : 15160 : tree descr = NULL_TREE;
1798 : 15160 : gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
1799 : :
1800 : 15160 : if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
1801 : : {
1802 : 374 : if (flag_coarray == GFC_FCOARRAY_LIB)
1803 : : {
1804 : 220 : if (caf_token)
1805 : : {
1806 : 64 : token = caf_token;
1807 : 64 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1808 : 33 : pointer = gfc_conv_descriptor_data_get (pointer);
1809 : : }
1810 : : else
1811 : : {
1812 : 156 : tree caf_type, caf_decl = pointer;
1813 : 156 : pointer = gfc_conv_descriptor_data_get (caf_decl);
1814 : 156 : caf_type = TREE_TYPE (caf_decl);
1815 : 156 : STRIP_NOPS (pointer);
1816 : 156 : if (GFC_DESCRIPTOR_TYPE_P (caf_type))
1817 : 156 : token = gfc_conv_descriptor_token (caf_decl);
1818 : 0 : else if (DECL_LANG_SPECIFIC (caf_decl)
1819 : 0 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1820 : 0 : token = GFC_DECL_TOKEN (caf_decl);
1821 : : else
1822 : : {
1823 : 0 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1824 : : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
1825 : : != NULL_TREE);
1826 : 0 : token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1827 : : }
1828 : : }
1829 : :
1830 : 220 : if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
1831 : : {
1832 : 4 : bool comp_ref;
1833 : 4 : if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
1834 : 4 : && comp_ref)
1835 : 0 : caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
1836 : : // else do a deregister as set by default.
1837 : : }
1838 : : else
1839 : : caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
1840 : : }
1841 : 154 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
1842 : 154 : pointer = gfc_conv_descriptor_data_get (pointer);
1843 : : }
1844 : 14786 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
1845 : : {
1846 : 11385 : descr = pointer;
1847 : 11385 : pointer = gfc_conv_descriptor_data_get (pointer);
1848 : : }
1849 : :
1850 : 15160 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
1851 : 15160 : build_int_cst (TREE_TYPE (pointer), 0));
1852 : :
1853 : : /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1854 : : we emit a runtime error. */
1855 : 15160 : gfc_start_block (&null);
1856 : 15160 : if (!can_fail)
1857 : : {
1858 : 6203 : tree varname;
1859 : :
1860 : 6203 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1861 : :
1862 : 6203 : varname = gfc_build_cstring_const (expr->symtree->name);
1863 : 6203 : varname = gfc_build_addr_expr (pchar_type_node, varname);
1864 : :
1865 : 6203 : error = gfc_trans_runtime_error (true, &expr->where,
1866 : : "Attempt to DEALLOCATE unallocated '%s'",
1867 : : varname);
1868 : : }
1869 : : else
1870 : 8957 : error = build_empty_stmt (input_location);
1871 : :
1872 : 15160 : if (status != NULL_TREE && !integer_zerop (status))
1873 : : {
1874 : 1376 : tree cond2;
1875 : :
1876 : 1376 : status_type = TREE_TYPE (TREE_TYPE (status));
1877 : 1376 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1878 : 1376 : status, build_int_cst (TREE_TYPE (status), 0));
1879 : 1376 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1880 : : fold_build1_loc (input_location, INDIRECT_REF,
1881 : : status_type, status),
1882 : 1376 : build_int_cst (status_type, 1));
1883 : 1376 : error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1884 : : cond2, tmp, error);
1885 : : }
1886 : :
1887 : 15160 : gfc_add_expr_to_block (&null, error);
1888 : :
1889 : : /* When POINTER is not NULL, we free it. */
1890 : 15160 : gfc_start_block (&non_null);
1891 : 15160 : if (add_when_allocated)
1892 : 2363 : gfc_add_expr_to_block (&non_null, add_when_allocated);
1893 : 15160 : gfc_add_finalizer_call (&non_null, expr, class_container);
1894 : 15160 : if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
1895 : 374 : || flag_coarray != GFC_FCOARRAY_LIB)
1896 : : {
1897 : 14940 : tmp = build_call_expr_loc (input_location,
1898 : : builtin_decl_explicit (BUILT_IN_FREE), 1,
1899 : : fold_convert (pvoid_type_node, pointer));
1900 : 14940 : if (flag_openmp_allocators && coarray_dealloc_mode < GFC_CAF_COARRAY_ANALYZE)
1901 : : {
1902 : 58 : tree cond, omp_tmp;
1903 : 58 : if (descr)
1904 : 43 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1905 : : gfc_conv_descriptor_version (descr),
1906 : : integer_one_node);
1907 : : else
1908 : 15 : cond = gfc_omp_call_is_alloc (pointer);
1909 : 58 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
1910 : 58 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer,
1911 : : build_zero_cst (ptr_type_node));
1912 : 58 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1913 : : omp_tmp, tmp);
1914 : : }
1915 : 14940 : gfc_add_expr_to_block (&non_null, tmp);
1916 : 14940 : gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
1917 : 14940 : 0));
1918 : 14940 : if (flag_openmp_allocators && descr)
1919 : 43 : gfc_add_modify (&non_null, gfc_conv_descriptor_version (descr),
1920 : : integer_zero_node);
1921 : :
1922 : 14940 : if (status != NULL_TREE && !integer_zerop (status))
1923 : : {
1924 : : /* We set STATUS to zero if it is present. */
1925 : 1366 : tree status_type = TREE_TYPE (TREE_TYPE (status));
1926 : 1366 : tree cond2;
1927 : :
1928 : 1366 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1929 : : status,
1930 : 1366 : build_int_cst (TREE_TYPE (status), 0));
1931 : 1366 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1932 : : fold_build1_loc (input_location, INDIRECT_REF,
1933 : : status_type, status),
1934 : 1366 : build_int_cst (status_type, 0));
1935 : 1366 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1936 : : gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1937 : : tmp, build_empty_stmt (input_location));
1938 : 1366 : gfc_add_expr_to_block (&non_null, tmp);
1939 : : }
1940 : : }
1941 : : else
1942 : : {
1943 : 220 : tree cond2, pstat = null_pointer_node;
1944 : :
1945 : 220 : if (errmsg == NULL_TREE)
1946 : : {
1947 : 214 : gcc_assert (errlen == NULL_TREE);
1948 : 214 : errmsg = null_pointer_node;
1949 : 214 : errlen = integer_zero_node;
1950 : : }
1951 : : else
1952 : : {
1953 : 6 : gcc_assert (errlen != NULL_TREE);
1954 : 6 : if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1955 : 0 : errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1956 : : }
1957 : :
1958 : 220 : if (status != NULL_TREE && !integer_zerop (status))
1959 : : {
1960 : 10 : gcc_assert (status_type == integer_type_node);
1961 : : pstat = status;
1962 : : }
1963 : :
1964 : 220 : token = gfc_build_addr_expr (NULL_TREE, token);
1965 : 220 : gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
1966 : 220 : tmp = build_call_expr_loc (input_location,
1967 : : gfor_fndecl_caf_deregister, 5,
1968 : : token, build_int_cst (integer_type_node,
1969 : : caf_dereg_type),
1970 : : pstat, errmsg, errlen);
1971 : 220 : gfc_add_expr_to_block (&non_null, tmp);
1972 : :
1973 : : /* It guarantees memory consistency within the same segment */
1974 : 220 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1975 : 220 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1976 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1977 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1978 : 220 : ASM_VOLATILE_P (tmp) = 1;
1979 : 220 : gfc_add_expr_to_block (&non_null, tmp);
1980 : :
1981 : 220 : if (status != NULL_TREE)
1982 : : {
1983 : 10 : tree stat = build_fold_indirect_ref_loc (input_location, status);
1984 : 10 : tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
1985 : : void_type_node, pointer,
1986 : 10 : build_int_cst (TREE_TYPE (pointer),
1987 : 10 : 0));
1988 : :
1989 : 10 : TREE_USED (label_finish) = 1;
1990 : 10 : tmp = build1_v (GOTO_EXPR, label_finish);
1991 : 10 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1992 : 10 : stat, build_zero_cst (TREE_TYPE (stat)));
1993 : 10 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1994 : : gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
1995 : : tmp, nullify);
1996 : 10 : gfc_add_expr_to_block (&non_null, tmp);
1997 : : }
1998 : : else
1999 : 210 : gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
2000 : 210 : 0));
2001 : : }
2002 : :
2003 : 15160 : return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
2004 : : gfc_finish_block (&null),
2005 : 15160 : gfc_finish_block (&non_null));
2006 : : }
2007 : :
2008 : :
2009 : : /* Generate code for deallocation of allocatable scalars (variables or
2010 : : components). Before the object itself is freed, any allocatable
2011 : : subcomponents are being deallocated. */
2012 : :
2013 : : tree
2014 : 4501 : gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
2015 : : bool can_fail, gfc_expr* expr,
2016 : : gfc_typespec ts, tree class_container,
2017 : : bool coarray)
2018 : : {
2019 : 4501 : stmtblock_t null, non_null;
2020 : 4501 : tree cond, tmp, error;
2021 : 4501 : bool finalizable, comp_ref;
2022 : 4501 : gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
2023 : :
2024 : 4501 : if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
2025 : 4549 : && comp_ref)
2026 : 48 : caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
2027 : :
2028 : 4501 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
2029 : 4501 : build_int_cst (TREE_TYPE (pointer), 0));
2030 : :
2031 : : /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
2032 : : we emit a runtime error. */
2033 : 4501 : gfc_start_block (&null);
2034 : 4501 : if (!can_fail)
2035 : : {
2036 : 2894 : tree varname;
2037 : :
2038 : 2894 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
2039 : :
2040 : 2894 : varname = gfc_build_cstring_const (expr->symtree->name);
2041 : 2894 : varname = gfc_build_addr_expr (pchar_type_node, varname);
2042 : :
2043 : 2894 : error = gfc_trans_runtime_error (true, &expr->where,
2044 : : "Attempt to DEALLOCATE unallocated '%s'",
2045 : : varname);
2046 : : }
2047 : : else
2048 : 1607 : error = build_empty_stmt (input_location);
2049 : :
2050 : 4501 : if (status != NULL_TREE && !integer_zerop (status))
2051 : : {
2052 : 587 : tree status_type = TREE_TYPE (TREE_TYPE (status));
2053 : 587 : tree cond2;
2054 : :
2055 : 587 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2056 : 587 : status, build_int_cst (TREE_TYPE (status), 0));
2057 : 587 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2058 : : fold_build1_loc (input_location, INDIRECT_REF,
2059 : : status_type, status),
2060 : 587 : build_int_cst (status_type, 1));
2061 : 587 : error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2062 : : cond2, tmp, error);
2063 : : }
2064 : 4501 : gfc_add_expr_to_block (&null, error);
2065 : :
2066 : : /* When POINTER is not NULL, we free it. */
2067 : 4501 : gfc_start_block (&non_null);
2068 : :
2069 : : /* Free allocatable components. */
2070 : 4501 : finalizable = gfc_add_finalizer_call (&non_null, expr, class_container);
2071 : 4501 : if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
2072 : : {
2073 : 825 : int caf_mode = coarray
2074 : 409 : ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
2075 : : ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
2076 : : | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
2077 : 7 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
2078 : : : 0;
2079 : 7 : if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
2080 : 0 : tmp = gfc_conv_descriptor_data_get (pointer);
2081 : : else
2082 : 409 : tmp = build_fold_indirect_ref_loc (input_location, pointer);
2083 : 409 : tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
2084 : 409 : gfc_add_expr_to_block (&non_null, tmp);
2085 : : }
2086 : :
2087 : 4501 : if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
2088 : : {
2089 : 4454 : tmp = build_call_expr_loc (input_location,
2090 : : builtin_decl_explicit (BUILT_IN_FREE), 1,
2091 : : fold_convert (pvoid_type_node, pointer));
2092 : 4454 : if (flag_openmp_allocators)
2093 : : {
2094 : 31 : tree cond, omp_tmp;
2095 : 31 : cond = gfc_omp_call_is_alloc (pointer);
2096 : 31 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
2097 : 31 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer,
2098 : : build_zero_cst (ptr_type_node));
2099 : 31 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
2100 : : omp_tmp, tmp);
2101 : : }
2102 : 4454 : gfc_add_expr_to_block (&non_null, tmp);
2103 : :
2104 : 4454 : if (status != NULL_TREE && !integer_zerop (status))
2105 : : {
2106 : : /* We set STATUS to zero if it is present. */
2107 : 587 : tree status_type = TREE_TYPE (TREE_TYPE (status));
2108 : 587 : tree cond2;
2109 : :
2110 : 587 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2111 : : status,
2112 : 587 : build_int_cst (TREE_TYPE (status), 0));
2113 : 587 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
2114 : : fold_build1_loc (input_location, INDIRECT_REF,
2115 : : status_type, status),
2116 : 587 : build_int_cst (status_type, 0));
2117 : 587 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2118 : : cond2, tmp, build_empty_stmt (input_location));
2119 : 587 : gfc_add_expr_to_block (&non_null, tmp);
2120 : : }
2121 : : }
2122 : : else
2123 : : {
2124 : 47 : tree token;
2125 : 47 : tree pstat = null_pointer_node;
2126 : 47 : gfc_se se;
2127 : :
2128 : 47 : gfc_init_se (&se, NULL);
2129 : 47 : token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
2130 : 47 : gcc_assert (token != NULL_TREE);
2131 : :
2132 : 47 : if (status != NULL_TREE && !integer_zerop (status))
2133 : : {
2134 : 0 : gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
2135 : : pstat = status;
2136 : : }
2137 : :
2138 : 47 : tmp = build_call_expr_loc (input_location,
2139 : : gfor_fndecl_caf_deregister, 5,
2140 : : token, build_int_cst (integer_type_node,
2141 : : caf_dereg_type),
2142 : : pstat, null_pointer_node, integer_zero_node);
2143 : 47 : gfc_add_expr_to_block (&non_null, tmp);
2144 : :
2145 : : /* It guarantees memory consistency within the same segment. */
2146 : 47 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
2147 : 47 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2148 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2149 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2150 : 47 : ASM_VOLATILE_P (tmp) = 1;
2151 : 47 : gfc_add_expr_to_block (&non_null, tmp);
2152 : :
2153 : 47 : if (status != NULL_TREE)
2154 : : {
2155 : 0 : tree stat = build_fold_indirect_ref_loc (input_location, status);
2156 : 0 : tree cond2;
2157 : :
2158 : 0 : TREE_USED (label_finish) = 1;
2159 : 0 : tmp = build1_v (GOTO_EXPR, label_finish);
2160 : 0 : cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2161 : 0 : stat, build_zero_cst (TREE_TYPE (stat)));
2162 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2163 : : gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
2164 : : tmp, build_empty_stmt (input_location));
2165 : 0 : gfc_add_expr_to_block (&non_null, tmp);
2166 : : }
2167 : : }
2168 : :
2169 : 4501 : return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
2170 : : gfc_finish_block (&null),
2171 : 4501 : gfc_finish_block (&non_null));
2172 : : }
2173 : :
2174 : : /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
2175 : : following pseudo-code:
2176 : :
2177 : : void *
2178 : : internal_realloc (void *mem, size_t size)
2179 : : {
2180 : : res = realloc (mem, size);
2181 : : if (!res && size != 0)
2182 : : _gfortran_os_error ("Allocation would exceed memory limit");
2183 : :
2184 : : return res;
2185 : : } */
2186 : : tree
2187 : 1077 : gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
2188 : : {
2189 : 1077 : tree res, nonzero, null_result, tmp;
2190 : 1077 : tree type = TREE_TYPE (mem);
2191 : :
2192 : : /* Only evaluate the size once. */
2193 : 1077 : size = save_expr (fold_convert (size_type_node, size));
2194 : :
2195 : : /* Create a variable to hold the result. */
2196 : 1077 : res = gfc_create_var (type, NULL);
2197 : :
2198 : : /* Call realloc and check the result. */
2199 : 1077 : tmp = build_call_expr_loc (input_location,
2200 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
2201 : : fold_convert (pvoid_type_node, mem), size);
2202 : 1077 : gfc_add_modify (block, res, fold_convert (type, tmp));
2203 : 1077 : null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2204 : 1077 : res, build_int_cst (pvoid_type_node, 0));
2205 : 1077 : nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
2206 : 1077 : build_int_cst (size_type_node, 0));
2207 : 1077 : null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
2208 : : null_result, nonzero);
2209 : 1077 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2210 : : null_result,
2211 : : trans_os_error_at (NULL,
2212 : : "Error reallocating to %lu bytes",
2213 : : fold_convert
2214 : : (long_unsigned_type_node, size)),
2215 : : build_empty_stmt (input_location));
2216 : 1077 : gfc_add_expr_to_block (block, tmp);
2217 : :
2218 : 1077 : return res;
2219 : : }
2220 : :
2221 : :
2222 : : /* Add an expression to another one, either at the front or the back. */
2223 : :
2224 : : static void
2225 : 14462915 : add_expr_to_chain (tree* chain, tree expr, bool front)
2226 : : {
2227 : 14462915 : if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
2228 : 6820288 : return;
2229 : :
2230 : 7642627 : if (*chain)
2231 : : {
2232 : 4078848 : if (TREE_CODE (*chain) != STATEMENT_LIST)
2233 : : {
2234 : 1197450 : tree tmp;
2235 : :
2236 : 1197450 : tmp = *chain;
2237 : 1197450 : *chain = NULL_TREE;
2238 : 1197450 : append_to_statement_list (tmp, chain);
2239 : : }
2240 : :
2241 : 4078848 : if (front)
2242 : : {
2243 : 19015 : tree_stmt_iterator i;
2244 : :
2245 : 19015 : i = tsi_start (*chain);
2246 : 19015 : tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
2247 : : }
2248 : : else
2249 : 4059833 : append_to_statement_list (expr, chain);
2250 : : }
2251 : : else
2252 : 3563779 : *chain = expr;
2253 : : }
2254 : :
2255 : :
2256 : : /* Add a statement at the end of a block. */
2257 : :
2258 : : void
2259 : 13746856 : gfc_add_expr_to_block (stmtblock_t * block, tree expr)
2260 : : {
2261 : 13746856 : gcc_assert (block);
2262 : 13746856 : add_expr_to_chain (&block->head, expr, false);
2263 : 13746856 : }
2264 : :
2265 : :
2266 : : /* Add a statement at the beginning of a block. */
2267 : :
2268 : : void
2269 : 659 : gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
2270 : : {
2271 : 659 : gcc_assert (block);
2272 : 659 : add_expr_to_chain (&block->head, expr, true);
2273 : 659 : }
2274 : :
2275 : :
2276 : : /* Add a block the end of a block. */
2277 : :
2278 : : void
2279 : 6856029 : gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
2280 : : {
2281 : 6856029 : gcc_assert (append);
2282 : 6856029 : gcc_assert (!append->has_scope);
2283 : :
2284 : 6856029 : gfc_add_expr_to_block (block, append->head);
2285 : 6856029 : append->head = NULL_TREE;
2286 : 6856029 : }
2287 : :
2288 : :
2289 : : /* Save the current locus. The structure may not be complete, and should
2290 : : only be used with gfc_restore_backend_locus. */
2291 : :
2292 : : void
2293 : 347041 : gfc_save_backend_locus (locus * loc)
2294 : : {
2295 : 347041 : loc->lb = XCNEW (gfc_linebuf);
2296 : 347041 : loc->lb->location = input_location;
2297 : 347041 : loc->lb->file = gfc_current_backend_file;
2298 : 347041 : }
2299 : :
2300 : :
2301 : : /* Set the current locus. */
2302 : :
2303 : : void
2304 : 2282003 : gfc_set_backend_locus (locus * loc)
2305 : : {
2306 : 2282003 : gfc_current_backend_file = loc->lb->file;
2307 : 2282003 : input_location = gfc_get_location (loc);
2308 : 2282003 : }
2309 : :
2310 : :
2311 : : /* Restore the saved locus. Only used in conjunction with
2312 : : gfc_save_backend_locus, to free the memory when we are done. */
2313 : :
2314 : : void
2315 : 346274 : gfc_restore_backend_locus (locus * loc)
2316 : : {
2317 : : /* This only restores the information captured by gfc_save_backend_locus,
2318 : : intentionally does not use gfc_get_location. */
2319 : 346274 : input_location = loc->lb->location;
2320 : 346274 : gfc_current_backend_file = loc->lb->file;
2321 : 346274 : free (loc->lb);
2322 : 346274 : }
2323 : :
2324 : :
2325 : : /* Translate an executable statement. The tree cond is used by gfc_trans_do.
2326 : : This static function is wrapped by gfc_trans_code_cond and
2327 : : gfc_trans_code. */
2328 : :
2329 : : static tree
2330 : 375001 : trans_code (gfc_code * code, tree cond)
2331 : : {
2332 : 375001 : stmtblock_t block;
2333 : 375001 : tree res;
2334 : :
2335 : 375001 : if (!code)
2336 : 1793 : return build_empty_stmt (input_location);
2337 : :
2338 : 373208 : gfc_start_block (&block);
2339 : :
2340 : : /* Translate statements one by one into GENERIC trees until we reach
2341 : : the end of this gfc_code branch. */
2342 : 1298032 : for (; code; code = code->next)
2343 : : {
2344 : 924824 : if (code->here != 0)
2345 : : {
2346 : 3496 : res = gfc_trans_label_here (code);
2347 : 3496 : gfc_add_expr_to_block (&block, res);
2348 : : }
2349 : :
2350 : 924824 : gfc_current_locus = code->loc;
2351 : 924824 : gfc_set_backend_locus (&code->loc);
2352 : :
2353 : 924824 : switch (code->op)
2354 : : {
2355 : : case EXEC_NOP:
2356 : : case EXEC_END_BLOCK:
2357 : : case EXEC_END_NESTED_BLOCK:
2358 : : case EXEC_END_PROCEDURE:
2359 : : res = NULL_TREE;
2360 : : break;
2361 : :
2362 : 185143 : case EXEC_ASSIGN:
2363 : 185143 : res = gfc_trans_assign (code);
2364 : 185143 : break;
2365 : :
2366 : 116 : case EXEC_LABEL_ASSIGN:
2367 : 116 : res = gfc_trans_label_assign (code);
2368 : 116 : break;
2369 : :
2370 : 8873 : case EXEC_POINTER_ASSIGN:
2371 : 8873 : res = gfc_trans_pointer_assign (code);
2372 : 8873 : break;
2373 : :
2374 : 9161 : case EXEC_INIT_ASSIGN:
2375 : 9161 : if (code->expr1->ts.type == BT_CLASS)
2376 : 344 : res = gfc_trans_class_init_assign (code);
2377 : : else
2378 : 8817 : res = gfc_trans_init_assign (code);
2379 : : break;
2380 : :
2381 : : case EXEC_CONTINUE:
2382 : : res = NULL_TREE;
2383 : : break;
2384 : :
2385 : 21 : case EXEC_CRITICAL:
2386 : 21 : res = gfc_trans_critical (code);
2387 : 21 : break;
2388 : :
2389 : 105 : case EXEC_CYCLE:
2390 : 105 : res = gfc_trans_cycle (code);
2391 : 105 : break;
2392 : :
2393 : 683 : case EXEC_EXIT:
2394 : 683 : res = gfc_trans_exit (code);
2395 : 683 : break;
2396 : :
2397 : 1185 : case EXEC_GOTO:
2398 : 1185 : res = gfc_trans_goto (code);
2399 : 1185 : break;
2400 : :
2401 : 1339 : case EXEC_ENTRY:
2402 : 1339 : res = gfc_trans_entry (code);
2403 : 1339 : break;
2404 : :
2405 : 28 : case EXEC_PAUSE:
2406 : 28 : res = gfc_trans_pause (code);
2407 : 28 : break;
2408 : :
2409 : 179390 : case EXEC_STOP:
2410 : 179390 : case EXEC_ERROR_STOP:
2411 : 179390 : res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
2412 : 179390 : break;
2413 : :
2414 : 72370 : case EXEC_CALL:
2415 : : /* For MVBITS we've got the special exception that we need a
2416 : : dependency check, too. */
2417 : 72370 : {
2418 : 72370 : bool is_mvbits = false;
2419 : :
2420 : 72370 : if (code->resolved_isym)
2421 : : {
2422 : 5667 : res = gfc_conv_intrinsic_subroutine (code);
2423 : 5667 : if (res != NULL_TREE)
2424 : : break;
2425 : : }
2426 : :
2427 : 68451 : if (code->resolved_isym
2428 : 1748 : && code->resolved_isym->id == GFC_ISYM_MVBITS)
2429 : 68451 : is_mvbits = true;
2430 : :
2431 : 68451 : res = gfc_trans_call (code, is_mvbits, NULL_TREE,
2432 : : NULL_TREE, false);
2433 : : }
2434 : 68451 : break;
2435 : :
2436 : 112 : case EXEC_CALL_PPC:
2437 : 112 : res = gfc_trans_call (code, false, NULL_TREE,
2438 : : NULL_TREE, false);
2439 : 112 : break;
2440 : :
2441 : 666 : case EXEC_ASSIGN_CALL:
2442 : 666 : res = gfc_trans_call (code, true, NULL_TREE,
2443 : : NULL_TREE, false);
2444 : 666 : break;
2445 : :
2446 : 2942 : case EXEC_RETURN:
2447 : 2942 : res = gfc_trans_return (code);
2448 : 2942 : break;
2449 : :
2450 : 198591 : case EXEC_IF:
2451 : 198591 : res = gfc_trans_if (code);
2452 : 198591 : break;
2453 : :
2454 : 64 : case EXEC_ARITHMETIC_IF:
2455 : 64 : res = gfc_trans_arithmetic_if (code);
2456 : 64 : break;
2457 : :
2458 : 12600 : case EXEC_BLOCK:
2459 : 12600 : res = gfc_trans_block_construct (code);
2460 : 12600 : break;
2461 : :
2462 : 25251 : case EXEC_DO:
2463 : 25251 : res = gfc_trans_do (code, cond);
2464 : 25251 : break;
2465 : :
2466 : 49 : case EXEC_DO_CONCURRENT:
2467 : 49 : res = gfc_trans_do_concurrent (code);
2468 : 49 : break;
2469 : :
2470 : 494 : case EXEC_DO_WHILE:
2471 : 494 : res = gfc_trans_do_while (code);
2472 : 494 : break;
2473 : :
2474 : 985 : case EXEC_SELECT:
2475 : 985 : res = gfc_trans_select (code);
2476 : 985 : break;
2477 : :
2478 : 2616 : case EXEC_SELECT_TYPE:
2479 : 2616 : res = gfc_trans_select_type (code);
2480 : 2616 : break;
2481 : :
2482 : 988 : case EXEC_SELECT_RANK:
2483 : 988 : res = gfc_trans_select_rank (code);
2484 : 988 : break;
2485 : :
2486 : 73 : case EXEC_FLUSH:
2487 : 73 : res = gfc_trans_flush (code);
2488 : 73 : break;
2489 : :
2490 : 716 : case EXEC_SYNC_ALL:
2491 : 716 : case EXEC_SYNC_IMAGES:
2492 : 716 : case EXEC_SYNC_MEMORY:
2493 : 716 : res = gfc_trans_sync (code, code->op);
2494 : 716 : break;
2495 : :
2496 : 84 : case EXEC_LOCK:
2497 : 84 : case EXEC_UNLOCK:
2498 : 84 : res = gfc_trans_lock_unlock (code, code->op);
2499 : 84 : break;
2500 : :
2501 : 39 : case EXEC_EVENT_POST:
2502 : 39 : case EXEC_EVENT_WAIT:
2503 : 39 : res = gfc_trans_event_post_wait (code, code->op);
2504 : 39 : break;
2505 : :
2506 : 3 : case EXEC_FAIL_IMAGE:
2507 : 3 : res = gfc_trans_fail_image (code);
2508 : 3 : break;
2509 : :
2510 : 1870 : case EXEC_FORALL:
2511 : 1870 : res = gfc_trans_forall (code);
2512 : 1870 : break;
2513 : :
2514 : 25 : case EXEC_FORM_TEAM:
2515 : 25 : res = gfc_trans_form_team (code);
2516 : 25 : break;
2517 : :
2518 : 19 : case EXEC_CHANGE_TEAM:
2519 : 19 : res = gfc_trans_change_team (code);
2520 : 19 : break;
2521 : :
2522 : 19 : case EXEC_END_TEAM:
2523 : 19 : res = gfc_trans_end_team (code);
2524 : 19 : break;
2525 : :
2526 : 0 : case EXEC_SYNC_TEAM:
2527 : 0 : res = gfc_trans_sync_team (code);
2528 : 0 : break;
2529 : :
2530 : 322 : case EXEC_WHERE:
2531 : 322 : res = gfc_trans_where (code);
2532 : 322 : break;
2533 : :
2534 : 12148 : case EXEC_ALLOCATE:
2535 : 12148 : res = gfc_trans_allocate (code, NULL);
2536 : 12148 : break;
2537 : :
2538 : 7321 : case EXEC_DEALLOCATE:
2539 : 7321 : res = gfc_trans_deallocate (code);
2540 : 7321 : break;
2541 : :
2542 : 3478 : case EXEC_OPEN:
2543 : 3478 : res = gfc_trans_open (code);
2544 : 3478 : break;
2545 : :
2546 : 2988 : case EXEC_CLOSE:
2547 : 2988 : res = gfc_trans_close (code);
2548 : 2988 : break;
2549 : :
2550 : 5826 : case EXEC_READ:
2551 : 5826 : res = gfc_trans_read (code);
2552 : 5826 : break;
2553 : :
2554 : 23221 : case EXEC_WRITE:
2555 : 23221 : res = gfc_trans_write (code);
2556 : 23221 : break;
2557 : :
2558 : 84 : case EXEC_IOLENGTH:
2559 : 84 : res = gfc_trans_iolength (code);
2560 : 84 : break;
2561 : :
2562 : 389 : case EXEC_BACKSPACE:
2563 : 389 : res = gfc_trans_backspace (code);
2564 : 389 : break;
2565 : :
2566 : 56 : case EXEC_ENDFILE:
2567 : 56 : res = gfc_trans_endfile (code);
2568 : 56 : break;
2569 : :
2570 : 759 : case EXEC_INQUIRE:
2571 : 759 : res = gfc_trans_inquire (code);
2572 : 759 : break;
2573 : :
2574 : 74 : case EXEC_WAIT:
2575 : 74 : res = gfc_trans_wait (code);
2576 : 74 : break;
2577 : :
2578 : 2020 : case EXEC_REWIND:
2579 : 2020 : res = gfc_trans_rewind (code);
2580 : 2020 : break;
2581 : :
2582 : 42482 : case EXEC_TRANSFER:
2583 : 42482 : res = gfc_trans_transfer (code);
2584 : 42482 : break;
2585 : :
2586 : 29131 : case EXEC_DT_END:
2587 : 29131 : res = gfc_trans_dt_end (code);
2588 : 29131 : break;
2589 : :
2590 : 17316 : case EXEC_OMP_ALLOCATE:
2591 : 17316 : case EXEC_OMP_ALLOCATORS:
2592 : 17316 : case EXEC_OMP_ASSUME:
2593 : 17316 : case EXEC_OMP_ATOMIC:
2594 : 17316 : case EXEC_OMP_BARRIER:
2595 : 17316 : case EXEC_OMP_CANCEL:
2596 : 17316 : case EXEC_OMP_CANCELLATION_POINT:
2597 : 17316 : case EXEC_OMP_CRITICAL:
2598 : 17316 : case EXEC_OMP_DEPOBJ:
2599 : 17316 : case EXEC_OMP_DISTRIBUTE:
2600 : 17316 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
2601 : 17316 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2602 : 17316 : case EXEC_OMP_DISTRIBUTE_SIMD:
2603 : 17316 : case EXEC_OMP_DO:
2604 : 17316 : case EXEC_OMP_DO_SIMD:
2605 : 17316 : case EXEC_OMP_LOOP:
2606 : 17316 : case EXEC_OMP_ERROR:
2607 : 17316 : case EXEC_OMP_FLUSH:
2608 : 17316 : case EXEC_OMP_MASKED:
2609 : 17316 : case EXEC_OMP_MASKED_TASKLOOP:
2610 : 17316 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
2611 : 17316 : case EXEC_OMP_MASTER:
2612 : 17316 : case EXEC_OMP_MASTER_TASKLOOP:
2613 : 17316 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
2614 : 17316 : case EXEC_OMP_ORDERED:
2615 : 17316 : case EXEC_OMP_PARALLEL:
2616 : 17316 : case EXEC_OMP_PARALLEL_DO:
2617 : 17316 : case EXEC_OMP_PARALLEL_DO_SIMD:
2618 : 17316 : case EXEC_OMP_PARALLEL_LOOP:
2619 : 17316 : case EXEC_OMP_PARALLEL_MASKED:
2620 : 17316 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
2621 : 17316 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2622 : 17316 : case EXEC_OMP_PARALLEL_MASTER:
2623 : 17316 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
2624 : 17316 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2625 : 17316 : case EXEC_OMP_PARALLEL_SECTIONS:
2626 : 17316 : case EXEC_OMP_PARALLEL_WORKSHARE:
2627 : 17316 : case EXEC_OMP_SCOPE:
2628 : 17316 : case EXEC_OMP_SECTIONS:
2629 : 17316 : case EXEC_OMP_SIMD:
2630 : 17316 : case EXEC_OMP_SINGLE:
2631 : 17316 : case EXEC_OMP_TARGET:
2632 : 17316 : case EXEC_OMP_TARGET_DATA:
2633 : 17316 : case EXEC_OMP_TARGET_ENTER_DATA:
2634 : 17316 : case EXEC_OMP_TARGET_EXIT_DATA:
2635 : 17316 : case EXEC_OMP_TARGET_PARALLEL:
2636 : 17316 : case EXEC_OMP_TARGET_PARALLEL_DO:
2637 : 17316 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
2638 : 17316 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
2639 : 17316 : case EXEC_OMP_TARGET_SIMD:
2640 : 17316 : case EXEC_OMP_TARGET_TEAMS:
2641 : 17316 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
2642 : 17316 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2643 : 17316 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2644 : 17316 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2645 : 17316 : case EXEC_OMP_TARGET_TEAMS_LOOP:
2646 : 17316 : case EXEC_OMP_TARGET_UPDATE:
2647 : 17316 : case EXEC_OMP_TASK:
2648 : 17316 : case EXEC_OMP_TASKGROUP:
2649 : 17316 : case EXEC_OMP_TASKLOOP:
2650 : 17316 : case EXEC_OMP_TASKLOOP_SIMD:
2651 : 17316 : case EXEC_OMP_TASKWAIT:
2652 : 17316 : case EXEC_OMP_TASKYIELD:
2653 : 17316 : case EXEC_OMP_TEAMS:
2654 : 17316 : case EXEC_OMP_TEAMS_DISTRIBUTE:
2655 : 17316 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2656 : 17316 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2657 : 17316 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
2658 : 17316 : case EXEC_OMP_TEAMS_LOOP:
2659 : 17316 : case EXEC_OMP_WORKSHARE:
2660 : 17316 : res = gfc_trans_omp_directive (code);
2661 : 17316 : break;
2662 : :
2663 : 11339 : case EXEC_OACC_CACHE:
2664 : 11339 : case EXEC_OACC_WAIT:
2665 : 11339 : case EXEC_OACC_UPDATE:
2666 : 11339 : case EXEC_OACC_LOOP:
2667 : 11339 : case EXEC_OACC_HOST_DATA:
2668 : 11339 : case EXEC_OACC_DATA:
2669 : 11339 : case EXEC_OACC_KERNELS:
2670 : 11339 : case EXEC_OACC_KERNELS_LOOP:
2671 : 11339 : case EXEC_OACC_PARALLEL:
2672 : 11339 : case EXEC_OACC_PARALLEL_LOOP:
2673 : 11339 : case EXEC_OACC_SERIAL:
2674 : 11339 : case EXEC_OACC_SERIAL_LOOP:
2675 : 11339 : case EXEC_OACC_ENTER_DATA:
2676 : 11339 : case EXEC_OACC_EXIT_DATA:
2677 : 11339 : case EXEC_OACC_ATOMIC:
2678 : 11339 : case EXEC_OACC_DECLARE:
2679 : 11339 : res = gfc_trans_oacc_directive (code);
2680 : 11339 : break;
2681 : :
2682 : 0 : default:
2683 : 0 : gfc_internal_error ("gfc_trans_code(): Bad statement code");
2684 : : }
2685 : :
2686 : 924824 : gfc_set_backend_locus (&code->loc);
2687 : :
2688 : 924824 : if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
2689 : : {
2690 : 865015 : if (TREE_CODE (res) != STATEMENT_LIST)
2691 : 630603 : SET_EXPR_LOCATION (res, input_location);
2692 : :
2693 : : /* Add the new statement to the block. */
2694 : 865015 : gfc_add_expr_to_block (&block, res);
2695 : : }
2696 : : }
2697 : :
2698 : : /* Return the finished block. */
2699 : 373208 : return gfc_finish_block (&block);
2700 : : }
2701 : :
2702 : :
2703 : : /* Translate an executable statement with condition, cond. The condition is
2704 : : used by gfc_trans_do to test for IO result conditions inside implied
2705 : : DO loops of READ and WRITE statements. See build_dt in trans-io.cc. */
2706 : :
2707 : : tree
2708 : 54382 : gfc_trans_code_cond (gfc_code * code, tree cond)
2709 : : {
2710 : 54382 : return trans_code (code, cond);
2711 : : }
2712 : :
2713 : : /* Translate an executable statement without condition. */
2714 : :
2715 : : tree
2716 : 320619 : gfc_trans_code (gfc_code * code)
2717 : : {
2718 : 320619 : return trans_code (code, NULL_TREE);
2719 : : }
2720 : :
2721 : :
2722 : : /* This function is called after a complete program unit has been parsed
2723 : : and resolved. */
2724 : :
2725 : : void
2726 : 34181 : gfc_generate_code (gfc_namespace * ns)
2727 : : {
2728 : 34181 : ompws_flags = 0;
2729 : 34181 : if (ns->is_block_data)
2730 : : {
2731 : 71 : gfc_generate_block_data (ns);
2732 : 71 : return;
2733 : : }
2734 : :
2735 : 34110 : gfc_generate_function_code (ns);
2736 : : }
2737 : :
2738 : :
2739 : : /* This function is called after a complete module has been parsed
2740 : : and resolved. */
2741 : :
2742 : : void
2743 : 8268 : gfc_generate_module_code (gfc_namespace * ns)
2744 : : {
2745 : 8268 : gfc_namespace *n;
2746 : 8268 : struct module_htab_entry *entry;
2747 : :
2748 : 8268 : gcc_assert (ns->proc_name->backend_decl == NULL);
2749 : 16536 : ns->proc_name->backend_decl
2750 : 8268 : = build_decl (gfc_get_location (&ns->proc_name->declared_at),
2751 : : NAMESPACE_DECL, get_identifier (ns->proc_name->name),
2752 : : void_type_node);
2753 : 8268 : entry = gfc_find_module (ns->proc_name->name);
2754 : 8268 : if (entry->namespace_decl)
2755 : : /* Buggy sourcecode, using a module before defining it? */
2756 : 0 : entry->decls->empty ();
2757 : 8268 : entry->namespace_decl = ns->proc_name->backend_decl;
2758 : :
2759 : 8268 : gfc_generate_module_vars (ns);
2760 : :
2761 : : /* We need to generate all module function prototypes first, to allow
2762 : : sibling calls. */
2763 : 30590 : for (n = ns->contained; n; n = n->sibling)
2764 : : {
2765 : 22322 : gfc_entry_list *el;
2766 : :
2767 : 22322 : if (!n->proc_name)
2768 : 0 : continue;
2769 : :
2770 : 22322 : gfc_create_function_decl (n, false);
2771 : 22322 : DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
2772 : 22322 : gfc_module_add_decl (entry, n->proc_name->backend_decl);
2773 : 22322 : for (el = ns->entries; el; el = el->next)
2774 : : {
2775 : 0 : DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
2776 : 0 : gfc_module_add_decl (entry, el->sym->backend_decl);
2777 : : }
2778 : : }
2779 : :
2780 : 30590 : for (n = ns->contained; n; n = n->sibling)
2781 : : {
2782 : 22322 : if (!n->proc_name)
2783 : 0 : continue;
2784 : :
2785 : 22322 : gfc_generate_function_code (n);
2786 : : }
2787 : 8268 : }
2788 : :
2789 : :
2790 : : /* Initialize an init/cleanup block with existing code. */
2791 : :
2792 : : void
2793 : 85782 : gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2794 : : {
2795 : 85782 : gcc_assert (block);
2796 : :
2797 : 85782 : block->init = NULL_TREE;
2798 : 85782 : block->code = code;
2799 : 85782 : block->cleanup = NULL_TREE;
2800 : 85782 : }
2801 : :
2802 : :
2803 : : /* Add a new pair of initializers/clean-up code. */
2804 : :
2805 : : void
2806 : 314809 : gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2807 : : {
2808 : 314809 : gcc_assert (block);
2809 : :
2810 : : /* The new pair of init/cleanup should be "wrapped around" the existing
2811 : : block of code, thus the initialization is added to the front and the
2812 : : cleanup to the back. */
2813 : 314809 : add_expr_to_chain (&block->init, init, true);
2814 : 314809 : add_expr_to_chain (&block->cleanup, cleanup, false);
2815 : 314809 : }
2816 : :
2817 : :
2818 : : /* Finish up a wrapped block by building a corresponding try-finally expr. */
2819 : :
2820 : : tree
2821 : 85782 : gfc_finish_wrapped_block (gfc_wrapped_block* block)
2822 : : {
2823 : 85782 : tree result;
2824 : :
2825 : 85782 : gcc_assert (block);
2826 : :
2827 : : /* Build the final expression. For this, just add init and body together,
2828 : : and put clean-up with that into a TRY_FINALLY_EXPR. */
2829 : 85782 : result = block->init;
2830 : 85782 : add_expr_to_chain (&result, block->code, false);
2831 : 85782 : if (block->cleanup)
2832 : 7764 : result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2833 : : result, block->cleanup);
2834 : :
2835 : : /* Clear the block. */
2836 : 85782 : block->init = NULL_TREE;
2837 : 85782 : block->code = NULL_TREE;
2838 : 85782 : block->cleanup = NULL_TREE;
2839 : :
2840 : 85782 : return result;
2841 : : }
2842 : :
2843 : :
2844 : : /* Helper function for marking a boolean expression tree as unlikely. */
2845 : :
2846 : : tree
2847 : 96776 : gfc_unlikely (tree cond, enum br_predictor predictor)
2848 : : {
2849 : 96776 : tree tmp;
2850 : :
2851 : 96776 : if (optimize)
2852 : : {
2853 : 82602 : cond = fold_convert (long_integer_type_node, cond);
2854 : 82602 : tmp = build_zero_cst (long_integer_type_node);
2855 : 82602 : cond = build_call_expr_loc (input_location,
2856 : : builtin_decl_explicit (BUILT_IN_EXPECT),
2857 : : 3, cond, tmp,
2858 : : build_int_cst (integer_type_node,
2859 : : predictor));
2860 : : }
2861 : 96776 : return cond;
2862 : : }
2863 : :
2864 : :
2865 : : /* Helper function for marking a boolean expression tree as likely. */
2866 : :
2867 : : tree
2868 : 1405 : gfc_likely (tree cond, enum br_predictor predictor)
2869 : : {
2870 : 1405 : tree tmp;
2871 : :
2872 : 1405 : if (optimize)
2873 : : {
2874 : 1235 : cond = fold_convert (long_integer_type_node, cond);
2875 : 1235 : tmp = build_one_cst (long_integer_type_node);
2876 : 1235 : cond = build_call_expr_loc (input_location,
2877 : : builtin_decl_explicit (BUILT_IN_EXPECT),
2878 : : 3, cond, tmp,
2879 : : build_int_cst (integer_type_node,
2880 : : predictor));
2881 : : }
2882 : 1405 : return cond;
2883 : : }
2884 : :
2885 : :
2886 : : /* Get the string length for a deferred character length component. */
2887 : :
2888 : : bool
2889 : 168141 : gfc_deferred_strlen (gfc_component *c, tree *decl)
2890 : : {
2891 : 168141 : char name[GFC_MAX_SYMBOL_LEN+9];
2892 : 168141 : gfc_component *strlen;
2893 : 168141 : if (!(c->ts.type == BT_CHARACTER
2894 : 10790 : && (c->ts.deferred || c->attr.pdt_string)))
2895 : : return false;
2896 : 4000 : sprintf (name, "_%s_length", c->name);
2897 : 12565 : for (strlen = c; strlen; strlen = strlen->next)
2898 : 12554 : if (strcmp (strlen->name, name) == 0)
2899 : : break;
2900 : 4000 : *decl = strlen ? strlen->backend_decl : NULL_TREE;
2901 : 4000 : return strlen != NULL;
2902 : : }
|
