From 23e38561c5027f1c94174df94996837a11cb7c51 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Mon, 18 May 2009 11:19:20 +0200 Subject: [PATCH] re PR fortran/36947 (Attributes not fully checked comparing actual vs dummy procedure) 2009-05-18 Janus Weil 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 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 --- gcc/fortran/ChangeLog | 27 ++ gcc/fortran/expr.c | 2 +- gcc/fortran/gfortran.h | 3 +- gcc/fortran/interface.c | 26 +- gcc/fortran/intrinsic.c | 332 ++++++++++++------ gcc/fortran/resolve.c | 2 +- gcc/fortran/symbol.c | 1 + gcc/testsuite/ChangeLog | 9 + gcc/testsuite/gfortran.dg/interface_27.f90 | 41 +++ gcc/testsuite/gfortran.dg/interface_28.f90 | 39 ++ gcc/testsuite/gfortran.dg/proc_ptr_11.f90 | 1 + .../gfortran.dg/proc_ptr_result_1.f90 | 9 +- 12 files changed, 379 insertions(+), 113 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/interface_27.f90 create mode 100644 gcc/testsuite/gfortran.dg/interface_28.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a9409f3640f..a47a3eeb7f7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2009-05-18 Janus Weil + + 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 * iso-fortran-env.def: Define INT8, INT16, INT32, INT64, REAL32, diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index feaa6254840..2c70ba6bb98 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index abde778a6b8..8ed05f2d6dd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f2d14657f06..48c026cb2fe 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 99cf7a94332..5d2747a1526 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); - - 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_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_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_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); + 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_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, 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_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_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, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 836aeb046ac..d3097c4ef7f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 81473a420bf..326d73e3ebf 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 994360be60b..b79f8c0a778 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2009-05-18 Janus Weil + + 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 * gcc.target/m68k/tls-ie.c: New test. diff --git a/gcc/testsuite/gfortran.dg/interface_27.f90 b/gcc/testsuite/gfortran.dg/interface_27.f90 new file mode 100644 index 00000000000..a3f1e4b2620 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_27.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR 40039: Procedures as actual arguments: Check intent of arguments +! +! Contributed by Janus Weil + +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" } } + diff --git a/gcc/testsuite/gfortran.dg/interface_28.f90 b/gcc/testsuite/gfortran.dg/interface_28.f90 new file mode 100644 index 00000000000..53495a44348 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_28.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! PR 36947: Attributes not fully checked comparing actual vs dummy procedure +! +! Contributed by Walter Spector + +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" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 index 5c39f995d34..92d65423157 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 @@ -23,6 +23,7 @@ program bsp interface function p3(x) real(8) :: p3,x + intent(in) :: x end function p3 end interface diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 index 1261791ae73..f3f7252a6ad 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_1.f90 @@ -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 -- 2.30.2