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
 218       if (!c->tb)
 219         c->tb = XCNEW (gfc_typebound_proc);
 220       *c->tb = *tb;
 221       c->tb->ppc = 1;
 222       c->attr.procedure = 1;
 223       c->attr.proc_pointer = 1;
 224       c->attr.flavor = FL_PROCEDURE;
 225       c->attr.access = ACCESS_PRIVATE;
 226       c->attr.external = 1;
 227       c->attr.untyped = 1;
 228       c->attr.if_source = IFSRC_IFBODY;
 229     }
 230   else if (c->attr.proc_pointer && c->tb)
 231     {
 232       *c->tb = *tb;
 233       c->tb->ppc = 1;
 234     }
 235
 236   if (tb->u.specific)
 237     {
 238       c->ts.interface = tb->u.specific->n.sym;
 239       if (!tb->deferred)
 240         c->initializer = gfc_get_variable_expr (tb->u.specific);
 241     }
 242 }
 243
 244
 245 /* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
 246
 247 static void
 248 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
 249 {
 250   if (!st)
 251     return;
 252
 253   if (st->left)
 254     add_procs_to_declared_vtab1 (st->left, vtype);
 255
 256   if (st->right)
 257     add_procs_to_declared_vtab1 (st->right, vtype);
 258
 259   if (st->n.tb && !st->n.tb->error
 260       && !st->n.tb->is_generic && st->n.tb->u.specific)
 261     add_proc_comp (vtype, st->name, st->n.tb);
 262 }
 263
 264
 265 /* Copy procedure pointers components from the parent type.  */
 266
 267 static void
 268 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 269 {
 270   gfc_component *cmp;
 271   gfc_symbol *vtab;
 272
 273   vtab = gfc_find_derived_vtab (declared);
 274
 275   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 276     {
 277       if (gfc_find_component (vtype, cmp->name, true, true))
 278         continue;
 279
 280       add_proc_comp (vtype, cmp->name, cmp->tb);
 281     }
 282 }
 283
 284
 285 /* Add procedure pointers for all type-bound procedures to a vtab.  */
 286
 287 static void
 288 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 289 {
 290   gfc_symbol* super_type;
 291
 292   super_type = gfc_get_derived_super_type (derived);
 293
 294   if (super_type && (super_type != derived))
 295     {
 296       /* Make sure that the PPCs appear in the same order as in the parent.  */
 297       copy_vtab_proc_comps (super_type, vtype);
 298       /* Only needed to get the PPC initializers right.  */
 299       add_procs_to_declared_vtab (super_type, vtype);
 300     }
 301
 302   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
 303     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
 304
 305   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
 306     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
 307 }
 308
 309
 310 /* Find the symbol for a derived type's vtab.
 311    A vtab has the following fields:
 312     * $hash     a hash value used to identify the derived type
 313     * $size     the size in bytes of the derived type
 314     * $extends  a pointer to the vtable of the parent derived type
 315    After these follow procedure pointer components for the
 316    specific type-bound procedures.  */
 317
 318 gfc_symbol *
 319 gfc_find_derived_vtab (gfc_symbol *derived)
 320 {
 321   gfc_namespace *ns;
 322   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
 323   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
 324
 325   /* Find the top-level namespace (MODULE or PROGRAM).  */
 326   for (ns = gfc_current_ns; ns; ns = ns->parent)
 327     if (!ns->parent)
 328       break;
 329
 330   /* If the type is a class container, use the underlying derived type.  */
 331   if (derived->attr.is_class)
 332     derived = gfc_get_derived_super_type (derived);
 333
 334   if (ns)
 335     {
 336       sprintf (name, "vtab$%s", derived->name);
 337       gfc_find_symbol (name, ns, 0, &vtab);
 338
 339       if (vtab == NULL)
 340         {
 341           gfc_get_symbol (name, ns, &vtab);
 342           vtab->ts.type = BT_DERIVED;
 343           if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
 344                               &gfc_current_locus) == FAILURE)
 345             goto cleanup;
 346           vtab->attr.target = 1;
 347           vtab->attr.save = SAVE_EXPLICIT;
 348           vtab->attr.vtab = 1;
 349           vtab->attr.access = ACCESS_PUBLIC;
 350           gfc_set_sym_referenced (vtab);
 351           sprintf (name, "vtype$%s", derived->name);
 352
 353           gfc_find_symbol (name, ns, 0, &vtype);
 354           if (vtype == NULL)
 355             {
 356               gfc_component *c;
 357               gfc_symbol *parent = NULL, *parent_vtab = NULL;
 358
 359               gfc_get_symbol (name, ns, &vtype);
 360               if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
 361                                   NULL, &gfc_current_locus) == FAILURE)
 362                 goto cleanup;
 363               vtype->attr.access = ACCESS_PUBLIC;
 364               gfc_set_sym_referenced (vtype);
 365
 366               /* Add component '$hash'.  */
 367               if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
 368                 goto cleanup;
 369               c->ts.type = BT_INTEGER;
 370               c->ts.kind = 4;
 371               c->attr.access = ACCESS_PRIVATE;
 372               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 373                                                  NULL, derived->hash_value);
 374
 375               /* Add component '$size'.  */
 376               if (gfc_add_component (vtype, "$size", &c) == FAILURE)
 377                 goto cleanup;
 378               c->ts.type = BT_INTEGER;
 379               c->ts.kind = 4;
 380               c->attr.access = ACCESS_PRIVATE;
 381               /* Remember the derived type in ts.u.derived,
 382                  so that the correct initializer can be set later on
 383                  (in gfc_conv_structure).  */
 384               c->ts.u.derived = derived;
 385               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 386                                                  NULL, 0);
 387
 388               /* Add component $extends.  */
 389               if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
 390                 goto cleanup;
 391               c->attr.pointer = 1;
 392               c->attr.access = ACCESS_PRIVATE;
 393               parent = gfc_get_derived_super_type (derived);
 394               if (parent)
 395                 {
 396                   parent_vtab = gfc_find_derived_vtab (parent);
 397                   c->ts.type = BT_DERIVED;
 398                   c->ts.u.derived = parent_vtab->ts.u.derived;
 399                   c->initializer = gfc_get_expr ();
 400                   c->initializer->expr_type = EXPR_VARIABLE;
 401                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
 402                                      0, &c->initializer->symtree);
 403                 }
 404               else
 405                 {
 406                   c->ts.type = BT_DERIVED;
 407                   c->ts.u.derived = vtype;
 408                   c->initializer = gfc_get_null_expr (NULL);
 409                 }
 410
 411               /* Add component $def_init.  */
 412               if (gfc_add_component (vtype, "$def_init", &c) == FAILURE)
 413                 goto cleanup;
 414               c->attr.pointer = 1;
 415               c->attr.access = ACCESS_PRIVATE;
 416               c->ts.type = BT_DERIVED;
 417               c->ts.u.derived = derived;
 418               if (derived->attr.abstract)
 419                 c->initializer = NULL;
 420               else
 421                 {
 422                   /* Construct default initialization variable.  */
 423                   sprintf (name, "def_init$%s", derived->name);
 424                   gfc_get_symbol (name, ns, &def_init);
 425                   def_init->attr.target = 1;
 426                   def_init->attr.save = SAVE_EXPLICIT;
 427                   def_init->attr.access = ACCESS_PUBLIC;
 428                   def_init->attr.flavor = FL_VARIABLE;
 429                   gfc_set_sym_referenced (def_init);
 430                   def_init->ts.type = BT_DERIVED;
 431                   def_init->ts.u.derived = derived;
 432                   def_init->value = gfc_default_initializer (&def_init->ts);
 433
 434                   c->initializer = gfc_lval_expr_from_sym (def_init);
 435                 }
 436
 437               /* Add procedure pointers for type-bound procedures.  */
 438               add_procs_to_declared_vtab (derived, vtype);
 439               vtype->attr.vtype = 1;
 440             }
 441
 442           vtab->ts.u.derived = vtype;
 443           vtab->value = gfc_default_initializer (&vtab->ts);
 444         }
 445     }
 446
 447   found_sym = vtab;
 448
 449 cleanup:
 450   /* It is unexpected to have some symbols added at resolution or code
 451      generation time. We commit the changes in order to keep a clean state.  */
 452   if (found_sym)
 453     {
 454       gfc_commit_symbol (vtab);
 455       if (vtype)
 456         gfc_commit_symbol (vtype);
 457       if (def_init)
 458         gfc_commit_symbol (def_init);
 459     }
 460   else
 461     gfc_undo_symbols ();
 462
 463   return found_sym;
 464 }
 465
 466
 467 /* General worker function to find either a type-bound procedure or a
 468    type-bound user operator.  */
 469
 470 static gfc_symtree*
 471 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 472                          const char* name, bool noaccess, bool uop,
 473                          locus* where)
 474 {
 475   gfc_symtree* res;
 476   gfc_symtree* root;
 477
 478   /* Set correct symbol-root.  */
 479   gcc_assert (derived->f2k_derived);
 480   root = (uop ? derived->f2k_derived->tb_uop_root
 481               : derived->f2k_derived->tb_sym_root);
 482
 483   /* Set default to failure.  */
 484   if (t)
 485     *t = FAILURE;
 486
 487   /* Try to find it in the current type's namespace.  */
 488   res = gfc_find_symtree (root, name);
 489   if (res && res->n.tb && !res->n.tb->error)
 490     {
 491       /* We found one.  */
 492       if (t)
 493         *t = SUCCESS;
 494
 495       if (!noaccess && derived->attr.use_assoc
 496           && res->n.tb->access == ACCESS_PRIVATE)
 497         {
 498           if (where)
 499             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 500                        name, derived->name, where);
 501           if (t)
 502             *t = FAILURE;
 503         }
 504
 505       return res;
 506     }
 507
 508   /* Otherwise, recurse on parent type if derived is an extension.  */
 509   if (derived->attr.extension)
 510     {
 511       gfc_symbol* super_type;
 512       super_type = gfc_get_derived_super_type (derived);
 513       gcc_assert (super_type);
 514
 515       return find_typebound_proc_uop (super_type, t, name,
 516                                       noaccess, uop, where);
 517     }
 518
 519   /* Nothing found.  */
 520   return NULL;
 521 }
 522
 523
 524 /* Find a type-bound procedure or user operator by name for a derived-type
 525    (looking recursively through the super-types).  */
 526
 527 gfc_symtree*
 528 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 529                          const char* name, bool noaccess, locus* where)
 530 {
 531   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 532 }
 533
 534 gfc_symtree*
 535 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 536                             const char* name, bool noaccess, locus* where)
 537 {
 538   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 539 }
 540
 541
 542 /* Find a type-bound intrinsic operator looking recursively through the
 543    super-type hierarchy.  */
 544
 545 gfc_typebound_proc*
 546 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 547                                  gfc_intrinsic_op op, bool noaccess,
 548                                  locus* where)
 549 {
 550   gfc_typebound_proc* res;
 551
 552   /* Set default to failure.  */
 553   if (t)
 554     *t = FAILURE;
 555
 556   /* Try to find it in the current type's namespace.  */
 557   if (derived->f2k_derived)
 558     res = derived->f2k_derived->tb_op[op];
 559   else
 560     res = NULL;
 561
 562   /* Check access.  */
 563   if (res && !res->error)
 564     {
 565       /* We found one.  */
 566       if (t)
 567         *t = SUCCESS;
 568
 569       if (!noaccess && derived->attr.use_assoc
 570           && res->access == ACCESS_PRIVATE)
 571         {
 572           if (where)
 573             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 574                        gfc_op2string (op), derived->name, where);
 575           if (t)
 576             *t = FAILURE;
 577         }
 578
 579       return res;
 580     }
 581
 582   /* Otherwise, recurse on parent type if derived is an extension.  */
 583   if (derived->attr.extension)
 584     {
 585       gfc_symbol* super_type;
 586       super_type = gfc_get_derived_super_type (derived);
 587       gcc_assert (super_type);
 588
 589       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 590                                               noaccess, where);
 591     }
 592
 593   /* Nothing found.  */
 594   return NULL;
 595 }
 596
 597
 598 /* Get a typebound-procedure symtree or create and insert it if not yet
 599    present.  This is like a very simplified version of gfc_get_sym_tree for
 600    tbp-symtrees rather than regular ones.  */
 601
 602 gfc_symtree*
 603 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 604 {
 605   gfc_symtree *result;
 606
 607   result = gfc_find_symtree (*root, name);
 608   if (!result)
 609     {
 610       result = gfc_new_symtree (root, name);
 611       gcc_assert (result);
 612       result->n.tb = NULL;
 613     }
 614
 615   return result;
 616 }