View | Details | Return to bug 38290
Collapse All | Expand All

(-)gcc/testsuite/gfortran.dg/proc_ptr_11.f90 (-2 / +1 lines)
Lines 16-23 program bsp Link Here
16
  procedure( up ) , pointer :: pptr
16
  procedure( up ) , pointer :: pptr
17
  procedure(isign), pointer :: q
17
  procedure(isign), pointer :: q
18
18
19
  ! TODO. See PR 38290.
19
  pptr => add   ! { dg-error "Interfaces don't match" }
20
  !pptr => add   ! { "Interfaces don't match" }
21
20
22
  q => add
21
  q => add
23
22
(-)gcc/testsuite/gfortran.dg/proc_decl_1.f90 (-11 / +8 lines)
Lines 19-26 module m Link Here
19
  public:: h
19
  public:: h
20
  procedure(),public:: h  ! { dg-error "was already specified" }
20
  procedure(),public:: h  ! { dg-error "was already specified" }
21
21
22
end module m
22
contains
23
23
24
  subroutine abc
25
    procedure() :: abc2
26
  entry abc2(x)  ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
27
    real x
28
  end subroutine
29
30
end module m
24
31
25
program prog
32
program prog
26
33
Lines 68-80 contains Link Here
68
  end subroutine foo 
75
  end subroutine foo 
69
76
70
end program
77
end program
71
72
73
subroutine abc
74
75
 procedure() :: abc2
76
77
entry abc2(x)  ! { dg-error "PROCEDURE attribute conflicts with ENTRY attribute" }
78
 real x
