fortran, libgfortran: Add remaining missing *_r17 symbols

Following patch adds remaining missing *_r17 entrypoints, so that
we have 91 *_r16 and 91 *_r17 entrypoints (and 24 *_c16 and 24 *_c17).

This fixes:
FAIL: gfortran.dg/dec_math.f90   -O0  execution test
FAIL: gfortran.dg/dec_math.f90   -O1  execution test
FAIL: gfortran.dg/dec_math.f90   -O2  execution test
FAIL: gfortran.dg/dec_math.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
FAIL: gfortran.dg/dec_math.f90   -O3 -g  execution test
FAIL: gfortran.dg/dec_math.f90   -Os  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -O0  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -O1  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -O2  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -O3 -g  execution test
FAIL: gfortran.dg/ieee/dec_math_1.f90   -Os  execution test

2022-01-04  Jakub Jelinek  <jakub@redhat.com>

gcc/fortran/
	* trans-intrinsic.c (gfc_get_intrinsic_lib_fndecl): Use
	gfc_type_abi_kind.
libgfortran/
	* libgfortran.h (GFC_REAL_17_INFINITY, GFC_REAL_17_QUIET_NAN): Define.
	(__erfcieee128): Declare.
	* intrinsics/trigd.c (_gfortran_sind_r17, _gfortran_cosd_r17,
	_gfortran_tand_r17): Define for HAVE_GFC_REAL_17.
	* intrinsics/random.c (random_r17, arandom_r17, rnumber_17): Define.
	* intrinsics/erfc_scaled.c (ERFC_SCALED): Define.
	(erfc_scaled_r16): Use ERFC_SCALED macro.
	(erfc_scaled_r17): Define.

4 files changed, 250 insertions, 40 deletions

diff --git a/libgfortran/intrinsics/erfc_scaled.c b/libgfortran/intrinsics/erfc_scaled.c
index 09c1127..60982fb 100644
--- a/libgfortran/intrinsics/erfc_scaled.c
+++ b/libgfortran/intrinsics/erfc_scaled.c
@@ -75,52 +75,91 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 #endif
 
+#define ERFC_SCALED(k) \
+GFC_REAL_ ## k								    \
+erfc_scaled_r ## k (GFC_REAL_ ## k x)					    \
+{									    \
+  if (x < _THRESH)							    \
+    {									    \
+      return _INF;							    \
+    }									    \
+  if (x < 12)								    \
+    {									    \
+      /* Compute directly as ERFC_SCALED(x) = ERFC(x) * EXP(X**2).	    \
+	 This is not perfect, but much better than netlib.  */		    \
+      return _ERFC(x) * _EXP(x * x);					    \
+    }									    \
+  else									    \
+    {									    \
+      /* Calculate ERFC_SCALED(x) using a power series in 1/x:		    \
+	 ERFC_SCALED(x) = 1 / (x * sqrt(pi))				    \
+			 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))  \
+					      / (2 * x**2)**n)		    \
+       */								    \
+      GFC_REAL_ ## k sum = 0, oldsum;					    \
+      GFC_REAL_ ## k inv2x2 = 1 / (2 * x * x);				    \
+      GFC_REAL_ ## k fac = 1;						    \
+      int n = 1;							    \
+									    \
+      while (n < 200)							    \
+	{								    \
+	  fac *= - (2*n - 1) * inv2x2;					    \
+	  oldsum = sum;							    \
+	  sum += fac;							    \
+									    \
+	  if (sum == oldsum)						    \
+	    break;							    \
+									    \
+	  n++;								    \
+	}								    \
+									    \
+      return (1 + sum) / x * (_M_2_SQRTPI / 2);				    \
+    }									    \
+}
+
 #if defined(_ERFC) && defined(_EXP)
 
 extern GFC_REAL_16 erfc_scaled_r16 (GFC_REAL_16);
 export_proto(erfc_scaled_r16);
 
-GFC_REAL_16
-erfc_scaled_r16 (GFC_REAL_16 x)
-{
-  if (x < _THRESH)
-    {
-      return _INF;
-    }
-  if (x < 12)
-    {
-      /* Compute directly as ERFC_SCALED(x) = ERFC(x) * EXP(X**2).
-	 This is not perfect, but much better than netlib.  */
-      return _ERFC(x) * _EXP(x * x);
-    }
-  else
-    {
-      /* Calculate ERFC_SCALED(x) using a power series in 1/x:
-	 ERFC_SCALED(x) = 1 / (x * sqrt(pi))
-			 * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
-					      / (2 * x**2)**n)
-       */
-      GFC_REAL_16 sum = 0, oldsum;
-      GFC_REAL_16 inv2x2 = 1 / (2 * x * x);
-      GFC_REAL_16 fac = 1;
-      int n = 1;
-
-      while (n < 200)
-	{
-	  fac *= - (2*n - 1) * inv2x2;
-	  oldsum = sum;
-	  sum += fac;
-
-	  if (sum == oldsum)
-	    break;
-
-	  n++;
-	}
-
-      return (1 + sum) / x * (_M_2_SQRTPI / 2);
-    }
-}
+ERFC_SCALED(16)
 
 #endif
 
