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

comparison gcc/fortran/expr.c @ 145:1830386684a0

gcc-9.2.0

author	anatofuz
date	Thu, 13 Feb 2020 11:34:05 +0900
parents	84e7813d76e9
children

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 /* Routines for manipulation of expression nodes.
-Copyright (C) 2000-2018 Free Software Foundation, Inc.
+Copyright (C) 2000-2020 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
 	case_bt_struct:
 	case BT_CLASS:
 	case BT_ASSUMED:
 	  break;		/* Already done.  */
+	case BT_BOZ:
+	  q->boz.len = p->boz.len;
+	  q->boz.rdx = p->boz.rdx;
+	  q->boz.str = XCNEWVEC (char, q->boz.len + 1);
+	  strncpy (q->boz.str, p->boz.str, p->boz.len);
+	  break;
 	case BT_PROCEDURE:
 case BT_VOID:
 /* Should never be reached.  */
 	case BT_UNKNOWN:
 	  gfc_internal_error ("gfc_copy_expr(): Bad expr node");
 break;
 case EXPR_VARIABLE:
 case EXPR_NULL:
 break;
+case EXPR_UNKNOWN:
+gcc_unreachable ();
 }
 q->shape = gfc_copy_shape (p->shape, p->rank);
 q->ref = gfc_copy_ref (p->ref);
 	  gfc_free_expr (p->u.ss.start);
 	  gfc_free_expr (p->u.ss.end);
 	  break;
 	case REF_COMPONENT:
+	case REF_INQUIRY:
 	  break;
 	}
 free (p);
 }
 free (ar);
 break;
 case REF_COMPONENT:
 dest->u.c = src->u.c;
+break;
+case REF_INQUIRY:
+dest->u.i = src->u.i;
 break;
 case REF_SUBSTRING:
 dest->u.ss = src->u.ss;
 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
 return false;
 }
 }
+/* Is true if the expression or symbol is a passed CFI descriptor.  */
+bool
+is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
+{
+if (sym == NULL
+&& e && e->expr_type == EXPR_VARIABLE)
+sym = e->symtree->n.sym;
+if (sym && sym->attr.dummy
+&& sym->ns->proc_name->attr.is_bind_c
+&& sym->attr.dimension
+&& (sym->attr.pointer
+	  || sym->attr.allocatable
+	  || sym->as->type == AS_ASSUMED_SHAPE
+	  || sym->as->type == AS_ASSUMED_RANK))
+return true;
+return false;
+}
 /* Is true if an array reference is followed by a component or substring
 reference.  */
 bool
 is_subref_array (gfc_expr * e)
 {
 gfc_ref * ref;
 bool seen_array;
+gfc_symbol *sym;
 if (e->expr_type != EXPR_VARIABLE)
 return false;
-if (e->symtree->n.sym->attr.subref_array_pointer)
+sym = e->symtree->n.sym;
+if (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)
 {
+/* If we haven't seen the array reference and this is an intrinsic,
+	 what follows cannot be a subreference array, unless there is a
+	 substring reference.  */
+if (!seen_array && ref->type == REF_COMPONENT
+	  && ref->u.c.component->ts.type != BT_CHARACTER
+	  && ref->u.c.component->ts.type != BT_CLASS
+	  && !gfc_bt_struct (ref->u.c.component->ts.type))
+	return false;
 if (ref->type == REF_ARRAY
 	    && ref->u.ar.type != AR_ELEMENT)
 	seen_array = true;
 if (seen_array
 	    && ref->type != REF_ARRAY)
 	return seen_array;
 }
+if (sym->ts.type == BT_CLASS
+&& sym->attr.dummy
+&& CLASS_DATA (sym)->attr.dimension
+&& CLASS_DATA (sym)->attr.class_pointer)
+return true;
 return false;
 }
 /* Try to collapse intrinsic expressions.  */
 limit = mpz_get_ui (ptr);
 if (limit >= flag_max_array_constructor)
 {
 	  gfc_error ("The number of elements in the array constructor "
 		     "at %L requires an increase of the allowed %d "
-		     "upper limit.   See -fmax-array-constructor "
+		     "upper limit.  See %<-fmax-array-constructor%> "
 		     "option", &expr->where, flag_max_array_constructor);
 	  return false;
 	}
 cons = gfc_constructor_lookup (base, limit);
 chr[length] = '\0';
 return true;
 }
+/* Pull an inquiry result out of an expression.  */
+static bool
+find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
+{
+gfc_ref *ref;
+gfc_ref *inquiry = NULL;
+gfc_expr *tmp;
+tmp = gfc_copy_expr (p);
+if (tmp->ref && tmp->ref->type == REF_INQUIRY)
+{
+inquiry = tmp->ref;
+tmp->ref = NULL;
+}
+else
+{
+for (ref = tmp->ref; ref; ref = ref->next)
+	if (ref->next && ref->next->type == REF_INQUIRY)
+	  {
+	    inquiry = ref->next;
+	    ref->next = NULL;
+	  }
+}
+if (!inquiry)
+{
+gfc_free_expr (tmp);
+return false;
+}
+gfc_resolve_expr (tmp);
+/* In principle there can be more than one inquiry reference.  */
+for (; inquiry; inquiry = inquiry->next)
+{
+switch (inquiry->u.i)
+	{
+	case INQUIRY_LEN:
+	  if (tmp->ts.type != BT_CHARACTER)
+	    goto cleanup;
+	  if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
+	    goto cleanup;
+	  if (tmp->ts.u.cl->length
+	      && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	    *newp = gfc_copy_expr (tmp->ts.u.cl->length);
+	  else if (tmp->expr_type == EXPR_CONSTANT)
+	    *newp = gfc_get_int_expr (gfc_default_integer_kind,
+				      NULL, tmp->value.character.length);
+	  else
+	    goto cleanup;
+	  break;
+	case INQUIRY_KIND:
+	  if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS)
+	    goto cleanup;
+	  if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C"))
+	    goto cleanup;
+	  *newp = gfc_get_int_expr (gfc_default_integer_kind,
+				    NULL, tmp->ts.kind);
+	  break;
+	case INQUIRY_RE:
+	  if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C"))
+	    goto cleanup;
+	  *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
+	  mpfr_set ((*newp)->value.real,
+		    mpc_realref (tmp->value.complex), GFC_RND_MODE);
+	  break;
+	case INQUIRY_IM:
+	  if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT)
+	    goto cleanup;
+	  if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C"))
+	    goto cleanup;
+	  *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where);
+	  mpfr_set ((*newp)->value.real,
+		    mpc_imagref (tmp->value.complex), GFC_RND_MODE);
+	  break;
+	}
+tmp = gfc_copy_expr (*newp);
+}
+if (!(*newp))
+goto cleanup;
+else if ((*newp)->expr_type != EXPR_CONSTANT)
+{
+gfc_free_expr (*newp);
+goto cleanup;
+}
+gfc_free_expr (tmp);
+return true;
+cleanup:
+gfc_free_expr (tmp);
+return false;
+}
 /* Simplify a subobject reference of a constructor.  This occurs when
 parameter variable values are substituted.  */
 static bool
 simplify_const_ref (gfc_expr *p)
 {
 gfc_constructor *cons, *c;
-gfc_expr *newp;
+gfc_expr *newp = NULL;
 gfc_ref *last_ref;
 while (p->ref)
 {
 switch (p->ref->type)
 			}
 		      else
 			string_len = 0;
 		      if (!p->ts.u.cl)
-			p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+			{
-						      NULL);
+			  if (p->symtree)
+			    p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+							  NULL);
+			  else
+			    p->ts.u.cl = gfc_new_charlen (gfc_current_ns,
+							  NULL);
+			}
 		      else
 			gfc_free_expr (p->ts.u.cl->length);
 		      p->ts.u.cl->length
 			= gfc_get_int_expr (gfc_charlen_int_kind,
 	case REF_COMPONENT:
 	  cons = find_component_ref (p->value.constructor, p->ref);
 	  remove_subobject_ref (p, cons);
 	  break;
-	case REF_SUBSTRING:
+	case REF_INQUIRY:
-	  if (!find_substring_ref (p, &newp))
+	  if (!find_inquiry_ref (p, &newp))
 	    return false;
 	  gfc_replace_expr (p, newp);
 	  gfc_free_ref_list (p->ref);
 	  p->ref = NULL;
 	  break;
+	case REF_SUBSTRING:
+	  if (!find_substring_ref (p, &newp))
+	    return false;
+	  gfc_replace_expr (p, newp);
+	  gfc_free_ref_list (p->ref);
+	  p->ref = NULL;
+	  break;
 	}
 }
 return true;
 }
 /* Simplify a chain of references.  */
 static bool