79
80
end subroutine
(-)gcc/fortran/interface.c (-12 / +19 lines)
Lines 958-963 gfc_compare_interfaces (gfc_symbol *s1, Link Here
958
{
958
{
959
  gfc_formal_arglist *f1, *f2;
959
  gfc_formal_arglist *f1, *f2;
960
960
961
  if (s2->attr.intrinsic)
962
    return compare_intr_interfaces (s1, s2);
963
961
  if (s1->attr.function != s2->attr.function
964
  if (s1->attr.function != s2->attr.function
962
      || s1->attr.subroutine != s2->attr.subroutine)
965
      || s1->attr.subroutine != s2->attr.subroutine)
963
    return 0;		/* Disagreement between function/subroutine.  */
966
    return 0;		/* Disagreement between function/subroutine.  */
Lines 997-1002 compare_intr_interfaces (gfc_symbol *s1, Link Here
997
  gfc_intrinsic_arg *fi, *f2;
1000
  gfc_intrinsic_arg *fi, *f2;
998
  gfc_intrinsic_sym *isym;
1001
  gfc_intrinsic_sym *isym;
999
1002
1003
  isym = gfc_find_function (s2->name);
1004
  if (isym)
1005
    {
1006
      if (!s2->attr.function)
1007
	gfc_add_function (&s2->attr, s2->name, &gfc_current_locus);
1008
      s2->ts = isym->ts;
1009
    }
1010
  else
1011
    {
1012
      isym = gfc_find_subroutine (s2->name);
1013
      gcc_assert (isym);
1014
      if (!s2->attr.subroutine)
1015
	gfc_add_subroutine (&s2->attr, s2->name, &gfc_current_locus);
1016
    }
1017
1000
  if (s1->attr.function != s2->attr.function
1018
  if (s1->attr.function != s2->attr.function
1001
      || s1->attr.subroutine != s2->attr.subroutine)
1019
      || s1->attr.subroutine != s2->attr.subroutine)
1002
    return 0;		/* Disagreement between function/subroutine.  */
1020
    return 0;		/* Disagreement between function/subroutine.  */
Lines 1013-1024 compare_intr_interfaces (gfc_symbol *s1, Link Here
1013
	return 1;
1031
	return 1;
1014
    }
1032
    }
1015
1033
1016
  isym = gfc_find_function (s2->name);
1017
  
1018
  /* This should already have been checked in
1019
     resolve.c (resolve_actual_arglist).  */
1020
  gcc_assert (isym);
1021
1022
  f1 = s1->formal;
1034
  f1 = s1->formal;
1023
  f2 = isym->formal;
1035
  f2 = isym->formal;
1024
1036
Lines 1454-1465 compare_parameter (gfc_symbol *formal, g Link Here
1454
	  || actual->symtree->n.sym->attr.external)
1466
	  || actual->symtree->n.sym->attr.external)
1455
	return 1;		/* Assume match.  */
1467
	return 1;		/* Assume match.  */
1456
1468
1457
      if (actual->symtree->n.sym->attr.intrinsic)
1469
      if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
1458
	{
1459
	 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
1460
	   goto proc_fail;
1461
	}
1462
      else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
1463
	goto proc_fail;
1470
	goto proc_fail;
1464
1471
1465
      return 1;
1472
      return 1;
(-)gcc/fortran/symbol.c (+53 lines)
Lines 3831-3836 copy_formal_args (gfc_symbol *dest, gfc_ Link Here
3831
  gfc_current_ns = parent_ns;
3831
  gfc_current_ns = parent_ns;
3832
}
3832
}
3833
3833
3834
void
3835
copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
3836
{
3837
  gfc_formal_arglist *head = NULL;
3838
  gfc_formal_arglist *tail = NULL;
3839
  gfc_formal_arglist *formal_arg = NULL;
3840
  gfc_intrinsic_arg *curr_arg = NULL;
3841
  gfc_formal_arglist *formal_prev = NULL;
3842
  /* Save current namespace so we can change it for formal args.  */
3843
  gfc_namespace *parent_ns = gfc_current_ns;
3844
3845
  /* Create a new namespace, which will be the formal ns (namespace
3846
     of the formal args).  */
3847
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3848
  gfc_current_ns->proc_name = dest;
3849
3850
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3851
    {
3852
      formal_arg = gfc_get_formal_arglist ();
3853
      gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
3854
3855
      /* May need to copy more info for the symbol.  */
3856
      formal_arg->sym->ts = curr_arg->ts;
3857
      formal_arg->sym->attr.optional = curr_arg->optional;
3858
      /*formal_arg->sym->attr = curr_arg->sym->attr;
3859
      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3860
      copy_formal_args (formal_arg->sym, curr_arg->sym);*/
3861
3862
      /* If this isn't the first arg, set up the next ptr.  For the
3863
        last arg built, the formal_arg->next will never get set to
3864
        anything other than NULL.  */
3865
      if (formal_prev != NULL)
3866
	formal_prev->next = formal_arg;
3867
      else
3868
	formal_arg->next = NULL;
3869
3870
      formal_prev = formal_arg;
3871
3872
      /* Add arg to list of formal args.  */
3873
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3874
    }
3875
3876
  /* Add the interface to the symbol.  */
3877
  add_proc_interface (dest, IFSRC_DECL, head);
3878
3879
  /* Store the formal namespace information.  */
3880
  if (dest->formal != NULL)
3881
    /* The current ns should be that for the dest proc.  */
3882
    dest->formal_ns = gfc_current_ns;
3883
  /* Restore the current namespace to what it was on entry.  */
3884
  gfc_current_ns = parent_ns;
3885
}
3886
3834
/* Builds the parameter list for the iso_c_binding procedure
3887
/* Builds the parameter list for the iso_c_binding procedure
3835
   c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
3888
   c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
3836
   generic version of either the c_f_pointer or c_f_procpointer
3889
   generic version of either the c_f_pointer or c_f_procpointer
(-)gcc/fortran/gfortran.h (-1 / +2 lines)
Lines 2353-2359 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymb Link Here
2353
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
2353
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
2354
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
2354
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
2355
2355
2356
void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
2356
void copy_formal_args (gfc_symbol *, gfc_symbol *);
2357
void copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
2357
2358
2358
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
2359
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
2359
2360
(-)gcc/fortran/expr.c (-2 / +1 lines)
Lines 3131-3137 gfc_check_pointer_assign (gfc_expr *lval Link Here
3131
		     "in procedure pointer assignment at %L",
3131
		     "in procedure pointer assignment at %L",
3132
		     rvalue->symtree->name, &rvalue->where);
3132
		     rvalue->symtree->name, &rvalue->where);
3133
	}
3133
	}
3134
      /* TODO. See PR 38290.
3135
      if (rvalue->expr_type == EXPR_VARIABLE
3134
      if (rvalue->expr_type == EXPR_VARIABLE
3136
	  && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
3135
	  && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
3137
	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
3136
	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
Lines 3140-3146 gfc_check_pointer_assign (gfc_expr *lval Link Here
3140
	  gfc_error ("Interfaces don't match "
3139
	  gfc_error ("Interfaces don't match "
3141
		     "in procedure pointer assignment at %L", &rvalue->where);
3140
		     "in procedure pointer assignment at %L", &rvalue->where);
3142
	  return FAILURE;
3141
	  return FAILURE;
3143
	}*/
3142
	}
3144
      return SUCCESS;
3143
      return SUCCESS;
3145
    }
3144
    }
