1 /* Implementation of Fortran 2003 Polymorphism.
2 Copyright (C) 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
5 and Janus Weil <janus@gcc.gnu.org>
7 This file is part of GCC.
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
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
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/>. */
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. */
29 /* Outline of the internal representation:
31 Each CLASS variable is encapsulated by a class container, which is a
32 structure with two fields:
33 * _data: A pointer to the actual data of the variable. This field has the
34 declared type of the class variable and its attributes
35 (pointer/allocatable/dimension/...).
36 * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
38 For each derived type we set up a "vtable" entry, i.e. a structure with the
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.
45 After these follow procedure pointer components for the specific
46 type-bound procedures. */
52 #include "constructor.h"
55 /* Insert a reference to the component of the given name.
56 Only to be used with CLASS containers and vtables. */
59 gfc_add_component_ref (gfc_expr *e, const char *name)
61 gfc_ref **tail = &(e->ref);
63 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
66 if ((*tail)->type == REF_COMPONENT)
67 derived = (*tail)->u.c.component->ts.u.derived;
68 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
70 tail = &((*tail)->next);
72 if (*tail != NULL && strcmp (name, "_data") == 0)
74 (*tail) = gfc_get_ref();
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);
81 e->ts = (*tail)->u.c.component->ts;
85 /* Build a NULL initializer for CLASS pointers,
86 initializing the _data component to NULL and
87 the _vptr component to the declared type. */
90 gfc_class_null_initializer (gfc_typespec *ts)
95 init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
96 &ts->u.derived->declared_at);
99 for (comp = ts->u.derived->components; comp; comp = comp->next)
101 gfc_constructor *ctor = gfc_constructor_get();
102 if (strcmp (comp->name, "_vptr") == 0)
103 ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
105 ctor->expr = gfc_get_null_expr (NULL);
106 gfc_constructor_append (&init->value.constructor, ctor);
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. */
118 get_unique_type_string (char *string, gfc_symbol *derived)
120 char dt_name[GFC_MAX_SYMBOL_LEN+1];
121 sprintf (dt_name, "%s", derived->name);
122 dt_name[0] = TOUPPER (dt_name[0]);
124 sprintf (string, "%s_%s", derived->module, dt_name);
125 else if (derived->ns->proc_name)
126 sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
128 sprintf (string, "_%s", dt_name);
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). */
136 get_unique_hashed_string (char *string, gfc_symbol *derived)
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 (allow for
141 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). */
142 if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 11)
144 int h = gfc_hash_value (derived);
145 sprintf (string, "%X", h);
148 strcpy (string, tmp);
152 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
155 gfc_hash_value (gfc_symbol *sym)
157 unsigned int hash = 0;
158 char c[2*(GFC_MAX_SYMBOL_LEN+1)];
161 get_unique_type_string (&c[0], sym);
164 for (i = 0; i < len; i++)
165 hash = (hash << 6) + (hash << 16) - hash + c[i];
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);
173 /* Build a polymorphic CLASS entity, using the symbol that comes from
174 build_sym. A CLASS entity is represented by an encapsulating type,
175 which contains the declared type as '_data' component, plus a pointer
176 component '_vptr' which determines the dynamic type. */
179 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
180 gfc_array_spec **as, bool delayed_vtab)
182 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
188 /* Class container has already been built. */
191 attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;
194 /* We can not build the class container yet. */
199 gfc_fatal_error ("Polymorphic array at %C not yet supported");
203 /* Determine the name of the encapsulating type. */
204 get_unique_hashed_string (tname, ts->u.derived);
205 if ((*as) && (*as)->rank && attr->allocatable)
206 sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
207 else if ((*as) && (*as)->rank)
208 sprintf (name, "__class_%s_%d", tname, (*as)->rank);
209 else if (attr->pointer)
210 sprintf (name, "__class_%s_p", tname);
211 else if (attr->allocatable)
212 sprintf (name, "__class_%s_a", tname);
214 sprintf (name, "__class_%s", tname);
216 gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
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);
224 gfc_set_sym_referenced (fclass);
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)
234 /* Add component '_data'. */
235 if (gfc_add_component (fclass, "_data", &c) == FAILURE)
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;
248 c->initializer = NULL;
250 /* Add component '_vptr'. */
251 if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
253 c->ts.type = BT_DERIVED;
255 c->ts.u.derived = NULL;
258 vtab = gfc_find_derived_vtab (ts->u.derived);
260 c->ts.u.derived = vtab->ts.u.derived;
262 c->attr.access = ACCESS_PRIVATE;
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)
270 gfc_error ("Maximum extension level reached with type '%s' at %L",
271 ts->u.derived->name, &ts->u.derived->declared_at);
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 */
284 /* Add a procedure pointer component to the vtype
285 to represent a specific type-bound procedure. */
288 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
291 c = gfc_find_component (vtype, name, true, true);
295 /* Add procedure component. */
296 if (gfc_add_component (vtype, name, &c) == FAILURE)
300 c->tb = XCNEW (gfc_typebound_proc);
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;
309 c->attr.if_source = IFSRC_IFBODY;
311 else if (c->attr.proc_pointer && c->tb)
319 c->ts.interface = tb->u.specific->n.sym;
321 c->initializer = gfc_get_variable_expr (tb->u.specific);
326 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
329 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
335 add_procs_to_declared_vtab1 (st->left, vtype);
338 add_procs_to_declared_vtab1 (st->right, vtype);
340 if (st->n.tb && !st->n.tb->error
341 && !st->n.tb->is_generic && st->n.tb->u.specific)
342 add_proc_comp (vtype, st->name, st->n.tb);
346 /* Copy procedure pointers components from the parent type. */
349 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
354 vtab = gfc_find_derived_vtab (declared);
356 for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
358 if (gfc_find_component (vtype, cmp->name, true, true))
361 add_proc_comp (vtype, cmp->name, cmp->tb);
366 /* Add procedure pointers for all type-bound procedures to a vtab. */
369 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
371 gfc_symbol* super_type;
373 super_type = gfc_get_derived_super_type (derived);
375 if (super_type && (super_type != derived))
377 /* Make sure that the PPCs appear in the same order as in the parent. */
378 copy_vtab_proc_comps (super_type, vtype);
379 /* Only needed to get the PPC initializers right. */
380 add_procs_to_declared_vtab (super_type, vtype);
383 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
384 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
386 if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
387 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
391 /* Find (or generate) the symbol for a derived type's vtab. */
394 gfc_find_derived_vtab (gfc_symbol *derived)
397 gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
398 gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
400 /* Find the top-level namespace (MODULE or PROGRAM). */
401 for (ns = gfc_current_ns; ns; ns = ns->parent)
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);
411 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
413 get_unique_hashed_string (tname, derived);
414 sprintf (name, "__vtab_%s", tname);
416 /* Look for the vtab symbol in various namespaces. */
417 gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
419 gfc_find_symbol (name, ns, 0, &vtab);
421 gfc_find_symbol (name, derived->ns, 0, &vtab);
425 gfc_get_symbol (name, ns, &vtab);
426 vtab->ts.type = BT_DERIVED;
427 if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
428 &gfc_current_locus) == FAILURE)
430 vtab->attr.target = 1;
431 vtab->attr.save = SAVE_IMPLICIT;
433 vtab->attr.access = ACCESS_PUBLIC;
434 gfc_set_sym_referenced (vtab);
435 sprintf (name, "__vtype_%s", tname);
437 gfc_find_symbol (name, ns, 0, &vtype);
441 gfc_symbol *parent = NULL, *parent_vtab = NULL;
443 gfc_get_symbol (name, ns, &vtype);
444 if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
445 NULL, &gfc_current_locus) == FAILURE)
447 vtype->attr.access = ACCESS_PUBLIC;
448 vtype->attr.vtype = 1;
449 gfc_set_sym_referenced (vtype);
451 /* Add component '_hash'. */
452 if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
454 c->ts.type = BT_INTEGER;
456 c->attr.access = ACCESS_PRIVATE;
457 c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
458 NULL, derived->hash_value);
460 /* Add component '_size'. */
461 if (gfc_add_component (vtype, "_size", &c) == FAILURE)
463 c->ts.type = BT_INTEGER;
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,
473 /* Add component _extends. */
474 if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
477 c->attr.access = ACCESS_PRIVATE;
478 parent = gfc_get_derived_super_type (derived);
481 parent_vtab = gfc_find_derived_vtab (parent);
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);
491 c->ts.type = BT_DERIVED;
492 c->ts.u.derived = vtype;
493 c->initializer = gfc_get_null_expr (NULL);
496 if (derived->components == NULL && !derived->attr.zero_comp)
498 /* At this point an error must have occurred.
499 Prevent further errors on the vtype components. */
504 /* Add component _def_init. */
505 if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
508 c->attr.access = ACCESS_PRIVATE;
509 c->ts.type = BT_DERIVED;
510 c->ts.u.derived = derived;
511 if (derived->attr.abstract)
512 c->initializer = gfc_get_null_expr (NULL);
515 /* Construct default initialization variable. */
516 sprintf (name, "__def_init_%s", tname);
517 gfc_get_symbol (name, ns, &def_init);
518 def_init->attr.target = 1;
519 def_init->attr.save = SAVE_IMPLICIT;
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);
527 c->initializer = gfc_lval_expr_from_sym (def_init);
530 /* Add component _copy. */
531 if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
533 c->attr.proc_pointer = 1;
534 c->attr.access = ACCESS_PRIVATE;
535 c->tb = XCNEW (gfc_typebound_proc);
537 if (derived->attr.abstract)
538 c->initializer = gfc_get_null_expr (NULL);
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. */
547 sprintf (name, "__copy_%s", tname);
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;
552 if (ns->proc_name->attr.flavor == FL_MODULE)
553 copy->module = ns->proc_name->name;
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;
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;
569 gfc_set_sym_referenced (dst);
570 copy->formal->next = gfc_get_formal_arglist ();
571 copy->formal->next->sym = dst;
573 sub_ns->code = gfc_get_code ();
574 sub_ns->code->op = EXEC_INIT_ASSIGN;
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;
582 /* Add procedure pointers for type-bound procedures. */
583 add_procs_to_declared_vtab (derived, vtype);
587 vtab->ts.u.derived = vtype;
588 vtab->value = gfc_default_initializer (&vtab->ts);
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. */
599 gfc_commit_symbol (vtab);
601 gfc_commit_symbol (vtype);
603 gfc_commit_symbol (def_init);
605 gfc_commit_symbol (copy);
607 gfc_commit_symbol (src);
609 gfc_commit_symbol (dst);
618 /* General worker function to find either a type-bound procedure or a
619 type-bound user operator. */
622 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
623 const char* name, bool noaccess, bool uop,
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);
634 /* Set default to failure. */
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)
646 if (!noaccess && derived->attr.use_assoc
647 && res->n.tb->access == ACCESS_PRIVATE)
650 gfc_error ("'%s' of '%s' is PRIVATE at %L",
651 name, derived->name, where);
659 /* Otherwise, recurse on parent type if derived is an extension. */
660 if (derived->attr.extension)
662 gfc_symbol* super_type;
663 super_type = gfc_get_derived_super_type (derived);
664 gcc_assert (super_type);
666 return find_typebound_proc_uop (super_type, t, name,
667 noaccess, uop, where);
675 /* Find a type-bound procedure or user operator by name for a derived-type
676 (looking recursively through the super-types). */
679 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
680 const char* name, bool noaccess, locus* where)
682 return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
686 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
687 const char* name, bool noaccess, locus* where)
689 return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
693 /* Find a type-bound intrinsic operator looking recursively through the
694 super-type hierarchy. */
697 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
698 gfc_intrinsic_op op, bool noaccess,
701 gfc_typebound_proc* res;
703 /* Set default to failure. */
707 /* Try to find it in the current type's namespace. */
708 if (derived->f2k_derived)
709 res = derived->f2k_derived->tb_op[op];
714 if (res && !res->error)
720 if (!noaccess && derived->attr.use_assoc
721 && res->access == ACCESS_PRIVATE)
724 gfc_error ("'%s' of '%s' is PRIVATE at %L",
725 gfc_op2string (op), derived->name, where);
733 /* Otherwise, recurse on parent type if derived is an extension. */
734 if (derived->attr.extension)
736 gfc_symbol* super_type;
737 super_type = gfc_get_derived_super_type (derived);
738 gcc_assert (super_type);
740 return gfc_find_typebound_intrinsic_op (super_type, t, op,
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. */
754 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
758 result = gfc_find_symtree (*root, name);
761 result = gfc_new_symtree (root, name);