Patchwork [Fortran] Add parsing support for assumed-rank array

login
register
mail settings
Submitter Tobias Burnus
Date June 24, 2012, 3:34 p.m.
Message ID <4FE7337C.3030002@net-b.de>
Download mbox | patch
Permalink /patch/166887/
State New
Headers show

Comments

Tobias Burnus - June 24, 2012, 3:34 p.m.
Tobias Burnus wrote:
> To cleanup my local trees; I had the patch lingering there for a many 
> weeks. User visible, it only adds parsing support for "dimension(..)" 
> and a sorry message.

I have now updated the patch. Changes:

* No longer stops with a sorry message (except for scalars to 
assumed-rank arrays)
* Test cases are included
* Passing nondescriptor arrays now works
* lbound, ubound and size with dim=  and size without dim= are 
supported, including the distinction of the lower bound for 
allocatables/pointers vs nonallocatables/nonpointers
* Many constraint checks

Missing:
* Passing of scalars
* Scalarizer (to be used by lbound/ubound/shape w/o dim=)
* More tests, especially with noncontiguous assumed-shape->contiguous, 
type<->class, and assumed-size arrays - and fixing the fall out
* Relaxing the constraint checks for C_loc et alia.
(* And out of scope: Full access from C as that implies the new array 
descriptor.)

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias
Mikael Morin - July 5, 2012, 1:51 p.m.
On 24.06.2012 17:34, Tobias Burnus wrote:
> Tobias Burnus wrote:
>> To cleanup my local trees; I had the patch lingering there for a many
>> weeks. User visible, it only adds parsing support for "dimension(..)"
>> and a sorry message.
>
> I have now updated the patch. Changes:
>

Hello,

some commen^Wbike shedding below. Overall it looks good.
I may have missed the point about the way you handle diagnostics.

Mikael

> diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
> index 7d505d5..b0c4b28 100644
> --- a/gcc/fortran/check.c
> +++ b/gcc/fortran/check.c
> @@ -619,6 +619,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
>    else
>      rank = array->rank;
>
> +  /* Assumed-rank array.  */
> +  if (rank == -1)
> +    rank = GFC_MAX_DIMENSIONS;
> +
I think the  assumed-rank => rank == -1  convention should be documented 
in gfortran.h, at least for the gfc_array_spec::rank field.




> @@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
>  	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
>  	      return;
>  	    }
> +
> +	  /* TS 29113, C407b.  */
> +	  if (a->expr && a->expr->expr_type == EXPR_VARIABLE
> +	      && symbol_rank (a->expr->symtree->n.sym) == -1)
> +	    {
> +	      gfc_error ("Assumed-rank argument requires an explicit interface "
> +			 "at %L", &a->expr->where);
> +	      return;
> +	    }
>  	}
>
>        return;

Doesn't this duplicates the other explicit interface diagnostic below...


> @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
>  			   sym->name, &sym->declared_at, arg->sym->name);
>  		break;
>  	      }
> +	    /* TS 29113, 6.2.  */
> +	    else if (arg->sym && arg->sym->as
> +		     && arg->sym->as->type == AS_ASSUMED_RANK)
> +	      {
> +		gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
> +			   "argument '%s' must have an explicit interface",
> +			   sym->name, &sym->declared_at, arg->sym->name);
> +		break;
> +	      }
>  	    /* F2008, 12.4.2.2 (2c)  */
>  	    else if (arg->sym->attr.codimension)
>  	      {

... here?





> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
>    sym = e->symtree->n.sym;
>
>    /* TS 29113, 407b.  */
> -  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
> +  if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
>      {
>        gfc_error ("Invalid expression with assumed-type variable %s at %L",
>  		 sym->name, &e->where);
>        return FAILURE;
>      }

I'm not sure I understand the logic with the mixed assumed rank/type 
flag. According to C407c, shouldn't we check that e is assumed rank/shape?


>
> +  /* TS 29113, C535b.  */
> +  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))
> +      && !assumed_rank_type_expr_allowed)
> +    {
> +      gfc_error ("Invalid expression with assumed-rank variable %s at %L",
> +		 sym->name, &e->where);

The error message could be made more helpful. ;-)


> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
>        return FAILURE;
>      }
>
> +  /* TS 29113, C535b.  */
> +  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))
> +      && e->ref
> +      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
> +           && e->ref->next == NULL))
> +    {
> +      gfc_error ("Assumed-rank variable %s with designator at %L",
> +                 sym->name, &e->ref->u.ar.where);

Ditto here. And I think that C535b is more about the context of the 
expression rather than the expression itself.





> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
> index f135af1..6c58a8e 100644
> --- a/gcc/fortran/trans-array.c
> +++ b/gcc/fortran/trans-array.c
> @@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
>  	  break;
>
>  	case AR_FULL:
> -	  newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
> +	  newss = gfc_get_array_ss (ss, expr,
> +				    ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
> +						     : ar->as->rank,
> +				    GFC_SS_SECTION);
>  	  newss->info->data.array.ref = ref;
>
>  	  /* Make sure array is the same as array(:,:), this way
>  	     we don't need to special case all the time.  */
> -	  ar->dimen = ar->as->rank;
> +	  ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
>  	  for (n = 0; n < ar->dimen; n++)
>  	    {
>  	      ar->dimen_type[n] = DIMEN_RANGE;

I would rather avoid that if possible.
The scalarizer assumes the rank is known, and all hell breaks loose if 
it's not the case.
After quickly browsing through TS29113, I couldn't tell whether 
expressions like (ar + 1) would be valid as assumed rank actual argument.
In case it is, gfc_conv_expr_descriptor won't work correctly, as it will 
hardcode exactly GFC_MAX_DIMENSIONS loops to set the temporary, 
accessing the array descriptor's fields (i.e. bounds, etc) beyond the 
maximal dimension.
In case it's not, then everything is fine I guess, though I prefer 
avoiding polluting the scalarizer with assumed rank stuff ;-).
Tobias Burnus - July 6, 2012, 9:13 p.m.
Hi Mikael, hi all,

Mikael Morin wrote:
>> index f135af1..6c58a8e 100644
>> --- a/gcc/fortran/trans-array.c
>> +++ b/gcc/fortran/trans-array.c
>> @@ -8319,12 +8323,15 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * 
>> expr, gfc_ref * ref)
>>        break;
>>
>>      case AR_FULL:
>> -      newss = gfc_get_array_ss (ss, expr, ar->as->rank, 
>> GFC_SS_SECTION);
>> +      newss = gfc_get_array_ss (ss, expr,
>> +                    ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
>> +                             : ar->as->rank,
>> +                    GFC_SS_SECTION);
>>        newss->info->data.array.ref = ref;
>>
>>        /* Make sure array is the same as array(:,:), this way
>>           we don't need to special case all the time.  */
>> -      ar->dimen = ar->as->rank;
>> +      ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
>>        for (n = 0; n < ar->dimen; n++)
>>          {
>>            ar->dimen_type[n] = DIMEN_RANGE;
> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
>
> I would rather avoid that if possible.

Maybe it is. However, the following has to work:

- ubound(assumed_rank, dim=i), ditto for lbound
- size(ar), size(ar, dim=i)

(That works with the current patch.) Furthermore, but unsupported, the 
following has to work:

- ubound(ar), lbound(ar) and shape(ar)
- Passing a class-actual assumed-rank variable to a derived-type 
assumed-rank dummy argument. (Required for packing - at least if the 
dummy is contiguous).

And for internal use for the FINAL wrapper function, but invalid 
according to the Technical Specification:
- call elemental_subroutine(ar)


> The scalarizer assumes the rank is known, and all hell breaks loose if 
> it's not the case.
> After quickly browsing through TS29113, I couldn't tell whether 
> expressions like (ar + 1) would be valid as assumed rank actual argument.

No, you are only allowed to do very few things with assumed rank arrays:

* Passing them as first argument to the intrinsic inquiry functions like 
PRESENT, ALLOCATED, ASSOCIATED, UBOUND, LBOUND, SHAPE and SIZE. (And 
some more like KIND but they aren't interesting.)

* Passing them to an assumed-rank procedure. (Here, allowed are: 
class->type, type->class, class->class, type->type and also 
non-simply-contiguous -> CONTIGUOUS, which implies a packing for the 
argument).

* As first argument to C_LOC

All other impressions and anything like "ar(:)" or "ar(1)" etc. aren't 
allowed.


> In case it's not, then everything is fine I guess, though I prefer 
> avoiding polluting the scalarizer with assumed rank stuff ;-).

It still will get worse, see above. Though, I wouldn't mind if you could 
modify the scalarizer. My next patch will be to pass scalars to assumed 
rank. It is mostly done, but it still has some issues.

Tobias

PS: I will reply later to the other issues raised in your review.
Mikael Morin - July 12, 2012, 7:38 p.m.
On 06/07/2012 23:13, Tobias Burnus wrote:
>> In case it's not, then everything is fine I guess, though I prefer
>> avoiding polluting the scalarizer with assumed rank stuff ;-).
> 
> It still will get worse, see above. Though, I wouldn't mind if you could
> modify the scalarizer. 

