summaryrefslogtreecommitdiffstats
path: root/meta/recipes-devtools/gcc/gcc-4.6.0/gcc-4_6-branch-backports/0194-2011-04-28-Tobias-Burnus-burnus-net-b.de.patch
blob: 0a14655a5a074f8b53de267f5301da7a9ae61621 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
From a588d1bdc7fb4aa8e1214b6a57d581ddcfa86159 Mon Sep 17 00:00:00 2001
From: burnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Thu, 28 Apr 2011 18:47:28 +0000
Subject: [PATCH 194/200] 2011-04-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48112
        * resolve.c (resolve_fl_var_and_proc): Print diagnostic of
        function results only once.
        (resolve_symbol): Always resolve function results.

        PR fortran/48279
        * expr.c (gfc_check_vardef_context): Fix handling of generic
        EXPR_FUNCTION.
        * interface.c (check_interface0): Reject internal functions
        in generic interfaces, unless -std=gnu.

2011-04-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48112



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_6-branch@173127 138bc75d-0d04-0410-961f-82ee72b054a4

index 58b6036..cfa1d57 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4367,15 +4367,26 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
 gfc_try
 gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
 {
-  gfc_symbol* sym;
+  gfc_symbol* sym = NULL;
   bool is_pointer;
   bool check_intentin;
   bool ptr_component;
   symbol_attribute attr;
   gfc_ref* ref;
 
+  if (e->expr_type == EXPR_VARIABLE)
+    {
+      gcc_assert (e->symtree);
+      sym = e->symtree->n.sym;
+    }
+  else if (e->expr_type == EXPR_FUNCTION)
+    {
+      gcc_assert (e->symtree);
+      sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
+    }
+
   if (!pointer && e->expr_type == EXPR_FUNCTION
-      && e->symtree->n.sym->result->attr.pointer)
+      && sym->result->attr.pointer)
     {
       if (!(gfc_option.allow_std & GFC_STD_F2008))
 	{
@@ -4393,9 +4404,6 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
       return FAILURE;
     }
 
-  gcc_assert (e->symtree);
-  sym = e->symtree->n.sym;
-
   if (!pointer && sym->attr.flavor == FL_PARAMETER)
     {
       if (context)
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b0b74c1..b5f77c3 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1128,6 +1128,12 @@ check_interface0 (gfc_interface *p, const char *interface_name)
 		     " or all FUNCTIONs", interface_name, &p->sym->declared_at);
 	  return 1;
 	}
+
+      if (p->sym->attr.proc == PROC_INTERNAL
+	  && gfc_notify_std (GFC_STD_GNU, "Extension: Internal procedure '%s' "
+			     "in %s at %L", p->sym->name, interface_name,
+			     &p->sym->declared_at) == FAILURE)
+	return 1;
     }
   p = psave;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 75e4697..f661140 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9858,6 +9858,11 @@ apply_default_init_local (gfc_symbol *sym)
 static gfc_try
 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 {
+  /* Avoid double diagnostics for function result symbols.  */
+  if ((sym->result || sym->attr.result) && !sym->attr.dummy
+      && (sym->ns != gfc_current_ns))
+    return SUCCESS;
+
   /* Constraints on deferred shape variable.  */
   if (sym->as == NULL || sym->as->type != AS_DEFERRED)
     {
@@ -11946,11 +11951,6 @@ resolve_symbol (gfc_symbol *sym)
   gfc_namespace *ns;
   gfc_component *c;
 
-  /* Avoid double resolution of function result symbols.  */
-  if ((sym->result || sym->attr.result) && !sym->attr.dummy
-      && (sym->ns != gfc_current_ns))
-    return;
-  
   if (sym->attr.flavor == FL_UNKNOWN)
     {
 
index 728c5ce..fb1e19b 100644
--- a/gcc/testsuite/gfortran.dg/bessel_1.f90
+++ b/gcc/testsuite/gfortran.dg/bessel_1.f90
@@ -26,11 +26,11 @@ program test
   call check(bessel_yn (3,x4), bessel_yn (3,1.9_4))
 
 contains
-  subroutine check_r4 (a, b)
+  subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
     real(kind=4), intent(in) :: a, b
     if (abs(a - b) > 1.e-5 * abs(b)) call abort
   end subroutine
-  subroutine check_r8 (a, b)
+  subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
     real(kind=8), intent(in) :: a, b
     if (abs(a - b) > 1.e-7 * abs(b)) call abort
   end subroutine
diff --git a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90 b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
index 8a114e6..eeb54c8 100644
--- a/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
+++ b/gcc/testsuite/gfortran.dg/erfc_scaled_1.f90
@@ -1,4 +1,8 @@
 ! { dg-do run }
+!
+! { dg-options "" }
+! Do not run with -pedantic checks enabled as "check"
+! contains internal procedures which is a vendor extension
 
 program test
   implicit none
diff --git a/gcc/testsuite/gfortran.dg/func_result_6.f90 b/gcc/testsuite/gfortran.dg/func_result_6.f90
index e64a2ef..e8347be 100644
--- a/gcc/testsuite/gfortran.dg/func_result_6.f90
+++ b/gcc/testsuite/gfortran.dg/func_result_6.f90
@@ -63,7 +63,7 @@ if (ptr /= 2) call abort()
 bar = gen()
 if (ptr /= 77) call abort()
 contains
-  function foo()
+  function foo() ! { dg-warning "Extension: Internal procedure .foo. in generic interface" }
     integer, allocatable :: foo(:)
     allocate(foo(2))
     foo = [33, 77]
diff --git a/gcc/testsuite/gfortran.dg/hypot_1.f90 b/gcc/testsuite/gfortran.dg/hypot_1.f90
index 59022fa..0c1c6e2 100644
--- a/gcc/testsuite/gfortran.dg/hypot_1.f90
+++ b/gcc/testsuite/gfortran.dg/hypot_1.f90
@@ -18,11 +18,11 @@ program test
   call check(hypot(x4,y4), hypot(1.9_4,-2.1_4))
 
 contains
-  subroutine check_r4 (a, b)
+  subroutine check_r4 (a, b) ! { dg-warning "Extension: Internal procedure" }
     real(kind=4), intent(in) :: a, b
     if (abs(a - b) > 1.e-5 * abs(b)) call abort
   end subroutine
-  subroutine check_r8 (a, b)
+  subroutine check_r8 (a, b) ! { dg-warning "Extension: Internal procedure" }
     real(kind=8), intent(in) :: a, b
     if (abs(a - b) > 1.e-7 * abs(b)) call abort
   end subroutine
diff --git a/gcc/testsuite/gfortran.dg/interface_35.f90 b/gcc/testsuite/gfortran.dg/interface_35.f90
new file mode 100644
index 0000000..20aa4af
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_35.f90
@@ -0,0 +1,79 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48112 (module_m)
+! PR fortran/48279 (sidl_string_array, s_Hard)
+!
+! Contributed by mhp77@gmx.at (module_m)
+! and Adrian Prantl (sidl_string_array, s_Hard)
+!
+
+module module_m
+  interface test
+     function test1( )  result( test )
+       integer ::  test
+     end function test1
+  end interface test
+end module module_m
+
+! -----
+
+module sidl_string_array
+  type sidl_string_1d
+  end type sidl_string_1d
+  interface set
+    module procedure &
+      setg1_p
+  end interface
+contains
+  subroutine setg1_p(array, index, val)
+    type(sidl_string_1d), intent(inout) :: array
+  end subroutine setg1_p
+end module sidl_string_array
+
+module s_Hard
+  use sidl_string_array
+  type :: s_Hard_t
+     integer(8) :: dummy
+  end type s_Hard_t
+  interface set_d_interface
+  end interface 
+  interface get_d_string
+    module procedure get_d_string_p
+  end interface 
+  contains ! Derived type member access functions
+    type(sidl_string_1d) function get_d_string_p(s)
+      type(s_Hard_t), intent(in) :: s
+    end function get_d_string_p
+    subroutine set_d_objectArray_p(s, d_objectArray)
+    end subroutine set_d_objectArray_p
+end module s_Hard
+
+subroutine initHard(h, ex)
+  use s_Hard
+  type(s_Hard_t), intent(inout) :: h
+  call set(get_d_string(h), 0, 'Three') ! { dg-error "There is no specific subroutine for the generic" }
+end subroutine initHard
+
+! -----
+
+  interface get
+    procedure get1
+  end interface
+
+  integer :: h
+  call set1 (get (h))
+
+contains
+
+  subroutine set1 (a)
+    integer, intent(in) :: a
+  end subroutine
+
+  integer function get1 (s) ! { dg-error "Extension: Internal procedure .get1. in generic interface .get." }
+    integer :: s
+  end function
+
+end
+
+! { dg-final { cleanup-modules "module_m module_m2 s_hard sidl_string_array" } }
diff --git a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90 b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
index 535e884..d55af29 100644
--- a/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
+++ b/gcc/testsuite/gfortran.dg/interface_assignment_4.f90
@@ -16,7 +16,7 @@
 
 contains
 
-  subroutine op_assign_VS_CH (var, exp)
+  subroutine op_assign_VS_CH (var, exp) ! { dg-warning "Extension: Internal procedure" }
     type(varying_string), intent(out) :: var
     character(LEN=*), intent(in)      :: exp
   end subroutine
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
index d477368..57660c7 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
@@ -35,12 +35,12 @@ o1%ppc => o2%ppc  ! { dg-error "Type/kind mismatch" }
 
 contains
 
-  real function f1(a,b)
+  real function f1(a,b) ! { dg-warning "Extension: Internal procedure" }
     real,intent(in) :: a,b
     f1 = a + b
   end function
 
-  integer function f2(a,b)
+  integer function f2(a,b) ! { dg-warning "Extension: Internal procedure" }
     real,intent(in) :: a,b
     f2 = a - b
   end function
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
index c000896..a21916b 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_21.f90
@@ -19,7 +19,7 @@
 
 contains
 
-  elemental subroutine op_assign (str, ch)
+  elemental subroutine op_assign (str, ch) ! { dg-warning "Extension: Internal procedure" }
     type(nf_t), intent(out) :: str
     character(len=*), intent(in) :: ch
   end subroutine
-- 
1.7.0.4

OpenPOWER on IntegriCloud