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