[PATCH] Implementation of RANDOM_INIT from F2018

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

I have attached my current implementation for RANDOM_INIT.

For programs compiled without -fcoarry= or with -fcoarray=single,
the one gets, 

% cat random_init_2.f90
program foo
   real x(2)
   call random_init(.false., .false.)
   call random_number(x)
   print *, x
   call random_init(.false., .false.)
   call random_number(x)
   print *, x

   call random_init(.true., .false.)
   call random_number(x)
   print *, x
   call random_init(.true., .false.)
   call random_number(x)
   print *, x
end program foo
% gfcx -o z random_init_2.f90 && ./z
  0.817726076      0.318128884    
  0.598739505       2.99510360E-02
  0.336736381      0.870776474    
  0.336736381      0.870776474  

Now, with -fcoarray=lib, one gets 

%  gfcx -fcoarray=lib -c random_init_2.f90
f951: Fatal Error: RANDOM_INIT with co-arrays is broken!
compilation terminated.

I have zero knowledge about co-arrays and especially zero
knowledge about gfortran internals for co-arrays.  I'm
disinclined to waste another 12 hours trying to get gfortran
to emit essentially a call to this_image().  See iresolve.c
for details.

2018-01-07  Steven G. Kargl  <kargl@gcc.gnu.org>

	* check.c (gfc_check_random_init): New function.
	* gfortran.h: Define GFC_ISYM_RANDOM_INIT.
	* intrinsic.c (add_subroutines): Add random_init to list of subroutines.
	(gfc_check_intrinsic_standard): Update error message for Fortran 2018.
	* intrinsic.h: Add prototypes for gfc_check_random_init and
	gfc_resolve_random_init.
	* iresolve.c (gfc_resolve_random_init): Implementation.

2018-01-07  Steven G. Kargl  <kargl@gcc.gnu.org>

	* libgfortran/gfortran.map: Add _gfortran_random_init.
	* libgfortran/intrinsics/random.c: Add implemention of
	_gfortran_random_init

-- 
Steve

Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 256045)
+++ gcc/fortran/check.c	(working copy)
@@ -5671,6 +5671,19 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, g
 
 
 bool
+gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct)
+{
+  if (!type_check (repeatable, 0, BT_LOGICAL))
+    return false;
+
+  if (!type_check (image_distinct, 1, BT_LOGICAL))
+    return false;
+
+  return true;
+}
+
+
+bool
 gfc_check_random_number (gfc_expr *harvest)
 {
   if (!type_check (harvest, 0, BT_REAL))
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 256045)
+++ gcc/fortran/expr.c	(working copy)
@@ -3853,7 +3853,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *
 
   /* Error for assignments of contiguous pointers to targets which is not
      contiguous.  Be lenient in the definition of what counts as
-     congiguous.  */
+     contiguous.  */
 
   if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true))
     gfc_error ("Assignment to contiguous pointer from non-contiguous "
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 256045)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -551,6 +551,7 @@ enum gfc_isym_id
   GFC_ISYM_PRODUCT,
   GFC_ISYM_RADIX,
   GFC_ISYM_RAND,
+  GFC_ISYM_RANDOM_INIT,
   GFC_ISYM_RANDOM_NUMBER,
   GFC_ISYM_RANDOM_SEED,
   GFC_ISYM_RANGE,
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 256045)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -3549,6 +3549,12 @@ add_subroutines (void)
       make_alias ("kmvbits", GFC_STD_GNU);
     }
 
+  add_sym_2s ("random_init", GFC_ISYM_RANDOM_INIT, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2018,
+	      gfc_check_random_init, NULL, gfc_resolve_random_init,
+	      "repeatable",     BT_LOGICAL, dl, REQUIRED, INTENT_IN,
+	      "image_distinct", BT_LOGICAL, dl, REQUIRED, INTENT_IN);
+
   add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
 	      BT_UNKNOWN, 0, GFC_STD_F95,
 	      gfc_check_random_number, NULL, gfc_resolve_random_number,