3146
3145
(-)gcc/fortran/resolve.c (-40 / +27 lines)
Lines 1705-1727 resolve_specific_f0 (gfc_symbol *sym, gf Link Here
1705
{
1705
{
1706
  match m;
1706
  match m;
1707
1707
1708
  /* See if we have an intrinsic interface.  */
1709
1710
  if (sym->ts.interface != NULL && sym->ts.interface->attr.intrinsic)
1711
    {
1712
      gfc_intrinsic_sym *isym;
1713
      isym = gfc_find_function (sym->ts.interface->name);
1714
1715
      /* Existence of isym should be checked already.  */
1716
      gcc_assert (isym);
1717
1718
      sym->ts.type = isym->ts.type;
1719
      sym->ts.kind = isym->ts.kind;
1720
      sym->attr.function = 1;
1721
      sym->attr.proc = PROC_EXTERNAL;
1722
      goto found;
1723
    }
1724
1725
  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1708
  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1726
    {
1709
    {
1727
      if (sym->attr.dummy)
1710
      if (sym->attr.dummy)
Lines 2788-2811 resolve_specific_s0 (gfc_code *c, gfc_sy Link Here
2788
{
2771
{
2789
  match m;
2772
  match m;
2790
2773
2791
  /* See if we have an intrinsic interface.  */
2792
  if (sym->ts.interface != NULL && !sym->ts.interface->attr.abstract
2793
      && !sym->ts.interface->attr.subroutine
2794
      && sym->ts.interface->attr.intrinsic)
2795
    {
2796
      gfc_intrinsic_sym *isym;
2797
2798
      isym = gfc_find_function (sym->ts.interface->name);
2799
2800
      /* Existence of isym should be checked already.  */
2801
      gcc_assert (isym);
2802
2803
      sym->ts.type = isym->ts.type;
2804
      sym->ts.kind = isym->ts.kind;
2805
      sym->attr.subroutine = 1;
2806
      goto found;
2807
    }
2808
2809
  if(sym->attr.is_iso_c)
2774
  if(sym->attr.is_iso_c)
2810
    {
2775
    {
2811
      m = gfc_iso_c_sub_interface (c,sym);
2776
      m = gfc_iso_c_sub_interface (c,sym);
Lines 8992-9001 resolve_symbol (gfc_symbol *sym) Link Here
8992
      if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8957
      if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
8993
	{
8958
	{
8994
	  gfc_symbol *ifc = sym->ts.interface;
8959
	  gfc_symbol *ifc = sym->ts.interface;
8995
	  sym->ts = ifc->ts;
8960
8996
	  sym->ts.interface = ifc;
8961
	  if (ifc->attr.intrinsic)
8997
	  sym->attr.function = ifc->attr.function;
8962
	    {
8998
	  sym->attr.subroutine = ifc->attr.subroutine;
8963
	      gfc_intrinsic_sym *isym = gfc_find_function (sym->ts.interface->name);
8964
	      if (isym)
8965
		{
8966
		  sym->attr.function = 1;
8967
		  sym->ts = isym->ts;
8968
		  sym->ts.interface = ifc;
8969
		}
8970
	      else
8971
		{
8972
		  isym = gfc_find_subroutine (sym->ts.interface->name);
8973
		  gcc_assert (isym);
8974
		  sym->attr.subroutine = 1;
8975
		}
8976
	      copy_formal_args_intr (sym, isym);
8977
	    }
8978
	  else
8979
	    {
8980
	      sym->ts = ifc->ts;
8981
	      sym->ts.interface = ifc;
8982
	      sym->attr.function = ifc->attr.function;
8983
	      sym->attr.subroutine = ifc->attr.subroutine;
8984
	      copy_formal_args (sym, ifc);
8985
	    }
8986
8999
	  sym->attr.allocatable = ifc->attr.allocatable;
8987
	  sym->attr.allocatable = ifc->attr.allocatable;
9000
	  sym->attr.pointer = ifc->attr.pointer;
8988
	  sym->attr.pointer = ifc->attr.pointer;
9001
	  sym->attr.pure = ifc->attr.pure;
8989
	  sym->attr.pure = ifc->attr.pure;
Lines 9003-9009 resolve_symbol (gfc_symbol *sym) Link Here
9003
	  sym->attr.dimension = ifc->attr.dimension;
8991
	  sym->attr.dimension = ifc->attr.dimension;
9004
	  sym->attr.recursive = ifc->attr.recursive;
8992
	  sym->attr.recursive = ifc->attr.recursive;
9005
	  sym->attr.always_explicit = ifc->attr.always_explicit;
8993
	  sym->attr.always_explicit = ifc->attr.always_explicit;
9006
	  copy_formal_args (sym, ifc);
9007
	  /* Copy array spec.  */
8994
	  /* Copy array spec.  */
9008
	  sym->as = gfc_copy_array_spec (ifc->as);
8995
	  sym->as = gfc_copy_array_spec (ifc->as);
9009
	  if (sym->as)
8996
	  if (sym->as)

Return to bug 38290