[gcc r13-4716] libgfortran's ISO_Fortran_binding.c: Use GCC11 version for backward-only code [PR108056]

[gcc r13-4716] libgfortran's ISO_Fortran_binding.c: Use GCC11 version for backward-only code [PR108056]

[Tobias Burnus]

https://gcc.gnu.org/g:e205ec03f0794aeac3e8a89e947c12624d5a274e

commit r13-4716-ge205ec03f0794aeac3e8a89e947c12624d5a274e
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Thu Dec 15 12:25:07 2022 +0100

    libgfortran's ISO_Fortran_binding.c: Use GCC11 version for backward-only code [PR108056]
    
    Since GCC 12, the conversion between the array descriptors formats - the
    internal (GFC) and the C binding one (CFI) - moved to the compiler itself
    such that the cfi_desc_to_gfc_desc/gfc_desc_to_cfi_desc functions are only
    used with older code (GCC 9 to 11).  The newly added checks caused asserts
    as older code did not pass the proper values (e.g. real(4) as effective
    argument arrived as BT_ASSUME type as the effective type got lost inbetween).
    
    As proposed in the PR, revert to the GCC 11 version - known bugs is better
    than some fixes and new issues. Still, GCC 12 is much better in terms of
    TS29113 support and should really be used.
    
    This patch uses the current libgomp version of the GCC 11 branch, except
    it fixes the GFC version number (which is 0), uses calloc instead of malloc,
    and sets the lower bound to 1 instead of keeping it as is for
    CFI_attribute_other.
    
    libgfortran/ChangeLog:
    
            PR libfortran/108056
            * runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc,
            gfc_desc_to_cfi_desc): Mostly revert to GCC 11 version for
            those backward-compatiblity-only functions.

Diff:
---
 libgfortran/runtime/ISO_Fortran_binding.c        | 151 ++++-------------------
 libgomp/testsuite/libgomp.fortran/allocate-4.f90 |  42 +++++++
 2 files changed, 64 insertions(+), 129 deletions(-)

diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index 342df4275b9..e63a717a69b 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -39,60 +39,31 @@ export_proto(cfi_desc_to_gfc_desc);
 void
 cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
 {
-  signed char type;
-  size_t size;
   int n;
+  index_type kind;
   CFI_cdesc_t *s = *s_ptr;
 
   if (!s)
     return;
 
-  /* Verify descriptor.  */
-  switch (s->attribute)
-    {
-    case CFI_attribute_pointer:
-    case CFI_attribute_allocatable:
-      break;
-    case CFI_attribute_other:
-      if (s->base_addr)
-	break;
-      runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
-		     "dummy argument where the effective argument is either "
-		     "not allocated or not associated");
-      break;
-    default:
-      runtime_error ("Invalid attribute type %d in CFI_cdesc_t descriptor",
-		     (int) s->attribute);
-      break;
-    }
   GFC_DESCRIPTOR_DATA (d) = s->base_addr;
+  GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
+  kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
 
   /* Correct the unfortunate difference in order with types.  */
-  type = (signed char)(s->type & CFI_type_mask);
-  switch (type)
-    {
-    case CFI_type_Character:
-      type = BT_CHARACTER;
-      break;
-    case CFI_type_struct:
-      type = BT_DERIVED;
-      break;
-    case CFI_type_cptr:
-      /* FIXME: PR 100915.  GFC descriptors do not distinguish between
-	 CFI_type_cptr and CFI_type_cfunptr.  */
-      type = BT_VOID;
-      break;
-    default:
-      break;
-    }
-
-  GFC_DESCRIPTOR_TYPE (d) = type;
-  GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
+  if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
+    GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
+  else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
+    GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER;
+
+  if (!s->rank || s->dim[0].sm == (CFI_index_t)s->elem_len)
+    GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
+  else if (GFC_DESCRIPTOR_TYPE (d) != BT_DERIVED)
+    GFC_DESCRIPTOR_SIZE (d) = kind;
+  else
+    GFC_DESCRIPTOR_SIZE (d) = s->elem_len;
 
   d->dtype.version = 0;
-
-  if (s->rank < 0 || s->rank > CFI_MAX_RANK)
-    internal_error (NULL, "Invalid rank in descriptor");
   GFC_DESCRIPTOR_RANK (d) = (signed char)s->rank;
 
   d->dtype.attribute = (signed short)s->attribute;