@@ -4601,6 +4607,10 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym*
 
     case GFC_STD_F2008_TS:
       symstd_msg = "new in TS 29113/TS 18508";
+      break;
+
+    case GFC_STD_F2018:
+      symstd_msg = "new in Fortran 2018";
       break;
 
     case GFC_STD_GNU:
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 256045)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -203,6 +203,7 @@ bool gfc_check_getlog (gfc_expr *);
 bool gfc_check_move_alloc (gfc_expr *, gfc_expr *);
 bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 		      gfc_expr *);
+bool gfc_check_random_init (gfc_expr *, gfc_expr *);
 bool gfc_check_random_number (gfc_expr *);
 bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
@@ -643,6 +644,7 @@ void gfc_resolve_lstat_sub (gfc_code *);
 void gfc_resolve_ltime (gfc_code *);
 void gfc_resolve_mvbits (gfc_code *);
 void gfc_resolve_perror (gfc_code *);
+void gfc_resolve_random_init (gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
 void gfc_resolve_random_seed (gfc_code *);
 void gfc_resolve_rename_sub (gfc_code *);
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 256045)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -35,7 +35,9 @@ along with GCC; see the file COPYING3.  If not see
 #include "intrinsic.h"
 #include "constructor.h"
 #include "arith.h"
+#include "tm.h"		/* For flag_coarray.  */
 
+
 /* Given printf-like arguments, return a stable version of the result string. 
 
    We already have a working, optimized string hashing table in the form of
@@ -3118,6 +3120,8 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 {
   f->ts.type = BT_CHARACTER;
   f->ts.kind = string->ts.kind;
+  f->ts.u.cl = NULL;
+  f->ts.u.pad = 0;
   f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind);
 }
 
@@ -3368,6 +3372,61 @@ gfc_resolve_mvbits (gfc_code *c)
   /* Create a dummy formal arglist so the INTENTs are known later for purpose
      of creating temporaries.  */
   c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS);