I don't see how I could.  The scalarizer's purpose is translating array
statements like foo(:,:) = bar(:,:), where the rank at least is supposed
known, so that we know how many nested loops we have to generate.  If
the number of loops is known at runtime only, hem, I don't see what code
we could generate.  We could probably produce something with complex
conditions and gotos in a single loop, but it seems to me far too
convoluted, and too big a change, in an area that already doesn't lack
complexity without it.

On the other hand, if I look at what should be supported, it doesn't
look that bad.  There are only full array references, so
gfc_conv_expr_descriptor with the flag se->descriptor_only should do the
right thing (i.e. nothing).  Class vs. type should be (correct me if I'm
wrong) a matter of decorating/undecorating with a class container.  As
for the contiguous/non-contiguous matter, I propose using libgfortran's
internal_{,un}pack and away with it.

Now about the implementation, I guess the devil is in the details.
I'll see if there is something that I obviously forgot or something to
do in gfc_conv_expr_descriptor.  Maybe that one (not the whole
scalarizer) could use a fix.

Mikael
Tobias Burnus - July 12, 2012, 8:08 p.m.
Mikael Morin wrote:
> I don't see how I could.  The scalarizer's purpose is translating array
> statements like foo(:,:) = bar(:,:), where the rank at least is supposed
> known, so that we know how many nested loops we have to generate.  If
> the number of loops is known at runtime only, hem, I don't see what code
> we could generate.  We could probably produce something with complex
> conditions and gotos in a single loop, but it seems to me far too
> convoluted, and too big a change, in an area that already doesn't lack
> complexity without it.
>
> On the other hand, if I look at what should be supported, it doesn't
> look that bad.

Concurred to both.

> There are only full array references, so gfc_conv_expr_descriptor with the flag se->descriptor_only should do the right thing (i.e. nothing).

That looks kind of okay for SHAPE/LBOUND/UBOUND, but we still need to 
create a single loop for filling the rank-one array with the values.

> Class vs. type should be (correct me if I'm wrong) a matter of decorating/undecorating with a class container.

No, that's only simple for TYPE -> CLASS.

Additionally, always if CLASS are involved for arrays with descriptor, 
it is not that trival: gfortran has "_data, _vptr" in the class 
container - and "_data" is the array descriptor. Hence, the offset from 
the beginning of the class container to _vptr varies depending on the 
size of the descriptor (i.e. its rank). However, with some copying 
that's handled by my patch (approved part).

Worsed it the CLASS->TYPE: If the actual type is not the declared type 
but one requires that the TYPE is packed ("contiguous" attribute), one 
needs to pack the actual argument. That's currently done via the 
scalarizer. (It is also done if the dummy is not contiguous as gfortran 
only has a stride and not a byte-wise stride multiplier.)


> As for the contiguous/non-contiguous matter, I propose using libgfortran's
> internal_{,un}pack and away with it.

Hmm, maybe. I have to check the code.


Another item I really want to have implemented, but it is outside the 
scope of the TS29113, but extremely handy internally is the following:

subroutine final_subroutine_wrapper (x)
   type(t) :: x
   if (rank(x) == 3) then
     call rank_3_finalizer (x)
   else
     call scalar_elemental_finalizer (x)
   end subroutine
end


Here, one has to walk "x" for the elemental subroutine. Though, it could 
be probably simpler than I feared: "x" does not have component or array 
references and it is a whole array. Thus, one can probably simple walk 
the array by running
    do i = 0, element_sizeof(x)-1
       call scalar_elemental_finalizer (x->data + i*elem_sizeof(x))
    end do

I have to think about issues with regards to contiguity and strides, but 
semantically, "x" is contiguous - the question is only whether it can be 
noncontiguous, e.g. when calling:
    call parent_final_wrapper (x%parent)
One could do it by packing a temporary - we probably have to do so as we 
do not have byte strides, otherwise, one could probably avoid it as only 
the first stride multiplier matters.

> Now about the implementation, I guess the devil is in the details.
> I'll see if there is something that I obviously forgot or something to
> do in gfc_conv_expr_descriptor.  Maybe that one (not the whole
> scalarizer) could use a fix.

I will try to generate a stripped down patch, which fixes the issues you 
raised and ignores the scalarizer. That will make it easier to look at 
the other parts as then the diff is more readable.

Thanks for your thoughts.

Tobias
Tobias Burnus - July 13, 2012, 7:50 a.m.
Hi Mikael, dear all,

On 07/05/2012 03:51 PM, Mikael Morin wrote:
> I think the  assumed-rank => rank == -1  convention should be 
> documented in gfortran.h, at least for the gfc_array_spec::rank field.

Okay. (Done in my version, which is not yet attached.)

>> @@ -2990,6 +3008,15 @@ gfc_procedure_use (gfc_symbol *sym, 
>> gfc_actual_arglist **ap, +      /* TS 29113, C407b.  */
>> +      if (a->expr && a->expr->expr_type == EXPR_VARIABLE
>> +          && symbol_rank (a->expr->symtree->n.sym) == -1)
>> +          gfc_error ("Assumed-rank argument requires an explicit 
>> interface "
>> +             "at %L", &a->expr->where);
> Doesn't this duplicates the other explicit interface diagnostic below...
>
>
>> @@ -2194,6 +2206,15 @@ resolve_global_procedure (gfc_symbol *sym, 
>> locus *where,
>> +        /* TS 29113, 6.2.  */
>> +        else if (arg->sym && arg->sym->as
>> +             && arg->sym->as->type == AS_ASSUMED_RANK)
>> +        gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
>> +               "argument '%s' must have an explicit interface",
>> +               sym->name, &sym->declared_at, arg->sym->name);


No, they are different. Example:

! resolve_global_procedure:
! From the global symbol information, one knows in "foo"
! that the dummy argument of "bar" is an assumed-rank array
!
! (the actual argument has no assumed rank)
!
! This check is weak as it only works if both procedures
! are in the same translation unit.
!----------------------
subroutine foo
   integer :: x
   call bar(x) ! <<< ERROR HERE
end subroutine foo

subroutine bar(y)
   integer :: y(..)
end subroutine bar

! gfc_procedure_use:
! The actual argument is assumed rank. Then the dummy argument
! has to be assumed-rank, which requires that the interface must
! be explicit.
!
! Hence, that's a constraint check which has and can be diagnosed
! at compile time. (C407b)
!---------------------
subroutine foobar(z)
   integer :: z(..)
   call sub(z) ! << ERROR here
end subroutine foobar
!---------------------


>> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
>>    /* TS 29113, 407b.  */
>> -  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
>> +  if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
>>      {
>>        gfc_error ("Invalid expression with assumed-type variable %s 
>> at %L",
>>           sym->name, &e->where);
>>        return FAILURE;
>>      }
>
> I'm not sure I understand the logic with the mixed assumed rank/type 
> flag. According to C407c, shouldn't we check that e is assumed rank/shape?

No, that check is not for assumed-rank arrays but for (e.g. scalar) 
assumed type, TYPE(*). The check handles cases like:

   type(*) :: x
   print *, ubound(array, dim=x)

where "x" is not allowed, contrary to, e.g.,

   type(*) :: x(:)
   print *, ubound(x)

Thus, one needs to keep track whether "x" is allowed or is not allowed 
in an expression. As that's the same for assumed type and for assumed 
rank, I am using the same tracking variable, called 
assumed_rank_type_expr_allowed. A better name would be: 
assumed_rank_or_assumed_type_expr_allowed  (or s/or/and/), however, I 
found my version clear enough and while it is already long, that variant 
would be even longer.

>>
>> +  /* TS 29113, C535b.  */
>> +  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))
>> +      && !assumed_rank_type_expr_allowed)
>> +    {
>> +      gfc_error ("Invalid expression with assumed-rank variable %s 
>> at %L",
>> +         sym->name, &e->where);
>
> The error message could be made more helpful. ;-)

Suggestions welcome. Example use would be:

x = x +1
call foo(x+1)
call sin(x)  ! Though that probably triggers elsewhere

I don't think the wording is that bad.

>> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
>>        return FAILURE;
>>      }
>>
>> +  /* TS 29113, C535b.  */
>> +  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))
>> +      && e->ref
>> +      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
>> +           && e->ref->next == NULL))
>> +    {
>> +      gfc_error ("Assumed-rank variable %s with designator at %L",
>> +                 sym->name, &e->ref->u.ar.where);
>
> Ditto here. And I think that C535b is more about the context of the 
> expression rather than the expression itself.

Here, I am lost. The check is that
   ubound(x(:))
   call bar (x(1))
   call bar2(x([1,3,5])
   call bar3(x(1:5:2))
or similar does not occur if "x" is assumed rank. That "(:)" is an 
(array) designator. Do you have a better suggestion? I could add the 
word "array" before "designator", but I would like to avoid to list all 
possible combinations.

 From TS29113:
"C407b An assumed-type variable name shall not appear in a designator or 
..."

 From Fortran 2008:

"1.3.59 designator
name followed by zero or more component selectors, complex part 
selectors, array section selectors, array element selectors, image 
selectors, and substring selectors (6.1)"

[I think due to the arrayness, the '(:)' has to be inserted if one wants 
to use component, complex part, or substring selectors, thus they should 
be properly covered.]



Unless you have better wordings, I will later send a slightly updated 
patch with some minor changes and the scalarizer part ripped off.

Tobias
Mikael Morin - July 14, 2012, 1:23 p.m.
Hello,

I somehow was reading this in the standard:
"An assumed-rank variable name shall not appear in a designator or
expression except as an actual
argument corresponding to a dummy argument that is assumed-rank..."

with "...except in..." instead of "...except as...".

Some of my comments were plain misunderstanding/misinterpretation on my
side.
The next comment iteration is below.

Mikael

On 13/07/2012 09:50, Tobias Burnus wrote:
>>> @@ -5067,13 +5097,26 @@ resolve_variable (gfc_expr *e)
>>>    /* TS 29113, 407b.  */
>>> -  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
>>> +  if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
>>>      {
>>>        gfc_error ("Invalid expression with assumed-type variable %s
>>> at %L",
>>>           sym->name, &e->where);
>>>        return FAILURE;
>>>      }
>>
>> I'm not sure I understand the logic with the mixed assumed rank/type
>> flag. According to C407c, shouldn't we check that e is assumed
>> rank/shape?
> 
> No, that check is not for assumed-rank arrays but for (e.g. scalar)
> assumed type, TYPE(*). The check handles cases like:
> 
>   type(*) :: x
>   print *, ubound(array, dim=x)
> 
> where "x" is not allowed, contrary to, e.g.,
> 
>   type(*) :: x(:)
>   print *, ubound(x)
> 
> Thus, one needs to keep track whether "x" is allowed or is not allowed
> in an expression. As that's the same for assumed type and for assumed
> rank, I am using the same tracking variable, called
> assumed_rank_type_expr_allowed. A better name would be:
> assumed_rank_or_assumed_type_expr_allowed  (or s/or/and/), however, I
> found my version clear enough and while it is already long, that variant
> would be even longer.

What about naming the flag in_actual_arg and moving the inquiry_argument
condition to the error condition?

> 
>>>
>>> +  /* TS 29113, C535b.  */
>>> +  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))
>>> +      && !assumed_rank_type_expr_allowed)
>>> +    {
>>> +      gfc_error ("Invalid expression with assumed-rank variable %s
>>> at %L",
>>> +         sym->name, &e->where);
>>
>> The error message could be made more helpful. ;-)
> 
> Suggestions welcome. Example use would be:
> 
> x = x +1
> call foo(x+1)
> call sin(x)  ! Though that probably triggers elsewhere
> 
> I don't think the wording is that bad.

Well, my problem with it is that it doesn't tell what is invalid.
What do you think about "Assumed rank variable %s at %L can only be used
as an actual argument." ?
I think that currently your foo(x+1) case doesn't trigger an error.
It's not in your testcases at least.

> 
>>> @@ -5084,6 +5127,22 @@ resolve_variable (gfc_expr *e)
>>>        return FAILURE;
>>>      }
>>>
>>> +  /* TS 29113, C535b.  */
>>> +  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))
>>> +      && e->ref
>>> +      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
>>> +           && e->ref->next == NULL))
>>> +    {
>>> +      gfc_error ("Assumed-rank variable %s with designator at %L",
>>> +                 sym->name, &e->ref->u.ar.where);
>>
>> Ditto here. And I think that C535b is more about the context of the
>> expression rather than the expression itself.
> 
> Here, I am lost. The check is that
>   ubound(x(:))
>   call bar (x(1))
>   call bar2(x([1,3,5])
>   call bar3(x(1:5:2))
> or similar does not occur if "x" is assumed rank. That "(:)" is an
> (array) designator. Do you have a better suggestion? I could add the
> word "array" before "designator", but I would like to avoid to list all
> possible combinations.

This one error is better as it tries to hint what's wrong. However, ...

> 
> From TS29113:
> "C407b An assumed-type variable name shall not appear in a designator or
> ..."
> 
> From Fortran 2008:
> 
> "1.3.59 designator
> name followed by zero or more component selectors, complex part
> selectors, array section selectors, array element selectors, image
> selectors, and substring selectors (6.1)"

... according to this, a bare variable name is also a designator, and it
is valid.  So issuing errors because the variable is/has a designator
seems confusing at best. I'm almost satisfied with this (maybe
s/with/in/ or s/be used with/???/) :
"Assumed-rank variable %s at %L cannot be used with a subobject reference."

Patch

2012-06-24  Tobias Burnus  <burnus@net-b.de>

	PR fortran/48820
	* array.c (match_array_element_spec, gfc_match_array_spec,
	spec_size, gfc_array_dimen_size): Add support for
	assumed-rank arrays.
	* check.c (dim_rank_check): Ditto.
	* decl.c (merge_array_spec): Ditto.
	* dump-parse-tree.c (show_array_spec): Ditto.
	* gfortran.h (array_type): Ditto.
	* interface.c (compare_type_rank, compare_parameter,
	argument_rank_mismatch, gfc_procedure_use): Ditto.
	* module.c (mio_typespec): Ditto.
	* resolve.c (resolve_formal_arglist, resolve_global_procedure,
	expression_shape, resolve_variable, resolve_symbol,
	resolve_fl_var_and_proc, resolve_actual_arglist,
	resolve_elemental_actual, update_ppc_arglist,
	check_typebound_baseobject, gfc_resolve_finalizers,
	resolve_typebound_procedure): Ditto.
	(assumed_rank_type_expr_allowed): Renamed static variable
	from assumed_type_expr_allowed.
	* simplify.c (simplify_bound, gfc_simplify_range): Ditto.
	* trans-array.c (gfc_conv_array_parameter): Ditto.
	* trans-decl. (gfc_build_dummy_array_decl,
	gfc_trans_deferred_vars, add_argument_checking): Ditto.
	* trans-expr.c (gfc_conv_expr_present, gfc_conv_variable,
	gfc_conv_procedure_call): Ditto.
	* trans-intrinsic.c (get_rank_from_desc): New function.
	(gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound,
	gfc_conv_associated): Use it.
	* trans-types.c (gfc_is_nodesc_array, gfc_is_nodesc_array,
	gfc_build_array_type, gfc_get_array_descriptor_base): Ditto.
	* trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and
	GFC_ARRAY_ASSUMED_RANK_CONT.

2012-06-24  Tobias Burnus  <burnus@net-b.de>

	PR fortran/48820
	* gfortran.dg/assumed_rank_1.f90: New.
	* gfortran.dg/assumed_rank_1_c.c: New.
	* gfortran.dg/assumed_rank_2.f90: New.
	* gfortran.dg/assumed_rank_3.f90: New.
	* gfortran.dg/assumed_rank_4.f90: New.
	* gfortran.dg/assumed_rank_5.f90: New.
	* gfortran.dg/assumed_rank_6.f90: New.


diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index b36d517..e986299 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -389,9 +389,11 @@  match_array_element_spec (gfc_array_spec *as)
 {
   gfc_expr **upper, **lower;
   match m;
+  int rank;
 
-  lower = &as->lower[as->rank + as->corank - 1];
-  upper = &as->upper[as->rank + as->corank - 1];
+  rank = as->rank == -1 ? 0 : as->rank;
+  lower = &as->lower[rank + as->corank - 1];
+  upper = &as->upper[rank + as->corank - 1];
 
   if (gfc_match_char ('*') == MATCH_YES)
     {
@@ -457,6 +459,20 @@  gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
       goto coarray;
     }
 
+  if (gfc_match (" .. )") == MATCH_YES)
+    {
+      as->type = AS_ASSUMED_RANK;
+      as->rank = -1;
+
+      if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed-rank array "
+			  "at %C") == FAILURE)
+	goto cleanup;
+
+      if (!match_codim)
+	goto done;
+      goto coarray;
+    }
+
   for (;;)
     {
       as->rank++;
@@ -535,6 +551,9 @@  gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
 
 	    gfc_error ("Bad specification for assumed size array at %C");
 	    goto cleanup;
+
+	  case AS_ASSUMED_RANK:
+	    gcc_unreachable (); 
 	  }
 
       if (gfc_match_char (')') == MATCH_YES)