-simplify_ref_chain (gfc_ref *ref, int type)
+simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
 {
 int n;
+gfc_expr *newp;
 for (; ref; ref = ref->next)
 {
 switch (ref->type)
 	{
 	    return false;
 	  if (!gfc_simplify_expr (ref->u.ss.end, type))
 	    return false;
 	  break;
+	case REF_INQUIRY:
+	  if (!find_inquiry_ref (*p, &newp))
+	    return false;
+	  gfc_replace_expr (*p, newp);
+	  gfc_free_ref_list ((*p)->ref);
+	  (*p)->ref = NULL;
+	  return true;
 	default:
 	  break;
 	}
 }
 return true;
 static bool
 simplify_parameter_variable (gfc_expr *p, int type)
 {
 gfc_expr *e;
 bool t;
+/* Set rank and check array ref; as resolve_variable calls
+gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead.  */
+if (!gfc_resolve_ref (p))
+{
+gfc_error_check ();
+return false;
+}
+gfc_expression_rank (p);
 if (gfc_is_size_zero_array (p))
 {
 if (p->expr_type == EXPR_ARRAY)
 	return true;
 if (e == NULL)
 return false;
 e->rank = p->rank;
+if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL)
+e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
 /* Do not copy subobject refs for constant.  */
 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
 e->ref = gfc_copy_ref (p->ref);
 t = gfc_simplify_expr (e, type);
+e->where = p->where;
 /* Only use the simplification if it eliminated all subobject references.  */
 if (t && !e->ref)
 gfc_replace_expr (p, e);
 else
 The expression type is defined for:
 0   Basic expression parsing
 1   Simplifying array constructors -- will substitute
 	 iterator values.
 Returns false on error, true otherwise.
-NOTE: Will return true even if the expression can not be simplified.  */
+NOTE: Will return true even if the expression cannot be simplified.  */
 bool
 gfc_simplify_expr (gfc_expr *p, int type)
 {
 gfc_actual_arglist *ap;
 return true;
 switch (p->expr_type)
 {
 case EXPR_CONSTANT:
+if (p->ref && p->ref->type == REF_INQUIRY)
+	simplify_ref_chain (p->ref, type, &p);
+break;
 case EXPR_NULL:
 break;
 case EXPR_FUNCTION:
 // For array-bound functions, we don't need to optimize
 	}
 break;
 case EXPR_SUBSTRING:
-if (!simplify_ref_chain (p->ref, type))
+if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
 if (gfc_is_constant_expr (p))
 	{
 	  gfc_char_t *s;
 	{
 	  gfc_simplify_iterator_var (p);
 	}
 /* Simplify subcomponent references.  */
-if (!simplify_ref_chain (p->ref, type))
+if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
 break;
 case EXPR_STRUCTURE:
 case EXPR_ARRAY:
-if (!simplify_ref_chain (p->ref, type))
+if (!simplify_ref_chain (p->ref, type, &p))
 	return false;
+/* If the following conditions hold, we found something like kind type
+	 inquiry of the form a(2)%kind while simplify the ref chain.  */
+if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape)
+	return true;
 if (!simplify_constructor (p->value.constructor, type))
 	return false;
 if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
 break;
 case EXPR_COMPCALL:
 case EXPR_PPC:
 break;
+case EXPR_UNKNOWN:
+gcc_unreachable ();
 }
 return true;
 }
 }
 static bool check_restricted (gfc_expr *);
 /* F95, 7.1.6.1, Initialization expressions, (7)
-F2003, 7.1.7 Initialization expression, (8)  */
+F2003, 7.1.7 Initialization expression, (8)
+F2008, 7.1.12 Constant expression, (4)  */
 static match
 check_inquiry (gfc_expr *e, int not_restricted)
 {
 const char *name;
 "digits", "epsilon", "huge", "maxexponent", "minexponent",
 "precision", "radix", "range", "tiny",
 "new_line", NULL
 };
+/* std=f2008+ or -std=gnu */
+static const char *const inquiry_func_gnu[] = {
+"lbound", "shape", "size", "ubound",
+"bit_size", "len", "kind",
+"digits", "epsilon", "huge", "maxexponent", "minexponent",
+"precision", "radix", "range", "tiny",
+"new_line", "storage_size", NULL
+};
 int i = 0;
 gfc_actual_arglist *ap;
+gfc_symbol *sym;
+gfc_symbol *asym;
 if (!e->value.function.isym
 || !e->value.function.isym->inquiry)
 return MATCH_NO;
 /* An undeclared parameter will get us here (PR25018).  */
 if (e->symtree == NULL)
 return MATCH_NO;
-if (e->symtree->n.sym->from_intmod)
+sym = e->symtree->n.sym;
-{
-if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+if (sym->from_intmod)
-	  && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+{
-	  && e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
+if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
+	  && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
+	  && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
 	return MATCH_NO;
-if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
+if (sym->from_intmod == INTMOD_ISO_C_BINDING
-	  && e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
+	  && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
 	return MATCH_NO;
 }
 else
 {
-name = e->symtree->n.sym->name;
+name = sym->name;
-functions = (gfc_option.warn_std & GFC_STD_F2003)
+functions = inquiry_func_gnu;
-		? inquiry_func_f2003 : inquiry_func_f95;
+if (gfc_option.warn_std & GFC_STD_F2003)
+	functions = inquiry_func_f2003;
+if (gfc_option.warn_std & GFC_STD_F95)
+	functions = inquiry_func_f95;
 for (i = 0; functions[i]; i++)
 	if (strcmp (functions[i], name) == 0)
 	  break;
 for (ap = e->value.function.actual; ap; ap = ap->next)
 {
 if (!ap->expr)
 	continue;
+asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL;
 if (ap->expr->ts.type == BT_UNKNOWN)
 	{
-	  if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
+	  if (asym && asym->ts.type == BT_UNKNOWN
-	      && !gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns))
+	      && !gfc_set_default_type (asym, 0, gfc_current_ns))
 	    return MATCH_NO;
-	  ap->expr->ts = ap->expr->symtree->n.sym->ts;
+	  ap->expr->ts = asym->ts;
 	}
-	/* Assumed character length will not reduce to a constant expression
+if (asym && asym->assoc && asym->assoc->target
-	   with LEN, as required by the standard.  */
+	  && asym->assoc->target->expr_type == EXPR_CONSTANT)
-	if (i == 5 && not_restricted && ap->expr->symtree
+	{
-	    && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
+	  gfc_free_expr (ap->expr);
-	    && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
+	  ap->expr = gfc_copy_expr (asym->assoc->target);
-		|| ap->expr->symtree->n.sym->ts.deferred))
+	}
-	  {
-	    gfc_error ("Assumed or deferred character length variable %qs "
+/* Assumed character length will not reduce to a constant expression
-			"in constant expression at %L",
+	 with LEN, as required by the standard.  */
-			ap->expr->symtree->n.sym->name,
+if (i == 5 && not_restricted && asym
-			&ap->expr->where);
+	  && asym->ts.type == BT_CHARACTER
-	      return MATCH_ERROR;
+	  && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL)
-	  }
+	      || asym->ts.deferred))
-	else if (not_restricted && !gfc_check_init_expr (ap->expr))
+	{
+	  gfc_error ("Assumed or deferred character length variable %qs "
+		     "in constant expression at %L",
+		      asym->name, &ap->expr->where);
 	  return MATCH_ERROR;
+	}
-	if (not_restricted == 0
+else if (not_restricted && !gfc_check_init_expr (ap->expr))
-	      && ap->expr->expr_type != EXPR_VARIABLE
+	return MATCH_ERROR;
-	      && !check_restricted (ap->expr))
-	  return MATCH_ERROR;
+if (not_restricted == 0
+	  && ap->expr->expr_type != EXPR_VARIABLE
-	if (not_restricted == 0
+	  && !check_restricted (ap->expr))
-	    && ap->expr->expr_type == EXPR_VARIABLE
+	return MATCH_ERROR;
-	    && ap->expr->symtree->n.sym->attr.dummy
-	    && ap->expr->symtree->n.sym->attr.optional)
+if (not_restricted == 0
-	  return MATCH_NO;
+	  && ap->expr->expr_type == EXPR_VARIABLE
+	  && asym->attr.dummy && asym->attr.optional)
+	return MATCH_NO;
 }
 return MATCH_YES;
 }
 "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
 "selected_real_kind", "spread", "sum", "transfer", "transpose",
 "trim", "unpack", NULL
 };
+static const char * const trans_func_f2008[] =  {
+"all", "any", "count", "dot_product", "matmul", "null", "pack",
+"product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+"selected_real_kind", "spread", "sum", "transfer", "transpose",
+"trim", "unpack", "findloc", NULL
+};
 int i;
 const char *name;
 const char *const *functions;
 if (!e->value.function.isym
 || !e->value.function.isym->transformational)
 return MATCH_NO;
 name = e->symtree->n.sym->name;
-functions = (gfc_option.allow_std & GFC_STD_F2003)
+if (gfc_option.allow_std & GFC_STD_F2008)
-		? trans_func_f2003 : trans_func_f95;
+functions = trans_func_f2008;
+else if (gfc_option.allow_std & GFC_STD_F2003)
+functions = trans_func_f2003;
+else
+functions = trans_func_f95;
 /* NULL() is dealt with below.  */
 if (strcmp ("null", name) == 0)
 return MATCH_NO;
 			   "in an initialization expression",
 			   e->symtree->n.sym->name, &e->where);
 		break;
 	      case AS_DEFERRED:
-		gfc_error ("Deferred array %qs at %L is not permitted "
+		if (!e->symtree->n.sym->attr.allocatable
-			   "in an initialization expression",
+		    && !e->symtree->n.sym->attr.pointer
-			   e->symtree->n.sym->name, &e->where);
+		    && e->symtree->n.sym->attr.dummy)
+		  gfc_error ("Assumed-shape array %qs at %L is not permitted "
+			     "in an initialization expression",
+			     e->symtree->n.sym->name, &e->where);
+		else
+		  gfc_error ("Deferred array %qs at %L is not permitted "
+			     "in an initialization expression",
+			     e->symtree->n.sym->name, &e->where);
 		break;
 	      case AS_EXPLICIT:
 		gfc_error ("Array %qs at %L is a variable, which does "
 			   "not reduce to a constant expression",
 t = gfc_resolve_expr (expr);
 if (t)
 t = gfc_check_init_expr (expr);
 gfc_init_expr_flag = false;
-if (!t)
+if (!t || !expr)
 return false;
 if (expr->expr_type == EXPR_ARRAY)
 {
 if (!gfc_check_constructor_type (expr))
 	  || !strcmp (f->name, "ieee_support_rounding")
 	  || !strcmp (f->name, "ieee_support_flag")
 	  || !strcmp (f->name, "ieee_support_halting")
 	  || !strcmp (f->name, "ieee_support_datatype")
 	  || !strcmp (f->name, "ieee_support_denormal")
+	  || !strcmp (f->name, "ieee_support_subnormal")
 	  || !strcmp (f->name, "ieee_support_divide")
 	  || !strcmp (f->name, "ieee_support_inf")
 	  || !strcmp (f->name, "ieee_support_io")
 	  || !strcmp (f->name, "ieee_support_nan")
 	  || !strcmp (f->name, "ieee_support_sqrt")
 /* If a dummy argument appears in a context that is valid for a
 	 restricted expression in an elemental procedure, it will have
 	 already been simplified away once we get here.  Therefore we
 	 don't need to jump through hoops to distinguish valid from
-	 invalid cases.  */
+	 invalid cases.  Allowed in F2008 and F2018.  */
-if (sym->attr.dummy && sym->ns == gfc_current_ns
+if (gfc_notification_std (GFC_STD_F2008)
+	  && sym->attr.dummy && sym->ns == gfc_current_ns
 	  && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
 	{
-	  gfc_error ("Dummy argument %qs not allowed in expression at %L",
+	  gfc_error_now ("Dummy argument %qs not "
-		     sym->name, &e->where);
+			 "allowed in expression at %L",
+			 sym->name, &e->where);
 	  break;
 	}
 if (sym->attr.optional)
 	{
 if (op1->rank == 0 || op2->rank == 0)
 return true;
 va_start (argp, optype_msgid);
-vsnprintf (buffer, 240, optype_msgid, argp);
+d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
 va_end (argp);
+if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation.  */
+gfc_internal_error ("optype_msgid overflow: %d", d);
 if (op1->rank != op2->rank)
 {
 gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
 		 op1->rank, op2->rank, &op1->where);
 gfc_ref *ref;
 int has_pointer;
 sym = lvalue->symtree->n.sym;
-/* See if this is the component or subcomponent of a pointer.  */
+/* See if this is the component or subcomponent of a pointer and guard
+against assignment to LEN or KIND part-refs.  */
 has_pointer = sym->attr.pointer;
 for (ref = lvalue->ref; ref; ref = ref->next)
-if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+{
-{
+if (!has_pointer && ref->type == REF_COMPONENT
-	has_pointer = 1;
+	  && ref->u.c.component->attr.pointer)
-	break;
+has_pointer = 1;
-}
+else if (ref->type == REF_INQUIRY
+	       && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND))
+	{
+	  gfc_error ("Assignment to a LEN or KIND part_ref at %L is not "
+		     "allowed", &lvalue->where);
+	  return false;
+	}
+}
 /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
 variable local to a function subprogram.  Its existence begins when
 execution of the function is initiated and ends when execution of the
 function is terminated...
 	{
 	  gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where);
 	  return false;
 	}
 }
+else
+{
+/* Reject assigning to an external symbol.  For initializers, this
+	 was already done before, in resolve_fl_procedure.  */
+if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
+	  && sym->attr.proc != PROC_MODULE && !rvalue->error)
+	{
+	  gfc_error ("Illegal assignment to external procedure at %L",
+		     &lvalue->where);
+	  return false;
+	}
+}
 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
 {
 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
 		 lvalue->rank, rvalue->rank, &lvalue->where);
 /* Check size of array assignments.  */
 if (lvalue->rank != 0 && rvalue->rank != 0
 && !gfc_check_conformance (lvalue, rvalue, "array assignment"))
 return false;
-if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
-&& lvalue->symtree->n.sym->attr.data
-&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
-			  "initialize non-integer variable %qs",
-			  &rvalue->where, lvalue->symtree->n.sym->name))
-return false;
-else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
-&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside "
-			  "a DATA statement and outside INT/REAL/DBLE/CMPLX",
-			  &rvalue->where))
-return false;
 /* Handle the case of a BOZ literal on the RHS.  */
-if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
+if (rvalue->ts.type == BT_BOZ)
 {
-int rc;
+if (lvalue->symtree->n.sym->attr.data)
-if (warn_surprising)
+	{
-	gfc_warning (OPT_Wsurprising,
+	  if (lvalue->ts.type == BT_INTEGER
-		     "BOZ literal at %L is bitwise transferred "
+	      && gfc_boz2int (rvalue, lvalue->ts.kind))
-		     "non-integer symbol %qs", &rvalue->where,
+	    return true;
-		     lvalue->symtree->n.sym->name);
-if (!gfc_convert_boz (rvalue, &lvalue->ts))
+	  if (lvalue->ts.type == BT_REAL
+	      && gfc_boz2real (rvalue, lvalue->ts.kind))
+	    {
+	      if (gfc_invalid_boz ("BOZ literal constant near %L cannot "
+				   "be assigned to a REAL variable",
+				   &rvalue->where))
+		return false;
+	      return true;
+	    }
+	}
+if (!lvalue->symtree->n.sym->attr.data
+	  && gfc_invalid_boz ("BOZ literal constant at %L is neither a "
+			      "data-stmt-constant nor an actual argument to "
+			      "INT, REAL, DBLE, or CMPLX intrinsic function",
+			      &rvalue->where))
 	return false;
-if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
-	{
+if (lvalue->ts.type == BT_INTEGER
-	  if (rc == ARITH_UNDERFLOW)
+	  && gfc_boz2int (rvalue, lvalue->ts.kind))
-	    gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
+	return true;
-		       ". This check can be disabled with the option "
-		       "%<-fno-range-check%>", &rvalue->where);
+if (lvalue->ts.type == BT_REAL
-	  else if (rc == ARITH_OVERFLOW)
+	  && gfc_boz2real (rvalue, lvalue->ts.kind))
-	    gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
+	return true;
-		       ". This check can be disabled with the option "
-		       "%<-fno-range-check%>", &rvalue->where);
+gfc_error ("BOZ literal constant near %L cannot be assigned to a "
-	  else if (rc == ARITH_NAN)
+		 "%qs variable", &rvalue->where, gfc_typename (lvalue));
-	    gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
+return false;
-		       ". This check can be disabled with the option "
-		       "%<-fno-range-check%>", &rvalue->where);
-	  return false;
-	}
 }
 if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len)
 {
 gfc_error ("The assignment to a KIND or LEN component of a "
 	 converted to any other type.  */
 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
 	  || rvalue->ts.type == BT_HOLLERITH)
 	return true;
+if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts)
+	  || lvalue->ts.type == BT_LOGICAL)
+	  && rvalue->ts.type == BT_CHARACTER
+	  && rvalue->ts.kind == gfc_default_character_kind)
+	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", where,
-		 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+		 gfc_typename (rvalue), gfc_typename (lvalue));
 return false;
 }
 /* Assignment is the only case where character variables of different
 /* Check that a pointer assignment is OK.  We first check lvalue, and
 we only check rvalue if it's not an assignment to NULL() or a
 NULLIFY statement.  */
 bool
-gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
+			  bool suppress_type_test, bool is_init_expr)
 {
 symbol_attribute attr, lhs_attr;
 gfc_ref *ref;
 bool is_pure, is_implicit_pure, rank_remap;
 int proc_pointer;
+bool same_rank;
 lhs_attr = gfc_expr_attr (lvalue);
 if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer)
 {
 gfc_error ("Pointer assignment target is not a POINTER at %L",
 }
 proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 rank_remap = false;
+same_rank = lvalue->rank == rvalue->rank;
 for (ref = lvalue->ref; ref; ref = ref->next)
 {
 if (ref->type == REF_COMPONENT)
 	proc_pointer = ref->u.c.component->attr.proc_pointer;
 	  if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
 			       "for %qs in pointer assignment at %L",
 			       lvalue->symtree->n.sym->name, &lvalue->where))
 	    return false;
-	  /* When bounds are given, all lbounds are necessary and either all
+	  /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment):
-	     or none of the upper bounds; no strides are allowed.  If the
+	   *
-	     upper bounds are present, we may do rank remapping.  */
+	   * (C1017) If bounds-spec-list is specified, the number of
+	   * bounds-specs shall equal the rank of data-pointer-object.
+	   *
+	   * If bounds-spec-list appears, it specifies the lower bounds.
+	   *
+	   * (C1018) If bounds-remapping-list is specified, the number of
+	   * bounds-remappings shall equal the rank of data-pointer-object.
+	   *
+	   * If bounds-remapping-list appears, it specifies the upper and
+	   * lower bounds of each dimension of the pointer; the pointer target
+	   * shall be simply contiguous or of rank one.
+	   *
+	   * (C1019) If bounds-remapping-list is not specified, the ranks of
+	   * data-pointer-object and data-target shall be the same.
+	   *
+	   * Thus when bounds are given, all lbounds are necessary and either
+	   * all or none of the upper bounds; no strides are allowed.  If the
+	   * upper bounds are present, we may do rank remapping.  */
 	  for (dim = 0; dim < ref->u.ar.dimen; ++dim)
 	    {
-	      if (!ref->u.ar.start[dim]
-		  || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
-		{
-		  gfc_error ("Lower bound has to be present at %L",
-			     &lvalue->where);
-		  return false;
-		}
 	      if (ref->u.ar.stride[dim])
 		{
 		  gfc_error ("Stride must not be present at %L",
 			     &lvalue->where);
 		  return false;
 		}
+	      if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim]))
+		{
+		  gfc_error ("Rank remapping requires a "
+			     "list of %<lower-bound : upper-bound%> "
+			     "specifications at %L", &lvalue->where);
+		  return false;
+		}
+	      if (!ref->u.ar.start[dim]
+		  || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+		{
+		  gfc_error ("Expected list of %<lower-bound :%> or "
+			     "list of %<lower-bound : upper-bound%> "
+			     "specifications at %L", &lvalue->where);
+		  return false;
+		}
 	      if (dim == 0)
 		rank_remap = (ref->u.ar.end[dim] != NULL);
 	      else
 		{
-		  if ((rank_remap && !ref->u.ar.end[dim])
+		  if ((rank_remap && !ref->u.ar.end[dim]))
-		      || (!rank_remap && ref->u.ar.end[dim]))
 		    {
-		      gfc_error ("Either all or none of the upper bounds"
+		      gfc_error ("Rank remapping requires a "
-				 " must be specified at %L", &lvalue->where);
+				 "list of %<lower-bound : upper-bound%> "
+				 "specifications at %L", &lvalue->where);
+		      return false;
+		    }
+		  if (!rank_remap && ref->u.ar.end[dim])
+		    {
+		      gfc_error ("Expected list of %<lower-bound :%> or "
+				 "list of %<lower-bound : upper-bound%> "
+				 "specifications at %L", &lvalue->where);
 		      return false;
 		    }
 		}
 	    }
 	}
 	{
 	  gfc_error ("Invalid procedure pointer assignment at %L",
 		     &rvalue->where);
 	  return false;
 	}
 if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
 	{
 	  /* Check for intrinsics.  */
 	  gfc_symbol *sym = rvalue->symtree->n.sym;
 	  if (!sym->attr.intrinsic
 	  return false;
 	}
 return true;
 }
+else
+{
+/* A non-proc pointer cannot point to a constant.  */
+if (rvalue->expr_type == EXPR_CONSTANT)
+	{
+	  gfc_error_now ("Pointer assignment target cannot be a constant at %L",
+			 &rvalue->where);
+	  return false;
+	}
+}
 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
 {
 /* Check for F03:C717.  */
 if (UNLIMITED_POLY (rvalue)
 		       || lvalue->ts.u.derived->attr.sequence))))
 	gfc_error ("Data-pointer-object at %L must be unlimited "
 		   "polymorphic, or of a type with the BIND or SEQUENCE "
 		   "attribute, to be compatible with an unlimited "
 		   "polymorphic target", &lvalue->where);
