CbC/CbC_gcc: gcc/fortran/expr.c comparison

comparison gcc/fortran/expr.c @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 /* Routines for manipulation of expression nodes.
-Copyright (C) 2000-2017 Free Software Foundation, Inc.
+Copyright (C) 2000-2018 Free Software Foundation, Inc.
 Contributed by Andy Vaught
 This file is part of GCC.
 GCC is free software; you can redistribute it and/or modify it under
 #include "gfortran.h"
 #include "arith.h"
 #include "match.h"
 #include "target-memory.h" /* for gfc_convert_boz */
 #include "constructor.h"
+#include "tree.h"
 /* The following set of functions provide access to gfc_expr* of
 various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
 /* Get a new expression node that is an string constant.
 If no string is passed, a string of len is allocated,
 blanked and null-terminated.  */
 gfc_expr *
-gfc_get_character_expr (int kind, locus *where, const char *src, int len)
+gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len)
 {
 gfc_expr *e;
 gfc_char_t *dest;
 if (!src)
 /* Get a new expression node that is an integer constant.  */
 gfc_expr *
-gfc_get_int_expr (int kind, locus *where, int value)
+gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
 {
 gfc_expr *p;
 p = gfc_get_constant_expr (BT_INTEGER, kind,
 			     where ? where : &gfc_current_locus);
-mpz_set_si (p->value.integer, value);
+const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
+wi::to_mpz (w, p->value.integer, SIGNED);
 return p;
 }
 return false;
 }
+/* Same as gfc_extract_int, but use a HWI.  */
+bool
+gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error)
+{
+gfc_ref *ref;
+/* A KIND component is a parameter too. The expression for it is
+stored in the initializer and should be consistent with the tests
+below.  */
+if (gfc_expr_attr(expr).pdt_kind)
+{
+for (ref = expr->ref; ref; ref = ref->next)
+	{
+	  if (ref->u.c.component->attr.pdt_kind)
+	    expr = ref->u.c.component->initializer;
+	}
+}
+if (expr->expr_type != EXPR_CONSTANT)
+{
+if (report_error > 0)
+	gfc_error ("Constant expression required at %C");
+else if (report_error < 0)
+	gfc_error_now ("Constant expression required at %C");
+return true;
+}
+if (expr->ts.type != BT_INTEGER)
+{
+if (report_error > 0)
+	gfc_error ("Integer expression required at %C");
+else if (report_error < 0)
+	gfc_error_now ("Integer expression required at %C");
+return true;
+}
+/* Use long_long_integer_type_node to determine when to saturate.  */
+const wide_int val = wi::from_mpz (long_long_integer_type_node,
+				     expr->value.integer, false);
+if (!wi::fits_shwi_p (val))
+{
+if (report_error > 0)
+	gfc_error ("Integer value too large in expression at %C");
+else if (report_error < 0)
+	gfc_error_now ("Integer value too large in expression at %C");
+return true;
+}
+*result = val.to_shwi ();
+return false;
+}
 /* Recursively copy a list of reference structures.  */
 gfc_ref *
 gfc_copy_ref (gfc_ref *src)
 {
 if (e->symtree->n.sym->attr.subref_array_pointer)
 return true;
 if (e->symtree->n.sym->ts.type == BT_CLASS
 && e->symtree->n.sym->attr.dummy
+&& CLASS_DATA (e->symtree->n.sym)->attr.dimension
 && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
 return true;
 seen_array = false;
 for (ref = e->ref; ref; ref = ref->next)
 /* Pull a substring out of an expression.  */
 static bool
 find_substring_ref (gfc_expr *p, gfc_expr **newp)
 {
-int end;
+gfc_charlen_t end;
-int start;
+gfc_charlen_t start;
-int length;
+gfc_charlen_t length;
 gfc_char_t *chr;
 if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
 || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
 return false;
 *newp = gfc_copy_expr (p);
 free ((*newp)->value.character.string);
-end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
+end = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.end->value.integer);
-start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
+start = (gfc_charlen_t) mpz_get_ui (p->ref->u.ss.start->value.integer);
-length = end - start + 1;
+if (end >= start)
+length = end - start + 1;
+else
+length = 0;
 chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
 (*newp)->value.character.length = length;
 memcpy (chr, &p->value.character.string[start - 1],
 	  length * sizeof (gfc_char_t));
 		    {
 		      /* If this is a CHARACTER array and we possibly took
 			 a substring out of it, update the type-spec's
 			 character length according to the first element
 			 (as all should have the same length).  */
-		      int string_len;
+		      gfc_charlen_t string_len;
 		      if ((c = gfc_constructor_first (p->value.constructor)))
 			{
 			  const gfc_expr* first = c->expr;
 			  gcc_assert (first->expr_type == EXPR_CONSTANT);
 			  gcc_assert (first->ts.type == BT_CHARACTER);
 						      NULL);
 		      else
 			gfc_free_expr (p->ts.u.cl->length);
 		      p->ts.u.cl->length
-			= gfc_get_int_expr (gfc_default_integer_kind,
+			= gfc_get_int_expr (gfc_charlen_int_kind,
 					    NULL, string_len);
 		    }
 		}
 	      gfc_free_ref_list (p->ref);
 	      p->ref = NULL;
 simplify_parameter_variable (gfc_expr *p, int type)
 {
 gfc_expr *e;
 bool t;
+if (gfc_is_size_zero_array (p))
+{
+if (p->expr_type == EXPR_ARRAY)
+	return true;
+e = gfc_get_expr ();
+e->expr_type = EXPR_ARRAY;
+e->ts = p->ts;
+e->rank = p->rank;
+e->value.constructor = NULL;
+e->shape = gfc_copy_shape (p->shape, p->rank);
+e->where = p->where;
+gfc_replace_expr (p, e);
+return true;
+}
 e = gfc_copy_expr (p->symtree->n.sym->value);
 if (e == NULL)
 return false;
 e->rank = p->rank;
 else
 gfc_free_expr (e);
 return t;
 }
+static bool
+scalarize_intrinsic_call (gfc_expr *, bool init_flag);
 /* Given an expression, simplify it by collapsing constant
 expressions.  Most simplification takes place when the expression
 tree is being constructed.  If an intrinsic function is simplified
 at some point, we get called again to collapse the result against
 bool
 gfc_simplify_expr (gfc_expr *p, int type)
 {
 gfc_actual_arglist *ap;
+gfc_intrinsic_sym* isym = NULL;
 if (p == NULL)
 return true;
 switch (p->expr_type)
 case EXPR_CONSTANT:
 case EXPR_NULL:
 break;
 case EXPR_FUNCTION:
-for (ap = p->value.function.actual; ap; ap = ap->next)
+// For array-bound functions, we don't need to optimize
+// the 'array' argument. In particular, if the argument
+// is a PARAMETER, simplifying might convert an EXPR_VARIABLE
+// into an EXPR_ARRAY; the latter has lbound = 1, the former
+// can have any lbound.
+ap = p->value.function.actual;
+if (p->value.function.isym &&
+	  (p->value.function.isym->id == GFC_ISYM_LBOUND
+	   || p->value.function.isym->id == GFC_ISYM_UBOUND
+	   || p->value.function.isym->id == GFC_ISYM_LCOBOUND
+	   || p->value.function.isym->id == GFC_ISYM_UCOBOUND))
+	ap = ap->next;
+for ( ; ap; ap = ap->next)
 	if (!gfc_simplify_expr (ap->expr, type))
 	  return false;
 if (p->value.function.isym != NULL
 	  && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
 	return false;
+if (p->expr_type == EXPR_FUNCTION)
+	{
+	  if (p->symtree)
+	    isym = gfc_find_function (p->symtree->n.sym->name);
+	  if (isym && isym->elemental)
+	    scalarize_intrinsic_call (p, false);
+	}
 break;
 case EXPR_SUBSTRING:
 if (!simplify_ref_chain (p->ref, type))
 	return false;
 if (gfc_is_constant_expr (p))
 	{
 	  gfc_char_t *s;
-	  int start, end;
+	  HOST_WIDE_INT start, end;
 	  start = 0;
 	  if (p->ref && p->ref->u.ss.start)
 	    {
-	      gfc_extract_int (p->ref->u.ss.start, &start);
+	      gfc_extract_hwi (p->ref->u.ss.start, &start);
 	      start--;  /* Convert from one-based to zero-based.  */
 	    }
 	  end = p->value.character.length;
 	  if (p->ref && p->ref->u.ss.end)
-	    gfc_extract_int (p->ref->u.ss.end, &end);
+	    gfc_extract_hwi (p->ref->u.ss.end, &end);
 	  if (end < start)
 	    end = start;
 	  s = gfc_get_wide_string (end - start + 2);
 	  s[end - start + 1] = '\0';  /* TODO: C-style string.  */
 	  free (p->value.character.string);
 	  p->value.character.string = s;
 	  p->value.character.length = end - start;
 	  p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-	  p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+	  p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
 						 NULL,
 						 p->value.character.length);
 	  gfc_free_ref_list (p->ref);
 	  p->ref = NULL;
 	  p->expr_type = EXPR_CONSTANT;
 /* Scalarize an expression for an elemental intrinsic call.  */
 static bool
