diff mbox series

[RFH] ME optimizes variable assignment away / Fortran bind(C) descriptor conversion

Message ID 0c0ee707-e66e-e6d7-4724-603a62a0957a@codesourcery.com
State New
Headers show
Series [RFH] ME optimizes variable assignment away / Fortran bind(C) descriptor conversion | expand

Commit Message

Tobias Burnus Aug. 27, 2021, 3:47 p.m. UTC 
Hi all,

Background: gfortran has its own array descriptor – and one which is defined in
F2018 and used/usable from C (#include <ISO_Fortran_binding.h>).
On mainline, the conversion is done via a void* pointer and calls to libgfortran,
which causes all kind of issues, including alias issues but also data type/bounds
issues etc.

The attached patch tries to do this inline - and defines in the FE a proper
type for the C descriptor.  ("CFI_cdesc_t" has a 'dim[]' as last member,
'CFI_cdesc_t01' has dim[1].)


But but I have a ME optimization issue, which removes an crucial
assignment - any help/suggestion is welcome!
(Additionally, there is room for improvement regarding the debugging
experience. Suggestions are welcome as well, but it is not as crucial.)


Do you have any suggestion or idea what goes wrong?


It looks really nice with "-O1 -fno-inline"   :-)
   The callee 'rank_p()' is mostly optimized and in the
   caller only those struct elements are set, which are used:

integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
{
   _1 = _this_11(D)->base_addr;
   _2 = _this_11(D)->rank;
...
   rnk_13 = (integer(kind=4)) _2;
   return rnk_13;
}