+}
+
+
+/* Set up the call to RANDOM_INIT.  To deal with image_distinct, we need to
+   send a hidden argument into the library function.  For program that don't
+   use co-arrays or uses -fcoarray=single, the hidden argument is set to 0.
+   For -fcoarray=lib, the hidden argument should be set to the value 
+   returned by this_image().  Using R for REPEATABLE and I for
+   IMAGE_DISTINCT. So, RANDOM_INIT(R, I) is mapped to the library routine
+   _gfortran_random_init(R, I, 0) for a single image, and it should be
+   mapped to _gfortran_random_init(R, I, this_image()).  */ 
+
+void
+gfc_resolve_random_init (gfc_code *c)
+{
+  gfc_actual_arglist *a;
+  const char *name;
+
+  name = gfc_get_string (PREFIX ("random_init"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+
+  /* Pass a hidden integer to deal with seeding images for coarrays.  */
+  a = gfc_get_actual_arglist ();
+  if (flag_coarray != GFC_FCOARRAY_LIB)
+    {
+      a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+					&c->ext.actual->next->expr->where);
+      mpz_set_si (a->expr->value.integer, 0);
+    }
+  else
+    {
+      gfc_fatal_error ("RANDOM_INIT with co-arrays is broken!");
+#if 0
+/* Well, this didn't work. :(  */
+      static const char name[] = "this_image";
+      a->expr = gfc_get_expr ();
+      a->expr->expr_type = EXPR_FUNCTION;
+      a->expr->ts.type = BT_INTEGER;
+      a->expr->ts.kind = gfc_default_integer_kind;
+      a->expr->where = gfc_current_locus;
+      a->expr->value.function.isym = gfc_find_function (name);
+      a->expr->value.function.name = a->expr->value.function.isym->name;
+
+      a->expr->value.function.actual = gfc_get_actual_arglist ();
+      a->expr->value.function.actual->next = gfc_get_actual_arglist ();
+      a->expr->value.function.actual->next->next = gfc_get_actual_arglist ();
+      a->expr->value.function.isym->formal->actual = gfc_get_actual_arglist ();
+      a->expr->value.function.isym->formal->actual->next = gfc_get_actual_arglist ();
+      a->expr->value.function.isym->formal->actual->next->next = gfc_get_actual_arglist ();
+
+      gfc_simplify_expr (a->expr, 0);
+      c->resolved_isym->formal->actual->next->next = a;
+#endif
+    }
+    c->ext.actual->next->next = a;
 }
 
 
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 256045)
+++ libgfortran/gfortran.map	(working copy)
@@ -801,6 +801,7 @@ GFORTRAN_8 {
     _gfortran_product_r4;
     _gfortran_product_r8;
     _gfortran_rand;
+    _gfortran_random_init;
     _gfortran_random_r10;
     _gfortran_random_r16;
     _gfortran_random_r4;
Index: libgfortran/intrinsics/random.c
===================================================================
--- libgfortran/intrinsics/random.c	(revision 256045)
+++ libgfortran/intrinsics/random.c	(working copy)
@@ -44,6 +44,9 @@ see the files COPYING3 and COPYING.RUNTIME respectivel
 #include <_mingw.h> /* For __MINGW64_VERSION_MAJOR  */
 #endif
 
+extern void random_init (GFC_LOGICAL_4 *, GFC_LOGICAL_4 *, GFC_INTEGER_4 *);
+iexport_proto(random_init);
+
 extern void random_r4 (GFC_REAL_4 *);
 iexport_proto(random_r4);
 
@@ -205,7 +208,6 @@ static uint64_t master_state[] = {
   0x625288bc262faf33ULL
 };
 
-
 static __gthread_key_t rand_state_key;
 
 static xorshift1024star_state*
@@ -927,6 +929,46 @@ random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put
 }
 iexport(random_seed_i8);
 
+
+/* random_init is used to seed the PRNG with either a default
+   set of seeds or a random set of seeds.  */
+
+void
+random_init (GFC_LOGICAL_4 *repeatable, GFC_LOGICAL_4 *image_distinct,
+	     GFC_INTEGER_4 *hidden)
+{
+  static const uint64_t repeat_state[] = {
+    0x25b946ebc0b36173ULL, 0x31fffb768dfde2d1ULL, 0xb08dbf28a70a6b08ULL,
+    0x60b1fc7fbcc04151ULL, 0xb4018862d654635dULL, 0x5c2fc35553bb5470ULL,
+    0xd588f951b8984a2bULL, 0x060c05384e97789dULL, 0x2b992ddfa23249d6ULL,
+    0x4034650f1c98bd69ULL, 0x79267e9c00e018afULL, 0x449eb881a2869d0eULL,
+    0xe2fee08d1e670313ULL, 0x17afc3eef0f0c640ULL, 0x2002db4f8acb8a0eULL,
+    0x50cd06b1b61a6804ULL
+  };
+
+  xorshift1024star_state* rs = get_rand_state();
+
+  __gthread_mutex_lock (&random_lock);
+
+  if (*repeatable)
+    {
+      /* Copy the repeat seeds.   */
+      memcpy (&rs->s, repeat_state, sizeof (repeat_state));
+      njumps = 0;
+      if (*image_distinct) njumps = *hidden;
+      master_init = true;
+      init_rand_state (rs, true);
+	  rs->p = 0;
+    }
+  else
+    {
+      master_init = false;
+      init_rand_state (rs, true);
+    }
+
+  __gthread_mutex_unlock (&random_lock);
+}
+iexport(random_init);
 
 #if !defined __GTHREAD_MUTEX_INIT || defined __GTHREADS
 static void __attribute__((constructor))