[fortran] Implementation of F2018 SELECT RANK

Message ID CAGkQGiKEhbeOLGLXdU5aR=gsZfgZTsDaRBtbB7xk4PjU1AoXZA@mail.gmail.com
State New
Headers show
Series
  • [fortran] Implementation of F2018 SELECT RANK
Related show

Commit Message

Paul Richard Thomas Aug. 31, 2019, 3:59 p.m.
When I started on this about three months ago, I thought that with
SELECT TYPE as a template this was going to be low hanging fruit. Not
so :-)

Among the issues on the way were: class selectors; unlimited
polymorphic selectors even more so; and error recovery. It's a good
starting point but I am not holding my breath for it being PR-free.

It will be noted that the select rank temporaries are also select type
temporaries. This simplifies some of the logic, especially in
resolution, and allows RANK DEFAULT to be handled in the same way as
CLASS DEFAULT in trans-stmt.c.

In the new function, trans-stmt.c(copy_descriptor), memcpy is used to
copy-in/copy-out sections of the dim[] array between the case
descriptor and the assumed rank selector. This avoids explicitly
copying the bounds and strides or messing around trying to convert the
types. There is maybe a better way to do this but I didn't find it.

While I was about it, I made the code in some of the SELECT TYPE
matching much more readable by using a gfc_symbol *selector =
select_type_stack->selector.

Bootstraps and regtests on FC29/x86_64 - OK for trunk?

Now on to PDTs....

Paul

2019-08-31  Paul Thomas  <pault@gcc.gnu.org>

    * array.c (spec_dimen_size): Check for the presence of
    expressions for the bounds.
    * decl.c (gfc_match_end): Add case COMP_SELECT_RANK.
    * dump-parse-tree.c(show_symbol): Show the arrayspec of class
    entities.
    (show_code_node): Show the code for SELECT_RANK.
    * expr.c (gfc_check_vardef_context): Omit the context of
    variable definition for select rank associate names since the
    ASSUMED RANK throws.
    * gfortran.h : Add ST_SELECT_RANK and ST_RANK to enum
    gfc_statement. Add select_rank_temporary to symbol attribute
    structure. Add EXEC_SELECT_RANK to enum gfc_exec_op.
    * match.c (match_exit_cycle): Add COMP_SELECT_RANK.
    (copy_ts_from_selector_to_associate): Add as special case for
    assumed rank class variables.
    (select_intrinsic_set_tmp): Clean up the code by using symbols
    for references to the temporary and the selector.
    (select_type_set_tmp): Ditto.
    (select_rank_set_tmp): New function.
    (gfc_match_select_rank): New function.
    (gfc_match_rank_is): New function.
    * match.h : Add prototypes for gfc_match_select_rank and
    gfc_match_rank_is.
    * parse.c (decode_statement): Attempt to match select_rank and
    rank statements.
    (next_statement, gfc_ascii_statement): Add ST_SELECT_RANK.
    (parse_select_rank_block): New function.
    (parse_executable): Parse select rank block for ST_SELECT_RANK.
    * parse.h : Add COMP_SELECT_RANK to enum gfc_compile_state.
    * resolve.c (resolve_variable): Exclude select_rank_temporaries
    from the check on use of ASSUMED RANK.
    (gfc_resolve_expr): Make sure that unlimited polymorphic select
    rank temporaries expressions are not resolved again after being
    successfully resolved.
    (resolve_assoc_var): Do not do the rank check for select rank
    temporaries.
    (resolve_select_rank): New function.
    (gfc_resolve_blocks): Deal with case EXEC_SELECT_RANK.
    (resolve_symbol): Exclude select rank temporaries for check on
    use of ASSUMED RANK.
    * st.c (gfc_free_statement): Include EXEC_SELECT_RANK.
    * trans-array.c (gfc_conv_array_ref): Select rank temporaries
    may have dimen == 0.
    (gfc_conv_expr_descriptor): Zero the offset of select rank
    temporaries.
    * trans-stmt.c (copy_descriptor): New function.
    (trans_associate_var): Add code to associate select rank temps.
    (gfc_trans_select_rank_cases): New function.
    (gfc_trans_select_rank): New function.
    * trans-stmt.h : Add prototype for gfc_trans_select_rank.
    trans.c (trans_code): Add select rank case.


2019-08-31  Paul Thomas  <pault@gcc.gnu.org>

    * gfortran.dg/select_rank_1.f90 : New test.

Comments

Steve Kargl Aug. 31, 2019, 4:56 p.m. | #1
On Sat, Aug 31, 2019 at 04:59:03PM +0100, Paul Richard Thomas wrote:
> + 

> + /* Match a SELECT RANK statement.  */

> + 

> + match

> + gfc_match_select_rank (void)

> + {

> +   gfc_expr *expr1, *expr2 = NULL;

> +   match m;

> +   char name[GFC_MAX_SYMBOL_LEN];

> +   gfc_symbol *sym, *sym2;

> +   gfc_namespace *ns = gfc_current_ns;

> +   gfc_array_spec *as;


(snip)

> +       if (expr2->expr_type != EXPR_VARIABLE

> + 	  || !(as && as->type == AS_ASSUMED_RANK))

> + 	gfc_error_now ("The SELECT RANK selector at %C must be an assumed "

> + 		       "rank variable");


If an error occurs, should this set m = MATCH_ERROR and goto cleanup?
OR, set m = MATCH_ERROR, free expr1 and expr2 and return m?
IOW, if an error occurs, why should gfortran continue to match select rank?

Still looking at the remaining part of patch.

-- 
steve
Steve Kargl Aug. 31, 2019, 5:12 p.m. | #2
On Sat, Aug 31, 2019 at 09:56:52AM -0700, Steve Kargl wrote:
> On Sat, Aug 31, 2019 at 04:59:03PM +0100, Paul Richard Thomas wrote:

> > + 

> > + /* Match a SELECT RANK statement.  */

> > + 

> > + match

> > + gfc_match_select_rank (void)

> > + {

> > +   gfc_expr *expr1, *expr2 = NULL;

> > +   match m;

> > +   char name[GFC_MAX_SYMBOL_LEN];

> > +   gfc_symbol *sym, *sym2;

> > +   gfc_namespace *ns = gfc_current_ns;

> > +   gfc_array_spec *as;

> 

> (snip)

> 

> > +       if (expr2->expr_type != EXPR_VARIABLE

> > + 	  || !(as && as->type == AS_ASSUMED_RANK))

> > + 	gfc_error_now ("The SELECT RANK selector at %C must be an assumed "

> > + 		       "rank variable");

> 

> If an error occurs, should this set m = MATCH_ERROR and goto cleanup?

> OR, set m = MATCH_ERROR, free expr1 and expr2 and return m?

> IOW, if an error occurs, why should gfortran continue to match select rank?

> 

> Still looking at the remaining part of patch.

> 


There's another gfc_error_now several lines down.  Does the
same early return apply there as well.

Also, found

Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 275242)
--- gcc/fortran/parse.c (working copy)
+ 
+   /* At this point, we're got a nonempty select block.  */

s/we're/we've

-- 
Steve
Steve Kargl Aug. 31, 2019, 5:18 p.m. | #3
On Sat, Aug 31, 2019 at 10:12:55AM -0700, Steve Kargl wrote:
> On Sat, Aug 31, 2019 at 09:56:52AM -0700, Steve Kargl wrote:

> > On Sat, Aug 31, 2019 at 04:59:03PM +0100, Paul Richard Thomas wrote:

> > > + 

> > > + /* Match a SELECT RANK statement.  */

> > > + 

> > > + match

> > > + gfc_match_select_rank (void)

> > > + {

> > > +   gfc_expr *expr1, *expr2 = NULL;

> > > +   match m;

> > > +   char name[GFC_MAX_SYMBOL_LEN];

> > > +   gfc_symbol *sym, *sym2;

> > > +   gfc_namespace *ns = gfc_current_ns;

> > > +   gfc_array_spec *as;

> > 

> > (snip)

> > 

> > > +       if (expr2->expr_type != EXPR_VARIABLE

> > > + 	  || !(as && as->type == AS_ASSUMED_RANK))

> > > + 	gfc_error_now ("The SELECT RANK selector at %C must be an assumed "

> > > + 		       "rank variable");

> > 

> > If an error occurs, should this set m = MATCH_ERROR and goto cleanup?

> > OR, set m = MATCH_ERROR, free expr1 and expr2 and return m?

> > IOW, if an error occurs, why should gfortran continue to match select rank?

> > 

> > Still looking at the remaining part of patch.

> > 

> 

> There's another gfc_error_now several lines down.  Does the

> same early return apply there as well.

> 

> Also, found

> 

> Index: gcc/fortran/parse.c

> ===================================================================

> *** gcc/fortran/parse.c (revision 275242)

> --- gcc/fortran/parse.c (working copy)

> + 

> +   /* At this point, we're got a nonempty select block.  */

> 

> s/we're/we've

> 


Copy-n-paste may corrupt this, but the change is removing
1 trailing whitespace space and leaving a remaining trailing
whitespace.

*************** resolve_procedure_expression (gfc_expr*
*** 1866,1872 ****
  
  
  /* Check that name is not a derived type.  */
!  
  static bool
  is_dt_name (const char *name)
  {
--- 1866,1872 ----
  
  
  /* Check that name is not a derived type.  */
! 
  static bool
  is_dt_name (const char *name)
  {


-- 
Steve
Paul Richard Thomas Aug. 31, 2019, 5:34 p.m. | #4
Hi Steve,


> > > If an error occurs, should this set m = MATCH_ERROR and goto cleanup?

> > > OR, set m = MATCH_ERROR, free expr1 and expr2 and return m?

> > > IOW, if an error occurs, why should gfortran continue to match select rank?


This prevents or reduces the deluge of errors that come from the cases
and the case blocks.

> > >

> > > Still looking at the remaining part of patch.

> > >

> >

> > There's another gfc_error_now several lines down.  Does the

> > same early return apply there as well.


Same reason

> >

> > Also, found

> >

> > Index: gcc/fortran/parse.c

> > ===================================================================

> > *** gcc/fortran/parse.c (revision 275242)

> > --- gcc/fortran/parse.c (working copy)

> > +

> > +   /* At this point, we're got a nonempty select block.  */

> >

> > s/we're/we've

> >

>

> Copy-n-paste may corrupt this, but the change is removing

> 1 trailing whitespace space and leaving a remaining trailing

> whitespace.


OK I'll check.

Thanks

Paul
Steve Kargl Aug. 31, 2019, 5:35 p.m. | #5
In resolve_select_rank you have a comment about casading error.

+   /* Loop over RANK cases. Note that returning on the errors causes a
+      cascade of further errors because the case blocks do not compile
+      correctly.  */

Shouldn't gfortran stop looping if an error occurs?  See below...


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

here

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

here

+    else if (case_value == case_value2)
+      gfc_error ("RANK (%i) at %L is repeated at %L",
+          case_value, &c->where, &d->where);

here

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

here

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

and here.

+     }


I would expect

    if (error)
      {
        gfc_error ();
	return;
      }

The early return will likely lead to a different cascade of errors. :(

-- 
Steve
Steve Kargl Aug. 31, 2019, 5:38 p.m. | #6
On Sat, Aug 31, 2019 at 06:34:43PM +0100, Paul Richard Thomas wrote:
> Hi Steve,

> 

> 

> > > > If an error occurs, should this set m = MATCH_ERROR and goto cleanup?

> > > > OR, set m = MATCH_ERROR, free expr1 and expr2 and return m?

> > > > IOW, if an error occurs, why should gfortran continue to match select rank?

> 

> This prevents or reduces the deluge of errors that come from the cases

> and the case blocks.

> 


I'm not oppose to either a fatal_error here or reducing -fmax-error
from its current default of 25 (a value I arbitrarily chose years ago)
to 1.

-- 
Steve
Steve Kargl Aug. 31, 2019, 5:46 p.m. | #7
On Sat, Aug 31, 2019 at 04:59:03PM +0100, Paul Richard Thomas wrote:
> 

> Bootstraps and regtests on FC29/x86_64 - OK for trunk?


Well, I've made it through to the trans-* files.  Reading
that part of the patch will take a awhile.  I'm think you
should commit.

-- 
steve
Paul Richard Thomas Sept. 1, 2019, 12:54 p.m. | #8
Hi Steve,

Thanks for the remarks and the OK. Committed as revision 275269.

Onward to PDTs!

Cheers

Paul

On Sat, 31 Aug 2019 at 18:46, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
>

> On Sat, Aug 31, 2019 at 04:59:03PM +0100, Paul Richard Thomas wrote:

> >

> > Bootstraps and regtests on FC29/x86_64 - OK for trunk?

>

> Well, I've made it through to the trans-* files.  Reading

> that part of the patch will take a awhile.  I'm think you

> should commit.

>

> --

> steve




-- 
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein

Patch

Index: gcc/fortran/array.c
===================================================================
*** gcc/fortran/array.c	(revision 275242)
--- gcc/fortran/array.c	(working copy)
*************** spec_dimen_size (gfc_array_spec *as, int
*** 2213,2219 ****
      gfc_internal_error ("spec_dimen_size(): Bad dimension");
  
    if (as->type != AS_EXPLICIT
!       || as->lower[dimen]->expr_type != EXPR_CONSTANT
        || as->upper[dimen]->expr_type != EXPR_CONSTANT
        || as->lower[dimen]->ts.type != BT_INTEGER
        || as->upper[dimen]->ts.type != BT_INTEGER)
--- 2213,2223 ----
      gfc_internal_error ("spec_dimen_size(): Bad dimension");
  
    if (as->type != AS_EXPLICIT
!       || !as->lower[dimen]
!       || !as->upper[dimen])
!     return false;
! 
!   if (as->lower[dimen]->expr_type != EXPR_CONSTANT
        || as->upper[dimen]->expr_type != EXPR_CONSTANT
        || as->lower[dimen]->ts.type != BT_INTEGER
        || as->upper[dimen]->ts.type != BT_INTEGER)
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 275242)
--- gcc/fortran/decl.c	(working copy)
*************** gfc_match_end (gfc_statement *st)
*** 8164,8169 ****
--- 8164,8170 ----
  
      case COMP_SELECT:
      case COMP_SELECT_TYPE:
+     case COMP_SELECT_RANK:
        *st = ST_END_SELECT;
        target = " select";
        eos_ok = 0;
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 275242)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** show_symbol (gfc_symbol *sym)
*** 1000,1011 ****
        show_expr (sym->value);
      }
  
!   if (sym->as)
      {
        show_indent ();
        fputs ("Array spec:", dumpfile);
        show_array_spec (sym->as);
      }
  
    if (sym->generic)
      {
--- 1000,1017 ----
        show_expr (sym->value);
      }
  
!   if (sym->ts.type != BT_CLASS && sym->as)
      {
        show_indent ();
        fputs ("Array spec:", dumpfile);
        show_array_spec (sym->as);
      }
+   else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
+     {
+       show_indent ();
+       fputs ("Array spec:", dumpfile);
+       show_array_spec (CLASS_DATA (sym)->as);
+     }
  
    if (sym->generic)
      {
*************** show_code_node (int level, gfc_code *c)
*** 2168,2185 ****
  
      case EXEC_SELECT:
      case EXEC_SELECT_TYPE:
        d = c->block;
!       if (c->op == EXEC_SELECT_TYPE)
  	fputs ("SELECT TYPE ", dumpfile);
        else
  	fputs ("SELECT CASE ", dumpfile);
        show_expr (c->expr1);
-       fputc ('\n', dumpfile);
  
        for (; d; d = d->block)
  	{
  	  code_indent (level, 0);
- 
  	  fputs ("CASE ", dumpfile);
  	  for (cp = d->ext.block.case_list; cp; cp = cp->next)
  	    {
--- 2174,2195 ----
  
      case EXEC_SELECT:
      case EXEC_SELECT_TYPE:
+     case EXEC_SELECT_RANK:
        d = c->block;
!       fputc ('\n', dumpfile);
!       code_indent (level, 0);
!       if (c->op == EXEC_SELECT_RANK)
! 	fputs ("SELECT RANK ", dumpfile);
!       else if (c->op == EXEC_SELECT_TYPE)
  	fputs ("SELECT TYPE ", dumpfile);
        else
  	fputs ("SELECT CASE ", dumpfile);
        show_expr (c->expr1);
  
        for (; d; d = d->block)
  	{
+ 	  fputc ('\n', dumpfile);
  	  code_indent (level, 0);
  	  fputs ("CASE ", dumpfile);
  	  for (cp = d->ext.block.case_list; cp; cp = cp->next)
  	    {
*************** show_code_node (int level, gfc_code *c)
*** 2190,2198 ****
  	      fputc (')', dumpfile);
  	      fputc (' ', dumpfile);
  	    }
- 	  fputc ('\n', dumpfile);
  
  	  show_code (level + 1, d->next);
  	}
  
        code_indent (level, c->label1);
--- 2200,2208 ----
  	      fputc (')', dumpfile);
  	      fputc (' ', dumpfile);
  	    }
  
  	  show_code (level + 1, d->next);
+ 	  fputc ('\n', dumpfile);
  	}
  
        code_indent (level, c->label1);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 275242)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 6181,6187 ****
  	}
      }
    /* Check variable definition context for associate-names.  */
!   if (!pointer && sym->assoc)
      {
        const char* name;
        gfc_association_list* assoc;
--- 6181,6187 ----
  	}
      }
    /* Check variable definition context for associate-names.  */
!   if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
      {
        const char* name;
        gfc_association_list* assoc;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 275242)
--- gcc/fortran/gfortran.h	(working copy)
*************** enum gfc_statement
*** 216,222 ****
    ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
    ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM,
    ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
