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