]>
Commit | Line | Data |
---|---|---|
d15bac21 JW |
1 | /* Implementation of Fortran 2003 Polymorphism. |
2 | Copyright (C) 2009, 2010 | |
3 | Free Software Foundation, Inc. | |
4fa02692 JW |
4 | Contributed by Paul Richard Thomas <pault@gcc.gnu.org> |
5 | and Janus Weil <janus@gcc.gnu.org> | |
d15bac21 JW |
6 | |
7 | This file is part of GCC. | |
8 | ||
9 | GCC is free software; you can redistribute it and/or modify it under | |
10 | the terms of the GNU General Public License as published by the Free | |
11 | Software Foundation; either version 3, or (at your option) any later | |
12 | version. | |
13 | ||
14 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY | |
15 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
16 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
17 | for more details. | |
18 | ||
19 | You should have received a copy of the GNU General Public License | |
20 | along with GCC; see the file COPYING3. If not see | |
21 | <http://www.gnu.org/licenses/>. */ | |
22 | ||
23 | ||
24 | /* class.c -- This file contains the front end functions needed to service | |
25 | the implementation of Fortran 2003 polymorphism and other | |
26 | object-oriented features. */ | |
27 | ||
28 | ||
29 | /* Outline of the internal representation: | |
30 | ||
31 | Each CLASS variable is encapsulated by a class container, which is a | |
32 | structure with two fields: | |
b04533af | 33 | * _data: A pointer to the actual data of the variable. This field has the |
d15bac21 JW |
34 | declared type of the class variable and its attributes |
35 | (pointer/allocatable/dimension/...). | |
b04533af | 36 | * _vptr: A pointer to the vtable entry (see below) of the dynamic type. |
d15bac21 JW |
37 | |
38 | For each derived type we set up a "vtable" entry, i.e. a structure with the | |
39 | following fields: | |
b04533af JW |
40 | * _hash: A hash value serving as a unique identifier for this type. |
41 | * _size: The size in bytes of the derived type. | |
42 | * _extends: A pointer to the vtable entry of the parent derived type. | |
43 | * _def_init: A pointer to a default initialized variable of this type. | |
44 | * _copy: A procedure pointer to a copying procedure. | |
611c64f0 JW |
45 | After these follow procedure pointer components for the specific |
46 | type-bound procedures. */ | |
d15bac21 JW |
47 | |
48 | ||
49 | #include "config.h" | |
50 | #include "system.h" | |
51 | #include "gfortran.h" | |
52 | #include "constructor.h" | |
53 | ||
54 | ||
37da591f MM |
55 | /* Inserts a derived type component reference in a data reference chain. |
56 | TS: base type of the ref chain so far, in which we will pick the component | |
57 | REF: the address of the GFC_REF pointer to update | |
58 | NAME: name of the component to insert | |
59 | Note that component insertion makes sense only if we are at the end of | |
60 | the chain (*REF == NULL) or if we are adding a missing "_data" component | |
61 | to access the actual contents of a class object. */ | |
62 | ||
63 | static void | |
64 | insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) | |
65 | { | |
66 | gfc_symbol *type_sym; | |
67 | gfc_ref *new_ref; | |
68 | ||
69 | gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); | |
70 | type_sym = ts->u.derived; | |
71 | ||
72 | new_ref = gfc_get_ref (); | |
73 | new_ref->type = REF_COMPONENT; | |
74 | new_ref->next = *ref; | |
75 | new_ref->u.c.sym = type_sym; | |
76 | new_ref->u.c.component = gfc_find_component (type_sym, name, true, true); | |
77 | gcc_assert (new_ref->u.c.component); | |
78 | ||
79 | if (new_ref->next) | |
80 | { | |
81 | gfc_ref *next = NULL; | |
82 | ||
83 | /* We need to update the base type in the trailing reference chain to | |
84 | that of the new component. */ | |
85 | ||
86 | gcc_assert (strcmp (name, "_data") == 0); | |
87 | ||
88 | if (new_ref->next->type == REF_COMPONENT) | |
89 | next = new_ref->next; | |
90 | else if (new_ref->next->type == REF_ARRAY | |
91 | && new_ref->next->next | |
92 | && new_ref->next->next->type == REF_COMPONENT) | |
93 | next = new_ref->next->next; | |
94 | ||
95 | if (next != NULL) | |
96 | { | |
97 | gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS | |
98 | || new_ref->u.c.component->ts.type == BT_DERIVED); | |
99 | next->u.c.sym = new_ref->u.c.component->ts.u.derived; | |
100 | } | |
101 | } | |
102 | ||
103 | *ref = new_ref; | |
104 | } | |
105 | ||
106 | ||
107 | /* Tells whether we need to add a "_data" reference to access REF subobject | |
108 | from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base | |
109 | object accessed by REF is a variable; in other words it is a full object, | |
110 | not a subobject. */ | |
111 | ||
112 | static bool | |
113 | class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain) | |
114 | { | |
115 | /* Only class containers may need the "_data" reference. */ | |
116 | if (ts->type != BT_CLASS) | |
117 | return false; | |
118 | ||
119 | /* Accessing a class container with an array reference is certainly wrong. */ | |
120 | if (ref->type != REF_COMPONENT) | |
121 | return true; | |
122 | ||
123 | /* Accessing the class container's fields is fine. */ | |
124 | if (ref->u.c.component->name[0] == '_') | |
125 | return false; | |
126 | ||
127 | /* At this point we have a class container with a non class container's field | |
128 | component reference. We don't want to add the "_data" component if we are | |
129 | at the first reference and the symbol's type is an extended derived type. | |
130 | In that case, conv_parent_component_references will do the right thing so | |
131 | it is not absolutely necessary. Omitting it prevents a regression (see | |
132 | class_41.f03) in the interface mapping mechanism. When evaluating string | |
133 | lengths depending on dummy arguments, we create a fake symbol with a type | |
134 | equal to that of the dummy type. However, because of type extension, | |
135 | the backend type (corresponding to the actual argument) can have a | |
136 | different (extended) type. Adding the "_data" component explicitly, using | |
137 | the base type, confuses the gfc_conv_component_ref code which deals with | |
138 | the extended type. */ | |
139 | if (first_ref_in_chain && ts->u.derived->attr.extension) | |
140 | return false; | |
141 | ||
142 | /* We have a class container with a non class container's field component | |
143 | reference that doesn't fall into the above. */ | |
144 | return true; | |
145 | } | |
146 | ||
147 | ||
148 | /* Browse through a data reference chain and add the missing "_data" references | |
149 | when a subobject of a class object is accessed without it. | |
150 | Note that it doesn't add the "_data" reference when the class container | |
151 | is the last element in the reference chain. */ | |
152 | ||
153 | void | |
154 | gfc_fix_class_refs (gfc_expr *e) | |
155 | { | |
156 | gfc_typespec *ts; | |
157 | gfc_ref **ref; | |
158 | ||
159 | if ((e->expr_type != EXPR_VARIABLE | |
160 | && e->expr_type != EXPR_FUNCTION) | |
161 | || (e->expr_type == EXPR_FUNCTION | |
162 | && e->value.function.isym != NULL)) | |
163 | return; | |
164 | ||
165 | ts = &e->symtree->n.sym->ts; | |
166 | ||
167 | for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) | |
168 | { | |
169 | if (class_data_ref_missing (ts, *ref, ref == &e->ref)) | |
170 | insert_component_ref (ts, ref, "_data"); | |
171 | ||
172 | if ((*ref)->type == REF_COMPONENT) | |
173 | ts = &(*ref)->u.c.component->ts; | |
174 | } | |
175 | } | |
176 | ||
177 | ||
d15bac21 | 178 | /* Insert a reference to the component of the given name. |
b04533af | 179 | Only to be used with CLASS containers and vtables. */ |
d15bac21 JW |
180 | |
181 | void | |
182 | gfc_add_component_ref (gfc_expr *e, const char *name) | |
183 | { | |
184 | gfc_ref **tail = &(e->ref); | |
185 | gfc_ref *next = NULL; | |
186 | gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; | |
187 | while (*tail != NULL) | |
188 | { | |
189 | if ((*tail)->type == REF_COMPONENT) | |
c49ea23d PT |
190 | { |
191 | if (strcmp ((*tail)->u.c.component->name, "_data") == 0 | |
192 | && (*tail)->next | |
193 | && (*tail)->next->type == REF_ARRAY | |
194 | && (*tail)->next->next == NULL) | |
195 | return; | |
196 | derived = (*tail)->u.c.component->ts.u.derived; | |
197 | } | |
d15bac21 JW |
198 | if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) |
199 | break; | |
200 | tail = &((*tail)->next); | |
201 | } | |
b04533af | 202 | if (*tail != NULL && strcmp (name, "_data") == 0) |
d15bac21 JW |
203 | next = *tail; |
204 | (*tail) = gfc_get_ref(); | |
205 | (*tail)->next = next; | |
206 | (*tail)->type = REF_COMPONENT; | |
207 | (*tail)->u.c.sym = derived; | |
208 | (*tail)->u.c.component = gfc_find_component (derived, name, true, true); | |
209 | gcc_assert((*tail)->u.c.component); | |
210 | if (!next) | |
211 | e->ts = (*tail)->u.c.component->ts; | |
212 | } | |
213 | ||
214 | ||
c49ea23d PT |
215 | /* This is used to add both the _data component reference and an array |
216 | reference to class expressions. Used in translation of intrinsic | |
217 | array inquiry functions. */ | |
218 | ||
219 | void | |
220 | gfc_add_class_array_ref (gfc_expr *e) | |
221 | { | |
222 | int rank = CLASS_DATA (e)->as->rank; | |
223 | gfc_array_spec *as = CLASS_DATA (e)->as; | |
224 | gfc_ref *ref = NULL; | |
225 | gfc_add_component_ref (e, "_data"); | |
226 | e->rank = rank; | |
227 | for (ref = e->ref; ref; ref = ref->next) | |
228 | if (!ref->next) | |
229 | break; | |
230 | if (ref->type != REF_ARRAY) | |
231 | { | |
232 | ref->next = gfc_get_ref (); | |
233 | ref = ref->next; | |
234 | ref->type = REF_ARRAY; | |
235 | ref->u.ar.type = AR_FULL; | |
236 | ref->u.ar.as = as; | |
237 | } | |
238 | } | |
239 | ||
240 | ||
241 | /* Unfortunately, class array expressions can appear in various conditions; | |
242 | with and without both _data component and an arrayspec. This function | |
243 | deals with that variability. The previous reference to 'ref' is to a | |
244 | class array. */ | |
245 | ||
246 | static bool | |
247 | class_array_ref_detected (gfc_ref *ref, bool *full_array) | |
248 | { | |
249 | bool no_data = false; | |
250 | bool with_data = false; | |
251 | ||
252 | /* An array reference with no _data component. */ | |
253 | if (ref && ref->type == REF_ARRAY | |
254 | && !ref->next | |
255 | && ref->u.ar.type != AR_ELEMENT) | |
256 | { | |
257 | if (full_array) | |
258 | *full_array = ref->u.ar.type == AR_FULL; | |
259 | no_data = true; | |
260 | } | |
261 | ||
262 | /* Cover cases where _data appears, with or without an array ref. */ | |
263 | if (ref && ref->type == REF_COMPONENT | |
264 | && strcmp (ref->u.c.component->name, "_data") == 0) | |
265 | { | |
266 | if (!ref->next) | |
267 | { | |
268 | with_data = true; | |
269 | if (full_array) | |
270 | *full_array = true; | |
271 | } | |
272 | else if (ref->next && ref->next->type == REF_ARRAY | |
273 | && !ref->next->next | |
274 | && ref->type == REF_COMPONENT | |
275 | && ref->next->type == REF_ARRAY | |
276 | && ref->next->u.ar.type != AR_ELEMENT) | |
277 | { | |
278 | with_data = true; | |
279 | if (full_array) | |
280 | *full_array = ref->next->u.ar.type == AR_FULL; | |
281 | } | |
282 | } | |
283 | ||
284 | return no_data || with_data; | |
285 | } | |
286 | ||
287 | ||
288 | /* Returns true if the expression contains a reference to a class | |
289 | array. Notice that class array elements return false. */ | |
290 | ||
291 | bool | |
292 | gfc_is_class_array_ref (gfc_expr *e, bool *full_array) | |
293 | { | |
294 | gfc_ref *ref; | |
295 | ||
296 | if (!e->rank) | |
297 | return false; | |
298 | ||
299 | if (full_array) | |
300 | *full_array= false; | |
301 | ||
302 | /* Is this a class array object? ie. Is the symbol of type class? */ | |
303 | if (e->symtree | |
304 | && e->symtree->n.sym->ts.type == BT_CLASS | |
305 | && CLASS_DATA (e->symtree->n.sym) | |
306 | && CLASS_DATA (e->symtree->n.sym)->attr.dimension | |
307 | && class_array_ref_detected (e->ref, full_array)) | |
308 | return true; | |
309 | ||
310 | /* Or is this a class array component reference? */ | |
311 | for (ref = e->ref; ref; ref = ref->next) | |
312 | { | |
313 | if (ref->type == REF_COMPONENT | |
314 | && ref->u.c.component->ts.type == BT_CLASS | |
315 | && CLASS_DATA (ref->u.c.component)->attr.dimension | |
316 | && class_array_ref_detected (ref->next, full_array)) | |
317 | return true; | |
318 | } | |
319 | ||
320 | return false; | |
321 | } | |
322 | ||
323 | ||
324 | /* Returns true if the expression is a reference to a class | |
325 | scalar. This function is necessary because such expressions | |
326 | can be dressed with a reference to the _data component and so | |
327 | have a type other than BT_CLASS. */ | |
328 | ||
329 | bool | |
330 | gfc_is_class_scalar_expr (gfc_expr *e) | |
331 | { | |
332 | gfc_ref *ref; | |
333 | ||
334 | if (e->rank) | |
335 | return false; | |
336 | ||
337 | /* Is this a class object? */ | |
338 | if (e->symtree | |
339 | && e->symtree->n.sym->ts.type == BT_CLASS | |
340 | && CLASS_DATA (e->symtree->n.sym) | |
341 | && !CLASS_DATA (e->symtree->n.sym)->attr.dimension | |
342 | && (e->ref == NULL | |
343 | || (strcmp (e->ref->u.c.component->name, "_data") == 0 | |
344 | && e->ref->next == NULL))) | |
345 | return true; | |
346 | ||
347 | /* Or is the final reference BT_CLASS or _data? */ | |
348 | for (ref = e->ref; ref; ref = ref->next) | |
349 | { | |
350 | if (ref->type == REF_COMPONENT | |
351 | && ref->u.c.component->ts.type == BT_CLASS | |
352 | && CLASS_DATA (ref->u.c.component) | |
353 | && !CLASS_DATA (ref->u.c.component)->attr.dimension | |
354 | && (ref->next == NULL | |
355 | || (strcmp (ref->next->u.c.component->name, "_data") == 0 | |
356 | && ref->next->next == NULL))) | |
357 | return true; | |
358 | } | |
359 | ||
360 | return false; | |
361 | } | |
362 | ||
363 | ||
5bf5fa56 MM |
364 | /* Tells whether the expression E is a reference to a (scalar) class container. |
365 | Scalar because array class containers usually have an array reference after | |
366 | them, and gfc_fix_class_refs will add the missing "_data" component reference | |
367 | in that case. */ | |
368 | ||
369 | bool | |
370 | gfc_is_class_container_ref (gfc_expr *e) | |
371 | { | |
372 | gfc_ref *ref; | |
373 | bool result; | |
374 | ||
375 | if (e->expr_type != EXPR_VARIABLE) | |
376 | return e->ts.type == BT_CLASS; | |
377 | ||
378 | if (e->symtree->n.sym->ts.type == BT_CLASS) | |
379 | result = true; | |
380 | else | |
381 | result = false; | |
382 | ||
383 | for (ref = e->ref; ref; ref = ref->next) | |
384 | { | |
385 | if (ref->type != REF_COMPONENT) | |
386 | result = false; | |
387 | else if (ref->u.c.component->ts.type == BT_CLASS) | |
388 | result = true; | |
389 | else | |
390 | result = false; | |
391 | } | |
392 | ||
393 | return result; | |
394 | } | |
395 | ||
396 | ||
d15bac21 | 397 | /* Build a NULL initializer for CLASS pointers, |
0d87fa8c JW |
398 | initializing the _data component to NULL and |
399 | the _vptr component to the declared type. */ | |
d15bac21 JW |
400 | |
401 | gfc_expr * | |
402 | gfc_class_null_initializer (gfc_typespec *ts) | |
403 | { | |
404 | gfc_expr *init; | |
405 | gfc_component *comp; | |
406 | ||
407 | init = gfc_get_structure_constructor_expr (ts->type, ts->kind, | |
408 | &ts->u.derived->declared_at); | |
409 | init->ts = *ts; | |
410 | ||
411 | for (comp = ts->u.derived->components; comp; comp = comp->next) | |
412 | { | |
413 | gfc_constructor *ctor = gfc_constructor_get(); | |
0d87fa8c JW |
414 | if (strcmp (comp->name, "_vptr") == 0) |
415 | ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); | |
416 | else | |
417 | ctor->expr = gfc_get_null_expr (NULL); | |
d15bac21 JW |
418 | gfc_constructor_append (&init->value.constructor, ctor); |
419 | } | |
420 | ||
421 | return init; | |
422 | } | |
423 | ||
424 | ||
b04533af JW |
425 | /* Create a unique string identifier for a derived type, composed of its name |
426 | and module name. This is used to construct unique names for the class | |
427 | containers and vtab symbols. */ | |
428 | ||
429 | static void | |
430 | get_unique_type_string (char *string, gfc_symbol *derived) | |
b52956be JW |
431 | { |
432 | char dt_name[GFC_MAX_SYMBOL_LEN+1]; | |
433 | sprintf (dt_name, "%s", derived->name); | |
434 | dt_name[0] = TOUPPER (dt_name[0]); | |
b04533af | 435 | if (derived->module) |
b52956be | 436 | sprintf (string, "%s_%s", derived->module, dt_name); |
4fa02692 | 437 | else if (derived->ns->proc_name) |
b52956be | 438 | sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); |
4fa02692 | 439 | else |
b52956be | 440 | sprintf (string, "_%s", dt_name); |
4fa02692 JW |
441 | } |
442 | ||
443 | ||
444 | /* A relative of 'get_unique_type_string' which makes sure the generated | |
445 | string will not be too long (replacing it by a hash string if needed). */ | |
446 | ||
447 | static void | |
448 | get_unique_hashed_string (char *string, gfc_symbol *derived) | |
449 | { | |
450 | char tmp[2*GFC_MAX_SYMBOL_LEN+2]; | |
451 | get_unique_type_string (&tmp[0], derived); | |
cb83a137 | 452 | /* If string is too long, use hash value in hex representation (allow for |
2419ff64 TB |
453 | extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). |
454 | We need space to for 15 characters "__class_" + symbol name + "_%d_%da", | |
455 | where %d is the (co)rank which can be up to n = 15. */ | |
456 | if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) | |
4fa02692 JW |
457 | { |
458 | int h = gfc_hash_value (derived); | |
459 | sprintf (string, "%X", h); | |
460 | } | |
461 | else | |
462 | strcpy (string, tmp); | |
463 | } | |
464 | ||
465 | ||
466 | /* Assign a hash value for a derived type. The algorithm is that of SDBM. */ | |
467 | ||
468 | unsigned int | |
469 | gfc_hash_value (gfc_symbol *sym) | |
470 | { | |
471 | unsigned int hash = 0; | |
472 | char c[2*(GFC_MAX_SYMBOL_LEN+1)]; | |
473 | int i, len; | |
474 | ||
475 | get_unique_type_string (&c[0], sym); | |
476 | len = strlen (c); | |
477 | ||
478 | for (i = 0; i < len; i++) | |
479 | hash = (hash << 6) + (hash << 16) - hash + c[i]; | |
480 | ||
481 | /* Return the hash but take the modulus for the sake of module read, | |
482 | even though this slightly increases the chance of collision. */ | |
483 | return (hash % 100000000); | |
b04533af JW |
484 | } |
485 | ||
486 | ||
d15bac21 JW |
487 | /* Build a polymorphic CLASS entity, using the symbol that comes from |
488 | build_sym. A CLASS entity is represented by an encapsulating type, | |
b04533af JW |
489 | which contains the declared type as '_data' component, plus a pointer |
490 | component '_vptr' which determines the dynamic type. */ | |
d15bac21 JW |
491 | |
492 | gfc_try | |
493 | gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, | |
494 | gfc_array_spec **as, bool delayed_vtab) | |
495 | { | |
4fa02692 | 496 | char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; |
d15bac21 JW |
497 | gfc_symbol *fclass; |
498 | gfc_symbol *vtab; | |
499 | gfc_component *c; | |
c49ea23d PT |
500 | |
501 | if (as && *as && (*as)->type == AS_ASSUMED_SIZE) | |
502 | { | |
503 | gfc_error ("Assumed size polymorphic objects or components, such " | |
504 | "as that at %C, have not yet been implemented"); | |
505 | return FAILURE; | |
506 | } | |
507 | ||
528622fd JW |
508 | if (attr->class_ok) |
509 | /* Class container has already been built. */ | |
510 | return SUCCESS; | |
511 | ||
7d40e49f TB |
512 | attr->class_ok = attr->dummy || attr->pointer || attr->allocatable |
513 | || attr->select_type_temporary; | |
528622fd JW |
514 | |
515 | if (!attr->class_ok) | |
516 | /* We can not build the class container yet. */ | |
517 | return SUCCESS; | |
d15bac21 JW |
518 | |
519 | /* Determine the name of the encapsulating type. */ | |
4fa02692 | 520 | get_unique_hashed_string (tname, ts->u.derived); |
2419ff64 TB |
521 | if ((*as) && attr->allocatable) |
522 | sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); | |
523 | else if ((*as)) | |
524 | sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); | |
d15bac21 | 525 | else if (attr->pointer) |
b04533af | 526 | sprintf (name, "__class_%s_p", tname); |
d15bac21 | 527 | else if (attr->allocatable) |
b04533af | 528 | sprintf (name, "__class_%s_a", tname); |
d15bac21 | 529 | else |
b04533af | 530 | sprintf (name, "__class_%s", tname); |
d15bac21 JW |
531 | |
532 | gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); | |
533 | if (fclass == NULL) | |
534 | { | |
535 | gfc_symtree *st; | |
536 | /* If not there, create a new symbol. */ | |
537 | fclass = gfc_new_symbol (name, ts->u.derived->ns); | |
538 | st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); | |
539 | st->n.sym = fclass; | |
540 | gfc_set_sym_referenced (fclass); | |
541 | fclass->refs++; | |
542 | fclass->ts.type = BT_UNKNOWN; | |
543 | fclass->attr.abstract = ts->u.derived->attr.abstract; | |
544 | if (ts->u.derived->f2k_derived) | |
545 | fclass->f2k_derived = gfc_get_namespace (NULL, 0); | |
546 | if (gfc_add_flavor (&fclass->attr, FL_DERIVED, | |
547 | NULL, &gfc_current_locus) == FAILURE) | |
548 | return FAILURE; | |
549 | ||
b04533af JW |
550 | /* Add component '_data'. */ |
551 | if (gfc_add_component (fclass, "_data", &c) == FAILURE) | |
d15bac21 JW |
552 | return FAILURE; |
553 | c->ts = *ts; | |
554 | c->ts.type = BT_DERIVED; | |
555 | c->attr.access = ACCESS_PRIVATE; | |
556 | c->ts.u.derived = ts->u.derived; | |
557 | c->attr.class_pointer = attr->pointer; | |
7d40e49f TB |
558 | c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) |
559 | || attr->select_type_temporary; | |
d15bac21 JW |
560 | c->attr.allocatable = attr->allocatable; |
561 | c->attr.dimension = attr->dimension; | |
562 | c->attr.codimension = attr->codimension; | |
563 | c->attr.abstract = ts->u.derived->attr.abstract; | |
564 | c->as = (*as); | |
565 | c->initializer = NULL; | |
566 | ||
b04533af JW |
567 | /* Add component '_vptr'. */ |
568 | if (gfc_add_component (fclass, "_vptr", &c) == FAILURE) | |
d15bac21 JW |
569 | return FAILURE; |
570 | c->ts.type = BT_DERIVED; | |
571 | if (delayed_vtab) | |
572 | c->ts.u.derived = NULL; | |
573 | else | |
574 | { | |
88ce8031 | 575 | vtab = gfc_find_derived_vtab (ts->u.derived); |
d15bac21 JW |
576 | gcc_assert (vtab); |
577 | c->ts.u.derived = vtab->ts.u.derived; | |
578 | } | |
f3f98a1e | 579 | c->attr.access = ACCESS_PRIVATE; |
d15bac21 JW |
580 | c->attr.pointer = 1; |
581 | } | |
f5a5c890 | 582 | else if (!fclass->f2k_derived) |
5cfa7039 | 583 | fclass->f2k_derived = gfc_get_namespace (NULL, 0); |
d15bac21 JW |
584 | |
585 | /* Since the extension field is 8 bit wide, we can only have | |
586 | up to 255 extension levels. */ | |
587 | if (ts->u.derived->attr.extension == 255) | |
588 | { | |
589 | gfc_error ("Maximum extension level reached with type '%s' at %L", | |
590 | ts->u.derived->name, &ts->u.derived->declared_at); | |
591 | return FAILURE; | |
592 | } | |
593 | ||
594 | fclass->attr.extension = ts->u.derived->attr.extension + 1; | |
d6430d9a | 595 | fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; |
d15bac21 JW |
596 | fclass->attr.is_class = 1; |
597 | ts->u.derived = fclass; | |
c49ea23d PT |
598 | attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; |
599 | (*as) = NULL; | |
d15bac21 JW |
600 | return SUCCESS; |
601 | } | |
602 | ||
603 | ||
88ce8031 JW |
604 | /* Add a procedure pointer component to the vtype |
605 | to represent a specific type-bound procedure. */ | |
606 | ||
d15bac21 | 607 | static void |
88ce8031 | 608 | add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) |
d15bac21 | 609 | { |
88ce8031 | 610 | gfc_component *c; |
fd83db3d JW |
611 | |
612 | if (tb->non_overridable) | |
613 | return; | |
614 | ||
88ce8031 JW |
615 | c = gfc_find_component (vtype, name, true, true); |
616 | ||
617 | if (c == NULL) | |
d15bac21 | 618 | { |
88ce8031 JW |
619 | /* Add procedure component. */ |
620 | if (gfc_add_component (vtype, name, &c) == FAILURE) | |
d15bac21 | 621 | return; |
d15bac21 | 622 | |
88ce8031 JW |
623 | if (!c->tb) |
624 | c->tb = XCNEW (gfc_typebound_proc); | |
625 | *c->tb = *tb; | |
626 | c->tb->ppc = 1; | |
627 | c->attr.procedure = 1; | |
628 | c->attr.proc_pointer = 1; | |
629 | c->attr.flavor = FL_PROCEDURE; | |
630 | c->attr.access = ACCESS_PRIVATE; | |
631 | c->attr.external = 1; | |
632 | c->attr.untyped = 1; | |
633 | c->attr.if_source = IFSRC_IFBODY; | |
d15bac21 JW |
634 | } |
635 | else if (c->attr.proc_pointer && c->tb) | |
636 | { | |
88ce8031 | 637 | *c->tb = *tb; |
d15bac21 | 638 | c->tb->ppc = 1; |
1d0134b3 JW |
639 | } |
640 | ||
641 | if (tb->u.specific) | |
642 | { | |
643 | c->ts.interface = tb->u.specific->n.sym; | |
644 | if (!tb->deferred) | |
645 | c->initializer = gfc_get_variable_expr (tb->u.specific); | |
d15bac21 JW |
646 | } |
647 | } | |
648 | ||
88ce8031 JW |
649 | |
650 | /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ | |
651 | ||
d15bac21 | 652 | static void |
88ce8031 | 653 | add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) |
d15bac21 | 654 | { |
d15bac21 JW |
655 | if (!st) |
656 | return; | |
657 | ||
658 | if (st->left) | |
88ce8031 | 659 | add_procs_to_declared_vtab1 (st->left, vtype); |
d15bac21 JW |
660 | |
661 | if (st->right) | |
88ce8031 | 662 | add_procs_to_declared_vtab1 (st->right, vtype); |
d15bac21 | 663 | |
aea18e92 JW |
664 | if (st->n.tb && !st->n.tb->error |
665 | && !st->n.tb->is_generic && st->n.tb->u.specific) | |
88ce8031 | 666 | add_proc_comp (vtype, st->name, st->n.tb); |
d15bac21 JW |
667 | } |
668 | ||
669 | ||
88ce8031 JW |
670 | /* Copy procedure pointers components from the parent type. */ |
671 | ||
d15bac21 | 672 | static void |
88ce8031 | 673 | copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) |
d15bac21 | 674 | { |
88ce8031 | 675 | gfc_component *cmp; |
d15bac21 JW |
676 | gfc_symbol *vtab; |
677 | ||
88ce8031 | 678 | vtab = gfc_find_derived_vtab (declared); |
d15bac21 JW |
679 | |
680 | for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) | |
681 | { | |
682 | if (gfc_find_component (vtype, cmp->name, true, true)) | |
683 | continue; | |
684 | ||
88ce8031 | 685 | add_proc_comp (vtype, cmp->name, cmp->tb); |
d15bac21 JW |
686 | } |
687 | } | |
688 | ||
d15bac21 | 689 | |
88ce8031 | 690 | /* Add procedure pointers for all type-bound procedures to a vtab. */ |
d15bac21 JW |
691 | |
692 | static void | |
88ce8031 | 693 | add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) |
d15bac21 | 694 | { |
d15bac21 JW |
695 | gfc_symbol* super_type; |
696 | ||
88ce8031 | 697 | super_type = gfc_get_derived_super_type (derived); |
d15bac21 | 698 | |
88ce8031 | 699 | if (super_type && (super_type != derived)) |
d15bac21 | 700 | { |
88ce8031 JW |
701 | /* Make sure that the PPCs appear in the same order as in the parent. */ |
702 | copy_vtab_proc_comps (super_type, vtype); | |
1d0134b3 | 703 | /* Only needed to get the PPC initializers right. */ |
88ce8031 JW |
704 | add_procs_to_declared_vtab (super_type, vtype); |
705 | } | |
d15bac21 | 706 | |
88ce8031 JW |
707 | if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) |
708 | add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); | |
d15bac21 | 709 | |
88ce8031 JW |
710 | if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) |
711 | add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); | |
d15bac21 JW |
712 | } |
713 | ||
714 | ||
611c64f0 | 715 | /* Find (or generate) the symbol for a derived type's vtab. */ |
d15bac21 JW |
716 | |
717 | gfc_symbol * | |
88ce8031 | 718 | gfc_find_derived_vtab (gfc_symbol *derived) |
d15bac21 JW |
719 | { |
720 | gfc_namespace *ns; | |
50f30801 | 721 | gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; |
611c64f0 | 722 | gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; |
c49ea23d | 723 | |
e10f52d0 JW |
724 | /* Find the top-level namespace (MODULE or PROGRAM). */ |
725 | for (ns = gfc_current_ns; ns; ns = ns->parent) | |
d15bac21 JW |
726 | if (!ns->parent) |
727 | break; | |
728 | ||
e10f52d0 JW |
729 | /* If the type is a class container, use the underlying derived type. */ |
730 | if (derived->attr.is_class) | |
731 | derived = gfc_get_derived_super_type (derived); | |
732 | ||
d15bac21 JW |
733 | if (ns) |
734 | { | |
4fa02692 | 735 | char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; |
b04533af | 736 | |
4fa02692 | 737 | get_unique_hashed_string (tname, derived); |
b04533af | 738 | sprintf (name, "__vtab_%s", tname); |
611c64f0 JW |
739 | |
740 | /* Look for the vtab symbol in various namespaces. */ | |
741 | gfc_find_symbol (name, gfc_current_ns, 0, &vtab); | |
742 | if (vtab == NULL) | |
743 | gfc_find_symbol (name, ns, 0, &vtab); | |
744 | if (vtab == NULL) | |
745 | gfc_find_symbol (name, derived->ns, 0, &vtab); | |
d15bac21 JW |
746 | |
747 | if (vtab == NULL) | |
748 | { | |
749 | gfc_get_symbol (name, ns, &vtab); | |
750 | vtab->ts.type = BT_DERIVED; | |
22c30bc0 | 751 | if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, |
e10f52d0 JW |
752 | &gfc_current_locus) == FAILURE) |
753 | goto cleanup; | |
d15bac21 | 754 | vtab->attr.target = 1; |
95f5c775 | 755 | vtab->attr.save = SAVE_IMPLICIT; |
d15bac21 | 756 | vtab->attr.vtab = 1; |
f3f98a1e | 757 | vtab->attr.access = ACCESS_PUBLIC; |
d15bac21 | 758 | gfc_set_sym_referenced (vtab); |
b04533af | 759 | sprintf (name, "__vtype_%s", tname); |
d15bac21 JW |
760 | |
761 | gfc_find_symbol (name, ns, 0, &vtype); | |
762 | if (vtype == NULL) | |
763 | { | |
764 | gfc_component *c; | |
765 | gfc_symbol *parent = NULL, *parent_vtab = NULL; | |
766 | ||
767 | gfc_get_symbol (name, ns, &vtype); | |
768 | if (gfc_add_flavor (&vtype->attr, FL_DERIVED, | |
769 | NULL, &gfc_current_locus) == FAILURE) | |
81fb8a48 | 770 | goto cleanup; |
f3f98a1e | 771 | vtype->attr.access = ACCESS_PUBLIC; |
611c64f0 | 772 | vtype->attr.vtype = 1; |
d15bac21 JW |
773 | gfc_set_sym_referenced (vtype); |
774 | ||
b04533af JW |
775 | /* Add component '_hash'. */ |
776 | if (gfc_add_component (vtype, "_hash", &c) == FAILURE) | |
81fb8a48 | 777 | goto cleanup; |
d15bac21 JW |
778 | c->ts.type = BT_INTEGER; |
779 | c->ts.kind = 4; | |
780 | c->attr.access = ACCESS_PRIVATE; | |
781 | c->initializer = gfc_get_int_expr (gfc_default_integer_kind, | |
782 | NULL, derived->hash_value); | |
783 | ||
b04533af JW |
784 | /* Add component '_size'. */ |
785 | if (gfc_add_component (vtype, "_size", &c) == FAILURE) | |
81fb8a48 | 786 | goto cleanup; |
d15bac21 JW |
787 | c->ts.type = BT_INTEGER; |
788 | c->ts.kind = 4; | |
789 | c->attr.access = ACCESS_PRIVATE; | |
790 | /* Remember the derived type in ts.u.derived, | |
791 | so that the correct initializer can be set later on | |
792 | (in gfc_conv_structure). */ | |
793 | c->ts.u.derived = derived; | |
794 | c->initializer = gfc_get_int_expr (gfc_default_integer_kind, | |
795 | NULL, 0); | |
796 | ||
b04533af JW |
797 | /* Add component _extends. */ |
798 | if (gfc_add_component (vtype, "_extends", &c) == FAILURE) | |
81fb8a48 | 799 | goto cleanup; |
d15bac21 JW |
800 | c->attr.pointer = 1; |
801 | c->attr.access = ACCESS_PRIVATE; | |
802 | parent = gfc_get_derived_super_type (derived); | |
803 | if (parent) | |
804 | { | |
88ce8031 | 805 | parent_vtab = gfc_find_derived_vtab (parent); |
d15bac21 JW |
806 | c->ts.type = BT_DERIVED; |
807 | c->ts.u.derived = parent_vtab->ts.u.derived; | |
808 | c->initializer = gfc_get_expr (); | |
809 | c->initializer->expr_type = EXPR_VARIABLE; | |
810 | gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, | |
811 | 0, &c->initializer->symtree); | |
812 | } | |
813 | else | |
814 | { | |
815 | c->ts.type = BT_DERIVED; | |
816 | c->ts.u.derived = vtype; | |
817 | c->initializer = gfc_get_null_expr (NULL); | |
818 | } | |
819 | ||
611c64f0 JW |
820 | if (derived->components == NULL && !derived->attr.zero_comp) |
821 | { | |
822 | /* At this point an error must have occurred. | |
823 | Prevent further errors on the vtype components. */ | |
824 | found_sym = vtab; | |
825 | goto have_vtype; | |
826 | } | |
827 | ||
b04533af JW |
828 | /* Add component _def_init. */ |
829 | if (gfc_add_component (vtype, "_def_init", &c) == FAILURE) | |
50f30801 JW |
830 | goto cleanup; |
831 | c->attr.pointer = 1; | |
832 | c->attr.access = ACCESS_PRIVATE; | |
833 | c->ts.type = BT_DERIVED; | |
834 | c->ts.u.derived = derived; | |
835 | if (derived->attr.abstract) | |
611c64f0 | 836 | c->initializer = gfc_get_null_expr (NULL); |
50f30801 JW |
837 | else |
838 | { | |
839 | /* Construct default initialization variable. */ | |
b04533af | 840 | sprintf (name, "__def_init_%s", tname); |
50f30801 JW |
841 | gfc_get_symbol (name, ns, &def_init); |
842 | def_init->attr.target = 1; | |
95f5c775 | 843 | def_init->attr.save = SAVE_IMPLICIT; |
50f30801 | 844 | def_init->attr.access = ACCESS_PUBLIC; |
22c30bc0 | 845 | def_init->attr.flavor = FL_VARIABLE; |
50f30801 JW |
846 | gfc_set_sym_referenced (def_init); |
847 | def_init->ts.type = BT_DERIVED; | |
848 | def_init->ts.u.derived = derived; | |
849 | def_init->value = gfc_default_initializer (&def_init->ts); | |
850 | ||
851 | c->initializer = gfc_lval_expr_from_sym (def_init); | |
852 | } | |
853 | ||
b04533af JW |
854 | /* Add component _copy. */ |
855 | if (gfc_add_component (vtype, "_copy", &c) == FAILURE) | |
611c64f0 JW |
856 | goto cleanup; |
857 | c->attr.proc_pointer = 1; | |
858 | c->attr.access = ACCESS_PRIVATE; | |
859 | c->tb = XCNEW (gfc_typebound_proc); | |
860 | c->tb->ppc = 1; | |
861 | if (derived->attr.abstract) | |
862 | c->initializer = gfc_get_null_expr (NULL); | |
863 | else | |
864 | { | |
865 | /* Set up namespace. */ | |
866 | gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); | |
867 | sub_ns->sibling = ns->contained; | |
868 | ns->contained = sub_ns; | |
869 | sub_ns->resolved = 1; | |
870 | /* Set up procedure symbol. */ | |
b04533af | 871 | sprintf (name, "__copy_%s", tname); |
611c64f0 JW |
872 | gfc_get_symbol (name, sub_ns, ©); |
873 | sub_ns->proc_name = copy; | |
874 | copy->attr.flavor = FL_PROCEDURE; | |
cf651ca2 | 875 | copy->attr.subroutine = 1; |
0b73eb81 | 876 | copy->attr.pure = 1; |
611c64f0 | 877 | copy->attr.if_source = IFSRC_DECL; |
c49ea23d PT |
878 | /* This is elemental so that arrays are automatically |
879 | treated correctly by the scalarizer. */ | |
880 | copy->attr.elemental = 1; | |
844ba455 JW |
881 | if (ns->proc_name->attr.flavor == FL_MODULE) |
882 | copy->module = ns->proc_name->name; | |
611c64f0 JW |
883 | gfc_set_sym_referenced (copy); |
884 | /* Set up formal arguments. */ | |
885 | gfc_get_symbol ("src", sub_ns, &src); | |
886 | src->ts.type = BT_DERIVED; | |
887 | src->ts.u.derived = derived; | |
888 | src->attr.flavor = FL_VARIABLE; | |
889 | src->attr.dummy = 1; | |
c49ea23d | 890 | src->attr.intent = INTENT_IN; |
611c64f0 JW |
891 | gfc_set_sym_referenced (src); |
892 | copy->formal = gfc_get_formal_arglist (); | |
893 | copy->formal->sym = src; | |
894 | gfc_get_symbol ("dst", sub_ns, &dst); | |
895 | dst->ts.type = BT_DERIVED; | |
896 | dst->ts.u.derived = derived; | |
897 | dst->attr.flavor = FL_VARIABLE; | |
898 | dst->attr.dummy = 1; | |
c49ea23d | 899 | dst->attr.intent = INTENT_OUT; |
611c64f0 JW |
900 | gfc_set_sym_referenced (dst); |
901 | copy->formal->next = gfc_get_formal_arglist (); | |
902 | copy->formal->next->sym = dst; | |
903 | /* Set up code. */ | |
904 | sub_ns->code = gfc_get_code (); | |
2e85ae0d | 905 | sub_ns->code->op = EXEC_INIT_ASSIGN; |
611c64f0 JW |
906 | sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); |
907 | sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); | |
908 | /* Set initializer. */ | |
909 | c->initializer = gfc_lval_expr_from_sym (copy); | |
910 | c->ts.interface = copy; | |
911 | } | |
912 | ||
50f30801 | 913 | /* Add procedure pointers for type-bound procedures. */ |
88ce8031 | 914 | add_procs_to_declared_vtab (derived, vtype); |
d15bac21 JW |
915 | } |
916 | ||
611c64f0 | 917 | have_vtype: |
d15bac21 JW |
918 | vtab->ts.u.derived = vtype; |
919 | vtab->value = gfc_default_initializer (&vtab->ts); | |
920 | } | |
921 | } | |
922 | ||
81fb8a48 MM |
923 | found_sym = vtab; |
924 | ||
925 | cleanup: | |
926 | /* It is unexpected to have some symbols added at resolution or code | |
927 | generation time. We commit the changes in order to keep a clean state. */ | |
928 | if (found_sym) | |
e10f52d0 JW |
929 | { |
930 | gfc_commit_symbol (vtab); | |
931 | if (vtype) | |
932 | gfc_commit_symbol (vtype); | |
50f30801 JW |
933 | if (def_init) |
934 | gfc_commit_symbol (def_init); | |
611c64f0 JW |
935 | if (copy) |
936 | gfc_commit_symbol (copy); | |
937 | if (src) | |
938 | gfc_commit_symbol (src); | |
939 | if (dst) | |
940 | gfc_commit_symbol (dst); | |
e10f52d0 | 941 | } |
81fb8a48 MM |
942 | else |
943 | gfc_undo_symbols (); | |
944 | ||
945 | return found_sym; | |
d15bac21 JW |
946 | } |
947 | ||
948 | ||
949 | /* General worker function to find either a type-bound procedure or a | |
950 | type-bound user operator. */ | |
951 | ||
952 | static gfc_symtree* | |
953 | find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, | |
954 | const char* name, bool noaccess, bool uop, | |
955 | locus* where) | |
956 | { | |
957 | gfc_symtree* res; | |
958 | gfc_symtree* root; | |
959 | ||
960 | /* Set correct symbol-root. */ | |
961 | gcc_assert (derived->f2k_derived); | |
962 | root = (uop ? derived->f2k_derived->tb_uop_root | |
963 | : derived->f2k_derived->tb_sym_root); | |
964 | ||
965 | /* Set default to failure. */ | |
966 | if (t) | |
967 | *t = FAILURE; | |
968 | ||
969 | /* Try to find it in the current type's namespace. */ | |
970 | res = gfc_find_symtree (root, name); | |
971 | if (res && res->n.tb && !res->n.tb->error) | |
972 | { | |
973 | /* We found one. */ | |
974 | if (t) | |
975 | *t = SUCCESS; | |
976 | ||
977 | if (!noaccess && derived->attr.use_assoc | |
978 | && res->n.tb->access == ACCESS_PRIVATE) | |
979 | { | |
980 | if (where) | |
981 | gfc_error ("'%s' of '%s' is PRIVATE at %L", | |
982 | name, derived->name, where); | |
983 | if (t) | |
984 | *t = FAILURE; | |
985 | } | |
986 | ||
987 | return res; | |
988 | } | |
989 | ||
990 | /* Otherwise, recurse on parent type if derived is an extension. */ | |
991 | if (derived->attr.extension) | |
992 | { | |
993 | gfc_symbol* super_type; | |
994 | super_type = gfc_get_derived_super_type (derived); | |
995 | gcc_assert (super_type); | |
996 | ||
997 | return find_typebound_proc_uop (super_type, t, name, | |
998 | noaccess, uop, where); | |
999 | } | |
1000 | ||
1001 | /* Nothing found. */ | |
1002 | return NULL; | |
1003 | } | |
1004 | ||
1005 | ||
1006 | /* Find a type-bound procedure or user operator by name for a derived-type | |
1007 | (looking recursively through the super-types). */ | |
1008 | ||
1009 | gfc_symtree* | |
1010 | gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, | |
1011 | const char* name, bool noaccess, locus* where) | |
1012 | { | |
1013 | return find_typebound_proc_uop (derived, t, name, noaccess, false, where); | |
1014 | } | |
1015 | ||
1016 | gfc_symtree* | |
1017 | gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, | |
1018 | const char* name, bool noaccess, locus* where) | |
1019 | { | |
1020 | return find_typebound_proc_uop (derived, t, name, noaccess, true, where); | |
1021 | } | |
1022 | ||
1023 | ||
1024 | /* Find a type-bound intrinsic operator looking recursively through the | |
1025 | super-type hierarchy. */ | |
1026 | ||
1027 | gfc_typebound_proc* | |
1028 | gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, | |
1029 | gfc_intrinsic_op op, bool noaccess, | |
1030 | locus* where) | |
1031 | { | |
1032 | gfc_typebound_proc* res; | |
1033 | ||
1034 | /* Set default to failure. */ | |
1035 | if (t) | |
1036 | *t = FAILURE; | |
1037 | ||
1038 | /* Try to find it in the current type's namespace. */ | |
1039 | if (derived->f2k_derived) | |
1040 | res = derived->f2k_derived->tb_op[op]; | |
1041 | else | |
1042 | res = NULL; | |
1043 | ||
1044 | /* Check access. */ | |
1045 | if (res && !res->error) | |
1046 | { | |
1047 | /* We found one. */ | |
1048 | if (t) | |
1049 | *t = SUCCESS; | |
1050 | ||
1051 | if (!noaccess && derived->attr.use_assoc | |
1052 | && res->access == ACCESS_PRIVATE) | |
1053 | { | |
1054 | if (where) | |
1055 | gfc_error ("'%s' of '%s' is PRIVATE at %L", | |
1056 | gfc_op2string (op), derived->name, where); | |
1057 | if (t) | |
1058 | *t = FAILURE; | |
1059 | } | |
1060 | ||
1061 | return res; | |
1062 | } | |
1063 | ||
1064 | /* Otherwise, recurse on parent type if derived is an extension. */ | |
1065 | if (derived->attr.extension) | |
1066 | { | |
1067 | gfc_symbol* super_type; | |
1068 | super_type = gfc_get_derived_super_type (derived); | |
1069 | gcc_assert (super_type); | |
1070 | ||
1071 | return gfc_find_typebound_intrinsic_op (super_type, t, op, | |
1072 | noaccess, where); | |
1073 | } | |
1074 | ||
1075 | /* Nothing found. */ | |
1076 | return NULL; | |
1077 | } | |
1078 | ||
1079 | ||
1080 | /* Get a typebound-procedure symtree or create and insert it if not yet | |
1081 | present. This is like a very simplified version of gfc_get_sym_tree for | |
1082 | tbp-symtrees rather than regular ones. */ | |
1083 | ||
1084 | gfc_symtree* | |
1085 | gfc_get_tbp_symtree (gfc_symtree **root, const char *name) | |
1086 | { | |
1087 | gfc_symtree *result; | |
1088 | ||
1089 | result = gfc_find_symtree (*root, name); | |
1090 | if (!result) | |
1091 | { | |
1092 | result = gfc_new_symtree (root, name); | |
1093 | gcc_assert (result); | |
1094 | result->n.tb = NULL; | |
1095 | } | |
1096 | ||
1097 | return result; | |
1098 | } |