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