+2014-09-20 Joost VandeVondele <vondele@gcc.gnu.org>
+
+ * trans-expr.c (gfc_reset_vptr): Fix comment whitespace.
+ (gfc_conv_class_to_class): Likewise.
+ (gfc_conv_procedure_call): Likewise.
+ (arrayfunc_assign_needs_temporary): Likewise.
+ (realloc_lhs_loop_for_fcn_call): Likewise.
+ (gfc_trans_assignment_1): Likewise.
+ * trans-array.c (gfc_conv_array_ref): Likewise.
+ (gfc_array_allocate): Likewise.
+ (gfc_alloc_allocatable_for_assignment): Likewise.
+ * symbol.c (generate_isocbinding_symbol): Likewise.
+ * class.c (finalization_scalarizer): Likewise.
+ (finalizer_insert_packed_call): Likewise.
+ (generate_finalization_wrapper): Likewise.
+ (find_intrinsic_vtab): Likewise.
+ * decl.c (gfc_match_import): Likewise.
+ (match_procedure_decl): Likewise.
+ (gfc_match_subroutine): Likewise.
+ (gfc_match_bind_c): Likewise.
+ (gfc_match_volatile): Likewise.
+ * trans-common.c (create_common): Likewise.
+ * error.c (gfc_diagnostic_starter): Likewise.
+ * trans-stmt.c (gfc_trans_sync): Likewise.
+ (gfc_trans_critical): Likewise.
+ (gfc_trans_simple_do): Likewise.
+ (gfc_trans_do): Likewise.
+ (gfc_trans_where_assign): Likewise.
+ * expr.c (gfc_is_simply_contiguous): Likewise.
+ * module.c (unquote_string): Likewise.
+ * trans.c (gfc_add_finalizer_call): Likewise.
+ * trans-types.c (gfc_init_kinds): Likewise.
+ * scanner.c (preprocessor_line): Likewise.
+ * gfortranspec.c (lang_specific_driver): Likewise.
+ * frontend-passes.c (create_var): Likewise.
+ (cfe_expr_0): Likewise.
+ * resolve.c (check_host_association): Likewise.
+ (gfc_resolve_code): Likewise.
+ (resolve_fl_derived0): Likewise.
+ (resolve_symbol): Likewise.
+ * f95-lang.c (poplevel): Likewise.
+ * trans-decl.c (create_main_function): Likewise.
+ * trans-io.c (transfer_expr): Likewise.
+ * arith.c (gfc_arith_divide): Likewise.
+ * parse.c (resolve_all_program_units): Likewise.
+ * check.c (gfc_check_rank): Likewise.
+ (gfc_check_sizeof): Likewise.
+ (is_c_interoperable): Likewise.
+ * dependency.c (gfc_dep_difference): Likewise.
+ * primary.c (gfc_match_rvalue): Likewise.
+ * trans-intrinsic.c (conv_intrinsic_system_clock): Likewise.
+ (conv_isocbinding_subroutine): Likewise.
+ * options.c (gfc_post_options): Likewise.
+ (gfc_handle_fpe_option): Likewise.
+ (gfc_get_option_string): Likewise.
+ * simplify.c (simplify_transformation_to_scalar): Likewise.
+ (gfc_simplify_spread): Likewise.
+
2014-09-19 Joost VandeVondele <vondele@gcc.gnu.org>
PR fortran/63152
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
{
/* In Fortran, return (NaN + NaN I) for any zero divisor. See
- PR 40318. */
+ PR 40318. */
mpfr_set_nan (mpc_realref (result->value.complex));
mpfr_set_nan (mpc_imagref (result->value.complex));
}
}
-/* Convert Hollerith to character. */
+/* Convert Hollerith to character. */
gfc_expr *
gfc_hollerith2character (gfc_expr *src, int kind)
bool is_variable = true;
- /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
+ /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
if (a->expr_type == EXPR_FUNCTION)
is_variable = a->value.function.esym
? a->value.function.esym->result->attr.pointer
If c_loc is true, character with len > 1 are allowed (cf. Fortran
2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape
arrays are permitted. And if c_f_ptr is true, deferred-shape arrays
- are permitted. */
+ are permitted. */
static bool
is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
if (expr->ts.deferred)
{
/* TS 29113 allows deferred-length strings as dummy arguments,
- but it is not an interoperable type. */
+ but it is not an interoperable type. */
*msg = "Expression shall not be a deferred-length string";
return false;
}
block->ext.actual->next = gfc_get_actual_arglist ();
block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
NULL, 0);
- block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
+ block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
/* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
block2->expr1 = gfc_lval_expr_from_sym (ptr2);
block2->expr2 = gfc_lval_expr_from_sym (ptr);
- /* Call now the user's final subroutine. */
+ /* Call now the user's final subroutine. */
block->next = gfc_get_code (EXEC_CALL);
block = block->next;
block->symtree = fini->proc_tree;
return;
}
- /* Search for the ancestor's finalizers. */
+ /* Search for the ancestor's finalizers. */
if (derived->attr.extension && derived->components
&& (!derived->components->ts.u.derived->attr.abstract
|| has_finalizer_component (derived)))
3. Call the ancestor's finalizer. */
/* Declare the wrapper function; it takes an assumed-rank array
- and a VALUE logical as arguments. */
+ and a VALUE logical as arguments. */
/* Set up the namespace. */
sub_ns = gfc_get_namespace (ns, 0);
last_code->ext.iterator = iter;
last_code->block = gfc_get_code (EXEC_DO);
- /* strides(idx) = _F._stride(array,dim=idx). */
+ /* strides(idx) = _F._stride(array,dim=idx). */
last_code->block->next = gfc_get_code (EXEC_ASSIGN);
block = last_code->block->next;
gfc_lval_expr_from_sym (array),
gfc_lval_expr_from_sym (idx));
- /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
+ /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
block->next = gfc_get_code (EXEC_ASSIGN);
block = block->next;
- /* sizes(idx) = ... */
+ /* sizes(idx) = ... */
block->expr1 = gfc_lval_expr_from_sym (sizes);
block->expr1->ref = gfc_get_ref ();
block->expr1->ref->type = REF_ARRAY;
block->expr2->expr_type = EXPR_OP;
block->expr2->value.op.op = INTRINSIC_TIMES;
- /* sizes(idx-1). */
+ /* sizes(idx-1). */
block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
block->expr2->value.op.op1->ref = gfc_get_ref ();
block->expr2->value.op.op1->ref->type = REF_ARRAY;
c->attr.access = ACCESS_PRIVATE;
/* Build a minimal expression to make use of
- target-memory.c/gfc_element_size for 'size'. */
+ target-memory.c/gfc_element_size for 'size'. */
e = gfc_get_expr ();
e->ts = *ts;
e->expr_type = EXPR_VARIABLE;
{
/* The actual derived type is stored in a symtree with the first
letter of the name capitalized; the symtree with the all
- lower-case name contains the associated generic function. */
+ lower-case name contains the associated generic function. */
st = gfc_new_symtree (&gfc_current_ns->sym_root,
gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) name[0]),
int num;
gfc_expr *initializer = NULL;
- /* Parse interface (with brackets). */
+ /* Parse interface (with brackets). */
m = match_procedure_interface (&proc_if);
if (m != MATCH_YES)
return m;
return MATCH_ERROR;
/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
- the symbol existed before. */
+ the symbol existed before. */
sym->declared_at = gfc_current_locus;
if (add_hidden_procptr_result (sym))
/* No binding label, but if symbol isn't null, we
can set the label for it here.
If name="" or allow_binding_name is false, no C binding name is
- created. */
+ created. */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
}
for(;;)
{
/* VOLATILE is special because it can be added to host-associated
- symbols locally. Except for coarrays. */
+ symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1);
switch (m)
{
return true;
}
- /* Case 3: (c1 + X) - X = c1. */
+ /* Case 3: (c1 + X) - X = c1. */
if (e1_op1->expr_type == EXPR_CONSTANT
&& gfc_dep_compare_expr (e1_op2, e2) == 0)
{
#undef IS_CONSTANT_INTEGER
- /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
+ /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
if (l_dir == 1 && r_dir == 1 &&
(start_comparison == 0 || start_comparison == -1)
{
pp_newline (context->printer);
/* If the caret line was shown, the prefix does not contain the
- locus. */
+ locus. */
pp_set_prefix (context->printer, prefix);
}
else
for (ref = expr->ref; ref; ref = ref->next)
{
if (ar)
- return false; /* Array shall be last part-ref. */
+ return false; /* Array shall be last part-ref. */
if (ref->type == REF_COMPONENT)
part_ref = ref;
return current_binding_level->names;
}
-/* Enter a new binding level. */
+/* Enter a new binding level. */
void
pushlevel (void)
current_binding_level = current_binding_level->level_chain;
if (functionbody)
- /* This is the top level block of a function. */
+ /* This is the top level block of a function. */
DECL_INITIAL (current_function_decl) = block_node;
else if (current_binding_level == global_binding_level)
/* When using gfc_start_block/gfc_finish_block from middle-end hooks,
static bool in_assoc_list;
-/* Entry point - run all passes for a namespace. */
+/* Entry point - run all passes for a namespace. */
void
gfc_run_passes (gfc_namespace *ns)
if (e->shape == NULL)
{
/* We don't know the shape at compile time, so we use an
- allocatable. */
+ allocatable. */
symbol->as->type = AS_DEFERRED;
symbol->attr.allocatable = 1;
}
gfc_expr *newvar;
gfc_expr **ei, **ej;
- /* Don't do this optimization within OMP workshare. */
+ /* Don't do this optimization within OMP workshare. */
if (in_omp_workshare)
{
/* By default, we throw on the math library if we have one. */
int need_math = (MATH_LIBRARY[0] != '\0');
- /* Whether we should link a static libgfortran. */
+ /* Whether we should link a static libgfortran. */
int static_lib = 0;
/* Whether we need to link statically. */
if (p[1] == '\\')
p++;
else if (p[1] == 'U')
- p += 9; /* That is a "\U????????". */
+ p += 9; /* That is a "\U????????". */
else
gfc_internal_error ("unquote_string(): got bad string");
}
break;
#include "iso-c-binding.def"
default:
- ; /* Not GFC_STD_* versioned. */
+ ; /* Not GFC_STD_* versioned. */
}
switch (i)
}
-/* Remove duplicated intrinsic operators from the rename list. */
+/* Remove duplicated intrinsic operators from the rename list. */
static void
rename_list_remove_duplicate (gfc_use_rename *list)
}
/* Get ready for options handling. Keep in sync with
- libgfortran/runtime/compile_options.c (init_compile_options). */
+ libgfortran/runtime/compile_options.c (init_compile_options). */
void
gfc_init_options (unsigned int decoded_options_count,
gfc_option.flag_stack_arrays = optimize_fast;
/* By default, disable (re)allocation during assignment for -std=f95,
- and enable it for F2003/F2008/GNU/Legacy. */
+ and enable it for F2003/F2008/GNU/Legacy. */
if (gfc_option.flag_realloc_lhs == -1)
{
if (gfc_option.allow_std & GFC_STD_F2003)
GFC_FPE_INEXACT,
0 };
- /* As the default for -ffpe-summary= is nonzero, set it to 0. */
+ /* As the default for -ffpe-summary= is nonzero, set it to 0. */
if (!trap)
gfc_option.fpe_summary = 0;
/* Ignore these. */
break;
default:
- /* Ignore file names. */
+ /* Ignore file names. */
if (save_decoded_options[j].orig_option_with_args_text[0] == '-')
len += 1
+ strlen (save_decoded_options[j].orig_option_with_args_text);
break;
default:
- /* Ignore file names. */
+ /* Ignore file names. */
if (save_decoded_options[j].orig_option_with_args_text[0] != '-')
continue;
break;
}
- /* If match_deferred_characteristics failed, then there is an error. */
+ /* If match_deferred_characteristics failed, then there is an error. */
if (bad_characteristic)
{
ts = &gfc_current_block ()->result->ts;
}
-/* Resolve all the program units. */
+/* Resolve all the program units. */
static void
resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
{
procedure, yet it is not sure to be the name of a function. */
case FL_PROCEDURE:
- /* Procedure Pointer Assignments. */
+ /* Procedure Pointer Assignments. */
procptr0:
if (gfc_matching_procptr_assignment)
{
{
/* Original was function so point to the new symbol, since
the actual argument list is already attached to the
- expression. */
+ expression. */
e->value.function.esym = NULL;
e->symtree = st;
}
break;
/* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
- the LHS. */
+ the LHS. */
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
super_type = gfc_get_derived_super_type (sym);
- /* F2008, C432. */
+ /* F2008, C432. */
if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)
{
gfc_error ("As extending type '%s' at %L has a coarray component, "
as = sym->as;
}
- /* F2008, C530. */
+ /* F2008, C530. */
if (sym->attr.contiguous
&& (!class_attr.dimension
|| (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
{
/* FIXME: we leak the old filename because a pointer to it may be stored
in the linemap. Alternative could be using GC or updating linemap to
- point to the new name, but there is no API for that currently. */
+ point to the new name, but there is no API for that currently. */
current_file->filename = xstrdup (filename);
}
/* Build a result expression for transformational intrinsics,
- depending on DIM. */
+ depending on DIM. */
static gfc_expr *
transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
REAL, PARAMETER :: array(n, m) = ...
REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
- where OP == gfc_multiply(). The result might be post processed using post_op. */
+ where OP == gfc_multiply().
+ The result might be post processed using post_op. */
static gfc_expr *
simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
else
/* FIXME: Returning here avoids a regression in array_simplify_1.f90.
Replace NULL with gcc_unreachable() after implementing
- gfc_simplify_cshift(). */
+ gfc_simplify_cshift(). */
return NULL;
if (source->ts.type == BT_CHARACTER)
|| tmp_symtree->n.sym->intmod_sym_id != s))
tmp_symtree = NULL;
- /* Already exists in this scope so don't re-add it. */
+ /* Already exists in this scope so don't re-add it. */
if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
&& (!tmp_sym->attr.generic
|| (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
&& TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
- /* Use the actual tree type and not the wrapped coarray. */
+ /* Use the actual tree type and not the wrapped coarray. */
if (!se->want_pointer)
se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
se->expr);
gfc_add_expr_to_block (&se->pre, tmp);
- /* Update the array descriptors. */
+ /* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
size2 = gfc_evaluate_now (size2, &fblock);
/* Realloc expression. Note that the scalarizer uses desc.data
- in the array reference - (*desc.data)[<element>]. */
+ in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
if ((expr1->ts.type == BT_DERIVED)
DECL_IGNORED_P (var_decl) = 1;
if (s->sym->attr.target)
TREE_ADDRESSABLE (var_decl) = 1;
- /* Fake variables are not visible from other translation units. */
+ /* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0;
gfc_finish_decl_attrs (var_decl, &s->sym->attr);
/* Initialize INTENT(OUT) derived type dummies. As well as giving
them their default initializer, if they do not have allocatable
- components, they have their allocatable components deallocated. */
+ components, they have their allocatable components deallocated. */
static void
init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_init_block (&body);
- /* Call some libgfortran initialization routines, call then MAIN__(). */
+ /* Call some libgfortran initialization routines, call then MAIN__(). */
/* Call _gfortran_caf_init (*argc, ***argv). */
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
/* TODO: This is the -frange-check option, which no longer affects
library behavior; when bumping the library ABI this slot can be
reused for something else. As it is the last element in the
- array, we can instead leave it out altogether. */
+ array, we can instead leave it out altogether. */
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
build_int_cst (integer_type_node, 0));
CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
gfc_ref *ref;
/* If we have a class array, we need go back to the class
- container. */
+ container. */
if (lhs->ref && lhs->ref->next && !lhs->ref->next->next
&& lhs->ref->next->type == REF_ARRAY
&& lhs->ref->next->u.ar.type == AR_FULL
ctree = gfc_class_vptr_get (var);
/* The vptr is the second field of the actual argument.
- First we have to find the corresponding class reference. */
+ First we have to find the corresponding class reference. */
tmp = NULL_TREE;
if (class_ref == NULL
&& CLASS_DATA (fsym)->attr.codimension
&& !CLASS_DATA (fsym)->attr.allocatable)))
{
- /* Token and offset. */
+ /* Token and offset. */
vec_safe_push (stringargs, null_pointer_node);
vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
gcc_assert (fsym->attr.optional);
{
/* A temporary is not needed if the function is not contained and
the variable is local or host associated and not a pointer or
- a target. */
+ a target. */
if (!expr2->value.function.esym->attr.contained)
return false;
gfc_loopinfo *loop)
{
/* Signal that the function call should not be made by
- gfc_conv_loop_setup. */
+ gfc_conv_loop_setup. */
se->ss->is_alloc_lhs = 1;
gfc_init_loopinfo (loop);
gfc_add_ss_to_loop (loop, *ss);
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
NOTE: This relies on having the exact dependence of the length type
- parameter available to the caller; gfortran saves it in the .mod files. */
+ parameter available to the caller; gfortran saves it in the .mod files. */
if (gfc_option.flag_realloc_lhs && expr2->ts.type == BT_CHARACTER
&& expr1->ts.deferred)
gfc_add_block_to_block (&block, &rse.pre);
else if (count_max)
arg3 = count_max_se.expr;
- /* Make the function call. */
+ /* Make the function call. */
gfc_init_block (&block);
tmp = build_call_expr_loc (input_location,
kind == 4 ? gfor_fndecl_system_clock4
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
- /* Set bounds and stride. */
+ /* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
- /* Calculate offset. */
+ /* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
gfc_add_block_to_block (&se->pre, &se->post);
return;
}
- /* Fall through. */
+ /* Fall through. */
case BT_HOLLERITH:
if (se->string_length)
arg2 = se->string_length;
}
/* Check SYNC IMAGES(imageset) for valid image index.
- FIXME: Add a check for image-set arrays. */
+ FIXME: Add a check for image-set arrays. */
if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& code->expr1->rank == 0)
{
}
-/* Translate a CRITICAL block. */
+/* Translate a CRITICAL block. */
tree
gfc_trans_critical (gfc_code *code)
{
gfc_add_modify_loc (loc, pblock, dovar,
fold_convert (TREE_TYPE(dovar), from));
- /* Save value for do-tinkering checking. */
+ /* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
saved_dovar = gfc_create_var (type, ".saved_dovar");
gfc_add_expr_to_block (&body, tmp);
}
- /* Check whether someone has modified the loop variable. */
+ /* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
/* Initialize the DO variable: dovar = from. */
gfc_add_modify (&block, dovar, from);
- /* Save value for do-tinkering checking. */
+ /* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
saved_dovar = gfc_create_var (type, ".saved_dovar");
gfc_add_expr_to_block (&body, tmp);
}
- /* Check whether someone has modified the loop variable. */
+ /* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
stmtblock_t body;
tree index, maskexpr;
- /* A defined assignment. */
+ /* A defined assignment. */
if (cnext && cnext->resolved_sym)
return gfc_trans_call (cnext, true, mask, count1, invert);
/* We only have two character kinds: ASCII and UCS-4.
ASCII corresponds to a 8-bit integer type, if one is available.
- UCS-4 corresponds to a 32-bit integer type, if one is available. */
+ UCS-4 corresponds to a 32-bit integer type, if one is available. */
i_index = 0;
if ((kind = get_int_kind_from_width (8)) > 0)
{
}
/* If we have a class array, we need go back to the class
- container. */
+ container. */
expr = gfc_copy_expr (expr2);
if (expr->ref && expr->ref->next && !expr->ref->next->next
projects / thirdparty / gcc.git / commitdiff
