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 <pault@gcc.gnu.org>
   5    and Janus Weil <janus@gcc.gnu.org>
   6
   7 This file is part of GCC.
   8
   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
  12 version.
  13
  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
  17 for more details.
  18
  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/>.  */
  22
  23
  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.  */
  27
  28
  29 /* Outline of the internal representation:
  30
  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.
  37
  38    For each derived type we set up a "vtable" entry, i.e. a structure with the
  39    following fields:
  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.  */
  47
  48
  49 #include "config.h"
  50 #include "system.h"
  51 #include "gfortran.h"
  52 #include "constructor.h"
  53
  54
  55 /* Insert a reference to the component of the given name.
  56    Only to be used with CLASS containers and vtables.  */
  57
  58 void
  59 gfc_add_component_ref (gfc_expr *e, const char *name)
  60 {
  61   gfc_ref **tail = &(e->ref);
  62   gfc_ref *next = NULL;
  63   gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
  64   while (*tail != NULL)
  65     {
  66       if ((*tail)->type == REF_COMPONENT)
  67         {
  68           if (strcmp ((*tail)->u.c.component->name, "_data") == 0
  69                 && (*tail)->next
  70                 && (*tail)->next->type == REF_ARRAY
  71                 && (*tail)->next->next == NULL)
  72             return;
  73           derived = (*tail)->u.c.component->ts.u.derived;
  74         }
  75       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
  76         break;
  77       tail = &((*tail)->next);
  78     }
  79   if (*tail != NULL && strcmp (name, "_data") == 0)
  80     next = *tail;
  81   (*tail) = gfc_get_ref();
  82   (*tail)->next = next;
  83   (*tail)->type = REF_COMPONENT;
  84   (*tail)->u.c.sym = derived;
  85   (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
  86   gcc_assert((*tail)->u.c.component);
  87   if (!next)
  88     e->ts = (*tail)->u.c.component->ts;
  89 }
  90
  91
  92 /* This is used to add both the _data component reference and an array
  93    reference to class expressions.  Used in translation of intrinsic
  94    array inquiry functions.  */
  95
  96 void
  97 gfc_add_class_array_ref (gfc_expr *e)
  98 {
  99   int rank =  CLASS_DATA (e)->as->rank;
 100   gfc_array_spec *as = CLASS_DATA (e)->as;
 101   gfc_ref *ref = NULL;
 102   gfc_add_component_ref (e, "_data");
 103   e->rank = rank;
 104   for (ref = e->ref; ref; ref = ref->next)
 105     if (!ref->next)
 106       break;
 107   if (ref->type != REF_ARRAY)
 108     {
 109       ref->next = gfc_get_ref ();
 110       ref = ref->next;
 111       ref->type = REF_ARRAY;
 112       ref->u.ar.type = AR_FULL;
 113       ref->u.ar.as = as;
 114     }
 115 }
 116
 117
 118 /* Unfortunately, class array expressions can appear in various conditions;
 119    with and without both _data component and an arrayspec.  This function
 120    deals with that variability.  The previous reference to 'ref' is to a
 121    class array.  */
 122
 123 static bool
 124 class_array_ref_detected (gfc_ref *ref, bool *full_array)
 125 {
 126   bool no_data = false;
 127   bool with_data = false;
 128
 129   /* An array reference with no _data component.  */
 130   if (ref && ref->type == REF_ARRAY
 131         && !ref->next
 132         && ref->u.ar.type != AR_ELEMENT)
 133     {
 134       if (full_array)
 135         *full_array = ref->u.ar.type == AR_FULL;
 136       no_data = true;
 137     }
 138
 139   /* Cover cases where _data appears, with or without an array ref.  */
 140   if (ref && ref->type == REF_COMPONENT
 141         && strcmp (ref->u.c.component->name, "_data") == 0)
 142     {
 143       if (!ref->next)
 144         {
 145           with_data = true;
 146           if (full_array)
 147             *full_array = true;
 148         }
 149       else if (ref->next && ref->next->type == REF_ARRAY
 150             && !ref->next->next
 151             && ref->type == REF_COMPONENT
 152             && ref->next->type == REF_ARRAY
 153             && ref->next->u.ar.type != AR_ELEMENT)
 154         {
 155           with_data = true;
 156           if (full_array)
 157             *full_array = ref->next->u.ar.type == AR_FULL;
 158         }
 159     }
 160
 161   return no_data || with_data;
 162 }
 163
 164
 165 /* Returns true if the expression contains a reference to a class
 166    array.  Notice that class array elements return false.  */
 167
 168 bool
 169 gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
 170 {
 171   gfc_ref *ref;
 172
 173   if (!e->rank)
 174     return false;
 175
 176   if (full_array)
 177     *full_array= false;
 178
 179   /* Is this a class array object? ie. Is the symbol of type class?  */
 180   if (e->symtree
 181         && e->symtree->n.sym->ts.type == BT_CLASS
 182         && CLASS_DATA (e->symtree->n.sym)
 183         && CLASS_DATA (e->symtree->n.sym)->attr.dimension
 184         && class_array_ref_detected (e->ref, full_array))
 185     return true;
 186
 187   /* Or is this a class array component reference?  */
 188   for (ref = e->ref; ref; ref = ref->next)
 189     {
 190       if (ref->type == REF_COMPONENT
 191             && ref->u.c.component->ts.type == BT_CLASS
 192             && CLASS_DATA (ref->u.c.component)->attr.dimension
 193             && class_array_ref_detected (ref->next, full_array))
 194         return true;
 195     }
 196
 197   return false;
 198 }
 199
 200
 201 /* Returns true if the expression is a reference to a class
 202    scalar.  This function is necessary because such expressions
 203    can be dressed with a reference to the _data component and so
 204    have a type other than BT_CLASS.  */
 205
 206 bool
 207 gfc_is_class_scalar_expr (gfc_expr *e)
 208 {
 209   gfc_ref *ref;
 210
 211   if (e->rank)
 212     return false;
 213
 214   /* Is this a class object?  */
 215   if (e->symtree
 216         && e->symtree->n.sym->ts.type == BT_CLASS
 217         && CLASS_DATA (e->symtree->n.sym)
 218         && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
 219         && (e->ref == NULL
 220             || (strcmp (e->ref->u.c.component->name, "_data") == 0
 221                 && e->ref->next == NULL)))
 222     return true;
 223
 224   /* Or is the final reference BT_CLASS or _data?  */
 225   for (ref = e->ref; ref; ref = ref->next)
 226     {
 227       if (ref->type == REF_COMPONENT
 228             && ref->u.c.component->ts.type == BT_CLASS
 229             && CLASS_DATA (ref->u.c.component)
 230             && !CLASS_DATA (ref->u.c.component)->attr.dimension
 231             && (ref->next == NULL
 232                 || (strcmp (ref->next->u.c.component->name, "_data") == 0
 233                     && ref->next->next == NULL)))
 234         return true;
 235     }
 236
 237   return false;
 238 }
 239
 240
 241 /* Build a NULL initializer for CLASS pointers,
 242    initializing the _data component to NULL and
 243    the _vptr component to the declared type.  */
 244
 245 gfc_expr *
 246 gfc_class_null_initializer (gfc_typespec *ts)
 247 {
 248   gfc_expr *init;
 249   gfc_component *comp;
 250
 251   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
 252                                              &ts->u.derived->declared_at);
 253   init->ts = *ts;
 254
 255   for (comp = ts->u.derived->components; comp; comp = comp->next)
 256     {
 257       gfc_constructor *ctor = gfc_constructor_get();
 258       if (strcmp (comp->name, "_vptr") == 0)
 259         ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
 260       else
 261         ctor->expr = gfc_get_null_expr (NULL);
 262       gfc_constructor_append (&init->value.constructor, ctor);
 263     }
 264
 265   return init;
 266 }
 267
 268
 269 /* Create a unique string identifier for a derived type, composed of its name
 270    and module name. This is used to construct unique names for the class
 271    containers and vtab symbols.  */
 272
 273 static void
 274 get_unique_type_string (char *string, gfc_symbol *derived)
 275 {
 276   char dt_name[GFC_MAX_SYMBOL_LEN+1];
 277   sprintf (dt_name, "%s", derived->name);
 278   dt_name[0] = TOUPPER (dt_name[0]);
 279   if (derived->module)
 280     sprintf (string, "%s_%s", derived->module, dt_name);
 281   else if (derived->ns->proc_name)
 282     sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
 283   else
 284     sprintf (string, "_%s", dt_name);
 285 }
 286
 287
 288 /* A relative of 'get_unique_type_string' which makes sure the generated
 289    string will not be too long (replacing it by a hash string if needed).  */
 290
 291 static void
 292 get_unique_hashed_string (char *string, gfc_symbol *derived)
 293 {
 294   char tmp[2*GFC_MAX_SYMBOL_LEN+2];
 295   get_unique_type_string (&tmp[0], derived);
 296   /* If string is too long, use hash value in hex representation (allow for
 297      extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).  */
 298   if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 11)
 299     {
 300       int h = gfc_hash_value (derived);
 301       sprintf (string, "%X", h);
 302     }
 303   else
 304     strcpy (string, tmp);
 305 }
 306
 307
 308 /* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
 309
 310 unsigned int
 311 gfc_hash_value (gfc_symbol *sym)
 312 {
 313   unsigned int hash = 0;
 314   char c[2*(GFC_MAX_SYMBOL_LEN+1)];
 315   int i, len;
 316
 317   get_unique_type_string (&c[0], sym);
 318   len = strlen (c);
 319
 320   for (i = 0; i < len; i++)
 321     hash = (hash << 6) + (hash << 16) - hash + c[i];
 322
 323   /* Return the hash but take the modulus for the sake of module read,
 324      even though this slightly increases the chance of collision.  */
 325   return (hash % 100000000);
 326 }
 327
 328
 329 /* Build a polymorphic CLASS entity, using the symbol that comes from
 330    build_sym. A CLASS entity is represented by an encapsulating type,
 331    which contains the declared type as '_data' component, plus a pointer
 332    component '_vptr' which determines the dynamic type.  */
 333
 334 gfc_try
 335 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 336                         gfc_array_spec **as, bool delayed_vtab)
 337 {
 338   char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 339   gfc_symbol *fclass;
 340   gfc_symbol *vtab;
 341   gfc_component *c;
 342
 343   if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
 344     {
 345       gfc_error ("Assumed size polymorphic objects or components, such "
 346                  "as that at %C, have not yet been implemented");
 347       return FAILURE;
 348     }
 349
 350   if (attr->class_ok)
 351     /* Class container has already been built.  */
 352     return SUCCESS;
 353
 354   attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
 355                    || attr->select_type_temporary;
 356
 357   if (!attr->class_ok)
 358     /* We can not build the class container yet.  */
 359     return SUCCESS;
 360
 361   /* Determine the name of the encapsulating type.  */
 362   get_unique_hashed_string (tname, ts->u.derived);
 363   if ((*as) && (*as)->rank && attr->allocatable)
 364     sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
 365   else if ((*as) && (*as)->rank)
 366     sprintf (name, "__class_%s_%d", tname, (*as)->rank);
 367   else if (attr->pointer)
 368     sprintf (name, "__class_%s_p", tname);
 369   else if (attr->allocatable)
 370     sprintf (name, "__class_%s_a", tname);
 371   else
 372     sprintf (name, "__class_%s", tname);
 373
 374   gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
 375   if (fclass == NULL)
 376     {
 377       gfc_symtree *st;
 378       /* If not there, create a new symbol.  */
 379       fclass = gfc_new_symbol (name, ts->u.derived->ns);
 380       st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
 381       st->n.sym = fclass;
 382       gfc_set_sym_referenced (fclass);
 383       fclass->refs++;
 384       fclass->ts.type = BT_UNKNOWN;
 385       fclass->attr.abstract = ts->u.derived->attr.abstract;
 386       if (ts->u.derived->f2k_derived)
 387         fclass->f2k_derived = gfc_get_namespace (NULL, 0);
 388       if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
 389           NULL, &gfc_current_locus) == FAILURE)
 390         return FAILURE;
 391
 392       /* Add component '_data'.  */
 393       if (gfc_add_component (fclass, "_data", &c) == FAILURE)
 394         return FAILURE;
 395       c->ts = *ts;
 396       c->ts.type = BT_DERIVED;
 397       c->attr.access = ACCESS_PRIVATE;
 398       c->ts.u.derived = ts->u.derived;
 399       c->attr.class_pointer = attr->pointer;
 400       c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
 401                         || attr->select_type_temporary;
 402       c->attr.allocatable = attr->allocatable;
 403       c->attr.dimension = attr->dimension;
 404       c->attr.codimension = attr->codimension;
 405       c->attr.abstract = ts->u.derived->attr.abstract;
 406       c->as = (*as);
 407       c->initializer = NULL;
 408
 409       /* Add component '_vptr'.  */
 410       if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
 411         return FAILURE;
 412       c->ts.type = BT_DERIVED;
 413       if (delayed_vtab)
 414         c->ts.u.derived = NULL;
 415       else
 416         {
 417           vtab = gfc_find_derived_vtab (ts->u.derived);
 418           gcc_assert (vtab);
 419           c->ts.u.derived = vtab->ts.u.derived;
 420         }
 421       c->attr.access = ACCESS_PRIVATE;
 422       c->attr.pointer = 1;
 423     }
 424
 425   /* Since the extension field is 8 bit wide, we can only have
 426      up to 255 extension levels.  */
 427   if (ts->u.derived->attr.extension == 255)
 428     {
 429       gfc_error ("Maximum extension level reached with type '%s' at %L",
 430                  ts->u.derived->name, &ts->u.derived->declared_at);
 431       return FAILURE;
 432     }
 433
 434   fclass->attr.extension = ts->u.derived->attr.extension + 1;
 435   fclass->attr.is_class = 1;
 436   ts->u.derived = fclass;
 437   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
 438   (*as) = NULL;
 439   return SUCCESS;
 440 }
 441
 442
 443 /* Add a procedure pointer component to the vtype
 444    to represent a specific type-bound procedure.  */
 445
 446 static void
 447 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 448 {
 449   gfc_component *c;
 450
 451   if (tb->non_overridable)
 452     return;
 453
 454   c = gfc_find_component (vtype, name, true, true);
 455
 456   if (c == NULL)
 457     {
 458       /* Add procedure component.  */
 459       if (gfc_add_component (vtype, name, &c) == FAILURE)
 460         return;
 461
 462       if (!c->tb)
 463         c->tb = XCNEW (gfc_typebound_proc);
 464       *c->tb = *tb;
 465       c->tb->ppc = 1;
 466       c->attr.procedure = 1;
 467       c->attr.proc_pointer = 1;
 468       c->attr.flavor = FL_PROCEDURE;
 469       c->attr.access = ACCESS_PRIVATE;
 470       c->attr.external = 1;
 471       c->attr.untyped = 1;
 472       c->attr.if_source = IFSRC_IFBODY;
 473     }
 474   else if (c->attr.proc_pointer && c->tb)
 475     {
 476       *c->tb = *tb;
 477       c->tb->ppc = 1;
 478     }
 479
 480   if (tb->u.specific)
 481     {
 482       c->ts.interface = tb->u.specific->n.sym;
 483       if (!tb->deferred)
 484         c->initializer = gfc_get_variable_expr (tb->u.specific);
 485     }
 486 }
 487
 488
 489 /* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
 490
 491 static void
 492 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
 493 {
 494   if (!st)
 495     return;
 496
 497   if (st->left)
 498     add_procs_to_declared_vtab1 (st->left, vtype);
 499
 500   if (st->right)
 501     add_procs_to_declared_vtab1 (st->right, vtype);
 502
 503   if (st->n.tb && !st->n.tb->error
 504       && !st->n.tb->is_generic && st->n.tb->u.specific)
 505     add_proc_comp (vtype, st->name, st->n.tb);
 506 }
 507
 508
 509 /* Copy procedure pointers components from the parent type.  */
 510
 511 static void
 512 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 513 {
 514   gfc_component *cmp;
 515   gfc_symbol *vtab;
 516
 517   vtab = gfc_find_derived_vtab (declared);
 518
 519   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 520     {
 521       if (gfc_find_component (vtype, cmp->name, true, true))
 522         continue;
 523
 524       add_proc_comp (vtype, cmp->name, cmp->tb);
 525     }
 526 }
 527
 528
 529 /* Add procedure pointers for all type-bound procedures to a vtab.  */
 530
 531 static void
 532 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 533 {
 534   gfc_symbol* super_type;
 535
 536   super_type = gfc_get_derived_super_type (derived);
 537
 538   if (super_type && (super_type != derived))
 539     {
 540       /* Make sure that the PPCs appear in the same order as in the parent.  */
 541       copy_vtab_proc_comps (super_type, vtype);
 542       /* Only needed to get the PPC initializers right.  */
 543       add_procs_to_declared_vtab (super_type, vtype);
 544     }
 545
 546   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
 547     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
 548
 549   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
 550     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
 551 }
 552
 553
 554 /* Find (or generate) the symbol for a derived type's vtab.  */
 555
 556 gfc_symbol *
 557 gfc_find_derived_vtab (gfc_symbol *derived)
 558 {
 559   gfc_namespace *ns;
 560   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
 561   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
 562
 563   /* Find the top-level namespace (MODULE or PROGRAM).  */
 564   for (ns = gfc_current_ns; ns; ns = ns->parent)
 565     if (!ns->parent)
 566       break;
 567
 568   /* If the type is a class container, use the underlying derived type.  */
 569   if (derived->attr.is_class)
 570     derived = gfc_get_derived_super_type (derived);
 571
 572   if (ns)
 573     {
 574       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 575
 576       get_unique_hashed_string (tname, derived);
 577       sprintf (name, "__vtab_%s", tname);
 578
 579       /* Look for the vtab symbol in various namespaces.  */
 580       gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
 581       if (vtab == NULL)
 582         gfc_find_symbol (name, ns, 0, &vtab);
 583       if (vtab == NULL)
 584         gfc_find_symbol (name, derived->ns, 0, &vtab);
 585
 586       if (vtab == NULL)
 587         {
 588           gfc_get_symbol (name, ns, &vtab);
 589           vtab->ts.type = BT_DERIVED;
 590           if (gfc_add_flavor (&vtab->attr, FL_PARAMETER, NULL,
 591                               &gfc_current_locus) == FAILURE)
 592             goto cleanup;
 593           vtab->attr.target = 1;
 594           vtab->attr.save = SAVE_IMPLICIT;
 595           vtab->attr.vtab = 1;
 596           vtab->attr.access = ACCESS_PUBLIC;
 597           gfc_set_sym_referenced (vtab);
 598           sprintf (name, "__vtype_%s", tname);
 599
 600           gfc_find_symbol (name, ns, 0, &vtype);
 601           if (vtype == NULL)
 602             {
 603               gfc_component *c;
 604               gfc_symbol *parent = NULL, *parent_vtab = NULL;
 605
 606               gfc_get_symbol (name, ns, &vtype);
 607               if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
 608                                   NULL, &gfc_current_locus) == FAILURE)
 609                 goto cleanup;
 610               vtype->attr.access = ACCESS_PUBLIC;
 611               vtype->attr.vtype = 1;
 612               gfc_set_sym_referenced (vtype);
 613
 614               /* Add component '_hash'.  */
 615               if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
 616                 goto cleanup;
 617               c->ts.type = BT_INTEGER;
 618               c->ts.kind = 4;
 619               c->attr.access = ACCESS_PRIVATE;
 620               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 621                                                  NULL, derived->hash_value);
 622
 623               /* Add component '_size'.  */
 624               if (gfc_add_component (vtype, "_size", &c) == FAILURE)
 625                 goto cleanup;
 626               c->ts.type = BT_INTEGER;
 627               c->ts.kind = 4;
 628               c->attr.access = ACCESS_PRIVATE;
 629               /* Remember the derived type in ts.u.derived,
 630                  so that the correct initializer can be set later on
 631                  (in gfc_conv_structure).  */
 632               c->ts.u.derived = derived;
 633               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 634                                                  NULL, 0);
 635
 636               /* Add component _extends.  */
 637               if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
 638                 goto cleanup;
 639               c->attr.pointer = 1;
 640               c->attr.access = ACCESS_PRIVATE;
 641               parent = gfc_get_derived_super_type (derived);
 642               if (parent)
 643                 {
 644                   parent_vtab = gfc_find_derived_vtab (parent);
 645                   c->ts.type = BT_DERIVED;
 646                   c->ts.u.derived = parent_vtab->ts.u.derived;
 647                   c->initializer = gfc_get_expr ();
 648                   c->initializer->expr_type = EXPR_VARIABLE;
 649                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
 650                                      0, &c->initializer->symtree);
 651                 }
 652               else
 653                 {
 654                   c->ts.type = BT_DERIVED;
 655                   c->ts.u.derived = vtype;
 656                   c->initializer = gfc_get_null_expr (NULL);
 657                 }
 658
 659               if (derived->components == NULL && !derived->attr.zero_comp)
 660                 {
 661                   /* At this point an error must have occurred.
 662                      Prevent further errors on the vtype components.  */
 663                   found_sym = vtab;
 664                   goto have_vtype;
 665                 }
 666
 667               /* Add component _def_init.  */
 668               if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
 669                 goto cleanup;
 670               c->attr.pointer = 1;
 671               c->attr.access = ACCESS_PRIVATE;
 672               c->ts.type = BT_DERIVED;
 673               c->ts.u.derived = derived;
 674               if (derived->attr.abstract)
 675                 c->initializer = gfc_get_null_expr (NULL);
 676               else
 677                 {
 678                   /* Construct default initialization variable.  */
 679                   sprintf (name, "__def_init_%s", tname);
 680                   gfc_get_symbol (name, ns, &def_init);
 681                   def_init->attr.target = 1;
 682                   def_init->attr.save = SAVE_IMPLICIT;
 683                   def_init->attr.access = ACCESS_PUBLIC;
 684                   def_init->attr.flavor = FL_PARAMETER;
 685                   gfc_set_sym_referenced (def_init);
 686                   def_init->ts.type = BT_DERIVED;
 687                   def_init->ts.u.derived = derived;
 688                   def_init->value = gfc_default_initializer (&def_init->ts);
 689
 690                   c->initializer = gfc_lval_expr_from_sym (def_init);
 691                 }
 692
 693               /* Add component _copy.  */
 694               if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
 695                 goto cleanup;
 696               c->attr.proc_pointer = 1;
 697               c->attr.access = ACCESS_PRIVATE;
 698               c->tb = XCNEW (gfc_typebound_proc);
 699               c->tb->ppc = 1;
 700               if (derived->attr.abstract)
 701                 c->initializer = gfc_get_null_expr (NULL);
 702               else
 703                 {
 704                   /* Set up namespace.  */
 705                   gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
 706                   sub_ns->sibling = ns->contained;
 707                   ns->contained = sub_ns;
 708                   sub_ns->resolved = 1;
 709                   /* Set up procedure symbol.  */
 710                   sprintf (name, "__copy_%s", tname);
 711                   gfc_get_symbol (name, sub_ns, &copy);
 712                   sub_ns->proc_name = copy;
 713                   copy->attr.flavor = FL_PROCEDURE;
 714                   copy->attr.subroutine = 1;
 715                   copy->attr.if_source = IFSRC_DECL;
 716                   /* This is elemental so that arrays are automatically
 717                      treated correctly by the scalarizer.  */
 718                   copy->attr.elemental = 1;
 719                   if (ns->proc_name->attr.flavor == FL_MODULE)
 720                     copy->module = ns->proc_name->name;
 721                   gfc_set_sym_referenced (copy);
 722                   /* Set up formal arguments.  */
 723                   gfc_get_symbol ("src", sub_ns, &src);
 724                   src->ts.type = BT_DERIVED;
 725                   src->ts.u.derived = derived;
 726                   src->attr.flavor = FL_VARIABLE;
 727                   src->attr.dummy = 1;
 728                   src->attr.intent = INTENT_IN;
 729                   gfc_set_sym_referenced (src);
 730                   copy->formal = gfc_get_formal_arglist ();
 731                   copy->formal->sym = src;
 732                   gfc_get_symbol ("dst", sub_ns, &dst);
 733                   dst->ts.type = BT_DERIVED;
 734                   dst->ts.u.derived = derived;
 735                   dst->attr.flavor = FL_VARIABLE;
 736                   dst->attr.dummy = 1;
 737                   dst->attr.intent = INTENT_OUT;
 738                   gfc_set_sym_referenced (dst);
 739                   copy->formal->next = gfc_get_formal_arglist ();
 740                   copy->formal->next->sym = dst;
 741                   /* Set up code.  */
 742                   sub_ns->code = gfc_get_code ();
 743                   sub_ns->code->op = EXEC_INIT_ASSIGN;
 744                   sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
 745                   sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
 746                   /* Set initializer.  */
 747                   c->initializer = gfc_lval_expr_from_sym (copy);
 748                   c->ts.interface = copy;
 749                 }
 750
 751               /* Add procedure pointers for type-bound procedures.  */
 752               add_procs_to_declared_vtab (derived, vtype);
 753             }
 754
 755 have_vtype:
 756           vtab->ts.u.derived = vtype;
 757           vtab->value = gfc_default_initializer (&vtab->ts);
 758         }
 759     }
 760
 761   found_sym = vtab;
 762
 763 cleanup:
 764   /* It is unexpected to have some symbols added at resolution or code
 765      generation time. We commit the changes in order to keep a clean state.  */
 766   if (found_sym)
 767     {
 768       gfc_commit_symbol (vtab);
 769       if (vtype)
 770         gfc_commit_symbol (vtype);
 771       if (def_init)
 772         gfc_commit_symbol (def_init);
 773       if (copy)
 774         gfc_commit_symbol (copy);
 775       if (src)
 776         gfc_commit_symbol (src);
 777       if (dst)
 778         gfc_commit_symbol (dst);
 779     }
 780   else
 781     gfc_undo_symbols ();
 782
 783   return found_sym;
 784 }
 785
 786
 787 /* General worker function to find either a type-bound procedure or a
 788    type-bound user operator.  */
 789
 790 static gfc_symtree*
 791 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 792                          const char* name, bool noaccess, bool uop,
 793                          locus* where)
 794 {
 795   gfc_symtree* res;
 796   gfc_symtree* root;
 797
 798   /* Set correct symbol-root.  */
 799   gcc_assert (derived->f2k_derived);
 800   root = (uop ? derived->f2k_derived->tb_uop_root
 801               : derived->f2k_derived->tb_sym_root);
 802
 803   /* Set default to failure.  */
 804   if (t)
 805     *t = FAILURE;
 806
 807   /* Try to find it in the current type's namespace.  */
 808   res = gfc_find_symtree (root, name);
 809   if (res && res->n.tb && !res->n.tb->error)
 810     {
 811       /* We found one.  */
 812       if (t)
 813         *t = SUCCESS;
 814
 815       if (!noaccess && derived->attr.use_assoc
 816           && res->n.tb->access == ACCESS_PRIVATE)
 817         {
 818           if (where)
 819             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 820                        name, derived->name, where);
 821           if (t)
 822             *t = FAILURE;
 823         }
 824
 825       return res;
 826     }
 827
 828   /* Otherwise, recurse on parent type if derived is an extension.  */
 829   if (derived->attr.extension)
 830     {
 831       gfc_symbol* super_type;
 832       super_type = gfc_get_derived_super_type (derived);
 833       gcc_assert (super_type);
 834
 835       return find_typebound_proc_uop (super_type, t, name,
 836                                       noaccess, uop, where);
 837     }
 838
 839   /* Nothing found.  */
 840   return NULL;
 841 }
 842
 843
 844 /* Find a type-bound procedure or user operator by name for a derived-type
 845    (looking recursively through the super-types).  */
 846
 847 gfc_symtree*
 848 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 849                          const char* name, bool noaccess, locus* where)
 850 {
 851   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 852 }
 853
 854 gfc_symtree*
 855 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 856                             const char* name, bool noaccess, locus* where)
 857 {
 858   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 859 }
 860
 861
 862 /* Find a type-bound intrinsic operator looking recursively through the
 863    super-type hierarchy.  */
 864
 865 gfc_typebound_proc*
 866 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 867                                  gfc_intrinsic_op op, bool noaccess,
 868                                  locus* where)
 869 {
 870   gfc_typebound_proc* res;
 871
 872   /* Set default to failure.  */
 873   if (t)
 874     *t = FAILURE;
 875
 876   /* Try to find it in the current type's namespace.  */
 877   if (derived->f2k_derived)
 878     res = derived->f2k_derived->tb_op[op];
 879   else
 880     res = NULL;
 881
 882   /* Check access.  */
 883   if (res && !res->error)
 884     {
 885       /* We found one.  */
 886       if (t)
 887         *t = SUCCESS;
 888
 889       if (!noaccess && derived->attr.use_assoc
 890           && res->access == ACCESS_PRIVATE)
 891         {
 892           if (where)
 893             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 894                        gfc_op2string (op), derived->name, where);
 895           if (t)
 896             *t = FAILURE;
 897         }
 898
 899       return res;
 900     }
 901
 902   /* Otherwise, recurse on parent type if derived is an extension.  */
 903   if (derived->attr.extension)
 904     {
 905       gfc_symbol* super_type;
 906       super_type = gfc_get_derived_super_type (derived);
 907       gcc_assert (super_type);
 908
 909       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 910                                               noaccess, where);
 911     }
 912
 913   /* Nothing found.  */
 914   return NULL;
 915 }
 916
 917
 918 /* Get a typebound-procedure symtree or create and insert it if not yet
 919    present.  This is like a very simplified version of gfc_get_sym_tree for
 920    tbp-symtrees rather than regular ones.  */
 921
 922 gfc_symtree*
 923 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 924 {
 925   gfc_symtree *result;
 926
 927   result = gfc_find_symtree (*root, name);
 928   if (!result)
 929     {
 930       result = gfc_new_symtree (root, name);
 931       gcc_assert (result);
 932       result->n.tb = NULL;
 933     }
 934
 935   return result;
 936 }