void selr_p ()
{
...
   struct CFI_cdesc_t01 cfi.7;
...
   <bb 2> [local count: 537730764]:
   cfi.7.rank = 1;
   cfi.7.base_addr = 0B;
   irnk_45 = rank_p (&cfi.7);
   cfi.7 ={v} {CLOBBER};
   if (irnk_45 != 1)


BUT BAD RESULT with -O2 -fno-inline  :-(
   The assignments on the caller side are gone,
   which causes wrong code (run stops with 'stop 1'):

integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
{
...
   <bb 2> [local count: 1073741824]:
   _1 = _this_3(D)->rank;
   rnk_4 = (integer(kind=4)) _1;
   return rnk_4;
}

void selr_p ()
{
...
   struct CFI_cdesc_t01 cfi.7;
...
   <bb 2> [local count: 537730764]:
   irnk_30 = rank_p (&cfi.7);   ! <<<< ERROR: cfi.7.rank assignment missing
   cfi.7 ={v} {CLOBBER};
   if (irnk_30 != 1)

  *  *  *

Any idea / suggestion?

  *  *  *

* trans-type.c defines the new type
* trans-decl.c handles the conversion from C descriptor to Fortran descriptor in the callee
* trans-expr.c handles the conversion to the C descriptor in the callee

Attached:
* Testcase 'test.f90'
   - original dump
   - -O1 -fno-inline optimized dump
   - -O2 -fno-inline optimized dump
* Full patch
   - Testcase is lightly modified gfortran.dg/PR93963.f90

Tobias

  *  *  *

PS: Current GCC (mainline w/o patch) generates the following.
[-> with patch, see a-test.f90.*.original.]

Namely, for the callee, casting the argument
   (in reality pointer to a CFI descriptor,
    but TREE_TYPE (PARM_DECL) is ptr to Fortran descriptor)
to 'void *', passing it to a library function, which creates
a new Fortran descriptor and pointer-assigning it to
the PARM_DECL pointer, which now points to a Fortran
descriptor:

integer(kind=4) rank_p (struct array15_integer(kind=4) & this)
{
    gfc_desc_ptr.1 = &gfc_desc.0;
    CFI_desc_ptr.2 = (void *) this;
    _gfortran_cfi_desc_to_gfc_desc (gfc_desc_ptr.1, &CFI_desc_ptr.2);
    this = (struct array15_integer(kind=4) &) gfc_desc_ptr.1;
    rnk = (integer(kind=4)) this->dtype.rank;
...
void selr_p ()
{
   struct array01_integer(kind=4) intp;
   integer(kind=4) irnk;
   static integer(kind=4) rnk = 1;

   intp.dtype = {.elem_len=4, .rank=1, .type=1};
   intp.span = 0;
...
     _gfortran_gfc_desc_to_cfi_desc (&cfi.3, &intp);
     intp.dtype.attribute = 0;
     irnk = rank_p (cfi.3);
     __builtin_free (cfi.3);

  *  *  *

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
__attribute__((fn spec (". . ")))
integer(kind=4) rank_p (struct array15_integer(kind=4) & this)
{
  struct array15_integer(kind=4) gfc_desc.0;
  struct array15_integer(kind=4) * gfc_desc_ptr.1;
  void * CFI_desc_ptr.2;
  integer(kind=4) rnk;

  if (this != 0)
    {
      gfc_desc_ptr.1 = &gfc_desc.0;
      CFI_desc_ptr.2 = (void *) this;
      _gfortran_cfi_desc_to_gfc_desc (gfc_desc_ptr.1, &CFI_desc_ptr.2);
      this = (struct array15_integer(kind=4) &) gfc_desc_ptr.1;
    }
  rnk = (integer(kind=4)) this->dtype.rank;
  return rnk;
}


__attribute__((fn spec (". ")))
void selr_p ()
{
  struct array01_integer(kind=4) intp;
  integer(kind=4) irnk;
  static integer(kind=4) rnk = 1;

  intp.dtype = {.elem_len=4, .rank=1, .type=1};
  intp.span = 0;
  intp.data = 0B;
  {
    void * cfi.3;

    if ((integer(kind=4)[0:] *) intp.data == 0B)
      {
        intp.dtype = {.elem_len=4, .rank=1, .type=1};
      }
    intp.span = (integer(kind=8)) intp.dtype.elem_len;
    intp.dtype.attribute = 0;
    cfi.3 = 0B;
    _gfortran_gfc_desc_to_cfi_desc (&cfi.3, &intp);
    intp.dtype.attribute = 0;
    irnk = rank_p (cfi.3);
    __builtin_free (cfi.3);
  }
  if (irnk != rnk)
    {
      _gfortran_stop_numeric (1, 0);
    }
  L.1:;
  if (irnk != 1)
    {
      _gfortran_stop_numeric (2, 0);
    }
  L.2:;
}


__attribute__((externally_visible))
integer(kind=4) main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.4[7] = {2116, 4095, 0, 1, 1, 0, 31};

  _gfortran_set_args (argc, argv);
  _gfortran_set_options (7, &options.4[0]);
  selr_p ();
  return 0;
}
;; Function rank_p (rank_p, funcdef_no=0, decl_uid=3946, cgraph_uid=1, symbol_order=0)

Removing basic block 6
Removing basic block 7
Removing basic block 8
Removing basic block 9
Removing basic block 10
__attribute__((fn spec (". . ")))
integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
{
  unsigned int ivtmp.17;
  integer(kind=4) rnk;
  void * _1;
  signed char _2;
  signed char _4;

  <bb 2> [local count: 168730857]:
  _1 = _this_11(D)->base_addr;
  _2 = _this_11(D)->rank;
  if (_1 != 0B)
    goto <bb 3>; [70.00%]
  else
    goto <bb 5>; [30.00%]

  <bb 3> [local count: 118111600]:
  if (_2 <= 0)
    goto <bb 5>; [11.00%]
  else
    goto <bb 4>; [89.00%]

  <bb 4> [local count: 955630226]:
  # ivtmp.17_9 = PHI <ivtmp.17_6(4), 0(3)>
  ivtmp.17_6 = ivtmp.17_9 + 1;
  _4 = (signed char) ivtmp.17_6;
  if (_2 <= _4)
    goto <bb 5>; [11.00%]
  else
    goto <bb 4>; [89.00%]

  <bb 5> [local count: 168730857]:
  rnk_13 = (integer(kind=4)) _2;
  return rnk_13;

}



;; Function selr_p (MAIN__, funcdef_no=1, decl_uid=3970, cgraph_uid=2, symbol_order=1) (executed once)

__attribute__((fn spec (". ")))
void selr_p ()
{
  struct CFI_cdesc_t01 cfi.2;
  integer(kind=4) irnk;

  <bb 2> [local count: 1073741824]:
  cfi.2.rank = 1;
  cfi.2.base_addr = 0B;
  irnk_6 = rank_p (&cfi.2);
  cfi.2 ={v} {CLOBBER};
  if (irnk_6 != 1)
    goto <bb 3>; [0.04%]
  else
    goto <bb 4>; [99.96%]

  <bb 3> [local count: 429496]:
  _gfortran_stop_numeric (1, 0);

  <bb 4> [local count: 1072883005]:
  return;

}



;; Function main (main, funcdef_no=2, decl_uid=4000, cgraph_uid=3, symbol_order=2) (executed once)

__attribute__((externally_visible))
integer(kind=4) main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.4[7] = {2116, 4095, 0, 1, 1, 0, 31};

  <bb 2> [local count: 1073741824]:
  _gfortran_set_args (argc_2(D), argv_3(D));
  _gfortran_set_options (7, &options.4[0]);
  selr_p ();
  return 0;

}
;; Function rank_p (rank_p, funcdef_no=0, decl_uid=3946, cgraph_uid=1, symbol_order=0)

__attribute__((fn spec (". . ")))
integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
{
  integer(kind=4) rnk;
  signed char _1;

  <bb 2> [local count: 1073741824]:
  _1 = _this_3(D)->rank;
  rnk_4 = (integer(kind=4)) _1;
  return rnk_4;

}



;; Function selr_p (MAIN__, funcdef_no=1, decl_uid=3970, cgraph_uid=2, symbol_order=1) (executed once)

__attribute__((fn spec (". ")))
void selr_p ()
{
  struct CFI_cdesc_t01 cfi.2;
  integer(kind=4) irnk;

  <bb 2> [local count: 1073741824]:
  irnk_3 = rank_p (&cfi.2);
  cfi.2 ={v} {CLOBBER};
  if (irnk_3 != 1)
    goto <bb 3>; [0.04%]
  else
    goto <bb 4>; [99.96%]

  <bb 3> [local count: 429496]:
  _gfortran_stop_numeric (1, 0);

  <bb 4> [local count: 1072883005]:
  return;

}



;; Function main (main, funcdef_no=2, decl_uid=4000, cgraph_uid=3, symbol_order=2) (executed once)

__attribute__((externally_visible))
integer(kind=4) main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.4[7] = {2116, 4095, 0, 1, 1, 0, 31};

  <bb 2> [local count: 1073741824]:
  _gfortran_set_args (argc_2(D), argv_3(D));
  _gfortran_set_options (7, &options.4[0]);
  selr_p ();
  return 0;

}

Comments

Tobias Burnus Aug. 27, 2021, 4:08 p.m. UTC | #1 
On 27.08.21 17:47, Tobias Burnus wrote at
https://gcc.gnu.org/pipermail/gcc-patches/2021-August/578271.html :

> PS: Current GCC (mainline w/o patch) generates the following.
> [-> with patch, see a-test.f90.*.original.]

I accidentally attached the original dump created by mainline GCC.

For the patched compiler, I did attach the optimized dumps. For
reference, this email now contains the original dump generated with my
patch applied.

Tobias

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
__attribute__((fn spec (". . ")))
integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
{
  struct array15_integer(kind=4) this.0;
  struct array15_integer(kind=4) * this;
  signed char idx.1;
  integer(kind=4) rnk;

  this = &this.0;
  this.0.dtype = {.elem_len=4, .type=1};
  this.0.data = _this->base_addr;
  this.0.dtype.rank = _this->rank;
  if (_this->base_addr != 0B)
    {
      this.0.span = _this->dim[0].sm % (integer(kind=8)) _this->elem_len != 0 ? _this->dim[0].sm : (integer(kind=8)) _this->elem_len;
      this.0.offset = 0;
      idx.1 = 0;
      L.1:;
      if (_this->rank <= idx.1) goto L.2;
      this.0.dim[idx.1].lbound = _this->dim[idx.1].lower_bound;
      this.0.dim[idx.1].ubound = _this->dim[idx.1].extent + (this.0.dim[idx.1].lbound + -1);
      this.0.dim[idx.1].stride = _this->dim[idx.1].sm / (integer(kind=8)) _this->elem_len;
      this.0.offset = this.0.offset - this.0.dim[idx.1].stride * this.0.dim[idx.1].lbound;
      idx.1 = idx.1 + 1;
      goto L.1;
      L.2:;
    }
  rnk = (integer(kind=4)) this->dtype.rank;
  return rnk;
}


__attribute__((fn spec (". ")))
void selr_p ()
{
  struct array01_integer(kind=4) intp;
  integer(kind=4) irnk;
  static integer(kind=4) rnk = 1;

  intp.dtype = {.elem_len=4, .rank=1, .type=1};
  intp.span = 0;
  intp.data = 0B;
  {
    struct CFI_cdesc_t01 cfi.2;
    signed char idx.3;

    cfi.2.version = 1;
    cfi.2.rank = 1;
    cfi.2.type = 1025;
    cfi.2.attribute = 0;
    cfi.2.base_addr = intp.data;
    cfi.2.elem_len = 4;
    if (cfi.2.base_addr != 0B)
      {
        idx.3 = 0;
        L.3:;
        if (idx.3 > 0) goto L.4;
        cfi.2.dim[idx.3].lower_bound = intp.dim[idx.3].lbound;
        cfi.2.dim[idx.3].extent = (intp.dim[idx.3].ubound - intp.dim[idx.3].lbound) + 1;
        cfi.2.dim[idx.3].sm = intp.dim[idx.3].stride * intp.span;
        idx.3 = idx.3 + 1;
        goto L.3;
        L.4:;
      }
    irnk = rank_p (&cfi.2);
  }
  if (irnk != rnk)
    {
      _gfortran_stop_numeric (1, 0);
    }
  L.5:;
  if (irnk != 1)
    {
      _gfortran_stop_numeric (2, 0);
    }
  L.6:;
}


__attribute__((externally_visible))
integer(kind=4) main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.4[7] = {2116, 4095, 0, 1, 1, 0, 31};

  _gfortran_set_args (argc, argv);
  _gfortran_set_options (7, &options.4[0]);
  selr_p ();
  return 0;
}
Richard Biener Aug. 27, 2021, 7:48 p.m. UTC | #2 
On August 27, 2021 5:47:58 PM GMT+02:00, Tobias Burnus <tobias@codesourcery.com> wrote:
>Hi all,
>
>Background: gfortran has its own array descriptor – and one which is defined in
>F2018 and used/usable from C (#include <ISO_Fortran_binding.h>).
>On mainline, the conversion is done via a void* pointer and calls to libgfortran,
>which causes all kind of issues, including alias issues but also data type/bounds
>issues etc.
>
>The attached patch tries to do this inline - and defines in the FE a proper
>type for the C descriptor.  ("CFI_cdesc_t" has a 'dim[]' as last member,
>'CFI_cdesc_t01' has dim[1].)
>
>
>But but I have a ME optimization issue, which removes an crucial
>assignment - any help/suggestion is welcome!
>(Additionally, there is room for improvement regarding the debugging
>experience. Suggestions are welcome as well, but it is not as crucial.)
>
>
>Do you have any suggestion or idea what goes wrong?
>
>
>It looks really nice with "-O1 -fno-inline"   :-)
>   The callee 'rank_p()' is mostly optimized and in the
>   caller only those struct elements are set, which are used:
>
>integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
>{
>   _1 = _this_11(D)->base_addr;
>   _2 = _this_11(D)->rank;
>...
>   rnk_13 = (integer(kind=4)) _2;
>   return rnk_13;
>}
>
>void selr_p ()
>{
>...
>   struct CFI_cdesc_t01 cfi.7;
>...
>   <bb 2> [local count: 537730764]:
>   cfi.7.rank = 1;
>   cfi.7.base_addr = 0B;

You need to do the accesses above using the generic 't' type as well, otherwise they are non-conflicting TBAA wise. 

>   irnk_45 = rank_p (&cfi.7);
>   cfi.7 ={v} {CLOBBER};
>   if (irnk_45 != 1)
>
>
>BUT BAD RESULT with -O2 -fno-inline  :-(
>   The assignments on the caller side are gone,
>   which causes wrong code (run stops with 'stop 1'):
>
>integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
>{
>...
>   <bb 2> [local count: 1073741824]:
>   _1 = _this_3(D)->rank;
>   rnk_4 = (integer(kind=4)) _1;
>   return rnk_4;
>}
>
>void selr_p ()
>{
>...
>   struct CFI_cdesc_t01 cfi.7;
>...
>   <bb 2> [local count: 537730764]:
>   irnk_30 = rank_p (&cfi.7);   ! <<<< ERROR: cfi.7.rank assignment missing
>   cfi.7 ={v} {CLOBBER};
>   if (irnk_30 != 1)
>
>  *  *  *
>
>Any idea / suggestion?
>
>  *  *  *
>
>* trans-type.c defines the new type
>* trans-decl.c handles the conversion from C descriptor to Fortran descriptor in the callee
>* trans-expr.c handles the conversion to the C descriptor in the callee
>
>Attached:
>* Testcase 'test.f90'
>   - original dump
>   - -O1 -fno-inline optimized dump
>   - -O2 -fno-inline optimized dump
>* Full patch
>   - Testcase is lightly modified gfortran.dg/PR93963.f90
>
>Tobias
>
>  *  *  *
>
>PS: Current GCC (mainline w/o patch) generates the following.
>[-> with patch, see a-test.f90.*.original.]
>
>Namely, for the callee, casting the argument
>   (in reality pointer to a CFI descriptor,
>    but TREE_TYPE (PARM_DECL) is ptr to Fortran descriptor)
>to 'void *', passing it to a library function, which creates
>a new Fortran descriptor and pointer-assigning it to
>the PARM_DECL pointer, which now points to a Fortran
>descriptor:
>
>integer(kind=4) rank_p (struct array15_integer(kind=4) & this)
>{
>    gfc_desc_ptr.1 = &gfc_desc.0;
>    CFI_desc_ptr.2 = (void *) this;
>    _gfortran_cfi_desc_to_gfc_desc (gfc_desc_ptr.1, &CFI_desc_ptr.2);
>    this = (struct array15_integer(kind=4) &) gfc_desc_ptr.1;
>    rnk = (integer(kind=4)) this->dtype.rank;
>...
>void selr_p ()
>{
>   struct array01_integer(kind=4) intp;
>   integer(kind=4) irnk;
>   static integer(kind=4) rnk = 1;
>
>   intp.dtype = {.elem_len=4, .rank=1, .type=1};
>   intp.span = 0;
>...
>     _gfortran_gfc_desc_to_cfi_desc (&cfi.3, &intp);
>     intp.dtype.attribute = 0;
>     irnk = rank_p (cfi.3);
>     __builtin_free (cfi.3);
>
>  *  *  *
>
>-----------------
>Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Tobias Burnus Aug. 29, 2021, 8:07 a.m. UTC | #3 
Hi all, hi Richard,

On 27.08.21 21:48, Richard Biener wrote:
>> It looks really nice with "-O1 -fno-inline"   :-)
>>    The callee 'rank_p()' is mostly optimized and in the
>>    caller only those struct elements are set, which are used:
>>
>> integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
>> {
>>    _1 = _this_11(D)->base_addr;
>>    _2 = _this_11(D)->rank;
>> ...
>>    rnk_13 = (integer(kind=4)) _2;
>>    return rnk_13;
>> }
>>
>> void selr_p ()
>> {
>> ...
>>    struct CFI_cdesc_t01 cfi.7;
>> ...
>>    <bb 2> [local count: 537730764]:
>>    cfi.7.rank = 1;
>>    cfi.7.base_addr = 0B;
> You need to do the accesses above using the generic 't' type as well, otherwise they are non-conflicting TBAA wise.

First, I wonder why the following works with C:

  struct gen_t { int n; int dim[]; }

  int f (struct gen_t *x) {
    if (x->n > 1) x->dim[0] = 5;
    return x->n;
  }

  void test() {
    struct { int n; int dim[2]; } y;
    y.n = 2;
    f ((struct gen_t*) &y);
  }

Or doesn't it? In any case, that's how it is suggested
and 'y.n' is not accessed using 'gen_t' – there is only
a cast in the function call. (Which is not sufficient
in the Fortran FE-code generated code – as tried)

  * * *

Otherwise, I can confirm that the following works.
Does this original dump now looks fine?

     struct CFI_cdesc_t01 cfi.2;
...
     ((struct CFI_cdesc_t *) &cfi.2)->version = 1;
     ((struct CFI_cdesc_t *) &cfi.2)->rank = 1;
     ((struct CFI_cdesc_t *) &cfi.2)->type = 1025;
     ((struct CFI_cdesc_t *) &cfi.2)->attribute = 0;
     ((struct CFI_cdesc_t *) &cfi.2)->base_addr = intp.data;
     ((struct CFI_cdesc_t *) &cfi.2)->elem_len = 4;
...
     irnk = rank_p ((struct CFI_cdesc_t *) &cfi.2);

Thanks,

Tobias

-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Richard Biener Aug. 30, 2021, 6:32 a.m. UTC | #4 
On Sun, Aug 29, 2021 at 10:07 AM Tobias Burnus <tobias@codesourcery.com> wrote:
>
> Hi all, hi Richard,
>
> On 27.08.21 21:48, Richard Biener wrote:
> >> It looks really nice with "-O1 -fno-inline"   :-)
> >>    The callee 'rank_p()' is mostly optimized and in the
> >>    caller only those struct elements are set, which are used:
> >>
> >> integer(kind=4) rank_p (struct CFI_cdesc_t & _this)
> >> {
> >>    _1 = _this_11(D)->base_addr;
> >>    _2 = _this_11(D)->rank;
> >> ...
> >>    rnk_13 = (integer(kind=4)) _2;
> >>    return rnk_13;
> >> }
> >>
> >> void selr_p ()
> >> {
> >> ...
> >>    struct CFI_cdesc_t01 cfi.7;
> >> ...
> >>    <bb 2> [local count: 537730764]:
> >>    cfi.7.rank = 1;
> >>    cfi.7.base_addr = 0B;
> > You need to do the accesses above using the generic 't' type as well, otherwise they are non-conflicting TBAA wise.
>
> First, I wonder why the following works with C:
>
>   struct gen_t { int n; int dim[]; }
>
>   int f (struct gen_t *x) {
>     if (x->n > 1) x->dim[0] = 5;
>     return x->n;
>   }
>
>   void test() {
>     struct { int n; int dim[2]; } y;
>     y.n = 2;
>     f ((struct gen_t*) &y);
>   }
>
> Or doesn't it?

It probably doesn't and suffers from the same issue as your
original fortran code.

>In any case, that's how it is suggested
> and 'y.n' is not accessed using 'gen_t' – there is only
> a cast in the function call. (Which is not sufficient
> in the Fortran FE-code generated code – as tried)
>
>   * * *
>
> Otherwise, I can confirm that the following works.
> Does this original dump now looks fine?
>
>      struct CFI_cdesc_t01 cfi.2;
> ...
>      ((struct CFI_cdesc_t *) &cfi.2)->version = 1;
>      ((struct CFI_cdesc_t *) &cfi.2)->rank = 1;
>      ((struct CFI_cdesc_t *) &cfi.2)->type = 1025;
>      ((struct CFI_cdesc_t *) &cfi.2)->attribute = 0;
>      ((struct CFI_cdesc_t *) &cfi.2)->base_addr = intp.data;
>      ((struct CFI_cdesc_t *) &cfi.2)->elem_len = 4;
> ...
>      irnk = rank_p ((struct CFI_cdesc_t *) &cfi.2);

Yes, that looks OK now.  The idea is you can use the complete
types for storage allocation but you _always_ have to use the
incomplete (with flexarray member) type for all accesses.

Richard.

> Thanks,
>
> Tobias
>
> -----------------
> Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
diff mbox series

Patch

 gcc/fortran/decl.c                                 |  23 -
 gcc/fortran/expr.c                                 |   8 +-
 gcc/fortran/gfortran.h                             |  31 +-
 gcc/fortran/interface.c                            |  15 +
 gcc/fortran/trans-array.c                          | 119 ++++
 gcc/fortran/trans-array.h                          |  13 +
 gcc/fortran/trans-decl.c                           | 624 ++++++++++++++++-----
 gcc/fortran/trans-expr.c                           | 572 ++++++++++++++-----
 gcc/fortran/trans-stmt.c                           |  44 +-
 gcc/fortran/trans-types.c                          | 105 +++-
 gcc/fortran/trans-types.h                          |   3 +-
 gcc/fortran/trans.c                                |  11 +-
 gcc/fortran/trans.h                                |   2 -
 .../gfortran.dg/ISO_Fortran_binding_4.f90          |  22 +-
 gcc/testsuite/gfortran.dg/PR93963.f90              |  94 +++-
 gcc/testsuite/gfortran.dg/assumed_type_12.f90      |  35 ++
 gcc/testsuite/gfortran.dg/bind-c-intent-out.f90    |   9 +-
 .../gfortran.dg/bind_c_array_params_2.f90          |  30 +-
 gcc/testsuite/gfortran.dg/bind_c_char_10.f90       |  25 +-
 libgfortran/runtime/ISO_Fortran_binding.c          |   4 +
 20 files changed, 1402 insertions(+), 387 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 05081c40f1e..ff098bf6fae 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1584,15 +1584,6 @@  gfc_verify_c_interop_param (gfc_symbol *sym)
 					    sym->name, &sym->declared_at,
 					    sym->ns->proc_name->name))
 		    retval = false;
-		  else if (!sym->attr.dimension)
-		    {
-		      /* FIXME: Use CFI array descriptor for scalars.  */
-		      gfc_error ("Sorry, deferred-length scalar character dummy "
-				 "argument %qs at %L of procedure %qs with "
-				 "BIND(C) not yet supported", sym->name,
-				 &sym->declared_at, sym->ns->proc_name->name);
-		      retval = false;
-		    }
 		}
 	      else if (sym->attr.value
 		       && (!cl || !cl->length
@@ -1614,20 +1605,6 @@  gfc_verify_c_interop_param (gfc_symbol *sym)
 				      "attribute", sym->name, &sym->declared_at,
 				      sym->ns->proc_name->name))
 		    retval = false;
-		  else if (!sym->attr.dimension
-			   || sym->as->type == AS_ASSUMED_SIZE
-			   || sym->as->type == AS_EXPLICIT)
-		    {
-		      /* FIXME: Valid - should use the CFI array descriptor, but
-			 not yet handled for scalars and assumed-/explicit-size
-			 arrays.  */
-		      gfc_error ("Sorry, character dummy argument %qs at %L "
-				 "with assumed length is not yet supported for "
-				 "procedure %qs with BIND(C) attribute",
-				 sym->name, &sym->declared_at,
-				 sym->ns->proc_name->name);
-		      retval = false;
-		    }
 		}
 	      else if (cl->length->expr_type != EXPR_CONSTANT)
 		{
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 35563a78697..0560f5b8c43 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1078,11 +1078,13 @@  is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
 
   if (sym && sym->attr.dummy
       && sym->ns->proc_name->attr.is_bind_c
-      && sym->attr.dimension
       && (sym->attr.pointer
 	  || sym->attr.allocatable
-	  || sym->as->type == AS_ASSUMED_SHAPE
-	  || sym->as->type == AS_ASSUMED_RANK))
+	  || (sym->attr.dimension
+	      && (sym->as->type == AS_ASSUMED_SHAPE
+		  || sym->as->type == AS_ASSUMED_RANK))
+	  || (sym->ts.type == BT_CHARACTER
+	      && (!sym->ts.u.cl || !sym->ts.u.cl->length))))
     return true;
 
 return false;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 48cdcdf6cb8..b6ac5d307b2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -48,7 +48,6 @@  not after.
    libgfortran/libgfortran_frontend.h  */
 #include "libgfortran.h"
 
-
 #include "intl.h"
 #include "splay-tree.h"
 
@@ -105,6 +104,36 @@  typedef struct
 }
 mstring;
 
+/* ISO_Fortran_binding.h
+   CAUTION: This has to be kept in sync with libgfortran.  */
+
+#define CFI_type_kind_shift 8
+#define CFI_type_from_type_kind(t, k) (t + (k << CFI_type_kind_shift))
+
+/* Constants, defined as macros. */
+#define CFI_VERSION 1
+#define CFI_MAX_RANK 15
+
+/* Attributes. */
+#define CFI_attribute_pointer 0
+#define CFI_attribute_allocatable 1
+#define CFI_attribute_other 2
+
+#define CFI_type_mask 0xFF
+#define CFI_type_kind_shift 8
+
+/* Intrinsic types. Their kind number defines their storage size. */
+#define CFI_type_Integer 1
+#define CFI_type_Logical 2
+#define CFI_type_Real 3
+#define CFI_type_Complex 4
+#define CFI_type_Character 5
+
+/* Types with no kind. */
+#define CFI_type_struct 6
+#define CFI_type_cptr 7
+#define CFI_type_cfunptr 8
+#define CFI_type_other -1
 
 
 /*************************** Enums *****************************/
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9e3e8aa9da9..d49f71d31f6 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2448,6 +2448,21 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       return false;
     }
 
+  /* F2018, C711.  */
+  if (actual->ts.type == BT_ASSUMED
+      && formal->attr.dimension
+      && formal->as->type == AS_ASSUMED_RANK
+      && (!actual->symtree->n.sym->attr.dimension
+	  || (actual->symtree->n.sym->as->type != AS_ASSUMED_RANK
+	      && actual->symtree->n.sym->as->type != AS_ASSUMED_SHAPE)))
+    {
+      if (where)
+	gfc_error ("Assumed-type actual argument at %L must be of assumed rank"
+		   " or assumed shape as dummy argument %qs has assumed rank",
+		   &actual->where, formal->name);
+      return false;
+    }
+
   /* F2008, 12.5.2.5; IR F08/0073.  */
   if (formal->ts.type == BT_CLASS && formal->attr.class_ok
       && actual->expr_type != EXPR_NULL
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0d013defdbb..543de55bdb2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -103,6 +103,111 @@  gfc_array_dataptr_type (tree desc)
   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
 }
 
+/* Build expressions to access members of the CFI descriptor.  */
+#define CFI_FIELD_BASE_ADDR 0
+#define CFI_FIELD_ELEM_LEN 1
+#define CFI_FIELD_VERSION 2
+#define CFI_FIELD_RANK 3
+#define CFI_FIELD_ATTRIBUTE 4
+#define CFI_FIELD_TYPE 5
+#define CFI_FIELD_DIM 6
+
+#define CFI_DIM_FIELD_LOWER_BOUND 0
+#define CFI_DIM_FIELD_EXTENT 1
+#define CFI_DIM_FIELD_SM 2
+
+static tree
+gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
+{
+  tree type = TREE_TYPE (desc);
+  gcc_assert (TREE_CODE (type) == RECORD_TYPE
+	      && TYPE_FIELDS (type)
+	      && (strcmp ("base_addr",
+			 IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
+		  == 0));
+  tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+  gcc_assert (field != NULL_TREE);
+
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  desc, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_desc_base_addr (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
+}
+
+tree
+gfc_get_cfi_desc_elem_len (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
+}
+
+tree
+gfc_get_cfi_desc_version (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
+}
+
+tree
+gfc_get_cfi_desc_rank (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
+}
+
+tree
+gfc_get_cfi_desc_type (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
+}
+
+tree
+gfc_get_cfi_desc_attribute (tree desc)
+{
+  return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
+}
+
+static tree
+gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
+{
+  tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
+  tmp = gfc_build_array_ref (tmp, idx, NULL);
+  tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
+  gcc_assert (field != NULL_TREE);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			  tmp, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_dim_lbound (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
+}
+
+tree
+gfc_get_cfi_dim_extent (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
+}
+
+tree
+gfc_get_cfi_dim_sm (tree desc, tree idx)
+{
+  return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
+}
+
+#undef CFI_FIELD_BASE_ADDR
+#undef CFI_FIELD_ELEM_LEN
+#undef CFI_FIELD_VERSION
+#undef CFI_FIELD_RANK
+#undef CFI_FIELD_ATTRIBUTE
+#undef CFI_FIELD_TYPE
+#undef CFI_FIELD_DIM
+
+#undef CFI_DIM_FIELD_LOWER_BOUND
+#undef CFI_DIM_FIELD_EXTENT
+#undef CFI_DIM_FIELD_SM
 
 /* Build expressions to access the members of an array descriptor.
    It's surprisingly easy to mess up here, so never access
@@ -288,6 +393,20 @@  gfc_conv_descriptor_attribute (tree desc)
 			  dtype, tmp, NULL_TREE);
 }
 
+tree
+gfc_conv_descriptor_type (tree desc)
+{
+  tree tmp;
+  tree dtype;
+
+  dtype = gfc_conv_descriptor_dtype (desc);
+  tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
+  gcc_assert (tmp!= NULL_TREE
+	      && TREE_TYPE (tmp) == signed_char_type_node);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			  dtype, tmp, NULL_TREE);
+}
+
 tree
 gfc_get_descriptor_dimension (tree desc)
 {
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e4d443d7118..f60ee7a377a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -173,6 +173,7 @@  tree gfc_conv_descriptor_dtype (tree);
 tree gfc_conv_descriptor_rank (tree);
 tree gfc_conv_descriptor_elem_len (tree);
 tree gfc_conv_descriptor_attribute (tree);
+tree gfc_conv_descriptor_type (tree);
 tree gfc_get_descriptor_dimension (tree);
 tree gfc_conv_descriptor_stride_get (tree, tree);
 tree gfc_conv_descriptor_lbound_get (tree, tree);
@@ -186,6 +187,18 @@  void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
 
+/* CFI descriptor.  */
+tree gfc_get_cfi_desc_base_addr (tree);
+tree gfc_get_cfi_desc_elem_len (tree);
+tree gfc_get_cfi_desc_version (tree);
+tree gfc_get_cfi_desc_rank (tree);
+tree gfc_get_cfi_desc_type (tree);
+tree gfc_get_cfi_desc_attribute (tree);
+tree gfc_get_cfi_dim_lbound (tree, tree);
+tree gfc_get_cfi_dim_extent (tree, tree);
+tree gfc_get_cfi_dim_sm (tree, tree);
+
+
 /* Shift lower bound of descriptor, updating ubound and offset.  */
 void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index bed61e2325d..84e601a7457 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -117,8 +117,6 @@  tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
-tree gfor_fndecl_cfi_to_gfc;
-tree gfor_fndecl_gfc_to_cfi;
 tree gfor_fndecl_associated;
 tree gfor_fndecl_system_clock4;
 tree gfor_fndecl_system_clock8;
@@ -1548,6 +1546,14 @@  gfc_get_symbol_decl (gfc_symbol * sym)
 	      || (sym->module && sym->attr.if_source != IFSRC_DECL
 		  && sym->backend_decl));
 
+  if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c
+      && is_CFI_desc (sym, NULL))
+    {
+      gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER
+					|| sym->ts.u.cl->backend_decl));
+      return sym->backend_decl;
+    }
+
   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
@@ -1595,9 +1601,6 @@  gfc_get_symbol_decl (gfc_symbol * sym)
       sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
     }
 
-  if (is_CFI_desc (sym, NULL))
-    gfc_defer_symbol_init (sym);
-
   fun_or_res = byref && (sym->attr.result
 			 || (sym->attr.function && sym->ts.deferred));
   if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
@@ -2755,9 +2758,19 @@  create_function_arglist (gfc_symbol * sym)
       if (f->sym->attr.volatile_)
 	type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
 
-      /* Build the argument declaration.  */
-      parm = build_decl (input_location,
-			 PARM_DECL, gfc_sym_identifier (f->sym), type);
+      /* Build the argument declaration. For C descriptors, we use a
+	 '_'-prefixed name as the decl inside the proc uses the
+	 sym->name. */
+      tree parm_name;
+      if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL))
+	{
+	  strcpy (&name[1], f->sym->name);
+	  name[0] = '_';
+	  parm_name = get_identifier (name);
+	}
+      else
+	parm_name = gfc_sym_identifier (f->sym);
+      parm = build_decl (input_location, PARM_DECL, parm_name, type);
 
       if (f->sym->attr.volatile_)
 	{
@@ -3834,19 +3847,6 @@  gfc_build_builtin_function_decls (void)
 	get_identifier (PREFIX("internal_unpack")), ". w R ",
 	void_type_node, 2, pvoid_type_node, pvoid_type_node);
 
-  /* These two builtins write into what the first argument points to and
-     read from what the second argument points to, but we can't use R
-     for that, because the directly pointed structure contains a pointer
-     which is copied into the descriptor pointed by the first argument,
-     effectively escaping that way.  See PR92123.  */
-  gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ". w . ",
-	void_type_node, 2, pvoid_type_node, ppvoid_type_node);
-
-  gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ". w . ",
-	void_type_node, 2, ppvoid_type_node, pvoid_type_node);
-
   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("associated")), ". R R ",
 	integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
@@ -4464,115 +4464,6 @@  gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
 }
 
 
-/* Convert CFI descriptor dummies into gfc types and back again.  */
-static void
-convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
-{
-  tree gfc_desc;
-  tree gfc_desc_ptr;
-  tree CFI_desc;
-  tree CFI_desc_ptr;
-  tree dummy_ptr;
-  tree tmp;
-  tree present;
-  tree incoming;
-  tree outgoing;
-  stmtblock_t outer_block;
-  stmtblock_t tmpblock;
-
-  /* dummy_ptr will be the pointer to the passed array descriptor,
-     while CFI_desc is the descriptor itself.  */
-  if (DECL_LANG_SPECIFIC (sym->backend_decl))
-    CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
-  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (sym->backend_decl))))
-    CFI_desc = sym->backend_decl;
-  else
-    CFI_desc = NULL;
-
-  dummy_ptr = CFI_desc;
-
-  if (CFI_desc)
-    {
-      CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
-
-      /* The compiler will have given CFI_desc the correct gfortran
-	 type. Use this new variable to store the converted
-	 descriptor.  */
-      gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
-      tmp = build_pointer_type (TREE_TYPE (gfc_desc));
-      gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
-      CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
-
-      /* Fix the condition for the presence of the argument.  */
-      gfc_init_block (&outer_block);
-      present = fold_build2_loc (input_location, NE_EXPR,
-				 logical_type_node, dummy_ptr,
-				 build_int_cst (TREE_TYPE (dummy_ptr), 0));
-
-      gfc_init_block (&tmpblock);
-      /* Pointer to the gfc descriptor.  */
-      gfc_add_modify (&tmpblock, gfc_desc_ptr,
-		      gfc_build_addr_expr (NULL, gfc_desc));
-      /* Store the pointer to the CFI descriptor.  */
-      gfc_add_modify (&tmpblock, CFI_desc_ptr,
-		      fold_convert (pvoid_type_node, dummy_ptr));
-      tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-      /* Convert the CFI descriptor.  */
-      incoming = build_call_expr_loc (input_location,
-			gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-      gfc_add_expr_to_block (&tmpblock, incoming);
-      /* Set the dummy pointer to point to the gfc_descriptor.  */
-      gfc_add_modify (&tmpblock, dummy_ptr,
-		      fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
-
-      /* The hidden string length is not passed to bind(C) procedures so set
-	 it from the descriptor element length.  */
-      if (sym->ts.type == BT_CHARACTER
-	  && sym->ts.u.cl->backend_decl
-	  && VAR_P (sym->ts.u.cl->backend_decl))
-	{
-	  tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
-	  tmp = gfc_conv_descriptor_elem_len (tmp);
-	  gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
-			  fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
-				        tmp));
-	}
-
-      /* Check that the argument is present before executing the above.  */
-      incoming = build3_v (COND_EXPR, present,
-			   gfc_finish_block (&tmpblock),
-			   build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&outer_block, incoming);
-      incoming = gfc_finish_block (&outer_block);
-
-      /* Convert the gfc descriptor back to the CFI type before going
-	 out of scope, if the CFI type was present at entry.  */
-      outgoing = NULL_TREE;
-      if ((sym->attr.pointer || sym->attr.allocatable)
-	  && !sym->attr.value
-	  && sym->attr.intent != INTENT_IN)
-	{
-	  gfc_init_block (&outer_block);
-	  gfc_init_block (&tmpblock);
-
-	  tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-	  outgoing = build_call_expr_loc (input_location,
-					  gfor_fndecl_gfc_to_cfi, 2,
-					  tmp, gfc_desc_ptr);
-	  gfc_add_expr_to_block (&tmpblock, outgoing);
-
-	  outgoing = build3_v (COND_EXPR, present,
-			       gfc_finish_block (&tmpblock),
-			       build_empty_stmt (input_location));
-	  gfc_add_expr_to_block (&outer_block, outgoing);
-	  outgoing = gfc_finish_block (&outer_block);
-	}
-
-      /* Add the lot to the procedure init and finally blocks.  */
-      gfc_add_init_cleanup (block, incoming, outgoing);
-    }
-}
-
 /* Get the result expression for a procedure.  */
 
 static tree
@@ -5149,13 +5040,6 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
 	gcc_unreachable ();
-
-      /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
-	 as ISO Fortran Interop descriptors. These have to be converted to
-	 gfortran descriptors and back again.  This has to be done here so that
-	 the conversion occurs at the start of the init block.  */
-      if (is_CFI_desc (sym, NULL))
-	convert_CFI_desc (block, sym);
     }
 
   gfc_init_block (&tmpblock);
@@ -6779,6 +6663,399 @@  finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
   return;
 }
 
+static void
+gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
+		     tree cfi_desc, tree gfc_desc, gfc_symbol *sym)
+{
+  stmtblock_t block;
+  gfc_init_block (&block);
+  tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
+  tree rank, label_loop, label_end, idx, etype, tmp, tmp2;
+
+  /* When allocatable + intent out, free the cfi descriptor.  */
+  if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tree call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+      gfc_add_modify (&block, tmp,
+		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+    }
+
+  if (!sym->attr.referenced)
+    goto done;
+
+  /* Set string length for len=* and len=:, otherwise, it is already set.  */
+  if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+    {
+      tmp = fold_convert (gfc_array_index_type,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      if (sym->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			       gfc_array_index_type, tmp,
+			       build_int_cst (gfc_charlen_type_node,
+					      sym->ts.kind));
+      gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp);
+    }
+  /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr. */
+  if (!sym->attr.dimension)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, gfc_desc,
+		      fold_convert (TREE_TYPE (gfc_desc), tmp));
+      goto done;
+    }
+
+   /* gfc->dtype = ... (from declaration, not from cfi).  */
+  etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
+  gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
+		  gfc_get_dtype_rank_type (sym->as->rank, etype));
+
+  /* gfc->data = cfi->base_addr. */
+  gfc_conv_descriptor_data_set (&block, gfc_desc,
+				gfc_get_cfi_desc_base_addr (cfi));
+
+  /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks.  */
+  if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+    {
+      char *msg;
+      tree tmp3;
+      msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
+		       "passed to dummy argument %s", CFI_VERSION, sym->name);
+      tmp2 = gfc_get_cfi_desc_version (cfi);
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+			     build_int_cst (TREE_TYPE (tmp2), CFI_VERSION));
+      gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp2);
+      free (msg);
+
+      msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI descriptor "
+		       "passed to dummy argument %s", CFI_MAX_RANK, sym->name);
+      tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi);
+      tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
+			     build_int_cst (TREE_TYPE (tmp), 0));
+      tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
+			      build_int_cst (TREE_TYPE (tmp2), CFI_MAX_RANK));
+      tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+			     tmp, tmp2);
+      gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp3);
+      free (msg);
+
+      tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi);
+      if (sym->attr.allocatable || sym->attr.pointer)
+	{
+	  int attr = (sym->attr.pointer ? CFI_attribute_pointer
+					: CFI_attribute_allocatable);
+	  msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI "
+			   "descriptor passed to %s dummy argument %s", attr,
+			   sym->attr.pointer ? "pointer" : "allocatable",
+			   sym->name);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 tmp, build_int_cst (TREE_TYPE (tmp), attr));
+	}
+      else
+	{
+	  int amin = MIN (CFI_attribute_pointer,
+			  MIN (CFI_attribute_allocatable, CFI_attribute_other));
+	  int amax = MAX (CFI_attribute_pointer,
+			  MAX (CFI_attribute_allocatable, CFI_attribute_other));
+	  msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
+			   "descriptor passed to nonallocatable, nonpointer "
+			   "dummy argument %s", amin, amax, sym->name);
+	  tmp2 = tmp;
+	  tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
+			     build_int_cst (TREE_TYPE (tmp), amin));
+	  tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
+			     build_int_cst (TREE_TYPE (tmp2), amax));
+	  tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				 boolean_type_node, tmp, tmp2);
+	  gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+				   msg, tmp3);
+	  free (msg);
+	  msg = xasprintf ("Invalid unallocatated/unassociated CFI "
+			   "descriptor passed to nonallocatable, nonpointer "
+			   "dummy argument %s", sym->name);
+	  tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi),
+	  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 tmp, null_pointer_node);
+	}
+      gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp3);
+      free (msg);
+
+      if (sym->ts.type != BT_ASSUMED)
+	{
+	  int type = CFI_type_other;
+	  if (sym->ts.f90_type == BT_VOID)
+	    {
+	      type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+		      ? CFI_type_cfunptr : CFI_type_cptr);
+	    }
+	  else
+	    switch (sym->ts.type)
+	      {
+		case BT_INTEGER:
+		case BT_LOGICAL:
+		case BT_REAL:
+		case BT_COMPLEX:
+		  type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
+		  break;
+		case BT_CHARACTER:
+		  type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
+		  break;
+		case BT_DERIVED:
+		  type = CFI_type_struct;
+		  break;
+		case BT_VOID:
+		  type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+			? CFI_type_cfunptr : CFI_type_cptr);
+		  break;
+		case BT_ASSUMED:
+		case BT_CLASS:
+		case BT_PROCEDURE:
+		case BT_HOLLERITH:
+		case BT_UNION:
+		case BT_BOZ:
+		case BT_UNKNOWN:
+		  gcc_unreachable ();
+	    }
+	  msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
+			   " passed to dummy argument %s", type, sym->name);
+	  tmp2 = tmp = gfc_get_cfi_desc_type (cfi);
+	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				 tmp, build_int_cst (TREE_TYPE (tmp), type));
+	  gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+			       msg, tmp2);
+	  free (msg);
+	}
+    }
+
+  /* Set gfc->dtype.rank, if assumed-rank.  */
+  if (sym->as->rank < 0)
+    {
+      rank = gfc_get_cfi_desc_rank (cfi);
+      gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
+    }
+  else
+    rank = build_int_cst (signed_char_type_node, sym->as->rank);
+
+  /* If cfi->data != NULL. */
+  stmtblock_t block2;
+  gfc_init_block (&block2);
+
+  /* gfc->dspan = ((cfi->dim[0].sm % cfi->elem_len)
+		   ? cfi->dim[0].sm : cfi->elem_len).  */
+  tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+  tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+			 gfc_array_index_type, tmp,
+			 fold_convert (gfc_array_index_type,
+				       gfc_get_cfi_desc_elem_len (cfi)));
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, gfc_index_zero_node);
+  tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+		    gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]),
+		    fold_convert (gfc_array_index_type,
+				  gfc_get_cfi_desc_elem_len (cfi)));
+  gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
+
+  /* Calculate offset + set lbound, ubound and stride.  */
+  gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
+  if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
+    for (int i = 0; i < sym->as->rank; ++i)
+      {
+	gfc_se se;
+	gfc_init_se (&se, NULL );
+	if (sym->as->lower[i])
+	  {
+	    gfc_conv_expr (&se, sym->as->lower[i]);
+	    tmp = se.expr;
+	  }
+	else
+	  tmp = gfc_index_one_node;
+	gfc_add_block_to_block (&block2, &se.pre);
+	gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
+					tmp);
+	gfc_add_block_to_block (&block2, &se.post);
+      }
+
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  label_loop = gfc_build_label_decl (NULL_TREE);
+  label_end = gfc_build_label_decl (NULL_TREE);
+  idx = gfc_create_var (TREE_TYPE (rank), "idx");
+  gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+  TREE_USED (label_loop) = 1;
+  tmp = build1_v (LABEL_EXPR, label_loop);
+  gfc_add_expr_to_block (&block2, tmp);
+  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx, rank);
+  tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block2, tmp);
+
+  /* Loop body.  */
+  /* gfc->dim[i].lbound = ... */
+  if (sym->attr.pointer || sym->attr.allocatable)
+    {
+      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+      gfc_conv_descriptor_lbound_set (&block2, gfc_desc, idx, tmp);
+    }
+  else if (sym->as->rank < 0)
+    gfc_conv_descriptor_lbound_set (&block2, gfc_desc, idx, gfc_index_one_node);
+
+  /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx),
+			     gfc_index_one_node);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  gfc_conv_descriptor_ubound_set (&block2, gfc_desc, idx, tmp);
+
+  /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+  tmp = gfc_get_cfi_dim_sm (cfi, idx);
+  tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+   gfc_conv_descriptor_stride_set (&block2, gfc_desc, idx, tmp);
+
+  /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc_desc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_offset_get (gfc_desc), tmp);
+  gfc_conv_descriptor_offset_set (&block2, gfc_desc, tmp);
+
+  /* End of loop body.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node, idx,
+			 build_int_cst (signed_char_type_node, 1));
+  gfc_add_modify (&block2, idx, tmp);
+  gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+  TREE_USED (label_end) = 1;
+  tmp = build1_v (LABEL_EXPR, label_end);
+  gfc_add_expr_to_block (&block2, tmp);
+
+  if (sym->attr.allocatable || sym->attr.pointer)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi),
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, null_pointer_node);
+      tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
+  else
+    gfc_add_block_to_block (&block, &block2);
+
+done:
+  /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'.  */
+  if (sym->attr.optional)
+    {
+      tree present = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node, cfi_desc,
+				      null_pointer_node);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     sym->backend_decl,
+			     fold_convert (TREE_TYPE (sym->backend_decl),
+					   null_pointer_node));
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp);
+      gfc_add_expr_to_block (init, tmp);
+    }
+  else
+    gfc_add_block_to_block (init, &block);
+
+  /* Nothing to do if either not referenced or pointer not changed.  */
+  if (!sym->attr.referenced
+      || ((!sym->attr.pointer && !sym->attr.allocatable)
+	  || sym->attr.intent == INTENT_IN))
+    return;
+
+  /* Update pointer + array data data on exit.  */
+  gfc_init_block (&block);
+  tmp = gfc_get_cfi_desc_base_addr (cfi);
+  tmp2 = (!sym->attr.dimension
+	       ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc));
+  gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+
+  /* Set string length for len=:, only.  */
+  if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+    {
+      tmp = sym->ts.u.cl->backend_decl;
+      if (sym->ts.kind != 1)
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       gfc_array_index_type,
+			       sym->ts.u.cl->backend_decl, tmp);
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+
+  if (!sym->attr.dimension)
+    goto done_finally;
+
+  gfc_init_block (&block2);
+
+  /* Loop: for (i = 0; i < rank; ++i).  */
+  label_loop = gfc_build_label_decl (NULL_TREE);
+  label_end = gfc_build_label_decl (NULL_TREE);
+  idx = gfc_create_var (TREE_TYPE (rank), "idx");
+  gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+  TREE_USED (label_loop) = 1;
+  tmp = build1_v (LABEL_EXPR, label_loop);
+  gfc_add_expr_to_block (&block2, tmp);
+  tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx, rank);
+  tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block2, tmp);
+
+  /* Loop body.  */
+  /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
+  gfc_add_modify (&block2, gfc_get_cfi_dim_lbound (cfi, idx),
+		  gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (gfc_desc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
+			 gfc_index_one_node);
+  gfc_add_modify (&block2, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc_desc, idx),
+			     gfc_conv_descriptor_span_get (gfc_desc));
+  gfc_add_modify (&block2, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+  /* End of loop body.  */
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node, idx,
+			 build_int_cst (signed_char_type_node, 1));
+  gfc_add_modify (&block2, idx, tmp);
+  gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+  TREE_USED (label_end) = 1;
+  tmp = build1_v (LABEL_EXPR, label_end);
+  gfc_add_expr_to_block (&block2, tmp);
+
+  /* if (gfc->data != NULL) { block2 }.  */
+  tmp = gfc_get_cfi_desc_base_addr (cfi),
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, null_pointer_node);
+  tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+done_finally:
+  /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'.  */
+  if (sym->attr.optional)
+    {
+      tree present = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node, cfi_desc,
+				      null_pointer_node);
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (finally, tmp);
+     }
+   else
+     gfc_add_block_to_block (finally, &block);
+}
 
 /* Generate code for a function.  */
 
@@ -6824,6 +7101,7 @@  gfc_generate_function_code (gfc_namespace * ns)
   trans_function_start (sym);
 
   gfc_init_block (&init);
+  gfc_init_block (&cleanup);
 
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
@@ -6847,6 +7125,76 @@  gfc_generate_function_code (gfc_namespace * ns)
 	|| ns->parent == NULL)
     parent_fake_result_decl = NULL_TREE;
 
+  /* For BIND(C):
+     - deallocate intent-out allocatable dummy arguments.
+     - Create GFC variable which will later be populated by convert_CFI_desc  */
+  if (sym->attr.is_bind_c)
+    for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym);
+	 formal; formal = formal->next)
+      {
+	gfc_symbol *fsym = formal->sym;
+	if (!is_CFI_desc (fsym, NULL))
+	  continue;
+	if (!fsym->attr.referenced)
+	  {
+	    gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl,
+				 NULL_TREE, fsym);
+	    continue;
+	  }
+
+// FIXME: CHECK THAT OPTIONAL IS HANDLED CORRECTLY IN trans-openmp.c
+// OR OTHERPLACES WITH USE LANG SPECIFIC AND/OR PARAM_DECL IN THE CHECK
+
+// FIXME: TESTING SHOWS THAT DEBUGGING DOES NOT WORK WELL
+// IMPROVE DEBUGGING EXPERIENCE!
+
+	/* Let's now create a local GFI descriptor. Afterwards:
+	   desc is the local descriptor,
+	   desc_p is a pointer to it
+	     and stored in sym->backend_decl
+	   GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
+	     -> PARM_DECL and before sym->backend_decl.
+	   For scalars, decl == decl_p is a pointer variable.  */
+	tree desc_p, desc;
+	location_t loc = gfc_get_location (&sym->declared_at);
+	if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length)
+	  fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type,
+							fsym->name);
+	else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl)
+	  {
+	    gfc_se se;
+	    gfc_init_se (&se, NULL );
+	    gfc_conv_expr (&se, fsym->ts.u.cl->length);
+	    gfc_add_block_to_block (&init, &se.pre);
+	    fsym->ts.u.cl->backend_decl = se.expr;
+	    gcc_assert(se.post.head == NULL_TREE);
+	  }
+	/* Nullify, otherwise gfc_sym_type will return the CFI type.  */
+	tree tmp = fsym->backend_decl;
+	fsym->backend_decl = NULL;
+	tree type = gfc_sym_type (fsym);
+	gcc_assert (POINTER_TYPE_P (type));
+	if (POINTER_TYPE_P (TREE_TYPE (type)))
+	  /* For instance, allocatable scalars.  */
+	  type = TREE_TYPE (type);
+	if (TREE_CODE (type) == REFERENCE_TYPE)
+	  /* FIXME: restrict qualifier? */
+	  type = build_pointer_type (TREE_TYPE (type));
+	desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type);
+	if (!fsym->attr.dimension)
+	  desc = desc_p;
+	else
+	  {
+	    desc = gfc_create_var (TREE_TYPE (type), fsym->name);
+	    gfc_add_modify (&init, desc_p, gfc_build_addr_expr (NULL, desc));
+	  }
+	//gfc_allocate_lang_decl (desc_p);
+	//GFC_DECL_SAVED_DESCRIPTOR (desc_p) = tmp;
+	pushdecl (desc_p);
+	fsym->backend_decl = desc_p;
+	gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
+      }
+
   gfc_generate_contained_functions (ns);
 
   has_coarray_vars = false;
@@ -7002,8 +7350,6 @@  gfc_generate_function_code (gfc_namespace * ns)
 	gfc_add_expr_to_block (&body, gfc_generate_return ());
     }
 