-scalarize_intrinsic_call (gfc_expr *e)
+scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
 {
 gfc_actual_arglist *a, *b;
 gfc_constructor_base ctor;
 gfc_constructor *args[5] = {};  /* Avoid uninitialized warnings.  */
 gfc_constructor *ci, *new_ctor;
 gfc_expr *expr, *old;
 int n, i, rank[5], array_arg;
+int errors = 0;
+if (e == NULL)
+return false;
+a = e->value.function.actual;
+for (; a; a = a->next)
+if (a->expr && !gfc_is_constant_expr (a->expr))
+return false;
 /* Find which, if any, arguments are arrays.  Assume that the old
 expression carries the type information and that the first arg
 that is an array expression carries all the shape information.*/
 n = array_arg = 0;
 n = 0;
 a = old->value.function.actual;
 for (; a; a = a->next)
 {
 /* Check that this is OK for an initialization expression.  */
-if (a->expr && !gfc_check_init_expr (a->expr))
+if (a->expr && init_flag && !gfc_check_init_expr (a->expr))
 	goto cleanup;
 rank[n] = 0;
 if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
 	{
 	args[n] = NULL;
 n++;
 }
+gfc_get_errors (NULL, &errors);
 /* Using the array argument as the master, step through the array
 calling the function for each element and advancing the array
 constructors together.  */
 for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
 	}
 /* Simplify the function calls.  If the simplification fails, the
 	 error will be flagged up down-stream or the library will deal
 	 with it.  */
-gfc_simplify_expr (new_ctor->expr, 0);
+if (errors == 0)
+	gfc_simplify_expr (new_ctor->expr, 0);
 for (i = 0; i < n; i++)
 	if (args[i])
 	  args[i] = gfc_constructor_next (args[i]);
 	  ap->expr->ts = ap->expr->symtree->n.sym->ts;
 	}
 	/* Assumed character length will not reduce to a constant expression
 	   with LEN, as required by the standard.  */
