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:
parent
c3f07bd6a0
commit
ed8315d5fc
@ -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>
|
||||
|
||||
|
@ -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)
|
||||
{
|
||||
|
@ -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,
|
||||
|
@ -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 *,
|
||||
|
@ -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
|
||||
|
@ -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);
|
||||
}
|
||||
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user