@@ -131,7 +102,6 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
 {
   int n;
   CFI_cdesc_t *d;
-  signed char type, kind;
 
   /* Play it safe with allocation of the flexible array member 'dim'
      by setting the length to CFI_MAX_RANK. This should not be necessary
@@ -142,99 +112,22 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
   else
     d = *d_ptr;
 
-  /* Verify descriptor.  */
-  switch (s->dtype.attribute)
-    {
-    case CFI_attribute_pointer:
-    case CFI_attribute_allocatable:
-      break;
-    case CFI_attribute_other:
-      if (s->base_addr)
-	break;
-      runtime_error ("Nonallocatable, nonpointer actual argument to BIND(C) "
-		     "dummy argument where the effective argument is either "
-		     "not allocated or not associated");
-      break;
-    default:
-      internal_error (NULL, "Invalid attribute in gfc_array descriptor");
-      break;
-    }
   d->base_addr = GFC_DESCRIPTOR_DATA (s);
   d->elem_len = GFC_DESCRIPTOR_SIZE (s);
-  if (d->elem_len <= 0)
-    internal_error (NULL, "Invalid size in descriptor");
-
   d->version = CFI_VERSION;
-
   d->rank = (CFI_rank_t)GFC_DESCRIPTOR_RANK (s);
-  if (d->rank < 0 || d->rank > CFI_MAX_RANK)
-    internal_error (NULL, "Invalid rank in descriptor");
-
   d->attribute = (CFI_attribute_t)s->dtype.attribute;
 
-  type = GFC_DESCRIPTOR_TYPE (s);
-  switch (type)
-    {
-    case BT_CHARACTER:
-      d->type = CFI_type_Character;
-      break;
-    case BT_DERIVED:
-      d->type = CFI_type_struct;
-      break;
-    case BT_VOID:
-      /* FIXME: PR 100915.  GFC descriptors do not distinguish between
-	 CFI_type_cptr and CFI_type_cfunptr.  */
-      d->type = CFI_type_cptr;
-      break;
-    default:
-      d->type = (CFI_type_t)type;
-      break;
-    }
-
-  switch (d->type)
-    {
-    case CFI_type_Integer:
-    case CFI_type_Logical:
-    case CFI_type_Real:
-      kind = (signed char)d->elem_len;
-      break;
-    case CFI_type_Complex:
-      kind = (signed char)(d->elem_len >> 1);
-      break;
-    case CFI_type_Character:
-      /* FIXME: we can't distinguish between kind/len because
-	 the GFC descriptor only encodes the elem_len..
-	 Until PR92482 is fixed, assume elem_len refers to the
-	 character size and not the string length.  */
-      kind = (signed char)d->elem_len;
-      break;
-    case CFI_type_struct:
-    case CFI_type_cptr:
-    case CFI_type_other:
-      /* FIXME: PR 100915.  GFC descriptors do not distinguish between
-	 CFI_type_cptr and CFI_type_cfunptr.  */
-      kind = 0;
-      break;
-    default:
-      internal_error (NULL, "Invalid type in descriptor");
-    }
-
-  if (kind < 0)
-    internal_error (NULL, "Invalid kind in descriptor");
-
-  /* FIXME: This is PR100917.  Because the GFC descriptor encodes only the
-     elem_len and not the kind, we get into trouble with long double kinds
-     that do not correspond directly to the elem_len, specifically the
-     kind 10 80-bit long double on x86 targets.  On x86_64, this has size
-     16 and cannot be differentiated from true _Float128.  Prefer the
-     standard long double type over the GNU extension in that case.  */
-  if (d->type == CFI_type_Real && kind == sizeof (long double))
-    d->type = CFI_type_long_double;
-  else if (d->type == CFI_type_Complex && kind == sizeof (long double))
-    d->type = CFI_type_long_double_Complex;
+  if (GFC_DESCRIPTOR_TYPE (s) == BT_CHARACTER)
+    d->type = CFI_type_Character;
+  else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED)
+    d->type = CFI_type_struct;
   else
+    d->type = (CFI_type_t)GFC_DESCRIPTOR_TYPE (s);
+
+  if (GFC_DESCRIPTOR_TYPE (s) != BT_DERIVED)
     d->type = (CFI_type_t)(d->type
-			   + ((CFI_type_t)kind << CFI_type_kind_shift));
+		+ ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
 
   if (d->base_addr)
     /* Full pointer or allocatable arrays retain their lower_bounds.  */
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-4.f90 b/libgomp/testsuite/libgomp.fortran/allocate-4.f90
new file mode 100644
index 00000000000..ddb507ba8e4
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-4.f90
@@ -0,0 +1,42 @@
+! { dg-do compile }
+
+
+subroutine test()
+use iso_c_binding, only: c_intptr_t
+implicit none
+integer, parameter :: omp_allocator_handle_kind = 1 !! <<<
+integer (kind=omp_allocator_handle_kind), &
+                 parameter :: omp_high_bw_mem_alloc = 4
+integer :: q, x,y,z
+integer, parameter :: cnst(2) = [64, 101]
+
+!$omp parallel allocate( omp_high_bw_mem_alloc : x)  firstprivate(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp end parallel
+
+!$omp parallel allocate( allocator (omp_high_bw_mem_alloc) : x)  firstprivate(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp end parallel
+
+!$omp parallel allocate( align (q) : x)  firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+
+!$omp parallel allocate( align (32) : x)  firstprivate(x) ! OK
+!$omp end parallel
+
+!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+
+!$omp parallel allocate( align(cnst(1)) : x ) firstprivate(x) ! OK
+!$omp end parallel
+
+!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x)  ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+
+!$omp parallel allocate( align( 31) :x) firstprivate(x)  ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+
+!$omp parallel allocate( align (32.0): x) firstprivate(x)  ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+
+!$omp parallel allocate( align(cnst ) : x ) firstprivate(x)  ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp end parallel
+end