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