Re: [Patch, Fortran] PR34262 - Fix MVBITS with arrays

[Tobias Burnus <burnus at net-b dot de>]

Paul Thomas wrote:
>> Your patch is OK :-)
>>
>> However, is the attached not more elegant?
It is more elegant, but it does not work. You get an invalid value for
iname if only one argument is passed. This causes a segmentation fault
in gfortran.fortran-torture/execute/date_time_1.f90 (-> valgrind).

There are only extremely few elemental subroutines. None of the
GNU-specific intrinsic procedures and only the following in the Fortran
2003 standard (and the Fortran 2008 draft):

- MVBITS
- IEEE_GET_FLAG *
- IEEE_GET_HALTING_MODE *

* = not yet implemented in gfortran

I see two possibilities:

a) A hackish one:

    c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym->elemental = 1;

(Though the right hand side can be implemented fancier.)


b) A patch along my patch, but with is_elemental_subroutine moved into
gfc_get_intrinsic_sub_symbol as a non-optional argument.

What do you prefer?

I attached both variants, either of which I would like to check in
together with the previously posted test case.

Tobias

PS: I build and regtested (x86-64) version (b); (a) is less tested, but
I would do so before check in.

Index: intrinsic.c
===================================================================
--- intrinsic.c	(Revision 130511)
+++ intrinsic.c	(Arbeitskopie)
@@ -96,7 +96,8 @@ gfc_type_letter (bt type)
 }
 
 
-/* Get a symbol for a resolved name.  */
+/* Get a symbol for a resolved name. Note, if needed be, the elemental
+   attribute has be added afterwards.  */
 
 gfc_symbol *
 gfc_get_intrinsic_sub_symbol (const char *name)
@@ -3501,7 +3509,10 @@ gfc_intrinsic_sub_interface (gfc_code *c
   if (isym->resolve.s1 != NULL)
     isym->resolve.s1 (c);
   else
-    c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
+    {
+      c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
+      c->resolved_sym->attr.elemental = isym->elemental;
+    }

   if (gfc_pure (NULL) && !isym->elemental)
     {
Index: iresolve.c
===================================================================
--- iresolve.c	(Revision 130511)
+++ iresolve.c	(Arbeitskopie)
@@ -2581,6 +2581,8 @@ gfc_resolve_mvbits (gfc_code *c)
   name = gfc_get_string (PREFIX ("mvbits_i%d"),
 			 c->ext.actual->expr->ts.kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  /* Mark as elemental subroutine as this does not happen automatically.  */
+  c->resolved_sym->attr.elemental = 1;
 }
 
 

Index: intrinsic.c
===================================================================
--- intrinsic.c	(revision 130511)
+++ intrinsic.c	(working copy)
@@ -99,7 +99,7 @@ gfc_type_letter (bt type)
 /* Get a symbol for a resolved name.  */
 
 gfc_symbol *
-gfc_get_intrinsic_sub_symbol (const char *name)
+gfc_get_intrinsic_sub_symbol (const char *name, const char *iname)
 {
   gfc_symbol *sym;
 
@@ -109,6 +109,14 @@ gfc_get_intrinsic_sub_symbol (const char
   sym->attr.flavor = FL_PROCEDURE;
   sym->attr.proc = PROC_INTRINSIC;
 
+  if (iname)
+    {
+      gfc_intrinsic_sym *isym;
+      isym = gfc_find_subroutine (iname);
+      if (isym)
+	sym->attr.elemental = isym->elemental;
+    }
+
   return sym;
 }
 
@@ -3501,7 +3509,10 @@ gfc_intrinsic_sub_interface (gfc_code *c
   if (isym->resolve.s1 != NULL)
     isym->resolve.s1 (c);
   else
-    c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
+    {
+      c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name, NULL);
+      c->resolved_sym->attr.elemental = isym->elemental;
+    }
 
   if (gfc_pure (NULL) && !isym->elemental)
     {
Index: gfortran.h
===================================================================
--- gfortran.h	(revision 130511)
+++ gfortran.h	(working copy)
@@ -2164,7 +2164,7 @@ void gfc_intrinsic_init_1 (void);
 void gfc_intrinsic_done_1 (void);
 
 char gfc_type_letter (bt);
-gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
+gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *, const char *);
 try gfc_convert_type (gfc_expr *, gfc_typespec *, int);
 try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int);
 int gfc_generic_intrinsic (const char *);
Index: iresolve.c
===================================================================
--- iresolve.c	(revision 130511)
+++ iresolve.c	(working copy)
@@ -422,7 +422,7 @@ gfc_resolve_chdir_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "chdir");
 }
 
 
@@ -448,7 +448,7 @@ gfc_resolve_chmod_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "chmod");
 }
 
 
@@ -2548,7 +2548,7 @@ gfc_resolve_alarm_sub (gfc_code *c)
   if (seconds->ts.kind != gfc_c_int_kind)
     gfc_convert_type (seconds, &ts, 2);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "alarm");
 }
 
 void
@@ -2556,7 +2556,7 @@ gfc_resolve_cpu_time (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "cpu_time");
 }
 
 
@@ -2580,7 +2580,7 @@ gfc_resolve_mvbits (gfc_code *c)
   /* TO and FROM are guaranteed to have the same kind parameter.  */
   name = gfc_get_string (PREFIX ("mvbits_i%d"),
 			 c->ext.actual->expr->ts.kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "mvbits");
 }
 
 
@@ -2596,7 +2596,7 @@ gfc_resolve_random_number (gfc_code *c)
   else
     name = gfc_get_string (PREFIX ("arandom_r%d"), kind);
   
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "random_number");
 }
 
 
@@ -2606,7 +2606,7 @@ gfc_resolve_random_seed (gfc_code *c)
   const char *name;
 
   name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "random_seed");
 }
 
 
@@ -2622,7 +2622,7 @@ gfc_resolve_rename_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "rename");
 }
 
 
@@ -2638,7 +2638,7 @@ gfc_resolve_kill_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("kill_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "kill");
 }
     
 
@@ -2654,7 +2654,7 @@ gfc_resolve_link_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("link_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "link");
 }
 
 
@@ -2670,7 +2670,7 @@ gfc_resolve_symlnk_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "symlnk");
 }
 
 
@@ -2681,7 +2681,7 @@ gfc_resolve_etime_sub (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("etime_sub"));
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "etime");
 }
 
 
@@ -2692,7 +2692,8 @@ gfc_resolve_itime (gfc_code *c)
 {
   c->resolved_sym
     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"),
-						    gfc_default_integer_kind));
+						    gfc_default_integer_kind),
+				    "itime");
 }
 
 void
@@ -2700,7 +2701,8 @@ gfc_resolve_idate (gfc_code *c)
 {
   c->resolved_sym
     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"),
-						    gfc_default_integer_kind));
+						    gfc_default_integer_kind),
+				    "idate");
 }
 
 void
@@ -2708,7 +2710,8 @@ gfc_resolve_ltime (gfc_code *c)
 {
   c->resolved_sym
     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"),
-						    gfc_default_integer_kind));
+						    gfc_default_integer_kind),
+				    "ltime");
 }
 
 void
@@ -2716,7 +2719,8 @@ gfc_resolve_gmtime (gfc_code *c)
 {
   c->resolved_sym
     = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"),
-						    gfc_default_integer_kind));
+						    gfc_default_integer_kind),
+				    "gmtime");
 }
 
 
@@ -2727,7 +2731,7 @@ gfc_resolve_second_sub (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("second_sub"));
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "second");
 }
 
 
@@ -2743,7 +2747,7 @@ gfc_resolve_sleep_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "sleep");
 }
 
 
@@ -2754,7 +2758,7 @@ gfc_resolve_srand (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("srand"));
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "srand");
 }
 
 
@@ -2776,7 +2780,7 @@ gfc_resolve_getarg (gfc_code *c)
     }
 
   name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "getarg");
 }
 
 
@@ -2794,7 +2798,7 @@ gfc_resolve_getcwd_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "getcwd");
 }
 
 
@@ -2807,7 +2811,7 @@ gfc_resolve_get_command (gfc_code *c)
   int kind;
   kind = gfc_default_integer_kind;
   name = gfc_get_string (PREFIX ("get_command_i%d"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "get_command");
 }
 
 
@@ -2820,7 +2824,8 @@ gfc_resolve_get_command_argument (gfc_co
   int kind;
   kind = gfc_default_integer_kind;
   name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name,
+						  "get_command_argument");
 }
 
 
