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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a9409f3640f7bbc5a15d4f2c0a8124879fb4755e..a47a3eeb7f7c29ef8019cb18f0ce742982fecfc5 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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,

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index feaa625484002f8d210af9a6b438b291afd87535..2c70ba6bb98a16957ac539547b89293710ac81cd 100644 (file)
--- 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 abde778a6b88a5a3e6023dc7b5c6954743dcdaa0..8ed05f2d6dd4a483fd0ab19288504799f1186cb0 100644 (file)
--- 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 f2d14657f0699fcf6cfee8ffc84cba1a866b6123..48c026cb2fece78882fd20e5b859357cc4283c4b 100644 (file)
--- 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 99cf7a9433202ccab7ac82660679c56ef8621d4f..5d2747a15265bde476441c5520cee39460947f0f 100644 (file)
--- 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 836aeb046ac950211eb96dc867d399a6a58df8dc..d3097c4ef7f6342a2f7f042e979388d8f9fe5ac6 100644 (file)
--- 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 81473a420bfa03f35c9d4177bc9a6933cfb57700..326d73e3ebfac11b905e31f432a8170ca8f70a76 100644 (file)
--- 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 994360be60b6467611cb106e5c1ba56c1feec63c..b79f8c0a778bd12ba1bc0e2947b36c7f4e90cd49 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.

diff --git a/gcc/testsuite/gfortran.dg/interface_27.f90 b/gcc/testsuite/gfortran.dg/interface_27.f90
new file mode 100644 (file)
index 0000000..a3f1e4b
--- /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 <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" } }
+

diff --git a/gcc/testsuite/gfortran.dg/interface_28.f90 b/gcc/testsuite/gfortran.dg/interface_28.f90
new file mode 100644 (file)
index 0000000..53495a4
--- /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 <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" } }
+

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
index 5c39f995d34f264ba8229ada4389e0948bf6599a..92d65423157eb4e72d755aa7c3c48f032ce7a455 100644 (file)
--- 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 1261791ae73d0708cf321d95021d2f0de2f0fb37..f3f7252a6ad5d807c3ce7edca1145201ddcd70cc 100644 (file)
--- 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