-else
+else if (!suppress_type_test)
 	gfc_error ("Different types in pointer assignment at %L; "
 		   "attempted assignment of %s to %s", &lvalue->where,
-		   gfc_typename (&rvalue->ts),
+		   gfc_typename (rvalue), gfc_typename (lvalue));
-		   gfc_typename (&lvalue->ts));
 return false;
 }
 if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
 {
 		   "at %L must deliver a pointer result",
 		   &rvalue->where);
 return false;
 }
-if (!attr.target && !attr.pointer)
+if (is_init_expr)
 {
-gfc_error ("Pointer assignment target is neither TARGET "
+gfc_symbol *sym;
-		 "nor POINTER at %L", &rvalue->where);
+bool target;
-return false;
+gcc_assert (rvalue->symtree);
+sym = rvalue->symtree->n.sym;
+if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+	target = CLASS_DATA (sym)->attr.target;
+else
+	target = sym->attr.target;
+if (!target && !proc_pointer)
+	{
+	  gfc_error ("Pointer assignment target in initialization expression "
+		     "does not have the TARGET attribute at %L",
+		     &rvalue->where);
+	  return false;
+	}
+}
+else
+{
+if (!attr.target && !attr.pointer)
+	{
+	  gfc_error ("Pointer assignment target is neither TARGET "
+		     "nor POINTER at %L", &rvalue->where);
+	  return false;
+	}
 }
 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
 {
 gfc_error ("Bad target in pointer assignment in PURE "
 		? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
 proc_pointer = sym->attr.proc_pointer;
 }
 if (pointer || proc_pointer)
-r = gfc_check_pointer_assign (&lvalue, rvalue);
+r = gfc_check_pointer_assign (&lvalue, rvalue, false, true);
 else
 {
 /* If a conversion function, e.g., __convert_i8_i4, was inserted
 	 into an array constructor, we should check if it can be reduced
 	 as an initialization expression.  */
 free (lvalue.ref);
 if (!r)
 return r;
-if (pointer && rvalue->expr_type != EXPR_NULL)
+if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer)
 {
 /* F08:C461. Additional checks for pointer initialization.  */
 symbol_attribute attr;
 attr = gfc_expr_attr (rvalue);
 if (attr.allocatable)
 symbol_attribute attr = gfc_expr_attr (rvalue);
 if (attr.proc_pointer)
 	{
 	  gfc_error ("Procedure pointer initialization target at %L "
 		     "may not be a procedure pointer", &rvalue->where);
+	  return false;
+	}
+if (attr.proc == PROC_INTERNAL)
+	{
+	  gfc_error ("Internal procedure %qs is invalid in "
+		     "procedure pointer initialization at %L",
+		     rvalue->symtree->name, &rvalue->where);
+	  return false;
+	}
+if (attr.dummy)
+	{
+	  gfc_error ("Dummy procedure %qs is invalid in "
+		     "procedure pointer initialization at %L",
+		     rvalue->symtree->name, &rvalue->where);
 	  return false;
 	}
 }
 return true;
 void
 gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
 {
 if (ts->type == BT_CHARACTER && !attr->pointer && init
 && ts->u.cl
-&& ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+&& ts->u.cl->length
-{
+&& ts->u.cl->length->expr_type == EXPR_CONSTANT
-gcc_assert (ts->u.cl && ts->u.cl->length);
+&& ts->u.cl->length->ts.type == BT_INTEGER)
-gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT);
+{
-gcc_assert (ts->u.cl->length->ts.type == BT_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
 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);
 }
 	    case REF_COMPONENT:
 	      as = ref->u.c.component->as;
 	      continue;
 	    case REF_SUBSTRING:
+	    case REF_INQUIRY:
 	      continue;
 	    case REF_ARRAY:
 	      {
 		switch (ref->u.ar.type)
 		if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
 				       sym, func, f))
 		  return true;
 	      }
 	  break;
+	case REF_INQUIRY:
+	  return true;
 	default:
 	  gcc_unreachable ();
 	}
 ref = ref->next;
 	      break;
 	    }
 	break;
 case REF_SUBSTRING:
+case REF_INQUIRY:
 	break;
 }
 return coarray && !coindexed;
 }
 bool colon;
 int i;
 gfc_array_ref *ar = NULL;
 gfc_ref *ref, *part_ref = NULL;
 gfc_symbol *sym;
+if (expr->expr_type == EXPR_ARRAY)
+return true;
 if (expr->expr_type == EXPR_FUNCTION)
 {
 if (expr->value.function.esym)
 	return expr->value.function.esym->result->attr.contiguous;
 }
 return true;
 }
