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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8d5e19f..f87dc8f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,4 +1,14 @@
 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>
 
        PR fortran/33105

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 634d6b4..ed824fe 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3234,6 +3234,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)
 {
   if (type_check (msg, 0, BT_CHARACTER) == FAILURE)

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 2bc8781..0c5c177 100644 (file)
--- 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 e284a6c..1d2c6c1 100644 (file)
--- 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 d70e819..876015b 100644 (file)
--- 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 7948b14..73f5d73 100644 (file)
--- 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 3c0ce89..8390c4b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/getarg_1.f90
index 2d56686..7189991 100644 (file)
--- 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)