@@ -641,6 +660,9 @@  coarray:
 	    case AS_ASSUMED_SIZE:
 	      gfc_error ("Bad specification for assumed size array at %C");
 	      goto cleanup;
+
+	    case AS_ASSUMED_RANK:
+	      gcc_unreachable (); 
 	  }
 
       if (gfc_match_char (']') == MATCH_YES)
@@ -1959,6 +1981,9 @@  spec_size (gfc_array_spec *as, mpz_t *result)
   mpz_t size;
   int d;
 
+  if (as->type == AS_ASSUMED_RANK)
+    return FAILURE;
+
   mpz_init_set_ui (*result, 1);
 
   for (d = 0; d < as->rank; d++)
@@ -2115,6 +2140,9 @@  gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
   if (array->ts.type == BT_CLASS)
     return FAILURE;
 
+  if (array->rank == -1)
+    return FAILURE;
+
   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
 
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 7d505d5..b0c4b28 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -619,6 +619,10 @@  dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
   else
     rank = array->rank;
 
+  /* Assumed-rank array.  */
+  if (rank == -1)
+    rank = GFC_MAX_DIMENSIONS;
+
   if (array->expr_type == EXPR_VARIABLE)
     {
       ar = gfc_find_array_ref (array);
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 26b5059..4c360bf 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -593,7 +593,7 @@  merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
 {
   int i;
 
-  if (to->rank == 0 && from->rank > 0)
+  if (to->rank == 0 && from->rank != 0)
     {
       to->rank = from->rank;
       to->type = from->type;
@@ -621,20 +621,24 @@  merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
     }
   else if (to->corank == 0 && from->corank > 0)
     {
+      int rank;
+
       to->corank = from->corank;
       to->cotype = from->cotype;
 
+      rank = to->rank == -1 ? 0 : to->rank;
+
       for (i = 0; i < from->corank; i++)
 	{
 	  if (copy)
 	    {
-	      to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
-	      to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
+	      to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
 	    }
 	  else
 	    {
-	      to->lower[to->rank + i] = from->lower[i];
-	      to->upper[to->rank + i] = from->upper[i];
+	      to->lower[rank + i] = from->lower[i];
+	      to->upper[rank + i] = from->upper[i];
 	    }
 	}
     }
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 7f1d28f..d94d9d3 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -165,7 +165,7 @@  show_array_spec (gfc_array_spec *as)
 
   fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
 
-  if (as->rank + as->corank > 0)
+  if (as->rank + as->corank > 0 || as->rank == -1)
     {
       switch (as->type)
       {
@@ -173,6 +173,7 @@  show_array_spec (gfc_array_spec *as)
 	case AS_DEFERRED:      c = "AS_DEFERRED";      break;
 	case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
 	case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
+	case AS_ASSUMED_RANK:  c = "AS_ASSUMED_RANK";  break;
 	default:
 	  gfc_internal_error ("show_array_spec(): Unhandled array shape "
 			      "type.");
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 0b38cac..29cfa5e 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4441,7 +4441,8 @@  gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
 	    || (!part_ref
 		&& !sym->attr.contiguous
 		&& (sym->attr.pointer
-		      || sym->as->type == AS_ASSUMED_SHAPE))))
+		    || sym->as->type == AS_ASSUMED_RANK
+		    || sym->as->type == AS_ASSUMED_SHAPE))))
     return false;
 
   if (!ar || ar->type == AR_FULL)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 43904e9..3ae1f1b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -132,7 +132,8 @@  expr_t;
 /* Array types.  */
 typedef enum
 { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED,
-  AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN
+  AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK,
+  AS_UNKNOWN
 }
 array_type;
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7a63f69..61163d8 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -511,7 +511,9 @@  compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
   r1 = (s1->as != NULL) ? s1->as->rank : 0;
   r2 = (s2->as != NULL) ? s2->as->rank : 0;
 
-  if (r1 != r2)
+  if (r1 != r2
+      && (!s1->as || s1->as->type != AS_ASSUMED_RANK)
+      && (!s2->as || s2->as->type != AS_ASSUMED_RANK))
     return 0;			/* Ranks differ.  */
 
   return gfc_compare_types (&s1->ts, &s2->ts)
@@ -1634,7 +1636,14 @@  static void
 argument_rank_mismatch (const char *name, locus *where,
 			int rank1, int rank2)
 {
-  if (rank1 == 0)
+
+  /* TS 29113, C407b.  */
+  if (rank2 == -1)
+    {
+      gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+		 " '%s' has assumed-rank", where, name);
+    }
+  else if (rank1 == 0)
     {
       gfc_error ("Rank mismatch in argument '%s' at %L "
 		 "(scalar and rank-%d)", name, where, rank2);
@@ -1859,7 +1868,16 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 		     " is modified",  &actual->where, formal->name);
     }
 
-  if (symbol_rank (formal) == actual->rank)
+  if (symbol_rank (formal) == -1 && actual->rank == 0)
+    {
+      gfc_error ("Sorry, passing the scalar at %L to the assumed-rank dummy "
+		 "argument '%s' is not yet supported", &actual->where,
+		 formal->name);
+      return 0;
+    }
+
+  /* If the rank is the same or the formal argument has assumed-rank.  */
+  if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
     return 1;
 
   if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
@@ -2990,6 +3008,15 @@  gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
 	      return;
 	    }
