static match match_ext_add_operand (gfc_expr **result) { gfc_expr *all, *e; locus where; match m; int i; where = gfc_current_locus; i = match_add_op (); if (i == 0) return match_add_operand (result); if (gfc_notification_std (GFC_STD_GNU) == ERROR) { gfc_error ("Extension: Unary operator following " "arithmetic operator (use parentheses) at %C"); return MATCH_ERROR; } else gfc_warning (0, "Extension: Unary operator following " "arithmetic operator (use parentheses) at %C"); m = match_ext_add_operand (&e); if (m != MATCH_YES) return m; if (i == -1) all = gfc_uminus (e); else all = gfc_uplus (e); if (all == NULL) { gfc_free_expr (e); return MATCH_ERROR; } all->where = where; *result = all; return MATCH_YES; }
static tree build_common_decl (gfc_common_head *com, tree union_type, bool is_init) { gfc_symbol *common_sym; tree decl; /* Create a namespace to store symbols for common blocks. */ if (gfc_common_ns == NULL) gfc_common_ns = gfc_get_namespace (NULL, 0); gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; /* Update the size of this common block as needed. */ if (decl != NULL_TREE) { tree size = TYPE_SIZE_UNIT (union_type); /* Named common blocks of the same name shall be of the same size in all scoping units of a program in which they appear, but blank common blocks may be of different sizes. */ if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size) && strcmp (com->name, BLANK_COMMON_NAME)) gfc_warning ("Named COMMON block '%s' at %L shall be of the " "same size as elsewhere (%lu vs %lu bytes)", com->name, &com->where, (unsigned long) TREE_INT_CST_LOW (size), (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl))); if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) { DECL_SIZE (decl) = TYPE_SIZE (union_type); DECL_SIZE_UNIT (decl) = size; DECL_MODE (decl) = TYPE_MODE (union_type); TREE_TYPE (decl) = union_type; layout_decl (decl, 0); } } /* If this common block has been declared in a previous program unit, and either it is already initialized or there is no new initialization for it, just return. */ if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) return decl; /* If there is no backend_decl for the common block, build it. */ if (decl == NULL_TREE) { decl = build_decl (input_location, VAR_DECL, get_identifier (com->name), union_type); gfc_set_decl_assembler_name (decl, gfc_sym_mangled_common_id (com)); TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; DECL_IGNORED_P (decl) = 1; if (!com->is_bind_c) DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; else { /* Do not set the alignment for bind(c) common blocks to BIGGEST_ALIGNMENT because that won't match what C does. Also, for common blocks with one element, the alignment must be that of the field within the common block in order to match what C will do. */ tree field = NULL_TREE; field = TYPE_FIELDS (TREE_TYPE (decl)); if (DECL_CHAIN (field) == NULL_TREE) DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field)); } DECL_USER_ALIGN (decl) = 0; GFC_DECL_COMMON_OR_EQUIV (decl) = 1; gfc_set_decl_location (decl, &com->where); if (com->threadprivate) DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); /* Place the back end declaration for this common block in GLOBAL_BINDING_LEVEL. */ common_sym->backend_decl = pushdecl_top_level (decl); } /* Has no initial values. */ if (!is_init) { DECL_INITIAL (decl) = NULL_TREE; DECL_COMMON (decl) = 1; DECL_DEFER_OUTPUT (decl) = 1; } else { DECL_INITIAL (decl) = error_mark_node; DECL_COMMON (decl) = 0; DECL_DEFER_OUTPUT (decl) = 0; } return decl; }
static void translate_common (gfc_common_head *common, gfc_symbol *var_list) { gfc_symbol *sym; segment_info *s; segment_info *common_segment; HOST_WIDE_INT offset; HOST_WIDE_INT current_offset; unsigned HOST_WIDE_INT align; bool saw_equiv; common_segment = NULL; offset = 0; current_offset = 0; align = 1; saw_equiv = false; /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) { current_segment = common_segment; s = find_segment_info (sym); /* Symbol has already been added via an equivalence. Multiple use associations of the same common block result in equiv_built being set but no information about the symbol in the segment. */ if (s && sym->equiv_built) { /* Ensure the current location is properly aligned. */ align = TYPE_ALIGN_UNIT (s->field); current_offset = (current_offset + align - 1) &~ (align - 1); /* Verify that it ended up where we expect it. */ if (s->offset != current_offset) { gfc_error ("Equivalence for '%s' does not match ordering of " "COMMON '%s' at %L", sym->name, common->name, &common->where); } } else { /* A symbol we haven't seen before. */ s = current_segment = get_segment_info (sym, current_offset); /* Add all objects directly or indirectly equivalenced with this symbol. */ add_equivalences (&saw_equiv); if (current_segment->offset < 0) gfc_error ("The equivalence set for '%s' cause an invalid " "extension to COMMON '%s' at %L", sym->name, common->name, &common->where); if (gfc_option.flag_align_commons) offset = align_segment (&align); if (offset) { /* The required offset conflicts with previous alignment requirements. Insert padding immediately before this segment. */ if (gfc_option.warn_align_commons) { if (strcmp (common->name, BLANK_COMMON_NAME)) gfc_warning ("Padding of %d bytes required before '%s' in " "COMMON '%s' at %L; reorder elements or use " "-fno-align-commons", (int)offset, s->sym->name, common->name, &common->where); else gfc_warning ("Padding of %d bytes required before '%s' in " "COMMON at %L; reorder elements or use " "-fno-align-commons", (int)offset, s->sym->name, &common->where); } } /* Apply the offset to the new segments. */ apply_segment_offset (current_segment, offset); current_offset += offset; /* Add the new segments to the common block. */ common_segment = add_segments (common_segment, current_segment); } /* The offset of the next common variable. */ current_offset += s->length; } if (common_segment == NULL) { gfc_error ("COMMON '%s' at %L does not exist", common->name, &common->where); return; } if (common_segment->offset != 0 && gfc_option.warn_align_commons) { if (strcmp (common->name, BLANK_COMMON_NAME)) gfc_warning ("COMMON '%s' at %L requires %d bytes of padding; " "reorder elements or use -fno-align-commons", common->name, &common->where, (int)common_segment->offset); else gfc_warning ("COMMON at %L requires %d bytes of padding; " "reorder elements or use -fno-align-commons", &common->where, (int)common_segment->offset); } create_common (common, common_segment, saw_equiv); }
tree gfc_conv_constant_to_tree (gfc_expr * expr) { tree res; gcc_assert (expr->expr_type == EXPR_CONSTANT); /* If it is has a prescribed memory representation, we build a string constant and VIEW_CONVERT to its type. */ switch (expr->ts.type) { case BT_INTEGER: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_int_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); case BT_REAL: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_real_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan); case BT_LOGICAL: if (expr->representation.string) { tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_int_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); if (!integer_zerop (tmp) && !integer_onep (tmp)) gfc_warning ("Assigning value other than 0 or 1 to LOGICAL" " has undefined result at %L", &expr->where); return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp); } else return build_int_cst (gfc_get_logical_type (expr->ts.kind), expr->value.logical); case BT_COMPLEX: if (expr->representation.string) return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, gfc_get_complex_type (expr->ts.kind), gfc_build_string_const (expr->representation.length, expr->representation.string)); else { tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex), expr->ts.kind, expr->is_snan); tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex), expr->ts.kind, expr->is_snan); return build_complex (gfc_typenode_for_spec (&expr->ts), real, imag); } case BT_CHARACTER: res = gfc_build_wide_string_const (expr->ts.kind, expr->value.character.length, expr->value.character.string); return res; case BT_HOLLERITH: return gfc_build_string_const (expr->representation.length, expr->representation.string); default: fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s", gfc_typename (&expr->ts)); } }
static int gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, gfc_expr *expr, gfc_dep_check elemental) { gfc_expr *arg; gcc_assert (var->expr_type == EXPR_VARIABLE); gcc_assert (var->rank > 0); switch (expr->expr_type) { case EXPR_VARIABLE: /* In case of elemental subroutines, there is no dependency between two same-range array references. */ if (gfc_ref_needs_temporary_p (expr->ref) || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) { if (elemental == ELEM_DONT_CHECK_VARIABLE) { /* Too many false positive with pointers. */ if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) { /* Elemental procedures forbid unspecified intents, and we don't check dependencies for INTENT_IN args. */ gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); /* We are told not to check dependencies. We do it, however, and issue a warning in case we find one. If a dependency is found in the case elemental == ELEM_CHECK_VARIABLE, we will generate a temporary, so we don't need to bother the user. */ gfc_warning ("INTENT(%s) actual argument at %L might " "interfere with actual argument at %L.", intent == INTENT_OUT ? "OUT" : "INOUT", &var->where, &expr->where); } return 0; } else return 1; } return 0; case EXPR_ARRAY: return gfc_check_dependency (var, expr, 1); case EXPR_FUNCTION: if (intent != INTENT_IN && expr->inline_noncopying_intrinsic && (arg = gfc_get_noncopying_intrinsic_argument (expr)) && gfc_check_argument_var_dependency (var, intent, arg, elemental)) return 1; if (elemental) { if ((expr->value.function.esym && expr->value.function.esym->attr.elemental) || (expr->value.function.isym && expr->value.function.isym->elemental)) return gfc_check_fncall_dependency (var, intent, NULL, expr->value.function.actual, ELEM_CHECK_VARIABLE); } return 0; case EXPR_OP: /* In case of non-elemental procedures, there is no need to catch dependencies, as we will make a temporary anyway. */ if (elemental) { /* If the actual arg EXPR is an expression, we need to catch a dependency between variables in EXPR and VAR, an intent((IN)OUT) variable. */ if (expr->value.op.op1 && gfc_check_argument_var_dependency (var, intent, expr->value.op.op1, ELEM_CHECK_VARIABLE)) return 1; else if (expr->value.op.op2 && gfc_check_argument_var_dependency (var, intent, expr->value.op.op2, ELEM_CHECK_VARIABLE)) return 1; } return 0; default: return 0; } }
static tree build_common_decl (gfc_common_head *com, tree union_type, bool is_init) { gfc_symbol *common_sym; tree decl; /* Create a namespace to store symbols for common blocks. */ if (gfc_common_ns == NULL) gfc_common_ns = gfc_get_namespace (NULL); gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; /* Update the size of this common block as needed. */ if (decl != NULL_TREE) { tree size = TYPE_SIZE_UNIT (union_type); if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) { /* Named common blocks of the same name shall be of the same size in all scoping units of a program in which they appear, but blank common blocks may be of different sizes. */ if (strcmp (com->name, BLANK_COMMON_NAME)) gfc_warning ("Named COMMON block '%s' at %L shall be of the " "same size", com->name, &com->where); DECL_SIZE_UNIT (decl) = size; } } /* If this common block has been declared in a previous program unit, and either it is already initialized or there is no new initialization for it, just return. */ if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) return decl; /* If there is no backend_decl for the common block, build it. */ if (decl == NULL_TREE) { decl = build_decl (VAR_DECL, get_identifier (com->name), union_type); SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name)); TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; DECL_USER_ALIGN (decl) = 0; gfc_set_decl_location (decl, &com->where); /* Place the back end declaration for this common block in GLOBAL_BINDING_LEVEL. */ common_sym->backend_decl = pushdecl_top_level (decl); } /* Has no initial values. */ if (!is_init) { DECL_INITIAL (decl) = NULL_TREE; DECL_COMMON (decl) = 1; DECL_DEFER_OUTPUT (decl) = 1; } else { DECL_INITIAL (decl) = error_mark_node; DECL_COMMON (decl) = 0; DECL_DEFER_OUTPUT (decl) = 0; } return decl; }
static void translate_common (gfc_common_head *common, gfc_symbol *var_list) { gfc_symbol *sym; segment_info *s; segment_info *common_segment; HOST_WIDE_INT offset; HOST_WIDE_INT current_offset; unsigned HOST_WIDE_INT align; unsigned HOST_WIDE_INT max_align; bool saw_equiv; common_segment = NULL; current_offset = 0; max_align = 1; saw_equiv = false; /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) { if (sym->equiv_built) { /* Symbol has already been added via an equivalence. */ current_segment = common_segment; s = find_segment_info (sym); /* Ensure the current location is properly aligned. */ align = TYPE_ALIGN_UNIT (s->field); current_offset = (current_offset + align - 1) &~ (align - 1); /* Verify that it ended up where we expect it. */ if (s->offset != current_offset) { gfc_error ("Equivalence for '%s' does not match ordering of " "COMMON '%s' at %L", sym->name, common->name, &common->where); } } else { /* A symbol we haven't seen before. */ s = current_segment = get_segment_info (sym, current_offset); /* Add all objects directly or indirectly equivalenced with this symbol. */ add_equivalences (&saw_equiv); if (current_segment->offset < 0) gfc_error ("The equivalence set for '%s' cause an invalid " "extension to COMMON '%s' at %L", sym->name, common->name, &common->where); offset = align_segment (&align); if (offset & (max_align - 1)) { /* The required offset conflicts with previous alignment requirements. Insert padding immediately before this segment. */ gfc_warning ("Padding of %d bytes required before '%s' in " "COMMON '%s' at %L", offset, s->sym->name, common->name, &common->where); } else { /* Offset the whole common block. */ apply_segment_offset (common_segment, offset); } /* Apply the offset to the new segments. */ apply_segment_offset (current_segment, offset); current_offset += offset; if (max_align < align) max_align = align; /* Add the new segments to the common block. */ common_segment = add_segments (common_segment, current_segment); } /* The offset of the next common variable. */ current_offset += s->length; } if (common_segment->offset != 0) { gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start", common->name, &common->where, common_segment->offset); } create_common (common, common_segment, saw_equiv); }