1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook
5 This file is part of GCC.
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
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
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/>. */
23 #include "coretypes.h"
27 #include "gimple-expr.h" /* For create_tmp_var_raw. */
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"
37 /* Naming convention for backend interface code:
39 gfc_trans_* translate gfc_code into STMT trees.
41 gfc_conv_* expression conversion
43 gfc_get_* get a backend tree representation of a decl or type */
45 static gfc_file
*gfc_current_backend_file
;
47 const char gfc_msg_fault
[] = N_("Array reference out of bounds");
50 /* Return a location_t suitable for 'tree' for a gfortran locus. The way the
51 parser works in gfortran, loc->lb->location contains only the line number
52 and LOCATION_COLUMN is 0; hence, the column has to be added when generating
53 locations for 'tree'. Cf. error.cc's gfc_format_decoder. */
56 gfc_get_location (locus
*loc
)
58 return linemap_position_for_loc_and_offset (line_table
, loc
->lb
->location
,
59 loc
->nextc
- loc
->lb
->line
);
62 /* Advance along TREE_CHAIN n times. */
65 gfc_advance_chain (tree t
, int n
)
69 gcc_assert (t
!= NULL_TREE
);
77 #define MAX_PREFIX_LEN 20
80 create_var_debug_raw (tree type
, const char *prefix
)
82 /* Space for prefix + "_" + 10-digit-number + \0. */
83 char name_buf
[MAX_PREFIX_LEN
+ 1 + 10 + 1];
90 gcc_assert (strlen (prefix
) <= MAX_PREFIX_LEN
);
92 for (i
= 0; prefix
[i
] != 0; i
++)
93 name_buf
[i
] = gfc_wide_toupper (prefix
[i
]);
95 snprintf (name_buf
+ i
, sizeof (name_buf
) - i
, "_%d", num_var
++);
97 t
= build_decl (input_location
, VAR_DECL
, get_identifier (name_buf
), type
);
99 /* Not setting this causes some regressions. */
100 DECL_ARTIFICIAL (t
) = 1;
102 /* We want debug info for it. */
103 DECL_IGNORED_P (t
) = 0;
104 /* It should not be nameless. */
105 DECL_NAMELESS (t
) = 0;
107 /* Make the variable writable. */
108 TREE_READONLY (t
) = 0;
110 DECL_EXTERNAL (t
) = 0;
117 /* Creates a variable declaration with a given TYPE. */
120 gfc_create_var_np (tree type
, const char *prefix
)
124 if (flag_debug_aux_vars
)
125 return create_var_debug_raw (type
, prefix
);
127 t
= create_tmp_var_raw (type
, prefix
);
129 /* No warnings for anonymous variables. */
131 suppress_warning (t
);
137 /* Like above, but also adds it to the current scope. */
140 gfc_create_var (tree type
, const char *prefix
)
144 tmp
= gfc_create_var_np (type
, prefix
);
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. */
157 gfc_evaluate_now_loc (location_t loc
, tree expr
, stmtblock_t
* pblock
)
161 if (CONSTANT_CLASS_P (expr
))
164 var
= gfc_create_var (TREE_TYPE (expr
), NULL
);
165 gfc_add_modify_loc (loc
, pblock
, var
, expr
);
172 gfc_evaluate_now (tree expr
, stmtblock_t
* pblock
)
174 return gfc_evaluate_now_loc (input_location
, expr
, pblock
);
177 /* Like gfc_evaluate_now, but add the created variable to the
181 gfc_evaluate_now_function_scope (tree expr
, stmtblock_t
* pblock
)
184 var
= gfc_create_var_np (TREE_TYPE (expr
), NULL
);
185 gfc_add_decl_to_function (var
);
186 gfc_add_modify (pblock
, var
, expr
);
191 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
192 A MODIFY_EXPR is an assignment:
196 gfc_add_modify_loc (location_t loc
, stmtblock_t
* pblock
, tree lhs
, tree rhs
)
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
)));
210 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, lhs
,
212 gfc_add_expr_to_block (pblock
, tmp
);
217 gfc_add_modify (stmtblock_t
* pblock
, tree lhs
, tree rhs
)
219 gfc_add_modify_loc (input_location
, pblock
, lhs
, rhs
);
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. */
228 gfc_start_block (stmtblock_t
* block
)
230 /* Start a new binding level. */
232 block
->has_scope
= 1;
234 /* The block is empty. */
235 block
->head
= NULL_TREE
;
239 /* Initialize a block without creating a new scope. */
242 gfc_init_block (stmtblock_t
* block
)
244 block
->head
= NULL_TREE
;
245 block
->has_scope
= 0;
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. */
254 gfc_merge_block_scope (stmtblock_t
* block
)
259 gcc_assert (block
->has_scope
);
260 block
->has_scope
= 0;
262 /* Remember the decls in this scope. */
266 /* Add them to the parent scope. */
267 while (decl
!= NULL_TREE
)
269 next
= DECL_CHAIN (decl
);
270 DECL_CHAIN (decl
) = NULL_TREE
;
278 /* Finish a scope containing a block of statements. */
281 gfc_finish_block (stmtblock_t
* stmtblock
)
287 expr
= stmtblock
->head
;
289 expr
= build_empty_stmt (input_location
);
291 stmtblock
->head
= NULL_TREE
;
293 if (stmtblock
->has_scope
)
299 block
= poplevel (1, 0);
300 expr
= build3_v (BIND_EXPR
, decl
, expr
, block
);
310 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
311 natural type is used. */
314 gfc_build_addr_expr (tree type
, tree t
)
316 tree base_type
= TREE_TYPE (t
);
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
)))
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
));
333 natural_type
= build_pointer_type (base_type
);
335 if (TREE_CODE (t
) == INDIRECT_REF
)
339 t
= TREE_OPERAND (t
, 0);
340 natural_type
= TREE_TYPE (t
);
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
);
350 if (type
&& natural_type
!= type
)
351 t
= convert (type
, t
);
358 get_array_span (tree type
, tree decl
)
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
);
372 /* Return the span for deferred character length array references. */
373 if (type
&& TREE_CODE (type
) == ARRAY_TYPE
&& TYPE_STRING_FLAG (type
))
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
);
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
);
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
)
389 if (GFC_DECL_CLASS (decl
))
391 /* When a temporary is in place for the class array, then the
392 original class' declaration is stored in the saved
394 if (DECL_LANG_SPECIFIC (decl
) && GFC_DECL_SAVED_DESCRIPTOR (decl
))
395 decl
= GFC_DECL_SAVED_DESCRIPTOR (decl
);
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
);
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
))))
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
);
414 else if (GFC_DECL_PTR_ARRAY_P (decl
))
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
);
431 gfc_build_spanned_array_ref (tree base
, tree offset
, tree span
)
435 type
= TREE_TYPE (TREE_TYPE (base
));
436 offset
= fold_build2_loc (input_location
, MULT_EXPR
,
437 gfc_array_index_type
,
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
);
449 /* Build an ARRAY_REF with its natural type.
450 NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative,
451 and thus that an ARRAY_REF can safely be generated. If it’s false, we
452 have to play it safe and use pointer arithmetic. */
455 gfc_build_array_ref (tree base
, tree offset
, tree decl
,
456 bool non_negative_offset
, tree vptr
)
458 tree type
= TREE_TYPE (base
);
459 tree span
= NULL_TREE
;
461 if (GFC_ARRAY_TYPE_P (type
) && GFC_TYPE_ARRAY_RANK (type
) == 0)
463 gcc_assert (GFC_TYPE_ARRAY_CORANK (type
) > 0);
465 return fold_convert (TYPE_MAIN_VARIANT (type
), base
);
468 /* Scalar coarray, there is nothing to do. */
469 if (TREE_CODE (type
) != ARRAY_TYPE
)
471 gcc_assert (decl
== NULL_TREE
);
472 gcc_assert (integer_zerop (offset
));
476 type
= TREE_TYPE (type
);
479 TREE_ADDRESSABLE (base
) = 1;
481 /* Strip NON_LVALUE_EXPR nodes. */
482 STRIP_TYPE_NOPS (offset
);
484 /* If decl or vptr are non-null, pointer arithmetic for the array reference
485 is likely. Generate the 'span' for the array reference. */
488 span
= gfc_vptr_size_get (vptr
);
490 /* Check if this is an unlimited polymorphic object carrying a character
491 payload. In this case, the 'len' field is non-zero. */
492 if (decl
&& GFC_CLASS_TYPE_P (TREE_TYPE (decl
)))
493 span
= gfc_resize_class_size_with_len (NULL
, decl
, span
);
496 span
= get_array_span (type
, decl
);
498 /* If a non-null span has been generated reference the element with
499 pointer arithmetic. */
500 if (span
!= NULL_TREE
)
501 return gfc_build_spanned_array_ref (base
, offset
, span
);
502 /* Else use a straightforward array reference if possible. */
503 else if (non_negative_offset
)
504 return build4_loc (input_location
, ARRAY_REF
, type
, base
, offset
,
505 NULL_TREE
, NULL_TREE
);
506 /* Otherwise use pointer arithmetic. */
509 gcc_assert (TREE_CODE (TREE_TYPE (base
)) == ARRAY_TYPE
);
510 tree min
= NULL_TREE
;
511 if (TYPE_DOMAIN (TREE_TYPE (base
))
512 && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base
)))))
513 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base
)));
515 tree zero_based_index
516 = min
? fold_build2_loc (input_location
, MINUS_EXPR
,
517 gfc_array_index_type
,
518 fold_convert (gfc_array_index_type
, offset
),
519 fold_convert (gfc_array_index_type
, min
))
520 : fold_convert (gfc_array_index_type
, offset
);
522 tree elt_size
= fold_convert (gfc_array_index_type
,
523 TYPE_SIZE_UNIT (type
));
525 tree offset_bytes
= fold_build2_loc (input_location
, MULT_EXPR
,
526 gfc_array_index_type
,
527 zero_based_index
, elt_size
);
529 tree base_addr
= gfc_build_addr_expr (pvoid_type_node
, base
);
531 tree ptr
= fold_build_pointer_plus_loc (input_location
, base_addr
,
533 return build1_loc (input_location
, INDIRECT_REF
, type
,
534 fold_convert (build_pointer_type (type
), ptr
));
539 /* Generate a call to print a runtime error possibly including multiple
540 arguments and a locus. */
543 trans_runtime_error_vararg (tree errorfunc
, locus
* where
, const char* msgid
,
556 /* Compute the number of extra arguments from the format string. */
557 for (p
= msgid
, nargs
= 0; *p
; p
++)
565 /* The code to generate the error. */
566 gfc_start_block (&block
);
570 line
= LOCATION_LINE (where
->lb
->location
);
571 message
= xasprintf ("At line %d of file %s", line
,
572 where
->lb
->file
->filename
);
575 message
= xasprintf ("In file '%s', around line %d",
576 gfc_source_file
, LOCATION_LINE (input_location
) + 1);
578 arg
= gfc_build_addr_expr (pchar_type_node
,
579 gfc_build_localized_cstring_const (message
));
582 message
= xasprintf ("%s", _(msgid
));
583 arg2
= gfc_build_addr_expr (pchar_type_node
,
584 gfc_build_localized_cstring_const (message
));
587 /* Build the argument array. */
588 argarray
= XALLOCAVEC (tree
, nargs
+ 2);
591 for (i
= 0; i
< nargs
; i
++)
592 argarray
[2 + i
] = va_arg (ap
, tree
);
594 /* Build the function call to runtime_(warning,error)_at; because of the
595 variable number of arguments, we can't use build_call_expr_loc dinput_location,
597 fntype
= TREE_TYPE (errorfunc
);
599 loc
= where
? gfc_get_location (where
) : input_location
;
600 tmp
= fold_build_call_array_loc (loc
, TREE_TYPE (fntype
),
601 fold_build1_loc (loc
, ADDR_EXPR
,
602 build_pointer_type (fntype
),
604 nargs
+ 2, argarray
);
605 gfc_add_expr_to_block (&block
, tmp
);
607 return gfc_finish_block (&block
);
612 gfc_trans_runtime_error (bool error
, locus
* where
, const char* msgid
, ...)
617 va_start (ap
, msgid
);
618 result
= trans_runtime_error_vararg (error
619 ? gfor_fndecl_runtime_error_at
620 : gfor_fndecl_runtime_warning_at
,
627 /* Generate a runtime error if COND is true. */
630 gfc_trans_runtime_check (bool error
, bool once
, tree cond
, stmtblock_t
* pblock
,
631 locus
* where
, const char * msgid
, ...)
639 if (integer_zerop (cond
))
644 tmpvar
= gfc_create_var (boolean_type_node
, "print_warning");
645 TREE_STATIC (tmpvar
) = 1;
646 DECL_INITIAL (tmpvar
) = boolean_true_node
;
647 gfc_add_expr_to_block (pblock
, tmpvar
);
650 gfc_start_block (&block
);
652 /* For error, runtime_error_at already implies PRED_NORETURN. */
654 gfc_add_expr_to_block (&block
, build_predict_expr (PRED_FORTRAN_WARN_ONCE
,
657 /* The code to generate the error. */
658 va_start (ap
, msgid
);
659 gfc_add_expr_to_block (&block
,
660 trans_runtime_error_vararg
661 (error
? gfor_fndecl_runtime_error_at
662 : gfor_fndecl_runtime_warning_at
,
667 gfc_add_modify (&block
, tmpvar
, boolean_false_node
);
669 body
= gfc_finish_block (&block
);
671 if (integer_onep (cond
))
673 gfc_add_expr_to_block (pblock
, body
);
678 cond
= fold_build2_loc (gfc_get_location (where
), TRUTH_AND_EXPR
,
679 boolean_type_node
, tmpvar
,
680 fold_convert (boolean_type_node
, cond
));
682 tmp
= fold_build3_loc (gfc_get_location (where
), COND_EXPR
, void_type_node
,
684 build_empty_stmt (gfc_get_location (where
)));
685 gfc_add_expr_to_block (pblock
, tmp
);
691 trans_os_error_at (locus
* where
, const char* msgid
, ...)
696 va_start (ap
, msgid
);
697 result
= trans_runtime_error_vararg (gfor_fndecl_os_error_at
,
705 /* Call malloc to allocate size bytes of memory, with special conditions:
706 + if size == 0, return a malloced area of size 1,
707 + if malloc returns NULL, issue a runtime error. */
709 gfc_call_malloc (stmtblock_t
* block
, tree type
, tree size
)
711 tree tmp
, malloc_result
, null_result
, res
, malloc_tree
;
714 /* Create a variable to hold the result. */
715 res
= gfc_create_var (prvoid_type_node
, NULL
);
718 gfc_start_block (&block2
);
720 if (size
== NULL_TREE
)
721 size
= build_int_cst (size_type_node
, 1);
723 size
= fold_convert (size_type_node
, size
);
724 size
= fold_build2_loc (input_location
, MAX_EXPR
, size_type_node
, size
,
725 build_int_cst (size_type_node
, 1));
727 malloc_tree
= builtin_decl_explicit (BUILT_IN_MALLOC
);
728 gfc_add_modify (&block2
, res
,
729 fold_convert (prvoid_type_node
,
730 build_call_expr_loc (input_location
,
731 malloc_tree
, 1, size
)));
733 /* Optionally check whether malloc was successful. */
734 if (gfc_option
.rtcheck
& GFC_RTCHECK_MEM
)
736 null_result
= fold_build2_loc (input_location
, EQ_EXPR
,
737 logical_type_node
, res
,
738 build_int_cst (pvoid_type_node
, 0));
739 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
741 trans_os_error_at (NULL
,
742 "Error allocating %lu bytes",
744 (long_unsigned_type_node
,
746 build_empty_stmt (input_location
));
747 gfc_add_expr_to_block (&block2
, tmp
);
750 malloc_result
= gfc_finish_block (&block2
);
751 gfc_add_expr_to_block (block
, malloc_result
);
754 res
= fold_convert (type
, res
);
759 /* Allocate memory, using an optional status argument.
761 This function follows the following pseudo-code:
764 allocate (size_t size, integer_type stat)
771 newmem = malloc (MAX (size, 1));
775 *stat = LIBERROR_NO_MEMORY;
777 runtime_error ("Allocation would exceed memory limit");
782 gfc_allocate_using_malloc (stmtblock_t
* block
, tree pointer
,
783 tree size
, tree status
)
785 tree tmp
, error_cond
;
786 stmtblock_t on_error
;
787 tree status_type
= status
? TREE_TYPE (status
) : NULL_TREE
;
789 /* If successful and stat= is given, set status to 0. */
790 if (status
!= NULL_TREE
)
791 gfc_add_expr_to_block (block
,
792 fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
793 status
, build_int_cst (status_type
, 0)));
795 /* The allocation itself. */
796 size
= fold_convert (size_type_node
, size
);
797 gfc_add_modify (block
, pointer
,
798 fold_convert (TREE_TYPE (pointer
),
799 build_call_expr_loc (input_location
,
800 builtin_decl_explicit (BUILT_IN_MALLOC
), 1,
801 fold_build2_loc (input_location
,
802 MAX_EXPR
, size_type_node
, size
,
803 build_int_cst (size_type_node
, 1)))));
805 /* What to do in case of error. */
806 gfc_start_block (&on_error
);
807 if (status
!= NULL_TREE
)
809 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
, status
,
810 build_int_cst (status_type
, LIBERROR_NO_MEMORY
));
811 gfc_add_expr_to_block (&on_error
, tmp
);
815 /* Here, os_error_at already implies PRED_NORETURN. */
816 tree lusize
= fold_convert (long_unsigned_type_node
, size
);
817 tmp
= trans_os_error_at (NULL
, "Error allocating %lu bytes", lusize
);
818 gfc_add_expr_to_block (&on_error
, tmp
);
821 error_cond
= fold_build2_loc (input_location
, EQ_EXPR
,
822 logical_type_node
, pointer
,
823 build_int_cst (prvoid_type_node
, 0));
824 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
825 gfc_unlikely (error_cond
, PRED_FORTRAN_FAIL_ALLOC
),
826 gfc_finish_block (&on_error
),
827 build_empty_stmt (input_location
));
829 gfc_add_expr_to_block (block
, tmp
);
833 /* Allocate memory, using an optional status argument.
835 This function follows the following pseudo-code:
838 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
842 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
846 gfc_allocate_using_caf_lib (stmtblock_t
* block
, tree pointer
, tree size
,
847 tree token
, tree status
, tree errmsg
, tree errlen
,
848 gfc_coarray_regtype alloc_type
)
852 gcc_assert (token
!= NULL_TREE
);
854 /* The allocation itself. */
855 if (status
== NULL_TREE
)
856 pstat
= null_pointer_node
;
858 pstat
= gfc_build_addr_expr (NULL_TREE
, status
);
860 if (errmsg
== NULL_TREE
)
862 gcc_assert(errlen
== NULL_TREE
);
863 errmsg
= null_pointer_node
;
864 errlen
= build_int_cst (integer_type_node
, 0);
867 size
= fold_convert (size_type_node
, size
);
868 tmp
= build_call_expr_loc (input_location
,
869 gfor_fndecl_caf_register
, 7,
870 fold_build2_loc (input_location
,
871 MAX_EXPR
, size_type_node
, size
, size_one_node
),
872 build_int_cst (integer_type_node
, alloc_type
),
873 token
, gfc_build_addr_expr (pvoid_type_node
, pointer
),
874 pstat
, errmsg
, errlen
);
876 gfc_add_expr_to_block (block
, tmp
);
878 /* It guarantees memory consistency within the same segment */
879 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
880 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
881 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
882 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
883 ASM_VOLATILE_P (tmp
) = 1;
884 gfc_add_expr_to_block (block
, tmp
);
888 /* Generate code for an ALLOCATE statement when the argument is an
889 allocatable variable. If the variable is currently allocated, it is an
890 error to allocate it again.
892 This function follows the following pseudo-code:
895 allocate_allocatable (void *mem, size_t size, integer_type stat)
898 return allocate (size, stat);
902 stat = LIBERROR_ALLOCATION;
904 runtime_error ("Attempting to allocate already allocated variable");
908 expr must be set to the original expression being allocated for its locus
909 and variable name in case a runtime error has to be printed. */
911 gfc_allocate_allocatable (stmtblock_t
* block
, tree mem
, tree size
,
912 tree token
, tree status
, tree errmsg
, tree errlen
,
913 tree label_finish
, gfc_expr
* expr
, int corank
)
915 stmtblock_t alloc_block
;
916 tree tmp
, null_mem
, alloc
, error
;
917 tree type
= TREE_TYPE (mem
);
918 symbol_attribute caf_attr
;
919 bool need_assign
= false, refs_comp
= false;
920 gfc_coarray_regtype caf_alloc_type
= GFC_CAF_COARRAY_ALLOC
;
922 size
= fold_convert (size_type_node
, size
);
923 null_mem
= gfc_unlikely (fold_build2_loc (input_location
, NE_EXPR
,
924 logical_type_node
, mem
,
925 build_int_cst (type
, 0)),
926 PRED_FORTRAN_REALLOC
);
928 /* If mem is NULL, we call gfc_allocate_using_malloc or
929 gfc_allocate_using_lib. */
930 gfc_start_block (&alloc_block
);
932 if (flag_coarray
== GFC_FCOARRAY_LIB
)
933 caf_attr
= gfc_caf_attr (expr
, true, &refs_comp
);
935 if (flag_coarray
== GFC_FCOARRAY_LIB
936 && (corank
> 0 || caf_attr
.codimension
))
938 tree cond
, sub_caf_tree
;
940 bool compute_special_caf_types_size
= false;
942 if (expr
->ts
.type
== BT_DERIVED
943 && expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
944 && expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
946 compute_special_caf_types_size
= true;
947 caf_alloc_type
= GFC_CAF_LOCK_ALLOC
;
949 else if (expr
->ts
.type
== BT_DERIVED
950 && expr
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
951 && expr
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
953 compute_special_caf_types_size
= true;
954 caf_alloc_type
= GFC_CAF_EVENT_ALLOC
;
956 else if (!caf_attr
.coarray_comp
&& refs_comp
)
957 /* Only allocatable components in a derived type coarray can be
959 caf_alloc_type
= GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY
;
961 gfc_init_se (&se
, NULL
);
962 sub_caf_tree
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&se
, expr
);
963 if (sub_caf_tree
== NULL_TREE
)
964 sub_caf_tree
= token
;
966 /* When mem is an array ref, then strip the .data-ref. */
967 if (TREE_CODE (mem
) == COMPONENT_REF
968 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem
))))
969 tmp
= TREE_OPERAND (mem
, 0);
973 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp
))
974 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp
))->corank
== 0)
975 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
977 symbol_attribute attr
;
979 gfc_clear_attr (&attr
);
980 tmp
= gfc_conv_scalar_to_descriptor (&se
, mem
, attr
);
983 gfc_add_block_to_block (&alloc_block
, &se
.pre
);
985 /* In the front end, we represent the lock variable as pointer. However,
986 the FE only passes the pointer around and leaves the actual
987 representation to the library. Hence, we have to convert back to the
988 number of elements. */
989 if (compute_special_caf_types_size
)
990 size
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, size_type_node
,
991 size
, TYPE_SIZE_UNIT (ptr_type_node
));
993 gfc_allocate_using_caf_lib (&alloc_block
, tmp
, size
, sub_caf_tree
,
994 status
, errmsg
, errlen
, caf_alloc_type
);
996 gfc_add_modify (&alloc_block
, mem
, fold_convert (TREE_TYPE (mem
),
997 gfc_conv_descriptor_data_get (tmp
)));
998 if (status
!= NULL_TREE
)
1000 TREE_USED (label_finish
) = 1;
1001 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1002 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1003 status
, build_zero_cst (TREE_TYPE (status
)));
1004 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1005 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
1006 tmp
, build_empty_stmt (input_location
));
1007 gfc_add_expr_to_block (&alloc_block
, tmp
);
1011 gfc_allocate_using_malloc (&alloc_block
, mem
, size
, status
);
1013 alloc
= gfc_finish_block (&alloc_block
);
1015 /* If mem is not NULL, we issue a runtime error or set the
1021 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1022 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1023 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1025 error
= gfc_trans_runtime_error (true, &expr
->where
,
1026 "Attempting to allocate already"
1027 " allocated variable '%s'",
1031 error
= gfc_trans_runtime_error (true, NULL
,
1032 "Attempting to allocate already allocated"
1035 if (status
!= NULL_TREE
)
1037 tree status_type
= TREE_TYPE (status
);
1039 error
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1040 status
, build_int_cst (status_type
, LIBERROR_ALLOCATION
));
1043 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, null_mem
,
1045 gfc_add_expr_to_block (block
, tmp
);
1049 /* Free a given variable. */
1052 gfc_call_free (tree var
)
1054 return build_call_expr_loc (input_location
,
1055 builtin_decl_explicit (BUILT_IN_FREE
),
1056 1, fold_convert (pvoid_type_node
, var
));
1060 /* Build a call to a FINAL procedure, which finalizes "var". */
1063 gfc_build_final_call (gfc_typespec ts
, gfc_expr
*final_wrapper
, gfc_expr
*var
,
1064 bool fini_coarray
, gfc_expr
*class_size
)
1068 tree final_fndecl
, array
, size
, tmp
;
1069 symbol_attribute attr
;
1071 gcc_assert (final_wrapper
->expr_type
== EXPR_VARIABLE
);
1074 gfc_start_block (&block
);
1075 gfc_init_se (&se
, NULL
);
1076 gfc_conv_expr (&se
, final_wrapper
);
1077 final_fndecl
= se
.expr
;
1078 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1079 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1081 if (ts
.type
== BT_DERIVED
)
1085 gcc_assert (!class_size
);
1086 elem_size
= gfc_typenode_for_spec (&ts
);
1087 elem_size
= TYPE_SIZE_UNIT (elem_size
);
1088 size
= fold_convert (gfc_array_index_type
, elem_size
);
1090 gfc_init_se (&se
, NULL
);
1091 se
.want_pointer
= 1;
1094 se
.descriptor_only
= 1;
1095 gfc_conv_expr_descriptor (&se
, var
);
1100 gfc_conv_expr (&se
, var
);
1101 gcc_assert (se
.pre
.head
== NULL_TREE
&& se
.post
.head
== NULL_TREE
);
1104 /* No copy back needed, hence set attr's allocatable/pointer
1106 gfc_clear_attr (&attr
);
1107 gfc_init_se (&se
, NULL
);
1108 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1109 gcc_assert (se
.post
.head
== NULL_TREE
);
1114 gfc_expr
*array_expr
;
1115 gcc_assert (class_size
);
1116 gfc_init_se (&se
, NULL
);
1117 gfc_conv_expr (&se
, class_size
);
1118 gfc_add_block_to_block (&block
, &se
.pre
);
1119 gcc_assert (se
.post
.head
== NULL_TREE
);
1122 array_expr
= gfc_copy_expr (var
);
1123 gfc_init_se (&se
, NULL
);
1124 se
.want_pointer
= 1;
1125 if (array_expr
->rank
)
1127 gfc_add_class_array_ref (array_expr
);
1128 se
.descriptor_only
= 1;
1129 gfc_conv_expr_descriptor (&se
, array_expr
);
1134 gfc_add_data_component (array_expr
);
1135 gfc_conv_expr (&se
, array_expr
);
1136 gfc_add_block_to_block (&block
, &se
.pre
);
1137 gcc_assert (se
.post
.head
== NULL_TREE
);
1140 if (!gfc_is_coarray (array_expr
))
1142 /* No copy back needed, hence set attr's allocatable/pointer
1144 gfc_clear_attr (&attr
);
1145 gfc_init_se (&se
, NULL
);
1146 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1148 gcc_assert (se
.post
.head
== NULL_TREE
);
1150 gfc_free_expr (array_expr
);
1153 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1154 array
= gfc_build_addr_expr (NULL
, array
);
1156 gfc_add_block_to_block (&block
, &se
.pre
);
1157 tmp
= build_call_expr_loc (input_location
,
1158 final_fndecl
, 3, array
,
1159 size
, fini_coarray
? boolean_true_node
1160 : boolean_false_node
);
1161 gfc_add_block_to_block (&block
, &se
.post
);
1162 gfc_add_expr_to_block (&block
, tmp
);
1163 return gfc_finish_block (&block
);
1168 gfc_add_comp_finalizer_call (stmtblock_t
*block
, tree decl
, gfc_component
*comp
,
1173 tree final_fndecl
, size
, array
, tmp
, cond
;
1174 symbol_attribute attr
;
1175 gfc_expr
*final_expr
= NULL
;
1177 if (comp
->ts
.type
!= BT_DERIVED
&& comp
->ts
.type
!= BT_CLASS
)
1180 gfc_init_block (&block2
);
1182 if (comp
->ts
.type
== BT_DERIVED
)
1184 if (comp
->attr
.pointer
)
1187 gfc_is_finalizable (comp
->ts
.u
.derived
, &final_expr
);
1191 gfc_init_se (&se
, NULL
);
1192 gfc_conv_expr (&se
, final_expr
);
1193 final_fndecl
= se
.expr
;
1194 size
= gfc_typenode_for_spec (&comp
->ts
);
1195 size
= TYPE_SIZE_UNIT (size
);
1196 size
= fold_convert (gfc_array_index_type
, size
);
1200 else /* comp->ts.type == BT_CLASS. */
1202 if (CLASS_DATA (comp
)->attr
.class_pointer
)
1205 gfc_is_finalizable (CLASS_DATA (comp
)->ts
.u
.derived
, &final_expr
);
1206 final_fndecl
= gfc_class_vtab_final_get (decl
);
1207 size
= gfc_class_vtab_size_get (decl
);
1208 array
= gfc_class_data_get (decl
);
1211 if (comp
->attr
.allocatable
1212 || (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->attr
.allocatable
))
1214 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
))
1215 ? gfc_conv_descriptor_data_get (array
) : array
;
1216 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1217 tmp
, fold_convert (TREE_TYPE (tmp
),
1218 null_pointer_node
));
1221 cond
= logical_true_node
;
1223 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array
)))
1225 gfc_clear_attr (&attr
);
1226 gfc_init_se (&se
, NULL
);
1227 array
= gfc_conv_scalar_to_descriptor (&se
, array
, attr
);
1228 gfc_add_block_to_block (&block2
, &se
.pre
);
1229 gcc_assert (se
.post
.head
== NULL_TREE
);
1232 if (!POINTER_TYPE_P (TREE_TYPE (array
)))
1233 array
= gfc_build_addr_expr (NULL
, array
);
1237 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1239 fold_convert (TREE_TYPE (final_fndecl
),
1240 null_pointer_node
));
1241 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1242 logical_type_node
, cond
, tmp
);
1245 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl
)))
1246 final_fndecl
= build_fold_indirect_ref_loc (input_location
, final_fndecl
);
1248 tmp
= build_call_expr_loc (input_location
,
1249 final_fndecl
, 3, array
,
1250 size
, fini_coarray
? boolean_true_node
1251 : boolean_false_node
);
1252 gfc_add_expr_to_block (&block2
, tmp
);
1253 tmp
= gfc_finish_block (&block2
);
1255 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
, tmp
,
1256 build_empty_stmt (input_location
));
1257 gfc_add_expr_to_block (block
, tmp
);
1263 /* Add a call to the finalizer, using the passed *expr. Returns
1264 true when a finalizer call has been inserted. */
1267 gfc_add_finalizer_call (stmtblock_t
*block
, gfc_expr
*expr2
)
1272 gfc_expr
*final_expr
= NULL
;
1273 gfc_expr
*elem_size
= NULL
;
1274 bool has_finalizer
= false;
1276 if (!expr2
|| (expr2
->ts
.type
!= BT_DERIVED
&& expr2
->ts
.type
!= BT_CLASS
))
1279 if (expr2
->ts
.type
== BT_DERIVED
)
1281 gfc_is_finalizable (expr2
->ts
.u
.derived
, &final_expr
);
1286 /* If we have a class array, we need go back to the class
1288 expr
= gfc_copy_expr (expr2
);
1290 if (expr
->ref
&& expr
->ref
->next
&& !expr
->ref
->next
->next
1291 && expr
->ref
->next
->type
== REF_ARRAY
1292 && expr
->ref
->type
== REF_COMPONENT
1293 && strcmp (expr
->ref
->u
.c
.component
->name
, "_data") == 0)
1295 gfc_free_ref_list (expr
->ref
);
1299 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1300 if (ref
->next
&& ref
->next
->next
&& !ref
->next
->next
->next
1301 && ref
->next
->next
->type
== REF_ARRAY
1302 && ref
->next
->type
== REF_COMPONENT
1303 && strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0)
1305 gfc_free_ref_list (ref
->next
);
1309 if (expr
->ts
.type
== BT_CLASS
)
1311 has_finalizer
= gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
);
1313 if (!expr2
->rank
&& !expr2
->ref
&& CLASS_DATA (expr2
->symtree
->n
.sym
)->as
)
1314 expr
->rank
= CLASS_DATA (expr2
->symtree
->n
.sym
)->as
->rank
;
1316 final_expr
= gfc_copy_expr (expr
);
1317 gfc_add_vptr_component (final_expr
);
1318 gfc_add_final_component (final_expr
);
1320 elem_size
= gfc_copy_expr (expr
);
1321 gfc_add_vptr_component (elem_size
);
1322 gfc_add_size_component (elem_size
);
1325 gcc_assert (final_expr
->expr_type
== EXPR_VARIABLE
);
1327 tmp
= gfc_build_final_call (expr
->ts
, final_expr
, expr
,
1330 if (expr
->ts
.type
== BT_CLASS
&& !has_finalizer
)
1335 gfc_init_se (&se
, NULL
);
1336 se
.want_pointer
= 1;
1337 gfc_conv_expr (&se
, final_expr
);
1338 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1339 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
1341 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1342 but already sym->_vtab itself. */
1343 if (UNLIMITED_POLY (expr
))
1346 gfc_expr
*vptr_expr
;
1348 vptr_expr
= gfc_copy_expr (expr
);
1349 gfc_add_vptr_component (vptr_expr
);
1351 gfc_init_se (&se
, NULL
);
1352 se
.want_pointer
= 1;
1353 gfc_conv_expr (&se
, vptr_expr
);
1354 gfc_free_expr (vptr_expr
);
1356 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1358 build_int_cst (TREE_TYPE (se
.expr
), 0));
1359 cond
= fold_build2_loc (input_location
, TRUTH_ANDIF_EXPR
,
1360 logical_type_node
, cond2
, cond
);
1363 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1364 cond
, tmp
, build_empty_stmt (input_location
));
1367 gfc_add_expr_to_block (block
, tmp
);
1373 /* User-deallocate; we emit the code directly from the front-end, and the
1374 logic is the same as the previous library function:
1377 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1384 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1394 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1395 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1396 even when no status variable is passed to us (this is used for
1397 unconditional deallocation generated by the front-end at end of
1400 If a runtime-message is possible, `expr' must point to the original
1401 expression being deallocated for its locus and variable name.
1403 For coarrays, "pointer" must be the array descriptor and not its
1406 COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are
1407 the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
1408 analyzed and set by this routine, and -2 to indicate that a non-coarray is to
1411 gfc_deallocate_with_status (tree pointer
, tree status
, tree errmsg
,
1412 tree errlen
, tree label_finish
,
1413 bool can_fail
, gfc_expr
* expr
,
1414 int coarray_dealloc_mode
, tree add_when_allocated
,
1417 stmtblock_t null
, non_null
;
1418 tree cond
, tmp
, error
;
1419 tree status_type
= NULL_TREE
;
1420 tree token
= NULL_TREE
;
1421 gfc_coarray_deregtype caf_dereg_type
= GFC_CAF_COARRAY_DEREGISTER
;
1423 if (coarray_dealloc_mode
>= GFC_CAF_COARRAY_ANALYZE
)
1425 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1431 tree caf_type
, caf_decl
= pointer
;
1432 pointer
= gfc_conv_descriptor_data_get (caf_decl
);
1433 caf_type
= TREE_TYPE (caf_decl
);
1434 STRIP_NOPS (pointer
);
1435 if (GFC_DESCRIPTOR_TYPE_P (caf_type
))
1436 token
= gfc_conv_descriptor_token (caf_decl
);
1437 else if (DECL_LANG_SPECIFIC (caf_decl
)
1438 && GFC_DECL_TOKEN (caf_decl
) != NULL_TREE
)
1439 token
= GFC_DECL_TOKEN (caf_decl
);
1442 gcc_assert (GFC_ARRAY_TYPE_P (caf_type
)
1443 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
)
1445 token
= GFC_TYPE_ARRAY_CAF_TOKEN (caf_type
);
1449 if (coarray_dealloc_mode
== GFC_CAF_COARRAY_ANALYZE
)
1452 if (expr
&& !gfc_caf_attr (expr
, false, &comp_ref
).coarray_comp
1454 caf_dereg_type
= GFC_CAF_COARRAY_DEALLOCATE_ONLY
;
1455 // else do a deregister as set by default.
1458 caf_dereg_type
= (enum gfc_coarray_deregtype
) coarray_dealloc_mode
;
1460 else if (flag_coarray
== GFC_FCOARRAY_SINGLE
)
1461 pointer
= gfc_conv_descriptor_data_get (pointer
);
1463 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)))
1464 pointer
= gfc_conv_descriptor_data_get (pointer
);
1466 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pointer
,
1467 build_int_cst (TREE_TYPE (pointer
), 0));
1469 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1470 we emit a runtime error. */
1471 gfc_start_block (&null
);
1476 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1478 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1479 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1481 error
= gfc_trans_runtime_error (true, &expr
->where
,
1482 "Attempt to DEALLOCATE unallocated '%s'",
1486 error
= build_empty_stmt (input_location
);
1488 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1492 status_type
= TREE_TYPE (TREE_TYPE (status
));
1493 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1494 status
, 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
, 1));
1499 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1503 gfc_add_expr_to_block (&null
, error
);
1505 /* When POINTER is not NULL, we free it. */
1506 gfc_start_block (&non_null
);
1507 if (add_when_allocated
)
1508 gfc_add_expr_to_block (&non_null
, add_when_allocated
);
1509 gfc_add_finalizer_call (&non_null
, expr
);
1510 if (coarray_dealloc_mode
== GFC_CAF_COARRAY_NOCOARRAY
1511 || flag_coarray
!= GFC_FCOARRAY_LIB
)
1513 tmp
= build_call_expr_loc (input_location
,
1514 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1515 fold_convert (pvoid_type_node
, pointer
));
1516 gfc_add_expr_to_block (&non_null
, tmp
);
1517 gfc_add_modify (&non_null
, pointer
, build_int_cst (TREE_TYPE (pointer
),
1520 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1522 /* We set STATUS to zero if it is present. */
1523 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1526 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1528 build_int_cst (TREE_TYPE (status
), 0));
1529 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1530 fold_build1_loc (input_location
, INDIRECT_REF
,
1531 status_type
, status
),
1532 build_int_cst (status_type
, 0));
1533 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1534 gfc_unlikely (cond2
, PRED_FORTRAN_FAIL_ALLOC
),
1535 tmp
, build_empty_stmt (input_location
));
1536 gfc_add_expr_to_block (&non_null
, tmp
);
1541 tree cond2
, pstat
= null_pointer_node
;
1543 if (errmsg
== NULL_TREE
)
1545 gcc_assert (errlen
== NULL_TREE
);
1546 errmsg
= null_pointer_node
;
1547 errlen
= build_zero_cst (integer_type_node
);
1551 gcc_assert (errlen
!= NULL_TREE
);
1552 if (!POINTER_TYPE_P (TREE_TYPE (errmsg
)))
1553 errmsg
= gfc_build_addr_expr (NULL_TREE
, errmsg
);
1556 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1558 gcc_assert (status_type
== integer_type_node
);
1562 token
= gfc_build_addr_expr (NULL_TREE
, token
);
1563 gcc_assert (caf_dereg_type
> GFC_CAF_COARRAY_ANALYZE
);
1564 tmp
= build_call_expr_loc (input_location
,
1565 gfor_fndecl_caf_deregister
, 5,
1566 token
, build_int_cst (integer_type_node
,
1568 pstat
, errmsg
, errlen
);
1569 gfc_add_expr_to_block (&non_null
, tmp
);
1571 /* It guarantees memory consistency within the same segment */
1572 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1573 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1574 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1575 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1576 ASM_VOLATILE_P (tmp
) = 1;
1577 gfc_add_expr_to_block (&non_null
, tmp
);
1579 if (status
!= NULL_TREE
)
1581 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1582 tree nullify
= fold_build2_loc (input_location
, MODIFY_EXPR
,
1583 void_type_node
, pointer
,
1584 build_int_cst (TREE_TYPE (pointer
),
1587 TREE_USED (label_finish
) = 1;
1588 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1589 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1590 stat
, build_zero_cst (TREE_TYPE (stat
)));
1591 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1592 gfc_unlikely (cond2
, PRED_FORTRAN_REALLOC
),
1594 gfc_add_expr_to_block (&non_null
, tmp
);
1597 gfc_add_modify (&non_null
, pointer
, build_int_cst (TREE_TYPE (pointer
),
1601 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1602 gfc_finish_block (&null
),
1603 gfc_finish_block (&non_null
));
1607 /* Generate code for deallocation of allocatable scalars (variables or
1608 components). Before the object itself is freed, any allocatable
1609 subcomponents are being deallocated. */
1612 gfc_deallocate_scalar_with_status (tree pointer
, tree status
, tree label_finish
,
1613 bool can_fail
, gfc_expr
* expr
,
1614 gfc_typespec ts
, bool coarray
)
1616 stmtblock_t null
, non_null
;
1617 tree cond
, tmp
, error
;
1618 bool finalizable
, comp_ref
;
1619 gfc_coarray_deregtype caf_dereg_type
= GFC_CAF_COARRAY_DEREGISTER
;
1621 if (coarray
&& expr
&& !gfc_caf_attr (expr
, false, &comp_ref
).coarray_comp
1623 caf_dereg_type
= GFC_CAF_COARRAY_DEALLOCATE_ONLY
;
1625 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, pointer
,
1626 build_int_cst (TREE_TYPE (pointer
), 0));
1628 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1629 we emit a runtime error. */
1630 gfc_start_block (&null
);
1635 gcc_assert (expr
&& expr
->expr_type
== EXPR_VARIABLE
&& expr
->symtree
);
1637 varname
= gfc_build_cstring_const (expr
->symtree
->name
);
1638 varname
= gfc_build_addr_expr (pchar_type_node
, varname
);
1640 error
= gfc_trans_runtime_error (true, &expr
->where
,
1641 "Attempt to DEALLOCATE unallocated '%s'",
1645 error
= build_empty_stmt (input_location
);
1647 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1649 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1652 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1653 status
, build_int_cst (TREE_TYPE (status
), 0));
1654 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1655 fold_build1_loc (input_location
, INDIRECT_REF
,
1656 status_type
, status
),
1657 build_int_cst (status_type
, 1));
1658 error
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1661 gfc_add_expr_to_block (&null
, error
);
1663 /* When POINTER is not NULL, we free it. */
1664 gfc_start_block (&non_null
);
1666 /* Free allocatable components. */
1667 finalizable
= gfc_add_finalizer_call (&non_null
, expr
);
1668 if (!finalizable
&& ts
.type
== BT_DERIVED
&& ts
.u
.derived
->attr
.alloc_comp
)
1670 int caf_mode
= coarray
1671 ? ((caf_dereg_type
== GFC_CAF_COARRAY_DEALLOCATE_ONLY
1672 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0)
1673 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
1674 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY
)
1676 if (coarray
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer
)))
1677 tmp
= gfc_conv_descriptor_data_get (pointer
);
1679 tmp
= build_fold_indirect_ref_loc (input_location
, pointer
);
1680 tmp
= gfc_deallocate_alloc_comp (ts
.u
.derived
, tmp
, 0, caf_mode
);
1681 gfc_add_expr_to_block (&non_null
, tmp
);
1684 if (!coarray
|| flag_coarray
== GFC_FCOARRAY_SINGLE
)
1686 tmp
= build_call_expr_loc (input_location
,
1687 builtin_decl_explicit (BUILT_IN_FREE
), 1,
1688 fold_convert (pvoid_type_node
, pointer
));
1689 gfc_add_expr_to_block (&non_null
, tmp
);
1691 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1693 /* We set STATUS to zero if it is present. */
1694 tree status_type
= TREE_TYPE (TREE_TYPE (status
));
1697 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1699 build_int_cst (TREE_TYPE (status
), 0));
1700 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, status_type
,
1701 fold_build1_loc (input_location
, INDIRECT_REF
,
1702 status_type
, status
),
1703 build_int_cst (status_type
, 0));
1704 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1705 cond2
, tmp
, build_empty_stmt (input_location
));
1706 gfc_add_expr_to_block (&non_null
, tmp
);
1712 tree pstat
= null_pointer_node
;
1715 gfc_init_se (&se
, NULL
);
1716 token
= gfc_get_ultimate_alloc_ptr_comps_caf_token (&se
, expr
);
1717 gcc_assert (token
!= NULL_TREE
);
1719 if (status
!= NULL_TREE
&& !integer_zerop (status
))
1721 gcc_assert (TREE_TYPE (TREE_TYPE (status
)) == integer_type_node
);
1725 tmp
= build_call_expr_loc (input_location
,
1726 gfor_fndecl_caf_deregister
, 5,
1727 token
, build_int_cst (integer_type_node
,
1729 pstat
, null_pointer_node
, integer_zero_node
);
1730 gfc_add_expr_to_block (&non_null
, tmp
);
1732 /* It guarantees memory consistency within the same segment. */
1733 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory");
1734 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1735 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1736 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1737 ASM_VOLATILE_P (tmp
) = 1;
1738 gfc_add_expr_to_block (&non_null
, tmp
);
1740 if (status
!= NULL_TREE
)
1742 tree stat
= build_fold_indirect_ref_loc (input_location
, status
);
1745 TREE_USED (label_finish
) = 1;
1746 tmp
= build1_v (GOTO_EXPR
, label_finish
);
1747 cond2
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1748 stat
, build_zero_cst (TREE_TYPE (stat
)));
1749 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1750 gfc_unlikely (cond2
, PRED_FORTRAN_REALLOC
),
1751 tmp
, build_empty_stmt (input_location
));
1752 gfc_add_expr_to_block (&non_null
, tmp
);
1756 return fold_build3_loc (input_location
, COND_EXPR
, void_type_node
, cond
,
1757 gfc_finish_block (&null
),
1758 gfc_finish_block (&non_null
));
1761 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1762 following pseudo-code:
1765 internal_realloc (void *mem, size_t size)
1767 res = realloc (mem, size);
1768 if (!res && size != 0)
1769 _gfortran_os_error ("Allocation would exceed memory limit");
1774 gfc_call_realloc (stmtblock_t
* block
, tree mem
, tree size
)
1776 tree res
, nonzero
, null_result
, tmp
;
1777 tree type
= TREE_TYPE (mem
);
1779 /* Only evaluate the size once. */
1780 size
= save_expr (fold_convert (size_type_node
, size
));
1782 /* Create a variable to hold the result. */
1783 res
= gfc_create_var (type
, NULL
);
1785 /* Call realloc and check the result. */
1786 tmp
= build_call_expr_loc (input_location
,
1787 builtin_decl_explicit (BUILT_IN_REALLOC
), 2,
1788 fold_convert (pvoid_type_node
, mem
), size
);
1789 gfc_add_modify (block
, res
, fold_convert (type
, tmp
));
1790 null_result
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
1791 res
, build_int_cst (pvoid_type_node
, 0));
1792 nonzero
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, size
,
1793 build_int_cst (size_type_node
, 0));
1794 null_result
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, logical_type_node
,
1795 null_result
, nonzero
);
1796 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1798 trans_os_error_at (NULL
,
1799 "Error reallocating to %lu bytes",
1801 (long_unsigned_type_node
, size
)),
1802 build_empty_stmt (input_location
));
1803 gfc_add_expr_to_block (block
, tmp
);
1809 /* Add an expression to another one, either at the front or the back. */
1812 add_expr_to_chain (tree
* chain
, tree expr
, bool front
)
1814 if (expr
== NULL_TREE
|| IS_EMPTY_STMT (expr
))
1819 if (TREE_CODE (*chain
) != STATEMENT_LIST
)
1825 append_to_statement_list (tmp
, chain
);
1830 tree_stmt_iterator i
;
1832 i
= tsi_start (*chain
);
1833 tsi_link_before (&i
, expr
, TSI_CONTINUE_LINKING
);
1836 append_to_statement_list (expr
, chain
);
1843 /* Add a statement at the end of a block. */
1846 gfc_add_expr_to_block (stmtblock_t
* block
, tree expr
)
1849 add_expr_to_chain (&block
->head
, expr
, false);
1853 /* Add a statement at the beginning of a block. */
1856 gfc_prepend_expr_to_block (stmtblock_t
* block
, tree expr
)
1859 add_expr_to_chain (&block
->head
, expr
, true);
1863 /* Add a block the end of a block. */
1866 gfc_add_block_to_block (stmtblock_t
* block
, stmtblock_t
* append
)
1868 gcc_assert (append
);
1869 gcc_assert (!append
->has_scope
);
1871 gfc_add_expr_to_block (block
, append
->head
);
1872 append
->head
= NULL_TREE
;
1876 /* Save the current locus. The structure may not be complete, and should
1877 only be used with gfc_restore_backend_locus. */
1880 gfc_save_backend_locus (locus
* loc
)
1882 loc
->lb
= XCNEW (gfc_linebuf
);
1883 loc
->lb
->location
= input_location
;
1884 loc
->lb
->file
= gfc_current_backend_file
;
1888 /* Set the current locus. */
1891 gfc_set_backend_locus (locus
* loc
)
1893 gfc_current_backend_file
= loc
->lb
->file
;
1894 input_location
= gfc_get_location (loc
);
1898 /* Restore the saved locus. Only used in conjunction with
1899 gfc_save_backend_locus, to free the memory when we are done. */
1902 gfc_restore_backend_locus (locus
* loc
)
1904 /* This only restores the information captured by gfc_save_backend_locus,
1905 intentionally does not use gfc_get_location. */
1906 input_location
= loc
->lb
->location
;
1907 gfc_current_backend_file
= loc
->lb
->file
;
1912 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1913 This static function is wrapped by gfc_trans_code_cond and
1917 trans_code (gfc_code
* code
, tree cond
)
1923 return build_empty_stmt (input_location
);
1925 gfc_start_block (&block
);
1927 /* Translate statements one by one into GENERIC trees until we reach
1928 the end of this gfc_code branch. */
1929 for (; code
; code
= code
->next
)
1931 if (code
->here
!= 0)
1933 res
= gfc_trans_label_here (code
);
1934 gfc_add_expr_to_block (&block
, res
);
1937 gfc_current_locus
= code
->loc
;
1938 gfc_set_backend_locus (&code
->loc
);
1943 case EXEC_END_BLOCK
:
1944 case EXEC_END_NESTED_BLOCK
:
1945 case EXEC_END_PROCEDURE
:
1950 res
= gfc_trans_assign (code
);
1953 case EXEC_LABEL_ASSIGN
:
1954 res
= gfc_trans_label_assign (code
);
1957 case EXEC_POINTER_ASSIGN
:
1958 res
= gfc_trans_pointer_assign (code
);
1961 case EXEC_INIT_ASSIGN
:
1962 if (code
->expr1
->ts
.type
== BT_CLASS
)
1963 res
= gfc_trans_class_init_assign (code
);
1965 res
= gfc_trans_init_assign (code
);
1973 res
= gfc_trans_critical (code
);
1977 res
= gfc_trans_cycle (code
);
1981 res
= gfc_trans_exit (code
);
1985 res
= gfc_trans_goto (code
);
1989 res
= gfc_trans_entry (code
);
1993 res
= gfc_trans_pause (code
);
1997 case EXEC_ERROR_STOP
:
1998 res
= gfc_trans_stop (code
, code
->op
== EXEC_ERROR_STOP
);
2002 /* For MVBITS we've got the special exception that we need a
2003 dependency check, too. */
2005 bool is_mvbits
= false;
2007 if (code
->resolved_isym
)
2009 res
= gfc_conv_intrinsic_subroutine (code
);
2010 if (res
!= NULL_TREE
)
2014 if (code
->resolved_isym
2015 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
)
2018 res
= gfc_trans_call (code
, is_mvbits
, NULL_TREE
,
2024 res
= gfc_trans_call (code
, false, NULL_TREE
,
2028 case EXEC_ASSIGN_CALL
:
2029 res
= gfc_trans_call (code
, true, NULL_TREE
,
2034 res
= gfc_trans_return (code
);
2038 res
= gfc_trans_if (code
);
2041 case EXEC_ARITHMETIC_IF
:
2042 res
= gfc_trans_arithmetic_if (code
);
2046 res
= gfc_trans_block_construct (code
);
2050 res
= gfc_trans_do (code
, cond
);
2053 case EXEC_DO_CONCURRENT
:
2054 res
= gfc_trans_do_concurrent (code
);
2058 res
= gfc_trans_do_while (code
);
2062 res
= gfc_trans_select (code
);
2065 case EXEC_SELECT_TYPE
:
2066 res
= gfc_trans_select_type (code
);
2069 case EXEC_SELECT_RANK
:
2070 res
= gfc_trans_select_rank (code
);
2074 res
= gfc_trans_flush (code
);
2078 case EXEC_SYNC_IMAGES
:
2079 case EXEC_SYNC_MEMORY
:
2080 res
= gfc_trans_sync (code
, code
->op
);
2085 res
= gfc_trans_lock_unlock (code
, code
->op
);
2088 case EXEC_EVENT_POST
:
2089 case EXEC_EVENT_WAIT
:
2090 res
= gfc_trans_event_post_wait (code
, code
->op
);
2093 case EXEC_FAIL_IMAGE
:
2094 res
= gfc_trans_fail_image (code
);
2098 res
= gfc_trans_forall (code
);
2101 case EXEC_FORM_TEAM
:
2102 res
= gfc_trans_form_team (code
);
2105 case EXEC_CHANGE_TEAM
:
2106 res
= gfc_trans_change_team (code
);
2110 res
= gfc_trans_end_team (code
);
2113 case EXEC_SYNC_TEAM
:
2114 res
= gfc_trans_sync_team (code
);
2118 res
= gfc_trans_where (code
);
2122 res
= gfc_trans_allocate (code
);
2125 case EXEC_DEALLOCATE
:
2126 res
= gfc_trans_deallocate (code
);
2130 res
= gfc_trans_open (code
);
2134 res
= gfc_trans_close (code
);
2138 res
= gfc_trans_read (code
);
2142 res
= gfc_trans_write (code
);
2146 res
= gfc_trans_iolength (code
);
2149 case EXEC_BACKSPACE
:
2150 res
= gfc_trans_backspace (code
);
2154 res
= gfc_trans_endfile (code
);
2158 res
= gfc_trans_inquire (code
);
2162 res
= gfc_trans_wait (code
);
2166 res
= gfc_trans_rewind (code
);
2170 res
= gfc_trans_transfer (code
);
2174 res
= gfc_trans_dt_end (code
);
2177 case EXEC_OMP_ASSUME
:
2178 case EXEC_OMP_ATOMIC
:
2179 case EXEC_OMP_BARRIER
:
2180 case EXEC_OMP_CANCEL
:
2181 case EXEC_OMP_CANCELLATION_POINT
:
2182 case EXEC_OMP_CRITICAL
:
2183 case EXEC_OMP_DEPOBJ
:
2184 case EXEC_OMP_DISTRIBUTE
:
2185 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2186 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2187 case EXEC_OMP_DISTRIBUTE_SIMD
:
2189 case EXEC_OMP_DO_SIMD
:
2191 case EXEC_OMP_ERROR
:
2192 case EXEC_OMP_FLUSH
:
2193 case EXEC_OMP_MASKED
:
2194 case EXEC_OMP_MASKED_TASKLOOP
:
2195 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
2196 case EXEC_OMP_MASTER
:
2197 case EXEC_OMP_MASTER_TASKLOOP
:
2198 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
2199 case EXEC_OMP_ORDERED
:
2200 case EXEC_OMP_PARALLEL
:
2201 case EXEC_OMP_PARALLEL_DO
:
2202 case EXEC_OMP_PARALLEL_DO_SIMD
:
2203 case EXEC_OMP_PARALLEL_LOOP
:
2204 case EXEC_OMP_PARALLEL_MASKED
:
2205 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
2206 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2207 case EXEC_OMP_PARALLEL_MASTER
:
2208 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
2209 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2210 case EXEC_OMP_PARALLEL_SECTIONS
:
2211 case EXEC_OMP_PARALLEL_WORKSHARE
:
2212 case EXEC_OMP_SCOPE
:
2213 case EXEC_OMP_SECTIONS
:
2215 case EXEC_OMP_SINGLE
:
2216 case EXEC_OMP_TARGET
:
2217 case EXEC_OMP_TARGET_DATA
:
2218 case EXEC_OMP_TARGET_ENTER_DATA
:
2219 case EXEC_OMP_TARGET_EXIT_DATA
:
2220 case EXEC_OMP_TARGET_PARALLEL
:
2221 case EXEC_OMP_TARGET_PARALLEL_DO
:
2222 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
2223 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
2224 case EXEC_OMP_TARGET_SIMD
:
2225 case EXEC_OMP_TARGET_TEAMS
:
2226 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2227 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2228 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2229 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2230 case EXEC_OMP_TARGET_TEAMS_LOOP
:
2231 case EXEC_OMP_TARGET_UPDATE
:
2233 case EXEC_OMP_TASKGROUP
:
2234 case EXEC_OMP_TASKLOOP
:
2235 case EXEC_OMP_TASKLOOP_SIMD
:
2236 case EXEC_OMP_TASKWAIT
:
2237 case EXEC_OMP_TASKYIELD
:
2238 case EXEC_OMP_TEAMS
:
2239 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2240 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2241 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2242 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2243 case EXEC_OMP_TEAMS_LOOP
:
2244 case EXEC_OMP_WORKSHARE
:
2245 res
= gfc_trans_omp_directive (code
);
2248 case EXEC_OACC_CACHE
:
2249 case EXEC_OACC_WAIT
:
2250 case EXEC_OACC_UPDATE
:
2251 case EXEC_OACC_LOOP
:
2252 case EXEC_OACC_HOST_DATA
:
2253 case EXEC_OACC_DATA
:
2254 case EXEC_OACC_KERNELS
:
2255 case EXEC_OACC_KERNELS_LOOP
:
2256 case EXEC_OACC_PARALLEL
:
2257 case EXEC_OACC_PARALLEL_LOOP
:
2258 case EXEC_OACC_SERIAL
:
2259 case EXEC_OACC_SERIAL_LOOP
:
2260 case EXEC_OACC_ENTER_DATA
:
2261 case EXEC_OACC_EXIT_DATA
:
2262 case EXEC_OACC_ATOMIC
:
2263 case EXEC_OACC_DECLARE
:
2264 res
= gfc_trans_oacc_directive (code
);
2268 gfc_internal_error ("gfc_trans_code(): Bad statement code");
2271 gfc_set_backend_locus (&code
->loc
);
2273 if (res
!= NULL_TREE
&& ! IS_EMPTY_STMT (res
))
2275 if (TREE_CODE (res
) != STATEMENT_LIST
)
2276 SET_EXPR_LOCATION (res
, input_location
);
2278 /* Add the new statement to the block. */
2279 gfc_add_expr_to_block (&block
, res
);
2283 /* Return the finished block. */
2284 return gfc_finish_block (&block
);
2288 /* Translate an executable statement with condition, cond. The condition is
2289 used by gfc_trans_do to test for IO result conditions inside implied
2290 DO loops of READ and WRITE statements. See build_dt in trans-io.cc. */
2293 gfc_trans_code_cond (gfc_code
* code
, tree cond
)
2295 return trans_code (code
, cond
);
2298 /* Translate an executable statement without condition. */
2301 gfc_trans_code (gfc_code
* code
)
2303 return trans_code (code
, NULL_TREE
);
2307 /* This function is called after a complete program unit has been parsed
2311 gfc_generate_code (gfc_namespace
* ns
)
2314 if (ns
->is_block_data
)
2316 gfc_generate_block_data (ns
);
2320 gfc_generate_function_code (ns
);
2324 /* This function is called after a complete module has been parsed
2328 gfc_generate_module_code (gfc_namespace
* ns
)
2331 struct module_htab_entry
*entry
;
2333 gcc_assert (ns
->proc_name
->backend_decl
== NULL
);
2334 ns
->proc_name
->backend_decl
2335 = build_decl (gfc_get_location (&ns
->proc_name
->declared_at
),
2336 NAMESPACE_DECL
, get_identifier (ns
->proc_name
->name
),
2338 entry
= gfc_find_module (ns
->proc_name
->name
);
2339 if (entry
->namespace_decl
)
2340 /* Buggy sourcecode, using a module before defining it? */
2341 entry
->decls
->empty ();
2342 entry
->namespace_decl
= ns
->proc_name
->backend_decl
;
2344 gfc_generate_module_vars (ns
);
2346 /* We need to generate all module function prototypes first, to allow
2348 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2355 gfc_create_function_decl (n
, false);
2356 DECL_CONTEXT (n
->proc_name
->backend_decl
) = ns
->proc_name
->backend_decl
;
2357 gfc_module_add_decl (entry
, n
->proc_name
->backend_decl
);
2358 for (el
= ns
->entries
; el
; el
= el
->next
)
2360 DECL_CONTEXT (el
->sym
->backend_decl
) = ns
->proc_name
->backend_decl
;
2361 gfc_module_add_decl (entry
, el
->sym
->backend_decl
);
2365 for (n
= ns
->contained
; n
; n
= n
->sibling
)
2370 gfc_generate_function_code (n
);
2375 /* Initialize an init/cleanup block with existing code. */
2378 gfc_start_wrapped_block (gfc_wrapped_block
* block
, tree code
)
2382 block
->init
= NULL_TREE
;
2384 block
->cleanup
= NULL_TREE
;
2388 /* Add a new pair of initializers/clean-up code. */
2391 gfc_add_init_cleanup (gfc_wrapped_block
* block
, tree init
, tree cleanup
)
2395 /* The new pair of init/cleanup should be "wrapped around" the existing
2396 block of code, thus the initialization is added to the front and the
2397 cleanup to the back. */
2398 add_expr_to_chain (&block
->init
, init
, true);
2399 add_expr_to_chain (&block
->cleanup
, cleanup
, false);
2403 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2406 gfc_finish_wrapped_block (gfc_wrapped_block
* block
)
2412 /* Build the final expression. For this, just add init and body together,
2413 and put clean-up with that into a TRY_FINALLY_EXPR. */
2414 result
= block
->init
;
2415 add_expr_to_chain (&result
, block
->code
, false);
2417 result
= build2_loc (input_location
, TRY_FINALLY_EXPR
, void_type_node
,
2418 result
, block
->cleanup
);
2420 /* Clear the block. */
2421 block
->init
= NULL_TREE
;
2422 block
->code
= NULL_TREE
;
2423 block
->cleanup
= NULL_TREE
;
2429 /* Helper function for marking a boolean expression tree as unlikely. */
2432 gfc_unlikely (tree cond
, enum br_predictor predictor
)
2438 cond
= fold_convert (long_integer_type_node
, cond
);
2439 tmp
= build_zero_cst (long_integer_type_node
);
2440 cond
= build_call_expr_loc (input_location
,
2441 builtin_decl_explicit (BUILT_IN_EXPECT
),
2443 build_int_cst (integer_type_node
,
2450 /* Helper function for marking a boolean expression tree as likely. */
2453 gfc_likely (tree cond
, enum br_predictor predictor
)
2459 cond
= fold_convert (long_integer_type_node
, cond
);
2460 tmp
= build_one_cst (long_integer_type_node
);
2461 cond
= build_call_expr_loc (input_location
,
2462 builtin_decl_explicit (BUILT_IN_EXPECT
),
2464 build_int_cst (integer_type_node
,
2471 /* Get the string length for a deferred character length component. */
2474 gfc_deferred_strlen (gfc_component
*c
, tree
*decl
)
2476 char name
[GFC_MAX_SYMBOL_LEN
+9];
2477 gfc_component
*strlen
;
2478 if (!(c
->ts
.type
== BT_CHARACTER
2479 && (c
->ts
.deferred
|| c
->attr
.pdt_string
)))
2481 sprintf (name
, "_%s_length", c
->name
);
2482 for (strlen
= c
; strlen
; strlen
= strlen
->next
)
2483 if (strcmp (strlen
->name
, name
) == 0)
2485 *decl
= strlen
? strlen
->backend_decl
: NULL_TREE
;
2486 return strlen
!= NULL
;