check.c (gfc_check_kill): Check pid and sig are scalar.

2018-03-11  Steven G. Kargl  <kargls@gcc.gnu.org>

	* check.c (gfc_check_kill):  Check pid and sig are scalar.
	(gfc_check_kill_sub): Restrict kind to 4 and 8.
	* intrinsic.c (add_function): Sort keyword list.  Add pid and sig
	keywords for KILL.  Remove redundant *back="back" in favor of the
	original *bck="back".
	(add_subroutines): Sort keyword list.  Add pid and sig keywords
	for KILL.
	* intrinsic.texi: Fix documentation to consistently use pid and sig.
	* iresolve.c (gfc_resolve_kill): Kind can only be 4 or 8.  Choose the
	correct function.
	(gfc_resolve_rename_sub): Add comment.

From-SVN: r258436

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fe8947e61a5680de32fa0f8c11af3d2972899c1e..68e4f38bb8516a2ac24a81c81a845130f7eb55c3 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,18 @@
-2017-06-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
+2018-03-11  Steven G. Kargl  <kargls@gcc.gnu.org>
+
+       * check.c (gfc_check_kill):  Check pid and sig are scalar.
+       (gfc_check_kill_sub): Restrict kind to 4 and 8.
+       * intrinsic.c (add_function): Sort keyword list.  Add pid and sig
+       keywords for KILL.  Remove redundant *back="back" in favor of the
+       original *bck="back".
+       (add_subroutines): Sort keyword list.  Add pid and sig keywords
+       for KILL.
+       * intrinsic.texi: Fix documentation to consistently use pid and sig.
+       * iresolve.c (gfc_resolve_kill): Kind can only be 4 or 8.  Choose the
+       correct function.
+       (gfc_resolve_rename_sub): Add comment.
+
+2018-03-11  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/66128
        * simplify.c (simplify_transformation): Return default result for

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index dbb1aa02111391148e7d2fec8283d419ded39e90..1971db037b19e11e39316080fc1fdd6733d89375 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2755,9 +2755,15 @@ gfc_check_kill (gfc_expr *pid, gfc_expr *sig)
   if (!type_check (pid, 0, BT_INTEGER))
     return false;
 
+  if (!scalar_check (pid, 0))
+    return false;
+
   if (!type_check (sig, 1, BT_INTEGER))
     return false;
 
+  if (!scalar_check (sig, 1))
+    return false;
+
   return true;
 }
 
@@ -2786,6 +2792,13 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
   if (!scalar_check (status, 2))
     return false;
 
+  if (status->ts.kind != 4 && status->ts.kind != 8)
+    {
+      gfc_error ("Invalid kind type parameter for STATUS at %L",
+                &status->where);
+      return false;
+    }
+
   return true;
 }
 

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index a47de4131389f166f187119b0fc5c62553d930be..006b11413540f4ce32069f348d7b96cdd19c3ce4 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1229,25 +1229,26 @@ set_attr_value (int n, ...)
 static void
 add_functions (void)
 {
-  /* Argument names as in the standard (to be used as argument keywords).  */
+  /* Argument names.  These are used as argument keywords and so need to
+    match the documentation.  Please keep this list in sorted order.  */
   const char
-    *a = "a", *f = "field", *pt = "pointer", *tg = "target",
-    *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
-    *c = "c", *n = "n", *ncopies= "ncopies", *pos = "pos", *bck = "back",
-    *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
-    *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
-    *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
-    *p = "p", *ar = "array", *shp = "shape", *src = "source",
-    *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
-    *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
-    *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
-    *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
-    *z = "z", *ln = "len", *ut = "unit", *han = "handler",
-    *num = "number", *tm = "time", *nm = "name", *md = "mode",
-    *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
-    *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed",
-    *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", *back = "back",
-    *team = "team", *image = "image", *level = "level";
+    *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b",
+    *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1",
+    *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command",
+    *dist = "distance", *dm = "dim", *f = "field", *failed="failed",
+    *fs = "fsource", *han = "handler", *i = "i",
+    *image = "image", *j = "j", *kind = "kind",
+    *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a",
+    *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask",
+    *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number",
+    *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2",
+    *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer",
+    *r = "r", *s = "s", *set = "set", *sh = "shift", *shp = "shape",
+    *sig = "sig", *src = "source", *ssg = "substring",
+    *sta = "string_a", *stb = "string_b", *stg = "string",
+    *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time",
+    *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a",
+    *vb = "vector_b", *vl = "values", *x = "x", *y = "y", *z = "z";
 
   int di, dr, dd, dl, dc, dz, ii;
 
@@ -2255,7 +2256,7 @@ add_functions (void)
 
   add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
             di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill,
-            a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
+            pid, BT_INTEGER, di, REQUIRED, sig, BT_INTEGER, di, REQUIRED);
 
   make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
 
@@ -2471,7 +2472,7 @@ add_functions (void)
               gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc,
               ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
               msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL,
-              back, BT_LOGICAL, dl, OPTIONAL);
+              bck, BT_LOGICAL, dl, OPTIONAL);
 
   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
 
@@ -2548,7 +2549,7 @@ add_functions (void)
               gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc,
               ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
               msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL,
-              back, BT_LOGICAL, dl, OPTIONAL);
+              bck, BT_LOGICAL, dl, OPTIONAL);
 
   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
 
