diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8d5e19fe7a2..f87dc8fba88 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2007-08-29 Francois-Xavier Coudert + + PR fortran/32989 + * iresolve.c (gfc_resolve_getarg): Handle non-default integer + kinds. + * check.c (gfc_check_getarg): New function + * intrinsic.h: Add prototype for gfc_check_getarg. + * intrinsic.c (add_subroutines): Add reference to gfc_check_getarg. + * intrinsic.texi (GETARG): Adjust documentation. + 2007-08-29 Francois-Xavier Coudert Tobias Burnus diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 634d6b4f05b..ed824feb6a5 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3233,6 +3233,28 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) } +try +gfc_check_getarg (gfc_expr *pos, gfc_expr *value) +{ + if (type_check (pos, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (pos->ts.kind > gfc_default_integer_kind) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be of a kind " + "not wider than the default kind (%d)", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + &pos->where, gfc_default_integer_kind); + return FAILURE; + } + + if (type_check (value, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + try gfc_check_getlog (gfc_expr *msg) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 2bc8781de34..0c5c1773332 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2377,7 +2377,7 @@ add_subroutines (void) *val = "value", *num = "number", *name = "name", *trim_name = "trim_name", *ut = "unit", *han = "handler", *sec = "seconds", *res = "result", *of = "offset", *md = "mode", - *whence = "whence"; + *whence = "whence", *pos = "pos"; int di, dr, dc, dl, ii; @@ -2461,8 +2461,8 @@ add_subroutines (void) REQUIRED); add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, - NULL, NULL, gfc_resolve_getarg, - c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED); + gfc_check_getarg, NULL, gfc_resolve_getarg, + pos, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, REQUIRED); add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index e284a6c7177..1d2c6c1ab6b 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -154,6 +154,7 @@ try gfc_check_flush (gfc_expr *); try gfc_check_free (gfc_expr *); try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_gerror (gfc_expr *); +try gfc_check_getarg (gfc_expr *, gfc_expr *); try gfc_check_getlog (gfc_expr *); try gfc_check_move_alloc (gfc_expr *, gfc_expr *); try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index d70e819c45f..876015b4f87 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -4609,21 +4609,22 @@ GNU extension Subroutine @item @emph{Syntax}: -@code{CALL GETARG(N, ARG)} +@code{CALL GETARG(POS, VALUE)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{N} @tab Shall be of type @code{INTEGER(4)}, @math{@var{N} \geq 0} -@item @var{ARG} @tab Shall be of type @code{CHARACTER(*)}. +@item @var{POS} @tab Shall be of type @code{INTEGER} and not wider than +the default integer kind; @math{@var{POS} \geq 0} +@item @var{VALUE} @tab Shall be of type @code{CHARACTER(*)}. @end multitable @item @emph{Return value}: -After @code{GETARG} returns, the @var{ARG} argument holds the @var{N}th -command line argument. If @var{ARG} can not hold the argument, it is -truncated to fit the length of @var{ARG}. If there are less than @var{N} -arguments specified at the command line, @var{ARG} will be filled with blanks. -If @math{@var{N} = 0}, @var{ARG} is set to the name of the program (on systems -that support this feature). +After @code{GETARG} returns, the @var{VALUE} argument holds the +@var{POS}th command line argument. If @var{VALUE} can not hold the +argument, it is truncated to fit the length of @var{VALUE}. If there are +less than @var{POS} arguments specified at the command line, @var{VALUE} +will be filled with blanks. If @math{@var{POS} = 0}, @var{VALUE} is set +to the name of the program (on systems that support this feature). @item @emph{Example}: @smallexample diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 7948b14eeb9..73f5d73bc45 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -2675,9 +2675,18 @@ void gfc_resolve_getarg (gfc_code *c) { const char *name; - int kind; - kind = gfc_default_integer_kind; - name = gfc_get_string (PREFIX ("getarg_i%d"), kind); + + if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind) + { + gfc_typespec ts; + + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3c0ce8931d0..8390c4b67fe 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-08-29 Francois-Xavier Coudert + + PR fortran/32989 + * gfortran.fortran-torture/execute/getarg_1.f90: Add check for + non-default integer kind arguments. + 2007-08-29 Tobias Burnus PR fortran/33105 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 index 2d566862d2d..7189991f7eb 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 @@ -1,12 +1,18 @@ ! Check that getarg does somethig sensible. program getarg_1 - CHARACTER*10 ARGS + CHARACTER*10 ARGS, ARGS2 INTEGER*4 I + INTEGER*2 I2 I = 0 CALL GETARG(I,ARGS) ! This should return the invoking command. The actual value depends ! on the OS, but a blank string is wrong no matter what. ! ??? What about deep embedded systems? + + I2 = 0 + CALL GETARG(I2,ARGS2) + if (args2.ne.args) call abort + if (args.eq.'') call abort I = 1 CALL GETARG(I,ARGS)