-  gfc_init_block (&cleanup);
-
   /* Reset recursion-check variable.  */
   if (recurcheckvar != NULL_TREE)
     {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c4291cce079..aaaf5a3a34c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2864,6 +2864,9 @@  tree
 gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
 			   bool is_classarray)
 {
+  if (is_CFI_desc (sym, NULL))
+    return build_fold_indirect_ref_loc (input_location, var);
+
   /* Characters are entirely different from other types, they are treated
      separately.  */
   if (sym->ts.type == BT_CHARACTER)
@@ -5481,168 +5484,452 @@  set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
 static void
 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 {
-  tree tmp;
-  tree cfi_desc_ptr;
-  tree gfc_desc_ptr;
-  tree type;
-  tree cond;
-  tree desc_attr;
-  int attribute;
-  int cfi_attribute;
-  symbol_attribute attr = gfc_expr_attr (e);
+  stmtblock_t block, block2;
+  tree cfi, gfc, gfc_strlen, tmp, tmp2;
+  tree present = NULL;
+  tree rank;
+  gfc_se se;
+
+  if (fsym->attr.optional
+      && e->expr_type == EXPR_VARIABLE
+      && e->symtree->n.sym->attr.optional)
+    present = gfc_conv_expr_present (e->symtree->n.sym);
 
-  /* If this is a full array or a scalar, the allocatable and pointer
-     attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
-  attribute = 2;
-  if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
+  // FIXME: If already a CFI descriptor, use it - unless bounds have to be modified.
+  // In particular, re-use type - especially for AT_ASSUMED
+
+  gfc_init_block (&block);
+
+  /* Convert original argument to a tree. */
+  gfc_init_se (&se, NULL);
+  if (e->rank == 0)
     {
-      if (attr.pointer)
-	attribute = 0;
-      else if (attr.allocatable)
-	attribute = 1;
+      gfc_conv_expr (&se, e);
+      gfc = se.expr;
+      if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = gfc_build_addr_expr (NULL_TREE, gfc);
     }
-
-  if (fsym->attr.pointer)
-    cfi_attribute = 0;
-  else if (fsym->attr.allocatable)
-    cfi_attribute = 1;
   else
-    cfi_attribute = 2;
-
-  if (e->rank != 0)
     {
-      parmse->force_no_tmp = 1;
+      se.force_no_tmp = 1;
       if (fsym->attr.contiguous
 	  && !gfc_is_simply_contiguous (e, false, true))
-	gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
+	gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
 				   fsym->attr.pointer);
       else
-	gfc_conv_expr_descriptor (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
-      bool is_artificial = (INDIRECT_REF_P (parmse->expr)
-			    ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
-			    : DECL_ARTIFICIAL (parmse->expr));
-
-      /* Unallocated allocatable arrays and unassociated pointer arrays
-	 need their dtype setting if they are argument associated with
-	 assumed rank dummies.  */
-      if (fsym && fsym->as
-	  && (gfc_expr_attr (e).pointer
-	      || gfc_expr_attr (e).allocatable))
-	set_dtype_for_unallocated (parmse, e);
-
-      /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
-	 the expression type is different from the descriptor type, then
-	 the offset must be found (eg. to a component ref or substring)
-	 and the dtype updated.  Assumed type entities are only allowed
-	 to be dummies in Fortran. They therefore lack the decl specific
-	 appendiges and so must be treated differently from other fortran
-	 entities passed to CFI descriptors in the interface decl.  */
-      type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
-					NULL_TREE;
-
-      if (type && is_artificial
-	  && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
-	{
-	  /* Obtain the offset to the data.  */
-	  gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
-				  gfc_index_zero_node, true, e);
-
-	  /* Update the dtype.  */
-	  gfc_add_modify (&parmse->pre,
-			  gfc_conv_descriptor_dtype (parmse->expr),
-			  gfc_get_dtype_rank_type (e->rank, type));
-	}
-      else if (type == NULL_TREE
-	       || (!is_subref_array (e) && !is_artificial))
-	{
-	  /* Make sure that the span is set for expressions where it
-	     might not have been done already.  */
-	  tmp = gfc_conv_descriptor_elem_len (parmse->expr);
-	  tmp = fold_convert (gfc_array_index_type, tmp);
-	  gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
-	}
+	gfc_conv_expr_descriptor (&se, e);
+      gfc = se.expr;
+      /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
+	 elem_len = sizeof(dt) and base_addr = dt(lb) instead.
+	 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
+	 While sm is fine as it uses span*stride and not elem_len.  */
+      if (POINTER_TYPE_P (TREE_TYPE (gfc)))
+	gfc = build_fold_indirect_ref_loc (input_location, gfc);
+      else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
+	 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
+    }
+  gfc_strlen = se.string_length;
+  gfc_add_block_to_block (&block, &se.pre);
+
+  /* Create array decriptor and set version, rank, attribute, type. */
+  cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
+					  ? GFC_MAX_DIMENSIONS : e->rank,
+					  false), "cfi");
+  tmp = gfc_get_cfi_desc_version (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
+  if (e->rank < 0)
+    rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
+  else
+    rank = build_int_cst (signed_char_type_node, e->rank);
+  tmp = gfc_get_cfi_desc_rank (cfi);
+  gfc_add_modify (&block, tmp, rank);
+  int itype = CFI_type_other;
+  if (e->ts.f90_type == BT_VOID)
+    itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+	     ? CFI_type_cfunptr : CFI_type_cptr);
+  else
+    switch (e->ts.type)
+      {
+	case BT_INTEGER:
+	case BT_LOGICAL:
+	case BT_REAL:
+	case BT_COMPLEX:
+	case BT_CHARACTER:
+	  itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
+	  break;
+	case BT_DERIVED:
+	  itype = CFI_type_struct;
+	  break;
+	case BT_VOID:
+	  itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+		   ? CFI_type_cfunptr : CFI_type_cptr);
+	  break;
+	case BT_ASSUMED:
+	  itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
+	  break;
+	case BT_CLASS:
+	case BT_PROCEDURE:
+	case BT_HOLLERITH:
+	case BT_UNION:
+	case BT_BOZ:
+	case BT_UNKNOWN:
+	  // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
+	  gcc_unreachable ();
+      }
+
+  tmp = gfc_get_cfi_desc_type (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), itype));
+
+  int attr = CFI_attribute_other;
+  if (fsym->attr.pointer)
+    attr = CFI_attribute_pointer;
+  else if (fsym->attr.allocatable)
+    attr = CFI_attribute_allocatable;
+  tmp = gfc_get_cfi_desc_attribute (cfi);
+  gfc_add_modify (&block, tmp,
+		  build_int_cst (TREE_TYPE (tmp), attr));
+
+  if (e->rank == 0)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
     }
   else
     {
-      gfc_conv_expr (parmse, e);
-
-      if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
-	parmse->expr = build_fold_indirect_ref_loc (input_location,
-						    parmse->expr);
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tmp2 = gfc_conv_descriptor_data_get (gfc);
+      gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+    }
 
-      parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
-						    parmse->expr, attr);
+  /* When allocatable + intent out, free the cfi descriptor.  */
+  if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      tree call = builtin_decl_explicit (BUILT_IN_FREE);
+      call = build_call_expr_loc (input_location, call, 1, tmp);
+      gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+      gfc_add_modify (&block, tmp,
+                      fold_convert (TREE_TYPE (tmp), null_pointer_node));
+      goto done;
     }
 
-  /* Set the CFI attribute field through a temporary value for the
-     gfc attribute.  */
-  desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  /* If not unallocated/unassociated. */
+  gfc_init_block (&block2);
 
-  /* Now pass the gfc_descriptor by reference.  */
-  parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+  if (e->ts.type == BT_CHARACTER)
+    {
+      gcc_assert (gfc_strlen);
+      tmp = gfc_strlen;
+      if (e->ts.kind != 1)
+        tmp = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_charlen_type_node, tmp,
+                               build_int_cst (gfc_charlen_type_node,
+                                              e->ts.kind));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+  else if (e->ts.type != BT_ASSUMED)
+    {
+      /* Length is known at compile time; use use 'block' for it.  */
+      tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
+  else
+    {
+      tmp = gfc_conv_descriptor_elem_len (gfc);
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+    }
 
-  /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
-     that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call.  */
-  gfc_desc_ptr = parmse->expr;
-  cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
-  gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
+  if (e->ts.type == BT_ASSUMED)
+    {
+      /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
+	 an CFI descriptor.  Use the type in the descritor as it provide
+	 mode information. (Quality of implementation feature.)  */
+      tree cond;
+      tree ctype = gfc_get_cfi_desc_type (cfi);
+      tree type = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_type (gfc));
+      tree kind = fold_convert (TREE_TYPE (ctype),
+				gfc_conv_descriptor_elem_len (gfc));
+      kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
+			      kind, build_int_cst (TREE_TYPE (type),
+						   CFI_type_kind_shift));
+
+      /* if (BT_VOID) CFI_type_cptr else CFI_type_other  */
+      /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_VOID));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_cptr));
+      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			      ctype,
+			      build_int_cst (TREE_TYPE (type), CFI_type_other));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_DERIVED) CFI_type_struct else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_DERIVED));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+			     build_int_cst (TREE_TYPE (type), CFI_type_struct));
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_CHARACTER) CFI_type_struct + kind=1 else  < tmp2 >  */
+      /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len/4.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp = build_int_cst (TREE_TYPE (type),
+			   CFI_type_from_type_kind (CFI_type_Character, 1));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_COMPLEX) CFI_type_Character + kind/2 else  < tmp2 >  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
+			     kind, build_int_cst (TREE_TYPE (type), 2));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
+			     build_int_cst (TREE_TYPE (type),
+					    CFI_type_Complex));
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else  <tmp2>  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_INTEGER));
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_LOGICAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+			      build_int_cst (TREE_TYPE (type), BT_REAL));
+      cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			      cond, tmp);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
+			     type, kind);
+      tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			     ctype, tmp);
+      tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+			      tmp, tmp2);
+      gfc_add_expr_to_block (&block2, tmp2);
+    }
 
-  /* Allocate the CFI descriptor itself and fill the fields.  */
-  tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
-  tmp = build_call_expr_loc (input_location,
-			     gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+  if (e->rank != 0)
+    {
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree label_loop = gfc_build_label_decl (NULL_TREE);
+      tree label_end = gfc_build_label_decl (NULL_TREE);
+      tree idx = gfc_create_var (signed_char_type_node, "idx");
+      gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+      TREE_USED (label_loop) = 1;
+      tmp = build1_v (LABEL_EXPR, label_loop);
+      gfc_add_expr_to_block (&block2, tmp);
+      tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx,
+			     rank);
+      tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block2, tmp);
 
-  /* Now set the gfc descriptor attribute.  */
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-			 void_type_node, desc_attr,
-			 build_int_cst (TREE_TYPE (desc_attr), attribute));
-  gfc_add_expr_to_block (&parmse->pre, tmp);
+      /* Loop body.  */
+      /* cfi->dim[i].lower_bound = (allocatable/pointer)
+				   ? gfc->dim[i].lbound : 0 */
+      if (fsym->attr.pointer || fsym->attr.allocatable)
+	tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
+      else
+	tmp = gfc_index_zero_node;
+      gfc_add_modify (&block2, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
+      /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_ubound_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      gfc_add_modify (&block2, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      /* d->dim[n].sm = gfc->dim[i].stride  * gfc->span); */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_span_get (gfc));
+      gfc_add_modify (&block2, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+      /* End of loop body.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node,
+			     idx, build_int_cst (signed_char_type_node, 1));
+      gfc_add_modify (&block2, idx, tmp);
+      gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+      TREE_USED (label_end) = 1;
+      tmp = build1_v (LABEL_EXPR, label_end);
+      gfc_add_expr_to_block (&block2, tmp);
 
-  /* The CFI descriptor is passed to the bind_C procedure.  */
-  parmse->expr = cfi_desc_ptr;
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->ref
+	  && e->ref->u.ar.type == AR_FULL
+	  && e->symtree->n.sym->attr.dummy
+	  && e->symtree->n.sym->as
+	  && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+	{
+	  tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
+	  gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+	}
+    }
 
-  /* Free the CFI descriptor.  */
-  tmp = gfc_call_free (cfi_desc_ptr);
-  gfc_prepend_expr_to_block (&parmse->post, tmp);
+// FIXME: Check that the bounds calculation is proper - for all kind of vars, including strided input etc.
 
-  /* Transfer values back to gfc descriptor.  */
-  if (cfi_attribute != 2  /* CFI_attribute_other.  */
-      && !fsym->attr.value
-      && fsym->attr.intent != INTENT_IN)
+  if (fsym->attr.allocatable || fsym->attr.pointer)
     {
-      tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
-      tmp = build_call_expr_loc (input_location,
-				 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-      gfc_prepend_expr_to_block (&parmse->post, tmp);
+      tmp = gfc_get_cfi_desc_base_addr (cfi),
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, null_pointer_node);
+      tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+   		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
     }
+  else
+    gfc_add_block_to_block (&block, &block2);
 
-  /* Deal with an optional dummy being passed to an optional formal arg
-     by finishing the pre and post blocks and making their execution
-     conditional on the dummy being present.  */
-  if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
-      && e->symtree->n.sym->attr.optional)
+
+done:
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, cfi);
+  if (present)
     {
-      cond = gfc_conv_expr_present (e->symtree->n.sym);
-      tmp = fold_build2 (MODIFY_EXPR, void_type_node,
-			 cfi_desc_ptr,
-			 build_int_cst (pvoid_type_node, 0));
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->pre), tmp);
+      parmse->expr = build3_loc (input_location, COND_EXPR,
+				 TREE_TYPE (parmse->expr),
+				 present, parmse->expr, null_pointer_node);
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+                      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->pre, tmp);
-      tmp = build3_v (COND_EXPR, cond,
-		      gfc_finish_block (&parmse->post),
+    }
+  else
+    gfc_add_block_to_block (&parmse->pre, &block);
+
+  gfc_init_block (&block);
+
+  if ((!fsym->attr.allocatable && !fsym->attr.pointer)
+      || fsym->attr.intent == INTENT_IN)
+    goto post_call;
+
+  gfc_init_block (&block2);
+  if (e->rank == 0)
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
+    }
+  else
+    {
+      tmp = gfc_get_cfi_desc_base_addr (cfi);
+      gfc_conv_descriptor_data_set (&block, gfc, tmp);
+
+      /* gfc->dspan = ((cfi->dim[0].sm % cfi->elem_len)
+		       ? cfi->dim[0].sm : cfi->elem_len).  */
+      tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+      tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     tmp, gfc_index_zero_node);
+      tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+			gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]),
+			fold_convert (gfc_array_index_type,
+				      gfc_get_cfi_desc_elem_len (cfi)));
+      gfc_conv_descriptor_span_set (&block2, gfc, tmp);
+
+      /* Calculate offset + set lbound, ubound and stride.  */
+      gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+      /* Loop: for (i = 0; i < rank; ++i).  */
+      tree label_loop = gfc_build_label_decl (NULL_TREE);
+      tree label_end = gfc_build_label_decl (NULL_TREE);
+      tree idx = gfc_create_var (signed_char_type_node, "idx");
+      gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+      TREE_USED (label_loop) = 1;
+      tmp = build1_v (LABEL_EXPR, label_loop);
+      gfc_add_expr_to_block (&block2, tmp);
+      tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx,
+			     rank);
+      tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
 		      build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block2, tmp);