@@ -3301,20 +3302,21 @@ add_functions (void)
 static void
 add_subroutines (void)
 {
-  /* Argument names as in the standard (to be used as argument keywords).  */
-  const char
-    *a = "a", *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
-    *c = "count", *tm = "time", *tp = "topos", *gt = "get",
-    *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
-    *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
-    *com = "command", *length = "length", *st = "status",
-    *val = "value", *num = "number", *name = "name",
-    *trim_name = "trim_name", *ut = "unit", *han = "handler",
-    *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
-    *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
-    *p2 = "path2", *msk = "mask", *old = "old", *result_image = "result_image",
-    *stat = "stat", *errmsg = "errmsg";
-
+  /* Argument names.  These are used as argument keywords and so need to
+     match the documentation.  Please keep this list in sorted order.  */
+  static const char
+    *a = "a", *c = "count", *cm = "count_max", *com = "command",
+    *cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from",
+    *fp = "frompos", *gt = "get", *h = "harvest", *han = "handler",
+    *length = "length", *ln = "len", *md = "mode", *msk = "mask",
+    *name = "name", *num = "number", *of = "offset", *old = "old",
+    *p1 = "path1", *p2 = "path2", *pid = "pid", *pos = "pos",
+    *pt = "put", *ptr = "ptr", *res = "result",
+    *result_image = "result_image", *sec = "seconds", *sig = "sig",
+    *st = "status", *stat = "stat", *sz = "size", *t = "to",
+    *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit",
+    *val = "value", *vl = "values", *whence = "whence", *zn = "zone";
+ 
   int di, dr, dc, dl, ii;
 
   di = gfc_default_integer_kind;
@@ -3723,8 +3725,8 @@ add_subroutines (void)
 
   add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
              gfc_check_kill_sub, NULL, gfc_resolve_kill_sub,
-             c, BT_INTEGER, di, REQUIRED, INTENT_IN,
-             val, BT_INTEGER, di, REQUIRED, INTENT_IN,
+             pid, BT_INTEGER, di, REQUIRED, INTENT_IN,
+             sig, BT_INTEGER, di, REQUIRED, INTENT_IN,
              st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
 
   add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,

diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 496b8dad4a7ef4c4444d29fd323b2e948fda9aad..bd77c1ebfc8d6b8ba1e6539ebddcd446c2a9d298 100644 (file)
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -8715,30 +8715,34 @@ end program test_itime
 @table @asis
 @item @emph{Description}:
 @item @emph{Standard}:
-Sends the signal specified by @var{SIGNAL} to the process @var{PID}.
+Sends the signal specified by @var{SIG} to the process @var{PID}.
 See @code{kill(2)}.
 
-This intrinsic is provided in both subroutine and function forms; however,
-only one form can be used in any given program unit.
+This intrinsic is provided in both subroutine and function forms;
+however,  only one form can be used in any given program unit.
 
 @item @emph{Class}:
 Subroutine, function
 
 @item @emph{Syntax}:
 @multitable @columnfractions .80
-@item @code{CALL KILL(C, VALUE [, STATUS])}
-@item @code{STATUS = KILL(C, VALUE)}
+@item @code{CALL KILL(PID, SIG [, STATUS])}
+@item @code{STATUS = KILL(PID, SIG)}
 @end multitable
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
-@item @var{C} @tab Shall be a scalar @code{INTEGER}, with
+@item @var{PID} @tab Shall be a scalar @code{INTEGER} with
 @code{INTENT(IN)}
-@item @var{VALUE} @tab Shall be a scalar @code{INTEGER}, with
+@item @var{SIG} @tab Shall be a scalar @code{INTEGER} with
 @code{INTENT(IN)}
-@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)} or
-@code{INTEGER(8)}. Returns 0 on success, or a system-specific error code
-otherwise.
+@item @var{STATUS} @tab [Subroutine](Optional) status flag of type
+@code{INTEGER(4)} or @code{INTEGER(8)}.
+Returns 0 on success; otherwise a system-specific error code is returned.
+@item @var{STATUS} @tab [Function] The kind type parameter is that of
+@code{pid} if @code{pid} is of type @code{INTEGER(4)} or @code{INTEGER(8)};
+otherwise, it is default integer kind.
+Returns 0 on success; otherwise a system-specific error code is returned.
 @end multitable
 
 @item @emph{See also}:
@@ -8746,7 +8750,6 @@ otherwise.
 @end table
 
 
-
 @node KIND
 @section @code{KIND} --- Kind of an entity
 @fnindex KIND

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 21344321709469dd2944778fb4da85d5da0fbda2..f2208b4c2cf7f8135f1a6ec4026faf8a97c36a5e 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1492,11 +1492,14 @@ gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size)
 
 
 void
-gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
-                 gfc_expr *s ATTRIBUTE_UNUSED)
+gfc_resolve_kill (gfc_expr *f, gfc_expr *pid,
+                 gfc_expr *sig ATTRIBUTE_UNUSED)
 {
   f->ts.type = BT_INTEGER;
-  f->ts.kind = gfc_default_integer_kind;
+  if (pid->ts.kind == 4 || pid->ts.kind == 8)
+    f->ts.kind = pid->ts.kind;
+  else
+    f->ts.kind = gfc_default_integer_kind;
   f->value.function.name = gfc_get_string (PREFIX ("kill_i%d"), f->ts.kind);
 }
 
@@ -3446,6 +3449,7 @@ gfc_resolve_rename_sub (gfc_code *c)
   const char *name;
   int kind;
 
+  /* Find the type of status.  If not present use default integer kind.  */
   if (c->ext.actual->next->next->expr != NULL)
     kind = c->ext.actual->next->next->expr->ts.kind;
   else