!   ST_STRUCTURE_DECL, ST_END_STRUCTURE,
    ST_UNION, ST_END_UNION, ST_MAP, ST_END_MAP,
    ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL,
    ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA,
--- 216,222 ----
    ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
    ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM,
    ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
!   ST_SELECT_RANK, ST_RANK, ST_STRUCTURE_DECL, ST_END_STRUCTURE,
    ST_UNION, ST_END_UNION, ST_MAP, ST_END_MAP,
    ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL,
    ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA,
*************** typedef struct
*** 894,902 ****
  	   event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
  	   has_dtio_procs:1, caf_token:1;
  
!   /* This is a temporary selector for SELECT TYPE or an associate
!      variable for SELECT_TYPE or ASSOCIATE.  */
!   unsigned select_type_temporary:1, associate_var:1;
  
    /* These are the attributes required for parameterized derived
       types.  */
--- 894,902 ----
  	   event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
  	   has_dtio_procs:1, caf_token:1;
  
!   /* This is a temporary selector for SELECT TYPE/RANK or an associate
!      variable for SELECT TYPE/RANK or ASSOCIATE.  */
!   unsigned select_type_temporary:1, select_rank_temporary:1, associate_var:1;
  
    /* These are the attributes required for parameterized derived
       types.  */
*************** enum gfc_exec_op
*** 2555,2562 ****
    EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
    EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
    EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
!   EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
!   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
    EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
    EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
    EXEC_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM,
--- 2555,2562 ----
    EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
    EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
    EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
!   EXEC_SELECT_TYPE, EXEC_SELECT_RANK, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY,
!   EXEC_SYNC_IMAGES, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
    EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
    EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
    EXEC_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM,
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 275242)
--- gcc/fortran/match.c	(working copy)
*************** match_exit_cycle (gfc_statement st, gfc_
*** 2825,2830 ****
--- 2825,2831 ----
      case COMP_IF:
      case COMP_SELECT:
      case COMP_SELECT_TYPE:
+     case COMP_SELECT_RANK:
        gcc_assert (sym);
        if (op == EXEC_CYCLE)
  	{
*************** copy_ts_from_selector_to_associate (gfc_
*** 6065,6071 ****
      ref = ref->next;
  
    if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
!       && ref && ref->type == REF_ARRAY)
      {
        /* Ensure that the array reference type is set.  We cannot use
  	 gfc_resolve_expr at this point, so the usable parts of
--- 6066,6079 ----
      ref = ref->next;
  
    if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
!       && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
!     {
!       assoc_sym->attr.dimension = 1;
!       assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
!       goto build_class_sym;
!     }
!   else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
! 	   && ref && ref->type == REF_ARRAY)
      {
        /* Ensure that the array reference type is set.  We cannot use
  	 gfc_resolve_expr at this point, so the usable parts of
*************** copy_ts_from_selector_to_associate (gfc_
*** 6116,6121 ****
--- 6124,6130 ----
    else
      assoc_sym->as = NULL;
  
+ build_class_sym:
    if (selector->ts.type == BT_CLASS)
      {
        /* The correct class container has to be available.  */
*************** select_intrinsic_set_tmp (gfc_typespec *
*** 6149,6162 ****
    char name[GFC_MAX_SYMBOL_LEN];
    gfc_symtree *tmp;
    HOST_WIDE_INT charlen = 0;
  
    if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
      return NULL;
  
!   if (select_type_stack->selector->ts.type == BT_CLASS
!       && !select_type_stack->selector->attr.class_ok)
      return NULL;
  
    if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
        && ts->u.cl->length->expr_type == EXPR_CONSTANT)
      charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
--- 6158,6174 ----
    char name[GFC_MAX_SYMBOL_LEN];
    gfc_symtree *tmp;
    HOST_WIDE_INT charlen = 0;
+   gfc_symbol *selector = select_type_stack->selector;
+   gfc_symbol *sym;
  
    if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
      return NULL;
  
!   if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
      return NULL;
  
+   /* Case value == NULL corresponds to SELECT TYPE cases otherwise
+      the values correspond to SELECT rank cases.  */
    if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
        && ts->u.cl->length->expr_type == EXPR_CONSTANT)
      charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
*************** select_intrinsic_set_tmp (gfc_typespec *
*** 6165,6193 ****
      sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
  	     ts->kind);
    else
!     snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
  	      gfc_basic_typename (ts->type), charlen, ts->kind);
  
    gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
!   gfc_add_type (tmp->n.sym, ts, NULL);
  
    /* Copy across the array spec to the selector.  */
!   if (select_type_stack->selector->ts.type == BT_CLASS
!       && (CLASS_DATA (select_type_stack->selector)->attr.dimension
! 	  || CLASS_DATA (select_type_stack->selector)->attr.codimension))
!     {
!       tmp->n.sym->attr.pointer = 1;
!       tmp->n.sym->attr.dimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.dimension;
!       tmp->n.sym->attr.codimension
! 		= CLASS_DATA (select_type_stack->selector)->attr.codimension;
!       tmp->n.sym->as
! 	= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
!     }
! 
!   gfc_set_sym_referenced (tmp->n.sym);
!   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
!   tmp->n.sym->attr.select_type_temporary = 1;
  
    return tmp;
  }
--- 6177,6204 ----
      sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
  	     ts->kind);
    else
!     snprintf (name, sizeof (name),
! 	      "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
  	      gfc_basic_typename (ts->type), charlen, ts->kind);
  
    gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
!   sym = tmp->n.sym;
!   gfc_add_type (sym, ts, NULL);
  
    /* Copy across the array spec to the selector.  */
!   if (selector->ts.type == BT_CLASS
!       && (CLASS_DATA (selector)->attr.dimension
! 	  || CLASS_DATA (selector)->attr.codimension))
!     {
!       sym->attr.pointer = 1;
!       sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
!       sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
!       sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
!     }
! 
!   gfc_set_sym_referenced (sym);
!   gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
!   sym->attr.select_type_temporary = 1;
  
    return tmp;
  }
*************** select_type_set_tmp (gfc_typespec *ts)
*** 6200,6205 ****
--- 6211,6218 ----
  {
    char name[GFC_MAX_SYMBOL_LEN];
    gfc_symtree *tmp = NULL;
+   gfc_symbol *selector = select_type_stack->selector;
+   gfc_symbol *sym;
  
    if (!ts)
      {
*************** select_type_set_tmp (gfc_typespec *ts)
*** 6218,6259 ****
  	sprintf (name, "__tmp_class_%s", ts->u.derived->name);
        else
  	sprintf (name, "__tmp_type_%s", ts->u.derived->name);
        gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
!       gfc_add_type (tmp->n.sym, ts, NULL);
  
!       if (select_type_stack->selector->ts.type == BT_CLASS
! 	&& select_type_stack->selector->attr.class_ok)
  	{
! 	  tmp->n.sym->attr.pointer
! 		= CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
  
  	  /* Copy across the array spec to the selector.  */
! 	  if (CLASS_DATA (select_type_stack->selector)->attr.dimension
! 	      || CLASS_DATA (select_type_stack->selector)->attr.codimension)
  	    {
! 	      tmp->n.sym->attr.dimension
! 		    = CLASS_DATA (select_type_stack->selector)->attr.dimension;
! 	      tmp->n.sym->attr.codimension
! 		    = CLASS_DATA (select_type_stack->selector)->attr.codimension;
! 	      tmp->n.sym->as
! 	    = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
  	    }
!     }
  
!   gfc_set_sym_referenced (tmp->n.sym);
!   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
!   tmp->n.sym->attr.select_type_temporary = 1;
  
!   if (ts->type == BT_CLASS)
!     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! 			    &tmp->n.sym->as);
      }
  
    /* Add an association for it, so the rest of the parser knows it is
       an associate-name.  The target will be set during resolution.  */
!   tmp->n.sym->assoc = gfc_get_association_list ();
!   tmp->n.sym->assoc->dangling = 1;
!   tmp->n.sym->assoc->st = tmp;
  
    select_type_stack->tmp = tmp;
  }
--- 6231,6275 ----
  	sprintf (name, "__tmp_class_%s", ts->u.derived->name);
        else
  	sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ 
        gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
!       sym = tmp->n.sym;
!       gfc_add_type (sym, ts, NULL);
  
!       if (selector->ts.type == BT_CLASS && selector->attr.class_ok)
  	{
! 	  sym->attr.pointer
! 		= CLASS_DATA (selector)->attr.class_pointer;
  
  	  /* Copy across the array spec to the selector.  */
! 	  if (CLASS_DATA (selector)->attr.dimension
! 	      || CLASS_DATA (selector)->attr.codimension)
  	    {
! 	      sym->attr.dimension
! 		    = CLASS_DATA (selector)->attr.dimension;
! 	      sym->attr.codimension
! 		    = CLASS_DATA (selector)->attr.codimension;
! 	      sym->as
! 		    = gfc_copy_array_spec (CLASS_DATA (selector)->as);
  	    }
! 	}
  
!       gfc_set_sym_referenced (sym);
!       gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
!       sym->attr.select_type_temporary = 1;
  