+#undef _THRESH
+#undef _M_2_SQRTPI
+#undef _INF
+#undef _ERFC
+#undef _EXP
+
+#endif
+
+#ifdef HAVE_GFC_REAL_17
+
+/* For quadruple-precision, netlib's implementation is
+   not accurate enough.  We provide another one.  */
+
+# define _THRESH -106.566990228185312813205074546585730Q
+# define _M_2_SQRTPI M_2_SQRTPIq
+# define _INF __builtin_inff128()
+# ifdef POWER_IEEE128
+#  define _ERFC(x) __erfcieee128(x)
+#  define _EXP(x) __expieee128(x)
+# else
+#  define _ERFC(x) erfcq(x)
+#  define _EXP(x) expq(x)
+# endif
+
+extern GFC_REAL_17 erfc_scaled_r17 (GFC_REAL_17);
+export_proto(erfc_scaled_r17);
+
+ERFC_SCALED(17)
+
+#undef _THRESH
+#undef _M_2_SQRTPI
+#undef _INF
+#undef _ERFC
+#undef _EXP
+#undef ERFC_SCALED
+
 #endif
diff --git a/libgfortran/intrinsics/random.c b/libgfortran/intrinsics/random.c
index ab4d7d8..b5732e6 100644
--- a/libgfortran/intrinsics/random.c
+++ b/libgfortran/intrinsics/random.c
@@ -79,6 +79,16 @@ export_proto(arandom_r16);
 
 #endif
 
+#ifdef HAVE_GFC_REAL_17
+
+extern void random_r17 (GFC_REAL_17 *);
+iexport_proto(random_r17);
+
+extern void arandom_r17 (gfc_array_r17 *);
+export_proto(arandom_r17);
+
+#endif
+
 #ifdef __GTHREAD_MUTEX_INIT
 static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
 #else
@@ -161,6 +171,27 @@ rnumber_16 (GFC_REAL_16 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2)
 }
 #endif
 
+#ifdef HAVE_GFC_REAL_17
+
+/* For REAL(KIND=16), we only need to mask off the lower bits.  */
+
+static void
+rnumber_17 (GFC_REAL_17 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2)
+{
+  GFC_UINTEGER_8 mask;
+#if GFC_REAL_17_RADIX == 2
+  mask = ~ (GFC_UINTEGER_8) 0u << (128 - GFC_REAL_17_DIGITS);
+#elif GFC_REAL_17_RADIX == 16
+  mask = ~ (GFC_UINTEGER_8) 0u << ((32 - GFC_REAL_17_DIGITS) * 4);
+#else
+#error "GFC_REAL_17_RADIX has unknown value"
+#endif
+  v2 = v2 & mask;
+  *f = (GFC_REAL_17) v1 * GFC_REAL_17_LITERAL(0x1.p-64)
+    + (GFC_REAL_17) v2 * GFC_REAL_17_LITERAL(0x1.p-128);
+}
+#endif
+
 
 /*
 
@@ -445,6 +476,28 @@ iexport(random_r16);
 
 #endif
 
+/*  This function produces a REAL(16) value from the uniform distribution
+    with range [0,1).  */
+
+#ifdef HAVE_GFC_REAL_17
+
+void
+random_r17 (GFC_REAL_17 *x)
+{
+  GFC_UINTEGER_8 r1, r2;
+  prng_state* rs = get_rand_state();
+
+  if (unlikely (!rs->init))
+    init_rand_state (rs, false);
+  r1 = prng_next (rs);
+  r2 = prng_next (rs);
+  rnumber_17 (x, r1, r2);
+}
+iexport(random_r17);
+
+
+#endif
+
 /*  This function fills a REAL(4) array with values from the uniform
     distribution with range [0,1).  */
 
@@ -719,6 +772,77 @@ arandom_r16 (gfc_array_r16 *x)
 
 #endif
 
