git.ipfire.org Git - thirdparty/openembedded/openembedded-core-contrib.git/blob

   1 From 1c9148fe797f564821355a8976802689519324dd Mon Sep 17 00:00:00 2001
   2 From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
   3 Date: Fri, 29 Apr 2011 21:26:07 +0000
   4 Subject: [PATCH 198/200] 2011-04-29  Tobias Burnus  <burnus@net-b.de>
   5
   6         PR fortran/48810
   7         * resolve.c (resolve_typebound_generic_call): Don't check access
   8         flags of the specific function.
   9
  10         PR fortran/48800
  11         * resolve.c (resolve_formal_arglist): Don't change AS_DEFERRED
  12         to AS_ASSUMED_SHAPE for function results.
  13         (resolve_fl_var_and_proc): Print also for function results with
  14         AS_DEFERRED an error, if they are not a pointer or allocatable.
  15         (resolve_types): Make sure arguments of procedures in interface
  16         blocks are resolved.
  17
  18 2011-04-29  Tobias Burnus  <burnus@net-b.de>
  19
  20         PR fortran/48810
  21         * gfortran.dg/typebound_proc_22.f90: New.
  22
  23         PR fortran/48800
  24         * gfortran.dg/interface_36.f90: New.
  25
  26
  27
  28 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173191 138bc75d-0d04-0410-961f-82ee72b054a4
  29
  30 index f661140..7618db9 100644
  31 --- a/gcc/fortran/resolve.c
  32 +++ b/gcc/fortran/resolve.c
  33 @@ -315,7 +315,8 @@ resolve_formal_arglist (gfc_symbol *proc)
  34          shape until we know if it has the pointer or allocatable attributes.
  35        */
  36        if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
  37 -         && !(sym->attr.pointer || sym->attr.allocatable))
  38 +         && !(sym->attr.pointer || sym->attr.allocatable)
  39 +         && sym->attr.flavor != FL_PROCEDURE)
  40         {
  41           sym->as->type = AS_ASSUMED_SHAPE;
  42           for (i = 0; i < sym->as->rank; i++)
  43 @@ -5674,7 +5675,7 @@ success:
  44    /* Make sure that we have the right specific instance for the name.  */
  45    derived = get_declared_from_expr (NULL, NULL, e);
  46
  47 -  st = gfc_find_typebound_proc (derived, NULL, genname, false, &e->where);
  48 +  st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
  49    if (st)
  50      e->value.compcall.tbp = st->n.tb;
  51
  52 @@ -9890,7 +9891,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
  53    else
  54      {
  55        if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
  56 -         && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
  57 +         && sym->ts.type != BT_CLASS && !sym->assoc)
  58         {
  59           gfc_error ("Array '%s' at %L cannot have a deferred shape",
  60                      sym->name, &sym->declared_at);
  61 @@ -13505,6 +13506,10 @@ resolve_types (gfc_namespace *ns)
  62
  63    resolve_contained_functions (ns);
  64
  65 +  if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE
  66 +      && ns->proc_name->attr.if_source == IFSRC_IFBODY)
  67 +    resolve_formal_arglist (ns->proc_name);
  68 +
  69    gfc_traverse_ns (ns, resolve_bind_c_derived_types);
  70
  71    for (cl = ns->cl_list; cl; cl = cl->next)
  72 new file mode 100644
  73 index 0000000..5032291
  74 --- /dev/null
  75 +++ b/gcc/testsuite/gfortran.dg/interface_36.f90
  76 @@ -0,0 +1,28 @@
  77 +! { dg-do compile }
  78 +!
  79 +! PR fortran/48800
  80 +!
  81 +! Contributed by Daniel Carrera
  82 +!
  83 +     pure function runge_kutta_step(t, r_, dr, h) result(res)
  84 +         real, intent(in) :: t, r_(:), h
  85 +         real, dimension(:), allocatable :: k1, k2, k3, k4, res
  86 +         integer :: N
  87 +
  88 +         interface
  89 +             pure function dr(t, r_)  ! { dg-error "cannot have a deferred shape" }
  90 +                 real, intent(in) :: t, r_(:)
  91 +                 real :: dr(:)
  92 +             end function
  93 +         end interface
  94 +
  95 +         N = size(r_)
  96 +         allocate(k1(N),k2(N),k3(N),k4(N),res(N))
  97 +
  98 +         k1 = dr(t, r_)
  99 +         k2 = dr(t + h/2, r_ + k1*h/2)
 100 +         k3 = dr(t + h/2, r_ + k2*h/2)
 101 +         k4 = dr(t + h  , r_ + k3*h)
 102 +
 103 +         res = r_ + (k1 + 2*k2 + 2*k3 + k4) * h/6
 104 +     end function
 105 diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_22.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_22.f90
 106 new file mode 100644
 107 index 0000000..f7691c5
 108 --- /dev/null
 109 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_22.f90
 110 @@ -0,0 +1,49 @@
 111 +! { dg-do compile }
 112 +!
 113 +! PR fortran/48810
 114 +!
 115 +! Contributed by Andrew Baldwin
 116 +!
 117 +      module qtest
 118 +      type foobar
 119 +        integer :: x
 120 +        contains
 121 +        private
 122 +        procedure :: gimmex
 123 +        generic, public :: getx => gimmex
 124 +      end type foobar
 125 +      contains
 126 +        function gimmex(foo)
 127 +          class (foobar) :: foo
 128 +          integer :: gimmex
 129 +          gimmex = foo%x
 130 +        end function gimmex
 131 +      end module qtest
 132 +
 133 +      module qtestPriv
 134 +      type foobarPriv
 135 +        integer :: x
 136 +        contains
 137 +        private
 138 +        procedure :: gimmexPriv
 139 +        generic, private :: getxPriv => gimmexPriv
 140 +      end type foobarPriv
 141 +      contains
 142 +        function gimmexPriv(foo)
 143 +          class (foobarPriv) :: foo
 144 +          integer :: gimmex
 145 +          gimmex = foo%x
 146 +        end function gimmexPriv
 147 +      end module qtestPriv
 148 +
 149 +      program quicktest
 150 +      use qtest
 151 +      use qtestPriv
 152 +      type (foobar) :: foo
 153 +      type (foobarPriv) :: fooPriv
 154 +      integer :: bar
 155 +      bar = foo%getx()  ! OK
 156 +      bar = fooPriv%getxPriv() ! { dg-error " is PRIVATE " }
 157 +      end program quicktest
 158 +
 159 +! { dg-final { cleanup-modules "qtest qtestpriv" } }
 160 --
 161 1.7.0.4
 162