!       if (ts->type == BT_CLASS)
! 	gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
      }
+   else
+     sym = tmp->n.sym;
+ 
  
    /* Add an association for it, so the rest of the parser knows it is
       an associate-name.  The target will be set during resolution.  */
!   sym->assoc = gfc_get_association_list ();
!   sym->assoc->dangling = 1;
!   sym->assoc->st = tmp;
  
    select_type_stack->tmp = tmp;
  }
*************** cleanup:
*** 6374,6379 ****
--- 6390,6623 ----
  }
  
  
+ /* Set the temporary for the current intrinsic SELECT RANK selector.  */
+ 
+ static void
+ select_rank_set_tmp (gfc_typespec *ts, int *case_value)
+ {
+   char name[2 * GFC_MAX_SYMBOL_LEN];
+   char tname[GFC_MAX_SYMBOL_LEN];
+   gfc_symtree *tmp;
+   gfc_symbol *selector = select_type_stack->selector;
+   gfc_symbol *sym;
+   gfc_symtree *st;
+   HOST_WIDE_INT charlen = 0;
+ 
+   if (case_value == NULL)
+     return;
+ 
+   if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
+       && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+     charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
+ 
+   if (ts->type == BT_CLASS)
+     sprintf (tname, "class_%s", ts->u.derived->name);
+   else if (ts->type == BT_DERIVED)
+     sprintf (tname, "type_%s", ts->u.derived->name);
+   else if (ts->type != BT_CHARACTER)
+     sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
+   else
+     sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ 	     gfc_basic_typename (ts->type), charlen, ts->kind);
+ 
+   /* Case value == NULL corresponds to SELECT TYPE cases otherwise
+      the values correspond to SELECT rank cases.  */
+   if (*case_value >=0)
+     sprintf (name, "__tmp_%s_rank_%d", tname, *case_value);
+   else
+     sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value);
+ 
+   gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+   if (st)
+     return;
+ 
+   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+   sym = tmp->n.sym;
+   gfc_add_type (sym, ts, NULL);
+ 
+   /* Copy across the array spec to the selector.  */
+   if (selector->ts.type == BT_CLASS)
+     {
+       sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+       sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
+       sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
+       sym->attr.target = CLASS_DATA (selector)->attr.target;
+       sym->attr.class_ok = 0;
+       if (case_value && *case_value != 0)
+ 	{
+ 	  sym->attr.dimension = 1;
+ 	  sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
+ 	  if (*case_value > 0)
+ 	    {
+ 	      sym->as->type = AS_DEFERRED;
+ 	      sym->as->rank = *case_value;
+ 	    }
+ 	  else if (*case_value == -1)
+ 	    {
+ 	      sym->as->type = AS_ASSUMED_SIZE;
+ 	      sym->as->rank = 1;
+ 	    }
+ 	}
+     }
+   else
+     {
+       sym->attr.pointer = selector->attr.pointer;
+       sym->attr.allocatable = selector->attr.allocatable;
+       sym->attr.target = selector->attr.target;
+       if (case_value && *case_value != 0)
+ 	{
+ 	  sym->attr.dimension = 1;
+ 	  sym->as = gfc_copy_array_spec (selector->as);
+ 	  if (*case_value > 0)
+ 	    {
+ 	      sym->as->type = AS_DEFERRED;
+ 	      sym->as->rank = *case_value;
+ 	    }
+ 	  else if (*case_value == -1)
+ 	    {
+ 	      sym->as->type = AS_ASSUMED_SIZE;
+ 	      sym->as->rank = 1;
+ 	    }
+ 	}
+     }
+ 
+   gfc_set_sym_referenced (sym);
+   gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
+   sym->attr.select_type_temporary = 1;
+   if (case_value)
+     sym->attr.select_rank_temporary = 1;
+ 
+   if (ts->type == BT_CLASS)
+     gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ 
+   /* Add an association for it, so the rest of the parser knows it is
+      an associate-name.  The target will be set during resolution.  */
+   sym->assoc = gfc_get_association_list ();
+   sym->assoc->dangling = 1;
+   sym->assoc->st = tmp;
+ 
+   select_type_stack->tmp = tmp;
+ }
+ 
+ 
+ /* Match a SELECT RANK statement.  */
+ 
+ match
+ gfc_match_select_rank (void)
+ {
+   gfc_expr *expr1, *expr2 = NULL;
+   match m;
+   char name[GFC_MAX_SYMBOL_LEN];
+   gfc_symbol *sym, *sym2;
+   gfc_namespace *ns = gfc_current_ns;
+   gfc_array_spec *as;
+ 
+   m = gfc_match_label ();
+   if (m == MATCH_ERROR)
+     return m;
+ 
+   m = gfc_match (" select rank ( ");
+   if (m != MATCH_YES)
+     return m;
+ 
+   if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
+     return MATCH_NO;
+ 
+   gfc_current_ns = gfc_build_block_ns (ns);
+   m = gfc_match (" %n => %e", name, &expr2);
+   if (m == MATCH_YES)
+     {
+       expr1 = gfc_get_expr ();
+       expr1->expr_type = EXPR_VARIABLE;
+       expr1->where = expr2->where;
+       expr1->ref = gfc_copy_ref (expr2->ref);
+       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+ 	{
+ 	  m = MATCH_ERROR;
+ 	  goto cleanup;
+ 	}
+ 
+       sym = expr1->symtree->n.sym;
+       sym2 = expr2->symtree->n.sym;
+ 
+       as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as;
+       if (expr2->expr_type != EXPR_VARIABLE
+ 	  || !(as && as->type == AS_ASSUMED_RANK))
+ 	gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
+ 		       "rank variable");
+ 
+       if (expr2->ts.type == BT_CLASS)
+ 	{
+ 	  copy_ts_from_selector_to_associate (expr1, expr2);
+ 
+ 	  sym->attr.flavor = FL_VARIABLE;
+ 	  sym->attr.referenced = 1;
+ 	  sym->attr.class_ok = 1;
+ 	  CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
+ 	  CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
+ 	  CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
+ 	  sym->attr.pointer = 1;
+ 	}
+       else
+ 	{
+ 	  sym->ts = sym2->ts;
+ 	  sym->as = gfc_copy_array_spec (sym2->as);
+ 	  sym->attr.dimension = 1;
+ 
+ 	  sym->attr.flavor = FL_VARIABLE;
+ 	  sym->attr.referenced = 1;
+ 	  sym->attr.class_ok = sym2->attr.class_ok;
+ 	  sym->attr.allocatable = sym2->attr.allocatable;
+ 	  sym->attr.pointer = sym2->attr.pointer;
+ 	  sym->attr.target = sym2->attr.target;
+ 	}
+     }
+   else
+     {
+       m = gfc_match (" %e ", &expr1);
+ 
+       if (m != MATCH_YES)
+ 	{
+ 	  std::swap (ns, gfc_current_ns);
+ 	  gfc_free_namespace (ns);
+ 	  return m;
+ 	}
+ 
+       sym = expr1->symtree->n.sym;
+       as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
+       if (expr1->expr_type != EXPR_VARIABLE
+ 	  || !(as && as->type == AS_ASSUMED_RANK))
+ 	gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
+ 		       "rank variable");
+     }
+ 
+   m = gfc_match (" )%t");
+   if (m != MATCH_YES)
+     {
+       gfc_error ("parse error in SELECT RANK statement at %C");
+       goto cleanup;
+     }
+ 
+   new_st.op = EXEC_SELECT_RANK;
+   new_st.expr1 = expr1;
+   new_st.expr2 = expr2;
+   new_st.ext.block.ns = gfc_current_ns;
+ 
+   select_type_push (expr1->symtree->n.sym);
+   gfc_current_ns = ns;
+ 
+   return MATCH_YES;
+ 
+ cleanup:
+   gfc_free_expr (expr1);
+   gfc_free_expr (expr2);
+   gfc_undo_symbols ();
+   std::swap (ns, gfc_current_ns);
+   gfc_free_namespace (ns);
+   return m;
+ }
+ 
+ 
  /* Match a CASE statement.  */
  
  match
*************** cleanup:
*** 6595,6600 ****
--- 6839,6945 ----
  }
  
  
