This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR40039: Procedures as actual arguments: Check intent of arguments
- From: Janus Weil <janus at gcc dot gnu dot org>
- To: gfortran <fortran at gcc dot gnu dot org>, gcc patches <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 14 May 2009 23:16:16 +0200
- Subject: [Patch, Fortran] PR40039: Procedures as actual arguments: Check intent of arguments
Hi all,
here is my fix for PR40039, which checks the intent of arguments for
procedure pointer assignments and procedures as actual arguments.
The F03 standard says in section 12.4.1.3:
If the interface of the dummy argument is explicit, the
characteristics listed in 12.2 shall be the same
for the associated actual argument and the corresponding dummy
argument, except that a pure actual
argument may be associated with a dummy argument that is not pure
and an elemental intrinsic actual
procedure may be associated with a dummy procedure (which is
prohibited from being elemental).
In section 12.2 one can read that the "characteristics" of a procedure
also include the intent of its dummy arguments.
The biggest part of the patch is actually devoted to adding intents to
intrinsic procedure interfaces (where they have been completely
neglected before). The F03 standard notes that almost all the
intrinsics have only intent(in)-arguments, with a few exceptions:
1) CPU_TIME
2) DATE_AND_TIME
3) GET_COMMAND
4) GET_COMMAND_ARGUMENT
5) GET_ENVIRONMENT_VARIABLE
6) MOVE_ALLOC
7) MVBITS
8) PRESENT
9) RANDOM_NUMBER
10) RANDOM_SEED
11) SYSTEM_CLOCK
I added the right intents for these, and intent(in) for the rest. Note
that I didn' take care of the various GNU extensions yet (apart from
'fseek', which is the only GNU extension subroutine with 4 arguments),
which means that all their arguments are specified as intent(in) with
the patch. I propose to fix this later, since it is potentially a lot
of work to look through all the extensions and set the correct
intents, especially since not all the intents may be explicitly
mentioned in the gfortran documentation. Problems are only expected if
these extended intrinsics (with an intent other than intent(in)) are
used as an actual argument or in a procedure pointer assignment.
Apart from the issues with intrinsics, the patch is actually rather
straightforward. Regression-tested on x86_64-unknown-linux-gnu. Ok for
trunk?
Cheers,
Janus
2009-05-14 Janus Weil <janus@gcc.gnu.org>
PR fortran/40039
* expr.c (gfc_check_pointer_assign): Check intents when comparing
interfaces.
* gfortran.h (typedef struct gfc_intrinsic_arg): Add 'intent' member.
(gfc_compare_interfaces): Additional argument.
* interface.c (operator_correspondence): Add check for equality of
intents, and new argument 'intent_check'.
(gfc_compare_interfaces): New argument 'intent_check', which is passed
on to operator_correspondence.
(check_interface1): Don't check intents when comparing interfaces.
(compare_parameter): Do check intents when comparing interfaces.
* intrinsic.c (add_sym): Add intents for arguments of intrinsic
procedures.
(add_sym_1,add_sym_1s,add_sym_1m,add_sym_2,add_sym_2s,add_sym_3,
add_sym_3ml,add_sym_3red,add_sym_3s,add_sym_4): Use INTENT_IN by
default.
(add_sym_1_intent,add_sym_1s_intent,add_sym_2s_intent,add_sym_3s_intent)
: New functions to add intrinsic symbols, specifying custom intents.
(add_sym_4s,add_sym_5s): Add new arguments to specify intents.
(add_functions,add_subroutines): Add intents for various intrinsics.
* resolve.c (check_generic_tbp_ambiguity): Don't check intents when
comparing interfaces.
* symbol.c (gfc_copy_formal_args_intr): Copy intent.
2009-05-14 Janus Weil <janus@gcc.gnu.org>
PR fortran/40039
* gfortran.dg/interface_27.f90: New.
* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
* gfortran.dg/proc_ptr_result_1.f90: Ditto.
Index: gcc/testsuite/gfortran.dg/proc_ptr_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (revision 147527)
+++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (working copy)
@@ -23,6 +23,7 @@ program bsp
interface
function p3(x)
real(8) :: p3,x
+ intent(in) :: x
end function p3
end interface
Index: gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 (revision 147527)
+++ gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 (working copy)
@@ -114,7 +114,7 @@ contains
pointer :: f
interface
integer function f(x)
- integer :: x
+ integer,intent(in) :: x
end function
end interface
f => iabs
@@ -123,7 +123,7 @@ contains
function g()
interface
integer function g(x)
- integer :: x
+ integer,intent(in) :: x
end function g
end interface
pointer :: g
@@ -133,13 +133,13 @@ contains
function h(arg)
interface
subroutine arg(b)
- integer :: b
+ integer,intent(inout) :: b
end subroutine arg
end interface
pointer :: h
interface
subroutine h(a)
- integer :: a
+ integer,intent(inout) :: a
end subroutine h
end interface
h => arg
@@ -150,6 +150,7 @@ contains
interface
function i(x)
integer :: i,x
+ intent(in) :: x
end function i
end interface
i => iabs
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 147527)
+++ gcc/fortran/interface.c (working copy)
@@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1
which makes this test much easier than that for generic tests.
This subroutine is also used when comparing a formal and actual
- argument list when an actual parameter is a dummy procedure. At
- that point, two formal interfaces must be compared for equality
- which is what happens here. */
+ argument list when an actual parameter is a dummy procedure, and in
+ procedure pointer assignments. In these cases, two formal interfaces must be
+ compared for equality which is what happens here. 'intent_flag' specifies
+ whether the intents of the arguments are required to match, which is not the
+ case for ambiguity checks. */
static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
+operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
+ int intent_flag)
{
for (;;)
{
+ /* Check existence. */
if (f1 == NULL && f2 == NULL)
break;
if (f1 == NULL || f2 == NULL)
return 1;
+ /* Check type and rank. */
if (!compare_type_rank (f1->sym, f2->sym))
return 1;
+ /* Check intent. */
+ if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+ return 1;
+
f1 = f1->next;
f2 = f2->next;
}
@@ -961,7 +970,8 @@ generic_correspondence (gfc_formal_argli
would be ambiguous between the two interfaces, zero otherwise. */
int
-gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag,
+ int intent_flag)
{
gfc_formal_arglist *f1, *f2;
@@ -1001,7 +1011,7 @@ gfc_compare_interfaces (gfc_symbol *s1,
}
else
{
- if (operator_correspondence (f1, f2))
+ if (operator_correspondence (f1, f2, intent_flag))
return 0;
}
@@ -1080,7 +1090,7 @@ check_interface1 (gfc_interface *p, gfc_
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
+ if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0))
{
if (referenced)
{
@@ -1362,7 +1372,7 @@ compare_parameter (gfc_symbol *formal, g
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */
- if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
+ if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0, 1))
goto proc_fail;
return 1;
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 147527)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -227,11 +227,12 @@ do_check (gfc_intrinsic_sym *specific, g
simplify pointer to simplification function
resolve pointer to resolution function
- Optional arguments come in multiples of four:
- char * name of argument
- bt type of argument
- int kind of argument
- int arg optional flag (1=optional, 0=required)
+ Optional arguments come in multiples of five:
+ char * name of argument
+ bt type of argument
+ int kind of argument
+ int arg optional flag (1=optional, 0=required)
+ sym_intent intent of argument
The sequence is terminated by a NULL name.
@@ -249,6 +250,7 @@ add_sym (const char *name, gfc_isym_id i
{
char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */
int optional, first_flag;
+ sym_intent intent;
va_list argp;
switch (sizing)
@@ -301,6 +303,7 @@ add_sym (const char *name, gfc_isym_id i
type = (bt) va_arg (argp, int);
kind = va_arg (argp, int);
optional = va_arg (argp, int);
+ intent = va_arg (argp, int);
if (sizing != SZ_NOTHING)
nargs++;
@@ -319,6 +322,7 @@ add_sym (const char *name, gfc_isym_id i
next_arg->ts.type = type;
next_arg->ts.kind = kind;
next_arg->optional = optional;
+ next_arg->intent = intent;
}
}
@@ -390,7 +394,7 @@ add_sym_1 (const char *name, gfc_isym_id
rf.f1 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
+ a1, type1, kind1, optional1, INTENT_IN,
(void *) 0);
}
@@ -414,7 +418,56 @@ add_sym_1s (const char *name, gfc_isym_i
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
+ a1, type1, kind1, optional1, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the function list where the function takes
+ 1 arguments, specifying the intent of the argument. */
+
+static void
+add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
+ int kind, int standard,
+ gfc_try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_expr *, gfc_expr *),
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f1 = check;
+ sf.f1 = simplify;
+ rf.f1 = resolve;
+
+ add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 1 arguments, specifying the intent of the argument. */
+
+static void
+add_sym_1s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
+ gfc_try (*check) (gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f1 = check;
+ sf.f1 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
(void *) 0);
}
@@ -440,8 +493,8 @@ add_sym_1m (const char *name, gfc_isym_i
rf.f1m = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
(void *) 0);
}
@@ -467,8 +520,8 @@ add_sym_2 (const char *name, gfc_isym_id
rf.f2 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
(void *) 0);
}
@@ -493,8 +546,34 @@ add_sym_2s (const char *name, gfc_isym_i
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 2 arguments, specifying the intent of the arguments. */
+
+static void
+add_sym_2s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
+ gfc_try (*check) (gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1,
+ const char *a2, bt type2, int kind2, int optional2, sym_intent intent2)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f2 = check;
+ sf.f2 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
(void *) 0);
}
@@ -521,9 +600,9 @@ add_sym_3 (const char *name, gfc_isym_id
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -550,9 +629,9 @@ add_sym_3ml (const char *name, gfc_isym_
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -579,9 +658,9 @@ add_sym_3red (const char *name, gfc_isym
rf.f3 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
(void *) 0);
}
@@ -607,9 +686,37 @@ add_sym_3s (const char *name, gfc_isym_i
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
+ (void *) 0);
+}
+
+
+/* Add a symbol to the subroutine list where the subroutine takes
+ 3 arguments, specifying the intent of the arguments. */
+
+static void
+add_sym_3s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
+ gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
+ gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
+ void (*resolve) (gfc_code *),
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1,
+ const char *a2, bt type2, int kind2, int optional2, sym_intent intent2,
+ const char *a3, bt type3, int kind3, int optional3, sym_intent intent3)
+{
+ gfc_check_f cf;
+ gfc_simplify_f sf;
+ gfc_resolve_f rf;
+
+ cf.f3 = check;
+ sf.f3 = simplify;
+ rf.s1 = resolve;
+
+ add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
(void *) 0);
}
@@ -639,10 +746,10 @@ add_sym_4 (const char *name, gfc_isym_id
rf.f4 = resolve;
add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
+ a1, type1, kind1, optional1, INTENT_IN,
+ a2, type2, kind2, optional2, INTENT_IN,
+ a3, type3, kind3, optional3, INTENT_IN,
+ a4, type4, kind4, optional4, INTENT_IN,
(void *) 0);
}
@@ -656,10 +763,10 @@ add_sym_4s (const char *name, gfc_isym_i
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *),
void (*resolve) (gfc_code *),
- const char *a1, bt type1, int kind1, int optional1,
- const char *a2, bt type2, int kind2, int optional2,
- const char *a3, bt type3, int kind3, int optional3,
- const char *a4, bt type4, int kind4, int optional4)
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1,
+ const char *a2, bt type2, int kind2, int optional2, sym_intent intent2,
+ const char *a3, bt type3, int kind3, int optional3, sym_intent intent3,
+ const char *a4, bt type4, int kind4, int optional4, sym_intent intent4)
{
gfc_check_f cf;
gfc_simplify_f sf;
@@ -670,10 +777,10 @@ add_sym_4s (const char *name, gfc_isym_i
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
+ a4, type4, kind4, optional4, intent4,
(void *) 0);
}
@@ -688,11 +795,11 @@ add_sym_5s (const char *name, gfc_isym_i
gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *, gfc_expr *),
void (*resolve) (gfc_code *),
- const char *a1, bt type1, int kind1, int optional1,
- const char *a2, bt type2, int kind2, int optional2,
- const char *a3, bt type3, int kind3, int optional3,
- const char *a4, bt type4, int kind4, int optional4,
- const char *a5, bt type5, int kind5, int optional5)
+ const char *a1, bt type1, int kind1, int optional1, sym_intent intent1,
+ const char *a2, bt type2, int kind2, int optional2, sym_intent intent2,
+ const char *a3, bt type3, int kind3, int optional3, sym_intent intent3,
+ const char *a4, bt type4, int kind4, int optional4, sym_intent intent4,
+ const char *a5, bt type5, int kind5, int optional5, sym_intent intent5)
{
gfc_check_f cf;
gfc_simplify_f sf;
@@ -703,11 +810,11 @@ add_sym_5s (const char *name, gfc_isym_i
rf.s1 = resolve;
add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
- a1, type1, kind1, optional1,
- a2, type2, kind2, optional2,
- a3, type3, kind3, optional3,
- a4, type4, kind4, optional4,
- a5, type5, kind5, optional5,
+ a1, type1, kind1, optional1, intent1,
+ a2, type2, kind2, optional2, intent2,
+ a3, type3, kind3, optional3, intent3,
+ a4, type4, kind4, optional4, intent4,
+ a5, type5, kind5, optional5, intent5,
(void *) 0);
}
@@ -2100,9 +2207,9 @@ add_functions (void)
make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
- add_sym_1 ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
+ add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
gfc_check_present, NULL, NULL,
- a, BT_REAL, dr, REQUIRED);
+ a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
@@ -2505,9 +2612,9 @@ add_subroutines (void)
make_noreturn();
- add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
+ add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
- tm, BT_REAL, dr, REQUIRED);
+ tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2545,8 +2652,10 @@ add_subroutines (void)
add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_date_and_time, NULL, NULL,
- dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
- zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
+ dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2584,46 +2693,52 @@ add_subroutines (void)
/* F2003 commandline routines. */
- add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
+ add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_command,
- com, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL,
- st, BT_INTEGER, di, OPTIONAL);
+ com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_command_argument,
- num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
+ num, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* F2003 subroutine to get environment variables. */
add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_environment_variable,
- name, BT_CHARACTER, dc, REQUIRED,
- val, BT_CHARACTER, dc, OPTIONAL,
- length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
- trim_name, BT_LOGICAL, dl, OPTIONAL);
+ name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
+ length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
- add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
+ add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
gfc_check_move_alloc, NULL, NULL,
- f, BT_UNKNOWN, 0, REQUIRED,
- t, BT_UNKNOWN, 0, REQUIRED);
+ f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
+ t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
- f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
- ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
- tp, BT_INTEGER, di, REQUIRED);
+ f, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+ tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
- add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
+ add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_random_number, NULL, gfc_resolve_random_number,
- h, BT_REAL, dr, REQUIRED);
+ h, BT_REAL, dr, REQUIRED, INTENT_OUT);
- add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
+ add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_random_seed, NULL, gfc_resolve_random_seed,
- sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
- gt, BT_INTEGER, di, OPTIONAL);
+ sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
@@ -2668,8 +2783,10 @@ add_subroutines (void)
add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
- ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, di, REQUIRED,
- whence, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
+ ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ of, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
+ st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
@@ -2730,10 +2847,11 @@ add_subroutines (void)
NULL, NULL, gfc_resolve_system_sub,
com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
- add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
+ add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
- c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
- cm, BT_INTEGER, di, OPTIONAL);
+ c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 147528)
+++ gcc/fortran/symbol.c (working copy)
@@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *d
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.intent = curr_arg->intent;
formal_arg->sym->attr.flavor = FL_VARIABLE;
formal_arg->sym->attr.dummy = 1;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 147527)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1445,6 +1445,7 @@ typedef struct gfc_intrinsic_arg
gfc_typespec ts;
int optional;
+ ENUM_BITFIELD (sym_intent) intent:2;
gfc_actual_arglist *actual;
struct gfc_intrinsic_arg *next;
@@ -2562,7 +2563,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_re
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
-int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 147527)
+++ gcc/fortran/expr.c (working copy)
@@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lval
return SUCCESS;
if (rvalue->expr_type == EXPR_VARIABLE
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0))
+ rvalue->symtree->n.sym, 0, 1))
{
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 147527)
+++ gcc/fortran/resolve.c (working copy)
@@ -8563,7 +8563,7 @@ check_generic_tbp_ambiguity (gfc_tbp_gen
}
/* Compare the interfaces. */
- if (gfc_compare_interfaces (sym1, sym2, 1))
+ if (gfc_compare_interfaces (sym1, sym2, 1, 0))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
! { dg-do compile }
!
! PR 40039: Procedures as actual arguments: Check intent of arguments
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
module m
contains
subroutine a(x,f)
real :: x
interface
real function f(y)
real,intent(in) :: y
end function
end interface
print *,f(x)
end subroutine
real function func(z)
real,intent(inout) :: z
func = z**2
end function
subroutine caller
interface
real function p(y)
real,intent(in) :: y
end function
end interface
pointer :: p
call a(4.3,func) ! { dg-error "Type/rank mismatch in argument" }
p => func ! { dg-error "Interfaces don't match in procedure pointer assignment" }
end subroutine
end module
! { dg-final { cleanup-modules "m" } }