-	if (i == 5 && not_restricted
+	if (i == 5 && not_restricted && ap->expr->symtree
 	    && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
 	    && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
 		|| ap->expr->symtree->n.sym->ts.deferred))
 	  {
 	    gfc_error ("Assumed or deferred character length variable %qs "
 	/* Try to scalarize an elemental intrinsic function that has an
 	   array argument.  */
 	isym = gfc_find_function (e->symtree->n.sym->name);
 	if (isym && isym->elemental
-	    && (t = scalarize_intrinsic_call (e)))
+	    && (t = scalarize_intrinsic_call (e, true)))
 	  break;
 }
 if (m == MATCH_YES)
 	t = gfc_simplify_expr (e, 0);
 return true;
 /* Only DATA Statements come here.  */
 if (!conform)
 {
+locus *where;
 /* Numeric can be converted to any other numeric. And Hollerith can be
 	 converted to any other type.  */
 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
 	  || rvalue->ts.type == BT_HOLLERITH)
 	return true;
 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
 	return true;
+where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
 gfc_error ("Incompatible types in DATA statement at %L; attempted "
-		 "conversion of %s to %s", &lvalue->where,
+		 "conversion of %s to %s", where,
 		 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
 return false;
 }
 		       &rvalue->where);
 	    return false;
 	  }
 }
-/* Error for assignments of contiguous pointers to targets which is not
+/* Warn for assignments of contiguous pointers to targets which is not
 contiguous.  Be lenient in the definition of what counts as
-congiguous.  */
+contiguous.  */
 if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true))
-gfc_error ("Assignment to contiguous pointer from non-contiguous "
+gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
-	       "target at %L", &rvalue->where);
+		 "non-contiguous target at %L", &rvalue->where);
 /* Warn if it is the LHS pointer may lives longer than the RHS target.  */
 if (warn_target_lifetime
 && rvalue->expr_type == EXPR_VARIABLE
 && !rvalue->symtree->n.sym->attr.save
 }
 return true;
 }
+/* Invoke gfc_build_init_expr to create an initializer expression, but do not
+* require that an expression be built.  */
+gfc_expr *
+gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
+{
+return gfc_build_init_expr (ts, where, false);
+}
 /* Build an initializer for a local integer, real, complex, logical, or
 character variable, based on the command line flags finit-local-zero,
-finit-integer=, finit-real=, finit-logical=, and finit-character=.  */
+finit-integer=, finit-real=, finit-logical=, and finit-character=.
+With force, an initializer is ALWAYS generated.  */
 gfc_expr *
-gfc_build_default_init_expr (gfc_typespec *ts, locus *where)
+gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force)
 {
-int char_len;
 gfc_expr *init_expr;
-int i;
 /* Try to build an initializer expression.  */
 init_expr = gfc_get_constant_expr (ts->type, ts->kind, where);
+/* If we want to force generation, make sure we default to zero.  */
+gfc_init_local_real init_real = flag_init_real;
+int init_logical = gfc_option.flag_init_logical;
+if (force)
+{
+if (init_real == GFC_INIT_REAL_OFF)
+	init_real = GFC_INIT_REAL_ZERO;
+if (init_logical == GFC_INIT_LOGICAL_OFF)
+	init_logical = GFC_INIT_LOGICAL_FALSE;
+}
 /* We will only initialize integers, reals, complex, logicals, and
 characters, and only if the corresponding command-line flags
 were set.  Otherwise, we free init_expr and return null.  */
 switch (ts->type)
 {
 case BT_INTEGER:
-if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
+if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF)
 mpz_set_si (init_expr->value.integer,
 gfc_option.flag_init_integer_value);
 else
 {
 gfc_free_expr (init_expr);
 init_expr = NULL;
 }
 break;
 case BT_REAL:
-switch (flag_init_real)
+switch (init_real)
 {
 case GFC_INIT_REAL_SNAN:
 init_expr->is_snan = 1;
 /* Fall through.  */
 case GFC_INIT_REAL_NAN:
 break;
 }
 break;
 case BT_COMPLEX:
-switch (flag_init_real)
+switch (init_real)
 {
 case GFC_INIT_REAL_SNAN:
 init_expr->is_snan = 1;
 /* Fall through.  */
 case GFC_INIT_REAL_NAN:
 break;
 }
 break;
 case BT_LOGICAL:
-if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE)
+if (init_logical == GFC_INIT_LOGICAL_FALSE)
 init_expr->value.logical = 0;