+ /* Match a RANK statement.  */
+ 
+ match
+ gfc_match_rank_is (void)
+ {
+   gfc_case *c = NULL;
+   match m;
+   int case_value;
+ 
+   if (gfc_current_state () != COMP_SELECT_RANK)
+     {
+       gfc_error ("Unexpected RANK statement at %C");
+       return MATCH_ERROR;
+     }
+ 
+   if (gfc_match ("% default") == MATCH_YES)
+     {
+       m = match_case_eos ();
+       if (m == MATCH_NO)
+ 	goto syntax;
+       if (m == MATCH_ERROR)
+ 	goto cleanup;
+ 
+       new_st.op = EXEC_SELECT_RANK;
+       c = gfc_get_case ();
+       c->ts.type = BT_UNKNOWN;
+       c->where = gfc_current_locus;
+       new_st.ext.block.case_list = c;
+       select_type_stack->tmp = NULL;
+       return MATCH_YES;
+     }
+ 
+   if (gfc_match_char ('(') != MATCH_YES)
+     goto syntax;
+ 
+   c = gfc_get_case ();
+   c->where = gfc_current_locus;
+   c->ts = select_type_stack->selector->ts;
+ 
+   m = gfc_match_expr (&c->low);
+   if (m == MATCH_NO)
+     {
+       if (gfc_match_char ('*') == MATCH_YES)
+ 	c->low = gfc_get_int_expr (gfc_default_integer_kind,
+ 				   NULL, -1);
+       else
+ 	goto syntax;
+ 
+       case_value = -1;
+     }
+   else if (m == MATCH_YES)
+     {
+       /* F2018: R1150  */
+       if (c->low->expr_type != EXPR_CONSTANT
+ 	  || c->low->ts.type != BT_INTEGER
+ 	  || c->low->rank)
+ 	{
+ 	  gfc_error ("The SELECT RANK CASE expression at %C must be a "
+ 		     "scalar, integer constant");
+ 	  goto cleanup;
+ 	}
+ 
+       case_value = (int) mpz_get_si (c->low->value.integer);
+       /* F2018: C1151  */
+       if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
+ 	{
+ 	  gfc_error ("The value of the SELECT RANK CASE expression at "
+ 		     "%C must not be less than zero or greater than %d",
+ 		     GFC_MAX_DIMENSIONS);
+ 	  goto cleanup;
+ 	}
+     }
+   else
+     goto cleanup;
+ 
+   if (gfc_match_char (')') != MATCH_YES)
+     goto syntax;
+ 
+   m = match_case_eos ();
+   if (m == MATCH_NO)
+     goto syntax;
+   if (m == MATCH_ERROR)
+     goto cleanup;
+ 
+   new_st.op = EXEC_SELECT_RANK;
+   new_st.ext.block.case_list = c;
+ 
+   /* Create temporary variable. Recycle the select type code.  */
+   select_rank_set_tmp (&c->ts, &case_value);
+ 
+   return MATCH_YES;
+ 
+ syntax:
+   gfc_error ("Syntax error in RANK specification at %C");
+ 
+ cleanup:
+   if (c != NULL)
+     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
+   return MATCH_ERROR;
+ }
+ 
  /********************* WHERE subroutines ********************/
  
  /* Match the rest of a simple WHERE statement that follows an IF statement.
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h	(revision 275242)
--- gcc/fortran/match.h	(working copy)
*************** match gfc_match_select (void);
*** 121,126 ****
--- 121,128 ----
  match gfc_match_select_type (void);
  match gfc_match_type_is (void);
  match gfc_match_class_is (void);
+ match gfc_match_select_rank (void);
+ match gfc_match_rank_is (void);
  match gfc_match_where (gfc_statement *);
  match gfc_match_elsewhere (void);
  match gfc_match_forall (gfc_statement *);
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 275242)
--- gcc/fortran/parse.c	(working copy)
*************** decode_statement (void)
*** 426,431 ****
--- 426,432 ----
    match (NULL, gfc_match_critical, ST_CRITICAL);
    match (NULL, gfc_match_select, ST_SELECT_CASE);
    match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
+   match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
  
    /* General statement matching: Instead of testing every possible
       statement, we eliminate most possibilities by peeking at the
*************** decode_statement (void)
*** 546,551 ****
--- 547,553 ----
        break;
  
      case 'r':
+       match ("rank", gfc_match_rank_is, ST_RANK);
        match ("read", gfc_match_read, ST_READ);
        match ("return", gfc_match_return, ST_RETURN);
        match ("rewind", gfc_match_rewind, ST_REWIND);
*************** next_statement (void)
*** 1537,1543 ****
  #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
    case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
    case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
!   case ST_OMP_PARALLEL: \
    case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
    case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
    case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
--- 1539,1545 ----
  #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
    case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
    case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
!   case ST_SELECT_RANK: case ST_OMP_PARALLEL: \
    case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
    case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
    case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
*************** gfc_ascii_statement (gfc_statement st)
*** 2077,2088 ****
--- 2079,2096 ----
      case ST_SELECT_TYPE:
        p = "SELECT TYPE";
        break;
+     case ST_SELECT_RANK:
+       p = "SELECT RANK";
+       break;
      case ST_TYPE_IS:
        p = "TYPE IS";
        break;
      case ST_CLASS_IS:
        p = "CLASS IS";
        break;
+     case ST_RANK:
+       p = "RANK";
+       break;
      case ST_SEQUENCE:
        p = "SEQUENCE";
        break;
*************** done:
*** 4306,4311 ****
--- 4314,4394 ----
  }
  
  
+ /* Parse a SELECT RANK construct.  */
+ 
+ static void
+ parse_select_rank_block (void)
+ {
+   gfc_statement st;
+   gfc_code *cp;
+   gfc_state_data s;
+ 
+   gfc_current_ns = new_st.ext.block.ns;
+   accept_statement (ST_SELECT_RANK);
+ 
+   cp = gfc_state_stack->tail;
+   push_state (&s, COMP_SELECT_RANK, gfc_new_block);
+ 
+   /* Make sure that the next statement is a RANK IS or RANK DEFAULT.  */
+   for (;;)
+     {
+       st = next_statement ();
+       if (st == ST_NONE)
+ 	unexpected_eof ();
+       if (st == ST_END_SELECT)
+ 	/* Empty SELECT CASE is OK.  */
+ 	goto done;
+       if (st == ST_RANK)
+ 	break;
+ 
+       gfc_error ("Expected RANK or RANK DEFAULT "
+ 		 "following SELECT RANK at %C");
+ 
+       reject_statement ();
+     }
+ 
+   /* At this point, we're got a nonempty select block.  */
+   cp = new_level (cp);
+   *cp = new_st;
+ 
+   accept_statement (st);
+ 
+   do
+     {
+       st = parse_executable (ST_NONE);
+       switch (st)
+ 	{
+ 	case ST_NONE:
+ 	  unexpected_eof ();
+ 
+ 	case ST_RANK:
+ 	  cp = new_level (gfc_state_stack->head);
+ 	  *cp = new_st;
+ 	  gfc_clear_new_st ();
+ 
+ 	  accept_statement (st);
+ 	  /* Fall through */
+ 
+ 	case ST_END_SELECT:
+ 	  break;
+ 
+ 	/* Can't have an executable statement because of
+ 	   parse_executable().  */
+ 	default:
+ 	  unexpected_statement (st);
+ 	  break;
+ 	}
+     }
+   while (st != ST_END_SELECT);
+ 
+ done:
+   pop_state ();
+   accept_statement (st);
+   gfc_current_ns = gfc_current_ns->parent;
+   select_type_pop ();
+ }
+ 
+ 
  /* Given a symbol, make sure it is not an iteration variable for a DO
     statement.  This subroutine is called when the symbol is seen in a
     context that causes it to become redefined.  If the symbol is an
*************** parse_executable (gfc_statement st)
*** 5360,5365 ****
--- 5443,5452 ----
  	  parse_select_type_block ();
  	  break;
  
+ 	case ST_SELECT_RANK:
+ 	  parse_select_rank_block ();
+ 	  break;
+ 
  	case ST_DO:
  	  parse_do_block ();
  	  if (check_do_closure () == 1)
Index: gcc/fortran/parse.h
===================================================================
*** gcc/fortran/parse.h	(revision 275242)
--- gcc/fortran/parse.h	(working copy)
*************** enum gfc_compile_state
*** 30,36 ****
    COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
    COMP_STRUCTURE, COMP_UNION, COMP_MAP,
    COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
!   COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
  };
  
  /* Stack element for the current compilation state.  These structures
--- 30,37 ----
    COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
    COMP_STRUCTURE, COMP_UNION, COMP_MAP,
    COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
!   COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL,
!   COMP_DO_CONCURRENT
  };
  
  /* Stack element for the current compilation state.  These structures
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 275242)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_procedure_expression (gfc_expr*
*** 1866,1872 ****
  
  
  /* Check that name is not a derived type.  */
!  
  static bool
  is_dt_name (const char *name)
  {
--- 1866,1872 ----
  
  
  /* Check that name is not a derived type.  */
! 
  static bool
  is_dt_name (const char *name)
  {
*************** resolve_variable (gfc_expr *e)
*** 5455,5467 ****
  	}
      }
    /* 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))
!     {
!       if (!actual_arg)
  	{
  	  gfc_error ("Assumed-rank variable %s at %L may only be used as "
  		     "actual argument", sym->name, &e->where);
--- 5455,5470 ----
  	}
      }
    /* 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))
! 	   && !sym->attr.select_rank_temporary)
!     {
!       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);
*************** gfc_resolve_expr (gfc_expr *e)
*** 6915,6921 ****
    bool t;
    bool inquiry_save, actual_arg_save, first_actual_arg_save;
  
!   if (e == NULL)
      return true;
  
    /* inquiry_argument only applies to variables.  */
