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, false);
 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 static void
 203 add_proc_component (gfc_component *c, gfc_symbol *vtype,
 204                     gfc_symtree *st, gfc_symbol *specific,
 205                     bool is_generic, bool is_generic_specific)
 206 {
 207   /* Add procedure component.  */
 208   if (is_generic)
 209     {
 210       if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
 211         return;
 212       c->ts.interface = specific;
 213     }
 214   else if (c && is_generic_specific)
 215     {
 216       c->ts.interface = st->n.tb->u.specific->n.sym;
 217     }
 218   else
 219     {
 220       c = gfc_find_component (vtype, st->name, true, true);
 221       if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
 222         return;
 223       c->ts.interface = st->n.tb->u.specific->n.sym;
 224     }
 225
 226   if (!c->tb)
 227     c->tb = XCNEW (gfc_typebound_proc);
 228   *c->tb = *st->n.tb;
 229   c->tb->ppc = 1;
 230   c->attr.procedure = 1;
 231   c->attr.proc_pointer = 1;
 232   c->attr.flavor = FL_PROCEDURE;
 233   c->attr.access = ACCESS_PRIVATE;
 234   c->attr.external = 1;
 235   c->attr.untyped = 1;
 236   c->attr.if_source = IFSRC_IFBODY;
 237
 238   /* A static initializer cannot be used here because the specific
 239      function is not a constant; internal compiler error: in
 240      output_constant, at varasm.c:4623  */
 241   c->initializer = NULL;
 242 }
 243
 244
 245 static void
 246 add_proc_comps (gfc_component *c, gfc_symbol *vtype,
 247                 gfc_symtree *st, bool is_generic)
 248 {
 249   if (c == NULL && !is_generic)
 250     {
 251       add_proc_component (c, vtype, st, NULL, false, false);
 252     }
 253   else if (is_generic && st->n.tb && vtype->components == NULL)
 254     {
 255       gfc_tbp_generic* g;
 256       gfc_symbol * specific;
 257       for (g = st->n.tb->u.generic; g; g = g->next)
 258         {
 259           if (!g->specific)
 260             continue;
 261           specific = g->specific->u.specific->n.sym;
 262           add_proc_component (NULL, vtype, st, specific, true, false);
 263         }
 264     }
 265   else if (c->attr.proc_pointer && c->tb)
 266     {
 267       *c->tb = *st->n.tb;
 268       c->tb->ppc = 1;
 269       c->ts.interface = st->n.tb->u.specific->n.sym;
 270     }
 271 }
 272
 273 static void
 274 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
 275                              bool resolved)
 276 {
 277   gfc_component *c;
 278   gfc_symbol *generic;
 279   char name[3 * GFC_MAX_SYMBOL_LEN + 10];
 280
 281   if (!st)
 282     return;
 283
 284   if (st->left)
 285     add_procs_to_declared_vtab1 (st->left, vtype, resolved);
 286
 287   if (st->right)
 288     add_procs_to_declared_vtab1 (st->right, vtype, resolved);
 289
 290   if (!st->n.tb)
 291     return;
 292
 293   if (!st->n.tb->is_generic && st->n.tb->u.specific)
 294     {
 295       c = gfc_find_component (vtype, st->name, true, true);
 296       add_proc_comps (c, vtype, st, false);
 297     }
 298   else if (st->n.tb->is_generic)
 299     {
 300       c = gfc_find_component (vtype, st->name, true, true);
 301
 302       if (c == NULL)
 303         {
 304           /* Add derived type component with generic name.  */
 305           if (gfc_add_component (vtype, st->name, &c) == FAILURE)
 306             return;
 307           c->ts.type = BT_DERIVED;
 308           c->attr.flavor = FL_VARIABLE;
 309           c->attr.pointer = 1;
 310
 311           /* Add a special empty derived type as a placeholder.  */
 312           sprintf (name, "$empty");
 313           gfc_find_symbol (name, vtype->ns, 0, &generic);
 314           if (generic == NULL)
 315             {
 316               gfc_get_symbol (name, vtype->ns, &generic);
 317               generic->attr.flavor = FL_DERIVED;
 318               generic->refs++;
 319               gfc_set_sym_referenced (generic);
 320               generic->ts.type = BT_UNKNOWN;
 321               generic->attr.zero_comp = 1;
 322             }
 323
 324           c->ts.u.derived = generic;
 325         }
 326     }
 327 }
 328
 329
 330 static void
 331 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
 332                       bool resolved)
 333 {
 334   gfc_component *c, *cmp;
 335   gfc_symbol *vtab;
 336
 337   vtab = gfc_find_derived_vtab (declared, resolved);
 338
 339   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 340     {
 341       if (gfc_find_component (vtype, cmp->name, true, true))
 342         continue;
 343
 344       if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
 345         return;
 346
 347       if (cmp->ts.type == BT_DERIVED)
 348         {
 349           c->ts = cmp->ts;
 350           c->ts.u.derived = cmp->ts.u.derived;
 351           c->attr.flavor = FL_VARIABLE;
 352           c->attr.pointer = 1;
 353           c->initializer = NULL;
 354           continue;
 355         }
 356
 357       c->tb = XCNEW (gfc_typebound_proc);
 358       *c->tb = *cmp->tb;
 359       c->attr.procedure = 1;
 360       c->attr.proc_pointer = 1;
 361       c->attr.flavor = FL_PROCEDURE;
 362       c->attr.access = ACCESS_PRIVATE;
 363       c->attr.external = 1;
 364       c->ts.interface = cmp->ts.interface;
 365       c->attr.untyped = 1;
 366       c->attr.if_source = IFSRC_IFBODY;
 367       c->initializer = NULL;
 368     }
 369 }
 370
 371 static void
 372 add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
 373                             gfc_symbol *derived, bool resolved)
 374 {
 375   gfc_symbol* super_type;
 376
 377   super_type = gfc_get_derived_super_type (declared);
 378
 379   if (super_type && (super_type != declared))
 380     add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
 381
 382   if (declared != derived)
 383     copy_vtab_proc_comps (declared, vtype, resolved);
 384
 385   if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
 386     add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
 387                                  vtype, resolved);
 388
 389   if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
 390     add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
 391                                  vtype, resolved);
 392 }
 393
 394
 395 static
 396 void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
 397                             const char *name)
 398 {
 399   gfc_tbp_generic* g;
 400   gfc_symbol * specific1;
 401   gfc_symbol * specific2;
 402   gfc_symtree *st = NULL;
 403   gfc_component *c;
 404
 405   /* Find the generic procedure using the component name.  */
 406   st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
 407   if (st == NULL)
 408     st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
 409
 410   if (st == NULL)
 411     return;
 412
 413   /* Add procedure pointer components for the specific procedures. */
 414   for (g = st->n.tb->u.generic; g; g = g->next)
 415     {
 416       if (!g->specific)
 417         continue;
 418       specific1 = g->specific_st->n.tb->u.specific->n.sym;
 419
 420       c = vtab->ts.u.derived->components;
 421       specific2 = NULL;
 422
 423       /* Override identical specific interface.  */
 424       if (vtab->ts.u.derived->components)
 425         {
 426           for (; c; c= c->next)
 427             {
 428               specific2 = c->ts.interface;
 429               if (gfc_compare_interfaces (specific2, specific1,
 430                                           specific1->name, 0, 0, NULL, 0))
 431                 break;
 432             }
 433         }
 434
 435       add_proc_component (c, vtab->ts.u.derived, g->specific_st,
 436                           NULL, false, true);
 437       vtab->ts.u.derived->attr.zero_comp = 0;
 438     }
 439 }
 440
 441
 442 static void
 443 add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
 444                                gfc_symbol *derived, bool resolved)
 445 {
 446   gfc_component *cmp;
 447   gfc_symtree *st = NULL;
 448   gfc_symbol * vtab;
 449   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
 450   gfc_symbol* super_type;
 451
 452   gcc_assert (resolved);
 453
 454   for (cmp = vtype->components; cmp; cmp = cmp->next)
 455     {
 456       if (cmp->ts.type != BT_DERIVED)
 457         continue;
 458
 459       /* The only derived type that does not represent a generic
 460          procedure is the pointer to the parent vtab.  */
 461       if (cmp->ts.u.derived
 462             && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
 463         continue;
 464
 465       /* Find the generic procedure using the component name.  */
 466       st = gfc_find_typebound_proc (declared, NULL, cmp->name,
 467                                     true, NULL);
 468       if (st == NULL)
 469         st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
 470                                          true, NULL);
 471
 472       /* Should be an error but we pass on it for now.  */
 473       if (st == NULL || !st->n.tb->is_generic)
 474         continue;
 475
 476       vtab = NULL;
 477
 478       /* Build a vtab and a special vtype, with only the procedure
 479          pointer fields, to carry the pointers to the specific
 480          procedures.  Should this name ever be changed, the same
 481          should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
 482       sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
 483       gfc_find_symbol (name, derived->ns, 0, &vtab);
 484       if (vtab == NULL)
 485         {
 486           gfc_get_symbol (name, derived->ns, &vtab);
 487           vtab->ts.type = BT_DERIVED;
 488           vtab->attr.flavor = FL_VARIABLE;
 489           vtab->attr.target = 1;
 490           vtab->attr.save = SAVE_EXPLICIT;
 491           vtab->attr.vtab = 1;
 492           vtab->refs++;
 493           gfc_set_sym_referenced (vtab);
 494           sprintf (name, "%s$%s", vtype->name, cmp->name);
 495
 496           gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
 497           if (cmp->ts.u.derived == NULL
 498                 || (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
 499             {
 500               gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
 501               if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
 502                                   NULL, &gfc_current_locus) == FAILURE)
 503                 return;
 504               cmp->ts.u.derived->refs++;
 505               gfc_set_sym_referenced (cmp->ts.u.derived);
 506               cmp->ts.u.derived->attr.vtype = 1;
 507               cmp->ts.u.derived->attr.zero_comp = 1;
 508             }
 509           vtab->ts.u.derived = cmp->ts.u.derived;
 510         }
 511
 512       /* Store this for later use in setting the pointer.  */
 513       cmp->ts.interface = vtab;
 514
 515       if (vtab->ts.u.derived->components)
 516         continue;
 517
 518       super_type = gfc_get_derived_super_type (declared);
 519
 520       if (super_type && (super_type != declared))
 521         add_generic_specifics (super_type, vtab, cmp->name);
 522
 523       add_generic_specifics (declared, vtab, cmp->name);
 524     }
 525 }
 526
 527
 528 /* Find the symbol for a derived type's vtab.  A vtab has the following
 529    fields:
 530    $hash        a hash value used to identify the derived type
 531    $size        the size in bytes of the derived type
 532    $extends     a pointer to the vtable of the parent derived type
 533    then:
 534    procedure pointer components for the specific typebound procedures
 535    structure pointers to reduced vtabs that contain procedure
 536    pointers to the specific procedures.  */
 537
 538 gfc_symbol *
 539 gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
 540 {
 541   gfc_namespace *ns;
 542   gfc_symbol *vtab = NULL, *vtype = NULL;
 543   char name[2 * GFC_MAX_SYMBOL_LEN + 8];
 544
 545   ns = gfc_current_ns;
 546
 547   for (; ns; ns = ns->parent)
 548     if (!ns->parent)
 549       break;
 550
 551   if (ns)
 552     {
 553       sprintf (name, "vtab$%s", derived->name);
 554       gfc_find_symbol (name, ns, 0, &vtab);
 555
 556       if (vtab == NULL)
 557         {
 558           gfc_get_symbol (name, ns, &vtab);
 559           vtab->ts.type = BT_DERIVED;
 560           vtab->attr.flavor = FL_VARIABLE;
 561           vtab->attr.target = 1;
 562           vtab->attr.save = SAVE_EXPLICIT;
 563           vtab->attr.vtab = 1;
 564           vtab->refs++;
 565           gfc_set_sym_referenced (vtab);
 566           sprintf (name, "vtype$%s", derived->name);
 567
 568           gfc_find_symbol (name, ns, 0, &vtype);
 569           if (vtype == NULL)
 570             {
 571               gfc_component *c;
 572               gfc_symbol *parent = NULL, *parent_vtab = NULL;
 573
 574               gfc_get_symbol (name, ns, &vtype);
 575               if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
 576                                   NULL, &gfc_current_locus) == FAILURE)
 577                 return NULL;
 578               vtype->refs++;
 579               gfc_set_sym_referenced (vtype);
 580
 581               /* Add component '$hash'.  */
 582               if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
 583                 return NULL;
 584               c->ts.type = BT_INTEGER;
 585               c->ts.kind = 4;
 586               c->attr.access = ACCESS_PRIVATE;
 587               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 588                                                  NULL, derived->hash_value);
 589
 590               /* Add component '$size'.  */
 591               if (gfc_add_component (vtype, "$size", &c) == FAILURE)
 592                 return NULL;
 593               c->ts.type = BT_INTEGER;
 594               c->ts.kind = 4;
 595               c->attr.access = ACCESS_PRIVATE;
 596               /* Remember the derived type in ts.u.derived,
 597                  so that the correct initializer can be set later on
 598                  (in gfc_conv_structure).  */
 599               c->ts.u.derived = derived;
 600               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 601                                                  NULL, 0);
 602
 603               /* Add component $extends.  */
 604               if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
 605                 return NULL;
 606               c->attr.pointer = 1;
 607               c->attr.access = ACCESS_PRIVATE;
 608               parent = gfc_get_derived_super_type (derived);
 609               if (parent)
 610                 {
 611                   parent_vtab = gfc_find_derived_vtab (parent, resolved);
 612                   c->ts.type = BT_DERIVED;
 613                   c->ts.u.derived = parent_vtab->ts.u.derived;
 614                   c->initializer = gfc_get_expr ();
 615                   c->initializer->expr_type = EXPR_VARIABLE;
 616                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
 617                                      0, &c->initializer->symtree);
 618                 }
 619               else
 620                 {
 621                   c->ts.type = BT_DERIVED;
 622                   c->ts.u.derived = vtype;
 623                   c->initializer = gfc_get_null_expr (NULL);
 624                 }
 625
 626               add_procs_to_declared_vtab (derived, vtype, derived, resolved);
 627               vtype->attr.vtype = 1;
 628             }
 629
 630           vtab->ts.u.derived = vtype;
 631           vtab->value = gfc_default_initializer (&vtab->ts);
 632         }
 633     }
 634
 635   /* Catch the call just before the backend declarations are built, so that
 636      the generic procedures have been resolved and the specific procedures
 637      have formal interfaces that can be compared.  */
 638   if (resolved
 639         && vtab->ts.u.derived
 640         && vtab->ts.u.derived->backend_decl == NULL)
 641     add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
 642                                    derived, resolved);
 643
 644   return vtab;
 645 }
 646
 647
 648 /* General worker function to find either a type-bound procedure or a
 649    type-bound user operator.  */
 650
 651 static gfc_symtree*
 652 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 653                          const char* name, bool noaccess, bool uop,
 654                          locus* where)
 655 {
 656   gfc_symtree* res;
 657   gfc_symtree* root;
 658
 659   /* Set correct symbol-root.  */
 660   gcc_assert (derived->f2k_derived);
 661   root = (uop ? derived->f2k_derived->tb_uop_root
 662               : derived->f2k_derived->tb_sym_root);
 663
 664   /* Set default to failure.  */
 665   if (t)
 666     *t = FAILURE;
 667
 668   /* Try to find it in the current type's namespace.  */
 669   res = gfc_find_symtree (root, name);
 670   if (res && res->n.tb && !res->n.tb->error)
 671     {
 672       /* We found one.  */
 673       if (t)
 674         *t = SUCCESS;
 675
 676       if (!noaccess && derived->attr.use_assoc
 677           && res->n.tb->access == ACCESS_PRIVATE)
 678         {
 679           if (where)
 680             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 681                        name, derived->name, where);
 682           if (t)
 683             *t = FAILURE;
 684         }
 685
 686       return res;
 687     }
 688
 689   /* Otherwise, recurse on parent type if derived is an extension.  */
 690   if (derived->attr.extension)
 691     {
 692       gfc_symbol* super_type;
 693       super_type = gfc_get_derived_super_type (derived);
 694       gcc_assert (super_type);
 695
 696       return find_typebound_proc_uop (super_type, t, name,
 697                                       noaccess, uop, where);
 698     }
 699
 700   /* Nothing found.  */
 701   return NULL;
 702 }
 703
 704
 705 /* Find a type-bound procedure or user operator by name for a derived-type
 706    (looking recursively through the super-types).  */
 707
 708 gfc_symtree*
 709 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 710                          const char* name, bool noaccess, locus* where)
 711 {
 712   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 713 }
 714
 715 gfc_symtree*
 716 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 717                             const char* name, bool noaccess, locus* where)
 718 {
 719   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 720 }
 721
 722
 723 /* Find a type-bound intrinsic operator looking recursively through the
 724    super-type hierarchy.  */
 725
 726 gfc_typebound_proc*
 727 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 728                                  gfc_intrinsic_op op, bool noaccess,
 729                                  locus* where)
 730 {
 731   gfc_typebound_proc* res;
 732
 733   /* Set default to failure.  */
 734   if (t)
 735     *t = FAILURE;
 736
 737   /* Try to find it in the current type's namespace.  */
 738   if (derived->f2k_derived)
 739     res = derived->f2k_derived->tb_op[op];
 740   else
 741     res = NULL;
 742
 743   /* Check access.  */
 744   if (res && !res->error)
 745     {
 746       /* We found one.  */
 747       if (t)
 748         *t = SUCCESS;
 749
 750       if (!noaccess && derived->attr.use_assoc
 751           && res->access == ACCESS_PRIVATE)
 752         {
 753           if (where)
 754             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 755                        gfc_op2string (op), derived->name, where);
 756           if (t)
 757             *t = FAILURE;
 758         }
 759
 760       return res;
 761     }
 762
 763   /* Otherwise, recurse on parent type if derived is an extension.  */
 764   if (derived->attr.extension)
 765     {
 766       gfc_symbol* super_type;
 767       super_type = gfc_get_derived_super_type (derived);
 768       gcc_assert (super_type);
 769
 770       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 771                                               noaccess, where);
 772     }
 773
 774   /* Nothing found.  */
 775   return NULL;
 776 }
 777
 778
 779 /* Get a typebound-procedure symtree or create and insert it if not yet
 780    present.  This is like a very simplified version of gfc_get_sym_tree for
 781    tbp-symtrees rather than regular ones.  */
 782
 783 gfc_symtree*
 784 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 785 {
 786   gfc_symtree *result;
 787
 788   result = gfc_find_symtree (*root, name);
 789   if (!result)
 790     {
 791       result = gfc_new_symtree (root, name);
 792       gcc_assert (result);
 793       result->n.tb = NULL;
 794     }
 795
 796   return result;
 797 }