From: Steven G. Kargl Date: Sun, 11 Mar 2018 21:34:40 +0000 (+0000) Subject: check.c (gfc_check_kill): Check pid and sig are scalar. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fbe1f017435875f9bfd29d250b4ba2eaf4c79047;p=gcc.git check.c (gfc_check_kill): Check pid and sig are scalar. 2018-03-11 Steven G. Kargl * 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 fe8947e61a5..68e4f38bb85 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,4 +1,18 @@ -2017-06-11 Thomas Koenig +2018-03-11 Steven G. Kargl + + * 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 PR fortran/66128 * simplify.c (simplify_transformation): Return default result for diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index dbb1aa02111..1971db037b1 100644 --- 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 a47de413138..006b1141354 100644 --- 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 496b8dad4a7..bd77c1ebfc8 100644 --- 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 21344321709..f2208b4c2cf 100644 --- 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