+
+      /* Loop body.  */
+
+// FIXME: CHECK!
+      /* gfc->dim[i].lbound = ... */
+      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+      gfc_conv_descriptor_lbound_set (&block2, gfc, idx, tmp);
+
+      /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_lbound_get (gfc, idx),
+			     gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
+      gfc_conv_descriptor_ubound_set (&block2, gfc, idx, tmp);
+
+      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+      tmp = gfc_get_cfi_dim_sm (cfi, idx);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+      gfc_conv_descriptor_stride_set (&block2, gfc, idx, tmp);
+
+      /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_stride_get (gfc, idx),
+			     gfc_conv_descriptor_lbound_get (gfc, idx));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_conv_descriptor_offset_get (gfc), tmp);
+      gfc_conv_descriptor_offset_set (&block2, gfc, tmp);
+
+      /* End of loop body.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node,
+			     idx, build_int_cst (signed_char_type_node, 1));
+      gfc_add_modify (&block2, idx, tmp);
+      gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+      TREE_USED (label_end) = 1;
+      tmp = build1_v (LABEL_EXPR, label_end);
+      gfc_add_expr_to_block (&block2, tmp);
+    }
+
+  if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+    {
+      tmp = fold_convert (gfc_charlen_type_node,
+			  gfc_get_cfi_desc_elem_len (cfi));
+      if (e->ts.kind != 1)
+        tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+                               gfc_charlen_type_node, tmp,
+                               build_int_cst (gfc_charlen_type_node,
+                                              e->ts.kind));
+      gfc_add_modify (&block2, gfc_strlen, tmp);
+    }
+
+  tmp = gfc_get_cfi_desc_base_addr (cfi),
+  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			 tmp, null_pointer_node);
+  tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+		  build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&block, tmp);
+
+post_call:
+  gfc_add_block_to_block (&block, &se.post);
+  if (present && block.head)
+    {
+      tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+                      build_empty_stmt (input_location));
       gfc_add_expr_to_block (&parmse->post, tmp);
     }
+  else if (block.head)
+    gfc_add_block_to_block (&parmse->post, &block);
+
+
+// Update pointer 
+// If char -> update length
+// (e->ts.type != BT_CHARACTER || !e->ts.u.cl->length)))*
+// If array, update descriptor etc. -> else = done.
 }
 
 
@@ -5761,17 +6048,12 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       bool finalized = false;
-      bool assumed_length_string = false;
       tree derived_array = NULL_TREE;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
 
-      if (fsym && fsym->ts.type == BT_CHARACTER
-	  && (!fsym->ts.u.cl || !fsym->ts.u.cl->length))
-	assumed_length_string = true;
-
       /* If the procedure requires an explicit interface, the actual
 	 argument is passed according to the corresponding formal
 	 argument.  If the corresponding formal argument is a POINTER,
@@ -6002,9 +6284,7 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    parmse.expr = convert (type, tmp);
 		}
 
-	      else if (sym->attr.is_bind_c && e
-		       && (is_CFI_desc (fsym, NULL)
-			   || assumed_length_string))
+	      else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6214,7 +6494,8 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  if (fsym && fsym->attr.intent == INTENT_OUT
 		      && (fsym->attr.allocatable
 			  || (fsym->ts.type == BT_CLASS
-			      && CLASS_DATA (fsym)->attr.allocatable)))
+			      && CLASS_DATA (fsym)->attr.allocatable))
+		      && !is_CFI_desc (fsym, NULL))
 		    {
 		      stmtblock_t block;
 		      tree ptr;
@@ -6448,8 +6729,7 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    parmse.force_tmp = 1;
 		}
 
-	      if (sym->attr.is_bind_c && e
-		  && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+	      if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
 		/* Implement F2018, 18.3.6, list item (5), bullet point 2.  */
 		gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
 
@@ -6536,9 +6816,11 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		}
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
-		 allocated on entry, it must be deallocated.  */
+		 allocated on entry, it must be deallocated.
+		 CFI descriptors are handled elsewhere.  */
 	      if (fsym && fsym->attr.allocatable
-		  && fsym->attr.intent == INTENT_OUT)
+		  && fsym->attr.intent == INTENT_OUT
+		  && !is_CFI_desc (fsym, NULL))
 		{
 		  if (fsym->ts.type == BT_DERIVED
 		      && fsym->ts.u.derived->attr.alloc_comp)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 11df1863bad..466109e8af3 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3669,10 +3669,7 @@  gfc_trans_select_rank_cases (gfc_code * code)
   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;
@@ -3686,24 +3683,25 @@  gfc_trans_select_rank_cases (gfc_code * code)
   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);
+  symbol_attribute attr = gfc_expr_attr (code->expr1);
+  if (!attr.pointer || !attr.allocatable)
+    {
+      /* Special case for assumed-rank ('rank(*)', internally -1):
+	 rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1.  */
+      cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			      rank, build_int_cst (TREE_TYPE (rank), 0));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     fold_convert (gfc_array_index_type, rank),
+			     gfc_index_one_node);
+      tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			     tmp, build_int_cst (TREE_TYPE (tmp), -1));
+      cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+			      logical_type_node, cond, tmp);
+      tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank),
+			     cond, rank, build_int_cst (TREE_TYPE (rank), -1));
+      rank = gfc_evaluate_now (tmp, &block);
+    }
   TREE_USED (code->exit_label) = 0;
 
 repeat:
@@ -3747,8 +3745,8 @@  repeat:
       if (low != NULL_TREE)
 	{
 	  cond = fold_build2_loc (input_location, EQ_EXPR,
-				  TREE_TYPE (sexpr), sexpr,
-				  fold_convert (TREE_TYPE (sexpr), low));
+				  TREE_TYPE (rank), rank,
+				  fold_convert (TREE_TYPE (rank), low));
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 				 cond, tmp,
 				 build_empty_stmt (input_location));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 1c78a906397..d76d1bd8e54 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -77,6 +77,7 @@  static GTY(()) tree gfc_desc_dim_type;
 static GTY(()) tree gfc_max_array_element_size;
 static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
 static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
 
 /* Arrays for all integral and real kinds.  We'll fill this in at runtime
    after the target has a chance to process command-line options.  */
@@ -1575,8 +1576,9 @@  gfc_get_dtype_rank_type (int rank, tree etype)
 
   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
 			     GFC_DTYPE_RANK);
-  CONSTRUCTOR_APPEND_ELT (v, field,
-			  build_int_cst (TREE_TYPE (field), rank));
+  if (rank >= 0)
+    CONSTRUCTOR_APPEND_ELT (v, field,
+			    build_int_cst (TREE_TYPE (field), rank));
 
   field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
 			     GFC_DTYPE_TYPE);
@@ -2244,7 +2246,7 @@  gfc_nonrestricted_type (tree t)
    especially for character and array types.  */
 
 tree
-gfc_sym_type (gfc_symbol * sym)
+gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
 {
   tree type;
   int byref;
@@ -2299,7 +2301,11 @@  gfc_sym_type (gfc_symbol * sym)
   if (!restricted)
     type = gfc_nonrestricted_type (type);
 
-  if (sym->attr.dimension || sym->attr.codimension)
+  /* Dummy argument to a bind(C) procedure.  */
+  if (is_bind_c && is_CFI_desc (sym, NULL))
+    type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
+			     restricted);
+  else if (sym->attr.dimension || sym->attr.codimension)
     {
       if (gfc_is_nodesc_array (sym))
         {
@@ -3131,7 +3137,7 @@  gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
 	      type = build_pointer_type (type);
 	    }
 	  else
-	    type = gfc_sym_type (arg);
+	    type = gfc_sym_type (arg, sym->attr.is_bind_c);
 
 	  /* Parameter Passing Convention
 
@@ -3722,4 +3728,93 @@  gfc_get_caf_reference_type ()
   return reference_type;
 }
 
+static tree
+gfc_get_cfi_dim_type ()
+{
+  static tree CFI_dim_t = NULL;
+
+  if (CFI_dim_t)
+    return CFI_dim_t;
+
+  CFI_dim_t = make_node (RECORD_TYPE);
+  TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
+  TYPE_NAMELESS (CFI_dim_t) = 1;
+  tree field;
+  tree *chain = NULL;
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
+				     gfc_array_index_type, &chain);
+  suppress_warning (field);
+  gfc_finish_type (CFI_dim_t);
+  TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
+  return CFI_dim_t;
+}
+
+
+/* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
+   otherwise dim[dimen] is used.  */
+
+tree
+gfc_get_cfi_type (int dimen, bool restricted)
+{
+  gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
+
+  int idx = 2*(dimen + 1) + restricted;
+
+  if (gfc_cfi_descriptor_base[idx])
+    return gfc_cfi_descriptor_base[idx];
+
+  /* Build the type node.  */
+  tree CFI_cdesc_t = make_node (RECORD_TYPE);
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  if (dimen != -1)
+    sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
+  TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
+  TYPE_NAMELESS (CFI_cdesc_t) = 1;
+
+  tree field;
+  tree *chain = NULL;
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
+				     (restricted ? prvoid_type_node
+						 : ptr_type_node), &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
+				     size_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
+				     integer_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
+				     signed_char_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
+				     signed_char_type_node, &chain);
+  suppress_warning (field);
+  field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
+				     get_typenode_from_name (INT16_TYPE),
+				     &chain);
+  suppress_warning (field);
+
+  if (dimen != 0)
+    {
+      tree range = NULL_TREE;
+      if (dimen > 0)
+	range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+				  gfc_rank_cst[dimen - 1]);
+      tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
+      field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
+					 CFI_dim_t, &chain);
+      suppress_warning (field);
+    }
+
+  gfc_finish_type (CFI_cdesc_t);
+  gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
+  return CFI_cdesc_t;
+}
+
 #include "gt-fortran-trans-types.h"
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 3b45ce25666..f8bccec79f8 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -84,7 +84,8 @@  tree gfc_get_character_type (int, gfc_charlen *);
 tree gfc_get_character_type_len (int, tree);
 tree gfc_get_character_type_len_for_eltype (tree, tree);
 
-tree gfc_sym_type (gfc_symbol *);
+tree gfc_sym_type (gfc_symbol *, bool is_bind_c_arg = false);
+tree gfc_get_cfi_type (int dimen, bool restricted);
 tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
 int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
 
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index eb5682a7cda..22f267645e8 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -608,9 +608,9 @@  gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 
   if (once)
     {
-       tmpvar = gfc_create_var (logical_type_node, "print_warning");
+       tmpvar = gfc_create_var (boolean_type_node, "print_warning");
        TREE_STATIC (tmpvar) = 1;
-       DECL_INITIAL (tmpvar) = logical_true_node;
+       DECL_INITIAL (tmpvar) = boolean_true_node;
        gfc_add_expr_to_block (pblock, tmpvar);
     }
 
@@ -631,7 +631,7 @@  gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
   va_end (ap);
 
   if (once)
-    gfc_add_modify (&block, tmpvar, logical_false_node);
+    gfc_add_modify (&block, tmpvar, boolean_false_node);
 
   body = gfc_finish_block (&block);
 
@@ -643,9 +643,8 @@  gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
     {
       if (once)
 	cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
-				long_integer_type_node, tmpvar, cond);
-      else
-	cond = fold_convert (long_integer_type_node, cond);
+				boolean_type_node, tmpvar,
+				fold_convert (boolean_type_node, cond));
 
       tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
 			     cond, body,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 78578cfd732..897c5d60b2a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -855,8 +855,6 @@  extern GTY(()) tree gfor_fndecl_ctime;
 extern GTY(()) tree gfor_fndecl_fdate;
 extern GTY(()) tree gfor_fndecl_in_pack;
 extern GTY(()) tree gfor_fndecl_in_unpack;