+
+	  /* TS 29113, C407b.  */
+	  if (a->expr && a->expr->expr_type == EXPR_VARIABLE
+	      && symbol_rank (a->expr->symtree->n.sym) == -1)
+	    {
+	      gfc_error ("Assumed-rank argument requires an explicit interface "
+			 "at %L", &a->expr->where);
+	      return;
+	    }
 	}
 
       return;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 60a74ca..87b903a 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2340,6 +2340,7 @@  mio_typespec (gfc_typespec *ts)
 
 static const mstring array_spec_types[] = {
     minit ("EXPLICIT", AS_EXPLICIT),
+    minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
     minit ("DEFERRED", AS_DEFERRED),
     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4595f76..33e3e4c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -63,7 +63,8 @@  static code_stack *cs_base = NULL;
 static int forall_flag;
 static int do_concurrent_flag;
 
-static bool assumed_type_expr_allowed = false;
+/* Nonzero for assumed rank and for assumed type.  */
+static bool assumed_rank_type_expr_allowed = false;
 
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
@@ -239,7 +240,7 @@  resolve_formal_arglist (gfc_symbol *proc)
 
   if (gfc_elemental (proc)
       || sym->attr.pointer || sym->attr.allocatable
-      || (sym->as && sym->as->rank > 0))
+      || (sym->as && sym->as->rank != 0))
     {
       proc->attr.always_explicit = 1;
       sym->attr.always_explicit = 1;
@@ -299,6 +300,7 @@  resolve_formal_arglist (gfc_symbol *proc)
 	}
 
       if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
+	  || (sym->as && sym->as->type == AS_ASSUMED_RANK)
 	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
 	  || sym->attr.optional)
 	{
@@ -1599,7 +1601,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_expr *e;
   int save_need_full_assumed_size;
 
-  assumed_type_expr_allowed = true;
+  assumed_rank_type_expr_allowed = true;
 
   for (; arg; arg = arg->next)
     {
@@ -1832,8 +1834,18 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		     "component", &e->where);
           return FAILURE;
         }
+
+      /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
+	 allowed for the first argument.
+	 Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
+	 FIXME: It doesn't work reliably as inquiry_argument is not set
+	 for all inquiry functions in resolve_function; the reason is that
+	 the function-name resolution happens too late in that function.  */
+      if (inquiry_argument)
+	assumed_rank_type_expr_allowed = false;
+
     }
-  assumed_type_expr_allowed = false;
+  assumed_rank_type_expr_allowed = false;
 
   return SUCCESS;
 }
@@ -1895,7 +1907,7 @@  resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
   /* The rank of an elemental is the rank of its array argument(s).  */
   for (arg = arg0; arg; arg = arg->next)
     {
-      if (arg->expr != NULL && arg->expr->rank > 0)
+      if (arg->expr != NULL && arg->expr->rank != 0)
 	{
 	  rank = arg->expr->rank;
 	  if (arg->expr->expr_type == EXPR_VARIABLE
@@ -2194,6 +2206,15 @@  resolve_global_procedure (gfc_symbol *sym, locus *where,
 			   sym->name, &sym->declared_at, arg->sym->name);
 		break;
 	      }
+	    /* TS 29113, 6.2.  */
+	    else if (arg->sym && arg->sym->as
+		     && arg->sym->as->type == AS_ASSUMED_RANK)
+	      {
+		gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
+			   "argument '%s' must have an explicit interface",
+			   sym->name, &sym->declared_at, arg->sym->name);
+		break;
+	      }
 	    /* F2008, 12.4.2.2 (2c)  */
 	    else if (arg->sym->attr.codimension)
 	      {
@@ -2219,6 +2240,15 @@  resolve_global_procedure (gfc_symbol *sym, locus *where,
 			   sym->name, &sym->declared_at, arg->sym->name);
 		break;
 	      }
+	    /* As assumed-type is unlimited polymorphic (cf. above).
+	       See also  TS 29113, Note 6.1.  */
+	    else if (arg->sym->ts.type == BT_ASSUMED)
+	      {
+		gfc_error ("Procedure '%s' at %L with assumed-type dummy "
+			   "argument '%s' must have an explicit interface",
+			   sym->name, &sym->declared_at, arg->sym->name);
+		break;
+	      }
 	}
 
       if (def_sym->attr.function)
@@ -4964,7 +4994,7 @@  expression_shape (gfc_expr *e)
   mpz_t array[GFC_MAX_DIMENSIONS];
   int i;
 
-  if (e->rank == 0 || e->shape != NULL)
+  if (e->rank <= 0 || e->shape != NULL)
     return;
 
   for (i = 0; i < e->rank; i++)
@@ -5067,13 +5097,26 @@  resolve_variable (gfc_expr *e)
   sym = e->symtree->n.sym;
 
   /* TS 29113, 407b.  */
-  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+  if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
     {
       gfc_error ("Invalid expression with assumed-type variable %s at %L",
 		 sym->name, &e->where);
       return FAILURE;
     }
 
+  /* TS 29113, C535b.  */
+  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))
+      && !assumed_rank_type_expr_allowed)
+    {
+      gfc_error ("Invalid expression with assumed-rank variable %s at %L",
+		 sym->name, &e->where);
+      return FAILURE;
+    }
+
   /* TS 29113, 407b.  */
   if (e->ts.type == BT_ASSUMED && e->ref
       && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
@@ -5084,6 +5127,22 @@  resolve_variable (gfc_expr *e)
       return FAILURE;
     }
 
+  /* TS 29113, C535b.  */
+  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))
+      && e->ref
+      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+           && e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-rank variable %s with designator at %L",
+                 sym->name, &e->ref->u.ar.where);
+      return FAILURE;
+    }
+
+
   /* If this is an associate-name, it may be parsed with an array reference
      in error even though the target is scalar.  Fail directly in this case.
      TODO Understand why class scalar expressions must be excluded.  */
@@ -5584,7 +5643,7 @@  update_ppc_arglist (gfc_expr* e)
     return FAILURE;
 
   /* F08:R739.  */
-  if (po->rank > 0)
+  if (po->rank != 0)
     {
       gfc_error ("Passed-object at %L must be scalar", &e->where);
       return FAILURE;
@@ -5632,7 +5691,7 @@  check_typebound_baseobject (gfc_expr* e)
 
   /* F08:C1230. If the procedure called is NOPASS,
      the base object must be scalar.  */
-  if (e->value.compcall.tbp->nopass && base->rank > 0)
+  if (e->value.compcall.tbp->nopass && base->rank != 0)
     {
       gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
 		 " be scalar", &e->where);
@@ -10319,10 +10378,10 @@  resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 
       if (allocatable)
 	{
-	  if (dimension)
+	  if (dimension && as->type != AS_ASSUMED_RANK)
 	    {
-	      gfc_error ("Allocatable array '%s' at %L must have "
-			 "a deferred shape", sym->name, &sym->declared_at);
+	      gfc_error ("Allocatable array '%s' at %L must have a deferred "
+			 "shape or assumed rank", sym->name, &sym->declared_at);
 	      return FAILURE;
 	    }
 	  else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L "
@@ -10331,10 +10390,10 @@  resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	    return FAILURE;
 	}
 
-      if (pointer && dimension)
+      if (pointer && dimension && as->type != AS_ASSUMED_RANK)
 	{
-	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
-		     sym->name, &sym->declared_at);
+	  gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
+		     "deferred rank", sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
     }
@@ -10948,7 +11007,7 @@  gfc_resolve_finalizers (gfc_symbol* derived)
 	}
 
       /* Warn if the procedure is non-scalar and not assumed shape.  */
-      if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+      if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0
 	  && arg->as->type != AS_ASSUMED_SHAPE)
 	gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
 		     " shape argument", &arg->declared_at);
@@ -11461,7 +11520,7 @@  resolve_typebound_procedure (gfc_symtree* stree)
 	}
   
       gcc_assert (me_arg->ts.type == BT_CLASS);
-      if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0)
+      if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0)
 	{
 	  gfc_error ("Passed-object dummy argument of '%s' at %L must be"
 		     " scalar", proc->name, &where);
@@ -12475,6 +12534,20 @@  resolve_symbol (gfc_symbol *sym)
 		       &sym->declared_at);
 	  return;
 	}
