Add testcase for PR fortran/100906

2021-10-21  José Rui Faustino de Sousa  <jrfsousa@gmail.com>
	    Sandra Loosemore  <sandra@codesourcery.com>

	gcc/testsuite/

	PR fortran/100906
	* gfortran.dg/PR100906.f90: New.
	* gfortran.dg/PR100906.c: New.

gcc/testsuite/gfortran.dg/PR100906.c

@@ -0,0 +1,169 @@
+/* Test the fix for PR100906 */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <stdio.h>
+/* #include <uchar.h> */
+
+#include <ISO_Fortran_binding.h>
+
+#define _CFI_type_mask 0xFF
+#define _CFI_type_kind_shift 8
+
+#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
+#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
+
+#define _CFI_encode_type(TYPE, KIND) (int16_t)\
+((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
+ | ((TYPE) & CFI_type_mask))
+
+#define N 11
+#define M 7
+
+typedef char c_char;
+/* typedef char32_t c_ucs4_char; */
+typedef uint32_t char32_t;
+typedef uint32_t c_ucs4_char;
+ 
+bool charcmp (char *, char, size_t);
+
+bool ucharcmp (char32_t *, char32_t, size_t);
+
+bool c_vrfy_c_char (const CFI_cdesc_t *restrict, const size_t);
+
+bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, const size_t);
+
+bool c_vrfy_character (const CFI_cdesc_t *restrict, const size_t);
+ 
+void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
+
+bool
+charcmp (char *c, char v, size_t n)
+{
+  bool res = true;
+  char b = (char)'A';
+  size_t i;
+
+  for (i=0; ((i<n)&&(res)); i++, c++)
+    res = (*c == (v+b));
+  return res;
+}
+
+bool
+ucharcmp (char32_t *c, char32_t v, size_t n)
+{
+  bool res = true;
+  char32_t b = (char32_t)0xFF01;
+  size_t i;
+
+  for (i=0; ((i<n)&&(res)); i++, c++)
+    res = (*c == (v+b));
+  return res;
+}
+
+bool
+c_vrfy_c_char (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+  CFI_index_t i, lb, ub, ex;
+  size_t sz;
+  c_char *ip = NULL;
+
+  assert (auxp);
+  assert (auxp->base_addr);
+  assert (auxp->elem_len>0);
+  lb = auxp->dim[0].lower_bound;
+  ex = auxp->dim[0].extent;
+  assert (ex==N);
+  sz = (size_t)auxp->elem_len / sizeof (c_char);
+  assert (sz==len);
+  ub = ex + lb - 1;
+  ip = (c_char*)auxp->base_addr;
+  for (i=0; i<ex; i++, ip+=sz)
+    if (!charcmp (ip, (c_char)(i), sz))
+      return false;
+  for (i=lb; i<ub+1; i++)
+    {
+      ip = (c_char*)CFI_address(auxp, &i);
+      if (!charcmp (ip, (c_char)(i-lb), sz))
+	return false;
+    }
+  return true;
+}
+
+bool
+c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+  CFI_index_t i, lb, ub, ex;
+  size_t sz;
+  c_ucs4_char *ip = NULL;
+
+  assert (auxp);
+  assert (auxp->base_addr);
+  assert (auxp->elem_len>0);
+  lb = auxp->dim[0].lower_bound;
+  ex = auxp->dim[0].extent;
+  assert (ex==N);
+  sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char);
+  assert (sz==len);
+  ub = ex + lb - 1;
+  ip = (c_ucs4_char*)auxp->base_addr;
+  for (i=0; i<ex; i++, ip+=sz)
+    if (!ucharcmp (ip, (c_ucs4_char)(i), sz))
+      return false;
+  for (i=lb; i<ub+1; i++)
+    {
+      ip = (c_ucs4_char*)CFI_address(auxp, &i);
+      if (!ucharcmp (ip, (c_ucs4_char)(i-lb), sz))
+	return false;
+    }
+  return true;
+}
+
+bool
+c_vrfy_character (const CFI_cdesc_t *restrict auxp, const size_t len)
+{
+  signed char type, kind;
+  
+  assert (auxp);
+  type = _CFI_decode_type(auxp->type);
+  kind = _CFI_decode_kind(auxp->type);
+  assert (type == CFI_type_Character);
+  switch (kind)
+    {
+    case 1:
+      return c_vrfy_c_char (auxp, len);
+      break;
+    case 4:
+      return c_vrfy_c_ucs4_char (auxp, len);
+      break;
+    default:
+      assert (false);
+    }
+  return true;
+}
+
+void
+check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
+{
+  signed char ityp, iknd;
+
+  assert (auxp);
+  assert (auxp->elem_len==elem_len*nelem);
+  assert (auxp->rank==1);
+  assert (auxp->dim[0].sm>0);
+  assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
+  /*  */
+  assert (auxp->type==type);
+  ityp = _CFI_decode_type(auxp->type);
+  assert (ityp == CFI_type_Character);
+  iknd = _CFI_decode_kind(auxp->type);
+  assert (_CFI_decode_type(type)==ityp);
+  assert (kind==iknd);
+  assert (c_vrfy_character (auxp, nelem));
+  return;
+}
+
+// Local Variables:
+// mode: C
+// End: