From 109b1eeba24e5091bf3bdb6caedf7101a9dcaa6a Mon Sep 17 00:00:00 2001

From: Jim MacArthur <jim.macarthur@codethink.co.uk>

Date: Wed, 18 Nov 2015 11:50:41 +0000

Subject: [PATCH 16/23] Allow calls to intrinsics with smaller types than

 specified

This feature is enabled by the `-std=extra-legacy` compiler flag.

---

    0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h

index a32de3e..e222003 100644

--- a/gcc/fortran/gfortran.h

+++ b/gcc/fortran/gfortran.h

@@ -646,6 +646,8 @@ enum gfc_reverse

   GFC_INHIBIT_REVERSE

 };

+enum match_type { MATCH_EXACT, MATCH_PROMOTABLE, MATCH_INVALID };

+

 /************************* Structures *****************************/

 /* Used for keeping things in balanced binary trees.  */

@@ -3251,7 +3253,7 @@ bool gfc_add_interface (gfc_symbol *);

 gfc_interface *gfc_current_interface_head (void);

 void gfc_set_current_interface_head (gfc_interface *);

 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);

-bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);

+bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*, enum match_type mtype);

 bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);

 bool gfc_has_vector_subscript (gfc_expr*);

 gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c

index 162f777..fc73e31 100644

--- a/gcc/fortran/interface.c

+++ b/gcc/fortran/interface.c

@@ -682,7 +682,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)

 /* Compare two typespecs, recursively if necessary.  */

 bool

-gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)

+gfc_compare_types_generic (gfc_typespec *ts1, gfc_typespec *ts2, enum match_type mtype)

 {

   /* See if one of the typespecs is a BT_VOID, which is what is being used

      to allow the funcs like c_f_pointer to accept any pointer type.

@@ -721,12 +721,23 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)

     return compare_union_types (ts1->u.derived, ts2->u.derived);

   if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)

-    return (ts1->kind == ts2->kind);

+    {

+    if (mtype == MATCH_PROMOTABLE)

+      return (ts1->kind >= ts2->kind);

+    else

+      return (ts1->kind == ts2->kind);

+    }

+

   /* Compare derived types.  */

   return gfc_type_compatible (ts1, ts2);

 }

+bool

+gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)

+{

+  return gfc_compare_types_generic (ts1, ts2, MATCH_EXACT);

+}

 static bool

 compare_type (gfc_symbol *s1, gfc_symbol *s2)

@@ -743,7 +754,9 @@ compare_type (gfc_symbol *s1, gfc_symbol *s2)

   return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;

 }

-

+/* Given two symbols that are formal arguments, compare their ranks

+   and types.  Returns nonzero if they have the same rank and type,

+   zero otherwise.  */

 static bool

 compare_rank (gfc_symbol *s1, gfc_symbol *s2)

 {

@@ -2150,7 +2163,7 @@ argument_rank_mismatch (const char *name, locus *where,

 static bool

 compare_parameter (gfc_symbol *formal, gfc_expr *actual,

-		   int ranks_must_agree, int is_elemental, locus *where)

+                   int ranks_must_agree, int is_elemental, locus *where, enum match_type mtype)

 {

   gfc_ref *ref;

   bool rank_check, is_pointer;

@@ -2242,7 +2255,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,

       && actual->ts.type != BT_HOLLERITH

       && formal->ts.type != BT_ASSUMED

       && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))

-      && !gfc_compare_types (&formal->ts, &actual->ts)

+      && !gfc_compare_types_generic (&formal->ts, &actual->ts, mtype)

       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS

 	   && gfc_compare_derived_types (formal->ts.u.derived,

 					 CLASS_DATA (actual)->ts.u.derived)))

@@ -2792,7 +2805,8 @@ is_procptr_result (gfc_expr *expr)

 static bool

 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,

 	 	       int ranks_must_agree, int is_elemental,

-		       bool in_statement_function, locus *where)

+		       bool in_statement_function, locus *where,

+		       enum match_type mtype)

 {

   gfc_actual_arglist **new_arg, *a, *actual;

   gfc_formal_arglist *f;

@@ -2918,7 +2932,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,

 	}

       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,

-			      is_elemental, where))

+			      is_elemental, where, mtype))

 	return false;

       /* TS 29113, 6.3p2.  */

@@ -3666,7 +3680,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)

   /* For a statement function, check that types and type parameters of actual

      arguments and dummy arguments match.  */

   if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental,

-			      sym->attr.proc == PROC_ST_FUNCTION, where))

+			      sym->attr.proc == PROC_ST_FUNCTION, where,

+			      MATCH_PROMOTABLE))

     return false;

   if (!check_intents (dummy_args, *ap))

@@ -3715,7 +3730,8 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)

     }

   if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,

-			      comp->attr.elemental, false, where))

+			      comp->attr.elemental, false, where,

+			      MATCH_EXACT))

     return;

   check_intents (comp->ts.interface->formal, *ap);

@@ -3729,7 +3745,7 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)

    GENERIC resolution.  */

 bool

-gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)

+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym, enum match_type mtype)

 {

   gfc_formal_arglist *dummy_args;

   bool r;

@@ -3740,7 +3756,7 @@ gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)

   dummy_args = gfc_sym_get_dummy_args (sym);

   r = !sym->attr.elemental;

-  if (compare_actual_formal (args, dummy_args, r, !r, false, NULL))

+  if (compare_actual_formal (args, dummy_args, r, !r, false, NULL, mtype))

     {

       check_intents (dummy_args, *args);

       if (warn_aliasing)

@@ -3766,7 +3782,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,

   locus null_expr_loc;

   gfc_actual_arglist *a;

   bool has_null_arg = false;

-

+  enum match_type mtypes[] = { MATCH_EXACT, MATCH_PROMOTABLE };

+  int i;

   for (a = *ap; a; a = a->next)

     if (a->expr && a->expr->expr_type == EXPR_NULL

 	&& a->expr->ts.type == BT_UNKNOWN)

@@ -3776,38 +3793,43 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,

 	break;

       }

-  for (; intr; intr = intr->next)

+  for (i = 0; i < 2; i++)

     {

-      if (gfc_fl_struct (intr->sym->attr.flavor))

-	continue;

-      if (sub_flag && intr->sym->attr.function)

-	continue;

-      if (!sub_flag && intr->sym->attr.subroutine)

-	continue;

-

-      if (gfc_arglist_matches_symbol (ap, intr->sym))

+      for (; intr; intr = intr->next)

 	{

-	  if (has_null_arg && null_sym)

-	    {

-	      gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "

-			 "between specific functions %s and %s",

-			 &null_expr_loc, null_sym->name, intr->sym->name);

-	      return NULL;

-	    }

-	  else if (has_null_arg)

-	    {

-	      null_sym = intr->sym;

-	      continue;

-	    }

+	  if (intr->sym->attr.flavor == FL_DERIVED)

+	    continue;

+	  if (gfc_fl_struct (intr->sym->attr.flavor))

+	    continue;

+	  if (sub_flag && intr->sym->attr.function)

+	    continue;

+	  if (!sub_flag && intr->sym->attr.subroutine)

+	    continue;

-	  /* Satisfy 12.4.4.1 such that an elemental match has lower

-	     weight than a non-elemental match.  */

-	  if (intr->sym->attr.elemental)

+	  if (gfc_arglist_matches_symbol (ap, intr->sym, mtypes[i]))

 	    {

-	      elem_sym = intr->sym;

-	      continue;

+	      if (has_null_arg && null_sym)

+		{

+		  gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity "

+			     "between specific functions %s and %s",

+			     &null_expr_loc, null_sym->name, intr->sym->name);

+		  return NULL;

+		}

+	      else if (has_null_arg)

+		{

+		  null_sym = intr->sym;

+		  continue;

+		}

+

+	      /* Satisfy 12.4.4.1 such that an elemental match has lower

+		 weight than a non-elemental match.  */

+	      if (intr->sym->attr.elemental)

+		{

+		  elem_sym = intr->sym;

+		  continue;

+		}

+	      return intr->sym;

 	    }

-	  return intr->sym;

 	}

     }

@@ -3942,7 +3964,7 @@ matching_typebound_op (gfc_expr** tb_base,

 		/* Check if this arglist matches the formal.  */

 		argcopy = gfc_copy_actual_arglist (args);

-		matches = gfc_arglist_matches_symbol (&argcopy, target);

+		matches = gfc_arglist_matches_symbol (&argcopy, target, MATCH_EXACT);

 		gfc_free_actual_arglist (argcopy);

 		/* Return if we found a match.  */

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c

index 371f5b8..846492a 100644

--- a/gcc/fortran/intrinsic.c

+++ b/gcc/fortran/intrinsic.c

@@ -4229,6 +4229,16 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,

       if (ts.kind == 0)

 	ts.kind = actual->expr->ts.kind;

+      /* ts.kind is the argument spec. actual is what was passed. */

+

+      if (actual->expr->ts.kind < ts.kind

+	  && ts.type == BT_INTEGER)

+	{

+	  /* If it was OK to overwrite ts.kind in the previous case, it

+	     should be fine here... */

+	  ts.kind = actual->expr->ts.kind;

+	}

+

       if (!gfc_compare_types (&ts, &actual->expr->ts))

 	{

 	  if (error_flag)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c

index 33b441a..f82c298 100644

--- a/gcc/fortran/resolve.c

+++ b/gcc/fortran/resolve.c

@@ -6055,7 +6055,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)

 				  && gfc_sym_get_dummy_args (target) == NULL);

 	  /* Check if this arglist matches the formal.  */

-	  matches = gfc_arglist_matches_symbol (&args, target);

+	  matches = gfc_arglist_matches_symbol (&args, target, MATCH_EXACT);

 	  /* Clean up and break out of the loop if we've found it.  */

 	  gfc_free_actual_arglist (args);