gcc/fortran/class.c

   1 /* Implementation of Fortran 2003 Polymorphism.
   2    Copyright (C) 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Richard Thomas & Janus Weil
   5
   6 This file is part of GCC.
   7
   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
  11 version.
  12
  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
  16 for more details.
  17
  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/>.  */
  21
  22
  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.  */
  26
  27
  28 /* Outline of the internal representation:
  29
  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.
  36
  37    For each derived type we set up a "vtable" entry, i.e. a structure with the
  38    following fields:
  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).  */
  45
  46
  47 #include "config.h"
  48 #include "system.h"
  49 #include "gfortran.h"
  50 #include "constructor.h"
  51
  52
  53 /* Insert a reference to the component of the given name.
  54    Only to be used with CLASS containers.  */
  55
  56 void
  57 gfc_add_component_ref (gfc_expr *e, const char *name)
  58 {
  59   gfc_ref **tail = &(e->ref);
  60   gfc_ref *next = NULL;
  61   gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
  62   while (*tail != NULL)
  63     {
  64       if ((*tail)->type == REF_COMPONENT)
  65         derived = (*tail)->u.c.component->ts.u.derived;
  66       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
  67         break;
  68       tail = &((*tail)->next);
  69     }
  70   if (*tail != NULL && strcmp (name, "$data") == 0)
  71     next = *tail;
  72   (*tail) = gfc_get_ref();
  73   (*tail)->next = next;
  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);
  78   if (!next)
  79     e->ts = (*tail)->u.c.component->ts;
  80 }
  81
  82
  83 /* Build a NULL initializer for CLASS pointers,
  84    initializing the $data and $vptr components to zero.  */
  85
  86 gfc_expr *
  87 gfc_class_null_initializer (gfc_typespec *ts)
  88 {
  89   gfc_expr *init;
  90   gfc_component *comp;
  91
  92   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
  93                                              &ts->u.derived->declared_at);
  94   init->ts = *ts;
  95
  96   for (comp = ts->u.derived->components; comp; comp = comp->next)
  97     {
  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);
 103     }
 104
 105   return init;
 106 }
 107
 108
 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.  */
 113
 114 gfc_try
 115 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 116                         gfc_array_spec **as, bool delayed_vtab)
 117 {
 118   char name[GFC_MAX_SYMBOL_LEN + 5];
 119   gfc_symbol *fclass;
 120   gfc_symbol *vtab;
 121   gfc_component *c;
 122
 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);
 132   else
 133     sprintf (name, "class$%s", ts->u.derived->name);
 134
 135   gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
 136   if (fclass == NULL)
 137     {
 138       gfc_symtree *st;
 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);
 142       st->n.sym = fclass;
 143       gfc_set_sym_referenced (fclass);
 144       fclass->refs++;
 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)
 151         return FAILURE;
 152
 153       /* Add component '$data'.  */
 154       if (gfc_add_component (fclass, "$data", &c) == FAILURE)
 155         return FAILURE;
 156       c->ts = *ts;
 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;
 166       c->as = (*as);
 167       c->initializer = NULL;
 168
 169       /* Add component '$vptr'.  */
 170       if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
 171         return FAILURE;
 172       c->ts.type = BT_DERIVED;
 173       if (delayed_vtab)
 174         c->ts.u.derived = NULL;
 175       else
 176         {
 177           vtab = gfc_find_derived_vtab (ts->u.derived);
 178           gcc_assert (vtab);
 179           c->ts.u.derived = vtab->ts.u.derived;
 180         }
 181       c->attr.access = ACCESS_PRIVATE;
 182       c->attr.pointer = 1;
 183     }
 184
 185   /* Since the extension field is 8 bit wide, we can only have
 186      up to 255 extension levels.  */
 187   if (ts->u.derived->attr.extension == 255)
 188     {
 189       gfc_error ("Maximum extension level reached with type '%s' at %L",
 190                  ts->u.derived->name, &ts->u.derived->declared_at);
 191       return FAILURE;
 192     }
 193
 194   fclass->attr.extension = ts->u.derived->attr.extension + 1;
 195   fclass->attr.is_class = 1;
 196   ts->u.derived = fclass;
 197   attr->allocatable = attr->pointer = attr->dimension = 0;
 198   (*as) = NULL;  /* XXX */
 199   return SUCCESS;
 200 }
 201
 202
 203 /* Add a procedure pointer component to the vtype
 204    to represent a specific type-bound procedure.  */
 205
 206 static void
 207 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 208 {
 209   gfc_component *c;
 210   c = gfc_find_component (vtype, name, true, true);
 211
 212   if (c == NULL)
 213     {
 214       /* Add procedure component.  */
 215       if (gfc_add_component (vtype, name, &c) == FAILURE)
 216         return;
 217       if (tb->u.specific)
 218         c->ts.interface = tb->u.specific->n.sym;
 219
 220       if (!c->tb)
 221         c->tb = XCNEW (gfc_typebound_proc);
 222       *c->tb = *tb;
 223       c->tb->ppc = 1;
 224       c->attr.procedure = 1;
 225       c->attr.proc_pointer = 1;
 226       c->attr.flavor = FL_PROCEDURE;
 227       c->attr.access = ACCESS_PRIVATE;
 228       c->attr.external = 1;
 229       c->attr.untyped = 1;
 230       c->attr.if_source = IFSRC_IFBODY;
 231
 232       /* A static initializer cannot be used here because the specific
 233         function is not a constant; internal compiler error: in
 234         output_constant, at varasm.c:4623  */
 235       c->initializer = NULL;
 236     }
 237   else if (c->attr.proc_pointer && c->tb)
 238     {
 239       *c->tb = *tb;
 240       c->tb->ppc = 1;
 241       c->ts.interface = tb->u.specific->n.sym;
 242     }
 243 }
 244
 245
 246 /* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
 247
 248 static void
 249 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
 250 {
 251   if (!st)
 252     return;
 253
 254   if (st->left)
 255     add_procs_to_declared_vtab1 (st->left, vtype);
 256
 257   if (st->right)
 258     add_procs_to_declared_vtab1 (st->right, vtype);
 259
 260   if (st->n.tb && !st->n.tb->error
 261       && !st->n.tb->is_generic && st->n.tb->u.specific)
 262     add_proc_comp (vtype, st->name, st->n.tb);
 263 }
 264
 265
 266 /* Copy procedure pointers components from the parent type.  */
 267
 268 static void
 269 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 270 {
 271   gfc_component *cmp;
 272   gfc_symbol *vtab;
 273
 274   vtab = gfc_find_derived_vtab (declared);
 275
 276   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 277     {
 278       if (gfc_find_component (vtype, cmp->name, true, true))
 279         continue;
 280
 281       add_proc_comp (vtype, cmp->name, cmp->tb);
 282     }
 283 }
 284
 285
 286 /* Add procedure pointers for all type-bound procedures to a vtab.  */
 287
 288 static void
 289 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 290 {
 291   gfc_symbol* super_type;
 292
 293   super_type = gfc_get_derived_super_type (derived);
 294
 295   if (super_type && (super_type != derived))
 296     {
 297       /* Make sure that the PPCs appear in the same order as in the parent.  */
 298       copy_vtab_proc_comps (super_type, vtype);
 299       /* Only needed to get the PPC interfaces right.  */
 300       add_procs_to_declared_vtab (super_type, vtype);
 301     }
 302
 303   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
 304     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
 305
 306   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
 307     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
 308 }
 309
 310
 311 /* Find the symbol for a derived type's vtab.
 312    A vtab has the following fields:
 313     * $hash     a hash value used to identify the derived type
 314     * $size     the size in bytes of the derived type
 315     * $extends  a pointer to the vtable of the parent derived type
 316    After these follow procedure pointer components for the
 317    specific type-bound procedures.  */
 318
 319 gfc_symbol *
 320 gfc_find_derived_vtab (gfc_symbol *derived)
 321 {
 322   gfc_namespace *ns;
 323   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
 324   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
 325
 326   ns = gfc_current_ns;
 327
 328   for (; ns; ns = ns->parent)
 329     if (!ns->parent)
 330       break;
 331
 332   if (ns)
 333     {
 334       sprintf (name, "vtab$%s", derived->name);
 335       gfc_find_symbol (name, ns, 0, &vtab);
 336
 337       if (vtab == NULL)
 338         {
 339           gfc_get_symbol (name, ns, &vtab);
 340           vtab->ts.type = BT_DERIVED;
 341           vtab->attr.flavor = FL_VARIABLE;
 342           vtab->attr.target = 1;
 343           vtab->attr.save = SAVE_EXPLICIT;
 344           vtab->attr.vtab = 1;
 345           vtab->attr.access = ACCESS_PUBLIC;
 346           vtab->refs++;
 347           gfc_set_sym_referenced (vtab);
 348           sprintf (name, "vtype$%s", derived->name);
 349
 350           gfc_find_symbol (name, ns, 0, &vtype);
 351           if (vtype == NULL)
 352             {
 353               gfc_component *c;
 354               gfc_symbol *parent = NULL, *parent_vtab = NULL;
 355
 356               gfc_get_symbol (name, ns, &vtype);
 357               if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
 358                                   NULL, &gfc_current_locus) == FAILURE)
 359                 goto cleanup;
 360               vtype->attr.access = ACCESS_PUBLIC;
 361               vtype->refs++;
 362               gfc_set_sym_referenced (vtype);
 363
 364               /* Add component '$hash'.  */
 365               if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
 366                 goto cleanup;
 367               c->ts.type = BT_INTEGER;
 368               c->ts.kind = 4;
 369               c->attr.access = ACCESS_PRIVATE;
 370               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 371                                                  NULL, derived->hash_value);
 372
 373               /* Add component '$size'.  */
 374               if (gfc_add_component (vtype, "$size", &c) == FAILURE)
 375                 goto cleanup;
 376               c->ts.type = BT_INTEGER;
 377               c->ts.kind = 4;
 378               c->attr.access = ACCESS_PRIVATE;
 379               /* Remember the derived type in ts.u.derived,
 380                  so that the correct initializer can be set later on
 381                  (in gfc_conv_structure).  */
 382               c->ts.u.derived = derived;
 383               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 384                                                  NULL, 0);
 385
 386               /* Add component $extends.  */
 387               if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
 388                 goto cleanup;
 389               c->attr.pointer = 1;
 390               c->attr.access = ACCESS_PRIVATE;
 391               parent = gfc_get_derived_super_type (derived);
 392               if (parent)
 393                 {
 394                   parent_vtab = gfc_find_derived_vtab (parent);
 395                   c->ts.type = BT_DERIVED;
 396                   c->ts.u.derived = parent_vtab->ts.u.derived;
 397                   c->initializer = gfc_get_expr ();
 398                   c->initializer->expr_type = EXPR_VARIABLE;
 399                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
 400                                      0, &c->initializer->symtree);
 401                 }
 402               else
 403                 {
 404                   c->ts.type = BT_DERIVED;
 405                   c->ts.u.derived = vtype;
 406                   c->initializer = gfc_get_null_expr (NULL);
 407                 }
 408
 409               add_procs_to_declared_vtab (derived, vtype);
 410               vtype->attr.vtype = 1;
 411             }
 412
 413           vtab->ts.u.derived = vtype;
 414           vtab->value = gfc_default_initializer (&vtab->ts);
 415         }
 416     }
 417
 418   found_sym = vtab;
 419
 420 cleanup:
 421   /* It is unexpected to have some symbols added at resolution or code
 422      generation time. We commit the changes in order to keep a clean state.  */
 423   if (found_sym)
 424     gfc_commit_symbols ();
 425   else
 426     gfc_undo_symbols ();
 427
 428   return found_sym;
 429 }
 430
 431
 432 /* General worker function to find either a type-bound procedure or a
 433    type-bound user operator.  */
 434
 435 static gfc_symtree*
 436 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 437                          const char* name, bool noaccess, bool uop,
 438                          locus* where)
 439 {
 440   gfc_symtree* res;
 441   gfc_symtree* root;
 442
 443   /* Set correct symbol-root.  */
 444   gcc_assert (derived->f2k_derived);
 445   root = (uop ? derived->f2k_derived->tb_uop_root
 446               : derived->f2k_derived->tb_sym_root);
 447
 448   /* Set default to failure.  */
 449   if (t)
 450     *t = FAILURE;
 451
 452   /* Try to find it in the current type's namespace.  */
 453   res = gfc_find_symtree (root, name);
 454   if (res && res->n.tb && !res->n.tb->error)
 455     {
 456       /* We found one.  */
 457       if (t)
 458         *t = SUCCESS;
 459
 460       if (!noaccess && derived->attr.use_assoc
 461           && res->n.tb->access == ACCESS_PRIVATE)
 462         {
 463           if (where)
 464             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 465                        name, derived->name, where);
 466           if (t)
 467             *t = FAILURE;
 468         }
 469
 470       return res;
 471     }
 472
 473   /* Otherwise, recurse on parent type if derived is an extension.  */
 474   if (derived->attr.extension)
 475     {
 476       gfc_symbol* super_type;
 477       super_type = gfc_get_derived_super_type (derived);
 478       gcc_assert (super_type);
 479
 480       return find_typebound_proc_uop (super_type, t, name,
 481                                       noaccess, uop, where);
 482     }
 483
 484   /* Nothing found.  */
 485   return NULL;
 486 }
 487
 488
 489 /* Find a type-bound procedure or user operator by name for a derived-type
 490    (looking recursively through the super-types).  */
 491
 492 gfc_symtree*
 493 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 494                          const char* name, bool noaccess, locus* where)
 495 {
 496   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 497 }
 498
 499 gfc_symtree*
 500 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 501                             const char* name, bool noaccess, locus* where)
 502 {
 503   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 504 }
 505
 506
 507 /* Find a type-bound intrinsic operator looking recursively through the
 508    super-type hierarchy.  */
 509
 510 gfc_typebound_proc*
 511 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 512                                  gfc_intrinsic_op op, bool noaccess,
 513                                  locus* where)
 514 {
 515   gfc_typebound_proc* res;
 516
 517   /* Set default to failure.  */
 518   if (t)
 519     *t = FAILURE;
 520
 521   /* Try to find it in the current type's namespace.  */
 522   if (derived->f2k_derived)
 523     res = derived->f2k_derived->tb_op[op];
 524   else
 525     res = NULL;
 526
 527   /* Check access.  */
 528   if (res && !res->error)
 529     {
 530       /* We found one.  */
 531       if (t)
 532         *t = SUCCESS;
 533
 534       if (!noaccess && derived->attr.use_assoc
 535           && res->access == ACCESS_PRIVATE)
 536         {
 537           if (where)
 538             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 539                        gfc_op2string (op), derived->name, where);
 540           if (t)
 541             *t = FAILURE;
 542         }
 543
 544       return res;
 545     }
 546
 547   /* Otherwise, recurse on parent type if derived is an extension.  */
 548   if (derived->attr.extension)
 549     {
 550       gfc_symbol* super_type;
 551       super_type = gfc_get_derived_super_type (derived);
 552       gcc_assert (super_type);
 553
 554       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 555                                               noaccess, where);
 556     }
 557
 558   /* Nothing found.  */
 559   return NULL;
 560 }
 561
 562
 563 /* Get a typebound-procedure symtree or create and insert it if not yet
 564    present.  This is like a very simplified version of gfc_get_sym_tree for
 565    tbp-symtrees rather than regular ones.  */
 566
 567 gfc_symtree*
 568 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 569 {
 570   gfc_symtree *result;
 571
 572   result = gfc_find_symtree (*root, name);
 573   if (!result)
 574     {
 575       result = gfc_new_symtree (root, name);
 576       gcc_assert (result);
 577       result->n.tb = NULL;
 578     }
 579
 580   return result;
 581 }