code.ossystems Code Review - openembedded-core.git/blob

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