-else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE)
+else if (init_logical == GFC_INIT_LOGICAL_TRUE)
 init_expr->value.logical = 1;
 else
 {
 gfc_free_expr (init_expr);
 init_expr = NULL;
 break;
 case BT_CHARACTER:
 /* For characters, the length must be constant in order to
 create a default initializer.  */
-if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
 && ts->u.cl->length
 && ts->u.cl->length->expr_type == EXPR_CONSTANT)
 {
-char_len = mpz_get_si (ts->u.cl->length->value.integer);
+HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
 init_expr->value.character.length = char_len;
 init_expr->value.character.string = gfc_get_wide_string (char_len+1);
-for (i = 0; i < char_len; i++)
+for (size_t i = 0; i < (size_t) char_len; i++)
 init_expr->value.character.string[i]
 = (unsigned char) gfc_option.flag_init_character_value;
 }
 else
 {
 gfc_free_expr (init_expr);
 init_expr = NULL;
 }
-if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON
+if (!init_expr
+	  && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON)
 && ts->u.cl->length && flag_max_stack_var_size != 0)
 {
 gfc_actual_arglist *arg;
 init_expr = gfc_get_expr ();
 init_expr->where = *where;
 {
 if (ts->type == BT_CHARACTER && !attr->pointer && init
 && ts->u.cl
 && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
 {
-int len;
 gcc_assert (ts->u.cl && ts->u.cl->length);
 gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
 gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER);
-len = mpz_get_si (ts->u.cl->length->value.integer);
+HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
 if (init->expr_type == EXPR_CONSTANT)
 gfc_set_constant_character_len (len, init, -1);
 else if (init
-&& init->ts.u.cl
+	       && init->ts.type == BT_CHARACTER
+&& init->ts.u.cl && init->ts.u.cl->length
 && mpz_cmp (ts->u.cl->length->value.integer,
 init->ts.u.cl->length->value.integer))
 {
 gfc_constructor *ctor;
 ctor = gfc_constructor_first (init->value.constructor);
 if (ctor)
 {
-int first_len;
 bool has_ts = (init->ts.u.cl
 && init->ts.u.cl->length_from_typespec);
 /* Remember the length of the first element for checking
 that all elements *in the constructor* have the same
 length.  This need not be the length of the LHS!  */
 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
 gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
-first_len = ctor->expr->value.character.length;
+gfc_charlen_t first_len = ctor->expr->value.character.length;
 for ( ; ctor; ctor = gfc_constructor_next (ctor))
 if (ctor->expr->expr_type == EXPR_CONSTANT)
 {
 gfc_set_constant_character_len (len, ctor->expr,
 *map_p = NULL;
 return init;
 }
+static bool
+class_allocatable (gfc_component *comp)
+{
+return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+&& CLASS_DATA (comp)->attr.allocatable;
+}
+static bool
+class_pointer (gfc_component *comp)
+{
+return comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+&& CLASS_DATA (comp)->attr.pointer;
+}
+static bool
+comp_allocatable (gfc_component *comp)
+{
+return comp->attr.allocatable || class_allocatable (comp);
+}
+static bool
+comp_pointer (gfc_component *comp)
+{
+return comp->attr.pointer
+|| comp->attr.pointer
+|| comp->attr.proc_pointer
+|| comp->attr.class_pointer
+|| class_pointer (comp);
+}
 /* Fetch or generate an initializer for the given component.
 Only generate an initializer if generate is true.  */
 static gfc_expr *
-component_initializer (gfc_typespec *ts, gfc_component *c, bool generate)
+component_initializer (gfc_component *c, bool generate)
 {
 gfc_expr *init = NULL;
-/* See if we can find the initializer immediately.
+/* Allocatable components always get EXPR_NULL.
-Some components should never get initializers.  */
+Pointer components are only initialized when generating, and only if they
-if (c->initializer || !generate
+do not already have an initializer.  */
-|| (ts->type == BT_CLASS && !c->attr.allocatable)
+if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer))
-|| c->attr.pointer
+{
-|| c->attr.class_pointer
+init = gfc_get_null_expr (&c->loc);
-|| c->attr.proc_pointer)
+init->ts = c->ts;
+return init;
+}
+/* See if we can find the initializer immediately.  */
+if (c->initializer || !generate)
 return c->initializer;
 /* Recursively handle derived type components.  */
-if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
 init = gfc_generate_initializer (&c->ts, true);
 else if (c->ts.type == BT_UNION && c->ts.u.derived->components)
 {
 gfc_component *map = NULL;
 }
 /* Treat simple components like locals.  */
 else
 {
-init = gfc_build_default_init_expr (&c->ts, &c->loc);
+/* We MUST give an initializer, so force generation.  */
+init = gfc_build_init_expr (&c->ts, &c->loc, true);
 gfc_apply_init (&c->ts, &c->attr, init);
 }
 return init;
 }
 gfc_default_initializer (gfc_typespec *ts)
 {
 return gfc_generate_initializer (ts, false);
 }
+/* Generate an initializer expression for an iso_c_binding type
+such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr.  */
+static gfc_expr *
+generate_isocbinding_initializer (gfc_symbol *derived)
+{
+/* The initializers have already been built into the c_null_[fun]ptr symbols
+from gen_special_c_interop_ptr.  */
+gfc_symtree *npsym = NULL;
+if (0 == strcmp (derived->name, "c_ptr"))
+gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym);
+else if (0 == strcmp (derived->name, "c_funptr"))
+gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym);
+else
+gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding"
+			" type, expected %<c_ptr%> or %<c_funptr%>");
+if (npsym)
+{
+gfc_expr *init = gfc_copy_expr (npsym->n.sym->value);
+init->symtree = npsym;
+init->ts.is_iso_c = true;
+return init;
+}
+return NULL;
+}
 /* Get or generate an expression for a default initializer of a derived type.
 If -finit-derived is specified, generate default initialization expressions
 for components that lack them when generate is set.  */
 gfc_expr *
 gfc_generate_initializer (gfc_typespec *ts, bool generate)
 {
 gfc_expr *init, *tmp;
 gfc_component *comp;
 generate = flag_init_derived && generate;
+if (ts->u.derived->ts.is_iso_c && generate)
+return generate_isocbinding_initializer (ts->u.derived);
 /* See if we have a default initializer in this, but not in nested
 types (otherwise we could use gfc_has_default_initializer()).
 We don't need to check if we are going to generate them.  */
 comp = ts->u.derived->components;
 if (!generate)
 {
 for (; comp; comp = comp->next)
-if (comp->initializer || comp->attr.allocatable
+	if (comp->initializer || comp_allocatable (comp))
-|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
-&& CLASS_DATA (comp)->attr.allocatable))
 break;
 }
 if (!comp)
 return NULL;
 for (comp = ts->u.derived->components; comp; comp = comp->next)
 {
 gfc_constructor *ctor = gfc_constructor_get();
 /* Fetch or generate an initializer for the component.  */
-tmp = component_initializer (ts, comp, generate);
+tmp = component_initializer (comp, generate);
 if (tmp)
 	{
 	  /* Save the component ref for STRUCTUREs and UNIONs.  */
 	  if (ts->u.derived->attr.flavor == FL_STRUCT
 	      || ts->u.derived->attr.flavor == FL_UNION)
 	    ctor->n.component = comp;
 /* If the initializer was not generated, we need a copy.  */
 ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp;
-	  if ((comp->ts.type != tmp->ts.type
+	  if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind)
-	       || comp->ts.kind != tmp->ts.kind)
 	      && !comp->attr.pointer && !comp->attr.proc_pointer)
 	    {
 	      bool val;
 	      val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false);
 	      if (val == false)
 		return NULL;
 	    }
-	}
-if (comp->attr.allocatable
-	  || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
-	{
-	  ctor->expr = gfc_get_expr ();
-	  ctor->expr->expr_type = EXPR_NULL;
-	  ctor->expr->where = init->where;
-	  ctor->expr->ts = comp->ts;
 	}
 gfc_constructor_append (&init->value.constructor, ctor);
 }
 /* Determine if an expression is a function with an allocatable class array
 result.  */
 bool
-gfc_is_alloc_class_array_function (gfc_expr *expr)
+gfc_is_class_array_function (gfc_expr *expr)
 {
 if (expr->expr_type == EXPR_FUNCTION
 && expr->value.function.esym
 && expr->value.function.esym->result
 && expr->value.function.esym->result->ts.type == BT_CLASS
 && CLASS_DATA (expr->value.function.esym->result)->attr.dimension
-&& CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
+&& (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
+	  || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
 return true;
 return false;
 }
 return true;
 }
 gfc_expr *
-gfc_find_stat_co(gfc_expr *e)
+gfc_find_team_co (gfc_expr *e)
+{
+gfc_ref *ref;
+for (ref = e->ref; ref; ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+return ref->u.ar.team;
+if (e->value.function.actual->expr)
+for (ref = e->value.function.actual->expr->ref; ref;
+	 ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+	return ref->u.ar.team;
+return NULL;
+}
+gfc_expr *
+gfc_find_stat_co (gfc_expr *e)
 {
 gfc_ref *ref;
 for (ref = e->ref; ref; ref = ref->next)
 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
 gfc_array_ref *ar = NULL;
 gfc_ref *ref, *part_ref = NULL;
 gfc_symbol *sym;
 if (expr->expr_type == EXPR_FUNCTION)
-return expr->value.function.esym
+{
-	   ? expr->value.function.esym->result->attr.contiguous : false;
+if (expr->value.function.esym)
+	return expr->value.function.esym->result->attr.contiguous;
+else
+	{
+	  /* Type-bound procedures.  */
+	  gfc_symbol *s = expr->symtree->n.sym;
+	  if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED)
+	    return false;
+	  gfc_ref *rc = NULL;
+	  for (gfc_ref *r = expr->ref; r; r = r->next)
+	    if (r->type == REF_COMPONENT)
+	      rc = r;
+	  if (rc == NULL || rc->u.c.component == NULL
+	      || rc->u.c.component->ts.interface == NULL)
+	    return false;
+	  return rc->u.c.component->ts.interface->attr.contiguous;
+	}
+}
 else if (expr->expr_type != EXPR_VARIABLE)
 return false;
 if (!permit_element && expr->rank == 0)
 return false;
 	ar = &ref->u.ar;
 }
 sym = expr->symtree->n.sym;
 if (expr->ts.type != BT_CLASS
-	&& ((part_ref
+&& ((part_ref
-		&& !part_ref->u.c.component->attr.contiguous
+	   && !part_ref->u.c.component->attr.contiguous
-		&& part_ref->u.c.component->attr.pointer)
+	   && part_ref->u.c.component->attr.pointer)
-	    || (!part_ref
+	  || (!part_ref
-		&& !sym->attr.contiguous
+	      && !sym->attr.contiguous
-		&& (sym->attr.pointer
+	      && (sym->attr.pointer
-		    || sym->as->type == AS_ASSUMED_RANK
+		  || (sym->as && sym->as->type == AS_ASSUMED_RANK)
-		    || sym->as->type == AS_ASSUMED_SHAPE))))
+		  || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
 return false;
 if (!ar || ar->type == AR_FULL)
 return true;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/expr.c @ 131:84e7813d76e9