re PR fortran/36947 (Attributes not fully checked comparing actual vs dummy procedure)
2009-05-18 Janus Weil <janus@gcc.gnu.org> PR fortran/36947 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-18 Janus Weil <janus@gcc.gnu.org> PR fortran/36947 PR fortran/40039 * gfortran.dg/interface_27.f90: New. * gfortran.dg/interface_28.f90: New. * gfortran.dg/proc_ptr_11.f90: Fixing invalid test case. * gfortran.dg/proc_ptr_result_1.f90: Ditto. From-SVN: r147655
This commit is contained in:
Janus Weil
parent
75df395f15
commit
23e38561c5
|
|
@ -1,3 +1,30 @@
|
|||
2009-05-18 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/36947
|
||||
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-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32,
|
||||
|
|
|
|||
|
|
@ -3176,7 +3176,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
|
|||
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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
@ -2566,7 +2567,7 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *);
|
|||
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,
|
||||
|
|
|
|||
|
|
@ -873,23 +873,32 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
|
|||
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_arglist *f1, gfc_formal_arglist *f2)
|
|||
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, gfc_symbol *s2, int generic_flag)
|
|||
}
|
||||
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_interface *q0,
|
|||
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, gfc_expr *actual,
|
|||
|| 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;
|
||||
|
|
|
|||
|
|
@ -227,11 +227,12 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
|
|||
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 id, enum klass cl, int actual_ok, bt type
|
|||
{
|
||||
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 id, enum klass cl, int actual_ok, bt type
|
|||
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 id, enum klass cl, int actual_ok, bt type
|
|||
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 id, enum klass cl, int actual_ok, bt ty
|
|||
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,59 @@ add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
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 +496,8 @@ add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt t
|
|||
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 +523,8 @@ add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
|
|||
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 +549,36 @@ add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
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 +605,9 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
|
|||
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 +634,9 @@ add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
|
|||
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 +663,9 @@ add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt
|
|||
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 +691,39 @@ add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
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 +753,10 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
|
|||
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);
|
||||
}
|
||||
|
||||
|
|
@ -651,15 +765,17 @@ add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
|
|||
4 arguments. */
|
||||
|
||||
static void
|
||||
add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
|
||||
add_sym_4s (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 *),
|
||||
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)
|
||||
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 +786,10 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
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);
|
||||
}
|
||||
|
||||
|
|
@ -682,17 +798,20 @@ add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
5 arguments. */
|
||||
|
||||
static void
|
||||
add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
|
||||
add_sym_5s (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 *,
|
||||
gfc_expr *),
|
||||
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)
|
||||
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 +822,11 @@ add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
|
|||
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);
|
||||
}
|
||||
|
||||
|
|
@ -2102,9 +2221,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,
|
||||
gfc_check_present, NULL, NULL,
|
||||
a, BT_REAL, dr, REQUIRED);
|
||||
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, INTENT_UNKNOWN);
|
||||
|
||||
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
|
||||
|
||||
|
|
@ -2508,9 +2627,10 @@ add_subroutines (void)
|
|||
|
||||
make_noreturn();
|
||||
|
||||
add_sym_1s ("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);
|
||||
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, INTENT_OUT);
|
||||
|
||||
/* More G77 compatibility garbage. */
|
||||
add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
|
|
@ -2546,10 +2666,12 @@ add_subroutines (void)
|
|||
name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
|
||||
st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
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);
|
||||
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, 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,
|
||||
|
|
@ -2587,46 +2709,56 @@ add_subroutines (void)
|
|||
|
||||
/* F2003 commandline routines. */
|
||||
|
||||
add_sym_3s ("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);
|
||||
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, 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);
|
||||
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, 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,
|
||||
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,
|
||||
gfc_check_move_alloc, NULL, NULL,
|
||||
f, BT_UNKNOWN, 0, REQUIRED,
|
||||
t, BT_UNKNOWN, 0, REQUIRED);
|
||||
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, 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);
|
||||
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, 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,
|
||||
gfc_check_random_number, NULL, gfc_resolve_random_number,
|
||||
h, BT_REAL, dr, REQUIRED);
|
||||
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, INTENT_OUT);
|
||||
|
||||
add_sym_3s ("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);
|
||||
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, 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,
|
||||
|
|
@ -2672,8 +2804,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,
|
||||
|
|
@ -2734,10 +2868,12 @@ 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,
|
||||
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
|
||||
c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
|
||||
cm, BT_INTEGER, di, OPTIONAL);
|
||||
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, 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,
|
||||
|
|
|
|||
|
|
@ -8585,7 +8585,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
|
|||
}
|
||||
|
||||
/* 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);
|
||||
|
|
|
|||
|
|
@ -3914,6 +3914,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
|
|||
/* 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;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
2009-05-18 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/36947
|
||||
PR fortran/40039
|
||||
* gfortran.dg/interface_27.f90: New.
|
||||
* gfortran.dg/interface_28.f90: New.
|
||||
* gfortran.dg/proc_ptr_11.f90: Fixing invalid test case.
|
||||
* gfortran.dg/proc_ptr_result_1.f90: Ditto.
|
||||
|
||||
2009-05-18 Maxim Kuvyrkov <maxim@codesourcery.com>
|
||||
|
||||
* gcc.target/m68k/tls-ie.c: New test.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,41 @@
|
|||
! { 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" } }
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 36947: Attributes not fully checked comparing actual vs dummy procedure
|
||||
!
|
||||
! Contributed by Walter Spector <w6ws@earthlink.net>
|
||||
|
||||
module testsub
|
||||
contains
|
||||
subroutine test(sub)
|
||||
interface
|
||||
subroutine sub(x)
|
||||
integer, intent(in), optional:: x
|
||||
end subroutine
|
||||
end interface
|
||||
print *, "In test(), about to call sub()"
|
||||
call sub()
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
module sub
|
||||
contains
|
||||
subroutine subActual(x)
|
||||
! actual subroutine's argment is different in intent and optional
|
||||
integer, intent(inout):: x
|
||||
print *, "In subActual():", x
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
program interfaceCheck
|
||||
use testsub
|
||||
use sub
|
||||
|
||||
integer :: a
|
||||
|
||||
call test(subActual) ! { dg-error "Type/rank mismatch in argument" }
|
||||
end program
|
||||
|
||||
! { dg-final { cleanup-modules "sub testsub" } }
|
||||
|
||||
|
|
@ -23,6 +23,7 @@ program bsp
|
|||
interface
|
||||
function p3(x)
|
||||
real(8) :: p3,x
|
||||
intent(in) :: x
|
||||
end function p3
|
||||
end interface
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue