Commit ed8315d5 by Francois-Xavier Coudert Committed by François-Xavier Coudert

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
parent c3f07bd6
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> 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> Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/33105 PR fortran/33105
......
...@@ -3234,6 +3234,28 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) ...@@ -3234,6 +3234,28 @@ gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status)
try 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) gfc_check_getlog (gfc_expr *msg)
{ {
if (type_check (msg, 0, BT_CHARACTER) == FAILURE) if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
......
...@@ -2377,7 +2377,7 @@ add_subroutines (void) ...@@ -2377,7 +2377,7 @@ add_subroutines (void)
*val = "value", *num = "number", *name = "name", *val = "value", *num = "number", *name = "name",
*trim_name = "trim_name", *ut = "unit", *han = "handler", *trim_name = "trim_name", *ut = "unit", *han = "handler",
*sec = "seconds", *res = "result", *of = "offset", *md = "mode", *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
*whence = "whence"; *whence = "whence", *pos = "pos";
int di, dr, dc, dl, ii; int di, dr, dc, dl, ii;
...@@ -2461,8 +2461,8 @@ add_subroutines (void) ...@@ -2461,8 +2461,8 @@ add_subroutines (void)
REQUIRED); REQUIRED);
add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getarg, gfc_check_getarg, NULL, gfc_resolve_getarg,
c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED); 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, 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, gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
......
...@@ -154,6 +154,7 @@ try gfc_check_flush (gfc_expr *); ...@@ -154,6 +154,7 @@ try gfc_check_flush (gfc_expr *);
try gfc_check_free (gfc_expr *); try gfc_check_free (gfc_expr *);
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_gerror (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_getlog (gfc_expr *);
try gfc_check_move_alloc (gfc_expr *, gfc_expr *); try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
......
...@@ -4609,21 +4609,22 @@ GNU extension ...@@ -4609,21 +4609,22 @@ GNU extension
Subroutine Subroutine
@item @emph{Syntax}: @item @emph{Syntax}:
@code{CALL GETARG(N, ARG)} @code{CALL GETARG(POS, VALUE)}
@item @emph{Arguments}: @item @emph{Arguments}:
@multitable @columnfractions .15 .70 @multitable @columnfractions .15 .70
@item @var{N} @tab Shall be of type @code{INTEGER(4)}, @math{@var{N} \geq 0} @item @var{POS} @tab Shall be of type @code{INTEGER} and not wider than
@item @var{ARG} @tab Shall be of type @code{CHARACTER(*)}. the default integer kind; @math{@var{POS} \geq 0}
@item @var{VALUE} @tab Shall be of type @code{CHARACTER(*)}.
@end multitable @end multitable
@item @emph{Return value}: @item @emph{Return value}:
After @code{GETARG} returns, the @var{ARG} argument holds the @var{N}th After @code{GETARG} returns, the @var{VALUE} argument holds the
command line argument. If @var{ARG} can not hold the argument, it is @var{POS}th command line argument. If @var{VALUE} can not hold the
truncated to fit the length of @var{ARG}. If there are less than @var{N} argument, it is truncated to fit the length of @var{VALUE}. If there are
arguments specified at the command line, @var{ARG} will be filled with blanks. less than @var{POS} arguments specified at the command line, @var{VALUE}
If @math{@var{N} = 0}, @var{ARG} is set to the name of the program (on systems will be filled with blanks. If @math{@var{POS} = 0}, @var{VALUE} is set
that support this feature). to the name of the program (on systems that support this feature).
@item @emph{Example}: @item @emph{Example}:
@smallexample @smallexample
......
...@@ -2675,9 +2675,18 @@ void ...@@ -2675,9 +2675,18 @@ void
gfc_resolve_getarg (gfc_code *c) gfc_resolve_getarg (gfc_code *c)
{ {
const char *name; const char *name;
int kind;
kind = gfc_default_integer_kind; if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
name = gfc_get_string (PREFIX ("getarg_i%d"), 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); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
} }
......
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> 2007-08-29 Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/33105 PR fortran/33105
! Check that getarg does somethig sensible. ! Check that getarg does somethig sensible.
program getarg_1 program getarg_1
CHARACTER*10 ARGS CHARACTER*10 ARGS, ARGS2
INTEGER*4 I INTEGER*4 I
INTEGER*2 I2
I = 0 I = 0
CALL GETARG(I,ARGS) CALL GETARG(I,ARGS)
! This should return the invoking command. The actual value depends ! This should return the invoking command. The actual value depends
! on the OS, but a blank string is wrong no matter what. ! on the OS, but a blank string is wrong no matter what.
! ??? What about deep embedded systems? ! ??? What about deep embedded systems?
I2 = 0
CALL GETARG(I2,ARGS2)
if (args2.ne.args) call abort
if (args.eq.'') call abort if (args.eq.'') call abort
I = 1 I = 1
CALL GETARG(I,ARGS) CALL GETARG(I,ARGS)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment