1 files changed, 198 insertions, 12 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f48045..383ba44 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1866,7 +1866,7 @@ resolve_procedure_expression (gfc_expr* expr)
 
 
 /* Check that name is not a derived type.  */
- 
+
 static bool
 is_dt_name (const char *name)
 {
@@ -5455,13 +5455,16 @@ resolve_variable (gfc_expr *e)
 	}
     }
   /* TS 29113, C535b.  */
-  else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
-	    && CLASS_DATA (sym)->as
-	    && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
-	   || (sym->ts.type != BT_CLASS && sym->as
-	       && sym->as->type == AS_ASSUMED_RANK))
+  else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+	     && CLASS_DATA (sym)->as
+	     && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+	    || (sym->ts.type != BT_CLASS && sym->as
+	        && sym->as->type == AS_ASSUMED_RANK))
+	   && !sym->attr.select_rank_temporary)
     {
-      if (!actual_arg)
+      if (!actual_arg
+	  && !(cs_base && cs_base->current
+	       && cs_base->current->op == EXEC_SELECT_RANK))
 	{
 	  gfc_error ("Assumed-rank variable %s at %L may only be used as "
 		     "actual argument", sym->name, &e->where);
@@ -6915,7 +6918,7 @@ gfc_resolve_expr (gfc_expr *e)
   bool t;
   bool inquiry_save, actual_arg_save, first_actual_arg_save;
 
-  if (e == NULL)
+  if (e == NULL || e->do_not_resolve_again)
     return true;
 
   /* inquiry_argument only applies to variables.  */
@@ -7025,6 +7028,13 @@ gfc_resolve_expr (gfc_expr *e)
   actual_arg = actual_arg_save;
   first_actual_arg = first_actual_arg_save;
 
+  /* For some reason, resolving these expressions a second time mangles
+     the typespec of the expression itself.  */
+  if (t && e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.select_rank_temporary
+      && UNLIMITED_POLY (e->symtree->n.sym))
+    e->do_not_resolve_again = 1;
+
   return t;
 }
 
@@ -8841,7 +8851,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
   if (target->ts.type == BT_CLASS)
     gfc_fix_class_refs (target);
 
-  if (target->rank != 0)
+  if (target->rank != 0 && !sym->attr.select_rank_temporary)
     {
       gfc_array_spec *as;
       /* The rank may be incorrectly guessed at parsing, therefore make sure
@@ -8871,7 +8881,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	    CLASS_DATA (sym)->attr.codimension = 1;
 	}
     }
-  else
+  else if (!sym->attr.select_rank_temporary)
     {
       /* target's rank is 0, but the type of the sym is still array valued,
 	 which has to be corrected.  */
@@ -9490,6 +9500,175 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 }
 
 
+/* Resolve a SELECT RANK statement.  */
+
+static void
+resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
+{
+  gfc_namespace *ns;
+  gfc_code *body, *new_st, *tail;
+  gfc_case *c;
+  char tname[GFC_MAX_SYMBOL_LEN];
+  char name[2 * GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *st;
+  gfc_expr *selector_expr = NULL;
+  int case_value;
+  HOST_WIDE_INT charlen = 0;
+
+  ns = code->ext.block.ns;
+  gfc_resolve (ns);
+
+  code->op = EXEC_BLOCK;
+  if (code->expr2)
+    {
+      gfc_association_list* assoc;
+
+      assoc = gfc_get_association_list ();
+      assoc->st = code->expr1->symtree;
+      assoc->target = gfc_copy_expr (code->expr2);
+      assoc->target->where = code->expr2->where;
+      /* assoc->variable will be set by resolve_assoc_var.  */
+
+      code->ext.block.assoc = assoc;
+      code->expr1->symtree->n.sym->assoc = assoc;
+
+      resolve_assoc_var (code->expr1->symtree->n.sym, false);
+    }
+  else
+    code->ext.block.assoc = NULL;
+
+  /* Loop over RANK cases. Note that returning on the errors causes a
+     cascade of further errors because the case blocks do not compile
+     correctly.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.block.case_list;
+      if (c->low)
+	case_value = (int) mpz_get_si (c->low->value.integer);
+      else
+	case_value = -2;
+
+      /* Check for repeated cases.  */
+      for (tail = code->block; tail; tail = tail->block)
+	{
+	  gfc_case *d = tail->ext.block.case_list;
+	  int case_value2;
+
+	  if (tail == body)
+	    break;
+
+	  /* Check F2018: C1153.  */
+	  if (!c->low && !d->low)
+	    gfc_error ("RANK DEFAULT at %L is repeated at %L",
+		       &c->where, &d->where);
+
+	  if (!c->low || !d->low)
+	    continue;
+
+	  /* Check F2018: C1153.  */
+	  case_value2 = (int) mpz_get_si (d->low->value.integer);
+	  if ((case_value == case_value2) && case_value == -1)
+	    gfc_error ("RANK (*) at %L is repeated at %L",
+		       &c->where, &d->where);
+	  else if (case_value == case_value2)
+	    gfc_error ("RANK (%i) at %L is repeated at %L",
+		       case_value, &c->where, &d->where);
+	}
+
+      if (!c->low)
+        continue;
+
+      /* Check F2018: C1155.  */
+      if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+			       || gfc_expr_attr (code->expr1).pointer))
+	gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+		   "allocatable selector at %L", &c->where, &code->expr1->where);
+
+      if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
+			       || gfc_expr_attr (code->expr1).pointer))
+	gfc_error ("RANK (*) at %L cannot be used with the pointer or "
+		   "allocatable selector at %L", &c->where, &code->expr1->where);
+    }
+
+  /* Add EXEC_SELECT to switch on rank.  */
+  new_st = gfc_get_code (code->op);
+  new_st->expr1 = code->expr1;
+  new_st->expr2 = code->expr2;
+  new_st->block = code->block;
+  code->expr1 = code->expr2 =  NULL;
+  code->block = NULL;
+  if (!ns->code)
+    ns->code = new_st;
+  else
+    ns->code->next = new_st;
+  code = new_st;
+  code->op = EXEC_SELECT_RANK;
+
+  selector_expr = code->expr1;
+
+  /* Loop over SELECT RANK cases.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.block.case_list;
+      int case_value;
+
+      /* Pass on the default case.  */
+      if (c->low == NULL)
+	continue;
+
+      /* Associate temporary to selector.  This should only be done
+	 when this case is actually true, so build a new ASSOCIATE
+	 that does precisely this here (instead of using the
+	 'global' one).  */
+      if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
+	  && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+	charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
+
+      if (c->ts.type == BT_CLASS)
+	sprintf (tname, "class_%s", c->ts.u.derived->name);
+      else if (c->ts.type == BT_DERIVED)
+	sprintf (tname, "type_%s", c->ts.u.derived->name);
+      else if (c->ts.type != BT_CHARACTER)
+	sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
+      else
+	sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+		 gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
+
+      case_value = (int) mpz_get_si (c->low->value.integer);
+      if (case_value >= 0)
+	sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
+      else
+	sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
+
+      st = gfc_find_symtree (ns->sym_root, name);
+      gcc_assert (st->n.sym->assoc);
+
+      st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
+      st->n.sym->assoc->target->where = selector_expr->where;
+
+      new_st = gfc_get_code (EXEC_BLOCK);
+      new_st->ext.block.ns = gfc_build_block_ns (ns);
+      new_st->ext.block.ns->code = body->next;
+      body->next = new_st;
+
+      /* Chain in the new list only if it is marked as dangling.  Otherwise
+	 there is a CASE label overlap and this is already used.  Just ignore,
+	 the error is diagnosed elsewhere.  */
+      if (st->n.sym->assoc->dangling)
+	{
+	  new_st->ext.block.assoc = st->n.sym->assoc;
+	  st->n.sym->assoc->dangling = 0;
+	}
+
+      resolve_assoc_var (st->n.sym, false);
+    }
+
+  gfc_current_ns = ns;
+  gfc_resolve_blocks (code->block, gfc_current_ns);
+  gfc_current_ns = old_ns;
+}
+
+
 /* Resolve a transfer statement. This is making sure that:
    -- a derived type being transferred has only non-pointer components
    -- a derived type being transferred doesn't have private components, unless
@@ -10366,6 +10545,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 
 	case EXEC_SELECT:
 	case EXEC_SELECT_TYPE:
+	case EXEC_SELECT_RANK:
 	case EXEC_FORALL:
 	case EXEC_DO:
 	case EXEC_DO_WHILE:
@@ -11643,6 +11823,10 @@ start:
 	  resolve_select_type (code, ns);
 	  break;
 
+	case EXEC_SELECT_RANK:
+	  resolve_select_rank (code, ns);
+	  break;
+
 	case EXEC_BLOCK:
 	  resolve_block_construct (code);
 	  break;
@@ -13573,7 +13757,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
     }
   else
     {
-      /* If proc has not been resolved at this point, proc->name may 
+      /* If proc has not been resolved at this point, proc->name may
 	 actually be a USE associated entity. See PR fortran/89647. */
       if (!proc->resolved
 	  && proc->attr.function == 0 && proc->attr.subroutine == 0)
@@ -15048,7 +15232,9 @@ resolve_symbol (gfc_symbol *sym)
 	}
       /* TS 29113, C535a.  */
       if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
-	  && !sym->attr.select_type_temporary)
+	  && !sym->attr.select_type_temporary
+	  && !(cs_base && cs_base->current
+	       && cs_base->current->op == EXEC_SELECT_RANK))
 	{
 	  gfc_error ("Assumed-rank array at %L must be a dummy argument",
 		     &sym->declared_at);