+      /* TS 29113, C535a.  */
+      if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy)
+	{
+	  gfc_error ("Assumed-rank array at %L must be a dummy argument",
+		     &sym->declared_at);
+	  return;
+	}
+      if (as->type == AS_ASSUMED_RANK
+	  && (sym->attr.codimension || sym->attr.value))
+	{
+	  gfc_error ("Assumed-rank array at %L may not have the VALUE or "
+		     "CODIMENSION attribute", &sym->declared_at);
+	  return;
+	}
     }
 
   /* Make sure symbols with known intent or optional are really dummy
@@ -12547,6 +12620,13 @@  resolve_symbol (gfc_symbol *sym)
 		     sym->name, &sym->declared_at);
 	  return;
 	}
+      if (sym->attr.intent == INTENT_OUT)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "INTENT(OUT) attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
       if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
 	{
 	  gfc_error ("Assumed-type variable %s at %L shall not be an "
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 1578db1..10f654d 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2934,7 +2934,6 @@  gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 }
 
 
-
 gfc_expr *
 gfc_simplify_is_iostat_end (gfc_expr *x)
 {
@@ -3380,7 +3379,8 @@  simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
  done:
 
-  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE))
+  if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE
+	     || as->type == AS_ASSUMED_RANK))
     return NULL;
 
   if (dim == NULL)
@@ -3442,13 +3442,16 @@  simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 
       d = mpz_get_si (dim->value.integer);
 
-      if (d < 1 || d > array->rank
+      if ((d < 1 || d > array->rank)
 	  || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
 	{
 	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
 	  return &gfc_bad_expr;
 	}
 
+      if (as && as->type == AS_ASSUMED_RANK)
+	return NULL;
+
       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
     }
 }
@@ -4779,6 +4782,10 @@  gfc_simplify_range (gfc_expr *e)
 gfc_expr *
 gfc_simplify_rank (gfc_expr *e)
 {
+  /* Assumed rank.  */
+  if (e->rank == -1)
+    return NULL;
+
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
 }
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index f135af1..6c58a8e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -311,6 +311,7 @@  gfc_conv_descriptor_stride_get (tree desc, tree dim)
   if (integer_zerop (dim)
       && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
 	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
 	  ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
     return gfc_index_one_node;
 
@@ -6906,9 +6907,10 @@  gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 	}
 
       if (!sym->attr.pointer
-	    && sym->as
-	    && sym->as->type != AS_ASSUMED_SHAPE 
-            && !sym->attr.allocatable)
+	  && sym->as
+	  && sym->as->type != AS_ASSUMED_SHAPE 
+	  && sym->as->type != AS_ASSUMED_RANK 
+	  && !sym->attr.allocatable)
         {
 	  /* Some variables are declared directly, others are declared as
 	     pointers and allocated on the heap.  */
@@ -6944,10 +6946,12 @@  gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
   no_pack = ((sym && sym->as
 		  && !sym->attr.pointer
 		  && sym->as->type != AS_DEFERRED
+		  && sym->as->type != AS_ASSUMED_RANK
 		  && sym->as->type != AS_ASSUMED_SHAPE)
 		      ||
 	     (ref && ref->u.ar.as
 		  && ref->u.ar.as->type != AS_DEFERRED
+		  && ref->u.ar.as->type != AS_ASSUMED_RANK
 		  && ref->u.ar.as->type != AS_ASSUMED_SHAPE)
 		      ||
 	     gfc_is_simply_contiguous (expr, false));
@@ -8319,12 +8323,15 @@  gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
 	  break;
 
 	case AR_FULL:
-	  newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
+	  newss = gfc_get_array_ss (ss, expr,
+				    ar->as->rank < 0 ? GFC_MAX_DIMENSIONS
+						     : ar->as->rank,
+				    GFC_SS_SECTION);
 	  newss->info->data.array.ref = ref;
 
 	  /* Make sure array is the same as array(:,:), this way
 	     we don't need to special case all the time.  */
-	  ar->dimen = ar->as->rank;
+	  ar->dimen = ar->as->rank < 0 ? GFC_MAX_DIMENSIONS : ar->as->rank;
 	  for (n = 0; n < ar->dimen; n++)
 	    {
 	      ar->dimen_type[n] = DIMEN_RANGE;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 75a2160..f1b7444 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -933,7 +933,8 @@  gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   int n;
   bool known_size;
 
-  if (sym->attr.pointer || sym->attr.allocatable)
+  if (sym->attr.pointer || sym->attr.allocatable
+      || (sym->as && sym->as->type == AS_ASSUMED_RANK))
     return dummy;
 
   /* Add to list of variables if not a fake result variable.  */
@@ -3669,6 +3670,7 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
 	      break;
 
+	    case AS_ASSUMED_RANK:
 	    case AS_DEFERRED:
 	      seen_trans_deferred_array = true;
 	      gfc_trans_deferred_array (sym, block);
@@ -4782,7 +4784,8 @@  add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
 	   dummy argument is an array. (See "Sequence association" in
 	   Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
 	if (fsym->attr.pointer || fsym->attr.allocatable
-	    || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+	    || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE
+			     || fsym->as->type == AS_ASSUMED_RANK)))
 	  {
 	    comparison = NE_EXPR;
 	    message = _("Actual string length does not match the declared one"
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..791b410 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -730,7 +730,8 @@  gfc_conv_expr_present (gfc_symbol * sym)
      as actual argument to denote absent dummies. For array descriptors,
      we thus also need to check the array descriptor.  */
   if (!sym->attr.pointer && !sym->attr.allocatable
-      && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+      && sym->as && (sym->as->type == AS_ASSUMED_SHAPE
+		     || sym->as->type == AS_ASSUMED_RANK)
       && (gfc_option.allow_std & GFC_STD_F2008) != 0)
     {
       tree tmp;
@@ -1325,7 +1326,8 @@  gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  /* Dereference non-character pointer variables. 
 	     These must be dummies, results, or scalars.  */
 	  if ((sym->attr.pointer || sym->attr.allocatable
-	       || gfc_is_associate_pointer (sym))
+	       || gfc_is_associate_pointer (sym)
+	       || (sym->as && sym->as->type == AS_ASSUMED_RANK))
 	      && (sym->attr.dummy
 		  || sym->attr.function
 		  || sym->attr.result
@@ -3769,7 +3771,8 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      bool f;
 	      f = (fsym != NULL)
 		  && !(fsym->attr.pointer || fsym->attr.allocatable)
-		  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE;
+		  && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE
+		  && fsym->as->type != AS_ASSUMED_RANK;
 	      if (comp)
 		f = f || !comp->attr.always_explicit;
 	      else
@@ -3878,12 +3881,13 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	     but do not always set fsym.  */
 	  if (e->expr_type == EXPR_VARIABLE
 	      && e->symtree->n.sym->attr.optional
-	      && ((e->rank > 0 && sym->attr.elemental)
+	      && ((e->rank != 0 && sym->attr.elemental)
 		  || e->representation.length || e->ts.type == BT_CHARACTER
-		  || (e->rank > 0
+		  || (e->rank != 0
 		      && (fsym == NULL 
 			  || (fsym-> as
 			      && (fsym->as->type == AS_ASSUMED_SHAPE
+				  || fsym->as->type == AS_ASSUMED_RANK
 			      	  || fsym->as->type == AS_DEFERRED))))))
 	    gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
 				    e->representation.length);
@@ -4129,7 +4133,9 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tmp = caf_decl;
 	    }
 
-          if (fsym->as->type == AS_ASSUMED_SHAPE)
+          if (fsym->as->type == AS_ASSUMED_SHAPE
+	      || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
+		  && !fsym->attr.allocatable))
 	    {
 	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
 	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c74e81a..db2a486 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1316,29 +1316,37 @@  trans_num_images (gfc_se * se)
 }
 
 
+static tree
+get_rank_from_desc (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+			 dtype, tmp);
+  return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
 static void
 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
 {
   gfc_se argse;
   gfc_ss *ss;
-  tree dtype, tmp;
 
   ss = gfc_walk_expr (expr->value.function.actual->expr);
   gcc_assert (ss != gfc_ss_terminator);
   gfc_init_se (&argse, NULL);
   argse.data_not_needed = 1;
-  argse.want_pointer = 1;
+  argse.descriptor_only = 1;
 
   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
-  argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
-  argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
-  dtype = gfc_conv_descriptor_dtype (argse.expr);
-  tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
-  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
-			 dtype, tmp);
-  se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+
+  se->expr = get_rank_from_desc (argse.expr);
 }
 
 
@@ -1360,6 +1368,7 @@  gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   gfc_se argse;
   gfc_ss *ss;
   gfc_array_spec * as;
+  bool assumed_rank_lb_one;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;
@@ -1401,27 +1410,40 @@  gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   desc = argse.expr;
 
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
+  /* FIXME: Why is this extra indirect_ref required?  */
+/*  if (as->type == AS_ASSUMED_RANK)
+    desc = build_fold_indirect_ref_loc (input_location, desc);*/
+
   if (INTEGER_CST_P (bound))
     {
       int hi, low;
 
       hi = TREE_INT_CST_HIGH (bound);
       low = TREE_INT_CST_LOW (bound);
-      if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+      if (hi || low < 0
+	  || ((!as || as->type != AS_ASSUMED_RANK)
+	      && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+	  || low > GFC_MAX_DIMENSIONS)
 	gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 		   "dimension index", upper ? "UBOUND" : "LBOUND",
 		   &expr->where);
     }
-  else
+
+  if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
     {
       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
         {
           bound = gfc_evaluate_now (bound, &se->pre);
           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
 				  bound, build_int_cst (TREE_TYPE (bound), 0));
-          tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+	  if (as && as->type == AS_ASSUMED_RANK)
+	    tmp = get_rank_from_desc (desc);
+	  else
+	    tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
-				 bound, tmp);
+				 bound, fold_convert(TREE_TYPE (bound), tmp));
           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
 				  boolean_type_node, cond, tmp);
           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@@ -1429,11 +1451,19 @@  gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
         }
     }
 
