diff options
Diffstat (limited to 'gcc/fortran/trans.cc')
-rw-r--r-- | gcc/fortran/trans.cc | 2452 |
1 files changed, 2452 insertions, 0 deletions
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc new file mode 100644 index 0000000..26f0815 --- /dev/null +++ b/gcc/fortran/trans.cc @@ -0,0 +1,2452 @@ +/* Code translation -- generate GCC trees from gfc_code. + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "gimple-expr.h" /* For create_tmp_var_raw. */ +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "tree-iterator.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Naming convention for backend interface code: + + gfc_trans_* translate gfc_code into STMT trees. + + gfc_conv_* expression conversion + + gfc_get_* get a backend tree representation of a decl or type */ + +static gfc_file *gfc_current_backend_file; + +const char gfc_msg_fault[] = N_("Array reference out of bounds"); + + +/* Return a location_t suitable for 'tree' for a gfortran locus. The way the + parser works in gfortran, loc->lb->location contains only the line number + and LOCATION_COLUMN is 0; hence, the column has to be added when generating + locations for 'tree'. Cf. error.c's gfc_format_decoder. */ + +location_t +gfc_get_location (locus *loc) +{ + return linemap_position_for_loc_and_offset (line_table, loc->lb->location, + loc->nextc - loc->lb->line); +} + +/* Advance along TREE_CHAIN n times. */ + +tree +gfc_advance_chain (tree t, int n) +{ + for (; n > 0; n--) + { + gcc_assert (t != NULL_TREE); + t = DECL_CHAIN (t); + } + return t; +} + +static int num_var; + +#define MAX_PREFIX_LEN 20 + +static tree +create_var_debug_raw (tree type, const char *prefix) +{ + /* Space for prefix + "_" + 10-digit-number + \0. */ + char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1]; + tree t; + int i; + + if (prefix == NULL) + prefix = "gfc"; + else + gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN); + + for (i = 0; prefix[i] != 0; i++) + name_buf[i] = gfc_wide_toupper (prefix[i]); + + snprintf (name_buf + i, sizeof (name_buf) - i, "_%d", num_var++); + + t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type); + + /* Not setting this causes some regressions. */ + DECL_ARTIFICIAL (t) = 1; + + /* We want debug info for it. */ + DECL_IGNORED_P (t) = 0; + /* It should not be nameless. */ + DECL_NAMELESS (t) = 0; + + /* Make the variable writable. */ + TREE_READONLY (t) = 0; + + DECL_EXTERNAL (t) = 0; + TREE_STATIC (t) = 0; + TREE_USED (t) = 1; + + return t; +} + +/* Creates a variable declaration with a given TYPE. */ + +tree +gfc_create_var_np (tree type, const char *prefix) +{ + tree t; + + if (flag_debug_aux_vars) + return create_var_debug_raw (type, prefix); + + t = create_tmp_var_raw (type, prefix); + + /* No warnings for anonymous variables. */ + if (prefix == NULL) + suppress_warning (t); + + return t; +} + + +/* Like above, but also adds it to the current scope. */ + +tree +gfc_create_var (tree type, const char *prefix) +{ + tree tmp; + + tmp = gfc_create_var_np (type, prefix); + + pushdecl (tmp); + + return tmp; +} + + +/* If the expression is not constant, evaluate it now. We assign the + result of the expression to an artificially created variable VAR, and + return a pointer to the VAR_DECL node for this variable. */ + +tree +gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock) +{ + tree var; + + if (CONSTANT_CLASS_P (expr)) + return expr; + + var = gfc_create_var (TREE_TYPE (expr), NULL); + gfc_add_modify_loc (loc, pblock, var, expr); + + return var; +} + + +tree +gfc_evaluate_now (tree expr, stmtblock_t * pblock) +{ + return gfc_evaluate_now_loc (input_location, expr, pblock); +} + +/* Like gfc_evaluate_now, but add the created variable to the + function scope. */ + +tree +gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock) +{ + tree var; + var = gfc_create_var_np (TREE_TYPE (expr), NULL); + gfc_add_decl_to_function (var); + gfc_add_modify (pblock, var, expr); + + return var; +} + +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. + A MODIFY_EXPR is an assignment: + LHS <- RHS. */ + +void +gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs) +{ + tree tmp; + + tree t1, t2; + t1 = TREE_TYPE (rhs); + t2 = TREE_TYPE (lhs); + /* Make sure that the types of the rhs and the lhs are compatible + for scalar assignments. We should probably have something + similar for aggregates, but right now removing that check just + breaks everything. */ + gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2) + || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); + + tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs, + rhs); + gfc_add_expr_to_block (pblock, tmp); +} + + +void +gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) +{ + gfc_add_modify_loc (input_location, pblock, lhs, rhs); +} + + +/* Create a new scope/binding level and initialize a block. Care must be + taken when translating expressions as any temporaries will be placed in + the innermost scope. */ + +void +gfc_start_block (stmtblock_t * block) +{ + /* Start a new binding level. */ + pushlevel (); + block->has_scope = 1; + + /* The block is empty. */ + block->head = NULL_TREE; +} + + +/* Initialize a block without creating a new scope. */ + +void +gfc_init_block (stmtblock_t * block) +{ + block->head = NULL_TREE; + block->has_scope = 0; +} + + +/* Sometimes we create a scope but it turns out that we don't actually + need it. This function merges the scope of BLOCK with its parent. + Only variable decls will be merged, you still need to add the code. */ + +void +gfc_merge_block_scope (stmtblock_t * block) +{ + tree decl; + tree next; + + gcc_assert (block->has_scope); + block->has_scope = 0; + + /* Remember the decls in this scope. */ + decl = getdecls (); + poplevel (0, 0); + + /* Add them to the parent scope. */ + while (decl != NULL_TREE) + { + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; + + pushdecl (decl); + decl = next; + } +} + + +/* Finish a scope containing a block of statements. */ + +tree +gfc_finish_block (stmtblock_t * stmtblock) +{ + tree decl; + tree expr; + tree block; + + expr = stmtblock->head; + if (!expr) + expr = build_empty_stmt (input_location); + + stmtblock->head = NULL_TREE; + + if (stmtblock->has_scope) + { + decl = getdecls (); + + if (decl) + { + block = poplevel (1, 0); + expr = build3_v (BIND_EXPR, decl, expr, block); + } + else + poplevel (0, 0); + } + + return expr; +} + + +/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the + natural type is used. */ + +tree +gfc_build_addr_expr (tree type, tree t) +{ + tree base_type = TREE_TYPE (t); + tree natural_type; + + if (type && POINTER_TYPE_P (type) + && TREE_CODE (base_type) == ARRAY_TYPE + && TYPE_MAIN_VARIANT (TREE_TYPE (type)) + == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) + { + tree min_val = size_zero_node; + tree type_domain = TYPE_DOMAIN (base_type); + if (type_domain && TYPE_MIN_VALUE (type_domain)) + min_val = TYPE_MIN_VALUE (type_domain); + t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), + t, min_val, NULL_TREE, NULL_TREE)); + natural_type = type; + } + else + natural_type = build_pointer_type (base_type); + + if (TREE_CODE (t) == INDIRECT_REF) + { + if (!type) + type = natural_type; + t = TREE_OPERAND (t, 0); + natural_type = TREE_TYPE (t); + } + else + { + tree base = get_base_address (t); + if (base && DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); + } + + if (type && natural_type != type) + t = convert (type, t); + + return t; +} + + +static tree +get_array_span (tree type, tree decl) +{ + tree span; + + /* Component references are guaranteed to have a reliable value for + 'span'. Likewise indirect references since they emerge from the + conversion of a CFI descriptor or the hidden dummy descriptor. */ + if (TREE_CODE (decl) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + else if (TREE_CODE (decl) == INDIRECT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + + /* Return the span for deferred character length array references. */ + if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type)) + { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + span = gfc_conv_descriptor_span_get (decl); + else + span = gfc_get_character_len_in_bytes (type); + span = (span && !integer_zerop (span)) + ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE); + } + /* Likewise for class array or pointer array references. */ + else if (TREE_CODE (decl) == FIELD_DECL + || VAR_OR_FUNCTION_DECL_P (decl) + || TREE_CODE (decl) == PARM_DECL) + { + if (GFC_DECL_CLASS (decl)) + { + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a null span. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return NULL_TREE; + } + span = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs + to be multiplied with the size. */ + span = gfc_resize_class_size_with_len (NULL, decl, span); + } + else if (GFC_DECL_PTR_ARRAY_P (decl)) + { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); + span = gfc_conv_descriptor_span_get (decl); + } + else + span = NULL_TREE; + } + else + span = NULL_TREE; + + return span; +} + + +tree +gfc_build_spanned_array_ref (tree base, tree offset, tree span) +{ + tree type; + tree tmp; + type = TREE_TYPE (TREE_TYPE (base)); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + offset, span); + tmp = gfc_build_addr_expr (pvoid_type_node, base); + tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); + tmp = fold_convert (build_pointer_type (type), tmp); + if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) + || !TYPE_STRING_FLAG (type)) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + return tmp; +} + + +/* Build an ARRAY_REF with its natural type. */ + +tree +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) +{ + tree type = TREE_TYPE (base); + tree span = NULL_TREE; + + if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) + { + gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); + + return fold_convert (TYPE_MAIN_VARIANT (type), base); + } + + /* Scalar coarray, there is nothing to do. */ + if (TREE_CODE (type) != ARRAY_TYPE) + { + gcc_assert (decl == NULL_TREE); + gcc_assert (integer_zerop (offset)); + return base; + } + + type = TREE_TYPE (type); + + if (DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + + /* Strip NON_LVALUE_EXPR nodes. */ + STRIP_TYPE_NOPS (offset); + + /* If decl or vptr are non-null, pointer arithmetic for the array reference + is likely. Generate the 'span' for the array reference. */ + if (vptr) + { + span = gfc_vptr_size_get (vptr); + + /* Check if this is an unlimited polymorphic object carrying a character + payload. In this case, the 'len' field is non-zero. */ + if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + span = gfc_resize_class_size_with_len (NULL, decl, span); + } + else if (decl) + span = get_array_span (type, decl); + + /* If a non-null span has been generated reference the element with + pointer arithmetic. */ + if (span != NULL_TREE) + return gfc_build_spanned_array_ref (base, offset, span); + /* Otherwise use a straightforward array reference. */ + else + return build4_loc (input_location, ARRAY_REF, type, base, offset, + NULL_TREE, NULL_TREE); +} + + +/* Generate a call to print a runtime error possibly including multiple + arguments and a locus. */ + +static tree +trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid, + va_list ap) +{ + stmtblock_t block; + tree tmp; + tree arg, arg2; + tree *argarray; + tree fntype; + char *message; + const char *p; + int line, nargs, i; + location_t loc; + + /* Compute the number of extra arguments from the format string. */ + for (p = msgid, nargs = 0; *p; p++) + if (*p == '%') + { + p++; + if (*p != '%') + nargs++; + } + + /* The code to generate the error. */ + gfc_start_block (&block); + + if (where) + { + line = LOCATION_LINE (where->lb->location); + message = xasprintf ("At line %d of file %s", line, + where->lb->file->filename); + } + else + message = xasprintf ("In file '%s', around line %d", + gfc_source_file, LOCATION_LINE (input_location) + 1); + + arg = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + free (message); + + message = xasprintf ("%s", _(msgid)); + arg2 = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + free (message); + + /* Build the argument array. */ + argarray = XALLOCAVEC (tree, nargs + 2); + argarray[0] = arg; + argarray[1] = arg2; + for (i = 0; i < nargs; i++) + argarray[2 + i] = va_arg (ap, tree); + + /* Build the function call to runtime_(warning,error)_at; because of the + variable number of arguments, we can't use build_call_expr_loc dinput_location, + irectly. */ + fntype = TREE_TYPE (errorfunc); + + loc = where ? gfc_get_location (where) : input_location; + tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype), + fold_build1_loc (loc, ADDR_EXPR, + build_pointer_type (fntype), + errorfunc), + nargs + 2, argarray); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) +{ + va_list ap; + tree result; + + va_start (ap, msgid); + result = trans_runtime_error_vararg (error + ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at, + where, msgid, ap); + va_end (ap); + return result; +} + + +/* Generate a runtime error if COND is true. */ + +void +gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, + locus * where, const char * msgid, ...) +{ + va_list ap; + stmtblock_t block; + tree body; + tree tmp; + tree tmpvar = NULL; + + if (integer_zerop (cond)) + return; + + if (once) + { + tmpvar = gfc_create_var (boolean_type_node, "print_warning"); + TREE_STATIC (tmpvar) = 1; + DECL_INITIAL (tmpvar) = boolean_true_node; + gfc_add_expr_to_block (pblock, tmpvar); + } + + gfc_start_block (&block); + + /* For error, runtime_error_at already implies PRED_NORETURN. */ + if (!error && once) + gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE, + NOT_TAKEN)); + + /* The code to generate the error. */ + va_start (ap, msgid); + gfc_add_expr_to_block (&block, + trans_runtime_error_vararg + (error ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at, + where, msgid, ap)); + va_end (ap); + + if (once) + gfc_add_modify (&block, tmpvar, boolean_false_node); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + if (once) + cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR, + boolean_type_node, tmpvar, + fold_convert (boolean_type_node, cond)); + + tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node, + cond, body, + build_empty_stmt (gfc_get_location (where))); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +static tree +trans_os_error_at (locus* where, const char* msgid, ...) +{ + va_list ap; + tree result; + + va_start (ap, msgid); + result = trans_runtime_error_vararg (gfor_fndecl_os_error_at, + where, msgid, ap); + va_end (ap); + return result; +} + + + +/* Call malloc to allocate size bytes of memory, with special conditions: + + if size == 0, return a malloced area of size 1, + + if malloc returns NULL, issue a runtime error. */ +tree +gfc_call_malloc (stmtblock_t * block, tree type, tree size) +{ + tree tmp, malloc_result, null_result, res, malloc_tree; + stmtblock_t block2; + + /* Create a variable to hold the result. */ + res = gfc_create_var (prvoid_type_node, NULL); + + /* Call malloc. */ + gfc_start_block (&block2); + + if (size == NULL_TREE) + size = build_int_cst (size_type_node, 1); + + size = fold_convert (size_type_node, size); + size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1)); + + malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC); + gfc_add_modify (&block2, res, + fold_convert (prvoid_type_node, + build_call_expr_loc (input_location, + malloc_tree, 1, size))); + + /* Optionally check whether malloc was successful. */ + if (gfc_option.rtcheck & GFC_RTCHECK_MEM) + { + null_result = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, res, + build_int_cst (pvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, + trans_os_error_at (NULL, + "Error allocating %lu bytes", + fold_convert + (long_unsigned_type_node, + size)), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + + malloc_result = gfc_finish_block (&block2); + gfc_add_expr_to_block (block, malloc_result); + + if (type != NULL) + res = fold_convert (type, res); + return res; +} + + +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, integer_type stat) + { + void *newmem; + + if (stat requested) + stat = 0; + + newmem = malloc (MAX (size, 1)); + if (newmem == NULL) + { + if (stat) + *stat = LIBERROR_ALLOCATION; + else + runtime_error ("Allocation would exceed memory limit"); + } + return newmem; + } */ +void +gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, + tree size, tree status) +{ + tree tmp, error_cond; + stmtblock_t on_error; + tree status_type = status ? TREE_TYPE (status) : NULL_TREE; + + /* If successful and stat= is given, set status to 0. */ + if (status != NULL_TREE) + gfc_add_expr_to_block (block, + fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, 0))); + + /* The allocation itself. */ + size = fold_convert (size_type_node, size); + gfc_add_modify (block, pointer, + fold_convert (TREE_TYPE (pointer), + build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1))))); + + /* What to do in case of error. */ + gfc_start_block (&on_error); + if (status != NULL_TREE) + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + gfc_add_expr_to_block (&on_error, tmp); + } + else + { + /* Here, os_error_at already implies PRED_NORETURN. */ + tree lusize = fold_convert (long_unsigned_type_node, size); + tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize); + gfc_add_expr_to_block (&on_error, tmp); + } + + error_cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, pointer, + build_int_cst (prvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&on_error), + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (block, tmp); +} + + +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, void** token, int *stat, char* errmsg, int errlen) + { + void *newmem; + + newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); + return newmem; + } */ +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) +{ + tree tmp, pstat; + + gcc_assert (token != NULL_TREE); + + /* The allocation itself. */ + if (status == NULL_TREE) + pstat = null_pointer_node; + else + pstat = gfc_build_addr_expr (NULL_TREE, status); + + if (errmsg == NULL_TREE) + { + gcc_assert(errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_int_cst (integer_type_node, 0); + } + + size = fold_convert (size_type_node, size); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_register, 7, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, size_one_node), + build_int_cst (integer_type_node, alloc_type), + token, gfc_build_addr_expr (pvoid_type_node, pointer), + pstat, errmsg, errlen); + + gfc_add_expr_to_block (block, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (block, tmp); +} + + +/* Generate code for an ALLOCATE statement when the argument is an + allocatable variable. If the variable is currently allocated, it is an + error to allocate it again. + + This function follows the following pseudo-code: + + void * + allocate_allocatable (void *mem, size_t size, integer_type stat) + { + if (mem == NULL) + return allocate (size, stat); + else + { + if (stat) + stat = LIBERROR_ALLOCATION; + else + runtime_error ("Attempting to allocate already allocated variable"); + } + } + + expr must be set to the original expression being allocated for its locus + and variable name in case a runtime error has to be printed. */ +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) +{ + stmtblock_t alloc_block; + tree tmp, null_mem, alloc, error; + tree type = TREE_TYPE (mem); + symbol_attribute caf_attr; + bool need_assign = false, refs_comp = false; + gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; + + size = fold_convert (size_type_node, size); + null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, + logical_type_node, mem, + build_int_cst (type, 0)), + PRED_FORTRAN_REALLOC); + + /* If mem is NULL, we call gfc_allocate_using_malloc or + gfc_allocate_using_lib. */ + gfc_start_block (&alloc_block); + + if (flag_coarray == GFC_FCOARRAY_LIB) + caf_attr = gfc_caf_attr (expr, true, &refs_comp); + + if (flag_coarray == GFC_FCOARRAY_LIB + && (corank > 0 || caf_attr.codimension)) + { + tree cond, sub_caf_tree; + gfc_se se; + bool compute_special_caf_types_size = false; + + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_LOCK_ALLOC; + } + else if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_EVENT_ALLOC; + } + else if (!caf_attr.coarray_comp && refs_comp) + /* Only allocatable components in a derived type coarray can be + allocate only. */ + caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY; + + gfc_init_se (&se, NULL); + sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); + if (sub_caf_tree == NULL_TREE) + sub_caf_tree = token; + + /* When mem is an array ref, then strip the .data-ref. */ + if (TREE_CODE (mem) == COMPONENT_REF + && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem)))) + tmp = TREE_OPERAND (mem, 0); + else + tmp = mem; + + if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp)) + && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0) + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + { + symbol_attribute attr; + + gfc_clear_attr (&attr); + tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr); + need_assign = true; + } + gfc_add_block_to_block (&alloc_block, &se.pre); + + /* In the front end, we represent the lock variable as pointer. However, + the FE only passes the pointer around and leaves the actual + representation to the library. Hence, we have to convert back to the + number of elements. */ + if (compute_special_caf_types_size) + size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, + size, TYPE_SIZE_UNIT (ptr_type_node)); + + gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree, + status, errmsg, errlen, caf_alloc_type); + if (need_assign) + gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem), + gfc_conv_descriptor_data_get (tmp))); + if (status != NULL_TREE) + { + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_zero_cst (TREE_TYPE (status))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&alloc_block, tmp); + } + } + else + gfc_allocate_using_malloc (&alloc_block, mem, size, status); + + alloc = gfc_finish_block (&alloc_block); + + /* If mem is not NULL, we issue a runtime error or set the + status variable. */ + if (expr) + { + tree varname; + + gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempting to allocate already" + " allocated variable '%s'", + varname); + } + else + error = gfc_trans_runtime_error (true, NULL, + "Attempting to allocate already allocated" + " variable"); + + if (status != NULL_TREE) + { + tree status_type = TREE_TYPE (status); + + error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, LIBERROR_ALLOCATION)); + } + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, + error, alloc); + gfc_add_expr_to_block (block, tmp); +} + + +/* Free a given variable. */ + +tree +gfc_call_free (tree var) +{ + return build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), + 1, fold_convert (pvoid_type_node, var)); +} + + +/* Build a call to a FINAL procedure, which finalizes "var". */ + +static tree +gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, + bool fini_coarray, gfc_expr *class_size) +{ + stmtblock_t block; + gfc_se se; + tree final_fndecl, array, size, tmp; + symbol_attribute attr; + + gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); + gcc_assert (var); + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_wrapper); + final_fndecl = se.expr; + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + if (ts.type == BT_DERIVED) + { + tree elem_size; + + gcc_assert (!class_size); + elem_size = gfc_typenode_for_spec (&ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + size = fold_convert (gfc_array_index_type, elem_size); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (var->rank) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + } + else + { + gfc_conv_expr (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gcc_assert (se.post.head == NULL_TREE); + } + } + else + { + gfc_expr *array_expr; + gcc_assert (class_size); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, class_size); + gfc_add_block_to_block (&block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + size = se.expr; + + array_expr = gfc_copy_expr (var); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (array_expr->rank) + { + gfc_add_class_array_ref (array_expr); + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, array_expr); + array = se.expr; + } + else + { + gfc_add_data_component (array_expr); + gfc_conv_expr (&se, array_expr); + gfc_add_block_to_block (&block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + array = se.expr; + + if (!gfc_is_coarray (array_expr)) + { + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + } + gcc_assert (se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_block_to_block (&block, &se.post); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); +} + + +bool +gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, + bool fini_coarray) +{ + gfc_se se; + stmtblock_t block2; + tree final_fndecl, size, array, tmp, cond; + symbol_attribute attr; + gfc_expr *final_expr = NULL; + + if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS) + return false; + + gfc_init_block (&block2); + + if (comp->ts.type == BT_DERIVED) + { + if (comp->attr.pointer) + return false; + + gfc_is_finalizable (comp->ts.u.derived, &final_expr); + if (!final_expr) + return false; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_expr); + final_fndecl = se.expr; + size = gfc_typenode_for_spec (&comp->ts); + size = TYPE_SIZE_UNIT (size); + size = fold_convert (gfc_array_index_type, size); + + array = decl; + } + else /* comp->ts.type == BT_CLASS. */ + { + if (CLASS_DATA (comp)->attr.class_pointer) + return false; + + gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); + final_fndecl = gfc_class_vtab_final_get (decl); + size = gfc_class_vtab_size_get (decl); + array = gfc_class_data_get (decl); + } + + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) + { + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) + ? gfc_conv_descriptor_data_get (array) : array; + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + else + cond = logical_true_node; + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) + { + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gfc_add_block_to_block (&block2, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + if (!final_expr) + { + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + final_fndecl, + fold_convert (TREE_TYPE (final_fndecl), + null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, cond, tmp); + } + + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_expr_to_block (&block2, tmp); + tmp = gfc_finish_block (&block2); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + return true; +} + + +/* Add a call to the finalizer, using the passed *expr. Returns + true when a finalizer call has been inserted. */ + +bool +gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) +{ + tree tmp; + gfc_ref *ref; + gfc_expr *expr; + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) + return false; + + if (expr2->ts.type == BT_DERIVED) + { + gfc_is_finalizable (expr2->ts.u.derived, &final_expr); + if (!final_expr) + return false; + } + + /* If we have a class array, we need go back to the class + container. */ + expr = gfc_copy_expr (expr2); + + if (expr->ref && expr->ref->next && !expr->ref->next->next + && expr->ref->next->type == REF_ARRAY + && expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + else + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next && ref->next->next && !ref->next->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (expr->ts.type == BT_CLASS) + { + has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); + + if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) + expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; + + final_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (final_expr); + gfc_add_final_component (final_expr); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_size_component (elem_size); + } + + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (expr->ts, final_expr, expr, + false, elem_size); + + if (expr->ts.type == BT_CLASS && !has_finalizer) + { + tree cond; + gfc_se se; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, final_expr); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (expr)) + { + tree cond2; + gfc_expr *vptr_expr; + + vptr_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (vptr_expr); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, cond2, cond); + } + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (block, tmp); + + return true; +} + + +/* User-deallocate; we emit the code directly from the front-end, and the + logic is the same as the previous library function: + + void + deallocate (void *pointer, GFC_INTEGER_4 * stat) + { + if (!pointer) + { + if (stat) + *stat = 1; + else + runtime_error ("Attempt to DEALLOCATE unallocated memory."); + } + else + { + free (pointer); + if (stat) + *stat = 0; + } + } + + In this front-end version, status doesn't have to be GFC_INTEGER_4. + Moreover, if CAN_FAIL is true, then we will not emit a runtime error, + even when no status variable is passed to us (this is used for + unconditional deallocation generated by the front-end at end of + each procedure). + + If a runtime-message is possible, `expr' must point to the original + expression being deallocated for its locus and variable name. + + For coarrays, "pointer" must be the array descriptor and not its + "data" component. + + COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are + the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be + analyzed and set by this routine, and -2 to indicate that a non-coarray is to + be deallocated. */ +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) +{ + stmtblock_t null, non_null; + tree cond, tmp, error; + tree status_type = NULL_TREE; + tree token = NULL_TREE; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; + + if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) + { + if (flag_coarray == GFC_FCOARRAY_LIB) + { + if (caf_token) + token = caf_token; + else + { + tree caf_type, caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + caf_type = TREE_TYPE (caf_decl); + STRIP_NOPS (pointer); + if (GFC_DESCRIPTOR_TYPE_P (caf_type)) + token = gfc_conv_descriptor_token (caf_decl); + else if (DECL_LANG_SPECIFIC (caf_decl) + && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) + token = GFC_DECL_TOKEN (caf_decl); + else + { + gcc_assert (GFC_ARRAY_TYPE_P (caf_type) + && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) + != NULL_TREE); + token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); + } + } + + if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + { + bool comp_ref; + if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + // else do a deregister as set by default. + } + else + caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + pointer = gfc_conv_descriptor_data_get (pointer); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise + we emit a runtime error. */ + gfc_start_block (&null); + if (!can_fail) + { + tree varname; + + gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); + + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempt to DEALLOCATE unallocated '%s'", + varname); + } + else + error = build_empty_stmt (input_location); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree cond2; + + status_type = TREE_TYPE (TREE_TYPE (status)); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, error); + } + + gfc_add_expr_to_block (&null, error); + + /* When POINTER is not NULL, we free it. */ + gfc_start_block (&non_null); + if (add_when_allocated) + gfc_add_expr_to_block (&non_null, add_when_allocated); + gfc_add_finalizer_call (&non_null, expr); + if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY + || flag_coarray != GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else + { + tree cond2, pstat = null_pointer_node; + + if (errmsg == NULL_TREE) + { + gcc_assert (errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_zero_cst (integer_type_node); + } + else + { + gcc_assert (errlen != NULL_TREE); + if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) + errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); + } + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (status_type == integer_type_node); + pstat = status; + } + + token = gfc_build_addr_expr (NULL_TREE, token); + gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, errmsg, errlen); + gfc_add_expr_to_block (&non_null, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), + 0)); + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), + tmp, nullify); + gfc_add_expr_to_block (&non_null, tmp); + } + else + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); + } + + return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), + gfc_finish_block (&non_null)); +} + + +/* Generate code for deallocation of allocatable scalars (variables or + components). Before the object itself is freed, any allocatable + subcomponents are being deallocated. */ + +tree +gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, + bool can_fail, gfc_expr* expr, + gfc_typespec ts, bool coarray) +{ + stmtblock_t null, non_null; + tree cond, tmp, error; + bool finalizable, comp_ref; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; + + if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise + we emit a runtime error. */ + gfc_start_block (&null); + if (!can_fail) + { + tree varname; + + gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); + + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempt to DEALLOCATE unallocated '%s'", + varname); + } + else + error = build_empty_stmt (input_location); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, error); + } + gfc_add_expr_to_block (&null, error); + + /* When POINTER is not NULL, we free it. */ + gfc_start_block (&non_null); + + /* Free allocatable components. */ + finalizable = gfc_add_finalizer_call (&non_null, expr); + if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) + { + int caf_mode = coarray + ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) + | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + : 0; + if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + tmp = gfc_conv_descriptor_data_get (pointer); + else + tmp = build_fold_indirect_ref_loc (input_location, pointer); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); + gfc_add_expr_to_block (&non_null, tmp); + } + + if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else + { + tree token; + tree pstat = null_pointer_node; + gfc_se se; + + gfc_init_se (&se, NULL); + token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); + gcc_assert (token != NULL_TREE); + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node); + pstat = status; + } + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, null_pointer_node, integer_zero_node); + gfc_add_expr_to_block (&non_null, tmp); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + tree cond2; + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + + return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), + gfc_finish_block (&non_null)); +} + +/* Reallocate MEM so it has SIZE bytes of data. This behaves like the + following pseudo-code: + +void * +internal_realloc (void *mem, size_t size) +{ + res = realloc (mem, size); + if (!res && size != 0) + _gfortran_os_error ("Allocation would exceed memory limit"); + + return res; +} */ +tree +gfc_call_realloc (stmtblock_t * block, tree mem, tree size) +{ + tree res, nonzero, null_result, tmp; + tree type = TREE_TYPE (mem); + + /* Only evaluate the size once. */ + size = save_expr (fold_convert (size_type_node, size)); + + /* Create a variable to hold the result. */ + res = gfc_create_var (type, NULL); + + /* Call realloc and check the result. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, + fold_convert (pvoid_type_node, mem), size); + gfc_add_modify (block, res, fold_convert (type, tmp)); + null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + res, build_int_cst (pvoid_type_node, 0)); + nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size, + build_int_cst (size_type_node, 0)); + null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + null_result, nonzero); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, + trans_os_error_at (NULL, + "Error reallocating to %lu bytes", + fold_convert + (long_unsigned_type_node, size)), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + return res; +} + + +/* Add an expression to another one, either at the front or the back. */ + +static void +add_expr_to_chain (tree* chain, tree expr, bool front) +{ + if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) + return; + + if (*chain) + { + if (TREE_CODE (*chain) != STATEMENT_LIST) + { + tree tmp; + + tmp = *chain; + *chain = NULL_TREE; + append_to_statement_list (tmp, chain); + } + + if (front) + { + tree_stmt_iterator i; + + i = tsi_start (*chain); + tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); + } + else + append_to_statement_list (expr, chain); + } + else + *chain = expr; +} + + +/* Add a statement at the end of a block. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, false); +} + + +/* Add a statement at the beginning of a block. */ + +void +gfc_prepend_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, true); +} + + +/* Add a block the end of a block. */ + +void +gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) +{ + gcc_assert (append); + gcc_assert (!append->has_scope); + + gfc_add_expr_to_block (block, append->head); + append->head = NULL_TREE; +} + + +/* Save the current locus. The structure may not be complete, and should + only be used with gfc_restore_backend_locus. */ + +void +gfc_save_backend_locus (locus * loc) +{ + loc->lb = XCNEW (gfc_linebuf); + loc->lb->location = input_location; + loc->lb->file = gfc_current_backend_file; +} + + +/* Set the current locus. */ + +void +gfc_set_backend_locus (locus * loc) +{ + gfc_current_backend_file = loc->lb->file; + input_location = gfc_get_location (loc); +} + + +/* Restore the saved locus. Only used in conjunction with + gfc_save_backend_locus, to free the memory when we are done. */ + +void +gfc_restore_backend_locus (locus * loc) +{ + /* This only restores the information captured by gfc_save_backend_locus, + intentionally does not use gfc_get_location. */ + input_location = loc->lb->location; + gfc_current_backend_file = loc->lb->file; + free (loc->lb); +} + + +/* Translate an executable statement. The tree cond is used by gfc_trans_do. + This static function is wrapped by gfc_trans_code_cond and + gfc_trans_code. */ + +static tree +trans_code (gfc_code * code, tree cond) +{ + stmtblock_t block; + tree res; + + if (!code) + return build_empty_stmt (input_location); + + gfc_start_block (&block); + + /* Translate statements one by one into GENERIC trees until we reach + the end of this gfc_code branch. */ + for (; code; code = code->next) + { + if (code->here != 0) + { + res = gfc_trans_label_here (code); + gfc_add_expr_to_block (&block, res); + } + + gfc_current_locus = code->loc; + gfc_set_backend_locus (&code->loc); + + switch (code->op) + { + case EXEC_NOP: + case EXEC_END_BLOCK: + case EXEC_END_NESTED_BLOCK: + case EXEC_END_PROCEDURE: + res = NULL_TREE; + break; + + case EXEC_ASSIGN: + res = gfc_trans_assign (code); + break; + + case EXEC_LABEL_ASSIGN: + res = gfc_trans_label_assign (code); + break; + + case EXEC_POINTER_ASSIGN: + res = gfc_trans_pointer_assign (code); + break; + + case EXEC_INIT_ASSIGN: + if (code->expr1->ts.type == BT_CLASS) + res = gfc_trans_class_init_assign (code); + else + res = gfc_trans_init_assign (code); + break; + + case EXEC_CONTINUE: + res = NULL_TREE; + break; + + case EXEC_CRITICAL: + res = gfc_trans_critical (code); + break; + + case EXEC_CYCLE: + res = gfc_trans_cycle (code); + break; + + case EXEC_EXIT: + res = gfc_trans_exit (code); + break; + + case EXEC_GOTO: + res = gfc_trans_goto (code); + break; + + case EXEC_ENTRY: + res = gfc_trans_entry (code); + break; + + case EXEC_PAUSE: + res = gfc_trans_pause (code); + break; + + case EXEC_STOP: + case EXEC_ERROR_STOP: + res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); + break; + + case EXEC_CALL: + /* For MVBITS we've got the special exception that we need a + dependency check, too. */ + { + bool is_mvbits = false; + + if (code->resolved_isym) + { + res = gfc_conv_intrinsic_subroutine (code); + if (res != NULL_TREE) + break; + } + + if (code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MVBITS) + is_mvbits = true; + + res = gfc_trans_call (code, is_mvbits, NULL_TREE, + NULL_TREE, false); + } + break; + + case EXEC_CALL_PPC: + res = gfc_trans_call (code, false, NULL_TREE, + NULL_TREE, false); + break; + + case EXEC_ASSIGN_CALL: + res = gfc_trans_call (code, true, NULL_TREE, + NULL_TREE, false); + break; + + case EXEC_RETURN: + res = gfc_trans_return (code); + break; + + case EXEC_IF: + res = gfc_trans_if (code); + break; + + case EXEC_ARITHMETIC_IF: + res = gfc_trans_arithmetic_if (code); + break; + + case EXEC_BLOCK: + res = gfc_trans_block_construct (code); + break; + + case EXEC_DO: + res = gfc_trans_do (code, cond); + break; + + case EXEC_DO_CONCURRENT: + res = gfc_trans_do_concurrent (code); + break; + + case EXEC_DO_WHILE: + res = gfc_trans_do_while (code); + break; + + case EXEC_SELECT: + res = gfc_trans_select (code); + break; + + case EXEC_SELECT_TYPE: + res = gfc_trans_select_type (code); + break; + + case EXEC_SELECT_RANK: + res = gfc_trans_select_rank (code); + break; + + case EXEC_FLUSH: + res = gfc_trans_flush (code); + break; + + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + res = gfc_trans_sync (code, code->op); + break; + + case EXEC_LOCK: + case EXEC_UNLOCK: + res = gfc_trans_lock_unlock (code, code->op); + break; + + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + res = gfc_trans_event_post_wait (code, code->op); + break; + + case EXEC_FAIL_IMAGE: + res = gfc_trans_fail_image (code); + break; + + case EXEC_FORALL: + res = gfc_trans_forall (code); + break; + + case EXEC_FORM_TEAM: + res = gfc_trans_form_team (code); + break; + + case EXEC_CHANGE_TEAM: + res = gfc_trans_change_team (code); + break; + + case EXEC_END_TEAM: + res = gfc_trans_end_team (code); + break; + + case EXEC_SYNC_TEAM: + res = gfc_trans_sync_team (code); + break; + + case EXEC_WHERE: + res = gfc_trans_where (code); + break; + + case EXEC_ALLOCATE: + res = gfc_trans_allocate (code); + break; + + case EXEC_DEALLOCATE: + res = gfc_trans_deallocate (code); + break; + + case EXEC_OPEN: + res = gfc_trans_open (code); + break; + + case EXEC_CLOSE: + res = gfc_trans_close (code); + break; + + case EXEC_READ: + res = gfc_trans_read (code); + break; + + case EXEC_WRITE: + res = gfc_trans_write (code); + break; + + case EXEC_IOLENGTH: + res = gfc_trans_iolength (code); + break; + + case EXEC_BACKSPACE: + res = gfc_trans_backspace (code); + break; + + case EXEC_ENDFILE: + res = gfc_trans_endfile (code); + break; + + case EXEC_INQUIRE: + res = gfc_trans_inquire (code); + break; + + case EXEC_WAIT: + res = gfc_trans_wait (code); + break; + + case EXEC_REWIND: + res = gfc_trans_rewind (code); + break; + + case EXEC_TRANSFER: + res = gfc_trans_transfer (code); + break; + + case EXEC_DT_END: + res = gfc_trans_dt_end (code); + break; + + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_ERROR: + case EXEC_OMP_FLUSH: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + res = gfc_trans_omp_directive (code); + break; + + case EXEC_OACC_CACHE: + case EXEC_OACC_WAIT: + case EXEC_OACC_UPDATE: + case EXEC_OACC_LOOP: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_DATA: + case EXEC_OACC_KERNELS: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ATOMIC: + case EXEC_OACC_DECLARE: + res = gfc_trans_oacc_directive (code); + break; + + default: + gfc_internal_error ("gfc_trans_code(): Bad statement code"); + } + + gfc_set_backend_locus (&code->loc); + + if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) + { + if (TREE_CODE (res) != STATEMENT_LIST) + SET_EXPR_LOCATION (res, input_location); + + /* Add the new statement to the block. */ + gfc_add_expr_to_block (&block, res); + } + } + + /* Return the finished block. */ + return gfc_finish_block (&block); +} + + +/* Translate an executable statement with condition, cond. The condition is + used by gfc_trans_do to test for IO result conditions inside implied + DO loops of READ and WRITE statements. See build_dt in trans-io.c. */ + +tree +gfc_trans_code_cond (gfc_code * code, tree cond) +{ + return trans_code (code, cond); +} + +/* Translate an executable statement without condition. */ + +tree +gfc_trans_code (gfc_code * code) +{ + return trans_code (code, NULL_TREE); +} + + +/* This function is called after a complete program unit has been parsed + and resolved. */ + +void +gfc_generate_code (gfc_namespace * ns) +{ + ompws_flags = 0; + if (ns->is_block_data) + { + gfc_generate_block_data (ns); + return; + } + + gfc_generate_function_code (ns); +} + + +/* This function is called after a complete module has been parsed + and resolved. */ + +void +gfc_generate_module_code (gfc_namespace * ns) +{ + gfc_namespace *n; + struct module_htab_entry *entry; + + gcc_assert (ns->proc_name->backend_decl == NULL); + ns->proc_name->backend_decl + = build_decl (gfc_get_location (&ns->proc_name->declared_at), + NAMESPACE_DECL, get_identifier (ns->proc_name->name), + void_type_node); + entry = gfc_find_module (ns->proc_name->name); + if (entry->namespace_decl) + /* Buggy sourcecode, using a module before defining it? */ + entry->decls->empty (); + entry->namespace_decl = ns->proc_name->backend_decl; + + gfc_generate_module_vars (ns); + + /* We need to generate all module function prototypes first, to allow + sibling calls. */ + for (n = ns->contained; n; n = n->sibling) + { + gfc_entry_list *el; + + if (!n->proc_name) + continue; + + gfc_create_function_decl (n, false); + DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; + gfc_module_add_decl (entry, n->proc_name->backend_decl); + for (el = ns->entries; el; el = el->next) + { + DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl; + gfc_module_add_decl (entry, el->sym->backend_decl); + } + } + + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_generate_function_code (n); + } +} + + +/* Initialize an init/cleanup block with existing code. */ + +void +gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) +{ + gcc_assert (block); + + block->init = NULL_TREE; + block->code = code; + block->cleanup = NULL_TREE; +} + + +/* Add a new pair of initializers/clean-up code. */ + +void +gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) +{ + gcc_assert (block); + + /* The new pair of init/cleanup should be "wrapped around" the existing + block of code, thus the initialization is added to the front and the + cleanup to the back. */ + add_expr_to_chain (&block->init, init, true); + add_expr_to_chain (&block->cleanup, cleanup, false); +} + + +/* Finish up a wrapped block by building a corresponding try-finally expr. */ + +tree +gfc_finish_wrapped_block (gfc_wrapped_block* block) +{ + tree result; + + gcc_assert (block); + + /* Build the final expression. For this, just add init and body together, + and put clean-up with that into a TRY_FINALLY_EXPR. */ + result = block->init; + add_expr_to_chain (&result, block->code, false); + if (block->cleanup) + result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, + result, block->cleanup); + + /* Clear the block. */ + block->init = NULL_TREE; + block->code = NULL_TREE; + block->cleanup = NULL_TREE; + + return result; +} + + +/* Helper function for marking a boolean expression tree as unlikely. */ + +tree +gfc_unlikely (tree cond, enum br_predictor predictor) +{ + tree tmp; + + if (optimize) + { + cond = fold_convert (long_integer_type_node, cond); + tmp = build_zero_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_EXPECT), + 3, cond, tmp, + build_int_cst (integer_type_node, + predictor)); + } + return cond; +} + + +/* Helper function for marking a boolean expression tree as likely. */ + +tree +gfc_likely (tree cond, enum br_predictor predictor) +{ + tree tmp; + + if (optimize) + { + cond = fold_convert (long_integer_type_node, cond); + tmp = build_one_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_EXPECT), + 3, cond, tmp, + build_int_cst (integer_type_node, + predictor)); + } + return cond; +} + + +/* Get the string length for a deferred character length component. */ + +bool +gfc_deferred_strlen (gfc_component *c, tree *decl) +{ + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + if (!(c->ts.type == BT_CHARACTER + && (c->ts.deferred || c->attr.pdt_string))) + return false; + sprintf (name, "_%s_length", c->name); + for (strlen = c; strlen; strlen = strlen->next) + if (strcmp (strlen->name, name) == 0) + break; + *decl = strlen ? strlen->backend_decl : NULL_TREE; + return strlen != NULL; +} |