+/* Return true if the expression is guaranteed to be non-contiguous,
+false if we cannot prove anything.  It is probably best to call
+this after gfc_is_simply_contiguous.  If neither of them returns
+true, we cannot say (at compile-time).  */
+bool
+gfc_is_not_contiguous (gfc_expr *array)
+{
+int i;
+gfc_array_ref *ar = NULL;
+gfc_ref *ref;
+bool previous_incomplete;
+for (ref = array->ref; ref; ref = ref->next)
+{
+/* Array-ref shall be last ref.  */
+if (ar)
+	return true;
+if (ref->type == REF_ARRAY)
+	ar = &ref->u.ar;
+}
+if (ar == NULL || ar->type != AR_SECTION)
+return false;
+previous_incomplete = false;
+/* Check if we can prove that the array is not contiguous.  */
+for (i = 0; i < ar->dimen; i++)
+{
+mpz_t arr_size, ref_size;
+if (gfc_ref_dimen_size (ar, i, &ref_size, NULL))
+	{
+	  if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size))
+	    {
+	      /* a(2:4,2:) is known to be non-contiguous, but
+		 a(2:4,i:i) can be contiguous.  */
+	      if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0)
+		{
+		  mpz_clear (arr_size);
+		  mpz_clear (ref_size);
+		  return true;
+		}
+	      else if (mpz_cmp (arr_size, ref_size) != 0)
+		previous_incomplete = true;
+	      mpz_clear (arr_size);
+	    }
+	  /* Check for a(::2), i.e. where the stride is not unity.
+	     This is only done if there is more than one element in
+	     the reference along this dimension.  */
+	  if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION
+	      && ar->dimen_type[i] == DIMEN_RANGE
+	      && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
+	      && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)
+	    return true;
+	  mpz_clear (ref_size);
+	}
+}
+/* We didn't find anything definitive.  */
+return false;
+}
 /* Build call to an intrinsic procedure.  The number of arguments has to be
 passed (rather than ending the list with a NULL value) because we may
 want to add arguments but with a NULL-expression.  */
 	  ptr_component = true;
 	  if (!pointer)
 	    check_intentin = false;
 	}
 }
-if (check_intentin && sym->attr.intent == INTENT_IN)
+if (check_intentin
+&& (sym->attr.intent == INTENT_IN
+	  || (sym->attr.select_type_temporary && sym->assoc
+	      && sym->assoc->target && sym->assoc->target->symtree
+	      && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN)))
 {
 if (pointer && is_pointer)
 	{
 	  if (context)
 	    gfc_error ("Dummy argument %qs with INTENT(IN) in pointer"
 		       sym->name, context, &e->where);
 	  return false;
 	}
 if (!pointer && !is_pointer && !sym->attr.pointer)
 	{
+	  const char *name = sym->attr.select_type_temporary
+			   ? sym->assoc->target->symtree->name : sym->name;
 	  if (context)
 	    gfc_error ("Dummy argument %qs with INTENT(IN) in variable"
 		       " definition context (%s) at %L",
-		       sym->name, context, &e->where);
+		       name, context, &e->where);
 	  return false;
 	}
 }
 /* PROTECTED and use-associated.  */
 if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
 {
 if (pointer && is_pointer)
 	{
 	  if (context)
-	    gfc_error ("Variable %qs is PROTECTED and can not appear in a"
+	    gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
 		       " pointer association context (%s) at %L",
 		       sym->name, context, &e->where);
 	  return false;
 	}
 if (!pointer && !is_pointer)
 	{
 	  if (context)
-	    gfc_error ("Variable %qs is PROTECTED and can not appear in a"
+	    gfc_error ("Variable %qs is PROTECTED and cannot appear in a"
 		       " variable definition context (%s) at %L",
 		       sym->name, context, &e->where);
 	  return false;
 	}
 }
 /* Variable not assignable from a PURE procedure but appears in
 variable definition context.  */
 if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym))
 {
 if (context)
-	gfc_error ("Variable %qs can not appear in a variable definition"
+	gfc_error ("Variable %qs cannot appear in a variable definition"
 		   " context (%s) at %L in PURE procedure",
 		   sym->name, context, &e->where);
 return false;
 }
 	      break;
 	    }
 	}
 }
 /* Check variable definition context for associate-names.  */
-if (!pointer && sym->assoc)
+if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
 {
 const char* name;
 gfc_association_list* assoc;
 gcc_assert (sym->assoc->target);
 if (!assoc->variable)
 	{
 	  if (context)
 	    {
 	      if (assoc->target->expr_type == EXPR_VARIABLE)
-		gfc_error ("%qs at %L associated to vector-indexed target can"
+		gfc_error ("%qs at %L associated to vector-indexed target"
-			   " not be used in a variable definition context (%s)",
+			   " cannot be used in a variable definition"
+			   " context (%s)",
 			   name, &e->where, context);
 	      else
-		gfc_error ("%qs at %L associated to expression can"
+		gfc_error ("%qs at %L associated to expression"
-			   " not be used in a variable definition context (%s)",
+			   " cannot be used in a variable definition"
+			   " context (%s)",
 			   name, &e->where, context);
 	    }
 	  return false;
 	}
 /* Target must be allowed to appear in a variable definition context.  */
 if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL))
 	{
 	  if (context)
-	    gfc_error ("Associate-name %qs can not appear in a variable"
+	    gfc_error ("Associate-name %qs cannot appear in a variable"
 		       " definition context (%s) at %L because its target"
-		       " at %L can not, either",
+		       " at %L cannot, either",
 		       name, context, &e->where,
 		       &assoc->target->where);
 	  return false;
 	}
 }

Mercurial > hg > CbC > CbC_gcc

comparison gcc/fortran/expr.c @ 145:1830386684a0