--- 6918,6924 ----
    bool t;
    bool inquiry_save, actual_arg_save, first_actual_arg_save;
  
!   if (e == NULL || e->do_not_resolve_again)
      return true;
  
    /* inquiry_argument only applies to variables.  */
*************** gfc_resolve_expr (gfc_expr *e)
*** 7025,7030 ****
--- 7028,7040 ----
    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;
  }
  
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8841,8847 ****
    if (target->ts.type == BT_CLASS)
      gfc_fix_class_refs (target);
  
!   if (target->rank != 0)
      {
        gfc_array_spec *as;
        /* The rank may be incorrectly guessed at parsing, therefore make sure
--- 8851,8857 ----
    if (target->ts.type == BT_CLASS)
      gfc_fix_class_refs (target);
  
!   if (target->rank != 0 && !sym->attr.select_rank_temporary)
      {
        gfc_array_spec *as;
        /* The rank may be incorrectly guessed at parsing, therefore make sure
*************** resolve_assoc_var (gfc_symbol* sym, bool
*** 8871,8877 ****
  	    CLASS_DATA (sym)->attr.codimension = 1;
  	}
      }
!   else
      {
        /* target's rank is 0, but the type of the sym is still array valued,
  	 which has to be corrected.  */
--- 8881,8887 ----
  	    CLASS_DATA (sym)->attr.codimension = 1;
  	}
      }
!   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.  */
*************** resolve_select_type (gfc_code *code, gfc
*** 9490,9495 ****
--- 9500,9674 ----
  }
  
  
+ /* 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
*************** gfc_resolve_blocks (gfc_code *b, gfc_nam
*** 10366,10371 ****
--- 10545,10551 ----
  
  	case EXEC_SELECT:
  	case EXEC_SELECT_TYPE:
+ 	case EXEC_SELECT_RANK:
  	case EXEC_FORALL:
  	case EXEC_DO:
  	case EXEC_DO_WHILE:
*************** start:
*** 11643,11648 ****
--- 11823,11832 ----
  	  resolve_select_type (code, ns);
  	  break;
  
+ 	case EXEC_SELECT_RANK:
+ 	  resolve_select_rank (code, ns);
+ 	  break;
+ 
  	case EXEC_BLOCK:
  	  resolve_block_construct (code);
  	  break;
*************** resolve_typebound_procedure (gfc_symtree
*** 13573,13579 ****
      }
    else
      {
!       /* 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)
--- 13757,13763 ----
      }
    else
      {
!       /* 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)
*************** resolve_symbol (gfc_symbol *sym)
*** 15048,15054 ****
  	}
        /* TS 29113, C535a.  */
        if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
! 	  && !sym->attr.select_type_temporary)
  	{
  	  gfc_error ("Assumed-rank array at %L must be a dummy argument",
  		     &sym->declared_at);
--- 15232,15240 ----
  	}
        /* TS 29113, C535a.  */
        if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
! 	  && !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);
Index: gcc/fortran/st.c
===================================================================
*** gcc/fortran/st.c	(revision 275242)
--- gcc/fortran/st.c	(working copy)
*************** gfc_free_statement (gfc_code *p)
*** 141,146 ****
--- 141,147 ----
  
      case EXEC_SELECT:
      case EXEC_SELECT_TYPE:
+     case EXEC_SELECT_RANK:
        if (p->ext.block.case_list)
  	gfc_free_case_list (p->ext.block.case_list);
        break;
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 275242)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3609,3615 ****
  
    if (ar->dimen == 0)
      {
!       gcc_assert (ar->codimen);
  
        if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
  	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
--- 3609,3615 ----
  
    if (ar->dimen == 0)
      {
!       gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
  
        if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
  	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7758,7763 ****
--- 7758,7769 ----
  	  gfc_conv_descriptor_offset_set (&loop.pre, parm,
  					 gfc_conv_descriptor_offset_get (desc));
  	}
+       else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ 	       && !se->data_not_needed
+ 	       && gfc_expr_attr (expr).select_rank_temporary)
+ 	{
+ 	  gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
+ 	}
        else if (onebased && (!rank_remap || se->use_offset)
  	  && expr->symtree
  	  && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 275242)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** class_has_len_component (gfc_symbol *sym
*** 1641,1646 ****
--- 1641,1688 ----
  }
  
  
+ static void
+ copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
+ {
+   int n;
+   tree dim;
+   tree tmp;
+   tree tmp2;
+   tree size;
+   tree offset;
+ 
+   offset = gfc_index_zero_node;
+ 
+   /* Use memcpy to copy the descriptor. The size is the minimum of
+      the sizes of 'src' and 'dst'. This avoids a non-trivial conversion.  */
+   tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
+   tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
+   size = fold_build2_loc (input_location, MIN_EXPR,
+ 			  TREE_TYPE (tmp), tmp, tmp2);
+   tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+   tmp = build_call_expr_loc (input_location, tmp, 3,
+ 			     gfc_build_addr_expr (NULL_TREE, dst),
+ 			     gfc_build_addr_expr (NULL_TREE, src),
+ 			     fold_convert (size_type_node, size));
+   gfc_add_expr_to_block (block, tmp);
+ 
+   /* Set the offset correctly.  */
+   for (n = 0; n < rank; n++)
+     {
+       dim = gfc_rank_cst[n];
+       tmp = gfc_conv_descriptor_lbound_get (src, dim);
+       tmp2 = gfc_conv_descriptor_stride_get (src, dim);
+       tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ 			     tmp, tmp2);
+       offset = fold_build2_loc (input_location, MINUS_EXPR,
+ 			TREE_TYPE (offset), offset, tmp);
+       offset = gfc_evaluate_now (offset, block);
+     }
+ 
+   gfc_conv_descriptor_offset_set (block, dst, offset);
+ }
+ 
+ 
  /* Do proper initialization for ASSOCIATE names.  */
  
  static void
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1658,1663 ****
--- 1700,1706 ----
    bool need_len_assign;
    bool whole_array = true;
    gfc_ref *ref;
