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);