re PR libfortran/32989 (GETARG intrinsic)

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.

	* gfortran.fortran-torture/execute/getarg_1.f90: Add check for
	non-default integer kind arguments.

From-SVN: r127905
This commit is contained in:
Francois-Xavier Coudert 2007-08-29 15:22:55 +00:00 committed by François-Xavier Coudert
parent c3f07bd6a0
commit ed8315d5fc
8 changed files with 71 additions and 16 deletions

View File

@ -1,3 +1,13 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
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 <fxcoudert@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>

View File

@ -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)
{

View File

@ -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,

View File

@ -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 *,

View File

@ -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

View File

@ -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);
}

View File

@ -1,3 +1,9 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/32989
* gfortran.fortran-torture/execute/getarg_1.f90: Add check for
non-default integer kind arguments.
2007-08-29 Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/33105

View File

@ -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)