1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Richard Thomas & Janus Weil
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
23 /* class.c -- This file contains the front end functions needed to service
24 the implementation of Fortran 2003 polymorphism and other
25 object-oriented features. */
28 /* Outline of the internal representation:
30 Each CLASS variable is encapsulated by a class container, which is a
31 structure with two fields:
32 * $data: A pointer to the actual data of the variable. This field has the
33 declared type of the class variable and its attributes
34 (pointer/allocatable/dimension/...).
35 * $vptr: A pointer to the vtable entry (see below) of the dynamic type.
37 For each derived type we set up a "vtable" entry, i.e. a structure with the
39 * $hash: A hash value serving as a unique identifier for this type.
40 * $size: The size in bytes of the derived type.
41 * $extends: A pointer to the vtable entry of the parent derived type.
42 In addition to these fields, each vtable entry contains additional procedure
43 pointer components, which contain pointers to the procedures which are bound
44 to the type's "methods" (type-bound procedures). */
50 #include "constructor.h"
53 /* Insert a reference to the component of the given name.
54 Only to be used with CLASS containers. */
57 gfc_add_component_ref (gfc_expr *e, const char *name)
59 gfc_ref **tail = &(e->ref);
61 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
64 if ((*tail)->type == REF_COMPONENT)
65 derived = (*tail)->u.c.component->ts.u.derived;
66 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
68 tail = &((*tail)->next);
70 if (*tail != NULL && strcmp (name, "$data") == 0)
72 (*tail) = gfc_get_ref();
74 (*tail)->type = REF_COMPONENT;
75 (*tail)->u.c.sym = derived;
76 (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
77 gcc_assert((*tail)->u.c.component);
79 e->ts = (*tail)->u.c.component->ts;
83 /* Build a NULL initializer for CLASS pointers,
84 initializing the $data and $vptr components to zero. */
87 gfc_class_null_initializer (gfc_typespec *ts)
92 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
93 &ts->u.derived->declared_at);
96 for (comp = ts->u.derived->components; comp; comp = comp->next)
98 gfc_constructor *ctor = gfc_constructor_get();
99 ctor->expr = gfc_get_expr ();
100 ctor->expr->expr_type = EXPR_NULL;
101 ctor->expr->ts = comp->ts;
102 gfc_constructor_append (&init->value.constructor, ctor);
109 /* Build a polymorphic CLASS entity, using the symbol that comes from
110 build_sym. A CLASS entity is represented by an encapsulating type,
111 which contains the declared type as '$data' component, plus a pointer
112 component '$vptr' which determines the dynamic type. */
115 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
116 gfc_array_spec **as, bool delayed_vtab)
118 char name[GFC_MAX_SYMBOL_LEN + 5];
123 /* Determine the name of the encapsulating type. */
124 if ((*as) && (*as)->rank && attr->allocatable)
125 sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
126 else if ((*as) && (*as)->rank)
127 sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
128 else if (attr->pointer)
129 sprintf (name, "class$%s_p", ts->u.derived->name);
130 else if (attr->allocatable)
131 sprintf (name, "class$%s_a", ts->u.derived->name);
133 sprintf (name, "class$%s", ts->u.derived->name);
135 gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
139 /* If not there, create a new symbol. */
140 fclass = gfc_new_symbol (name, ts->u.derived->ns);
141 st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
143 gfc_set_sym_referenced (fclass);
145 fclass->ts.type = BT_UNKNOWN;
146 fclass->attr.abstract = ts->u.derived->attr.abstract;
147 if (ts->u.derived->f2k_derived)
148 fclass->f2k_derived = gfc_get_namespace (NULL, 0);
149 if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
150 NULL, &gfc_current_locus) == FAILURE)
153 /* Add component '$data'. */
154 if (gfc_add_component (fclass, "$data", &c) == FAILURE)
157 c->ts.type = BT_DERIVED;
158 c->attr.access = ACCESS_PRIVATE;
159 c->ts.u.derived = ts->u.derived;
160 c->attr.class_pointer = attr->pointer;
161 c->attr.pointer = attr->pointer || attr->dummy;
162 c->attr.allocatable = attr->allocatable;
163 c->attr.dimension = attr->dimension;
164 c->attr.codimension = attr->codimension;
165 c->attr.abstract = ts->u.derived->attr.abstract;
167 c->initializer = NULL;
169 /* Add component '$vptr'. */
170 if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
172 c->ts.type = BT_DERIVED;
174 c->ts.u.derived = NULL;
177 vtab = gfc_find_derived_vtab (ts->u.derived);
179 c->ts.u.derived = vtab->ts.u.derived;
184 /* Since the extension field is 8 bit wide, we can only have
185 up to 255 extension levels. */
186 if (ts->u.derived->attr.extension == 255)
188 gfc_error ("Maximum extension level reached with type '%s' at %L",
189 ts->u.derived->name, &ts->u.derived->declared_at);
193 fclass->attr.extension = ts->u.derived->attr.extension + 1;
194 fclass->attr.is_class = 1;
195 ts->u.derived = fclass;
196 attr->allocatable = attr->pointer = attr->dimension = 0;
197 (*as) = NULL; /* XXX */
202 /* Add a procedure pointer component to the vtype
203 to represent a specific type-bound procedure. */
206 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
209 c = gfc_find_component (vtype, name, true, true);
213 /* Add procedure component. */
214 if (gfc_add_component (vtype, name, &c) == FAILURE)
217 c->ts.interface = tb->u.specific->n.sym;
220 c->tb = XCNEW (gfc_typebound_proc);
223 c->attr.procedure = 1;
224 c->attr.proc_pointer = 1;
225 c->attr.flavor = FL_PROCEDURE;
226 c->attr.access = ACCESS_PRIVATE;
227 c->attr.external = 1;
229 c->attr.if_source = IFSRC_IFBODY;
231 /* A static initializer cannot be used here because the specific
232 function is not a constant; internal compiler error: in
233 output_constant, at varasm.c:4623 */
234 c->initializer = NULL;
236 else if (c->attr.proc_pointer && c->tb)
240 c->ts.interface = tb->u.specific->n.sym;
245 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
248 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
254 add_procs_to_declared_vtab1 (st->left, vtype);
257 add_procs_to_declared_vtab1 (st->right, vtype);
262 if (!st->n.tb->is_generic && st->n.tb->u.specific)
263 add_proc_comp (vtype, st->name, st->n.tb);
267 /* Copy procedure pointers components from the parent type. */
270 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
275 vtab = gfc_find_derived_vtab (declared);
277 for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
279 if (gfc_find_component (vtype, cmp->name, true, true))
282 add_proc_comp (vtype, cmp->name, cmp->tb);
287 /* Add procedure pointers for all type-bound procedures to a vtab. */
290 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
292 gfc_symbol* super_type;
294 super_type = gfc_get_derived_super_type (derived);
296 if (super_type && (super_type != derived))
298 /* Make sure that the PPCs appear in the same order as in the parent. */
299 copy_vtab_proc_comps (super_type, vtype);
300 /* Only needed to get the PPC interfaces right. */
301 add_procs_to_declared_vtab (super_type, vtype);
304 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
305 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
307 if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
308 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
312 /* Find the symbol for a derived type's vtab.
313 A vtab has the following fields:
314 * $hash a hash value used to identify the derived type
315 * $size the size in bytes of the derived type
316 * $extends a pointer to the vtable of the parent derived type
317 After these follow procedure pointer components for the
318 specific type-bound procedures. */
321 gfc_find_derived_vtab (gfc_symbol *derived)
324 gfc_symbol *vtab = NULL, *vtype = NULL;
325 char name[2 * GFC_MAX_SYMBOL_LEN + 8];
329 for (; ns; ns = ns->parent)
335 sprintf (name, "vtab$%s", derived->name);
336 gfc_find_symbol (name, ns, 0, &vtab);
340 gfc_get_symbol (name, ns, &vtab);
341 vtab->ts.type = BT_DERIVED;
342 vtab->attr.flavor = FL_VARIABLE;
343 vtab->attr.target = 1;
344 vtab->attr.save = SAVE_EXPLICIT;
347 gfc_set_sym_referenced (vtab);
348 sprintf (name, "vtype$%s", derived->name);
350 gfc_find_symbol (name, ns, 0, &vtype);
354 gfc_symbol *parent = NULL, *parent_vtab = NULL;
356 gfc_get_symbol (name, ns, &vtype);
357 if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
358 NULL, &gfc_current_locus) == FAILURE)
361 gfc_set_sym_referenced (vtype);
363 /* Add component '$hash'. */
364 if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
366 c->ts.type = BT_INTEGER;
368 c->attr.access = ACCESS_PRIVATE;
369 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
370 NULL, derived->hash_value);
372 /* Add component '$size'. */
373 if (gfc_add_component (vtype, "$size", &c) == FAILURE)
375 c->ts.type = BT_INTEGER;
377 c->attr.access = ACCESS_PRIVATE;
378 /* Remember the derived type in ts.u.derived,
379 so that the correct initializer can be set later on
380 (in gfc_conv_structure). */
381 c->ts.u.derived = derived;
382 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
385 /* Add component $extends. */
386 if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
389 c->attr.access = ACCESS_PRIVATE;
390 parent = gfc_get_derived_super_type (derived);
393 parent_vtab = gfc_find_derived_vtab (parent);
394 c->ts.type = BT_DERIVED;
395 c->ts.u.derived = parent_vtab->ts.u.derived;
396 c->initializer = gfc_get_expr ();
397 c->initializer->expr_type = EXPR_VARIABLE;
398 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
399 0, &c->initializer->symtree);
403 c->ts.type = BT_DERIVED;
404 c->ts.u.derived = vtype;
405 c->initializer = gfc_get_null_expr (NULL);
408 add_procs_to_declared_vtab (derived, vtype);
409 vtype->attr.vtype = 1;
412 vtab->ts.u.derived = vtype;
413 vtab->value = gfc_default_initializer (&vtab->ts);
421 /* General worker function to find either a type-bound procedure or a
422 type-bound user operator. */
425 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
426 const char* name, bool noaccess, bool uop,
432 /* Set correct symbol-root. */
433 gcc_assert (derived->f2k_derived);
434 root = (uop ? derived->f2k_derived->tb_uop_root
435 : derived->f2k_derived->tb_sym_root);
437 /* Set default to failure. */
441 /* Try to find it in the current type's namespace. */
442 res = gfc_find_symtree (root, name);
443 if (res && res->n.tb && !res->n.tb->error)
449 if (!noaccess && derived->attr.use_assoc
450 && res->n.tb->access == ACCESS_PRIVATE)
453 gfc_error ("'%s' of '%s' is PRIVATE at %L",
454 name, derived->name, where);
462 /* Otherwise, recurse on parent type if derived is an extension. */
463 if (derived->attr.extension)
465 gfc_symbol* super_type;
466 super_type = gfc_get_derived_super_type (derived);
467 gcc_assert (super_type);
469 return find_typebound_proc_uop (super_type, t, name,
470 noaccess, uop, where);
478 /* Find a type-bound procedure or user operator by name for a derived-type
479 (looking recursively through the super-types). */
482 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
483 const char* name, bool noaccess, locus* where)
485 return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
489 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
490 const char* name, bool noaccess, locus* where)
492 return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
496 /* Find a type-bound intrinsic operator looking recursively through the
497 super-type hierarchy. */
500 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
501 gfc_intrinsic_op op, bool noaccess,
504 gfc_typebound_proc* res;
506 /* Set default to failure. */
510 /* Try to find it in the current type's namespace. */
511 if (derived->f2k_derived)
512 res = derived->f2k_derived->tb_op[op];
517 if (res && !res->error)
523 if (!noaccess && derived->attr.use_assoc
524 && res->access == ACCESS_PRIVATE)
527 gfc_error ("'%s' of '%s' is PRIVATE at %L",
528 gfc_op2string (op), derived->name, where);
536 /* Otherwise, recurse on parent type if derived is an extension. */
537 if (derived->attr.extension)
539 gfc_symbol* super_type;
540 super_type = gfc_get_derived_super_type (derived);
541 gcc_assert (super_type);
543 return gfc_find_typebound_intrinsic_op (super_type, t, op,
552 /* Get a typebound-procedure symtree or create and insert it if not yet
553 present. This is like a very simplified version of gfc_get_sym_tree for
554 tbp-symtrees rather than regular ones. */
557 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
561 result = gfc_find_symtree (*root, name);
564 result = gfc_new_symtree (root, name);