@@ -2833,7 +2838,8 @@ gfc_resolve_get_environment_variable (gf
   int kind;
   kind = gfc_default_integer_kind;
   name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind);
-  code->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  code->resolved_sym = gfc_get_intrinsic_sub_symbol (name,
+			 "get_environment_variable");
 }
 
 
@@ -2865,7 +2871,7 @@ gfc_resolve_signal_sub (gfc_code *c)
   if (status != NULL && status->ts.kind != gfc_c_int_kind)
     gfc_convert_type (status, &ts, 2);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "signal");
 }
 
 
@@ -2876,7 +2882,7 @@ gfc_resolve_system_sub (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("system_sub"));
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "system");
 }
 
 
@@ -2898,7 +2904,7 @@ gfc_resolve_system_clock (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("system_clock_%d"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "system_clock");
 }
 
 
@@ -2920,7 +2926,7 @@ gfc_resolve_exit (gfc_code *c)
     gfc_convert_type (n, &ts, 2);
 
   name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "exit");
 }
 
 
@@ -2940,7 +2946,7 @@ gfc_resolve_flush (gfc_code *c)
     gfc_convert_type (n, &ts, 2);
 
   name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "flush");
 }
 
 
@@ -2956,7 +2962,7 @@ gfc_resolve_free (gfc_code *c)
   if (n->ts.kind != ts.kind)
     gfc_convert_type (n, &ts, 2);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("free"), "free");
 }
 
 
@@ -2975,28 +2981,32 @@ gfc_resolve_ctime_sub (gfc_code *c)
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"),
+						  "ctime");
 }
 
 
 void
 gfc_resolve_fdate_sub (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"),
+						  "fdate");
 }
 
 
 void
 gfc_resolve_gerror (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"),
+						  "gerror");
 }
 
 
 void
 gfc_resolve_getlog (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"),
+						  "getlog");
 }
 
 
@@ -3012,14 +3022,15 @@ gfc_resolve_hostnm_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "hostnm");
 }
 
 
 void
 gfc_resolve_perror (gfc_code *c)
 {
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"),
+						  "perror");
 }
 
 /* Resolve the STAT and FSTAT intrinsic subroutines.  */
@@ -3029,7 +3040,7 @@ gfc_resolve_stat_sub (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "stat");
 }
 
 
@@ -3038,7 +3049,7 @@ gfc_resolve_lstat_sub (gfc_code *c)
 {
   const char *name;
   name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "lstat");
 }
 
 
@@ -3054,7 +3065,7 @@ gfc_resolve_fstat_sub (gfc_code *c)
   if (u->ts.kind != ts->kind)
     gfc_convert_type (u, ts, 2);
   name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "fstat");
 }
 
 
@@ -3082,7 +3093,7 @@ gfc_resolve_fgetc_sub (gfc_code *c)
   else
     name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "fgetc");
 }
 
 
@@ -3098,7 +3109,7 @@ gfc_resolve_fget_sub (gfc_code *c)
   else
     name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "fget");
 }
 
 
@@ -3126,7 +3137,7 @@ gfc_resolve_fputc_sub (gfc_code *c)
   else
     name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "fputc");
 }
 
 
@@ -3142,7 +3153,7 @@ gfc_resolve_fput_sub (gfc_code *c)
   else
     name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind);
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "fput");
 }
 
 
@@ -3187,7 +3198,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
       gfc_convert_type (whence, &ts, 2);
     }
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"),
+					          "fseek");
 }
 
 void
@@ -3211,7 +3223,7 @@ gfc_resolve_ftell_sub (gfc_code *c)
     }
 
   name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "ftell");
 }
 
 
@@ -3229,7 +3241,8 @@ gfc_resolve_ttynam_sub (gfc_code *c)
       gfc_convert_type (c->ext.actual->expr, &ts, 2);
     }
 
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"),
+						  "ttynam");
 }
 
 
@@ -3247,7 +3260,7 @@ gfc_resolve_umask_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "umask");
 }
 
 /* Resolve the UNLINK intrinsic subroutine.  */
@@ -3264,5 +3277,5 @@ gfc_resolve_unlink_sub (gfc_code *c)
     kind = gfc_default_integer_kind;
 
   name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name, "unlink");
 }