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.pointer = 1;
 182     }
 183
 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)
 187     {
 188       gfc_error ("Maximum extension level reached with type '%s' at %L",
 189                  ts->u.derived->name, &ts->u.derived->declared_at);
 190       return FAILURE;
 191     }
 192
 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 */
 198   return SUCCESS;
 199 }
 200
 201
 202 /* Add a procedure pointer component to the vtype
 203    to represent a specific type-bound procedure.  */
 204
 205 static void
 206 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 207 {
 208   gfc_component *c;
 209   c = gfc_find_component (vtype, name, true, true);
 210
 211   if (c == NULL)
 212     {
 213       /* Add procedure component.  */
 214       if (gfc_add_component (vtype, name, &c) == FAILURE)
 215         return;
 216       if (tb->u.specific)
 217         c->ts.interface = tb->u.specific->n.sym;
 218
 219       if (!c->tb)
 220         c->tb = XCNEW (gfc_typebound_proc);
 221       *c->tb = *tb;
 222       c->tb->ppc = 1;
 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;
 228       c->attr.untyped = 1;
 229       c->attr.if_source = IFSRC_IFBODY;
 230
 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;
 235     }
 236   else if (c->attr.proc_pointer && c->tb)
 237     {
 238       *c->tb = *tb;
 239       c->tb->ppc = 1;
 240       c->ts.interface = tb->u.specific->n.sym;
 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)
 260     return;
 261
 262   if (!st->n.tb->is_generic && st->n.tb->u.specific)
 263     add_proc_comp (vtype, st->name, st->n.tb);
 264 }
 265
 266
 267 /* Copy procedure pointers components from the parent type.  */
 268
 269 static void
 270 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 271 {
 272   gfc_component *cmp;
 273   gfc_symbol *vtab;
 274
 275   vtab = gfc_find_derived_vtab (declared);
 276
 277   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 278     {
 279       if (gfc_find_component (vtype, cmp->name, true, true))
 280         continue;
 281
 282       add_proc_comp (vtype, cmp->name, cmp->tb);
 283     }
 284 }
 285
 286
 287 /* Add procedure pointers for all type-bound procedures to a vtab.  */
 288
 289 static void
 290 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 291 {
 292   gfc_symbol* super_type;
 293
 294   super_type = gfc_get_derived_super_type (derived);
 295
 296   if (super_type && (super_type != derived))
 297     {
 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);
 302     }
 303
 304   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
 305     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
 306
 307   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
 308     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
 309 }
 310
 311
 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.  */
 319
 320 gfc_symbol *
 321 gfc_find_derived_vtab (gfc_symbol *derived)
 322 {
 323   gfc_namespace *ns;
 324   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
 325   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
 326
 327   ns = gfc_current_ns;
 328
 329   for (; ns; ns = ns->parent)
 330     if (!ns->parent)
 331       break;
 332
 333   if (ns)
 334     {
 335       sprintf (name, "vtab$%s", derived->name);
 336       gfc_find_symbol (name, ns, 0, &vtab);
 337
 338       if (vtab == NULL)
 339         {
 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;
 345           vtab->attr.vtab = 1;
 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->refs++;
 361               gfc_set_sym_referenced (vtype);
 362
 363               /* Add component '$hash'.  */
 364               if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
 365                 goto cleanup;
 366               c->ts.type = BT_INTEGER;
 367               c->ts.kind = 4;
 368               c->attr.access = ACCESS_PRIVATE;
 369               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 370                                                  NULL, derived->hash_value);
 371
 372               /* Add component '$size'.  */
 373               if (gfc_add_component (vtype, "$size", &c) == FAILURE)
 374                 goto cleanup;
 375               c->ts.type = BT_INTEGER;
 376               c->ts.kind = 4;
 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,
 383                                                  NULL, 0);
 384
 385               /* Add component $extends.  */
 386               if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
 387                 goto cleanup;
 388               c->attr.pointer = 1;
 389               c->attr.access = ACCESS_PRIVATE;
 390               parent = gfc_get_derived_super_type (derived);
 391               if (parent)
 392                 {
 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);
 400                 }
 401               else
 402                 {
 403                   c->ts.type = BT_DERIVED;
 404                   c->ts.u.derived = vtype;
 405                   c->initializer = gfc_get_null_expr (NULL);
 406                 }
 407
 408               add_procs_to_declared_vtab (derived, vtype);
 409               vtype->attr.vtype = 1;
 410             }
 411
 412           vtab->ts.u.derived = vtype;
 413           vtab->value = gfc_default_initializer (&vtab->ts);
 414         }
 415     }
 416
 417   found_sym = vtab;
 418
 419 cleanup:
 420   /* It is unexpected to have some symbols added at resolution or code
 421      generation time. We commit the changes in order to keep a clean state.  */
 422   if (found_sym)
 423     gfc_commit_symbols ();
 424   else
 425     gfc_undo_symbols ();
 426
 427   return found_sym;
 428 }
 429
 430
 431 /* General worker function to find either a type-bound procedure or a
 432    type-bound user operator.  */
 433
 434 static gfc_symtree*
 435 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 436                          const char* name, bool noaccess, bool uop,
 437                          locus* where)
 438 {
 439   gfc_symtree* res;
 440   gfc_symtree* root;
 441
 442   /* Set correct symbol-root.  */
 443   gcc_assert (derived->f2k_derived);
 444   root = (uop ? derived->f2k_derived->tb_uop_root
 445               : derived->f2k_derived->tb_sym_root);
 446
 447   /* Set default to failure.  */
 448   if (t)
 449     *t = FAILURE;
 450
 451   /* Try to find it in the current type's namespace.  */
 452   res = gfc_find_symtree (root, name);
 453   if (res && res->n.tb && !res->n.tb->error)
 454     {
 455       /* We found one.  */
 456       if (t)
 457         *t = SUCCESS;
 458
 459       if (!noaccess && derived->attr.use_assoc
 460           && res->n.tb->access == ACCESS_PRIVATE)
 461         {
 462           if (where)
 463             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 464                        name, derived->name, where);
 465           if (t)
 466             *t = FAILURE;
 467         }
 468
 469       return res;
 470     }
 471
 472   /* Otherwise, recurse on parent type if derived is an extension.  */
 473   if (derived->attr.extension)
 474     {
 475       gfc_symbol* super_type;
 476       super_type = gfc_get_derived_super_type (derived);
 477       gcc_assert (super_type);
 478
 479       return find_typebound_proc_uop (super_type, t, name,
 480                                       noaccess, uop, where);
 481     }
 482
 483   /* Nothing found.  */
 484   return NULL;
 485 }
 486
 487
 488 /* Find a type-bound procedure or user operator by name for a derived-type
 489    (looking recursively through the super-types).  */
 490
 491 gfc_symtree*
 492 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 493                          const char* name, bool noaccess, locus* where)
 494 {
 495   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 496 }
 497
 498 gfc_symtree*
 499 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 500                             const char* name, bool noaccess, locus* where)
 501 {
 502   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 503 }
 504
 505
 506 /* Find a type-bound intrinsic operator looking recursively through the
 507    super-type hierarchy.  */
 508
 509 gfc_typebound_proc*
 510 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 511                                  gfc_intrinsic_op op, bool noaccess,
 512                                  locus* where)
 513 {
 514   gfc_typebound_proc* res;
 515
 516   /* Set default to failure.  */
 517   if (t)
 518     *t = FAILURE;
 519
 520   /* Try to find it in the current type's namespace.  */
 521   if (derived->f2k_derived)
 522     res = derived->f2k_derived->tb_op[op];
 523   else
 524     res = NULL;
 525
 526   /* Check access.  */
 527   if (res && !res->error)
 528     {
 529       /* We found one.  */
 530       if (t)
 531         *t = SUCCESS;
 532
 533       if (!noaccess && derived->attr.use_assoc
 534           && res->access == ACCESS_PRIVATE)
 535         {
 536           if (where)
 537             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 538                        gfc_op2string (op), derived->name, where);
 539           if (t)
 540             *t = FAILURE;
 541         }
 542
 543       return res;
 544     }
 545
 546   /* Otherwise, recurse on parent type if derived is an extension.  */
 547   if (derived->attr.extension)
 548     {
 549       gfc_symbol* super_type;
 550       super_type = gfc_get_derived_super_type (derived);
 551       gcc_assert (super_type);
 552
 553       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 554                                               noaccess, where);
 555     }
 556
 557   /* Nothing found.  */
 558   return NULL;
 559 }
 560
 561
 562 /* Get a typebound-procedure symtree or create and insert it if not yet
 563    present.  This is like a very simplified version of gfc_get_sym_tree for
 564    tbp-symtrees rather than regular ones.  */
 565
 566 gfc_symtree*
 567 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 568 {
 569   gfc_symtree *result;
 570
 571   result = gfc_find_symtree (*root, name);
 572   if (!result)
 573     {
 574       result = gfc_new_symtree (root, name);
 575       gcc_assert (result);
 576       result->n.tb = NULL;
 577     }
 578
 579   return result;
 580 }