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         derived = (*tail)->u.c.component->ts.u.derived;
  68       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
  69         break;
  70       tail = &((*tail)->next);
  71     }
  72   if (*tail != NULL && strcmp (name, "_data") == 0)
  73     next = *tail;
  74   (*tail) = gfc_get_ref();
  75   (*tail)->next = next;
  76   (*tail)->type = REF_COMPONENT;
  77   (*tail)->u.c.sym = derived;
  78   (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
  79   gcc_assert((*tail)->u.c.component);
  80   if (!next)
  81     e->ts = (*tail)->u.c.component->ts;
  82 }
  83
  84
  85 /* Build a NULL initializer for CLASS pointers,
  86    initializing the _data and _vptr components to zero.  */
  87
  88 gfc_expr *
  89 gfc_class_null_initializer (gfc_typespec *ts)
  90 {
  91   gfc_expr *init;
  92   gfc_component *comp;
  93
  94   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
  95                                              &ts->u.derived->declared_at);
  96   init->ts = *ts;
  97
  98   for (comp = ts->u.derived->components; comp; comp = comp->next)
  99     {
 100       gfc_constructor *ctor = gfc_constructor_get();
 101       ctor->expr = gfc_get_expr ();
 102       ctor->expr->expr_type = EXPR_NULL;
 103       ctor->expr->ts = comp->ts;
 104       gfc_constructor_append (&init->value.constructor, ctor);
 105     }
 106
 107   return init;
 108 }
 109
 110
 111 /* Create a unique string identifier for a derived type, composed of its name
 112    and module name. This is used to construct unique names for the class
 113    containers and vtab symbols.  */
 114
 115 static void
 116 get_unique_type_string (char *string, gfc_symbol *derived)
 117 {
 118   if (derived->module)
 119     sprintf (string, "%s_%s", derived->module, derived->name);
 120   else if (derived->ns->proc_name)
 121     sprintf (string, "%s_%s", derived->ns->proc_name->name, derived->name);
 122   else
 123     sprintf (string, "_%s", derived->name);
 124 }
 125
 126
 127 /* A relative of 'get_unique_type_string' which makes sure the generated
 128    string will not be too long (replacing it by a hash string if needed).  */
 129
 130 static void
 131 get_unique_hashed_string (char *string, gfc_symbol *derived)
 132 {
 133   char tmp[2*GFC_MAX_SYMBOL_LEN+2];
 134   get_unique_type_string (&tmp[0], derived);
 135   /* If string is too long, use hash value in hex representation
 136      (allow for extra decoration, cf. gfc_build_class_symbol)*/
 137   if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 10)
 138     {
 139       int h = gfc_hash_value (derived);
 140       sprintf (string, "%X", h);
 141     }
 142   else
 143     strcpy (string, tmp);
 144 }
 145
 146
 147 /* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
 148
 149 unsigned int
 150 gfc_hash_value (gfc_symbol *sym)
 151 {
 152   unsigned int hash = 0;
 153   char c[2*(GFC_MAX_SYMBOL_LEN+1)];
 154   int i, len;
 155
 156   get_unique_type_string (&c[0], sym);
 157   len = strlen (c);
 158
 159   for (i = 0; i < len; i++)
 160     hash = (hash << 6) + (hash << 16) - hash + c[i];
 161
 162   /* Return the hash but take the modulus for the sake of module read,
 163      even though this slightly increases the chance of collision.  */
 164   return (hash % 100000000);
 165 }
 166
 167
 168 /* Build a polymorphic CLASS entity, using the symbol that comes from
 169    build_sym. A CLASS entity is represented by an encapsulating type,
 170    which contains the declared type as '_data' component, plus a pointer
 171    component '_vptr' which determines the dynamic type.  */
 172
 173 gfc_try
 174 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 175                         gfc_array_spec **as, bool delayed_vtab)
 176 {
 177   char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 178   gfc_symbol *fclass;
 179   gfc_symbol *vtab;
 180   gfc_component *c;
 181
 182   /* Determine the name of the encapsulating type.  */
 183   get_unique_hashed_string (tname, ts->u.derived);
 184   if ((*as) && (*as)->rank && attr->allocatable)
 185     sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
 186   else if ((*as) && (*as)->rank)
 187     sprintf (name, "__class_%s_%d", tname, (*as)->rank);
 188   else if (attr->pointer)
 189     sprintf (name, "__class_%s_p", tname);
 190   else if (attr->allocatable)
 191     sprintf (name, "__class_%s_a", tname);
 192   else
 193     sprintf (name, "__class_%s", tname);
 194
 195   gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
 196   if (fclass == NULL)
 197     {
 198       gfc_symtree *st;
 199       /* If not there, create a new symbol.  */
 200       fclass = gfc_new_symbol (name, ts->u.derived->ns);
 201       st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
 202       st->n.sym = fclass;
 203       gfc_set_sym_referenced (fclass);
 204       fclass->refs++;
 205       fclass->ts.type = BT_UNKNOWN;
 206       fclass->attr.abstract = ts->u.derived->attr.abstract;
 207       if (ts->u.derived->f2k_derived)
 208         fclass->f2k_derived = gfc_get_namespace (NULL, 0);
 209       if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
 210           NULL, &gfc_current_locus) == FAILURE)
 211         return FAILURE;
 212
 213       /* Add component '_data'.  */
 214       if (gfc_add_component (fclass, "_data", &c) == FAILURE)
 215         return FAILURE;
 216       c->ts = *ts;
 217       c->ts.type = BT_DERIVED;
 218       c->attr.access = ACCESS_PRIVATE;
 219       c->ts.u.derived = ts->u.derived;
 220       c->attr.class_pointer = attr->pointer;
 221       c->attr.pointer = attr->pointer || attr->dummy;
 222       c->attr.allocatable = attr->allocatable;
 223       c->attr.dimension = attr->dimension;
 224       c->attr.codimension = attr->codimension;
 225       c->attr.abstract = ts->u.derived->attr.abstract;
 226       c->as = (*as);
 227       c->initializer = NULL;
 228
 229       /* Add component '_vptr'.  */
 230       if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
 231         return FAILURE;
 232       c->ts.type = BT_DERIVED;
 233       if (delayed_vtab)
 234         c->ts.u.derived = NULL;
 235       else
 236         {
 237           vtab = gfc_find_derived_vtab (ts->u.derived);
 238           gcc_assert (vtab);
 239           c->ts.u.derived = vtab->ts.u.derived;
 240         }
 241       c->attr.access = ACCESS_PRIVATE;
 242       c->attr.pointer = 1;
 243     }
 244
 245   /* Since the extension field is 8 bit wide, we can only have
 246      up to 255 extension levels.  */
 247   if (ts->u.derived->attr.extension == 255)
 248     {
 249       gfc_error ("Maximum extension level reached with type '%s' at %L",
 250                  ts->u.derived->name, &ts->u.derived->declared_at);
 251       return FAILURE;
 252     }
 253
 254   fclass->attr.extension = ts->u.derived->attr.extension + 1;
 255   fclass->attr.is_class = 1;
 256   ts->u.derived = fclass;
 257   attr->allocatable = attr->pointer = attr->dimension = 0;
 258   (*as) = NULL;  /* XXX */
 259   return SUCCESS;
 260 }
 261
 262
 263 /* Add a procedure pointer component to the vtype
 264    to represent a specific type-bound procedure.  */
 265
 266 static void
 267 add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
 268 {
 269   gfc_component *c;
 270   c = gfc_find_component (vtype, name, true, true);
 271
 272   if (c == NULL)
 273     {
 274       /* Add procedure component.  */
 275       if (gfc_add_component (vtype, name, &c) == FAILURE)
 276         return;
 277
 278       if (!c->tb)
 279         c->tb = XCNEW (gfc_typebound_proc);
 280       *c->tb = *tb;
 281       c->tb->ppc = 1;
 282       c->attr.procedure = 1;
 283       c->attr.proc_pointer = 1;
 284       c->attr.flavor = FL_PROCEDURE;
 285       c->attr.access = ACCESS_PRIVATE;
 286       c->attr.external = 1;
 287       c->attr.untyped = 1;
 288       c->attr.if_source = IFSRC_IFBODY;
 289     }
 290   else if (c->attr.proc_pointer && c->tb)
 291     {
 292       *c->tb = *tb;
 293       c->tb->ppc = 1;
 294     }
 295
 296   if (tb->u.specific)
 297     {
 298       c->ts.interface = tb->u.specific->n.sym;
 299       if (!tb->deferred)
 300         c->initializer = gfc_get_variable_expr (tb->u.specific);
 301     }
 302 }
 303
 304
 305 /* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
 306
 307 static void
 308 add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
 309 {
 310   if (!st)
 311     return;
 312
 313   if (st->left)
 314     add_procs_to_declared_vtab1 (st->left, vtype);
 315
 316   if (st->right)
 317     add_procs_to_declared_vtab1 (st->right, vtype);
 318
 319   if (st->n.tb && !st->n.tb->error
 320       && !st->n.tb->is_generic && st->n.tb->u.specific)
 321     add_proc_comp (vtype, st->name, st->n.tb);
 322 }
 323
 324
 325 /* Copy procedure pointers components from the parent type.  */
 326
 327 static void
 328 copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 329 {
 330   gfc_component *cmp;
 331   gfc_symbol *vtab;
 332
 333   vtab = gfc_find_derived_vtab (declared);
 334
 335   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
 336     {
 337       if (gfc_find_component (vtype, cmp->name, true, true))
 338         continue;
 339
 340       add_proc_comp (vtype, cmp->name, cmp->tb);
 341     }
 342 }
 343
 344
 345 /* Add procedure pointers for all type-bound procedures to a vtab.  */
 346
 347 static void
 348 add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 349 {
 350   gfc_symbol* super_type;
 351
 352   super_type = gfc_get_derived_super_type (derived);
 353
 354   if (super_type && (super_type != derived))
 355     {
 356       /* Make sure that the PPCs appear in the same order as in the parent.  */
 357       copy_vtab_proc_comps (super_type, vtype);
 358       /* Only needed to get the PPC initializers right.  */
 359       add_procs_to_declared_vtab (super_type, vtype);
 360     }
 361
 362   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
 363     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
 364
 365   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
 366     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
 367 }
 368
 369
 370 /* Find (or generate) the symbol for a derived type's vtab.  */
 371
 372 gfc_symbol *
 373 gfc_find_derived_vtab (gfc_symbol *derived)
 374 {
 375   gfc_namespace *ns;
 376   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
 377   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
 378
 379   /* Find the top-level namespace (MODULE or PROGRAM).  */
 380   for (ns = gfc_current_ns; ns; ns = ns->parent)
 381     if (!ns->parent)
 382       break;
 383
 384   /* If the type is a class container, use the underlying derived type.  */
 385   if (derived->attr.is_class)
 386     derived = gfc_get_derived_super_type (derived);
 387
 388   if (ns)
 389     {
 390       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
 391
 392       get_unique_hashed_string (tname, derived);
 393       sprintf (name, "__vtab_%s", tname);
 394
 395       /* Look for the vtab symbol in various namespaces.  */
 396       gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
 397       if (vtab == NULL)
 398         gfc_find_symbol (name, ns, 0, &vtab);
 399       if (vtab == NULL)
 400         gfc_find_symbol (name, derived->ns, 0, &vtab);
 401
 402       if (vtab == NULL)
 403         {
 404           gfc_get_symbol (name, ns, &vtab);
 405           vtab->ts.type = BT_DERIVED;
 406           if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
 407                               &gfc_current_locus) == FAILURE)
 408             goto cleanup;
 409           vtab->attr.target = 1;
 410           vtab->attr.save = SAVE_EXPLICIT;
 411           vtab->attr.vtab = 1;
 412           vtab->attr.access = ACCESS_PUBLIC;
 413           gfc_set_sym_referenced (vtab);
 414           sprintf (name, "__vtype_%s", tname);
 415
 416           gfc_find_symbol (name, ns, 0, &vtype);
 417           if (vtype == NULL)
 418             {
 419               gfc_component *c;
 420               gfc_symbol *parent = NULL, *parent_vtab = NULL;
 421
 422               gfc_get_symbol (name, ns, &vtype);
 423               if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
 424                                   NULL, &gfc_current_locus) == FAILURE)
 425                 goto cleanup;
 426               vtype->attr.access = ACCESS_PUBLIC;
 427               vtype->attr.vtype = 1;
 428               gfc_set_sym_referenced (vtype);
 429
 430               /* Add component '_hash'.  */
 431               if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
 432                 goto cleanup;
 433               c->ts.type = BT_INTEGER;
 434               c->ts.kind = 4;
 435               c->attr.access = ACCESS_PRIVATE;
 436               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 437                                                  NULL, derived->hash_value);
 438
 439               /* Add component '_size'.  */
 440               if (gfc_add_component (vtype, "_size", &c) == FAILURE)
 441                 goto cleanup;
 442               c->ts.type = BT_INTEGER;
 443               c->ts.kind = 4;
 444               c->attr.access = ACCESS_PRIVATE;
 445               /* Remember the derived type in ts.u.derived,
 446                  so that the correct initializer can be set later on
 447                  (in gfc_conv_structure).  */
 448               c->ts.u.derived = derived;
 449               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 450                                                  NULL, 0);
 451
 452               /* Add component _extends.  */
 453               if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
 454                 goto cleanup;
 455               c->attr.pointer = 1;
 456               c->attr.access = ACCESS_PRIVATE;
 457               parent = gfc_get_derived_super_type (derived);
 458               if (parent)
 459                 {
 460                   parent_vtab = gfc_find_derived_vtab (parent);
 461                   c->ts.type = BT_DERIVED;
 462                   c->ts.u.derived = parent_vtab->ts.u.derived;
 463                   c->initializer = gfc_get_expr ();
 464                   c->initializer->expr_type = EXPR_VARIABLE;
 465                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
 466                                      0, &c->initializer->symtree);
 467                 }
 468               else
 469                 {
 470                   c->ts.type = BT_DERIVED;
 471                   c->ts.u.derived = vtype;
 472                   c->initializer = gfc_get_null_expr (NULL);
 473                 }
 474
 475               if (derived->components == NULL && !derived->attr.zero_comp)
 476                 {
 477                   /* At this point an error must have occurred.
 478                      Prevent further errors on the vtype components.  */
 479                   found_sym = vtab;
 480                   goto have_vtype;
 481                 }
 482
 483               /* Add component _def_init.  */
 484               if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
 485                 goto cleanup;
 486               c->attr.pointer = 1;
 487               c->attr.access = ACCESS_PRIVATE;
 488               c->ts.type = BT_DERIVED;
 489               c->ts.u.derived = derived;
 490               if (derived->attr.abstract)
 491                 c->initializer = gfc_get_null_expr (NULL);
 492               else
 493                 {
 494                   /* Construct default initialization variable.  */
 495                   sprintf (name, "__def_init_%s", tname);
 496                   gfc_get_symbol (name, ns, &def_init);
 497                   def_init->attr.target = 1;
 498                   def_init->attr.save = SAVE_EXPLICIT;
 499                   def_init->attr.access = ACCESS_PUBLIC;
 500                   def_init->attr.flavor = FL_VARIABLE;
 501                   gfc_set_sym_referenced (def_init);
 502                   def_init->ts.type = BT_DERIVED;
 503                   def_init->ts.u.derived = derived;
 504                   def_init->value = gfc_default_initializer (&def_init->ts);
 505
 506                   c->initializer = gfc_lval_expr_from_sym (def_init);
 507                 }
 508
 509               /* Add component _copy.  */
 510               if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
 511                 goto cleanup;
 512               c->attr.proc_pointer = 1;
 513               c->attr.access = ACCESS_PRIVATE;
 514               c->tb = XCNEW (gfc_typebound_proc);
 515               c->tb->ppc = 1;
 516               if (derived->attr.abstract)
 517                 c->initializer = gfc_get_null_expr (NULL);
 518               else
 519                 {
 520                   /* Set up namespace.  */
 521                   gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
 522                   sub_ns->sibling = ns->contained;
 523                   ns->contained = sub_ns;
 524                   sub_ns->resolved = 1;
 525                   /* Set up procedure symbol.  */
 526                   sprintf (name, "__copy_%s", tname);
 527                   gfc_get_symbol (name, sub_ns, &copy);
 528                   sub_ns->proc_name = copy;
 529                   copy->attr.flavor = FL_PROCEDURE;
 530                   copy->attr.if_source = IFSRC_DECL;
 531                   gfc_set_sym_referenced (copy);
 532                   /* Set up formal arguments.  */
 533                   gfc_get_symbol ("src", sub_ns, &src);
 534                   src->ts.type = BT_DERIVED;
 535                   src->ts.u.derived = derived;
 536                   src->attr.flavor = FL_VARIABLE;
 537                   src->attr.dummy = 1;
 538                   gfc_set_sym_referenced (src);
 539                   copy->formal = gfc_get_formal_arglist ();
 540                   copy->formal->sym = src;
 541                   gfc_get_symbol ("dst", sub_ns, &dst);
 542                   dst->ts.type = BT_DERIVED;
 543                   dst->ts.u.derived = derived;
 544                   dst->attr.flavor = FL_VARIABLE;
 545                   dst->attr.dummy = 1;
 546                   gfc_set_sym_referenced (dst);
 547                   copy->formal->next = gfc_get_formal_arglist ();
 548                   copy->formal->next->sym = dst;
 549                   /* Set up code.  */
 550                   sub_ns->code = gfc_get_code ();
 551                   sub_ns->code->op = EXEC_ASSIGN;
 552                   sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
 553                   sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
 554                   /* Set initializer.  */
 555                   c->initializer = gfc_lval_expr_from_sym (copy);
 556                   c->ts.interface = copy;
 557                 }
 558
 559               /* Add procedure pointers for type-bound procedures.  */
 560               add_procs_to_declared_vtab (derived, vtype);
 561             }
 562
 563 have_vtype:
 564           vtab->ts.u.derived = vtype;
 565           vtab->value = gfc_default_initializer (&vtab->ts);
 566         }
 567     }
 568
 569   found_sym = vtab;
 570
 571 cleanup:
 572   /* It is unexpected to have some symbols added at resolution or code
 573      generation time. We commit the changes in order to keep a clean state.  */
 574   if (found_sym)
 575     {
 576       gfc_commit_symbol (vtab);
 577       if (vtype)
 578         gfc_commit_symbol (vtype);
 579       if (def_init)
 580         gfc_commit_symbol (def_init);
 581       if (copy)
 582         gfc_commit_symbol (copy);
 583       if (src)
 584         gfc_commit_symbol (src);
 585       if (dst)
 586         gfc_commit_symbol (dst);
 587     }
 588   else
 589     gfc_undo_symbols ();
 590
 591   return found_sym;
 592 }
 593
 594
 595 /* General worker function to find either a type-bound procedure or a
 596    type-bound user operator.  */
 597
 598 static gfc_symtree*
 599 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
 600                          const char* name, bool noaccess, bool uop,
 601                          locus* where)
 602 {
 603   gfc_symtree* res;
 604   gfc_symtree* root;
 605
 606   /* Set correct symbol-root.  */
 607   gcc_assert (derived->f2k_derived);
 608   root = (uop ? derived->f2k_derived->tb_uop_root
 609               : derived->f2k_derived->tb_sym_root);
 610
 611   /* Set default to failure.  */
 612   if (t)
 613     *t = FAILURE;
 614
 615   /* Try to find it in the current type's namespace.  */
 616   res = gfc_find_symtree (root, name);
 617   if (res && res->n.tb && !res->n.tb->error)
 618     {
 619       /* We found one.  */
 620       if (t)
 621         *t = SUCCESS;
 622
 623       if (!noaccess && derived->attr.use_assoc
 624           && res->n.tb->access == ACCESS_PRIVATE)
 625         {
 626           if (where)
 627             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 628                        name, derived->name, where);
 629           if (t)
 630             *t = FAILURE;
 631         }
 632
 633       return res;
 634     }
 635
 636   /* Otherwise, recurse on parent type if derived is an extension.  */
 637   if (derived->attr.extension)
 638     {
 639       gfc_symbol* super_type;
 640       super_type = gfc_get_derived_super_type (derived);
 641       gcc_assert (super_type);
 642
 643       return find_typebound_proc_uop (super_type, t, name,
 644                                       noaccess, uop, where);
 645     }
 646
 647   /* Nothing found.  */
 648   return NULL;
 649 }
 650
 651
 652 /* Find a type-bound procedure or user operator by name for a derived-type
 653    (looking recursively through the super-types).  */
 654
 655 gfc_symtree*
 656 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
 657                          const char* name, bool noaccess, locus* where)
 658 {
 659   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
 660 }
 661
 662 gfc_symtree*
 663 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
 664                             const char* name, bool noaccess, locus* where)
 665 {
 666   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
 667 }
 668
 669
 670 /* Find a type-bound intrinsic operator looking recursively through the
 671    super-type hierarchy.  */
 672
 673 gfc_typebound_proc*
 674 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
 675                                  gfc_intrinsic_op op, bool noaccess,
 676                                  locus* where)
 677 {
 678   gfc_typebound_proc* res;
 679
 680   /* Set default to failure.  */
 681   if (t)
 682     *t = FAILURE;
 683
 684   /* Try to find it in the current type's namespace.  */
 685   if (derived->f2k_derived)
 686     res = derived->f2k_derived->tb_op[op];
 687   else
 688     res = NULL;
 689
 690   /* Check access.  */
 691   if (res && !res->error)
 692     {
 693       /* We found one.  */
 694       if (t)
 695         *t = SUCCESS;
 696
 697       if (!noaccess && derived->attr.use_assoc
 698           && res->access == ACCESS_PRIVATE)
 699         {
 700           if (where)
 701             gfc_error ("'%s' of '%s' is PRIVATE at %L",
 702                        gfc_op2string (op), derived->name, where);
 703           if (t)
 704             *t = FAILURE;
 705         }
 706
 707       return res;
 708     }
 709
 710   /* Otherwise, recurse on parent type if derived is an extension.  */
 711   if (derived->attr.extension)
 712     {
 713       gfc_symbol* super_type;
 714       super_type = gfc_get_derived_super_type (derived);
 715       gcc_assert (super_type);
 716
 717       return gfc_find_typebound_intrinsic_op (super_type, t, op,
 718                                               noaccess, where);
 719     }
 720
 721   /* Nothing found.  */
 722   return NULL;
 723 }
 724
 725
 726 /* Get a typebound-procedure symtree or create and insert it if not yet
 727    present.  This is like a very simplified version of gfc_get_sym_tree for
 728    tbp-symtrees rather than regular ones.  */
 729
 730 gfc_symtree*
 731 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
 732 {
 733   gfc_symtree *result;
 734
 735   result = gfc_find_symtree (*root, name);
 736   if (!result)
 737     {
 738       result = gfc_new_symtree (root, name);
 739       gcc_assert (result);
 740       result->n.tb = NULL;
 741     }
 742
 743   return result;
 744 }