+   gfc_symbol *sym2;
  
    gcc_assert (sym->assoc);
    e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1690,1701 ****
                       && e->ts.u.derived->attr.unlimited_polymorphic))
        && (sym->ts.type == BT_CHARACTER
            || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
!               && class_has_len_component (sym))));
    /* Do a `pointer assignment' with updated descriptor (or assign descriptor
       to array temporary) for arrays with either unknown shape or if associating
!      to a variable.  */
!   if (sym->attr.dimension && !class_target
!       && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
      {
        gfc_se se;
        tree desc;
--- 1733,1872 ----
                       && e->ts.u.derived->attr.unlimited_polymorphic))
        && (sym->ts.type == BT_CHARACTER
            || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
!               && class_has_len_component (sym)))
!       && !sym->attr.select_rank_temporary);
! 
    /* Do a `pointer assignment' with updated descriptor (or assign descriptor
       to array temporary) for arrays with either unknown shape or if associating
!      to a variable. Select rank temporaries need somewhat different treatment
!      to other associate names and case temporaries. This because the selector
!      is assumed rank and so the offset in particular has to be changed. Also,
!      the case temporaries carry both allocatable and target attributes if
!      present in the selector. This means that an allocatation or change of
!      association can occur and so has to be dealt with.  */
!   if (sym->attr.select_rank_temporary)
!     {
!       gfc_se se;
!       tree class_decl = NULL_TREE;
!       int rank = 0;
!       bool class_ptr;
! 
!       sym2 = e->symtree->n.sym;
!       gfc_init_se (&se, NULL);
!       if (e->ts.type == BT_CLASS)
! 	{
! 	  /* Go straight to the class data.  */
! 	  if (sym2->attr.dummy)
! 	    {
! 	      class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ?
! 			   GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) :
! 			   sym2->backend_decl;
! 	      if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
! 		class_decl = build_fold_indirect_ref_loc (input_location,
! 							  class_decl);
! 	      gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
! 	      se.expr = gfc_class_data_get (class_decl);
! 	    }
! 	  else
! 	    {
! 	      class_decl = sym2->backend_decl;
! 	      gfc_conv_expr_descriptor (&se, e);
! 	      if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
! 		se.expr = build_fold_indirect_ref_loc (input_location,
! 						       se.expr);
! 	    }
! 
! 	  if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
! 	    rank = CLASS_DATA (sym)->as->rank;
! 	}
!       else
! 	{
! 	  gfc_conv_expr_descriptor (&se, e);
! 	  if (sym->as && sym->as->rank > 0)
! 	    rank = sym->as->rank;
! 	}
! 
!       desc = sym->backend_decl;
! 
!       /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
! 	 point to the selector. */
!       class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
!       if (class_ptr)
! 	{
! 	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
! 	  tmp = gfc_build_addr_expr (NULL, tmp);
! 	  gfc_add_modify (&se.pre, desc, tmp);
! 
! 	  tmp = gfc_class_vptr_get (class_decl);
! 	  gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
! 	  if (UNLIMITED_POLY (sym))
! 	    gfc_add_modify (&se.pre, gfc_class_len_get (desc),
! 			    gfc_class_len_get (class_decl));
! 
! 	  desc = gfc_class_data_get (desc);
! 	}
! 
!       /* SELECT RANK temporaries can carry the allocatable and pointer
! 	 attributes so the selector descriptor must be copied in and
! 	 copied out.  */
!       if (rank > 0)
! 	copy_descriptor (&se.pre, desc, se.expr, rank);
!       else
! 	{
! 	  tmp = gfc_conv_descriptor_data_get (se.expr);
! 	  gfc_add_modify (&se.pre, desc,
! 			  fold_convert (TREE_TYPE (desc), tmp));
! 	}
! 
!       /* Deal with associate_name => selector. Class associate names are
! 	 treated in the same way as in SELECT TYPE.  */
!       sym2 = sym->assoc->target->symtree->n.sym;
!       if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
! 	{
! 	  sym2 = sym2->assoc->target->symtree->n.sym;
! 	  se.expr = sym2->backend_decl;
! 
! 	  if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
! 	    se.expr = build_fold_indirect_ref_loc (input_location,
! 						   se.expr);
! 	}
! 
!       /* There could have been reallocation.  Copy descriptor back to the
! 	 selector and update the offset.  */
!       if (sym->attr.allocatable || sym->attr.pointer
! 	  || (sym->ts.type == BT_CLASS
! 	      && (CLASS_DATA (sym)->attr.allocatable
! 		  || CLASS_DATA (sym)->attr.pointer)))
! 	{
! 	  if (rank > 0)
! 	    copy_descriptor (&se.post, se.expr, desc, rank);
! 	  else
! 	    {
! 	      tmp = gfc_conv_descriptor_data_get (desc);
! 	      gfc_conv_descriptor_data_set (&se.post, se.expr, tmp);
! 	    }
! 
! 	  /* The dynamic type could have changed too.  */
! 	  if (sym->ts.type == BT_CLASS)
! 	    {
! 	      tmp = sym->backend_decl;
! 	      if (class_ptr)
! 		tmp = build_fold_indirect_ref_loc (input_location, tmp);
! 	      gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
! 			      gfc_class_vptr_get (tmp));
! 	      if (UNLIMITED_POLY (sym))
! 		gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
! 				gfc_class_len_get (tmp));
! 	    }
! 	}
! 
!       tmp = gfc_finish_block (&se.post);
! 
!       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
!     }
!   /* Now all the other kinds of associate variable.  */
!   else if (sym->attr.dimension && !class_target
! 	   && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
      {
        gfc_se se;
        tree desc;
*************** gfc_trans_select_type (gfc_code * code)
*** 3416,3421 ****
--- 3587,3728 ----
  
    /* Build everything together.  */
    gfc_add_expr_to_block (&block, body);
+ 
+   if (TREE_USED (exit_label))
+     gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+ 
+   return gfc_finish_block (&block);
+ }
+ 
+ 
+ static tree
+ gfc_trans_select_rank_cases (gfc_code * code)
+ {
+   gfc_code *c;
+   gfc_case *cp;
+   tree tmp;
+   tree cond;
+   tree low;
+   tree sexpr;
+   tree rank;
+   tree rank_minus_one;
+   tree minus_one;
+   gfc_se se;
+   gfc_se cse;
+   stmtblock_t block;
+   stmtblock_t body;
+   bool def = false;
+ 
+   gfc_start_block (&block);
+ 
+   /* Calculate the switch expression.  */
+   gfc_init_se (&se, NULL);
+   gfc_conv_expr_descriptor (&se, code->expr1);
+   rank = gfc_conv_descriptor_rank (se.expr);
+   rank = gfc_evaluate_now (rank, &block);
+   minus_one = build_int_cst (TREE_TYPE (rank), -1);
+   tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			 gfc_array_index_type,
+ 			 fold_convert (gfc_array_index_type, rank),
+ 			 build_int_cst (gfc_array_index_type, 1));
+   rank_minus_one = gfc_evaluate_now (tmp, &block);
+   tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
+   cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ 			  tmp, build_int_cst (TREE_TYPE (tmp), -1));
+   tmp = fold_build3_loc (input_location, COND_EXPR,
+ 			 TREE_TYPE (rank), cond,
+ 			 rank, minus_one);
+   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ 			  rank, build_int_cst (TREE_TYPE (rank), 0));
+   sexpr = fold_build3_loc (input_location, COND_EXPR,
+ 			   TREE_TYPE (rank), cond,
+ 			   rank, tmp);
+   sexpr = gfc_evaluate_now (sexpr, &block);
+   TREE_USED (code->exit_label) = 0;
+ 
+ repeat:
+   for (c = code->block; c; c = c->block)
+     {
+       cp = c->ext.block.case_list;
+ 
+       /* Assume it's the default case.  */
+       low = NULL_TREE;
+       tmp = NULL_TREE;
+ 
+       /* Put the default case at the end.  */
+       if ((!def && !cp->low) || (def && cp->low))
+ 	continue;
+ 
+       if (cp->low)
+ 	{
+ 	  gfc_init_se (&cse, NULL);
+ 	  gfc_conv_expr_val (&cse, cp->low);
+ 	  gfc_add_block_to_block (&block, &cse.pre);
+ 	  low = cse.expr;
+ 	}
+ 
+       gfc_init_block (&body);
+ 
+       /* Add the statements for this case.  */
+       tmp = gfc_trans_code (c->next);
+       gfc_add_expr_to_block (&body, tmp);
+ 
+       /* Break to the end of the SELECT RANK construct.  The default
+ 	 case just falls through.  */
+       if (!def)
+ 	{
+ 	  TREE_USED (code->exit_label) = 1;
+ 	  tmp = build1_v (GOTO_EXPR, code->exit_label);
+ 	  gfc_add_expr_to_block (&body, tmp);
+ 	}
+ 
+       tmp = gfc_finish_block (&body);
+ 
+       if (low != NULL_TREE)
+ 	{
+ 	  cond = fold_build2_loc (input_location, EQ_EXPR,
+ 				  TREE_TYPE (sexpr), sexpr,
+ 				  fold_convert (TREE_TYPE (sexpr), low));
+ 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ 				 cond, tmp,
+ 				 build_empty_stmt (input_location));
+ 	}
+ 
+       gfc_add_expr_to_block (&block, tmp);
+     }
+ 
+   if (!def)
+     {
+       def = true;
+       goto repeat;
+     }
+ 
+   return gfc_finish_block (&block);
+ }
+ 
+ 
+ tree
+ gfc_trans_select_rank (gfc_code * code)
+ {
+   stmtblock_t block;
+   tree body;
+   tree exit_label;
+ 
+   gcc_assert (code && code->expr1);
+   gfc_init_block (&block);
+ 
+   /* Build the exit label and hang it in.  */
+   exit_label = gfc_build_label_decl (NULL_TREE);
+   code->exit_label = exit_label;
+ 
+   /* Empty SELECT constructs are legal.  */
+   if (code->block == NULL)
+     body = build_empty_stmt (input_location);
+   else
+     body = gfc_trans_select_rank_cases (code);
+ 
+   /* Build everything together.  */
+   gfc_add_expr_to_block (&block, body);
  
    if (TREE_USED (exit_label))
      gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
Index: gcc/fortran/trans-stmt.h
===================================================================
*** gcc/fortran/trans-stmt.h	(revision 275242)
--- gcc/fortran/trans-stmt.h	(working copy)
*************** tree gfc_trans_do_concurrent (gfc_code *
*** 53,58 ****
--- 53,59 ----
  tree gfc_trans_do_while (gfc_code *);
  tree gfc_trans_select (gfc_code *);
  tree gfc_trans_select_type (gfc_code *);
+ tree gfc_trans_select_rank (gfc_code *);
  tree gfc_trans_sync (gfc_code *, gfc_exec_op);
  tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
  tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c	(revision 275242)
--- gcc/fortran/trans.c	(working copy)
*************** trans_code (gfc_code * code, tree cond)
*** 1968,1973 ****
--- 1968,1977 ----
  	  res = gfc_trans_select_type (code);
  	  break;
  
+ 	case EXEC_SELECT_RANK:
+ 	  res = gfc_trans_select_rank (code);
+ 	  break;
+ 
  	case EXEC_FLUSH:
  	  res = gfc_trans_flush (code);
  	  break;
Index: gcc/testsuite/gfortran.dg/select_rank_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/select_rank_1.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/select_rank_1.f90	(working copy)
***************
*** 0 ****
--- 1,179 ----
+ ! { dg-do run }
+ !
+ ! Basic tests of SELECT RANK
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   implicit none
+   type mytype
+     real :: r
+   end type
+   type, extends(mytype) :: thytype
+     integer :: i
+   end type
+ 
+ ! Torture using integers
+ ints: block
+   integer, dimension(2,2) :: y = reshape ([1,2,3,4],[2,2])
+   integer, dimension(4) :: z = [1,2,3,4]
+   integer, dimension(2,2,2) :: q = reshape ([11,12,13,14,15,16,17,18],[2,2,2])
+   integer :: i = 42
+ 
+   call ifoo(y, "y")
+   if (any (y .ne. reshape ([10,11,12,13], [2,2]))) stop 1
+   call ifoo(z, "z")
+   call ifoo(i, "i")
+   call ifoo(q, "q")
+   if (any (q .ne. reshape ([11,12,10,11,15,16,12,13], [2,2,2]))) stop 2
+   call ibar(y)
+ end block ints
+ 
+ ! Check derived types
+ types: block
+   integer :: i
+   type(mytype), allocatable, dimension(:,:) :: t
+   type(mytype), allocatable :: u
+ 
+   allocate (t, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2]))
+   call tfoo(t, "t")
+   if (any (size (t) .ne. [1,1])) stop 3   ! 't' has been reallocated!
+   if (abs (t(1,1)%r - 42.0) .ge. 1e-6) stop 4
+   allocate (u, source = mytype(42.0))
+   call tfoo(u, "u")
+ end block types
+ 
+ ! Check classes
+ classes: block
+   integer :: i
+   class(mytype), allocatable, dimension(:,:) :: v
+   class(mytype), allocatable :: w
+ 
+   allocate (v, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2]))
+   call cfoo(v, "v")
+   select type (v)
+     type is (mytype)
+       stop 5
+     type is (thytype)
+       if (any (ubound (v) .ne. [3,3])) stop 6
+       if (any (abs (v%r - 99.0) .ge. 1e-6)) stop 7
+       if (any (v%i .ne. 42)) stop 8
+   end select
+   allocate (w, source = thytype(42.0, 99))
+   call cfoo(w, "w")
+ end block classes
+ 
+ ! Check unlimited polymorphic.
+ unlimited: block
+   integer(4) :: i
+   class(*), allocatable, dimension(:,:,:) :: v
+ 
+   allocate (v, source = reshape ([(i, i = 1,8)],[2,2,2]))
+   call ufoo(v, "v")
+   select type (v)
+     type is (integer(4))
+       stop 9
+     type is (real(4))
+       if (any (ubound(v) .ne. [2,2,1])) stop 10
+       if (abs (sum (v) - 10.0) .gt. 1e-6) stop 11
+   end select
+ end block unlimited
+ 
+ contains
+ 
+   recursive subroutine ifoo(w, chr)
+     integer, dimension(..) :: w
+     character(1) :: chr
+ 
+     OUTER: select rank (x => w)
+       rank (2)
+         if ((chr .eq. 'y') .and. (any (x(1,:) .ne. [1,3]))) stop 12
+         if ((chr .eq. 'r') .and. (any (x(1,:) .ne. [13,17]))) stop 13
+         x = reshape ([10,11,12,13], [2,2])
+       rank (0)
+         if ((chr .eq. 'i') .and. (x .ne. 42)) stop 14
+       rank (*)
+         if ((chr .eq. 'w') .and. (any (x(1:4) .ne. [10,11,12,13]))) stop 15
+       rank default
+         if ((chr .eq. 'z') .and. (rank (x) .ne. 1)) stop 16
+         if ((chr .eq. 'q') .and. (rank (x) .ne. 3)) stop 17
+         INNER: select rank (x)
+           rank (1) INNER
+             if ((chr .eq. 'z') .and. (any (x(1:4) .ne. [1,2,3,4]))) stop 18
+           rank (3) INNER
+  ! Pass a rank 2 section otherwise an infinite loop ensues.
+             call ifoo(x(:,2,:), 'r')
+         end select INNER
+     end select OUTER
+   end subroutine ifoo
+ 
+   subroutine ibar(x)
+     integer, dimension(*) :: x
+ 
+     call ifoo(x, "w")
+   end subroutine ibar
+ 
+   subroutine tfoo(w, chr)
+     type(mytype), dimension(..), allocatable :: w
+     character(1) :: chr
+     integer :: i
+     type(mytype), dimension(2,2) :: r
+ 
+     select rank (x => w)
+       rank (2)
+         if (chr .eq. 't') then
+           r = reshape ([(mytype(real(i)), i = 1,4)],[2,2])
+           if (any (abs (x%r - r%r) .gt. 1e-6)) stop 19
+           if (allocated (x)) deallocate (x)
+           allocate (x(1,1))
+           x(1,1) = mytype (42.0)
+         end if
+       rank default
+         if ((chr .eq. 'u') .and. (rank (x) .ne. 0)) stop 20
+     end select
+   end subroutine tfoo
+ 
+   subroutine cfoo(w, chr)
+     class(mytype), dimension(..), allocatable :: w
+     character(1) :: chr
+     integer :: i
+     type(mytype), dimension(2,2) :: r
+ 
+     select rank (c => w)
+       rank (2)
+         select type (c)
+           type is (mytype)
+             if (chr .eq. 'v') then
+               r = reshape ([(mytype(real(i)), i = 1,4)],[2,2])
+               if (any (abs (c%r - r%r) .gt. 1e-6)) stop 21
+             end if
+           class default
+             stop 22
+         end select
+         if (allocated (c)) deallocate (c)
+         allocate (c(3,3), source = thytype (99.0, 42))
+       rank default
+         if ((chr .eq. 'w') .and. (rank (c) .ne. 0)) stop 23
+     end select
+   end subroutine cfoo
+ 
+   subroutine ufoo(w, chr)
+     class(*), dimension(..), allocatable :: w
+     character(1) :: chr
+     integer :: i
+ 
+     select rank (c => w)
+       rank (3)
+         select type (c)
+           type is (integer(4))
+             if (chr .eq. 'v' .and. (sum (c) .ne. 36)) stop 24
+           class default
+             stop 25
+         end select
+         if (allocated (c)) deallocate(c)
+         allocate (c, source = reshape ([(real(i), i = 1,4)],[2,2,1]))
+       rank default
+         stop 26
+     end select
+   end subroutine ufoo
+ 
+ end
Index: gcc/testsuite/gfortran.dg/select_rank_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/select_rank_2.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/select_rank_2.f90	(working copy)
***************
*** 0 ****
--- 1,85 ----
+ ! { dg-do compile }
+ !
+ ! Basic tests of SELECT RANK
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+ subroutine foo1 (arg)
+   integer :: i
+   integer, dimension(3) :: arg
+   select rank (arg)   ! { dg-error "must be an assumed rank variable" }
+     rank (3)
+     print *, arg
+   end select
+ end
+ 
+ subroutine foo2 (arg)
+   integer :: i
+   integer, dimension(..) :: arg
+   select rank (arg)
+     rank (i)          ! { dg-error "must be a scalar" }
+     print *, arg      ! { dg-error "Expected RANK or RANK DEFAULT" }
+   end select
+ end
+ 
+ subroutine foo3 (arg)
+   integer :: i
+   integer, parameter :: r = 3
+   integer, dimension(..) :: arg
+   select rank (arg)
+     rank (16)         ! { dg-error "must not be less than zero or greater than 15" }
+     print *, arg      ! { dg-error "Expected RANK or RANK DEFAULT" }
+     rank (-1)         ! { dg-error "must not be less than zero or greater than 15" }
+     print *, arg      ! { dg-error "Expected RANK or RANK DEFAULT" }
+     rank (r)          ! OK
+     print *, arg
+   end select
+ end
+ 
+ subroutine foo4 (arg)
+   integer :: i
+   integer, dimension(..), pointer :: arg
+   select rank (arg)   ! { dg-error "cannot be used with the pointer or allocatable selector" }
+     rank (*)          ! { dg-error "cannot be used with the pointer or allocatable selector" }
+     print *, arg(1:1)
+     rank (1)
+     print *, arg
+   end select
+ end
+ 
+ subroutine foo5 (arg)
+   integer :: i
+   integer, dimension(..), ALLOCATABLE :: arg
+   select rank (arg)   ! { dg-error "cannot be used with the pointer or allocatable selector" }
+     rank (*)          ! { dg-error "pointer or allocatable selector|deferred shape or assumed rank" }
+     print *, arg(1:1)
+     rank (1)
+     print *, arg
+   end select
+ end
+ 
+ subroutine foo6 (arg)
+   integer :: i
+   integer, dimension(..) :: arg
+   select rank (arg)
+     rank (*)
+     print *, arg      ! { dg-error "assumed.size array" }
+     rank (1)
+     print *, arg
+   end select
+ end
+ 
+ subroutine foo7 (arg)
+   integer :: i
+   integer, dimension(..) :: arg
+   select rank (arg)
+     rank (1)          ! { dg-error "is repeated" }
+       arg = 1
+     rank (1)          ! { dg-error "is repeated" }
+       arg = 1
+     rank (*)          ! { dg-error "is repeated" }
+     rank (*)          ! { dg-error "is repeated" }
+     rank default      ! { dg-error "is repeated" }
+     rank default      ! { dg-error "is repeated" }
+   end select
+ end