-extern GTY(()) tree gfor_fndecl_cfi_to_gfc;
-extern GTY(()) tree gfor_fndecl_gfc_to_cfi;
 extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_system_clock4;
 extern GTY(()) tree gfor_fndecl_system_clock8;
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
index 7731d1a6c88..c596e47cfdd 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
@@ -19,23 +19,37 @@  contains
 
   subroutine substr(str) BIND(C)
     character(*) :: str(:)
-    if (str(2) .ne. "ghi") stop 2
+    if (str(1) .ne. "bcd") stop 2
+    if (str(2) .ne. "ghi") stop 3
     str = ['uvw','xyz']
   end subroutine
 
+  subroutine substr4(str4) BIND(C)
+    character(*, kind=4) :: str4(:)
+    print *, str4(1)
+    print *, str4(2)
+    if (str4(1) .ne. 4_"bcd") stop 4
+    if (str4(2) .ne. 4_"ghi") stop 5
+    str4 = [4_'uvw', 4_'xyz']
+  end subroutine
+
 end module
 
 program p
   use mod_ctg
   implicit none
   real :: x(6)
-  character(5) :: str(2) = ['abcde','fghij']
+  character(5)         :: str(2)  = ['abcde', 'fghij']
+  character(5, kind=4) :: str4(2) = [4_'abcde', 4_'fghij']
   integer :: i
 
   x = [ (real(i), i=1, size(x)) ]
   call ctg(x(2::2))
   if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3
 
-  call substr(str(:)(2:4))
-  if (any (str .ne. ['auvwe','fxyzj'])) stop 4
+  !call substr(str(:)(2:4))
+  !if (any (str .ne. ['auvwe','fxyzj'])) stop 4
+
+  call substr4(str4(:)(2:4))
+  if (any (str4 .ne. [4_'auvwe', 4_'fxyzj'])) stop 4
 end program
diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90
index 4e1b06fd525..e2174627242 100644
--- a/gcc/testsuite/gfortran.dg/PR93963.f90
+++ b/gcc/testsuite/gfortran.dg/PR93963.f90
@@ -3,6 +3,8 @@ 
 ! Test the fix for PR93963
 !
 
+module m
+contains
 function rank_p(this) result(rnk) bind(c)
   use, intrinsic :: iso_c_binding, only: c_int
 
@@ -11,6 +13,13 @@  function rank_p(this) result(rnk) bind(c)
   integer(kind=c_int), pointer, intent(in) :: this(..)
   integer(kind=c_int)                      :: rnk
 
+  if (.not. associated (this)) then
+    rnk = rank (this)
+    return
+  end if
+
+  ! Only valid when associated
+  ! As otherweise, only inquiry functions permitted.
   select rank(this)
   rank(0)
     rnk = 0
@@ -58,6 +67,13 @@  function rank_a(this) result(rnk) bind(c)
   integer(kind=c_int), allocatable, intent(in) :: this(..)
   integer(kind=c_int)                          :: rnk
 
+  if (.not. allocated (this)) then
+    rnk = rank (this)
+    return
+  end if
+
+  ! Only valid when allocated
+  ! As otherweise, only inquiry functions permitted.
   select rank(this)
   rank(0)
     rnk = 0
@@ -97,27 +113,60 @@  function rank_a(this) result(rnk) bind(c)
   return
 end function rank_a
 
-program selr_p
-
+function rank_o(this) result(rnk) bind(c)
   use, intrinsic :: iso_c_binding, only: c_int
 
   implicit none
+  
+  integer(kind=c_int), intent(in) :: this(..)
+  integer(kind=c_int)             :: rnk
 
-  interface
-    function rank_p(this) result(rnk) bind(c)
-      use, intrinsic :: iso_c_binding, only: c_int
-      integer(kind=c_int), pointer, intent(in) :: this(..)
-      integer(kind=c_int)                      :: rnk
-    end function rank_p
-  end interface
-
-  interface
-    function rank_a(this) result(rnk) bind(c)
-      use, intrinsic :: iso_c_binding, only: c_int
-      integer(kind=c_int), allocatable, intent(in) :: this(..)
-      integer(kind=c_int)                          :: rnk
-    end function rank_a
-  end interface
+  select rank(this)
+  rank(0)
+    rnk = 0
+  rank(1)
+    rnk = 1
+  rank(2)
+    rnk = 2
+  rank(3)
+    rnk = 3
+  rank(4)
+    rnk = 4
+  rank(5)
+    rnk = 5
+  rank(6)
+    rnk = 6
+  rank(7)
+    rnk = 7
+  rank(8)
+    rnk = 8
+  rank(9)
+    rnk = 9
+  rank(10)
+    rnk = 10
+  rank(11)
+    rnk = 11
+  rank(12)
+    rnk = 12
+  rank(13)
+    rnk = 13
+  rank(14)
+    rnk = 14
+  rank(15)
+    rnk = 15
+  rank default
+    rnk = -1000
+  end select
+  return
+end function rank_o
+
+end module m
+
+program selr_p
+  use m
+  use, intrinsic :: iso_c_binding, only: c_int
+
+  implicit none
 
   integer(kind=c_int), parameter :: siz = 7
   integer(kind=c_int), parameter :: rnk = 1
@@ -139,12 +188,19 @@  program selr_p
   irnk = rank_p(intp)
   if (irnk /= rnk)        stop 5
   if (irnk /= rank(intp)) stop 6
+  irnk = rank_o(intp)
+  if (irnk /= rnk)        stop 7
+  if (irnk /= rank(intp)) stop 8
   deallocate(intp)
   nullify(intp)
   !
   allocate(inta(siz))
-  if (irnk /= rnk)        stop 7
-  if (irnk /= rank(inta)) stop 8
+  irnk = rank_a(inta)
+  if (irnk /= rnk)        stop 9
+  if (irnk /= rank(inta)) stop 10
+  irnk = rank_o(inta)
+  if (irnk /= rnk)        stop 11
+  if (irnk /= rank(inta)) stop 12
   deallocate(inta)
 
 end program selr_p
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_12.f90 b/gcc/testsuite/gfortran.dg/assumed_type_12.f90
new file mode 100644
index 00000000000..852fd41445d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_12.f90
@@ -0,0 +1,35 @@ 
+! PR fortran/102086
+
+implicit none (type, external)
+contains
+subroutine as(a)
+  type(*) :: a(:,:)
+end
+subroutine ar(b)
+  type(*) :: b(..)
+end
+subroutine bar(x,y)
+  type(*) :: x
+  type(*) :: y(3,*)
+  call as(x)  ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and scalar\\)" }
+  call ar(x)  ! { dg-error "Assumed-type actual argument at .1. must be of assumed rank or assumed shape as dummy argument 'b' has assumed rank" }
+  call as(y)  ! { dg-error "Actual argument for 'a' cannot be an assumed-size array" }
+  call ar(y)  ! { dg-error "Assumed-type actual argument at .1. must be of assumed rank or assumed shape as dummy argument 'b' has assumed rank" }
+  call as(y(1,3))  ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+  call ar(y(1,3))  ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+  call as(y(1:1,3:3))  ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+  call ar(y(1:1,3:3))  ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+end
+
+subroutine okayish(x,y,z)
+  type(*) :: x(:)
+  type(*) :: y(:,:)
+  type(*) :: z(..)
+  call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and rank-1\\)" }
+  call as(y) 
+  call as(z) ! { dg-error "The assumed-rank array at .1. requires that the dummy argument 'a' has assumed-rank" }
+  call ar(x)
+  call ar(y)
+  call ar(z)
+end
+end
diff --git a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
index 39822c0753a..b159ba808fc 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
+++ b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
@@ -32,11 +32,14 @@  program p
 end program p
 
 ! "cfi" only appears in context of "a" -> bind-C descriptor
-! the intent(out) implies freeing in the callee (!), hence the "free"
+! the intent(out) implies freeing in the callee (!) (when implemented in Fortran), hence the "free"
+! and also in the caller (when implemented in Fortran)
 ! It is the only 'free' as 'a' is part of the main program and, hence, implicitly has the SAVE attribute.
 ! The  'cfi = 0' appears before the call due to the deallocate and when preparing the C descriptor
 ! As cfi (i.e. the descriptor itself) is allocated in libgomp, it has to be freed after the call.
 
 ! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\);" 2 "original" } }
-! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+ = 0B;" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(_x->base_addr\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_x->base_addr = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\.base_addr\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+\\.base_addr = 0B;" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
index ede6eff67fa..688fb972527 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
@@ -22,4 +22,32 @@  end
 ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
 ! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } }
 ! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } }
-! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } }
+
+
+! { dg-final { scan-tree-dump "parm...span = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].lbound = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].ubound = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].stride = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...data = \\(void \\*\\) &aa\\\[0\\\];" "original" } }
+! { dg-final { scan-tree-dump "parm...offset = -5;" "original" } }
+! { dg-final { scan-tree-dump "cfi...version = 1;" "original" } }
+! { dg-final { scan-tree-dump "cfi...rank = 2;" "original" } }
+! { dg-final { scan-tree-dump "cfi...type = 1025;" "original" } }
+! { dg-final { scan-tree-dump "cfi...attribute = 2;" "original" } }
+! { dg-final { scan-tree-dump "cfi...base_addr = parm.0.data;" "original" } }
+! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } }
+! { dg-final { scan-tree-dump "idx.2 = 0;" "original" } }
+
+! { dg-final { scan-tree-dump "if \\(idx.. > 1\\) goto L..;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].lower_bound = 0;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].extent = \\(parm...dim\\\[idx..\\\].ubound - parm...dim\\\[idx..\\\].lbound\\) \\+ 1;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].sm = parm...dim\\\[idx..\\\].stride \\* parm...span;" "original" } }
+! { dg-final { scan-tree-dump "idx.. = idx.. \\+ 1;" "original" } }
+
+! { dg-final { scan-tree-dump "test \\(&cfi..\\);" "original" } }
+
+
diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
index 35958515d38..7c6f4dcc961 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
@@ -466,15 +466,16 @@  program main
 end
 
 ! All arguments shall use array descriptors
-! { dg-final { scan-tree-dump-times "void as1 \\(struct array01_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as2 \\(struct array01_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as4 \\(struct array01_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as3 \\(struct array01_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
-! { dg-final { scan-tree-dump-times "void ar1 \\(struct array15_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void ar2 \\(struct array15_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void ar3 \\(struct array15_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
-! { dg-final { scan-tree-dump-times "void ar4 \\(struct array15_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5a \\(struct array01_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5ar \\(struct array15_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5p \\(struct array01_character\\(kind=1\\) & xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5pr \\(struct array15_character\\(kind=1\\) & xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as1 \\(struct CFI_cdesc_t01 & restrict _x1\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as2 \\(struct CFI_cdesc_t01 & restrict _x2\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as3 \\(struct CFI_cdesc_t01 & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as4 \\(struct CFI_cdesc_t01 & restrict _xstar\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar1 \\(struct CFI_cdesc_t & restrict _x1\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar2 \\(struct CFI_cdesc_t & restrict _x2\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar3 \\(struct CFI_cdesc_t & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar4 \\(struct CFI_cdesc_t & restrict _xstar\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5ar \\(struct CFI_cdesc_t & restrict _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5a \\(struct CFI_cdesc_t01 & restrict _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5pr \\(struct CFI_cdesc_t & _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5p \\(struct CFI_cdesc_t01 & _xcolon\\)" 1 "original" } }
+
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index f8b3ecd0046..b38eb0bbcb0 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -34,6 +34,8 @@  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **);
 export_proto(cfi_desc_to_gfc_desc);
 
+/* NOTE: Since GCC 12, the FE generates code to do the conversion
+   directly without calling this function.  */
 void
 cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
 {
@@ -111,6 +113,8 @@  cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
 extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
 export_proto(gfc_desc_to_cfi_desc);
 
+/* NOTE: Since GCC 12, the FE generates code to do the conversion
+   directly without calling this function.  */
 void
 gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
 {