+#ifdef HAVE_GFC_REAL_17
+
+/*  This function fills a REAL(16) array with values from the uniform
+    distribution with range [0,1).  */
+
+void
+arandom_r17 (gfc_array_r17 *x)
+{
+  index_type count[GFC_MAX_DIMENSIONS];
+  index_type extent[GFC_MAX_DIMENSIONS];
+  index_type stride[GFC_MAX_DIMENSIONS];
+  index_type stride0;
+  index_type dim;
+  GFC_REAL_17 *dest;
+  prng_state* rs = get_rand_state();
+
+  dest = x->base_addr;
+
+  dim = GFC_DESCRIPTOR_RANK (x);
+
+  for (index_type n = 0; n < dim; n++)
+    {
+      count[n] = 0;
+      stride[n] = GFC_DESCRIPTOR_STRIDE(x,n);
+      extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
+      if (extent[n] <= 0)
+        return;
+    }
+
+  stride0 = stride[0];
+
+  if (unlikely (!rs->init))
+    init_rand_state (rs, false);
+
+  while (dest)
+    {
+      /* random_r17 (dest);  */
+      uint64_t r1 = prng_next (rs);
+      uint64_t r2 = prng_next (rs);
+      rnumber_17 (dest, r1, r2);
+
+      /* Advance to the next element.  */
+      dest += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      index_type n = 0;
+      while (count[n] == extent[n])
+        {
+          /* When we get to the end of a dimension, reset it and increment
+             the next dimension.  */
+          count[n] = 0;
+          /* We could precalculate these products, but this is a less
+             frequently used path so probably not worth it.  */
+          dest -= stride[n] * extent[n];
+          n++;
+          if (n == dim)
+            {
+              dest = NULL;
+              break;
+            }
+          else
+            {
+              count[n]++;
+              dest += stride[n];
+            }
+        }
+    }
+}
+
+#endif
+
 
 /* Number of elements in master_state array.  */
 #define SZU64 (sizeof (master_state.s) / sizeof (uint64_t))
diff --git a/libgfortran/intrinsics/trigd.c b/libgfortran/intrinsics/trigd.c
index b18111c..2fed8b2 100644
--- a/libgfortran/intrinsics/trigd.c
+++ b/libgfortran/intrinsics/trigd.c
@@ -289,3 +289,42 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #undef HAVE_INFINITY_KIND
 
 #endif /* HAVE_GFC_REAL_16 */
+
+#ifdef HAVE_GFC_REAL_17
+
+/* Build _gfortran_sind_r17, _gfortran_cosd_r17, and _gfortran_tand_r17  */
+
+#define KIND	17
+#define TINY	0x1.p-16400	/* ~= 1.28e-4937 */
+#undef  SIND_SMALL		/* not precise */
+
+/* Proper float128 precision.  */
+#define COSD_SMALL  0x1.p-51	/* ~= 4.441e-16 */
+#define COSD30      8.66025403784438646763723170752936183e-01
+#define PIO180H     1.74532925199433197605003442731685936e-02
+#define PIO180L     -2.39912634365882824665106671063098954e-17
+
+/* libquadmath or glibc 2.32+: HAVE_*Q are never defined.  They must be available.  */
+#define ENABLE_SIND
+#define ENABLE_COSD
+#define ENABLE_TAND
+
+#ifdef GFC_REAL_17_INFINITY
+#define HAVE_INFINITY_KIND
+#endif
+
+#include "trigd_lib.inc"
+
+#undef KIND
+#undef TINY
+#undef COSD_SMALL
+#undef SIND_SMALL
+#undef COSD30
+#undef PIO180H
+#undef PIO180L
+#undef ENABLE_SIND
+#undef ENABLE_COSD
+#undef ENABLE_TAND
+#undef HAVE_INFINITY_KIND
+
+#endif /* HAVE_GFC_REAL_17 */
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index f4fd8ae..dc7a5f1 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -324,6 +324,9 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
 #   define GFC_REAL_16_INFINITY __builtin_infq ()
 #  endif
 # endif
+# ifdef HAVE_GFC_REAL_17
+#  define GFC_REAL_17_INFINITY __builtin_inff128 ()
+# endif
 #endif
 #if __FLT_HAS_QUIET_NAN__
 # define GFC_REAL_4_QUIET_NAN __builtin_nanf ("")
@@ -342,6 +345,9 @@ typedef GFC_UINTEGER_4 gfc_char4_t;
 #   define GFC_REAL_16_QUIET_NAN nanq ("")
 #  endif
 # endif
+# ifdef HAVE_GFC_REAL_17
+#  define GFC_REAL_17_QUIET_NAN __builtin_nanf128 ("")
+# endif
 #endif
 
 typedef struct descriptor_dimension
@@ -1966,6 +1972,8 @@ extern __float128 __coshieee128 (__float128)
   __attribute__ ((__nothrow__, __leaf__));
 extern __float128 __cosieee128 (__float128)
   __attribute__ ((__nothrow__, __leaf__));
+extern __float128 __erfcieee128 (__float128)
+  __attribute__ ((__nothrow__, __leaf__));
 extern __float128 __erfieee128 (__float128)
   __attribute__ ((__nothrow__, __leaf__));
 extern __float128 __expieee128 (__float128)