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