+  /* Take care of the lbound shift for assumed-rank arrays, which are
+     nonallocatable and nonpointers. Those has a lbound of 1.  */
+  assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
+			&& ((arg->expr->ts.type != BT_CLASS
+			     && !arg->expr->symtree->n.sym->attr.allocatable
+			     && !arg->expr->symtree->n.sym->attr.pointer)
+			    || (arg->expr->ts.type == BT_CLASS
+			     && !CLASS_DATA (arg->expr)->attr.allocatable
+			     && !CLASS_DATA (arg->expr)->attr.class_pointer));
+
   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
   
-  as = gfc_get_full_arrayspec_from_expr (arg->expr);
-
   /* 13.14.53: Result value for LBOUND
 
      Case (i): For an array section or for an array expression other than a
@@ -1455,7 +1485,9 @@  gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
                not have size zero and has value zero if dimension DIM has
                size zero.  */
 
-  if (as)
+  if (!upper && assumed_rank_lb_one)
+    se->expr = gfc_index_one_node;
+  else if (as)
     {
       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
 
@@ -1481,9 +1513,19 @@  gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
 				  boolean_type_node, cond, cond5);
 
+	  if (assumed_rank_lb_one)
+	    {
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, ubound, lbound);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			       gfc_array_index_type, tmp, gfc_index_one_node);
+	    }
+          else
+            tmp = ubound;
+
 	  se->expr = fold_build3_loc (input_location, COND_EXPR,
 				      gfc_array_index_type, cond,
-				      ubound, gfc_index_zero_node);
+				      tmp, gfc_index_zero_node);
 	}
       else
 	{
@@ -5856,8 +5898,15 @@  gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 	     present.  */
 	  arg1se.descriptor_only = 1;
 	  gfc_conv_expr_lhs (&arg1se, arg1->expr);
-	  tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
-					    gfc_rank_cst[arg1->expr->rank - 1]);
+	  if (arg1->expr->rank == -1)
+	    {
+	      tmp = get_rank_from_desc (arg1se.expr);
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     TREE_TYPE (tmp), tmp, gfc_index_one_node);
+	    }
+	  else
+	    tmp = gfc_rank_cst[arg1->expr->rank - 1];
+	  tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
 	  nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
 					      boolean_type_node, tmp,
 					      build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index aa50e3d..8b1caf8 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1277,7 +1277,8 @@  gfc_is_nodesc_array (gfc_symbol * sym)
     return 0;
 
   if (sym->attr.dummy)
-    return sym->as->type != AS_ASSUMED_SHAPE;
+    return sym->as->type != AS_ASSUMED_SHAPE
+	   && sym->as->type != AS_ASSUMED_RANK;
 
   if (sym->attr.result || sym->attr.function)
     return 0;
