]>
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 | ||
55 | /* Insert a reference to the component of the given name. | |
b04533af | 56 | Only to be used with CLASS containers and vtables. */ |
d15bac21 JW |
57 | |
58 | void | |
59 | gfc_add_component_ref (gfc_expr *e, const char *name) | |
60 | { | |
61 | gfc_ref **tail = &(e->ref); | |
62 | gfc_ref *next = NULL; | |
63 | gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; | |
64 | while (*tail != NULL) | |
65 | { | |
66 | if ((*tail)->type == REF_COMPONENT) | |
c49ea23d PT |
67 | { |
68 | if (strcmp ((*tail)->u.c.component->name, "_data") == 0 | |
69 | && (*tail)->next | |
70 | && (*tail)->next->type == REF_ARRAY | |
71 | && (*tail)->next->next == NULL) | |
72 | return; | |
73 | derived = (*tail)->u.c.component->ts.u.derived; | |
74 | } | |
d15bac21 JW |
75 | if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) |
76 | break; | |
77 | tail = &((*tail)->next); | |
78 | } | |
b04533af | 79 | if (*tail != NULL && strcmp (name, "_data") == 0) |
d15bac21 JW |
80 | next = *tail; |
81 | (*tail) = gfc_get_ref(); | |
82 | (*tail)->next = next; | |
83 | (*tail)->type = REF_COMPONENT; | |
84 | (*tail)->u.c.sym = derived; | |
85 | (*tail)->u.c.component = gfc_find_component (derived, name, true, true); | |
86 | gcc_assert((*tail)->u.c.component); | |
87 | if (!next) | |
88 | e->ts = (*tail)->u.c.component->ts; | |
89 | } | |
90 | ||
91 | ||
c49ea23d PT |
92 | /* This is used to add both the _data component reference and an array |
93 | reference to class expressions. Used in translation of intrinsic | |
94 | array inquiry functions. */ | |
95 | ||
96 | void | |
97 | gfc_add_class_array_ref (gfc_expr *e) | |
98 | { | |
99 | int rank = CLASS_DATA (e)->as->rank; | |
100 | gfc_array_spec *as = CLASS_DATA (e)->as; | |
101 | gfc_ref *ref = NULL; | |
102 | gfc_add_component_ref (e, "_data"); | |
103 | e->rank = rank; | |
104 | for (ref = e->ref; ref; ref = ref->next) | |
105 | if (!ref->next) | |
106 | break; | |
107 | if (ref->type != REF_ARRAY) | |
108 | { | |
109 | ref->next = gfc_get_ref (); | |
110 | ref = ref->next; | |
111 | ref->type = REF_ARRAY; | |
112 | ref->u.ar.type = AR_FULL; | |
113 | ref->u.ar.as = as; | |
114 | } | |
115 | } | |
116 | ||
117 | ||
118 | /* Unfortunately, class array expressions can appear in various conditions; | |
119 | with and without both _data component and an arrayspec. This function | |
120 | deals with that variability. The previous reference to 'ref' is to a | |
121 | class array. */ | |
122 | ||
123 | static bool | |
124 | class_array_ref_detected (gfc_ref *ref, bool *full_array) | |
125 | { | |
126 | bool no_data = false; | |
127 | bool with_data = false; | |
128 | ||
129 | /* An array reference with no _data component. */ | |
130 | if (ref && ref->type == REF_ARRAY | |
131 | && !ref->next | |
132 | && ref->u.ar.type != AR_ELEMENT) | |
133 | { | |
134 | if (full_array) | |
135 | *full_array = ref->u.ar.type == AR_FULL; | |
136 | no_data = true; | |
137 | } | |
138 | ||
139 | /* Cover cases where _data appears, with or without an array ref. */ | |
140 | if (ref && ref->type == REF_COMPONENT | |
141 | && strcmp (ref->u.c.component->name, "_data") == 0) | |
142 | { | |
143 | if (!ref->next) | |
144 | { | |
145 | with_data = true; | |
146 | if (full_array) | |
147 | *full_array = true; | |
148 | } | |
149 | else if (ref->next && ref->next->type == REF_ARRAY | |
150 | && !ref->next->next | |
151 | && ref->type == REF_COMPONENT | |
152 | && ref->next->type == REF_ARRAY | |
153 | && ref->next->u.ar.type != AR_ELEMENT) | |
154 | { | |
155 | with_data = true; | |
156 | if (full_array) | |
157 | *full_array = ref->next->u.ar.type == AR_FULL; | |
158 | } | |
159 | } | |
160 | ||
161 | return no_data || with_data; | |
162 | } | |
163 | ||
164 | ||
165 | /* Returns true if the expression contains a reference to a class | |
166 | array. Notice that class array elements return false. */ | |
167 | ||
168 | bool | |
169 | gfc_is_class_array_ref (gfc_expr *e, bool *full_array) | |
170 | { | |
171 | gfc_ref *ref; | |
172 | ||
173 | if (!e->rank) | |
174 | return false; | |
175 | ||
176 | if (full_array) | |
177 | *full_array= false; | |
178 | ||
179 | /* Is this a class array object? ie. Is the symbol of type class? */ | |
180 | if (e->symtree | |
181 | && e->symtree->n.sym->ts.type == BT_CLASS | |
182 | && CLASS_DATA (e->symtree->n.sym) | |
183 | && CLASS_DATA (e->symtree->n.sym)->attr.dimension | |
184 | && class_array_ref_detected (e->ref, full_array)) | |
185 | return true; | |
186 | ||
187 | /* Or is this a class array component reference? */ | |
188 | for (ref = e->ref; ref; ref = ref->next) | |
189 | { | |
190 | if (ref->type == REF_COMPONENT | |
191 | && ref->u.c.component->ts.type == BT_CLASS | |
192 | && CLASS_DATA (ref->u.c.component)->attr.dimension | |
193 | && class_array_ref_detected (ref->next, full_array)) | |
194 | return true; | |
195 | } | |
196 | ||
197 | return false; | |
198 | } | |
199 | ||
200 | ||
201 | /* Returns true if the expression is a reference to a class | |
202 | scalar. This function is necessary because such expressions | |
203 | can be dressed with a reference to the _data component and so | |
204 | have a type other than BT_CLASS. */ | |
205 | ||
206 | bool | |
207 | gfc_is_class_scalar_expr (gfc_expr *e) | |
208 | { | |
209 | gfc_ref *ref; | |
210 | ||
211 | if (e->rank) | |
212 | return false; | |
213 | ||
214 | /* Is this a class object? */ | |
215 | if (e->symtree | |
216 | && e->symtree->n.sym->ts.type == BT_CLASS | |
217 | && CLASS_DATA (e->symtree->n.sym) | |
218 | && !CLASS_DATA (e->symtree->n.sym)->attr.dimension | |
219 | && (e->ref == NULL | |
220 | || (strcmp (e->ref->u.c.component->name, "_data") == 0 | |
221 | && e->ref->next == NULL))) | |
222 | return true; | |
223 | ||
224 | /* Or is the final reference BT_CLASS or _data? */ | |
225 | for (ref = e->ref; ref; ref = ref->next) | |
226 | { | |
227 | if (ref->type == REF_COMPONENT | |
228 | && ref->u.c.component->ts.type == BT_CLASS | |
229 | && CLASS_DATA (ref->u.c.component) | |
230 | && !CLASS_DATA (ref->u.c.component)->attr.dimension | |
231 | && (ref->next == NULL | |
232 | || (strcmp (ref->next->u.c.component->name, "_data") == 0 | |
233 | && ref->next->next == NULL))) | |
234 | return true; | |
235 | } | |
236 | ||
237 | return false; | |
238 | } | |
239 | ||
240 | ||
d15bac21 | 241 | /* Build a NULL initializer for CLASS pointers, |
0d87fa8c JW |
242 | initializing the _data component to NULL and |
243 | the _vptr component to the declared type. */ | |
d15bac21 JW |
244 | |
245 | gfc_expr * | |
246 | gfc_class_null_initializer (gfc_typespec *ts) | |
247 | { | |
248 | gfc_expr *init; | |
249 | gfc_component *comp; | |
250 | ||
251 | init = gfc_get_structure_constructor_expr (ts->type, ts->kind, | |
252 | &ts->u.derived->declared_at); | |
253 | init->ts = *ts; | |
254 | ||
255 | for (comp = ts->u.derived->components; comp; comp = comp->next) | |
256 | { | |
257 | gfc_constructor *ctor = gfc_constructor_get(); | |
0d87fa8c JW |
258 | if (strcmp (comp->name, "_vptr") == 0) |
259 | ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); | |
260 | else | |
261 | ctor->expr = gfc_get_null_expr (NULL); | |
d15bac21 JW |
262 | gfc_constructor_append (&init->value.constructor, ctor); |
263 | } | |
264 | ||
265 | return init; | |
266 | } | |
267 | ||
268 | ||
b04533af JW |
269 | /* Create a unique string identifier for a derived type, composed of its name |
270 | and module name. This is used to construct unique names for the class | |
271 | containers and vtab symbols. */ | |
272 | ||
273 | static void | |
274 | get_unique_type_string (char *string, gfc_symbol *derived) | |
b52956be JW |
275 | { |
276 | char dt_name[GFC_MAX_SYMBOL_LEN+1]; | |
277 | sprintf (dt_name, "%s", derived->name); | |
278 | dt_name[0] = TOUPPER (dt_name[0]); | |
b04533af | 279 | if (derived->module) |
b52956be | 280 | sprintf (string, "%s_%s", derived->module, dt_name); |
4fa02692 | 281 | else if (derived->ns->proc_name) |
b52956be | 282 | sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); |
4fa02692 | 283 | else |
b52956be | 284 | sprintf (string, "_%s", dt_name); |
4fa02692 JW |
285 | } |
286 | ||
287 | ||
288 | /* A relative of 'get_unique_type_string' which makes sure the generated | |
289 | string will not be too long (replacing it by a hash string if needed). */ | |
290 | ||
291 | static void | |
292 | get_unique_hashed_string (char *string, gfc_symbol *derived) | |
293 | { | |
294 | char tmp[2*GFC_MAX_SYMBOL_LEN+2]; | |
295 | get_unique_type_string (&tmp[0], derived); | |
cb83a137 | 296 | /* If string is too long, use hash value in hex representation (allow for |
2419ff64 TB |
297 | extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). |
298 | We need space to for 15 characters "__class_" + symbol name + "_%d_%da", | |
299 | where %d is the (co)rank which can be up to n = 15. */ | |
300 | if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) | |
4fa02692 JW |
301 | { |
302 | int h = gfc_hash_value (derived); | |
303 | sprintf (string, "%X", h); | |
304 | } | |
305 | else | |
306 | strcpy (string, tmp); | |
307 | } | |
308 | ||
309 | ||
310 | /* Assign a hash value for a derived type. The algorithm is that of SDBM. */ | |
311 | ||
312 | unsigned int | |
313 | gfc_hash_value (gfc_symbol *sym) | |
314 | { | |
315 | unsigned int hash = 0; | |
316 | char c[2*(GFC_MAX_SYMBOL_LEN+1)]; | |
317 | int i, len; | |
318 | ||
319 | get_unique_type_string (&c[0], sym); | |
320 | len = strlen (c); | |
321 | ||
322 | for (i = 0; i < len; i++) | |
323 | hash = (hash << 6) + (hash << 16) - hash + c[i]; | |
324 | ||
325 | /* Return the hash but take the modulus for the sake of module read, | |
326 | even though this slightly increases the chance of collision. */ | |
327 | return (hash % 100000000); | |
b04533af JW |
328 | } |
329 | ||
330 | ||
d15bac21 JW |
331 | /* Build a polymorphic CLASS entity, using the symbol that comes from |
332 | build_sym. A CLASS entity is represented by an encapsulating type, | |
b04533af JW |
333 | which contains the declared type as '_data' component, plus a pointer |
334 | component '_vptr' which determines the dynamic type. */ | |
d15bac21 JW |
335 | |
336 | gfc_try | |
337 | gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, | |
338 | gfc_array_spec **as, bool delayed_vtab) | |
339 | { | |
4fa02692 | 340 | char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; |
d15bac21 JW |
341 | gfc_symbol *fclass; |
342 | gfc_symbol *vtab; | |
343 | gfc_component *c; | |
c49ea23d PT |
344 | |
345 | if (as && *as && (*as)->type == AS_ASSUMED_SIZE) | |
346 | { | |
347 | gfc_error ("Assumed size polymorphic objects or components, such " | |
348 | "as that at %C, have not yet been implemented"); | |
349 | return FAILURE; | |
350 | } | |
351 | ||
528622fd JW |
352 | if (attr->class_ok) |
353 | /* Class container has already been built. */ | |
354 | return SUCCESS; | |
355 | ||
7d40e49f TB |
356 | attr->class_ok = attr->dummy || attr->pointer || attr->allocatable |
357 | || attr->select_type_temporary; | |
528622fd JW |
358 | |
359 | if (!attr->class_ok) | |
360 | /* We can not build the class container yet. */ | |
361 | return SUCCESS; | |
d15bac21 JW |
362 | |
363 | /* Determine the name of the encapsulating type. */ | |
4fa02692 | 364 | get_unique_hashed_string (tname, ts->u.derived); |
2419ff64 TB |
365 | if ((*as) && attr->allocatable) |
366 | sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); | |
367 | else if ((*as)) | |
368 | sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); | |
d15bac21 | 369 | else if (attr->pointer) |
b04533af | 370 | sprintf (name, "__class_%s_p", tname); |
d15bac21 | 371 | else if (attr->allocatable) |
b04533af | 372 | sprintf (name, "__class_%s_a", tname); |
d15bac21 | 373 | else |
b04533af | 374 | sprintf (name, "__class_%s", tname); |
d15bac21 JW |
375 | |
376 | gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); | |
377 | if (fclass == NULL) | |
378 | { | |
379 | gfc_symtree *st; | |
380 | /* If not there, create a new symbol. */ | |
381 | fclass = gfc_new_symbol (name, ts->u.derived->ns); | |
382 | st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name); | |
383 | st->n.sym = fclass; | |
384 | gfc_set_sym_referenced (fclass); | |
385 | fclass->refs++; | |
386 | fclass->ts.type = BT_UNKNOWN; | |
387 | fclass->attr.abstract = ts->u.derived->attr.abstract; | |
388 | if (ts->u.derived->f2k_derived) | |
389 | fclass->f2k_derived = gfc_get_namespace (NULL, 0); | |
390 | if (gfc_add_flavor (&fclass->attr, FL_DERIVED, | |
391 | NULL, &gfc_current_locus) == FAILURE) | |
392 | return FAILURE; | |
393 | ||
b04533af JW |
394 | /* Add component '_data'. */ |
395 | if (gfc_add_component (fclass, "_data", &c) == FAILURE) | |
d15bac21 JW |
396 | return FAILURE; |
397 | c->ts = *ts; | |
398 | c->ts.type = BT_DERIVED; | |
399 | c->attr.access = ACCESS_PRIVATE; | |
400 | c->ts.u.derived = ts->u.derived; | |
401 | c->attr.class_pointer = attr->pointer; | |
7d40e49f TB |
402 | c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) |
403 | || attr->select_type_temporary; | |
d15bac21 JW |
404 | c->attr.allocatable = attr->allocatable; |
405 | c->attr.dimension = attr->dimension; | |
406 | c->attr.codimension = attr->codimension; | |
407 | c->attr.abstract = ts->u.derived->attr.abstract; | |
408 | c->as = (*as); | |
409 | c->initializer = NULL; | |
410 | ||
b04533af JW |
411 | /* Add component '_vptr'. */ |
412 | if (gfc_add_component (fclass, "_vptr", &c) == FAILURE) | |
d15bac21 JW |
413 | return FAILURE; |
414 | c->ts.type = BT_DERIVED; | |
415 | if (delayed_vtab) | |
416 | c->ts.u.derived = NULL; | |
417 | else | |
418 | { | |
88ce8031 | 419 | vtab = gfc_find_derived_vtab (ts->u.derived); |
d15bac21 JW |
420 | gcc_assert (vtab); |
421 | c->ts.u.derived = vtab->ts.u.derived; | |
422 | } | |
f3f98a1e | 423 | c->attr.access = ACCESS_PRIVATE; |
d15bac21 JW |
424 | c->attr.pointer = 1; |
425 | } | |
f5a5c890 | 426 | else if (!fclass->f2k_derived) |
5cfa7039 | 427 | fclass->f2k_derived = gfc_get_namespace (NULL, 0); |
d15bac21 JW |
428 | |
429 | /* Since the extension field is 8 bit wide, we can only have | |
430 | up to 255 extension levels. */ | |
431 | if (ts->u.derived->attr.extension == 255) | |
432 | { | |
433 | gfc_error ("Maximum extension level reached with type '%s' at %L", | |
434 | ts->u.derived->name, &ts->u.derived->declared_at); | |
435 | return FAILURE; | |
436 | } | |
437 | ||
438 | fclass->attr.extension = ts->u.derived->attr.extension + 1; | |
d6430d9a | 439 | fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; |
d15bac21 JW |
440 | fclass->attr.is_class = 1; |
441 | ts->u.derived = fclass; | |
c49ea23d PT |
442 | attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; |
443 | (*as) = NULL; | |
d15bac21 JW |
444 | return SUCCESS; |
445 | } | |
446 | ||
447 | ||
88ce8031 JW |
448 | /* Add a procedure pointer component to the vtype |
449 | to represent a specific type-bound procedure. */ | |
450 | ||
d15bac21 | 451 | static void |
88ce8031 | 452 | add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) |
d15bac21 | 453 | { |
88ce8031 | 454 | gfc_component *c; |
fd83db3d JW |
455 | |
456 | if (tb->non_overridable) | |
457 | return; | |
458 | ||
88ce8031 JW |
459 | c = gfc_find_component (vtype, name, true, true); |
460 | ||
461 | if (c == NULL) | |
d15bac21 | 462 | { |
88ce8031 JW |
463 | /* Add procedure component. */ |
464 | if (gfc_add_component (vtype, name, &c) == FAILURE) | |
d15bac21 | 465 | return; |
d15bac21 | 466 | |
88ce8031 JW |
467 | if (!c->tb) |
468 | c->tb = XCNEW (gfc_typebound_proc); | |
469 | *c->tb = *tb; | |
470 | c->tb->ppc = 1; | |
471 | c->attr.procedure = 1; | |
472 | c->attr.proc_pointer = 1; | |
473 | c->attr.flavor = FL_PROCEDURE; | |
474 | c->attr.access = ACCESS_PRIVATE; | |
475 | c->attr.external = 1; | |
476 | c->attr.untyped = 1; | |
477 | c->attr.if_source = IFSRC_IFBODY; | |
d15bac21 JW |
478 | } |
479 | else if (c->attr.proc_pointer && c->tb) | |
480 | { | |
88ce8031 | 481 | *c->tb = *tb; |
d15bac21 | 482 | c->tb->ppc = 1; |
1d0134b3 JW |
483 | } |
484 | ||
485 | if (tb->u.specific) | |
486 | { | |
487 | c->ts.interface = tb->u.specific->n.sym; | |
488 | if (!tb->deferred) | |
489 | c->initializer = gfc_get_variable_expr (tb->u.specific); | |
d15bac21 JW |
490 | } |
491 | } | |
492 | ||
88ce8031 JW |
493 | |
494 | /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ | |
495 | ||
d15bac21 | 496 | static void |
88ce8031 | 497 | add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) |
d15bac21 | 498 | { |
d15bac21 JW |
499 | if (!st) |
500 | return; | |
501 | ||
502 | if (st->left) | |
88ce8031 | 503 | add_procs_to_declared_vtab1 (st->left, vtype); |
d15bac21 JW |
504 | |
505 | if (st->right) | |
88ce8031 | 506 | add_procs_to_declared_vtab1 (st->right, vtype); |
d15bac21 | 507 | |
aea18e92 JW |
508 | if (st->n.tb && !st->n.tb->error |
509 | && !st->n.tb->is_generic && st->n.tb->u.specific) | |
88ce8031 | 510 | add_proc_comp (vtype, st->name, st->n.tb); |
d15bac21 JW |
511 | } |
512 | ||
513 | ||
88ce8031 JW |
514 | /* Copy procedure pointers components from the parent type. */ |
515 | ||
d15bac21 | 516 | static void |
88ce8031 | 517 | copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) |
d15bac21 | 518 | { |
88ce8031 | 519 | gfc_component *cmp; |
d15bac21 JW |
520 | gfc_symbol *vtab; |
521 | ||
88ce8031 | 522 | vtab = gfc_find_derived_vtab (declared); |
d15bac21 JW |
523 | |
524 | for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) | |
525 | { | |
526 | if (gfc_find_component (vtype, cmp->name, true, true)) | |
527 | continue; | |
528 | ||
88ce8031 | 529 | add_proc_comp (vtype, cmp->name, cmp->tb); |
d15bac21 JW |
530 | } |
531 | } | |
532 | ||
d15bac21 | 533 | |
88ce8031 | 534 | /* Add procedure pointers for all type-bound procedures to a vtab. */ |
d15bac21 JW |
535 | |
536 | static void | |
88ce8031 | 537 | add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) |
d15bac21 | 538 | { |
d15bac21 JW |
539 | gfc_symbol* super_type; |
540 | ||
88ce8031 | 541 | super_type = gfc_get_derived_super_type (derived); |
d15bac21 | 542 | |
88ce8031 | 543 | if (super_type && (super_type != derived)) |
d15bac21 | 544 | { |
88ce8031 JW |
545 | /* Make sure that the PPCs appear in the same order as in the parent. */ |
546 | copy_vtab_proc_comps (super_type, vtype); | |
1d0134b3 | 547 | /* Only needed to get the PPC initializers right. */ |
88ce8031 JW |
548 | add_procs_to_declared_vtab (super_type, vtype); |
549 | } | |
d15bac21 | 550 | |
88ce8031 JW |
551 | if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) |
552 | add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); | |
d15bac21 | 553 | |
88ce8031 JW |
554 | if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) |
555 | add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); | |
d15bac21 JW |
556 | } |
557 | ||
558 | ||
611c64f0 | 559 | /* Find (or generate) the symbol for a derived type's vtab. */ |
d15bac21 JW |
560 | |
561 | gfc_symbol * | |
88ce8031 | 562 | gfc_find_derived_vtab (gfc_symbol *derived) |
d15bac21 JW |
563 | { |
564 | gfc_namespace *ns; | |
50f30801 | 565 | gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; |
611c64f0 | 566 | gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; |
c49ea23d | 567 | |
e10f52d0 JW |
568 | /* Find the top-level namespace (MODULE or PROGRAM). */ |
569 | for (ns = gfc_current_ns; ns; ns = ns->parent) | |
d15bac21 JW |
570 | if (!ns->parent) |
571 | break; | |
572 | ||
e10f52d0 JW |
573 | /* If the type is a class container, use the underlying derived type. */ |
574 | if (derived->attr.is_class) | |
575 | derived = gfc_get_derived_super_type (derived); | |
576 | ||
d15bac21 JW |
577 | if (ns) |
578 | { | |
4fa02692 | 579 | char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; |
b04533af | 580 | |
4fa02692 | 581 | get_unique_hashed_string (tname, derived); |
b04533af | 582 | sprintf (name, "__vtab_%s", tname); |
611c64f0 JW |
583 | |
584 | /* Look for the vtab symbol in various namespaces. */ | |
585 | gfc_find_symbol (name, gfc_current_ns, 0, &vtab); | |
586 | if (vtab == NULL) | |
587 | gfc_find_symbol (name, ns, 0, &vtab); | |
588 | if (vtab == NULL) | |
589 | gfc_find_symbol (name, derived->ns, 0, &vtab); | |
d15bac21 JW |
590 | |
591 | if (vtab == NULL) | |
592 | { | |
593 | gfc_get_symbol (name, ns, &vtab); | |
594 | vtab->ts.type = BT_DERIVED; | |
22c30bc0 | 595 | if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, |
e10f52d0 JW |
596 | &gfc_current_locus) == FAILURE) |
597 | goto cleanup; | |
d15bac21 | 598 | vtab->attr.target = 1; |
95f5c775 | 599 | vtab->attr.save = SAVE_IMPLICIT; |
d15bac21 | 600 | vtab->attr.vtab = 1; |
f3f98a1e | 601 | vtab->attr.access = ACCESS_PUBLIC; |
d15bac21 | 602 | gfc_set_sym_referenced (vtab); |
b04533af | 603 | sprintf (name, "__vtype_%s", tname); |
d15bac21 JW |
604 | |
605 | gfc_find_symbol (name, ns, 0, &vtype); | |
606 | if (vtype == NULL) | |
607 | { | |
608 | gfc_component *c; | |
609 | gfc_symbol *parent = NULL, *parent_vtab = NULL; | |
610 | ||
611 | gfc_get_symbol (name, ns, &vtype); | |
612 | if (gfc_add_flavor (&vtype->attr, FL_DERIVED, | |
613 | NULL, &gfc_current_locus) == FAILURE) | |
81fb8a48 | 614 | goto cleanup; |
f3f98a1e | 615 | vtype->attr.access = ACCESS_PUBLIC; |
611c64f0 | 616 | vtype->attr.vtype = 1; |
d15bac21 JW |
617 | gfc_set_sym_referenced (vtype); |
618 | ||
b04533af JW |
619 | /* Add component '_hash'. */ |
620 | if (gfc_add_component (vtype, "_hash", &c) == FAILURE) | |
81fb8a48 | 621 | goto cleanup; |
d15bac21 JW |
622 | c->ts.type = BT_INTEGER; |
623 | c->ts.kind = 4; | |
624 | c->attr.access = ACCESS_PRIVATE; | |
625 | c->initializer = gfc_get_int_expr (gfc_default_integer_kind, | |
626 | NULL, derived->hash_value); | |
627 | ||
b04533af JW |
628 | /* Add component '_size'. */ |
629 | if (gfc_add_component (vtype, "_size", &c) == FAILURE) | |
81fb8a48 | 630 | goto cleanup; |
d15bac21 JW |
631 | c->ts.type = BT_INTEGER; |
632 | c->ts.kind = 4; | |
633 | c->attr.access = ACCESS_PRIVATE; | |
634 | /* Remember the derived type in ts.u.derived, | |
635 | so that the correct initializer can be set later on | |
636 | (in gfc_conv_structure). */ | |
637 | c->ts.u.derived = derived; | |
638 | c->initializer = gfc_get_int_expr (gfc_default_integer_kind, | |
639 | NULL, 0); | |
640 | ||
b04533af JW |
641 | /* Add component _extends. */ |
642 | if (gfc_add_component (vtype, "_extends", &c) == FAILURE) | |
81fb8a48 | 643 | goto cleanup; |
d15bac21 JW |
644 | c->attr.pointer = 1; |
645 | c->attr.access = ACCESS_PRIVATE; | |
646 | parent = gfc_get_derived_super_type (derived); | |
647 | if (parent) | |
648 | { | |
88ce8031 | 649 | parent_vtab = gfc_find_derived_vtab (parent); |
d15bac21 JW |
650 | c->ts.type = BT_DERIVED; |
651 | c->ts.u.derived = parent_vtab->ts.u.derived; | |
652 | c->initializer = gfc_get_expr (); | |
653 | c->initializer->expr_type = EXPR_VARIABLE; | |
654 | gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, | |
655 | 0, &c->initializer->symtree); | |
656 | } | |
657 | else | |
658 | { | |
659 | c->ts.type = BT_DERIVED; | |
660 | c->ts.u.derived = vtype; | |
661 | c->initializer = gfc_get_null_expr (NULL); | |
662 | } | |
663 | ||
611c64f0 JW |
664 | if (derived->components == NULL && !derived->attr.zero_comp) |
665 | { | |
666 | /* At this point an error must have occurred. | |
667 | Prevent further errors on the vtype components. */ | |
668 | found_sym = vtab; | |
669 | goto have_vtype; | |
670 | } | |
671 | ||
b04533af JW |
672 | /* Add component _def_init. */ |
673 | if (gfc_add_component (vtype, "_def_init", &c) == FAILURE) | |
50f30801 JW |
674 | goto cleanup; |
675 | c->attr.pointer = 1; | |
676 | c->attr.access = ACCESS_PRIVATE; | |
677 | c->ts.type = BT_DERIVED; | |
678 | c->ts.u.derived = derived; | |
679 | if (derived->attr.abstract) | |
611c64f0 | 680 | c->initializer = gfc_get_null_expr (NULL); |
50f30801 JW |
681 | else |
682 | { | |
683 | /* Construct default initialization variable. */ | |
b04533af | 684 | sprintf (name, "__def_init_%s", tname); |
50f30801 JW |
685 | gfc_get_symbol (name, ns, &def_init); |
686 | def_init->attr.target = 1; | |
95f5c775 | 687 | def_init->attr.save = SAVE_IMPLICIT; |
50f30801 | 688 | def_init->attr.access = ACCESS_PUBLIC; |
22c30bc0 | 689 | def_init->attr.flavor = FL_VARIABLE; |
50f30801 JW |
690 | gfc_set_sym_referenced (def_init); |
691 | def_init->ts.type = BT_DERIVED; | |
692 | def_init->ts.u.derived = derived; | |
693 | def_init->value = gfc_default_initializer (&def_init->ts); | |
694 | ||
695 | c->initializer = gfc_lval_expr_from_sym (def_init); | |
696 | } | |
697 | ||
b04533af JW |
698 | /* Add component _copy. */ |
699 | if (gfc_add_component (vtype, "_copy", &c) == FAILURE) | |
611c64f0 JW |
700 | goto cleanup; |
701 | c->attr.proc_pointer = 1; | |
702 | c->attr.access = ACCESS_PRIVATE; | |
703 | c->tb = XCNEW (gfc_typebound_proc); | |
704 | c->tb->ppc = 1; | |
705 | if (derived->attr.abstract) | |
706 | c->initializer = gfc_get_null_expr (NULL); | |
707 | else | |
708 | { | |
709 | /* Set up namespace. */ | |
710 | gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); | |
711 | sub_ns->sibling = ns->contained; | |
712 | ns->contained = sub_ns; | |
713 | sub_ns->resolved = 1; | |
714 | /* Set up procedure symbol. */ | |
b04533af | 715 | sprintf (name, "__copy_%s", tname); |
611c64f0 JW |
716 | gfc_get_symbol (name, sub_ns, ©); |
717 | sub_ns->proc_name = copy; | |
718 | copy->attr.flavor = FL_PROCEDURE; | |
cf651ca2 | 719 | copy->attr.subroutine = 1; |
611c64f0 | 720 | copy->attr.if_source = IFSRC_DECL; |
c49ea23d PT |
721 | /* This is elemental so that arrays are automatically |
722 | treated correctly by the scalarizer. */ | |
723 | copy->attr.elemental = 1; | |
844ba455 JW |
724 | if (ns->proc_name->attr.flavor == FL_MODULE) |
725 | copy->module = ns->proc_name->name; | |
611c64f0 JW |
726 | gfc_set_sym_referenced (copy); |
727 | /* Set up formal arguments. */ | |
728 | gfc_get_symbol ("src", sub_ns, &src); | |
729 | src->ts.type = BT_DERIVED; | |
730 | src->ts.u.derived = derived; | |
731 | src->attr.flavor = FL_VARIABLE; | |
732 | src->attr.dummy = 1; | |
c49ea23d | 733 | src->attr.intent = INTENT_IN; |
611c64f0 JW |
734 | gfc_set_sym_referenced (src); |
735 | copy->formal = gfc_get_formal_arglist (); | |
736 | copy->formal->sym = src; | |
737 | gfc_get_symbol ("dst", sub_ns, &dst); | |
738 | dst->ts.type = BT_DERIVED; | |
739 | dst->ts.u.derived = derived; | |
740 | dst->attr.flavor = FL_VARIABLE; | |
741 | dst->attr.dummy = 1; | |
c49ea23d | 742 | dst->attr.intent = INTENT_OUT; |
611c64f0 JW |
743 | gfc_set_sym_referenced (dst); |
744 | copy->formal->next = gfc_get_formal_arglist (); | |
745 | copy->formal->next->sym = dst; | |
746 | /* Set up code. */ | |
747 | sub_ns->code = gfc_get_code (); | |
2e85ae0d | 748 | sub_ns->code->op = EXEC_INIT_ASSIGN; |
611c64f0 JW |
749 | sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); |
750 | sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); | |
751 | /* Set initializer. */ | |
752 | c->initializer = gfc_lval_expr_from_sym (copy); | |
753 | c->ts.interface = copy; | |
754 | } | |
755 | ||
50f30801 | 756 | /* Add procedure pointers for type-bound procedures. */ |
88ce8031 | 757 | add_procs_to_declared_vtab (derived, vtype); |
d15bac21 JW |
758 | } |
759 | ||
611c64f0 | 760 | have_vtype: |
d15bac21 JW |
761 | vtab->ts.u.derived = vtype; |
762 | vtab->value = gfc_default_initializer (&vtab->ts); | |
763 | } | |
764 | } | |
765 | ||
81fb8a48 MM |
766 | found_sym = vtab; |
767 | ||
768 | cleanup: | |
769 | /* It is unexpected to have some symbols added at resolution or code | |
770 | generation time. We commit the changes in order to keep a clean state. */ | |
771 | if (found_sym) | |
e10f52d0 JW |
772 | { |
773 | gfc_commit_symbol (vtab); | |
774 | if (vtype) | |
775 | gfc_commit_symbol (vtype); | |
50f30801 JW |
776 | if (def_init) |
777 | gfc_commit_symbol (def_init); | |
611c64f0 JW |
778 | if (copy) |
779 | gfc_commit_symbol (copy); | |
780 | if (src) | |
781 | gfc_commit_symbol (src); | |
782 | if (dst) | |
783 | gfc_commit_symbol (dst); | |
e10f52d0 | 784 | } |
81fb8a48 MM |
785 | else |
786 | gfc_undo_symbols (); | |
787 | ||
788 | return found_sym; | |
d15bac21 JW |
789 | } |
790 | ||
791 | ||
792 | /* General worker function to find either a type-bound procedure or a | |
793 | type-bound user operator. */ | |
794 | ||
795 | static gfc_symtree* | |
796 | find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, | |
797 | const char* name, bool noaccess, bool uop, | |
798 | locus* where) | |
799 | { | |
800 | gfc_symtree* res; | |
801 | gfc_symtree* root; | |
802 | ||
803 | /* Set correct symbol-root. */ | |
804 | gcc_assert (derived->f2k_derived); | |
805 | root = (uop ? derived->f2k_derived->tb_uop_root | |
806 | : derived->f2k_derived->tb_sym_root); | |
807 | ||
808 | /* Set default to failure. */ | |
809 | if (t) | |
810 | *t = FAILURE; | |
811 | ||
812 | /* Try to find it in the current type's namespace. */ | |
813 | res = gfc_find_symtree (root, name); | |
814 | if (res && res->n.tb && !res->n.tb->error) | |
815 | { | |
816 | /* We found one. */ | |
817 | if (t) | |
818 | *t = SUCCESS; | |
819 | ||
820 | if (!noaccess && derived->attr.use_assoc | |
821 | && res->n.tb->access == ACCESS_PRIVATE) | |
822 | { | |
823 | if (where) | |
824 | gfc_error ("'%s' of '%s' is PRIVATE at %L", | |
825 | name, derived->name, where); | |
826 | if (t) | |
827 | *t = FAILURE; | |
828 | } | |
829 | ||
830 | return res; | |
831 | } | |
832 | ||
833 | /* Otherwise, recurse on parent type if derived is an extension. */ | |
834 | if (derived->attr.extension) | |
835 | { | |
836 | gfc_symbol* super_type; | |
837 | super_type = gfc_get_derived_super_type (derived); | |
838 | gcc_assert (super_type); | |
839 | ||
840 | return find_typebound_proc_uop (super_type, t, name, | |
841 | noaccess, uop, where); | |
842 | } | |
843 | ||
844 | /* Nothing found. */ | |
845 | return NULL; | |
846 | } | |
847 | ||
848 | ||
849 | /* Find a type-bound procedure or user operator by name for a derived-type | |
850 | (looking recursively through the super-types). */ | |
851 | ||
852 | gfc_symtree* | |
853 | gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, | |
854 | const char* name, bool noaccess, locus* where) | |
855 | { | |
856 | return find_typebound_proc_uop (derived, t, name, noaccess, false, where); | |
857 | } | |
858 | ||
859 | gfc_symtree* | |
860 | gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, | |
861 | const char* name, bool noaccess, locus* where) | |
862 | { | |
863 | return find_typebound_proc_uop (derived, t, name, noaccess, true, where); | |
864 | } | |
865 | ||
866 | ||
867 | /* Find a type-bound intrinsic operator looking recursively through the | |
868 | super-type hierarchy. */ | |
869 | ||
870 | gfc_typebound_proc* | |
871 | gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, | |
872 | gfc_intrinsic_op op, bool noaccess, | |
873 | locus* where) | |
874 | { | |
875 | gfc_typebound_proc* res; | |
876 | ||
877 | /* Set default to failure. */ | |
878 | if (t) | |
879 | *t = FAILURE; | |
880 | ||
881 | /* Try to find it in the current type's namespace. */ | |
882 | if (derived->f2k_derived) | |
883 | res = derived->f2k_derived->tb_op[op]; | |
884 | else | |
885 | res = NULL; | |
886 | ||
887 | /* Check access. */ | |
888 | if (res && !res->error) | |
889 | { | |
890 | /* We found one. */ | |
891 | if (t) | |
892 | *t = SUCCESS; | |
893 | ||
894 | if (!noaccess && derived->attr.use_assoc | |
895 | && res->access == ACCESS_PRIVATE) | |
896 | { | |
897 | if (where) | |
898 | gfc_error ("'%s' of '%s' is PRIVATE at %L", | |
899 | gfc_op2string (op), derived->name, where); | |
900 | if (t) | |
901 | *t = FAILURE; | |
902 | } | |
903 | ||
904 | return res; | |
905 | } | |
906 | ||
907 | /* Otherwise, recurse on parent type if derived is an extension. */ | |
908 | if (derived->attr.extension) | |
909 | { | |
910 | gfc_symbol* super_type; | |
911 | super_type = gfc_get_derived_super_type (derived); | |
912 | gcc_assert (super_type); | |
913 | ||
914 | return gfc_find_typebound_intrinsic_op (super_type, t, op, | |
915 | noaccess, where); | |
916 | } | |
917 | ||
918 | /* Nothing found. */ | |
919 | return NULL; | |
920 | } | |
921 | ||
922 | ||
923 | /* Get a typebound-procedure symtree or create and insert it if not yet | |
924 | present. This is like a very simplified version of gfc_get_sym_tree for | |
925 | tbp-symtrees rather than regular ones. */ | |
926 | ||
927 | gfc_symtree* | |
928 | gfc_get_tbp_symtree (gfc_symtree **root, const char *name) | |
929 | { | |
930 | gfc_symtree *result; | |
931 | ||
932 | result = gfc_find_symtree (*root, name); | |
933 | if (!result) | |
934 | { | |
935 | result = gfc_new_symtree (root, name); | |
936 | gcc_assert (result); | |
937 | result->n.tb = NULL; | |
938 | } | |
939 | ||
940 | return result; | |
941 | } |