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