@@ -1299,6 +1300,13 @@  gfc_build_array_type (tree type, gfc_array_spec * as,
   tree ubound[GFC_MAX_DIMENSIONS];
   int n;
 
+  if (as->type == AS_ASSUMED_RANK)
+    for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+      {
+	lbound[n] = NULL_TREE;
+	ubound[n] = NULL_TREE;
+      }
+
   for (n = 0; n < as->rank; n++)
     {
       /* Create expressions for the known bounds of the array.  */
@@ -1323,7 +1331,12 @@  gfc_build_array_type (tree type, gfc_array_spec * as,
   if (as->type == AS_ASSUMED_SHAPE)
     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
 		       : GFC_ARRAY_ASSUMED_SHAPE;
-  return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+  else if (as->type == AS_ASSUMED_RANK)
+    akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+		       : GFC_ARRAY_ASSUMED_RANK;
+  return gfc_get_array_type_bounds (type, as->rank == -1
+					  ? GFC_MAX_DIMENSIONS : as->rank,
+				    as->corank, lbound,
 				    ubound, 0, akind, restricted);
 }
 
@@ -1682,7 +1695,13 @@  gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
 {
   tree fat_type, decl, arraytype, *chain = NULL;
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
-  int idx = 2 * (codimen + dimen - 1) + restricted;
+  int idx;
+
+  /* Assumed-rank array.  */
+  if (dimen == -1)
+    dimen = GFC_MAX_DIMENSIONS;
+
+  idx = 2 * (codimen + dimen - 1) + restricted;
 
   gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 3b77281..d4092f7 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -765,6 +765,8 @@  enum gfc_array_kind
   GFC_ARRAY_UNKNOWN,
   GFC_ARRAY_ASSUMED_SHAPE,
   GFC_ARRAY_ASSUMED_SHAPE_CONT,
+  GFC_ARRAY_ASSUMED_RANK,
+  GFC_ARRAY_ASSUMED_RANK_CONT,
   GFC_ARRAY_ALLOCATABLE,
   GFC_ARRAY_POINTER,
   GFC_ARRAY_POINTER_CONT
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1.f90	2012-06-24 15:17:36.000000000 +0200
@@ -0,0 +1,145 @@ 
+! { dg-do run }
+! { dg-additional-sources assumed_rank_1_c.c }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests
+!
+
+implicit none
+
+interface
+  subroutine check_value(b, n, val)
+    integer :: b(..)
+    integer, value :: n
+    integer :: val(n)
+  end subroutine
+end interface
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+  subroutine bar(a,b, prsnt)
+    integer, pointer, optional, intent(in) :: a(..),b(..)
+    logical, value :: prsnt
+    ! The following is not valid, but it goes past the constraint check
+    ! Technically, it could be allowed and might be in Fortran 2015:
+    if (.not. associated(a)) call abort()
+    if (present(b)) then
+      if (.not. associated(a,b)) call abort()
+    else
+      if (.not. associated(a)) call abort()
+    end if
+    if (.not. present(a)) call abort()
+    if (prsnt .neqv. present(b)) call abort()
+  end subroutine
+
+  ! POINTER argument - bounds as specified before
+  subroutine foo(a, rnk, low, high, val)
+    integer,pointer, intent(in) :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+    call check_value (a, rnk, val)
+    call foo2(a, rnk, low, high, val)
+  end subroutine
+
+  ! Non-pointer, non-allocatable bounds. lbound == 1
+  subroutine foo2(a, rnk, low, high, val)
+    integer, intent(in) :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (1 /= lbound(a,1)) call abort()
+      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (1 /= lbound(a,i)) call abort()
+      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+    call check_value (a, rnk, val)
+  end subroutine foo2
+
+  ! ALLOCATABLE argument - bounds as specified before
+  subroutine foo3 (a, rnk, low, high, val)
+    integer, allocatable, intent(in), target :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+    call check_value (a, rnk, val)
+    call foo(a, rnk, low, high, val)
+  end subroutine
+end
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_1_c.c	2012-06-24 12:58:44.000000000 +0200
@@ -0,0 +1,16 @@ 
+/* Called by assumed_rank_1.f90.  */
+
+#include <stdlib.h>  /* For abort().  */
+
+struct array {
+  int *data;
+};
+
+void check_value_ (struct array *b, int n, int val[])
+{
+  int i;
+
+  for (i = 0; i < n; i++)
+    if (b->data[i] != val[i])
+      abort ();
+}
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_2.f90	2012-06-24 15:17:39.000000000 +0200
@@ -0,0 +1,135 @@ 
+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! PR fortran/48820
+!
+! Assumed-rank tests - same as assumed_rank_1.f90,
+! but with bounds checks and w/o call to C function
+!
+
+implicit none
+
+integer, target :: x(2:5,4:7), y(-4:4)
+integer, allocatable, target :: z(:,:,:,:)
+integer, allocatable :: val(:)
+integer :: i
+
+allocate(z(1:4, -2:5, 4, 10:11))
+
+if (rank(x) /= 2) call abort ()
+val = [(2*i+3, i = 1, size(x))]
+x = reshape (val, shape(x))
+call foo(x, rank(x), lbound(x), ubound(x), val)
+call foo2(x, rank(x), lbound(x), ubound(x), val)
+call bar(x,x,.true.)
+call bar(x,prsnt=.false.)
+
+if (rank(y) /= 1) call abort ()
+val = [(2*i+7, i = 1, size(y))]
+y = reshape (val, shape(y))
+call foo(y, rank(y), lbound(y), ubound(y), val)
+call foo2(y, rank(y), lbound(y), ubound(y), val)
+call bar(y,y,.true.)
+call bar(y,prsnt=.false.)
+
+if (rank(z) /= 4) call abort ()
+val = [(2*i+5, i = 1, size(z))]
+z(:,:,:,:) = reshape (val, shape(z))
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo(z, rank(z), lbound(z), ubound(z), val)
+call foo2(z, rank(z), lbound(z), ubound(z), val)
+call bar(z,z,.true.)
+call bar(z,prsnt=.false.)
+
+contains
+  subroutine bar(a,b, prsnt)
+    integer, pointer, optional, intent(in) :: a(..),b(..)
+    logical, value :: prsnt
+    ! The following is not valid, but it goes past the constraint check
+    ! Technically, it could be allowed and might be in Fortran 2015:
+    if (.not. associated(a)) call abort()
+    if (present(b)) then
+      if (.not. associated(a,b)) call abort()
+    else
+      if (.not. associated(a)) call abort()
+    end if
+    if (.not. present(a)) call abort()
+    if (prsnt .neqv. present(b)) call abort()
+  end subroutine
+
+  ! POINTER argument - bounds as specified before
+  subroutine foo(a, rnk, low, high, val)
+    integer,pointer, intent(in) :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+    call foo2(a, rnk, low, high, val)
+  end subroutine
+
+  ! Non-pointer, non-allocatable bounds. lbound == 1
+  subroutine foo2(a, rnk, low, high, val)
+    integer, intent(in) :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (1 /= lbound(a,1)) call abort()
+      if (high(1)-low(1)+1 /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (1 /= lbound(a,i)) call abort()
+      if (high(i)-low(i)+1 /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+  end subroutine foo2
+
+  ! ALLOCATABLE argument - bounds as specified before
+  subroutine foo3 (a, rnk, low, high, val)
+    integer, allocatable, intent(in), target :: a(..)
+    integer, value :: rnk
+    integer, intent(in) :: low(:), high(:), val(:)
+    integer :: i
+
+    if (rank(a) /= rnk) call abort()
+    if (size(low) /= rnk .or. size(high) /= rnk) call abort()
+    if (size(a) /= product (high - low +1)) call abort()
+
+    if (rnk > 0) then
+      if (low(1) /= lbound(a,1)) call abort()
+      if (high(1) /= ubound(a,1)) call abort()
+      if (size (a,1) /= high(1)-low(1)+1) call abort()
+    end if
+
+    do i = 1, rnk
+      if (low(i) /= lbound(a,i)) call abort()
+      if (high(i) /= ubound(a,i)) call abort()
+      if (size (a,i) /= high(i)-low(i)+1) call abort()
+    end do
+    call foo(a, rnk, low, high, val)
+  end subroutine
+end
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_3.f90	2012-06-24 15:17:43.000000000 +0200
@@ -0,0 +1,19 @@ 
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+! { dg-shouldfail "Array reference out of bounds" }
+!
+! PR fortran/48820
+!
+! Do assumed-rank bound checking
+
+implicit none
+integer :: a(4,4)
+call bar(a)
+contains
+  subroutine bar(x)
+    integer :: x(..)
+    print *, ubound(x,dim=3)  ! << wrong dim
+  end subroutine
+end
+
+! { dg-output "Fortran runtime error: Array reference out of bounds" }
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_4.f90	2012-06-24 15:17:46.000000000 +0200
@@ -0,0 +1,49 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2008ts" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine valid1a(x)
+  integer, intent(in), pointer, contiguous :: x(..)
+end subroutine valid1a
+
+subroutine valid1(x)
+  integer, intent(in) :: x(..)
+end subroutine valid1
+
+subroutine valid2(x)
+ type(*) :: x
+end subroutine valid2
+
+subroutine foo99(x)
+  integer  x(99)
+  call valid1(x) ! { dg-error "Procedure 'valid1' at .1. with assumed-rank dummy argument 'x' must have an explicit interface" }
+  call valid2(x(1)) ! { dg-error "Procedure 'valid2' at .1. with assumed-type dummy argument 'x' must have an explicit interface" }
+end subroutine foo99
+
+subroutine foo(x)
+  integer :: x(..)
+  print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" }
+  call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" }
+  call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" }
+contains
+  subroutine intnl(x)
+    integer :: x(:)
+  end subroutine intnl
+end subroutine foo
+
+subroutine foo2(x)
+  integer :: x(..)
+  call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+  subroutine valid3(y)
+    integer :: y(..)
+  end subroutine
+end subroutine
+
+subroutine foo3()
+  integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" }
+end subroutine
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_5.f90	2012-06-24 15:17:51.000000000 +0200
@@ -0,0 +1,9 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+!
+subroutine foo(x)
+  integer :: x(..)  ! { dg-error "TS 29113: Assumed-rank array" }
+end subroutine foo
--- /dev/null	2012-06-24 07:57:13.619797600 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_6.f90	2012-06-24 15:17:57.000000000 +0200
@@ -0,0 +1,39 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Assumed-rank constraint checks and other diagnostics
+!
+
+subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" }
+  type(*), intent(out) :: x
+end subroutine
+
+subroutine bar(x)
+  integer, intent(out) :: x(..)
+end subroutine bar
+
+subroutine foo3(y)
+  integer :: y(..)
+  y = 7 ! { dg-error "Invalid expression with assumed-rank variable" }
+  print *, y + 10 ! { dg-error "Invalid expression with assumed-rank variable" }
+  print *, y ! { dg-error "Invalid expression with assumed-rank variable" }
+end subroutine
+
+subroutine foo2(x, y)
+  integer :: x(..), y(..)
+  call valid3(x(:)) ! { dg-error "Assumed-rank variable x with designator" }
+contains
+  subroutine valid3(y)
+    integer :: y(..)
+  end subroutine
+end subroutine
+
+subroutine foo4(x) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+  integer, codimension[*] :: x(..)
+end subroutine
+
+subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" }
+  integer :: y(..)[*]
+end subroutine