LCOV - code coverage report
Current view: top level - gcc/fortran - class.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 1630 1669 97.7 %
Date: 2020-03-28 11:57:23 Functions: 35 36 97.2 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Implementation of Fortran 2003 Polymorphism.
       2                 :            :    Copyright (C) 2009-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
       4                 :            :    and Janus Weil <janus@gcc.gnu.org>
       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                 :            :     Only for unlimited polymorphic classes:
      38                 :            :     * _len:  An integer(C_SIZE_T) to store the string length when the unlimited
      39                 :            :              polymorphic pointer is used to point to a char array.  The '_len'
      40                 :            :              component will be zero when no character array is stored in
      41                 :            :              '_data'.
      42                 :            : 
      43                 :            :    For each derived type we set up a "vtable" entry, i.e. a structure with the
      44                 :            :    following fields:
      45                 :            :     * _hash:     A hash value serving as a unique identifier for this type.
      46                 :            :     * _size:     The size in bytes of the derived type.
      47                 :            :     * _extends:  A pointer to the vtable entry of the parent derived type.
      48                 :            :     * _def_init: A pointer to a default initialized variable of this type.
      49                 :            :     * _copy:     A procedure pointer to a copying procedure.
      50                 :            :     * _final:    A procedure pointer to a wrapper function, which frees
      51                 :            :                  allocatable components and calls FINAL subroutines.
      52                 :            : 
      53                 :            :    After these follow procedure pointer components for the specific
      54                 :            :    type-bound procedures.  */
      55                 :            : 
      56                 :            : 
      57                 :            : #include "config.h"
      58                 :            : #include "system.h"
      59                 :            : #include "coretypes.h"
      60                 :            : #include "gfortran.h"
      61                 :            : #include "constructor.h"
      62                 :            : #include "target-memory.h"
      63                 :            : 
      64                 :            : /* Inserts a derived type component reference in a data reference chain.
      65                 :            :     TS: base type of the ref chain so far, in which we will pick the component
      66                 :            :     REF: the address of the GFC_REF pointer to update
      67                 :            :     NAME: name of the component to insert
      68                 :            :    Note that component insertion makes sense only if we are at the end of
      69                 :            :    the chain (*REF == NULL) or if we are adding a missing "_data" component
      70                 :            :    to access the actual contents of a class object.  */
      71                 :            : 
      72                 :            : static void
      73                 :       4718 : insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
      74                 :            : {
      75                 :       4718 :   gfc_ref *new_ref;
      76                 :       4718 :   int wcnt, ecnt;
      77                 :            : 
      78                 :       4718 :   gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
      79                 :            : 
      80                 :       4718 :   gfc_find_component (ts->u.derived, name, true, true, &new_ref);
      81                 :            : 
      82                 :       4718 :   gfc_get_errors (&wcnt, &ecnt);
      83                 :       4718 :   if (ecnt > 0 && !new_ref)
      84                 :          1 :     return;
      85                 :       4717 :   gcc_assert (new_ref->u.c.component);
      86                 :            : 
      87                 :       4717 :   while (new_ref->next)
      88                 :          0 :     new_ref = new_ref->next;
      89                 :       4717 :   new_ref->next = *ref;
      90                 :            : 
      91                 :       4717 :   if (new_ref->next)
      92                 :            :     {
      93                 :       4717 :       gfc_ref *next = NULL;
      94                 :            : 
      95                 :            :       /* We need to update the base type in the trailing reference chain to
      96                 :            :          that of the new component.  */
      97                 :            : 
      98                 :       4717 :       gcc_assert (strcmp (name, "_data") == 0);
      99                 :            : 
     100                 :       4717 :       if (new_ref->next->type == REF_COMPONENT)
     101                 :            :         next = new_ref->next;
     102                 :       4542 :       else if (new_ref->next->type == REF_ARRAY
     103                 :       4542 :                && new_ref->next->next
     104                 :       1103 :                && new_ref->next->next->type == REF_COMPONENT)
     105                 :            :         next = new_ref->next->next;
     106                 :            : 
     107                 :       1222 :       if (next != NULL)
     108                 :            :         {
     109                 :       1222 :           gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
     110                 :            :                       || new_ref->u.c.component->ts.type == BT_DERIVED);
     111                 :       1222 :           next->u.c.sym = new_ref->u.c.component->ts.u.derived;
     112                 :            :         }
     113                 :            :     }
     114                 :            : 
     115                 :       4717 :   *ref = new_ref;
     116                 :            : }
     117                 :            : 
     118                 :            : 
     119                 :            : /* Tells whether we need to add a "_data" reference to access REF subobject
     120                 :            :    from an object of type TS.  If FIRST_REF_IN_CHAIN is set, then the base
     121                 :            :    object accessed by REF is a variable; in other words it is a full object,
     122                 :            :    not a subobject.  */
     123                 :            : 
     124                 :            : static bool
     125                 :     742152 : class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
     126                 :            : {
     127                 :            :   /* Only class containers may need the "_data" reference.  */
     128                 :          0 :   if (ts->type != BT_CLASS)
     129                 :            :     return false;
     130                 :            : 
     131                 :            :   /* Accessing a class container with an array reference is certainly wrong.  */
     132                 :      64577 :   if (ref->type != REF_COMPONENT)
     133                 :            :     return true;
     134                 :            : 
     135                 :            :   /* Accessing the class container's fields is fine.  */
     136                 :      60034 :   if (ref->u.c.component->name[0] == '_')
     137                 :            :     return false;
     138                 :            : 
     139                 :            :   /* At this point we have a class container with a non class container's field
     140                 :            :      component reference.  We don't want to add the "_data" component if we are
     141                 :            :      at the first reference and the symbol's type is an extended derived type.
     142                 :            :      In that case, conv_parent_component_references will do the right thing so
     143                 :            :      it is not absolutely necessary.  Omitting it prevents a regression (see
     144                 :            :      class_41.f03) in the interface mapping mechanism.  When evaluating string
     145                 :            :      lengths depending on dummy arguments, we create a fake symbol with a type
     146                 :            :      equal to that of the dummy type.  However, because of type extension,
     147                 :            :      the backend type (corresponding to the actual argument) can have a
     148                 :            :      different (extended) type.  Adding the "_data" component explicitly, using
     149                 :            :      the base type, confuses the gfc_conv_component_ref code which deals with
     150                 :            :      the extended type.  */
     151                 :      10260 :   if (first_ref_in_chain && ts->u.derived->attr.extension)
     152                 :          0 :     return false;
     153                 :            : 
     154                 :            :   /* We have a class container with a non class container's field component
     155                 :            :      reference that doesn't fall into the above.  */
     156                 :            :   return true;
     157                 :            : }
     158                 :            : 
     159                 :            : 
     160                 :            : /* Browse through a data reference chain and add the missing "_data" references
     161                 :            :    when a subobject of a class object is accessed without it.
     162                 :            :    Note that it doesn't add the "_data" reference when the class container
     163                 :            :    is the last element in the reference chain.  */
     164                 :            : 
     165                 :            : void
     166                 :    2469930 : gfc_fix_class_refs (gfc_expr *e)
     167                 :            : {
     168                 :    2469930 :   gfc_typespec *ts;
     169                 :    2469930 :   gfc_ref **ref;
     170                 :            : 
     171                 :    2469930 :   if ((e->expr_type != EXPR_VARIABLE
     172                 :    2469930 :        && e->expr_type != EXPR_FUNCTION)
     173                 :    1446960 :       || (e->expr_type == EXPR_FUNCTION
     174                 :     189739 :           && e->value.function.isym != NULL))
     175                 :            :     return;
     176                 :            : 
     177                 :    1286700 :   if (e->expr_type == EXPR_VARIABLE)
     178                 :    1257220 :     ts = &e->symtree->n.sym->ts;
     179                 :            :   else
     180                 :            :     {
     181                 :      29487 :       gfc_symbol *func;
     182                 :            : 
     183                 :      29487 :       gcc_assert (e->expr_type == EXPR_FUNCTION);
     184                 :      29487 :       if (e->value.function.esym != NULL)
     185                 :            :         func = e->value.function.esym;
     186                 :            :       else
     187                 :       1311 :         func = e->symtree->n.sym;
     188                 :            : 
     189                 :      29487 :       if (func->result != NULL)
     190                 :      28487 :         ts = &func->result->ts;
     191                 :            :       else
     192                 :       1000 :         ts = &func->ts;
     193                 :            :     }
     194                 :            : 
     195                 :    2028860 :   for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
     196                 :            :     {
     197                 :     742152 :       if (class_data_ref_missing (ts, *ref, ref == &e->ref))
     198                 :       4718 :         insert_component_ref (ts, ref, "_data");
     199                 :            : 
     200                 :     742152 :       if ((*ref)->type == REF_COMPONENT)
     201                 :     154963 :         ts = &(*ref)->u.c.component->ts;
     202                 :            :     }
     203                 :            : }
     204                 :            : 
     205                 :            : 
     206                 :            : /* Insert a reference to the component of the given name.
     207                 :            :    Only to be used with CLASS containers and vtables.  */
     208                 :            : 
     209                 :            : void
     210                 :      38153 : gfc_add_component_ref (gfc_expr *e, const char *name)
     211                 :            : {
     212                 :      38153 :   gfc_component *c;
     213                 :      38153 :   gfc_ref **tail = &(e->ref);
     214                 :      38153 :   gfc_ref *ref, *next = NULL;
     215                 :      38153 :   gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
     216                 :      52537 :   while (*tail != NULL)
     217                 :            :     {
     218                 :      22646 :       if ((*tail)->type == REF_COMPONENT)
     219                 :            :         {
     220                 :      14290 :           if (strcmp ((*tail)->u.c.component->name, "_data") == 0
     221                 :        587 :                 && (*tail)->next
     222                 :        587 :                 && (*tail)->next->type == REF_ARRAY
     223                 :        575 :                 && (*tail)->next->next == NULL)
     224                 :            :             return;
     225                 :      13727 :           derived = (*tail)->u.c.component->ts.u.derived;
     226                 :            :         }
     227                 :      22083 :       if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
     228                 :            :         break;
     229                 :      14384 :       tail = &((*tail)->next);
     230                 :            :     }
     231                 :      37590 :   if (derived->components && derived->components->next &&
     232                 :      37588 :       derived->components->next->ts.type == BT_DERIVED &&
     233                 :      29481 :       derived->components->next->ts.u.derived == NULL)
     234                 :            :     {
     235                 :            :       /* Fix up missing vtype.  */
     236                 :          6 :       gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
     237                 :          6 :       gcc_assert (vtab);
     238                 :          6 :       derived->components->next->ts.u.derived = vtab->ts.u.derived;
     239                 :            :     }
     240                 :      37590 :   if (*tail != NULL && strcmp (name, "_data") == 0)
     241                 :            :     next = *tail;
     242                 :            :   else
     243                 :            :     /* Avoid losing memory.  */
     244                 :      33377 :     gfc_free_ref_list (*tail);
     245                 :      37590 :   c = gfc_find_component (derived, name, true, true, tail);
     246                 :            : 
     247                 :      37590 :   if (c) {
     248                 :      37587 :     for (ref = *tail; ref->next; ref = ref->next)
     249                 :            :       ;
     250                 :      37587 :     ref->next = next;
     251                 :      37587 :     if (!next)
     252                 :      33374 :       e->ts = c->ts;
     253                 :            :   }
     254                 :            : }
     255                 :            : 
     256                 :            : 
     257                 :            : /* This is used to add both the _data component reference and an array
     258                 :            :    reference to class expressions.  Used in translation of intrinsic
     259                 :            :    array inquiry functions.  */
     260                 :            : 
     261                 :            : void
     262                 :       2350 : gfc_add_class_array_ref (gfc_expr *e)
     263                 :            : {
     264                 :       2350 :   int rank = CLASS_DATA (e)->as->rank;
     265                 :       2350 :   gfc_array_spec *as = CLASS_DATA (e)->as;
     266                 :       2350 :   gfc_ref *ref = NULL;
     267                 :       2350 :   gfc_add_data_component (e);
     268                 :       2350 :   e->rank = rank;
     269                 :       4346 :   for (ref = e->ref; ref; ref = ref->next)
     270                 :       4346 :     if (!ref->next)
     271                 :            :       break;
     272                 :       2350 :   if (ref->type != REF_ARRAY)
     273                 :            :     {
     274                 :        661 :       ref->next = gfc_get_ref ();
     275                 :        661 :       ref = ref->next;
     276                 :        661 :       ref->type = REF_ARRAY;
     277                 :        661 :       ref->u.ar.type = AR_FULL;
     278                 :        661 :       ref->u.ar.as = as;
     279                 :            :     }
     280                 :       2350 : }
     281                 :            : 
     282                 :            : 
     283                 :            : /* Unfortunately, class array expressions can appear in various conditions;
     284                 :            :    with and without both _data component and an arrayspec.  This function
     285                 :            :    deals with that variability.  The previous reference to 'ref' is to a
     286                 :            :    class array.  */
     287                 :            : 
     288                 :            : static bool
     289                 :       4997 : class_array_ref_detected (gfc_ref *ref, bool *full_array)
     290                 :            : {
     291                 :       4997 :   bool no_data = false;
     292                 :       4997 :   bool with_data = false;
     293                 :            : 
     294                 :            :   /* An array reference with no _data component.  */
     295                 :       4997 :   if (ref && ref->type == REF_ARRAY
     296                 :        202 :         && !ref->next
     297                 :        196 :         && ref->u.ar.type != AR_ELEMENT)
     298                 :            :     {
     299                 :        196 :       if (full_array)
     300                 :        196 :         *full_array = ref->u.ar.type == AR_FULL;
     301                 :            :       no_data = true;
     302                 :            :     }
     303                 :            : 
     304                 :            :   /* Cover cases where _data appears, with or without an array ref.  */
     305                 :       4997 :   if (ref && ref->type == REF_COMPONENT
     306                 :       4770 :         && strcmp (ref->u.c.component->name, "_data") == 0)
     307                 :            :     {
     308                 :       4770 :       if (!ref->next)
     309                 :            :         {
     310                 :          0 :           with_data = true;
     311                 :          0 :           if (full_array)
     312                 :          0 :             *full_array = true;
     313                 :            :         }
     314                 :       4770 :       else if (ref->next && ref->next->type == REF_ARRAY
     315                 :            :             && ref->type == REF_COMPONENT
     316                 :       4770 :             && ref->next->u.ar.type != AR_ELEMENT)
     317                 :            :         {
     318                 :       4638 :           with_data = true;
     319                 :       4638 :           if (full_array)
     320                 :       1493 :             *full_array = ref->next->u.ar.type == AR_FULL;
     321                 :            :         }
     322                 :            :     }
     323                 :            : 
     324                 :       4997 :   return no_data || with_data;
     325                 :            : }
     326                 :            : 
     327                 :            : 
     328                 :            : /* Returns true if the expression contains a reference to a class
     329                 :            :    array.  Notice that class array elements return false.  */
     330                 :            : 
     331                 :            : bool
     332                 :     164248 : gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
     333                 :            : {
     334                 :     164248 :   gfc_ref *ref;
     335                 :            : 
     336                 :     164248 :   if (!e->rank)
     337                 :            :     return false;
     338                 :            : 
     339                 :     141662 :   if (full_array)
     340                 :       1701 :     *full_array= false;
     341                 :            : 
     342                 :            :   /* Is this a class array object? ie. Is the symbol of type class?  */
     343                 :     141662 :   if (e->symtree
     344                 :     117052 :         && e->symtree->n.sym->ts.type == BT_CLASS
     345                 :       4996 :         && CLASS_DATA (e->symtree->n.sym)
     346                 :       4996 :         && CLASS_DATA (e->symtree->n.sym)->attr.dimension
     347                 :     145827 :         && class_array_ref_detected (e->ref, full_array))
     348                 :            :     return true;
     349                 :            : 
     350                 :            :   /* Or is this a class array component reference?  */
     351                 :     254835 :   for (ref = e->ref; ref; ref = ref->next)
     352                 :            :     {
     353                 :     118007 :       if (ref->type == REF_COMPONENT
     354                 :      10843 :             && ref->u.c.component->ts.type == BT_CLASS
     355                 :        858 :             && CLASS_DATA (ref->u.c.component)->attr.dimension
     356                 :     118839 :             && class_array_ref_detected (ref->next, full_array))
     357                 :            :         return true;
     358                 :            :     }
     359                 :            : 
     360                 :            :   return false;
     361                 :            : }
     362                 :            : 
     363                 :            : 
     364                 :            : /* Returns true if the expression is a reference to a class
     365                 :            :    scalar.  This function is necessary because such expressions
     366                 :            :    can be dressed with a reference to the _data component and so
     367                 :            :    have a type other than BT_CLASS.  */
     368                 :            : 
     369                 :            : bool
     370                 :      29159 : gfc_is_class_scalar_expr (gfc_expr *e)
     371                 :            : {
     372                 :      29159 :   gfc_ref *ref;
     373                 :            : 
     374                 :      29159 :   if (e->rank)
     375                 :            :     return false;
     376                 :            : 
     377                 :            :   /* Is this a class object?  */
     378                 :      24912 :   if (e->symtree
     379                 :      20075 :         && e->symtree->n.sym->ts.type == BT_CLASS
     380                 :       2890 :         && CLASS_DATA (e->symtree->n.sym)
     381                 :       2890 :         && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
     382                 :       2713 :         && (e->ref == NULL
     383                 :       2414 :             || (e->ref->type == REF_COMPONENT
     384                 :       2412 :                 && strcmp (e->ref->u.c.component->name, "_data") == 0
     385                 :       2181 :                 && e->ref->next == NULL)))
     386                 :            :     return true;
     387                 :            : 
     388                 :            :   /* Or is the final reference BT_CLASS or _data?  */
     389                 :      24366 :   for (ref = e->ref; ref; ref = ref->next)
     390                 :            :     {
     391                 :       2210 :       if (ref->type == REF_COMPONENT
     392                 :       1615 :             && ref->u.c.component->ts.type == BT_CLASS
     393                 :        326 :             && CLASS_DATA (ref->u.c.component)
     394                 :        326 :             && !CLASS_DATA (ref->u.c.component)->attr.dimension
     395                 :        296 :             && (ref->next == NULL
     396                 :        172 :                 || (ref->next->type == REF_COMPONENT
     397                 :        170 :                     && strcmp (ref->next->u.c.component->name, "_data") == 0
     398                 :        170 :                     && ref->next->next == NULL)))
     399                 :            :         return true;
     400                 :            :     }
     401                 :            : 
     402                 :            :   return false;
     403                 :            : }
     404                 :            : 
     405                 :            : 
     406                 :            : /* Tells whether the expression E is a reference to a (scalar) class container.
     407                 :            :    Scalar because array class containers usually have an array reference after
     408                 :            :    them, and gfc_fix_class_refs will add the missing "_data" component reference
     409                 :            :    in that case.  */
     410                 :            : 
     411                 :            : bool
     412                 :       1149 : gfc_is_class_container_ref (gfc_expr *e)
     413                 :            : {
     414                 :       1149 :   gfc_ref *ref;
     415                 :       1149 :   bool result;
     416                 :            : 
     417                 :       1149 :   if (e->expr_type != EXPR_VARIABLE)
     418                 :        120 :     return e->ts.type == BT_CLASS;
     419                 :            : 
     420                 :       1029 :   if (e->symtree->n.sym->ts.type == BT_CLASS)
     421                 :            :     result = true;
     422                 :            :   else
     423                 :        821 :     result = false;
     424                 :            : 
     425                 :       2218 :   for (ref = e->ref; ref; ref = ref->next)
     426                 :            :     {
     427                 :       1189 :       if (ref->type != REF_COMPONENT)
     428                 :            :         result = false;
     429                 :        260 :       else if (ref->u.c.component->ts.type == BT_CLASS)
     430                 :            :         result = true;
     431                 :            :       else
     432                 :        260 :         result = false;
     433                 :            :     }
     434                 :            : 
     435                 :            :   return result;
     436                 :            : }
     437                 :            : 
     438                 :            : 
     439                 :            : /* Build an initializer for CLASS pointers,
     440                 :            :    initializing the _data component to the init_expr (or NULL) and the _vptr
     441                 :            :    component to the corresponding type (or the declared type, given by ts).  */
     442                 :            : 
     443                 :            : gfc_expr *
     444                 :       2012 : gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
     445                 :            : {
     446                 :       2012 :   gfc_expr *init;
     447                 :       2012 :   gfc_component *comp;
     448                 :       2012 :   gfc_symbol *vtab = NULL;
     449                 :            : 
     450                 :       2012 :   if (init_expr && init_expr->expr_type != EXPR_NULL)
     451                 :       1089 :     vtab = gfc_find_vtab (&init_expr->ts);
     452                 :            :   else
     453                 :        923 :     vtab = gfc_find_vtab (ts);
     454                 :            : 
     455                 :       4024 :   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
     456                 :       2012 :                                              &ts->u.derived->declared_at);
     457                 :       2012 :   init->ts = *ts;
     458                 :            : 
     459                 :       6363 :   for (comp = ts->u.derived->components; comp; comp = comp->next)
     460                 :            :     {
     461                 :       4351 :       gfc_constructor *ctor = gfc_constructor_get();
     462                 :       4351 :       if (strcmp (comp->name, "_vptr") == 0 && vtab)
     463                 :       2012 :         ctor->expr = gfc_lval_expr_from_sym (vtab);
     464                 :       2339 :       else if (init_expr && init_expr->expr_type != EXPR_NULL)
     465                 :       1203 :           ctor->expr = gfc_copy_expr (init_expr);
     466                 :            :       else
     467                 :       1136 :         ctor->expr = gfc_get_null_expr (NULL);
     468                 :       4351 :       gfc_constructor_append (&init->value.constructor, ctor);
     469                 :            :     }
     470                 :            : 
     471                 :       2012 :   return init;
     472                 :            : }
     473                 :            : 
     474                 :            : 
     475                 :            : /* Create a unique string identifier for a derived type, composed of its name
     476                 :            :    and module name. This is used to construct unique names for the class
     477                 :            :    containers and vtab symbols.  */
     478                 :            : 
     479                 :            : static void
     480                 :      59466 : get_unique_type_string (char *string, gfc_symbol *derived)
     481                 :            : {
     482                 :      59466 :   char dt_name[GFC_MAX_SYMBOL_LEN+1];
     483                 :      59466 :   if (derived->attr.unlimited_polymorphic)
     484                 :       3387 :     strcpy (dt_name, "STAR");
     485                 :            :   else
     486                 :      56079 :     strcpy (dt_name, gfc_dt_upper_string (derived->name));
     487                 :      59466 :   if (derived->attr.unlimited_polymorphic)
     488                 :       3387 :     sprintf (string, "_%s", dt_name);
     489                 :      56079 :   else if (derived->module)
     490                 :      15913 :     sprintf (string, "%s_%s", derived->module, dt_name);
     491                 :      40166 :   else if (derived->ns->proc_name)
     492                 :      39465 :     sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
     493                 :            :   else
     494                 :        701 :     sprintf (string, "_%s", dt_name);
     495                 :      59466 : }
     496                 :            : 
     497                 :            : 
     498                 :            : /* A relative of 'get_unique_type_string' which makes sure the generated
     499                 :            :    string will not be too long (replacing it by a hash string if needed).  */
     500                 :            : 
     501                 :            : static void
     502                 :      49199 : get_unique_hashed_string (char *string, gfc_symbol *derived)
     503                 :            : {
     504                 :      49199 :   char tmp[2*GFC_MAX_SYMBOL_LEN+2];
     505                 :      49199 :   get_unique_type_string (&tmp[0], derived);
     506                 :            :   /* If string is too long, use hash value in hex representation (allow for
     507                 :            :      extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
     508                 :            :      We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
     509                 :            :      where %d is the (co)rank which can be up to n = 15.  */
     510                 :      49199 :   if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
     511                 :            :     {
     512                 :         97 :       int h = gfc_hash_value (derived);
     513                 :         97 :       sprintf (string, "%X", h);
     514                 :            :     }
     515                 :            :   else
     516                 :      49102 :     strcpy (string, tmp);
     517                 :      49199 : }
     518                 :            : 
     519                 :            : 
     520                 :            : /* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
     521                 :            : 
     522                 :            : unsigned int
     523                 :      10267 : gfc_hash_value (gfc_symbol *sym)
     524                 :            : {
     525                 :      10267 :   unsigned int hash = 0;
     526                 :      10267 :   char c[2*(GFC_MAX_SYMBOL_LEN+1)];
     527                 :      10267 :   int i, len;
     528                 :            : 
     529                 :      10267 :   get_unique_type_string (&c[0], sym);
     530                 :      10267 :   len = strlen (c);
     531                 :            : 
     532                 :     144821 :   for (i = 0; i < len; i++)
     533                 :     134554 :     hash = (hash << 6) + (hash << 16) - hash + c[i];
     534                 :            : 
     535                 :            :   /* Return the hash but take the modulus for the sake of module read,
     536                 :            :      even though this slightly increases the chance of collision.  */
     537                 :      10267 :   return (hash % 100000000);
     538                 :            : }
     539                 :            : 
     540                 :            : 
     541                 :            : /* Assign a hash value for an intrinsic type. The algorithm is that of SDBM.  */
     542                 :            : 
     543                 :            : unsigned int
     544                 :        432 : gfc_intrinsic_hash_value (gfc_typespec *ts)
     545                 :            : {
     546                 :        432 :   unsigned int hash = 0;
     547                 :        432 :   const char *c = gfc_typename (ts);
     548                 :        432 :   int i, len;
     549                 :            : 
     550                 :        432 :   len = strlen (c);
     551                 :            : 
     552                 :       4670 :   for (i = 0; i < len; i++)
     553                 :       4238 :     hash = (hash << 6) + (hash << 16) - hash + c[i];
     554                 :            : 
     555                 :            :   /* Return the hash but take the modulus for the sake of module read,
     556                 :            :      even though this slightly increases the chance of collision.  */
     557                 :        432 :   return (hash % 100000000);
     558                 :            : }
     559                 :            : 
     560                 :            : 
     561                 :            : /* Get the _len component from a class/derived object storing a string.
     562                 :            :    For unlimited polymorphic entities a ref to the _data component is available
     563                 :            :    while a ref to the _len component is needed.  This routine traverese the
     564                 :            :    ref-chain and strips the last ref to a _data from it replacing it with a
     565                 :            :    ref to the _len component.  */
     566                 :            : 
     567                 :            : gfc_expr *
     568                 :        163 : gfc_get_len_component (gfc_expr *e, int k)
     569                 :            : {
     570                 :        163 :   gfc_expr *ptr;
     571                 :        163 :   gfc_ref *ref, **last;
     572                 :            : 
     573                 :        163 :   ptr = gfc_copy_expr (e);
     574                 :            : 
     575                 :            :   /* We need to remove the last _data component ref from ptr.  */
     576                 :        163 :   last = &(ptr->ref);
     577                 :        163 :   ref = ptr->ref;
     578                 :        163 :   while (ref)
     579                 :            :     {
     580                 :        163 :       if (!ref->next
     581                 :        163 :           && ref->type == REF_COMPONENT
     582                 :        163 :           && strcmp ("_data", ref->u.c.component->name)== 0)
     583                 :            :         {
     584                 :        163 :           gfc_free_ref_list (ref);
     585                 :        163 :           *last = NULL;
     586                 :        163 :           break;
     587                 :            :         }
     588                 :          0 :       last = &(ref->next);
     589                 :          0 :       ref = ref->next;
     590                 :            :     }
     591                 :            :   /* And replace if with a ref to the _len component.  */
     592                 :        163 :   gfc_add_len_component (ptr);
     593                 :        163 :   if (k != ptr->ts.kind)
     594                 :            :     {
     595                 :        163 :       gfc_typespec ts;
     596                 :        163 :       gfc_clear_ts (&ts);
     597                 :        163 :       ts.type = BT_INTEGER;
     598                 :        163 :       ts.kind = k;
     599                 :        163 :       gfc_convert_type_warn (ptr, &ts, 2, 0);
     600                 :            :     }
     601                 :        163 :   return ptr;
     602                 :            : }
     603                 :            : 
     604                 :            : 
     605                 :            : /* Build a polymorphic CLASS entity, using the symbol that comes from
     606                 :            :    build_sym. A CLASS entity is represented by an encapsulating type,
     607                 :            :    which contains the declared type as '_data' component, plus a pointer
     608                 :            :    component '_vptr' which determines the dynamic type.  When this CLASS
     609                 :            :    entity is unlimited polymorphic, then also add a component '_len' to
     610                 :            :    store the length of string when that is stored in it.  */
     611                 :            : 
     612                 :            : bool
     613                 :       8863 : gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     614                 :            :                         gfc_array_spec **as)
     615                 :            : {
     616                 :       8863 :   char tname[GFC_MAX_SYMBOL_LEN+1];
     617                 :       8863 :   char *name;
     618                 :       8863 :   gfc_symbol *fclass;
     619                 :       8863 :   gfc_symbol *vtab;
     620                 :       8863 :   gfc_component *c;
     621                 :       8863 :   gfc_namespace *ns;
     622                 :       8863 :   int rank;
     623                 :            : 
     624                 :       8863 :   gcc_assert (as);
     625                 :            : 
     626                 :       8863 :   if (*as && (*as)->type == AS_ASSUMED_SIZE)
     627                 :            :     {
     628                 :          0 :       gfc_error ("Assumed size polymorphic objects or components, such "
     629                 :            :                  "as that at %C, have not yet been implemented");
     630                 :          0 :       return false;
     631                 :            :     }
     632                 :            : 
     633                 :       8863 :   if (attr->class_ok)
     634                 :            :     /* Class container has already been built.  */
     635                 :            :     return true;
     636                 :            : 
     637                 :      17698 :   attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
     638                 :       8849 :                    || attr->select_type_temporary || attr->associate_var;
     639                 :            : 
     640                 :       8849 :   if (!attr->class_ok)
     641                 :            :     /* We cannot build the class container yet.  */
     642                 :            :     return true;
     643                 :            : 
     644                 :            :   /* Determine the name of the encapsulating type.  */
     645                 :       8803 :   rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
     646                 :       8803 :   get_unique_hashed_string (tname, ts->u.derived);
     647                 :       8803 :   if ((*as) && attr->allocatable)
     648                 :       1093 :     name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
     649                 :       7710 :   else if ((*as) && attr->pointer)
     650                 :        586 :     name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
     651                 :       7124 :   else if ((*as))
     652                 :        534 :     name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
     653                 :       6590 :   else if (attr->pointer)
     654                 :       1352 :     name = xasprintf ("__class_%s_p", tname);
     655                 :       5238 :   else if (attr->allocatable)
     656                 :       1579 :     name = xasprintf ("__class_%s_a", tname);
     657                 :            :   else
     658                 :       3659 :     name = xasprintf ("__class_%s_t", tname);
     659                 :            : 
     660                 :       8803 :   if (ts->u.derived->attr.unlimited_polymorphic)
     661                 :            :     {
     662                 :            :       /* Find the top-level namespace.  */
     663                 :       2001 :       for (ns = gfc_current_ns; ns; ns = ns->parent)
     664                 :       2001 :         if (!ns->parent)
     665                 :            :           break;
     666                 :            :     }
     667                 :            :   else
     668                 :       7722 :     ns = ts->u.derived->ns;
     669                 :            : 
     670                 :       8803 :   gfc_find_symbol (name, ns, 0, &fclass);
     671                 :       8803 :   if (fclass == NULL)
     672                 :            :     {
     673                 :       5030 :       gfc_symtree *st;
     674                 :            :       /* If not there, create a new symbol.  */
     675                 :       5030 :       fclass = gfc_new_symbol (name, ns);
     676                 :       5030 :       st = gfc_new_symtree (&ns->sym_root, name);
     677                 :       5030 :       st->n.sym = fclass;
     678                 :       5030 :       gfc_set_sym_referenced (fclass);
     679                 :       5030 :       fclass->refs++;
     680                 :       5030 :       fclass->ts.type = BT_UNKNOWN;
     681                 :       5030 :       if (!ts->u.derived->attr.unlimited_polymorphic)
     682                 :       4350 :         fclass->attr.abstract = ts->u.derived->attr.abstract;
     683                 :       5030 :       fclass->f2k_derived = gfc_get_namespace (NULL, 0);
     684                 :       5030 :       if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
     685                 :            :                            &gfc_current_locus))
     686                 :            :         return false;
     687                 :            : 
     688                 :            :       /* Add component '_data'.  */
     689                 :       5030 :       if (!gfc_add_component (fclass, "_data", &c))
     690                 :            :         return false;
     691                 :       5030 :       c->ts = *ts;
     692                 :       5030 :       c->ts.type = BT_DERIVED;
     693                 :       5030 :       c->attr.access = ACCESS_PRIVATE;
     694                 :       5030 :       c->ts.u.derived = ts->u.derived;
     695                 :       5030 :       c->attr.class_pointer = attr->pointer;
     696                 :       3963 :       c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
     697                 :       6785 :                         || attr->select_type_temporary;
     698                 :       5030 :       c->attr.allocatable = attr->allocatable;
     699                 :       5030 :       c->attr.dimension = attr->dimension;
     700                 :       5030 :       c->attr.codimension = attr->codimension;
     701                 :       5030 :       c->attr.abstract = fclass->attr.abstract;
     702                 :       5030 :       c->as = (*as);
     703                 :       5030 :       c->initializer = NULL;
     704                 :            : 
     705                 :            :       /* Add component '_vptr'.  */
     706                 :       5030 :       if (!gfc_add_component (fclass, "_vptr", &c))
     707                 :            :         return false;
     708                 :       5030 :       c->ts.type = BT_DERIVED;
     709                 :       5030 :       c->attr.access = ACCESS_PRIVATE;
     710                 :       5030 :       c->attr.pointer = 1;
     711                 :            : 
     712                 :       5030 :       if (ts->u.derived->attr.unlimited_polymorphic)
     713                 :            :         {
     714                 :        680 :           vtab = gfc_find_derived_vtab (ts->u.derived);
     715                 :        680 :           gcc_assert (vtab);
     716                 :        680 :           c->ts.u.derived = vtab->ts.u.derived;
     717                 :            : 
     718                 :            :           /* Add component '_len'.  Only unlimited polymorphic pointers may
     719                 :            :              have a string assigned to them, i.e., only those need the _len
     720                 :            :              component.  */
     721                 :        680 :           if (!gfc_add_component (fclass, "_len", &c))
     722                 :            :             return false;
     723                 :        680 :           c->ts.type = BT_INTEGER;
     724                 :        680 :           c->ts.kind = gfc_charlen_int_kind;
     725                 :        680 :           c->attr.access = ACCESS_PRIVATE;
     726                 :        680 :           c->attr.artificial = 1;
     727                 :            :         }
     728                 :            :       else
     729                 :            :         /* Build vtab later.  */
     730                 :       4350 :         c->ts.u.derived = NULL;
     731                 :            :     }
     732                 :            : 
     733                 :       8803 :   if (!ts->u.derived->attr.unlimited_polymorphic)
     734                 :            :     {
     735                 :            :       /* Since the extension field is 8 bit wide, we can only have
     736                 :            :          up to 255 extension levels.  */
     737                 :       7722 :       if (ts->u.derived->attr.extension == 255)
     738                 :            :         {
     739                 :          0 :           gfc_error ("Maximum extension level reached with type %qs at %L",
     740                 :            :                      ts->u.derived->name, &ts->u.derived->declared_at);
     741                 :          0 :         return false;
     742                 :            :         }
     743                 :            : 
     744                 :       7722 :       fclass->attr.extension = ts->u.derived->attr.extension + 1;
     745                 :       7722 :       fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
     746                 :       7722 :       fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
     747                 :            :     }
     748                 :            : 
     749                 :       8803 :   fclass->attr.is_class = 1;
     750                 :       8803 :   ts->u.derived = fclass;
     751                 :       8803 :   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
     752                 :       8803 :   (*as) = NULL;
     753                 :       8803 :   free (name);
     754                 :       8803 :   return true;
     755                 :            : }
     756                 :            : 
     757                 :            : 
     758                 :            : /* Add a procedure pointer component to the vtype
     759                 :            :    to represent a specific type-bound procedure.  */
     760                 :            : 
     761                 :            : static void
     762                 :       3972 : add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
     763                 :            : {
     764                 :       3972 :   gfc_component *c;
     765                 :            : 
     766                 :       3972 :   if (tb->non_overridable && !tb->overridden)
     767                 :         14 :     return;
     768                 :            : 
     769                 :       3958 :   c = gfc_find_component (vtype, name, true, true, NULL);
     770                 :            : 
     771                 :       3958 :   if (c == NULL)
     772                 :            :     {
     773                 :            :       /* Add procedure component.  */
     774                 :       2761 :       if (!gfc_add_component (vtype, name, &c))
     775                 :            :         return;
     776                 :            : 
     777                 :       2761 :       if (!c->tb)
     778                 :       2761 :         c->tb = XCNEW (gfc_typebound_proc);
     779                 :       2761 :       *c->tb = *tb;
     780                 :       2761 :       c->tb->ppc = 1;
     781                 :       2761 :       c->attr.procedure = 1;
     782                 :       2761 :       c->attr.proc_pointer = 1;
     783                 :       2761 :       c->attr.flavor = FL_PROCEDURE;
     784                 :       2761 :       c->attr.access = ACCESS_PRIVATE;
     785                 :       2761 :       c->attr.external = 1;
     786                 :       2761 :       c->attr.untyped = 1;
     787                 :       2761 :       c->attr.if_source = IFSRC_IFBODY;
     788                 :            :     }
     789                 :       1197 :   else if (c->attr.proc_pointer && c->tb)
     790                 :            :     {
     791                 :       1197 :       *c->tb = *tb;
     792                 :       1197 :       c->tb->ppc = 1;
     793                 :            :     }
     794                 :            : 
     795                 :       3958 :   if (tb->u.specific)
     796                 :            :     {
     797                 :       3958 :       gfc_symbol *ifc = tb->u.specific->n.sym;
     798                 :       3958 :       c->ts.interface = ifc;
     799                 :       3958 :       if (!tb->deferred)
     800                 :       3327 :         c->initializer = gfc_get_variable_expr (tb->u.specific);
     801                 :       3958 :       c->attr.pure = ifc->attr.pure;
     802                 :            :     }
     803                 :            : }
     804                 :            : 
     805                 :            : 
     806                 :            : /* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
     807                 :            : 
     808                 :            : static void
     809                 :       3853 : add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
     810                 :            : {
     811                 :       3853 :   if (!st)
     812                 :            :     return;
     813                 :            : 
     814                 :       3853 :   if (st->left)
     815                 :       1026 :     add_procs_to_declared_vtab1 (st->left, vtype);
     816                 :            : 
     817                 :       3853 :   if (st->right)
     818                 :        976 :     add_procs_to_declared_vtab1 (st->right, vtype);
     819                 :            : 
     820                 :       3853 :   if (st->n.tb && !st->n.tb->error
     821                 :       3852 :       && !st->n.tb->is_generic && st->n.tb->u.specific)
     822                 :       3250 :     add_proc_comp (vtype, st->name, st->n.tb);
     823                 :            : }
     824                 :            : 
     825                 :            : 
     826                 :            : /* Copy procedure pointers components from the parent type.  */
     827                 :            : 
     828                 :            : static void
     829                 :       1118 : copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
     830                 :            : {
     831                 :       1118 :   gfc_component *cmp;
     832                 :       1118 :   gfc_symbol *vtab;
     833                 :            : 
     834                 :       1118 :   vtab = gfc_find_derived_vtab (declared);
     835                 :            : 
     836                 :       9693 :   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
     837                 :            :     {
     838                 :       8575 :       if (gfc_find_component (vtype, cmp->name, true, true, NULL))
     839                 :       7853 :         continue;
     840                 :            : 
     841                 :        722 :       add_proc_comp (vtype, cmp->name, cmp->tb);
     842                 :            :     }
     843                 :       1118 : }
     844                 :            : 
     845                 :            : 
     846                 :            : /* Returns true if any of its nonpointer nonallocatable components or
     847                 :            :    their nonpointer nonallocatable subcomponents has a finalization
     848                 :            :    subroutine.  */
     849                 :            : 
     850                 :            : static bool
     851                 :       6243 : has_finalizer_component (gfc_symbol *derived)
     852                 :            : {
     853                 :       6243 :    gfc_component *c;
     854                 :            : 
     855                 :      13488 :   for (c = derived->components; c; c = c->next)
     856                 :       7245 :     if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
     857                 :            :       {
     858                 :       1437 :         if (c->ts.u.derived->f2k_derived
     859                 :       1322 :             && c->ts.u.derived->f2k_derived->finalizers)
     860                 :            :           return true;
     861                 :            : 
     862                 :            :         /* Stop infinite recursion through this function by inhibiting
     863                 :            :           calls when the derived type and that of the component are
     864                 :            :           the same.  */
     865                 :       1437 :         if (!gfc_compare_derived_types (derived, c->ts.u.derived)
     866                 :       1437 :             && has_finalizer_component (c->ts.u.derived))
     867                 :            :           return true;
     868                 :            :       }
     869                 :            :   return false;
     870                 :            : }
     871                 :            : 
     872                 :            : 
     873                 :            : static bool
     874                 :       4556 : comp_is_finalizable (gfc_component *comp)
     875                 :            : {
     876                 :       4556 :   if (comp->attr.proc_pointer)
     877                 :            :     return false;
     878                 :       4502 :   else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
     879                 :            :     return true;
     880                 :        659 :   else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
     881                 :       2211 :            && (comp->ts.u.derived->attr.alloc_comp
     882                 :        621 :                || has_finalizer_component (comp->ts.u.derived)
     883                 :        219 :                || (comp->ts.u.derived->f2k_derived
     884                 :        219 :                    && comp->ts.u.derived->f2k_derived->finalizers)))
     885                 :        404 :     return true;
     886                 :       1807 :   else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
     887                 :        462 :             && CLASS_DATA (comp)->attr.allocatable)
     888                 :            :     return true;
     889                 :            :   else
     890                 :       1391 :     return false;
     891                 :            : }
     892                 :            : 
     893                 :            : 
     894                 :            : /* Call DEALLOCATE for the passed component if it is allocatable, if it is
     895                 :            :    neither allocatable nor a pointer but has a finalizer, call it. If it
     896                 :            :    is a nonpointer component with allocatable components or has finalizers, walk
     897                 :            :    them. Either of them is required; other nonallocatables and pointers aren't
     898                 :            :    handled gracefully.
     899                 :            :    Note: If the component is allocatable, the DEALLOCATE handling takes care
     900                 :            :    of calling the appropriate finalizers, coarray deregistering, and
     901                 :            :    deallocation of allocatable subcomponents.  */
     902                 :            : 
     903                 :            : static void
     904                 :       2345 : finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
     905                 :            :                     gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code,
     906                 :            :                     gfc_namespace *sub_ns)
     907                 :            : {
     908                 :       2345 :   gfc_expr *e;
     909                 :       2345 :   gfc_ref *ref;
     910                 :            : 
     911                 :       2345 :   if (!comp_is_finalizable (comp))
     912                 :            :     return;
     913                 :            : 
     914                 :       1652 :   if (comp->finalized)
     915                 :            :     return;
     916                 :            : 
     917                 :       1513 :   e = gfc_copy_expr (expr);
     918                 :       1513 :   if (!e->ref)
     919                 :       1413 :     e->ref = ref = gfc_get_ref ();
     920                 :            :   else
     921                 :            :     {
     922                 :        119 :       for (ref = e->ref; ref->next; ref = ref->next)
     923                 :            :         ;
     924                 :        100 :       ref->next = gfc_get_ref ();
     925                 :        100 :       ref = ref->next;
     926                 :            :     }
     927                 :       1513 :   ref->type = REF_COMPONENT;
     928                 :       1513 :   ref->u.c.sym = derived;
     929                 :       1513 :   ref->u.c.component = comp;
     930                 :       1513 :   e->ts = comp->ts;
     931                 :            : 
     932                 :       1513 :   if (comp->attr.dimension || comp->attr.codimension
     933                 :        691 :       || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
     934                 :        212 :           && (CLASS_DATA (comp)->attr.dimension
     935                 :        212 :               || CLASS_DATA (comp)->attr.codimension)))
     936                 :            :     {
     937                 :        888 :       ref->next = gfc_get_ref ();
     938                 :        888 :       ref->next->type = REF_ARRAY;
     939                 :        888 :       ref->next->u.ar.dimen = 0;
     940                 :        888 :       ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
     941                 :            :                                                         : comp->as;
     942                 :        888 :       e->rank = ref->next->u.ar.as->rank;
     943                 :        904 :       ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
     944                 :            :     }
     945                 :            : 
     946                 :            :   /* Call DEALLOCATE (comp, stat=ignore).  */
     947                 :       1513 :   if (comp->attr.allocatable
     948                 :        403 :       || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
     949                 :       1725 :           && CLASS_DATA (comp)->attr.allocatable))
     950                 :            :     {
     951                 :       1322 :       gfc_code *dealloc, *block = NULL;
     952                 :            : 
     953                 :            :       /* Add IF (fini_coarray).  */
     954                 :       1322 :       if (comp->attr.codimension
     955                 :       1310 :           || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
     956                 :       1534 :               && CLASS_DATA (comp)->attr.codimension))
     957                 :            :         {
     958                 :         25 :           block = gfc_get_code (EXEC_IF);
     959                 :         25 :           if (*code)
     960                 :            :             {
     961                 :         25 :               (*code)->next = block;
     962                 :         25 :               (*code) = (*code)->next;
     963                 :            :             }
     964                 :            :           else
     965                 :          0 :               (*code) = block;
     966                 :            : 
     967                 :         25 :           block->block = gfc_get_code (EXEC_IF);
     968                 :         25 :           block = block->block;
     969                 :         25 :           block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
     970                 :            :         }
     971                 :            : 
     972                 :       1322 :       dealloc = gfc_get_code (EXEC_DEALLOCATE);
     973                 :            : 
     974                 :       1322 :       dealloc->ext.alloc.list = gfc_get_alloc ();
     975                 :       1322 :       dealloc->ext.alloc.list->expr = e;
     976                 :       1322 :       dealloc->expr1 = gfc_lval_expr_from_sym (stat);
     977                 :            : 
     978                 :       1322 :       gfc_code *cond = gfc_get_code (EXEC_IF);
     979                 :       1322 :       cond->block = gfc_get_code (EXEC_IF);
     980                 :       1322 :       cond->block->expr1 = gfc_get_expr ();
     981                 :       1322 :       cond->block->expr1->expr_type = EXPR_FUNCTION;
     982                 :       1322 :       cond->block->expr1->where = gfc_current_locus;
     983                 :       1322 :       gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
     984                 :       1322 :       cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
     985                 :       1322 :       cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
     986                 :       1322 :       cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
     987                 :       1322 :       gfc_commit_symbol (cond->block->expr1->symtree->n.sym);
     988                 :       1322 :       cond->block->expr1->ts.type = BT_LOGICAL;
     989                 :       1322 :       cond->block->expr1->ts.kind = gfc_default_logical_kind;
     990                 :       1322 :       cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED);
     991                 :       1322 :       cond->block->expr1->value.function.actual = gfc_get_actual_arglist ();
     992                 :       1322 :       cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr);
     993                 :       1322 :       cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
     994                 :       1322 :       cond->block->next = dealloc;
     995                 :            : 
     996                 :       1322 :       if (block)
     997                 :         25 :         block->next = cond;
     998                 :       1297 :       else if (*code)
     999                 :            :         {
    1000                 :       1297 :           (*code)->next = cond;
    1001                 :       1297 :           (*code) = (*code)->next;
    1002                 :            :         }
    1003                 :            :       else
    1004                 :          0 :         (*code) = cond;
    1005                 :            :     }
    1006                 :        191 :   else if (comp->ts.type == BT_DERIVED
    1007                 :        191 :             && comp->ts.u.derived->f2k_derived
    1008                 :        191 :             && comp->ts.u.derived->f2k_derived->finalizers)
    1009                 :            :     {
    1010                 :            :       /* Call FINAL_WRAPPER (comp);  */
    1011                 :         14 :       gfc_code *final_wrap;
    1012                 :         14 :       gfc_symbol *vtab;
    1013                 :         14 :       gfc_component *c;
    1014                 :            : 
    1015                 :         14 :       vtab = gfc_find_derived_vtab (comp->ts.u.derived);
    1016                 :         84 :       for (c = vtab->ts.u.derived->components; c; c = c->next)
    1017                 :         84 :         if (strcmp (c->name, "_final") == 0)
    1018                 :            :           break;
    1019                 :            : 
    1020                 :         14 :       gcc_assert (c);
    1021                 :         14 :       final_wrap = gfc_get_code (EXEC_CALL);
    1022                 :         14 :       final_wrap->symtree = c->initializer->symtree;
    1023                 :         14 :       final_wrap->resolved_sym = c->initializer->symtree->n.sym;
    1024                 :         14 :       final_wrap->ext.actual = gfc_get_actual_arglist ();
    1025                 :         14 :       final_wrap->ext.actual->expr = e;
    1026                 :            : 
    1027                 :         14 :       if (*code)
    1028                 :            :         {
    1029                 :         14 :           (*code)->next = final_wrap;
    1030                 :         14 :           (*code) = (*code)->next;
    1031                 :            :         }
    1032                 :            :       else
    1033                 :          0 :         (*code) = final_wrap;
    1034                 :            :     }
    1035                 :            :   else
    1036                 :            :     {
    1037                 :        177 :       gfc_component *c;
    1038                 :            : 
    1039                 :        453 :       for (c = comp->ts.u.derived->components; c; c = c->next)
    1040                 :        276 :         finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code,
    1041                 :            :                             sub_ns);
    1042                 :        177 :       gfc_free_expr (e);
    1043                 :            :     }
    1044                 :       1513 :   comp->finalized = true;
    1045                 :            : }
    1046                 :            : 
    1047                 :            : 
    1048                 :            : /* Generate code equivalent to
    1049                 :            :    CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
    1050                 :            :                      + offset, c_ptr), ptr).  */
    1051                 :            : 
    1052                 :            : static gfc_code *
    1053                 :       1575 : finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
    1054                 :            :                          gfc_expr *offset, gfc_namespace *sub_ns)
    1055                 :            : {
    1056                 :       1575 :   gfc_code *block;
    1057                 :       1575 :   gfc_expr *expr, *expr2;
    1058                 :            : 
    1059                 :            :   /* C_F_POINTER().  */
    1060                 :       1575 :   block = gfc_get_code (EXEC_CALL);
    1061                 :       1575 :   gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
    1062                 :       1575 :   block->resolved_sym = block->symtree->n.sym;
    1063                 :       1575 :   block->resolved_sym->attr.flavor = FL_PROCEDURE;
    1064                 :       1575 :   block->resolved_sym->attr.intrinsic = 1;
    1065                 :       1575 :   block->resolved_sym->attr.subroutine = 1;
    1066                 :       1575 :   block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
    1067                 :       1575 :   block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
    1068                 :       1575 :   block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
    1069                 :       1575 :   gfc_commit_symbol (block->resolved_sym);
    1070                 :            : 
    1071                 :            :   /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t).  */
    1072                 :       1575 :   block->ext.actual = gfc_get_actual_arglist ();
    1073                 :       1575 :   block->ext.actual->next = gfc_get_actual_arglist ();
    1074                 :       1575 :   block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
    1075                 :            :                                                     NULL, 0);
    1076                 :       1575 :   block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE.  */
    1077                 :            : 
    1078                 :            :   /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t).  */
    1079                 :            : 
    1080                 :            :   /* TRANSFER's first argument: C_LOC (array).  */
    1081                 :       1575 :   expr = gfc_get_expr ();
    1082                 :       1575 :   expr->expr_type = EXPR_FUNCTION;
    1083                 :       1575 :   gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
    1084                 :       1575 :   expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
    1085                 :       1575 :   expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
    1086                 :       1575 :   expr->symtree->n.sym->attr.intrinsic = 1;
    1087                 :       1575 :   expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
    1088                 :       1575 :   expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
    1089                 :       1575 :   expr->value.function.actual = gfc_get_actual_arglist ();
    1090                 :       1575 :   expr->value.function.actual->expr
    1091                 :       1575 :             = gfc_lval_expr_from_sym (array);
    1092                 :       1575 :   expr->symtree->n.sym->result = expr->symtree->n.sym;
    1093                 :       1575 :   gfc_commit_symbol (expr->symtree->n.sym);
    1094                 :       1575 :   expr->ts.type = BT_INTEGER;
    1095                 :       1575 :   expr->ts.kind = gfc_index_integer_kind;
    1096                 :       1575 :   expr->where = gfc_current_locus;
    1097                 :            : 
    1098                 :            :   /* TRANSFER.  */
    1099                 :       1575 :   expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
    1100                 :            :                                     gfc_current_locus, 3, expr,
    1101                 :            :                                     gfc_get_int_expr (gfc_index_integer_kind,
    1102                 :            :                                                       NULL, 0), NULL);
    1103                 :       1575 :   expr2->ts.type = BT_INTEGER;
    1104                 :       1575 :   expr2->ts.kind = gfc_index_integer_kind;
    1105                 :            : 
    1106                 :            :   /* <array addr> + <offset>.  */
    1107                 :       1575 :   block->ext.actual->expr = gfc_get_expr ();
    1108                 :       1575 :   block->ext.actual->expr->expr_type = EXPR_OP;
    1109                 :       1575 :   block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
    1110                 :       1575 :   block->ext.actual->expr->value.op.op1 = expr2;
    1111                 :       1575 :   block->ext.actual->expr->value.op.op2 = offset;
    1112                 :       1575 :   block->ext.actual->expr->ts = expr->ts;
    1113                 :       1575 :   block->ext.actual->expr->where = gfc_current_locus;
    1114                 :            : 
    1115                 :            :   /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
    1116                 :       1575 :   block->ext.actual->next = gfc_get_actual_arglist ();
    1117                 :       1575 :   block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
    1118                 :       1575 :   block->ext.actual->next->next = gfc_get_actual_arglist ();
    1119                 :            : 
    1120                 :       1575 :   return block;
    1121                 :            : }
    1122                 :            : 
    1123                 :            : 
    1124                 :            : /* Calculates the offset to the (idx+1)th element of an array, taking the
    1125                 :            :    stride into account. It generates the code:
    1126                 :            :      offset = 0
    1127                 :            :      do idx2 = 1, rank
    1128                 :            :        offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
    1129                 :            :      end do
    1130                 :            :      offset = offset * byte_stride.  */
    1131                 :            : 
    1132                 :            : static gfc_code*
    1133                 :       1439 : finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
    1134                 :            :                          gfc_symbol *strides, gfc_symbol *sizes,
    1135                 :            :                          gfc_symbol *byte_stride, gfc_expr *rank,
    1136                 :            :                          gfc_code *block, gfc_namespace *sub_ns)
    1137                 :            : {
    1138                 :       1439 :   gfc_iterator *iter;
    1139                 :       1439 :   gfc_expr *expr, *expr2;
    1140                 :            : 
    1141                 :            :   /* offset = 0.  */
    1142                 :       1439 :   block->next = gfc_get_code (EXEC_ASSIGN);
    1143                 :       1439 :   block = block->next;
    1144                 :       1439 :   block->expr1 = gfc_lval_expr_from_sym (offset);
    1145                 :       1439 :   block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1146                 :            : 
    1147                 :            :   /* Create loop.  */
    1148                 :       1439 :   iter = gfc_get_iterator ();
    1149                 :       1439 :   iter->var = gfc_lval_expr_from_sym (idx2);
    1150                 :       1439 :   iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1151                 :       1439 :   iter->end = gfc_copy_expr (rank);
    1152                 :       1439 :   iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1153                 :       1439 :   block->next = gfc_get_code (EXEC_DO);
    1154                 :       1439 :   block = block->next;
    1155                 :       1439 :   block->ext.iterator = iter;
    1156                 :       1439 :   block->block = gfc_get_code (EXEC_DO);
    1157                 :            : 
    1158                 :            :   /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
    1159                 :            :                                   * strides(idx2).  */
    1160                 :            : 
    1161                 :            :   /* mod (idx, sizes(idx2)).  */
    1162                 :       1439 :   expr = gfc_lval_expr_from_sym (sizes);
    1163                 :       1439 :   expr->ref = gfc_get_ref ();
    1164                 :       1439 :   expr->ref->type = REF_ARRAY;
    1165                 :       1439 :   expr->ref->u.ar.as = sizes->as;
    1166                 :       1439 :   expr->ref->u.ar.type = AR_ELEMENT;
    1167                 :       1439 :   expr->ref->u.ar.dimen = 1;
    1168                 :       1439 :   expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1169                 :       1439 :   expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
    1170                 :       1439 :   expr->where = sizes->declared_at;
    1171                 :            : 
    1172                 :       1439 :   expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
    1173                 :            :                                    gfc_current_locus, 2,
    1174                 :            :                                    gfc_lval_expr_from_sym (idx), expr);
    1175                 :       1439 :   expr->ts = idx->ts;
    1176                 :            : 
    1177                 :            :   /* (...) / sizes(idx2-1).  */
    1178                 :       1439 :   expr2 = gfc_get_expr ();
    1179                 :       1439 :   expr2->expr_type = EXPR_OP;
    1180                 :       1439 :   expr2->value.op.op = INTRINSIC_DIVIDE;
    1181                 :       1439 :   expr2->value.op.op1 = expr;
    1182                 :       1439 :   expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
    1183                 :       1439 :   expr2->value.op.op2->ref = gfc_get_ref ();
    1184                 :       1439 :   expr2->value.op.op2->ref->type = REF_ARRAY;
    1185                 :       1439 :   expr2->value.op.op2->ref->u.ar.as = sizes->as;
    1186                 :       1439 :   expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
    1187                 :       1439 :   expr2->value.op.op2->ref->u.ar.dimen = 1;
    1188                 :       1439 :   expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1189                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
    1190                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
    1191                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
    1192                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
    1193                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
    1194                 :       1439 :         = gfc_lval_expr_from_sym (idx2);
    1195                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
    1196                 :       1439 :         = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1197                 :       1439 :   expr2->value.op.op2->ref->u.ar.start[0]->ts
    1198                 :       1439 :         = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
    1199                 :       1439 :   expr2->ts = idx->ts;
    1200                 :       1439 :   expr2->where = gfc_current_locus;
    1201                 :            : 
    1202                 :            :   /* ... * strides(idx2).  */
    1203                 :       1439 :   expr = gfc_get_expr ();
    1204                 :       1439 :   expr->expr_type = EXPR_OP;
    1205                 :       1439 :   expr->value.op.op = INTRINSIC_TIMES;
    1206                 :       1439 :   expr->value.op.op1 = expr2;
    1207                 :       1439 :   expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
    1208                 :       1439 :   expr->value.op.op2->ref = gfc_get_ref ();
    1209                 :       1439 :   expr->value.op.op2->ref->type = REF_ARRAY;
    1210                 :       1439 :   expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
    1211                 :       1439 :   expr->value.op.op2->ref->u.ar.dimen = 1;
    1212                 :       1439 :   expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1213                 :       1439 :   expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
    1214                 :       1439 :   expr->value.op.op2->ref->u.ar.as = strides->as;
    1215                 :       1439 :   expr->ts = idx->ts;
    1216                 :       1439 :   expr->where = gfc_current_locus;
    1217                 :            : 
    1218                 :            :   /* offset = offset + ...  */
    1219                 :       1439 :   block->block->next = gfc_get_code (EXEC_ASSIGN);
    1220                 :       1439 :   block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
    1221                 :       1439 :   block->block->next->expr2 = gfc_get_expr ();
    1222                 :       1439 :   block->block->next->expr2->expr_type = EXPR_OP;
    1223                 :       1439 :   block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
    1224                 :       1439 :   block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
    1225                 :       1439 :   block->block->next->expr2->value.op.op2 = expr;
    1226                 :       1439 :   block->block->next->expr2->ts = idx->ts;
    1227                 :       1439 :   block->block->next->expr2->where = gfc_current_locus;
    1228                 :            : 
    1229                 :            :   /* After the loop:  offset = offset * byte_stride.  */
    1230                 :       1439 :   block->next = gfc_get_code (EXEC_ASSIGN);
    1231                 :       1439 :   block = block->next;
    1232                 :       1439 :   block->expr1 = gfc_lval_expr_from_sym (offset);
    1233                 :       1439 :   block->expr2 = gfc_get_expr ();
    1234                 :       1439 :   block->expr2->expr_type = EXPR_OP;
    1235                 :       1439 :   block->expr2->value.op.op = INTRINSIC_TIMES;
    1236                 :       1439 :   block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
    1237                 :       1439 :   block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
    1238                 :       1439 :   block->expr2->ts = block->expr2->value.op.op1->ts;
    1239                 :       1439 :   block->expr2->where = gfc_current_locus;
    1240                 :       1439 :   return block;
    1241                 :            : }
    1242                 :            : 
    1243                 :            : 
    1244                 :            : /* Insert code of the following form:
    1245                 :            : 
    1246                 :            :    block
    1247                 :            :      integer(c_intptr_t) :: i
    1248                 :            : 
    1249                 :            :      if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
    1250                 :            :           && (is_contiguous || !final_rank3->attr.contiguous
    1251                 :            :               || final_rank3->as->type != AS_ASSUMED_SHAPE))
    1252                 :            :          || 0 == STORAGE_SIZE (array)) then
    1253                 :            :        call final_rank3 (array)
    1254                 :            :      else
    1255                 :            :        block
    1256                 :            :          integer(c_intptr_t) :: offset, j
    1257                 :            :          type(t) :: tmp(shape (array))
    1258                 :            : 
    1259                 :            :          do i = 0, size (array)-1
    1260                 :            :            offset = obtain_offset(i, strides, sizes, byte_stride)
    1261                 :            :            addr = transfer (c_loc (array), addr) + offset
    1262                 :            :            call c_f_pointer (transfer (addr, cptr), ptr)
    1263                 :            : 
    1264                 :            :            addr = transfer (c_loc (tmp), addr)
    1265                 :            :                             + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
    1266                 :            :            call c_f_pointer (transfer (addr, cptr), ptr2)
    1267                 :            :            ptr2 = ptr
    1268                 :            :          end do
    1269                 :            :          call final_rank3 (tmp)
    1270                 :            :        end block
    1271                 :            :      end if
    1272                 :            :    block  */
    1273                 :            : 
    1274                 :            : static void
    1275                 :         77 : finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
    1276                 :            :                               gfc_symbol *array, gfc_symbol *byte_stride,
    1277                 :            :                               gfc_symbol *idx, gfc_symbol *ptr,
    1278                 :            :                               gfc_symbol *nelem,
    1279                 :            :                               gfc_symbol *strides, gfc_symbol *sizes,
    1280                 :            :                               gfc_symbol *idx2, gfc_symbol *offset,
    1281                 :            :                               gfc_symbol *is_contiguous, gfc_expr *rank,
    1282                 :            :                               gfc_namespace *sub_ns)
    1283                 :            : {
    1284                 :         77 :   gfc_symbol *tmp_array, *ptr2;
    1285                 :         77 :   gfc_expr *size_expr, *offset2, *expr;
    1286                 :         77 :   gfc_namespace *ns;
    1287                 :         77 :   gfc_iterator *iter;
    1288                 :         77 :   gfc_code *block2;
    1289                 :         77 :   int i;
    1290                 :            : 
    1291                 :         77 :   block->next = gfc_get_code (EXEC_IF);
    1292                 :         77 :   block = block->next;
    1293                 :            : 
    1294                 :         77 :   block->block = gfc_get_code (EXEC_IF);
    1295                 :         77 :   block = block->block;
    1296                 :            : 
    1297                 :            :   /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
    1298                 :         77 :   size_expr = gfc_get_expr ();
    1299                 :         77 :   size_expr->where = gfc_current_locus;
    1300                 :         77 :   size_expr->expr_type = EXPR_OP;
    1301                 :         77 :   size_expr->value.op.op = INTRINSIC_DIVIDE;
    1302                 :            : 
    1303                 :            :   /* STORAGE_SIZE (array,kind=c_intptr_t).  */
    1304                 :         77 :   size_expr->value.op.op1
    1305                 :         77 :         = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
    1306                 :            :                                     "storage_size", gfc_current_locus, 2,
    1307                 :            :                                     gfc_lval_expr_from_sym (array),
    1308                 :            :                                     gfc_get_int_expr (gfc_index_integer_kind,
    1309                 :            :                                                       NULL, 0));
    1310                 :            : 
    1311                 :            :   /* NUMERIC_STORAGE_SIZE.  */
    1312                 :         77 :   size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
    1313                 :            :                                               gfc_character_storage_size);
    1314                 :         77 :   size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
    1315                 :         77 :   size_expr->ts = size_expr->value.op.op1->ts;
    1316                 :            : 
    1317                 :            :   /* IF condition: (stride == size_expr
    1318                 :            :                     && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
    1319                 :            :                         || is_contiguous)
    1320                 :            :                    || 0 == size_expr.  */
    1321                 :         77 :   block->expr1 = gfc_get_expr ();
    1322                 :         77 :   block->expr1->ts.type = BT_LOGICAL;
    1323                 :         77 :   block->expr1->ts.kind = gfc_default_logical_kind;
    1324                 :         77 :   block->expr1->expr_type = EXPR_OP;
    1325                 :         77 :   block->expr1->where = gfc_current_locus;
    1326                 :            : 
    1327                 :         77 :   block->expr1->value.op.op = INTRINSIC_OR;
    1328                 :            : 
    1329                 :            :   /* byte_stride == size_expr */
    1330                 :         77 :   expr = gfc_get_expr ();
    1331                 :         77 :   expr->ts.type = BT_LOGICAL;
    1332                 :         77 :   expr->ts.kind = gfc_default_logical_kind;
    1333                 :         77 :   expr->expr_type = EXPR_OP;
    1334                 :         77 :   expr->where = gfc_current_locus;
    1335                 :         77 :   expr->value.op.op = INTRINSIC_EQ;
    1336                 :         77 :   expr->value.op.op1
    1337                 :         77 :         = gfc_lval_expr_from_sym (byte_stride);
    1338                 :         77 :   expr->value.op.op2 = size_expr;
    1339                 :            : 
    1340                 :            :   /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
    1341                 :            :      add is_contiguous check.  */
    1342                 :            : 
    1343                 :         77 :   if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
    1344                 :         57 :       || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
    1345                 :            :     {
    1346                 :         26 :       gfc_expr *expr2;
    1347                 :         26 :       expr2 = gfc_get_expr ();
    1348                 :         26 :       expr2->ts.type = BT_LOGICAL;
    1349                 :         26 :       expr2->ts.kind = gfc_default_logical_kind;
    1350                 :         26 :       expr2->expr_type = EXPR_OP;
    1351                 :         26 :       expr2->where = gfc_current_locus;
    1352                 :         26 :       expr2->value.op.op = INTRINSIC_AND;
    1353                 :         26 :       expr2->value.op.op1 = expr;
    1354                 :         26 :       expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
    1355                 :         26 :       expr = expr2;
    1356                 :            :     }
    1357                 :            : 
    1358                 :         77 :   block->expr1->value.op.op1 = expr;
    1359                 :            : 
    1360                 :            :   /* 0 == size_expr */
    1361                 :         77 :   block->expr1->value.op.op2 = gfc_get_expr ();
    1362                 :         77 :   block->expr1->value.op.op2->ts.type = BT_LOGICAL;
    1363                 :         77 :   block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
    1364                 :         77 :   block->expr1->value.op.op2->expr_type = EXPR_OP;
    1365                 :         77 :   block->expr1->value.op.op2->where = gfc_current_locus;
    1366                 :         77 :   block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
    1367                 :        154 :   block->expr1->value.op.op2->value.op.op1 =
    1368                 :         77 :                         gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1369                 :         77 :   block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
    1370                 :            : 
    1371                 :            :   /* IF body: call final subroutine.  */
    1372                 :         77 :   block->next = gfc_get_code (EXEC_CALL);
    1373                 :         77 :   block->next->symtree = fini->proc_tree;
    1374                 :         77 :   block->next->resolved_sym = fini->proc_tree->n.sym;
    1375                 :         77 :   block->next->ext.actual = gfc_get_actual_arglist ();
    1376                 :         77 :   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
    1377                 :         77 :   block->next->ext.actual->next = gfc_get_actual_arglist ();
    1378                 :         77 :   block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
    1379                 :            : 
    1380                 :            :   /* ELSE.  */
    1381                 :            : 
    1382                 :         77 :   block->block = gfc_get_code (EXEC_IF);
    1383                 :         77 :   block = block->block;
    1384                 :            : 
    1385                 :            :   /* BLOCK ... END BLOCK.  */
    1386                 :         77 :   block->next = gfc_get_code (EXEC_BLOCK);
    1387                 :         77 :   block = block->next;
    1388                 :            : 
    1389                 :         77 :   ns = gfc_build_block_ns (sub_ns);
    1390                 :         77 :   block->ext.block.ns = ns;
    1391                 :         77 :   block->ext.block.assoc = NULL;
    1392                 :            : 
    1393                 :         77 :   gfc_get_symbol ("ptr2", ns, &ptr2);
    1394                 :         77 :   ptr2->ts.type = BT_DERIVED;
    1395                 :         77 :   ptr2->ts.u.derived = array->ts.u.derived;
    1396                 :         77 :   ptr2->attr.flavor = FL_VARIABLE;
    1397                 :         77 :   ptr2->attr.pointer = 1;
    1398                 :         77 :   ptr2->attr.artificial = 1;
    1399                 :         77 :   gfc_set_sym_referenced (ptr2);
    1400                 :         77 :   gfc_commit_symbol (ptr2);
    1401                 :            : 
    1402                 :         77 :   gfc_get_symbol ("tmp_array", ns, &tmp_array);
    1403                 :         77 :   tmp_array->ts.type = BT_DERIVED;
    1404                 :         77 :   tmp_array->ts.u.derived = array->ts.u.derived;
    1405                 :         77 :   tmp_array->attr.flavor = FL_VARIABLE;
    1406                 :         77 :   tmp_array->attr.dimension = 1;
    1407                 :         77 :   tmp_array->attr.artificial = 1;
    1408                 :         77 :   tmp_array->as = gfc_get_array_spec();
    1409                 :         77 :   tmp_array->attr.intent = INTENT_INOUT;
    1410                 :         77 :   tmp_array->as->type = AS_EXPLICIT;
    1411                 :         77 :   tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
    1412                 :            : 
    1413                 :        228 :   for (i = 0; i < tmp_array->as->rank; i++)
    1414                 :            :     {
    1415                 :        151 :       gfc_expr *shape_expr;
    1416                 :        151 :       tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
    1417                 :            :                                                   NULL, 1);
    1418                 :            :       /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind).  */
    1419                 :        151 :       shape_expr
    1420                 :        302 :         = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
    1421                 :            :                                     gfc_current_locus, 3,
    1422                 :            :                                     gfc_lval_expr_from_sym (array),
    1423                 :            :                                     gfc_get_int_expr (gfc_default_integer_kind,
    1424                 :        151 :                                                       NULL, i+1),
    1425                 :            :                                     gfc_get_int_expr (gfc_default_integer_kind,
    1426                 :            :                                                       NULL,
    1427                 :            :                                                       gfc_index_integer_kind));
    1428                 :        151 :       shape_expr->ts.kind = gfc_index_integer_kind;
    1429                 :        151 :       tmp_array->as->upper[i] = shape_expr;
    1430                 :            :     }
    1431                 :         77 :   gfc_set_sym_referenced (tmp_array);
    1432                 :         77 :   gfc_commit_symbol (tmp_array);
    1433                 :            : 
    1434                 :            :   /* Create loop.  */
    1435                 :         77 :   iter = gfc_get_iterator ();
    1436                 :         77 :   iter->var = gfc_lval_expr_from_sym (idx);
    1437                 :         77 :   iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1438                 :         77 :   iter->end = gfc_lval_expr_from_sym (nelem);
    1439                 :         77 :   iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1440                 :            : 
    1441                 :         77 :   block = gfc_get_code (EXEC_DO);
    1442                 :         77 :   ns->code = block;
    1443                 :         77 :   block->ext.iterator = iter;
    1444                 :         77 :   block->block = gfc_get_code (EXEC_DO);
    1445                 :            : 
    1446                 :            :   /* Offset calculation for the new array: idx * size of type (in bytes).  */
    1447                 :         77 :   offset2 = gfc_get_expr ();
    1448                 :         77 :   offset2->expr_type = EXPR_OP;
    1449                 :         77 :   offset2->where = gfc_current_locus;
    1450                 :         77 :   offset2->value.op.op = INTRINSIC_TIMES;
    1451                 :         77 :   offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
    1452                 :         77 :   offset2->value.op.op2 = gfc_copy_expr (size_expr);
    1453                 :         77 :   offset2->ts = byte_stride->ts;
    1454                 :            : 
    1455                 :            :   /* Offset calculation of "array".  */
    1456                 :         77 :   block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
    1457                 :            :                                     byte_stride, rank, block->block, sub_ns);
    1458                 :            : 
    1459                 :            :   /* Create code for
    1460                 :            :      CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
    1461                 :            :                        + idx * stride, c_ptr), ptr).  */
    1462                 :         77 :   block2->next = finalization_scalarizer (array, ptr,
    1463                 :            :                                           gfc_lval_expr_from_sym (offset),
    1464                 :            :                                           sub_ns);
    1465                 :         77 :   block2 = block2->next;
    1466                 :         77 :   block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
    1467                 :         77 :   block2 = block2->next;
    1468                 :            : 
    1469                 :            :   /* ptr2 = ptr.  */
    1470                 :         77 :   block2->next = gfc_get_code (EXEC_ASSIGN);
    1471                 :         77 :   block2 = block2->next;
    1472                 :         77 :   block2->expr1 = gfc_lval_expr_from_sym (ptr2);
    1473                 :         77 :   block2->expr2 = gfc_lval_expr_from_sym (ptr);
    1474                 :            : 
    1475                 :            :   /* Call now the user's final subroutine.  */
    1476                 :         77 :   block->next  = gfc_get_code (EXEC_CALL);
    1477                 :         77 :   block = block->next;
    1478                 :         77 :   block->symtree = fini->proc_tree;
    1479                 :         77 :   block->resolved_sym = fini->proc_tree->n.sym;
    1480                 :         77 :   block->ext.actual = gfc_get_actual_arglist ();
    1481                 :         77 :   block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
    1482                 :            : 
    1483                 :         77 :   if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
    1484                 :         18 :     return;
    1485                 :            : 
    1486                 :            :   /* Copy back.  */
    1487                 :            : 
    1488                 :            :   /* Loop.  */
    1489                 :         59 :   iter = gfc_get_iterator ();
    1490                 :         59 :   iter->var = gfc_lval_expr_from_sym (idx);
    1491                 :         59 :   iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1492                 :         59 :   iter->end = gfc_lval_expr_from_sym (nelem);
    1493                 :         59 :   iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1494                 :            : 
    1495                 :         59 :   block->next = gfc_get_code (EXEC_DO);
    1496                 :         59 :   block = block->next;
    1497                 :         59 :   block->ext.iterator = iter;
    1498                 :         59 :   block->block = gfc_get_code (EXEC_DO);
    1499                 :            : 
    1500                 :            :   /* Offset calculation of "array".  */
    1501                 :         59 :   block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
    1502                 :            :                                     byte_stride, rank, block->block, sub_ns);
    1503                 :            : 
    1504                 :            :   /* Create code for
    1505                 :            :      CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
    1506                 :            :                        + offset, c_ptr), ptr).  */
    1507                 :         59 :   block2->next = finalization_scalarizer (array, ptr,
    1508                 :            :                                           gfc_lval_expr_from_sym (offset),
    1509                 :            :                                           sub_ns);
    1510                 :         59 :   block2 = block2->next;
    1511                 :         59 :   block2->next = finalization_scalarizer (tmp_array, ptr2,
    1512                 :            :                                           gfc_copy_expr (offset2), sub_ns);
    1513                 :         59 :   block2 = block2->next;
    1514                 :            : 
    1515                 :            :   /* ptr = ptr2.  */
    1516                 :         59 :   block2->next = gfc_get_code (EXEC_ASSIGN);
    1517                 :         59 :   block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
    1518                 :         59 :   block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
    1519                 :            : }
    1520                 :            : 
    1521                 :            : 
    1522                 :            : /* Generate the finalization/polymorphic freeing wrapper subroutine for the
    1523                 :            :    derived type "derived". The function first calls the approriate FINAL
    1524                 :            :    subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
    1525                 :            :    components (but not the inherited ones). Last, it calls the wrapper
    1526                 :            :    subroutine of the parent. The generated wrapper procedure takes as argument
    1527                 :            :    an assumed-rank array.
    1528                 :            :    If neither allocatable components nor FINAL subroutines exists, the vtab
    1529                 :            :    will contain a NULL pointer.
    1530                 :            :    The generated function has the form
    1531                 :            :      _final(assumed-rank array, stride, skip_corarray)
    1532                 :            :    where the array has to be contiguous (except of the lowest dimension). The
    1533                 :            :    stride (in bytes) is used to allow different sizes for ancestor types by
    1534                 :            :    skipping over the additionally added components in the scalarizer. If
    1535                 :            :    "fini_coarray" is false, coarray components are not finalized to allow for
    1536                 :            :    the correct semantic with intrinsic assignment.  */
    1537                 :            : 
    1538                 :            : static void
    1539                 :       6175 : generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
    1540                 :            :                                const char *tname, gfc_component *vtab_final)
    1541                 :            : {
    1542                 :       6175 :   gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
    1543                 :       6175 :   gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
    1544                 :       6175 :   gfc_component *comp;
    1545                 :       6175 :   gfc_namespace *sub_ns;
    1546                 :       6175 :   gfc_code *last_code, *block;
    1547                 :       6175 :   char *name;
    1548                 :       6175 :   bool finalizable_comp = false;
    1549                 :       6175 :   bool expr_null_wrapper = false;
    1550                 :       6175 :   gfc_expr *ancestor_wrapper = NULL, *rank;
    1551                 :       6175 :   gfc_iterator *iter;
    1552                 :            : 
    1553                 :       6175 :   if (derived->attr.unlimited_polymorphic)
    1554                 :            :     {
    1555                 :        359 :       vtab_final->initializer = gfc_get_null_expr (NULL);
    1556                 :       4791 :       return;
    1557                 :            :     }
    1558                 :            : 
    1559                 :            :   /* Search for the ancestor's finalizers.  */
    1560                 :       1032 :   if (derived->attr.extension && derived->components
    1561                 :       6848 :       && (!derived->components->ts.u.derived->attr.abstract
    1562                 :        198 :           || has_finalizer_component (derived)))
    1563                 :            :     {
    1564                 :        834 :       gfc_symbol *vtab;
    1565                 :        834 :       gfc_component *comp;
    1566                 :            : 
    1567                 :        834 :       vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
    1568                 :       5004 :       for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
    1569                 :       5004 :         if (comp->name[0] == '_' && comp->name[1] == 'f')
    1570                 :            :           {
    1571                 :        834 :             ancestor_wrapper = comp->initializer;
    1572                 :        834 :             break;
    1573                 :            :           }
    1574                 :            :     }
    1575                 :            : 
    1576                 :            :   /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
    1577                 :            :      components: Return a NULL() expression; we defer this a bit to have
    1578                 :            :      an interface declaration.  */
    1579                 :        834 :   if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
    1580                 :       5700 :       && !derived->attr.alloc_comp
    1581                 :       4502 :       && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
    1582                 :       5229 :       && !has_finalizer_component (derived))
    1583                 :            :     expr_null_wrapper = true;
    1584                 :            :   else
    1585                 :            :     /* Check whether there are new allocatable components.  */
    1586                 :       3748 :     for (comp = derived->components; comp; comp = comp->next)
    1587                 :            :       {
    1588                 :       2327 :         if (comp == derived->components && derived->attr.extension
    1589                 :        233 :             && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
    1590                 :        116 :         continue;
    1591                 :            : 
    1592                 :       2211 :         finalizable_comp |= comp_is_finalizable (comp);
    1593                 :            :       }
    1594                 :            : 
    1595                 :            :   /* If there is no new finalizer and no new allocatable, return with
    1596                 :            :      an expr to the ancestor's one.  */
    1597                 :       5816 :   if (!expr_null_wrapper && !finalizable_comp
    1598                 :        168 :       && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
    1599                 :            :     {
    1600                 :         37 :       gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
    1601                 :            :                   && ancestor_wrapper->expr_type == EXPR_VARIABLE);
    1602                 :         37 :       vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
    1603                 :         37 :       vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
    1604                 :         37 :       return;
    1605                 :            :     }
    1606                 :            : 
    1607                 :            :   /* We now create a wrapper, which does the following:
    1608                 :            :      1. Call the suitable finalization subroutine for this type
    1609                 :            :      2. Loop over all noninherited allocatable components and noninherited
    1610                 :            :         components with allocatable components and DEALLOCATE those; this will
    1611                 :            :         take care of finalizers, coarray deregistering and allocatable
    1612                 :            :         nested components.
    1613                 :            :      3. Call the ancestor's finalizer.  */
    1614                 :            : 
    1615                 :            :   /* Declare the wrapper function; it takes an assumed-rank array
    1616                 :            :      and a VALUE logical as arguments.  */
    1617                 :            : 
    1618                 :            :   /* Set up the namespace.  */
    1619                 :       5779 :   sub_ns = gfc_get_namespace (ns, 0);
    1620                 :       5779 :   sub_ns->sibling = ns->contained;
    1621                 :       5779 :   if (!expr_null_wrapper)
    1622                 :       1384 :     ns->contained = sub_ns;
    1623                 :       5779 :   sub_ns->resolved = 1;
    1624                 :            : 
    1625                 :            :   /* Set up the procedure symbol.  */
    1626                 :       5779 :   name = xasprintf ("__final_%s", tname);
    1627                 :       5779 :   gfc_get_symbol (name, sub_ns, &final);
    1628                 :       5779 :   sub_ns->proc_name = final;
    1629                 :       5779 :   final->attr.flavor = FL_PROCEDURE;
    1630                 :       5779 :   final->attr.function = 1;
    1631                 :       5779 :   final->attr.pure = 0;
    1632                 :       5779 :   final->attr.recursive = 1;
    1633                 :       5779 :   final->result = final;
    1634                 :       5779 :   final->ts.type = BT_INTEGER;
    1635                 :       5779 :   final->ts.kind = 4;
    1636                 :       5779 :   final->attr.artificial = 1;
    1637                 :       5779 :   final->attr.always_explicit = 1;
    1638                 :       5779 :   final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
    1639                 :       5779 :   if (ns->proc_name->attr.flavor == FL_MODULE)
    1640                 :       4600 :     final->module = ns->proc_name->name;
    1641                 :       5779 :   gfc_set_sym_referenced (final);
    1642                 :       5779 :   gfc_commit_symbol (final);
    1643                 :            : 
    1644                 :            :   /* Set up formal argument.  */
    1645                 :       5779 :   gfc_get_symbol ("array", sub_ns, &array);
    1646                 :       5779 :   array->ts.type = BT_DERIVED;
    1647                 :       5779 :   array->ts.u.derived = derived;
    1648                 :       5779 :   array->attr.flavor = FL_VARIABLE;
    1649                 :       5779 :   array->attr.dummy = 1;
    1650                 :       5779 :   array->attr.contiguous = 1;
    1651                 :       5779 :   array->attr.dimension = 1;
    1652                 :       5779 :   array->attr.artificial = 1;
    1653                 :       5779 :   array->as = gfc_get_array_spec();
    1654                 :       5779 :   array->as->type = AS_ASSUMED_RANK;
    1655                 :       5779 :   array->as->rank = -1;
    1656                 :       5779 :   array->attr.intent = INTENT_INOUT;
    1657                 :       5779 :   gfc_set_sym_referenced (array);
    1658                 :       5779 :   final->formal = gfc_get_formal_arglist ();
    1659                 :       5779 :   final->formal->sym = array;
    1660                 :       5779 :   gfc_commit_symbol (array);
    1661                 :            : 
    1662                 :            :   /* Set up formal argument.  */
    1663                 :       5779 :   gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
    1664                 :       5779 :   byte_stride->ts.type = BT_INTEGER;
    1665                 :       5779 :   byte_stride->ts.kind = gfc_index_integer_kind;
    1666                 :       5779 :   byte_stride->attr.flavor = FL_VARIABLE;
    1667                 :       5779 :   byte_stride->attr.dummy = 1;
    1668                 :       5779 :   byte_stride->attr.value = 1;
    1669                 :       5779 :   byte_stride->attr.artificial = 1;
    1670                 :       5779 :   gfc_set_sym_referenced (byte_stride);
    1671                 :       5779 :   final->formal->next = gfc_get_formal_arglist ();
    1672                 :       5779 :   final->formal->next->sym = byte_stride;
    1673                 :       5779 :   gfc_commit_symbol (byte_stride);
    1674                 :            : 
    1675                 :            :   /* Set up formal argument.  */
    1676                 :       5779 :   gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
    1677                 :       5779 :   fini_coarray->ts.type = BT_LOGICAL;
    1678                 :       5779 :   fini_coarray->ts.kind = 1;
    1679                 :       5779 :   fini_coarray->attr.flavor = FL_VARIABLE;
    1680                 :       5779 :   fini_coarray->attr.dummy = 1;
    1681                 :       5779 :   fini_coarray->attr.value = 1;
    1682                 :       5779 :   fini_coarray->attr.artificial = 1;
    1683                 :       5779 :   gfc_set_sym_referenced (fini_coarray);
    1684                 :       5779 :   final->formal->next->next = gfc_get_formal_arglist ();
    1685                 :       5779 :   final->formal->next->next->sym = fini_coarray;
    1686                 :       5779 :   gfc_commit_symbol (fini_coarray);
    1687                 :            : 
    1688                 :            :   /* Return with a NULL() expression but with an interface which has
    1689                 :            :      the formal arguments.  */
    1690                 :       5779 :   if (expr_null_wrapper)
    1691                 :            :     {
    1692                 :       4395 :       vtab_final->initializer = gfc_get_null_expr (NULL);
    1693                 :       4395 :       vtab_final->ts.interface = final;
    1694                 :       4395 :       return;
    1695                 :            :     }
    1696                 :            : 
    1697                 :            :   /* Local variables.  */
    1698                 :            : 
    1699                 :       1384 :   gfc_get_symbol ("idx", sub_ns, &idx);
    1700                 :       1384 :   idx->ts.type = BT_INTEGER;
    1701                 :       1384 :   idx->ts.kind = gfc_index_integer_kind;
    1702                 :       1384 :   idx->attr.flavor = FL_VARIABLE;
    1703                 :       1384 :   idx->attr.artificial = 1;
    1704                 :       1384 :   gfc_set_sym_referenced (idx);
    1705                 :       1384 :   gfc_commit_symbol (idx);
    1706                 :            : 
    1707                 :       1384 :   gfc_get_symbol ("idx2", sub_ns, &idx2);
    1708                 :       1384 :   idx2->ts.type = BT_INTEGER;
    1709                 :       1384 :   idx2->ts.kind = gfc_index_integer_kind;
    1710                 :       1384 :   idx2->attr.flavor = FL_VARIABLE;
    1711                 :       1384 :   idx2->attr.artificial = 1;
    1712                 :       1384 :   gfc_set_sym_referenced (idx2);
    1713                 :       1384 :   gfc_commit_symbol (idx2);
    1714                 :            : 
    1715                 :       1384 :   gfc_get_symbol ("offset", sub_ns, &offset);
    1716                 :       1384 :   offset->ts.type = BT_INTEGER;
    1717                 :       1384 :   offset->ts.kind = gfc_index_integer_kind;
    1718                 :       1384 :   offset->attr.flavor = FL_VARIABLE;
    1719                 :       1384 :   offset->attr.artificial = 1;
    1720                 :       1384 :   gfc_set_sym_referenced (offset);
    1721                 :       1384 :   gfc_commit_symbol (offset);
    1722                 :            : 
    1723                 :            :   /* Create RANK expression.  */
    1724                 :       1384 :   rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
    1725                 :            :                                    gfc_current_locus, 1,
    1726                 :            :                                    gfc_lval_expr_from_sym (array));
    1727                 :       1384 :   if (rank->ts.kind != idx->ts.kind)
    1728                 :       1384 :     gfc_convert_type_warn (rank, &idx->ts, 2, 0);
    1729                 :            : 
    1730                 :            :   /* Create is_contiguous variable.  */
    1731                 :       1384 :   gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
    1732                 :       1384 :   is_contiguous->ts.type = BT_LOGICAL;
    1733                 :       1384 :   is_contiguous->ts.kind = gfc_default_logical_kind;
    1734                 :       1384 :   is_contiguous->attr.flavor = FL_VARIABLE;
    1735                 :       1384 :   is_contiguous->attr.artificial = 1;
    1736                 :       1384 :   gfc_set_sym_referenced (is_contiguous);
    1737                 :       1384 :   gfc_commit_symbol (is_contiguous);
    1738                 :            : 
    1739                 :            :   /* Create "sizes(0..rank)" variable, which contains the multiplied
    1740                 :            :      up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
    1741                 :            :      sizes(2) = sizes(1) * extent(dim=2) etc.  */
    1742                 :       1384 :   gfc_get_symbol ("sizes", sub_ns, &sizes);
    1743                 :       1384 :   sizes->ts.type = BT_INTEGER;
    1744                 :       1384 :   sizes->ts.kind = gfc_index_integer_kind;
    1745                 :       1384 :   sizes->attr.flavor = FL_VARIABLE;
    1746                 :       1384 :   sizes->attr.dimension = 1;
    1747                 :       1384 :   sizes->attr.artificial = 1;
    1748                 :       1384 :   sizes->as = gfc_get_array_spec();
    1749                 :       1384 :   sizes->attr.intent = INTENT_INOUT;
    1750                 :       1384 :   sizes->as->type = AS_EXPLICIT;
    1751                 :       1384 :   sizes->as->rank = 1;
    1752                 :       1384 :   sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1753                 :       1384 :   sizes->as->upper[0] = gfc_copy_expr (rank);
    1754                 :       1384 :   gfc_set_sym_referenced (sizes);
    1755                 :       1384 :   gfc_commit_symbol (sizes);
    1756                 :            : 
    1757                 :            :   /* Create "strides(1..rank)" variable, which contains the strides per
    1758                 :            :      dimension.  */
    1759                 :       1384 :   gfc_get_symbol ("strides", sub_ns, &strides);
    1760                 :       1384 :   strides->ts.type = BT_INTEGER;
    1761                 :       1384 :   strides->ts.kind = gfc_index_integer_kind;
    1762                 :       1384 :   strides->attr.flavor = FL_VARIABLE;
    1763                 :       1384 :   strides->attr.dimension = 1;
    1764                 :       1384 :   strides->attr.artificial = 1;
    1765                 :       1384 :   strides->as = gfc_get_array_spec();
    1766                 :       1384 :   strides->attr.intent = INTENT_INOUT;
    1767                 :       1384 :   strides->as->type = AS_EXPLICIT;
    1768                 :       1384 :   strides->as->rank = 1;
    1769                 :       1384 :   strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1770                 :       1384 :   strides->as->upper[0] = gfc_copy_expr (rank);
    1771                 :       1384 :   gfc_set_sym_referenced (strides);
    1772                 :       1384 :   gfc_commit_symbol (strides);
    1773                 :            : 
    1774                 :            : 
    1775                 :            :   /* Set return value to 0.  */
    1776                 :       1384 :   last_code = gfc_get_code (EXEC_ASSIGN);
    1777                 :       1384 :   last_code->expr1 = gfc_lval_expr_from_sym (final);
    1778                 :       1384 :   last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
    1779                 :       1384 :   sub_ns->code = last_code;
    1780                 :            : 
    1781                 :            :   /* Set:  is_contiguous = .true.  */
    1782                 :       1384 :   last_code->next = gfc_get_code (EXEC_ASSIGN);
    1783                 :       1384 :   last_code = last_code->next;
    1784                 :       1384 :   last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
    1785                 :       1384 :   last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
    1786                 :            :                                            &gfc_current_locus, true);
    1787                 :            : 
    1788                 :            :   /* Set:  sizes(0) = 1.  */
    1789                 :       1384 :   last_code->next = gfc_get_code (EXEC_ASSIGN);
    1790                 :       1384 :   last_code = last_code->next;
    1791                 :       1384 :   last_code->expr1 = gfc_lval_expr_from_sym (sizes);
    1792                 :       1384 :   last_code->expr1->ref = gfc_get_ref ();
    1793                 :       1384 :   last_code->expr1->ref->type = REF_ARRAY;
    1794                 :       1384 :   last_code->expr1->ref->u.ar.type = AR_ELEMENT;
    1795                 :       1384 :   last_code->expr1->ref->u.ar.dimen = 1;
    1796                 :       1384 :   last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1797                 :       1384 :   last_code->expr1->ref->u.ar.start[0]
    1798                 :       1384 :                 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    1799                 :       1384 :   last_code->expr1->ref->u.ar.as = sizes->as;
    1800                 :       1384 :   last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
    1801                 :            : 
    1802                 :            :   /* Create:
    1803                 :            :      DO idx = 1, rank
    1804                 :            :        strides(idx) = _F._stride (array, dim=idx)
    1805                 :            :        sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
    1806                 :            :        if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
    1807                 :            :      END DO.  */
    1808                 :            : 
    1809                 :            :   /* Create loop.  */
    1810                 :       1384 :   iter = gfc_get_iterator ();
    1811                 :       1384 :   iter->var = gfc_lval_expr_from_sym (idx);
    1812                 :       1384 :   iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1813                 :       1384 :   iter->end = gfc_copy_expr (rank);
    1814                 :       1384 :   iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1815                 :       1384 :   last_code->next = gfc_get_code (EXEC_DO);
    1816                 :       1384 :   last_code = last_code->next;
    1817                 :       1384 :   last_code->ext.iterator = iter;
    1818                 :       1384 :   last_code->block = gfc_get_code (EXEC_DO);
    1819                 :            : 
    1820                 :            :   /* strides(idx) = _F._stride(array,dim=idx).  */
    1821                 :       1384 :   last_code->block->next = gfc_get_code (EXEC_ASSIGN);
    1822                 :       1384 :   block = last_code->block->next;
    1823                 :            : 
    1824                 :       1384 :   block->expr1 = gfc_lval_expr_from_sym (strides);
    1825                 :       1384 :   block->expr1->ref = gfc_get_ref ();
    1826                 :       1384 :   block->expr1->ref->type = REF_ARRAY;
    1827                 :       1384 :   block->expr1->ref->u.ar.type = AR_ELEMENT;
    1828                 :       1384 :   block->expr1->ref->u.ar.dimen = 1;
    1829                 :       1384 :   block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1830                 :       1384 :   block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
    1831                 :       1384 :   block->expr1->ref->u.ar.as = strides->as;
    1832                 :            : 
    1833                 :       1384 :   block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
    1834                 :            :                                            gfc_current_locus, 2,
    1835                 :            :                                            gfc_lval_expr_from_sym (array),
    1836                 :            :                                            gfc_lval_expr_from_sym (idx));
    1837                 :            : 
    1838                 :            :   /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind).  */
    1839                 :       1384 :   block->next = gfc_get_code (EXEC_ASSIGN);
    1840                 :       1384 :   block = block->next;
    1841                 :            : 
    1842                 :            :   /* sizes(idx) = ...  */
    1843                 :       1384 :   block->expr1 = gfc_lval_expr_from_sym (sizes);
    1844                 :       1384 :   block->expr1->ref = gfc_get_ref ();
    1845                 :       1384 :   block->expr1->ref->type = REF_ARRAY;
    1846                 :       1384 :   block->expr1->ref->u.ar.type = AR_ELEMENT;
    1847                 :       1384 :   block->expr1->ref->u.ar.dimen = 1;
    1848                 :       1384 :   block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1849                 :       1384 :   block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
    1850                 :       1384 :   block->expr1->ref->u.ar.as = sizes->as;
    1851                 :            : 
    1852                 :       1384 :   block->expr2 = gfc_get_expr ();
    1853                 :       1384 :   block->expr2->expr_type = EXPR_OP;
    1854                 :       1384 :   block->expr2->value.op.op = INTRINSIC_TIMES;
    1855                 :       1384 :   block->expr2->where = gfc_current_locus;
    1856                 :            : 
    1857                 :            :   /* sizes(idx-1).  */
    1858                 :       1384 :   block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
    1859                 :       1384 :   block->expr2->value.op.op1->ref = gfc_get_ref ();
    1860                 :       1384 :   block->expr2->value.op.op1->ref->type = REF_ARRAY;
    1861                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
    1862                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
    1863                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.dimen = 1;
    1864                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1865                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
    1866                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
    1867                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus;
    1868                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
    1869                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
    1870                 :       1384 :         = gfc_lval_expr_from_sym (idx);
    1871                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
    1872                 :       1384 :         = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1873                 :       1384 :   block->expr2->value.op.op1->ref->u.ar.start[0]->ts
    1874                 :       1384 :         = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
    1875                 :            : 
    1876                 :            :   /* size(array, dim=idx, kind=index_kind).  */
    1877                 :       2768 :   block->expr2->value.op.op2
    1878                 :       1384 :         = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
    1879                 :            :                                     gfc_current_locus, 3,
    1880                 :            :                                     gfc_lval_expr_from_sym (array),
    1881                 :            :                                     gfc_lval_expr_from_sym (idx),
    1882                 :            :                                     gfc_get_int_expr (gfc_index_integer_kind,
    1883                 :            :                                                       NULL,
    1884                 :            :                                                       gfc_index_integer_kind));
    1885                 :       1384 :   block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
    1886                 :       1384 :   block->expr2->ts = idx->ts;
    1887                 :            : 
    1888                 :            :   /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false.  */
    1889                 :       1384 :   block->next = gfc_get_code (EXEC_IF);
    1890                 :       1384 :   block = block->next;
    1891                 :            : 
    1892                 :       1384 :   block->block = gfc_get_code (EXEC_IF);
    1893                 :       1384 :   block = block->block;
    1894                 :            : 
    1895                 :            :   /* if condition: strides(idx) /= sizes(idx-1).  */
    1896                 :       1384 :   block->expr1 = gfc_get_expr ();
    1897                 :       1384 :   block->expr1->ts.type = BT_LOGICAL;
    1898                 :       1384 :   block->expr1->ts.kind = gfc_default_logical_kind;
    1899                 :       1384 :   block->expr1->expr_type = EXPR_OP;
    1900                 :       1384 :   block->expr1->where = gfc_current_locus;
    1901                 :       1384 :   block->expr1->value.op.op = INTRINSIC_NE;
    1902                 :            : 
    1903                 :       1384 :   block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
    1904                 :       1384 :   block->expr1->value.op.op1->ref = gfc_get_ref ();
    1905                 :       1384 :   block->expr1->value.op.op1->ref->type = REF_ARRAY;
    1906                 :       1384 :   block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
    1907                 :       1384 :   block->expr1->value.op.op1->ref->u.ar.dimen = 1;
    1908                 :       1384 :   block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1909                 :       1384 :   block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
    1910                 :       1384 :   block->expr1->value.op.op1->ref->u.ar.as = strides->as;
    1911                 :            : 
    1912                 :       1384 :   block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
    1913                 :       1384 :   block->expr1->value.op.op2->ref = gfc_get_ref ();
    1914                 :       1384 :   block->expr1->value.op.op2->ref->type = REF_ARRAY;
    1915                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
    1916                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
    1917                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.dimen = 1;
    1918                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1919                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
    1920                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
    1921                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
    1922                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
    1923                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
    1924                 :       1384 :         = gfc_lval_expr_from_sym (idx);
    1925                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
    1926                 :       1384 :         = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1927                 :       1384 :   block->expr1->value.op.op2->ref->u.ar.start[0]->ts
    1928                 :       1384 :         = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
    1929                 :            : 
    1930                 :            :   /* if body: is_contiguous = .false.  */
    1931                 :       1384 :   block->next = gfc_get_code (EXEC_ASSIGN);
    1932                 :       1384 :   block = block->next;
    1933                 :       1384 :   block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
    1934                 :       1384 :   block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
    1935                 :            :                                        &gfc_current_locus, false);
    1936                 :            : 
    1937                 :            :   /* Obtain the size (number of elements) of "array" MINUS ONE,
    1938                 :            :      which is used in the scalarization.  */
    1939                 :       1384 :   gfc_get_symbol ("nelem", sub_ns, &nelem);
    1940                 :       1384 :   nelem->ts.type = BT_INTEGER;
    1941                 :       1384 :   nelem->ts.kind = gfc_index_integer_kind;
    1942                 :       1384 :   nelem->attr.flavor = FL_VARIABLE;
    1943                 :       1384 :   nelem->attr.artificial = 1;
    1944                 :       1384 :   gfc_set_sym_referenced (nelem);
    1945                 :       1384 :   gfc_commit_symbol (nelem);
    1946                 :            : 
    1947                 :            :   /* nelem = sizes (rank) - 1.  */
    1948                 :       1384 :   last_code->next = gfc_get_code (EXEC_ASSIGN);
    1949                 :       1384 :   last_code = last_code->next;
    1950                 :            : 
    1951                 :       1384 :   last_code->expr1 = gfc_lval_expr_from_sym (nelem);
    1952                 :            : 
    1953                 :       1384 :   last_code->expr2 = gfc_get_expr ();
    1954                 :       1384 :   last_code->expr2->expr_type = EXPR_OP;
    1955                 :       1384 :   last_code->expr2->value.op.op = INTRINSIC_MINUS;
    1956                 :       1384 :   last_code->expr2->value.op.op2
    1957                 :       1384 :         = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    1958                 :       1384 :   last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
    1959                 :       1384 :   last_code->expr2->where = gfc_current_locus;
    1960                 :            : 
    1961                 :       1384 :   last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
    1962                 :       1384 :   last_code->expr2->value.op.op1->ref = gfc_get_ref ();
    1963                 :       1384 :   last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
    1964                 :       1384 :   last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
    1965                 :       1384 :   last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
    1966                 :       1384 :   last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
    1967                 :       1384 :   last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
    1968                 :       1384 :   last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
    1969                 :            : 
    1970                 :            :   /* Call final subroutines. We now generate code like:
    1971                 :            :      use iso_c_binding
    1972                 :            :      integer, pointer :: ptr
    1973                 :            :      type(c_ptr) :: cptr
    1974                 :            :      integer(c_intptr_t) :: i, addr
    1975                 :            : 
    1976                 :            :      select case (rank (array))
    1977                 :            :        case (3)
    1978                 :            :          ! If needed, the array is packed
    1979                 :            :          call final_rank3 (array)
    1980                 :            :        case default:
    1981                 :            :          do i = 0, size (array)-1
    1982                 :            :            addr = transfer (c_loc (array), addr) + i * stride
    1983                 :            :            call c_f_pointer (transfer (addr, cptr), ptr)
    1984                 :            :            call elemental_final (ptr)
    1985                 :            :          end do
    1986                 :            :      end select */
    1987                 :            : 
    1988                 :       1384 :   if (derived->f2k_derived && derived->f2k_derived->finalizers)
    1989                 :            :     {
    1990                 :        147 :       gfc_finalizer *fini, *fini_elem = NULL;
    1991                 :            : 
    1992                 :        147 :       gfc_get_symbol ("ptr1", sub_ns, &ptr);
    1993                 :        147 :       ptr->ts.type = BT_DERIVED;
    1994                 :        147 :       ptr->ts.u.derived = derived;
    1995                 :        147 :       ptr->attr.flavor = FL_VARIABLE;
    1996                 :        147 :       ptr->attr.pointer = 1;
    1997                 :        147 :       ptr->attr.artificial = 1;
    1998                 :        147 :       gfc_set_sym_referenced (ptr);
    1999                 :        147 :       gfc_commit_symbol (ptr);
    2000                 :            : 
    2001                 :            :       /* SELECT CASE (RANK (array)).  */
    2002                 :        147 :       last_code->next = gfc_get_code (EXEC_SELECT);
    2003                 :        147 :       last_code = last_code->next;
    2004                 :        147 :       last_code->expr1 = gfc_copy_expr (rank);
    2005                 :        147 :       block = NULL;
    2006                 :            : 
    2007                 :        334 :       for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
    2008                 :            :         {
    2009                 :        187 :           gcc_assert (fini->proc_tree);   /* Should have been set in gfc_resolve_finalizers.  */
    2010                 :        187 :           if (fini->proc_tree->n.sym->attr.elemental)
    2011                 :            :             {
    2012                 :         50 :               fini_elem = fini;
    2013                 :         50 :               continue;
    2014                 :            :             }
    2015                 :            : 
    2016                 :            :           /* CASE (fini_rank).  */
    2017                 :        137 :           if (block)
    2018                 :            :             {
    2019                 :         27 :               block->block = gfc_get_code (EXEC_SELECT);
    2020                 :         27 :               block = block->block;
    2021                 :            :             }
    2022                 :            :           else
    2023                 :            :             {
    2024                 :        110 :               block = gfc_get_code (EXEC_SELECT);
    2025                 :        110 :               last_code->block = block;
    2026                 :            :             }
    2027                 :        137 :           block->ext.block.case_list = gfc_get_case ();
    2028                 :        137 :           block->ext.block.case_list->where = gfc_current_locus;
    2029                 :        137 :           if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
    2030                 :         77 :             block->ext.block.case_list->low
    2031                 :         77 :              = gfc_get_int_expr (gfc_default_integer_kind, NULL,
    2032                 :         77 :                                  fini->proc_tree->n.sym->formal->sym->as->rank);
    2033                 :            :           else
    2034                 :         60 :             block->ext.block.case_list->low
    2035                 :         60 :                 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
    2036                 :        137 :           block->ext.block.case_list->high
    2037                 :        137 :                 = gfc_copy_expr (block->ext.block.case_list->low);
    2038                 :            : 
    2039                 :            :           /* CALL fini_rank (array) - possibly with packing.  */
    2040                 :        137 :           if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
    2041                 :         77 :             finalizer_insert_packed_call (block, fini, array, byte_stride,
    2042                 :            :                                           idx, ptr, nelem, strides,
    2043                 :            :                                           sizes, idx2, offset, is_contiguous,
    2044                 :            :                                           rank, sub_ns);
    2045                 :            :           else
    2046                 :            :             {
    2047                 :         60 :               block->next = gfc_get_code (EXEC_CALL);
    2048                 :         60 :               block->next->symtree = fini->proc_tree;
    2049                 :         60 :               block->next->resolved_sym = fini->proc_tree->n.sym;
    2050                 :         60 :               block->next->ext.actual = gfc_get_actual_arglist ();
    2051                 :         60 :               block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
    2052                 :            :             }
    2053                 :            :         }
    2054                 :            : 
    2055                 :            :       /* Elemental call - scalarized.  */
    2056                 :        147 :       if (fini_elem)
    2057                 :            :         {
    2058                 :            :           /* CASE DEFAULT.  */
    2059                 :         50 :           if (block)
    2060                 :            :             {
    2061                 :         13 :               block->block = gfc_get_code (EXEC_SELECT);
    2062                 :         13 :               block = block->block;
    2063                 :            :             }
    2064                 :            :           else
    2065                 :            :             {
    2066                 :         37 :               block = gfc_get_code (EXEC_SELECT);
    2067                 :         37 :               last_code->block = block;
    2068                 :            :             }
    2069                 :         50 :           block->ext.block.case_list = gfc_get_case ();
    2070                 :            : 
    2071                 :            :           /* Create loop.  */
    2072                 :         50 :           iter = gfc_get_iterator ();
    2073                 :         50 :           iter->var = gfc_lval_expr_from_sym (idx);
    2074                 :         50 :           iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    2075                 :         50 :           iter->end = gfc_lval_expr_from_sym (nelem);
    2076                 :         50 :           iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    2077                 :         50 :           block->next = gfc_get_code (EXEC_DO);
    2078                 :         50 :           block = block->next;
    2079                 :         50 :           block->ext.iterator = iter;
    2080                 :         50 :           block->block = gfc_get_code (EXEC_DO);
    2081                 :            : 
    2082                 :            :           /* Offset calculation.  */
    2083                 :         50 :           block = finalization_get_offset (idx, idx2, offset, strides, sizes,
    2084                 :            :                                            byte_stride, rank, block->block,
    2085                 :            :                                            sub_ns);
    2086                 :            : 
    2087                 :            :           /* Create code for
    2088                 :            :              CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
    2089                 :            :                                + offset, c_ptr), ptr).  */
    2090                 :         50 :           block->next
    2091                 :         50 :                 = finalization_scalarizer (array, ptr,
    2092                 :            :                                            gfc_lval_expr_from_sym (offset),
    2093                 :            :                                            sub_ns);
    2094                 :         50 :           block = block->next;
    2095                 :            : 
    2096                 :            :           /* CALL final_elemental (array).  */
    2097                 :         50 :           block->next = gfc_get_code (EXEC_CALL);
    2098                 :         50 :           block = block->next;
    2099                 :         50 :           block->symtree = fini_elem->proc_tree;
    2100                 :         50 :           block->resolved_sym = fini_elem->proc_sym;
    2101                 :         50 :           block->ext.actual = gfc_get_actual_arglist ();
    2102                 :         50 :           block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
    2103                 :            :         }
    2104                 :            :     }
    2105                 :            : 
    2106                 :            :   /* Finalize and deallocate allocatable components. The same manual
    2107                 :            :      scalarization is used as above.  */
    2108                 :            : 
    2109                 :       1384 :   if (finalizable_comp)
    2110                 :            :     {
    2111                 :       1253 :       gfc_symbol *stat;
    2112                 :       1253 :       gfc_code *block = NULL;
    2113                 :            : 
    2114                 :       1253 :       if (!ptr)
    2115                 :            :         {
    2116                 :       1237 :           gfc_get_symbol ("ptr2", sub_ns, &ptr);
    2117                 :       1237 :           ptr->ts.type = BT_DERIVED;
    2118                 :       1237 :           ptr->ts.u.derived = derived;
    2119                 :       1237 :           ptr->attr.flavor = FL_VARIABLE;
    2120                 :       1237 :           ptr->attr.pointer = 1;
    2121                 :       1237 :           ptr->attr.artificial = 1;
    2122                 :       1237 :           gfc_set_sym_referenced (ptr);
    2123                 :       1237 :           gfc_commit_symbol (ptr);
    2124                 :            :         }
    2125                 :            : 
    2126                 :       1253 :       gfc_get_symbol ("ignore", sub_ns, &stat);
    2127                 :       1253 :       stat->attr.flavor = FL_VARIABLE;
    2128                 :       1253 :       stat->attr.artificial = 1;
    2129                 :       1253 :       stat->ts.type = BT_INTEGER;
    2130                 :       1253 :       stat->ts.kind = gfc_default_integer_kind;
    2131                 :       1253 :       gfc_set_sym_referenced (stat);
    2132                 :       1253 :       gfc_commit_symbol (stat);
    2133                 :            : 
    2134                 :            :       /* Create loop.  */
    2135                 :       1253 :       iter = gfc_get_iterator ();
    2136                 :       1253 :       iter->var = gfc_lval_expr_from_sym (idx);
    2137                 :       1253 :       iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
    2138                 :       1253 :       iter->end = gfc_lval_expr_from_sym (nelem);
    2139                 :       1253 :       iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
    2140                 :       1253 :       last_code->next = gfc_get_code (EXEC_DO);
    2141                 :       1253 :       last_code = last_code->next;
    2142                 :       1253 :       last_code->ext.iterator = iter;
    2143                 :       1253 :       last_code->block = gfc_get_code (EXEC_DO);
    2144                 :            : 
    2145                 :            :       /* Offset calculation.  */
    2146                 :       1253 :       block = finalization_get_offset (idx, idx2, offset, strides, sizes,
    2147                 :            :                                        byte_stride, rank, last_code->block,
    2148                 :            :                                        sub_ns);
    2149                 :            : 
    2150                 :            :       /* Create code for
    2151                 :            :          CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
    2152                 :            :                            + idx * stride, c_ptr), ptr).  */
    2153                 :       1253 :       block->next = finalization_scalarizer (array, ptr,
    2154                 :            :                                              gfc_lval_expr_from_sym(offset),
    2155                 :            :                                              sub_ns);
    2156                 :       1253 :       block = block->next;
    2157                 :            : 
    2158                 :       3376 :       for (comp = derived->components; comp; comp = comp->next)
    2159                 :            :         {
    2160                 :       2123 :           if (comp == derived->components && derived->attr.extension
    2161                 :        171 :               && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
    2162                 :         54 :             continue;
    2163                 :            : 
    2164                 :       2069 :           finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
    2165                 :            :                               stat, fini_coarray, &block, sub_ns);
    2166                 :       2069 :           if (!last_code->block->next)
    2167                 :          0 :             last_code->block->next = block;
    2168                 :            :         }
    2169                 :            : 
    2170                 :            :     }
    2171                 :            : 
    2172                 :            :   /* Call the finalizer of the ancestor.  */
    2173                 :       1384 :   if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
    2174                 :            :     {
    2175                 :         79 :       last_code->next = gfc_get_code (EXEC_CALL);
    2176                 :         79 :       last_code = last_code->next;
    2177                 :         79 :       last_code->symtree = ancestor_wrapper->symtree;
    2178                 :         79 :       last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
    2179                 :            : 
    2180                 :         79 :       last_code->ext.actual = gfc_get_actual_arglist ();
    2181                 :         79 :       last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
    2182                 :         79 :       last_code->ext.actual->next = gfc_get_actual_arglist ();
    2183                 :         79 :       last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
    2184                 :         79 :       last_code->ext.actual->next->next = gfc_get_actual_arglist ();
    2185                 :         79 :       last_code->ext.actual->next->next->expr
    2186                 :         79 :                         = gfc_lval_expr_from_sym (fini_coarray);
    2187                 :            :     }
    2188                 :            : 
    2189                 :       1384 :   gfc_free_expr (rank);
    2190                 :       1384 :   vtab_final->initializer = gfc_lval_expr_from_sym (final);
    2191                 :       1384 :   vtab_final->ts.interface = final;
    2192                 :       1384 :   free (name);
    2193                 :            : }
    2194                 :            : 
    2195                 :            : 
    2196                 :            : /* Add procedure pointers for all type-bound procedures to a vtab.  */
    2197                 :            : 
    2198                 :            : static void
    2199                 :       6934 : add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
    2200                 :            : {
    2201                 :       6934 :   gfc_symbol* super_type;
    2202                 :            : 
    2203                 :       6934 :   super_type = gfc_get_derived_super_type (derived);
    2204                 :            : 
    2205                 :       6934 :   if (super_type && (super_type != derived))
    2206                 :            :     {
    2207                 :            :       /* Make sure that the PPCs appear in the same order as in the parent.  */
    2208                 :       1118 :       copy_vtab_proc_comps (super_type, vtype);
    2209                 :            :       /* Only needed to get the PPC initializers right.  */
    2210                 :       1118 :       add_procs_to_declared_vtab (super_type, vtype);
    2211                 :            :     }
    2212                 :            : 
    2213                 :       6934 :   if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
    2214                 :       1829 :     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
    2215                 :            : 
    2216                 :       6934 :   if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
    2217                 :         22 :     add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
    2218                 :       6934 : }
    2219                 :            : 
    2220                 :            : 
    2221                 :            : /* Find or generate the symbol for a derived type's vtab.  */
    2222                 :            : 
    2223                 :            : gfc_symbol *
    2224                 :      40411 : gfc_find_derived_vtab (gfc_symbol *derived)
    2225                 :            : {
    2226                 :      40411 :   gfc_namespace *ns;
    2227                 :      40411 :   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
    2228                 :      40411 :   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
    2229                 :      40411 :   gfc_gsymbol *gsym = NULL;
    2230                 :      40411 :   gfc_symbol *dealloc = NULL, *arg = NULL;
    2231                 :            : 
    2232                 :      40411 :   if (derived->attr.pdt_template)
    2233                 :            :     return NULL;
    2234                 :            : 
    2235                 :            :   /* Find the top-level namespace.  */
    2236                 :      45500 :   for (ns = gfc_current_ns; ns; ns = ns->parent)
    2237                 :      45500 :     if (!ns->parent)
    2238                 :            :       break;
    2239                 :            : 
    2240                 :            :   /* If the type is a class container, use the underlying derived type.  */
    2241                 :      40397 :   if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
    2242                 :       6693 :     derived = gfc_get_derived_super_type (derived);
    2243                 :            : 
    2244                 :      40397 :   if (!derived)
    2245                 :            :     return NULL;
    2246                 :            : 
    2247                 :            :   /* Find the gsymbol for the module of use associated derived types.  */
    2248                 :      40396 :   if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
    2249                 :      14084 :        && !derived->attr.vtype && !derived->attr.is_class)
    2250                 :      14084 :     gsym =  gfc_find_gsymbol (gfc_gsym_root, derived->module);
    2251                 :            :   else
    2252                 :            :     gsym = NULL;
    2253                 :            : 
    2254                 :            :   /* Work in the gsymbol namespace if the top-level namespace is a module.
    2255                 :            :      This ensures that the vtable is unique, which is required since we use
    2256                 :            :      its address in SELECT TYPE.  */
    2257                 :      14084 :   if (gsym && gsym->ns && ns && ns->proc_name
    2258                 :      12820 :       && ns->proc_name->attr.flavor == FL_MODULE)
    2259                 :       1831 :     ns = gsym->ns;
    2260                 :            : 
    2261                 :      40396 :   if (ns)
    2262                 :            :     {
    2263                 :      40396 :       char tname[GFC_MAX_SYMBOL_LEN+1];
    2264                 :      40396 :       char *name;
    2265                 :            : 
    2266                 :      40396 :       get_unique_hashed_string (tname, derived);
    2267                 :      40396 :       name = xasprintf ("__vtab_%s", tname);
    2268                 :            : 
    2269                 :            :       /* Look for the vtab symbol in various namespaces.  */
    2270                 :      40396 :       if (gsym && gsym->ns)
    2271                 :            :         {
    2272                 :      12820 :           gfc_find_symbol (name, gsym->ns, 0, &vtab);
    2273                 :      12820 :           if (vtab)
    2274                 :      12818 :             ns = gsym->ns;
    2275                 :            :         }
    2276                 :      40396 :       if (vtab == NULL)
    2277                 :      27578 :         gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
    2278                 :      40396 :       if (vtab == NULL)
    2279                 :       9900 :         gfc_find_symbol (name, ns, 0, &vtab);
    2280                 :      40396 :       if (vtab == NULL)
    2281                 :       6178 :         gfc_find_symbol (name, derived->ns, 0, &vtab);
    2282                 :            : 
    2283                 :      40396 :       if (vtab == NULL)
    2284                 :            :         {
    2285                 :       6178 :           gfc_get_symbol (name, ns, &vtab);
    2286                 :       6178 :           vtab->ts.type = BT_DERIVED;
    2287                 :       6178 :           if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
    2288                 :            :                                &gfc_current_locus))
    2289                 :          0 :             goto cleanup;
    2290                 :       6178 :           vtab->attr.target = 1;
    2291                 :       6178 :           vtab->attr.save = SAVE_IMPLICIT;
    2292                 :       6178 :           vtab->attr.vtab = 1;
    2293                 :       6178 :           vtab->attr.access = ACCESS_PUBLIC;
    2294                 :       6178 :           gfc_set_sym_referenced (vtab);
    2295                 :       6178 :           name = xasprintf ("__vtype_%s", tname);
    2296                 :            : 
    2297                 :       6178 :           gfc_find_symbol (name, ns, 0, &vtype);
    2298                 :       6178 :           if (vtype == NULL)
    2299                 :            :             {
    2300                 :       6178 :               gfc_component *c;
    2301                 :       6178 :               gfc_symbol *parent = NULL, *parent_vtab = NULL;
    2302                 :       6178 :               bool rdt = false;
    2303                 :            : 
    2304                 :            :               /* Is this a derived type with recursive allocatable
    2305                 :            :                  components?  */
    2306                 :       6178 :               c = (derived->attr.unlimited_polymorphic
    2307                 :       6178 :                    || derived->attr.abstract) ?
    2308                 :            :                   NULL : derived->components;
    2309                 :      13709 :               for (; c; c= c->next)
    2310                 :       7617 :                 if (c->ts.type == BT_DERIVED
    2311                 :       1996 :                     && c->ts.u.derived == derived)
    2312                 :            :                   {
    2313                 :            :                     rdt = true;
    2314                 :            :                     break;
    2315                 :            :                   }
    2316                 :            : 
    2317                 :       6178 :               gfc_get_symbol (name, ns, &vtype);
    2318                 :       6178 :               if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
    2319                 :            :                                    &gfc_current_locus))
    2320                 :          0 :                 goto cleanup;
    2321                 :       6178 :               vtype->attr.access = ACCESS_PUBLIC;
    2322                 :       6178 :               vtype->attr.vtype = 1;
    2323                 :       6178 :               gfc_set_sym_referenced (vtype);
    2324                 :            : 
    2325                 :            :               /* Add component '_hash'.  */
    2326                 :       6178 :               if (!gfc_add_component (vtype, "_hash", &c))
    2327                 :          0 :                 goto cleanup;
    2328                 :       6178 :               c->ts.type = BT_INTEGER;
    2329                 :       6178 :               c->ts.kind = 4;
    2330                 :       6178 :               c->attr.access = ACCESS_PRIVATE;
    2331                 :      12356 :               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
    2332                 :       6178 :                                                  NULL, derived->hash_value);
    2333                 :            : 
    2334                 :            :               /* Add component '_size'.  */
    2335                 :       6178 :               if (!gfc_add_component (vtype, "_size", &c))
    2336                 :          0 :                 goto cleanup;
    2337                 :       6178 :               c->ts.type = BT_INTEGER;
    2338                 :       6178 :               c->ts.kind = gfc_size_kind;
    2339                 :       6178 :               c->attr.access = ACCESS_PRIVATE;
    2340                 :            :               /* Remember the derived type in ts.u.derived,
    2341                 :            :                  so that the correct initializer can be set later on
    2342                 :            :                  (in gfc_conv_structure).  */
    2343                 :       6178 :               c->ts.u.derived = derived;
    2344                 :       6178 :               c->initializer = gfc_get_int_expr (gfc_size_kind,
    2345                 :            :                                                  NULL, 0);
    2346                 :            : 
    2347                 :            :               /* Add component _extends.  */
    2348                 :       6178 :               if (!gfc_add_component (vtype, "_extends", &c))
    2349                 :          0 :                 goto cleanup;
    2350                 :       6178 :               c->attr.pointer = 1;
    2351                 :       6178 :               c->attr.access = ACCESS_PRIVATE;
    2352                 :       6178 :               if (!derived->attr.unlimited_polymorphic)
    2353                 :       5819 :                 parent = gfc_get_derived_super_type (derived);
    2354                 :            :               else
    2355                 :            :                 parent = NULL;
    2356                 :            : 
    2357                 :       5819 :               if (parent)
    2358                 :            :                 {
    2359                 :       1032 :                   parent_vtab = gfc_find_derived_vtab (parent);
    2360                 :       1032 :                   c->ts.type = BT_DERIVED;
    2361                 :       1032 :                   c->ts.u.derived = parent_vtab->ts.u.derived;
    2362                 :       1032 :                   c->initializer = gfc_get_expr ();
    2363                 :       1032 :                   c->initializer->expr_type = EXPR_VARIABLE;
    2364                 :       1032 :                   gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
    2365                 :            :                                      0, &c->initializer->symtree);
    2366                 :            :                 }
    2367                 :            :               else
    2368                 :            :                 {
    2369                 :       5146 :                   c->ts.type = BT_DERIVED;
    2370                 :       5146 :                   c->ts.u.derived = vtype;
    2371                 :       5146 :                   c->initializer = gfc_get_null_expr (NULL);
    2372                 :            :                 }
    2373                 :            : 
    2374                 :       6178 :               if (!derived->attr.unlimited_polymorphic
    2375                 :       5819 :                   && derived->components == NULL
    2376                 :        795 :                   && !derived->attr.zero_comp)
    2377                 :            :                 {
    2378                 :            :                   /* At this point an error must have occurred.
    2379                 :            :                      Prevent further errors on the vtype components.  */
    2380                 :          3 :                   found_sym = vtab;
    2381                 :          3 :                   goto have_vtype;
    2382                 :            :                 }
    2383                 :            : 
    2384                 :            :               /* Add component _def_init.  */
    2385                 :       6175 :               if (!gfc_add_component (vtype, "_def_init", &c))
    2386                 :          0 :                 goto cleanup;
    2387                 :       6175 :               c->attr.pointer = 1;
    2388                 :       6175 :               c->attr.artificial = 1;
    2389                 :       6175 :               c->attr.access = ACCESS_PRIVATE;
    2390                 :       6175 :               c->ts.type = BT_DERIVED;
    2391                 :       6175 :               c->ts.u.derived = derived;
    2392                 :       6175 :               if (derived->attr.unlimited_polymorphic
    2393                 :       6175 :                   || derived->attr.abstract)
    2394                 :        562 :                 c->initializer = gfc_get_null_expr (NULL);
    2395                 :            :               else
    2396                 :            :                 {
    2397                 :            :                   /* Construct default initialization variable.  */
    2398                 :       5613 :                   name = xasprintf ("__def_init_%s", tname);
    2399                 :       5613 :                   gfc_get_symbol (name, ns, &def_init);
    2400                 :       5613 :                   def_init->attr.target = 1;
    2401                 :       5613 :                   def_init->attr.artificial = 1;
    2402                 :       5613 :                   def_init->attr.save = SAVE_IMPLICIT;
    2403                 :       5613 :                   def_init->attr.access = ACCESS_PUBLIC;
    2404                 :       5613 :                   def_init->attr.flavor = FL_VARIABLE;
    2405                 :       5613 :                   gfc_set_sym_referenced (def_init);
    2406                 :       5613 :                   def_init->ts.type = BT_DERIVED;
    2407                 :       5613 :                   def_init->ts.u.derived = derived;
    2408                 :       5613 :                   def_init->value = gfc_default_initializer (&def_init->ts);
    2409                 :            : 
    2410                 :       5613 :                   c->initializer = gfc_lval_expr_from_sym (def_init);
    2411                 :            :                 }
    2412                 :            : 
    2413                 :            :               /* Add component _copy.  */
    2414                 :       6175 :               if (!gfc_add_component (vtype, "_copy", &c))
    2415                 :          0 :                 goto cleanup;
    2416                 :       6175 :               c->attr.proc_pointer = 1;
    2417                 :       6175 :               c->attr.access = ACCESS_PRIVATE;
    2418                 :       6175 :               c->tb = XCNEW (gfc_typebound_proc);
    2419                 :       6175 :               c->tb->ppc = 1;
    2420                 :       6175 :               if (derived->attr.unlimited_polymorphic
    2421                 :       6175 :                   || derived->attr.abstract)
    2422                 :        562 :                 c->initializer = gfc_get_null_expr (NULL);
    2423                 :            :               else
    2424                 :            :                 {
    2425                 :            :                   /* Set up namespace.  */
    2426                 :       5613 :                   gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
    2427                 :       5613 :                   sub_ns->sibling = ns->contained;
    2428                 :       5613 :                   ns->contained = sub_ns;
    2429                 :       5613 :                   sub_ns->resolved = 1;
    2430                 :            :                   /* Set up procedure symbol.  */
    2431                 :       5613 :                   name = xasprintf ("__copy_%s", tname);
    2432                 :       5613 :                   gfc_get_symbol (name, sub_ns, &copy);
    2433                 :       5613 :                   sub_ns->proc_name = copy;
    2434                 :       5613 :                   copy->attr.flavor = FL_PROCEDURE;
    2435                 :       5613 :                   copy->attr.subroutine = 1;
    2436                 :       5613 :                   copy->attr.pure = 1;
    2437                 :       5613 :                   copy->attr.artificial = 1;
    2438                 :       5613 :                   copy->attr.if_source = IFSRC_DECL;
    2439                 :            :                   /* This is elemental so that arrays are automatically
    2440                 :            :                      treated correctly by the scalarizer.  */
    2441                 :       5613 :                   copy->attr.elemental = 1;
    2442                 :       5613 :                   if (ns->proc_name->attr.flavor == FL_MODULE)
    2443                 :       4442 :                     copy->module = ns->proc_name->name;
    2444                 :       5613 :                   gfc_set_sym_referenced (copy);
    2445                 :            :                   /* Set up formal arguments.  */
    2446                 :       5613 :                   gfc_get_symbol ("src", sub_ns, &src);
    2447                 :       5613 :                   src->ts.type = BT_DERIVED;
    2448                 :       5613 :                   src->ts.u.derived = derived;
    2449                 :       5613 :                   src->attr.flavor = FL_VARIABLE;
    2450                 :       5613 :                   src->attr.dummy = 1;
    2451                 :       5613 :                   src->attr.artificial = 1;
    2452                 :       5613 :                   src->attr.intent = INTENT_IN;
    2453                 :       5613 :                   gfc_set_sym_referenced (src);
    2454                 :       5613 :                   copy->formal = gfc_get_formal_arglist ();
    2455                 :       5613 :                   copy->formal->sym = src;
    2456                 :       5613 :                   gfc_get_symbol ("dst", sub_ns, &dst);
    2457                 :       5613 :                   dst->ts.type = BT_DERIVED;
    2458                 :       5613 :                   dst->ts.u.derived = derived;
    2459                 :       5613 :                   dst->attr.flavor = FL_VARIABLE;
    2460                 :       5613 :                   dst->attr.dummy = 1;
    2461                 :       5613 :                   dst->attr.artificial = 1;
    2462                 :       5613 :                   dst->attr.intent = INTENT_INOUT;
    2463                 :       5613 :                   gfc_set_sym_referenced (dst);
    2464                 :       5613 :                   copy->formal->next = gfc_get_formal_arglist ();
    2465                 :       5613 :                   copy->formal->next->sym = dst;
    2466                 :            :                   /* Set up code.  */
    2467                 :       5613 :                   sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
    2468                 :       5613 :                   sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
    2469                 :       5613 :                   sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
    2470                 :            :                   /* Set initializer.  */
    2471                 :       5613 :                   c->initializer = gfc_lval_expr_from_sym (copy);
    2472                 :       5613 :                   c->ts.interface = copy;
    2473                 :            :                 }
    2474                 :            : 
    2475                 :            :               /* Add component _final, which contains a procedure pointer to
    2476                 :            :                  a wrapper which handles both the freeing of allocatable
    2477                 :            :                  components and the calls to finalization subroutines.
    2478                 :            :                  Note: The actual wrapper function can only be generated
    2479                 :            :                  at resolution time.  */
    2480                 :       6175 :               if (!gfc_add_component (vtype, "_final", &c))
    2481                 :          0 :                 goto cleanup;
    2482                 :       6175 :               c->attr.proc_pointer = 1;
    2483                 :       6175 :               c->attr.access = ACCESS_PRIVATE;
    2484                 :       6175 :               c->attr.artificial = 1;
    2485                 :       6175 :               c->tb = XCNEW (gfc_typebound_proc);
    2486                 :       6175 :               c->tb->ppc = 1;
    2487                 :       6175 :               generate_finalization_wrapper (derived, ns, tname, c);
    2488                 :            : 
    2489                 :            :               /* Add component _deallocate.  */
    2490                 :       6175 :               if (!gfc_add_component (vtype, "_deallocate", &c))
    2491                 :          0 :                 goto cleanup;
    2492                 :       6175 :               c->attr.proc_pointer = 1;
    2493                 :       6175 :               c->attr.access = ACCESS_PRIVATE;
    2494                 :       6175 :               c->tb = XCNEW (gfc_typebound_proc);
    2495                 :       6175 :               c->tb->ppc = 1;
    2496                 :       6175 :               if (derived->attr.unlimited_polymorphic
    2497                 :       6175 :                   || derived->attr.abstract
    2498                 :       5613 :                   || !rdt)
    2499                 :       6089 :                 c->initializer = gfc_get_null_expr (NULL);
    2500                 :            :               else
    2501                 :            :                 {
    2502                 :            :                   /* Set up namespace.  */
    2503                 :         86 :                   gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
    2504                 :            : 
    2505                 :         86 :                   sub_ns->sibling = ns->contained;
    2506                 :         86 :                   ns->contained = sub_ns;
    2507                 :         86 :                   sub_ns->resolved = 1;
    2508                 :            :                   /* Set up procedure symbol.  */
    2509                 :         86 :                   name = xasprintf ("__deallocate_%s", tname);
    2510                 :         86 :                   gfc_get_symbol (name, sub_ns, &dealloc);
    2511                 :         86 :                   sub_ns->proc_name = dealloc;
    2512                 :         86 :                   dealloc->attr.flavor = FL_PROCEDURE;
    2513                 :         86 :                   dealloc->attr.subroutine = 1;
    2514                 :         86 :                   dealloc->attr.pure = 1;
    2515                 :         86 :                   dealloc->attr.artificial = 1;
    2516                 :         86 :                   dealloc->attr.if_source = IFSRC_DECL;
    2517                 :            : 
    2518                 :         86 :                   if (ns->proc_name->attr.flavor == FL_MODULE)
    2519                 :         60 :                     dealloc->module = ns->proc_name->name;
    2520                 :         86 :                   gfc_set_sym_referenced (dealloc);
    2521                 :            :                   /* Set up formal argument.  */
    2522                 :         86 :                   gfc_get_symbol ("arg", sub_ns, &arg);
    2523                 :         86 :                   arg->ts.type = BT_DERIVED;
    2524                 :         86 :                   arg->ts.u.derived = derived;
    2525                 :         86 :                   arg->attr.flavor = FL_VARIABLE;
    2526                 :         86 :                   arg->attr.dummy = 1;
    2527                 :         86 :                   arg->attr.artificial = 1;
    2528                 :         86 :                   arg->attr.intent = INTENT_INOUT;
    2529                 :         86 :                   arg->attr.dimension = 1;
    2530                 :         86 :                   arg->attr.allocatable = 1;
    2531                 :         86 :                   arg->as = gfc_get_array_spec();
    2532                 :         86 :                   arg->as->type = AS_ASSUMED_SHAPE;
    2533                 :         86 :                   arg->as->rank = 1;
    2534                 :         86 :                   arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
    2535                 :            :                                                         NULL, 1);
    2536                 :         86 :                   gfc_set_sym_referenced (arg);
    2537                 :         86 :                   dealloc->formal = gfc_get_formal_arglist ();
    2538                 :         86 :                   dealloc->formal->sym = arg;
    2539                 :            :                   /* Set up code.  */
    2540                 :         86 :                   sub_ns->code = gfc_get_code (EXEC_DEALLOCATE);
    2541                 :         86 :                   sub_ns->code->ext.alloc.list = gfc_get_alloc ();
    2542                 :         86 :                   sub_ns->code->ext.alloc.list->expr
    2543                 :         86 :                                 = gfc_lval_expr_from_sym (arg);
    2544                 :            :                   /* Set initializer.  */
    2545                 :         86 :                   c->initializer = gfc_lval_expr_from_sym (dealloc);
    2546                 :         86 :                   c->ts.interface = dealloc;
    2547                 :            :                 }
    2548                 :            : 
    2549                 :            :               /* Add procedure pointers for type-bound procedures.  */
    2550                 :       6175 :               if (!derived->attr.unlimited_polymorphic)
    2551                 :       5816 :                 add_procs_to_declared_vtab (derived, vtype);
    2552                 :            :           }
    2553                 :            : 
    2554                 :          0 : have_vtype:
    2555                 :       6178 :           vtab->ts.u.derived = vtype;
    2556                 :       6178 :           vtab->value = gfc_default_initializer (&vtab->ts);
    2557                 :            :         }
    2558                 :      40396 :       free (name);
    2559                 :            :     }
    2560                 :            : 
    2561                 :      40396 :   found_sym = vtab;
    2562                 :            : 
    2563                 :      40396 : cleanup:
    2564                 :            :   /* It is unexpected to have some symbols added at resolution or code
    2565                 :            :      generation time. We commit the changes in order to keep a clean state.  */
    2566                 :      40396 :   if (found_sym)
    2567                 :            :     {
    2568                 :      40396 :       gfc_commit_symbol (vtab);
    2569                 :      40396 :       if (vtype)
    2570                 :       6178 :         gfc_commit_symbol (vtype);
    2571                 :      40396 :       if (def_init)
    2572                 :       5613 :         gfc_commit_symbol (def_init);
    2573                 :      40396 :       if (copy)
    2574                 :       5613 :         gfc_commit_symbol (copy);
    2575                 :      40396 :       if (src)
    2576                 :       5613 :         gfc_commit_symbol (src);
    2577                 :      40396 :       if (dst)
    2578                 :       5613 :         gfc_commit_symbol (dst);
    2579                 :      40396 :       if (dealloc)
    2580                 :         86 :         gfc_commit_symbol (dealloc);
    2581                 :      40396 :       if (arg)
    2582                 :         86 :         gfc_commit_symbol (arg);
    2583                 :            :     }
    2584                 :            :   else
    2585                 :          0 :     gfc_undo_symbols ();
    2586                 :            : 
    2587                 :            :   return found_sym;
    2588                 :            : }
    2589                 :            : 
    2590                 :            : 
    2591                 :            : /* Check if a derived type is finalizable. That is the case if it
    2592                 :            :    (1) has a FINAL subroutine or
    2593                 :            :    (2) has a nonpointer nonallocatable component of finalizable type.
    2594                 :            :    If it is finalizable, return an expression containing the
    2595                 :            :    finalization wrapper.  */
    2596                 :            : 
    2597                 :            : bool
    2598                 :      16893 : gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
    2599                 :            : {
    2600                 :      16893 :   gfc_symbol *vtab;
    2601                 :      16893 :   gfc_component *c;
    2602                 :            : 
    2603                 :            :   /* (1) Check for FINAL subroutines.  */
    2604                 :      16893 :   if (derived->f2k_derived && derived->f2k_derived->finalizers)
    2605                 :        770 :     goto yes;
    2606                 :            : 
    2607                 :            :   /* (2) Check for components of finalizable type.  */
    2608                 :      43332 :   for (c = derived->components; c; c = c->next)
    2609                 :      27272 :     if (c->ts.type == BT_DERIVED
    2610                 :       8582 :         && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
    2611                 :      29571 :         && gfc_is_finalizable (c->ts.u.derived, NULL))
    2612                 :         63 :       goto yes;
    2613                 :            : 
    2614                 :            :   return false;
    2615                 :            : 
    2616                 :        833 : yes:
    2617                 :            :   /* Make sure vtab is generated.  */
    2618                 :        833 :   vtab = gfc_find_derived_vtab (derived);
    2619                 :        833 :   if (final_expr)
    2620                 :            :     {
    2621                 :            :       /* Return finalizer expression.  */
    2622                 :        131 :       gfc_component *final;
    2623                 :        131 :       final = vtab->ts.u.derived->components->next->next->next->next->next;
    2624                 :        131 :       gcc_assert (strcmp (final->name, "_final") == 0);
    2625                 :        131 :       gcc_assert (final->initializer
    2626                 :            :                   && final->initializer->expr_type != EXPR_NULL);
    2627                 :        131 :       *final_expr = final->initializer;
    2628                 :            :     }
    2629                 :            :   return true;
    2630                 :            : }
    2631                 :            : 
    2632                 :            : 
    2633                 :            : /* Find (or generate) the symbol for an intrinsic type's vtab.  This is
    2634                 :            :    needed to support unlimited polymorphism.  */
    2635                 :            : 
    2636                 :            : static gfc_symbol *
    2637                 :       2401 : find_intrinsic_vtab (gfc_typespec *ts)
    2638                 :            : {
    2639                 :       2401 :   gfc_namespace *ns;
    2640                 :       2401 :   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
    2641                 :       2401 :   gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
    2642                 :            : 
    2643                 :            :   /* Find the top-level namespace.  */
    2644                 :       3204 :   for (ns = gfc_current_ns; ns; ns = ns->parent)
    2645                 :       3204 :     if (!ns->parent)
    2646                 :            :       break;
    2647                 :            : 
    2648                 :       2401 :   if (ns)
    2649                 :            :     {
    2650                 :       2401 :       char tname[GFC_MAX_SYMBOL_LEN+1];
    2651                 :       2401 :       char *name;
    2652                 :            : 
    2653                 :            :       /* Encode all types as TYPENAME_KIND_ including especially character
    2654                 :            :          arrays, whose length is now consistently stored in the _len component
    2655                 :            :          of the class-variable.  */
    2656                 :       2401 :       sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
    2657                 :       2401 :       name = xasprintf ("__vtab_%s", tname);
    2658                 :            : 
    2659                 :            :       /* Look for the vtab symbol in the top-level namespace only.  */
    2660                 :       2401 :       gfc_find_symbol (name, ns, 0, &vtab);
    2661                 :            : 
    2662                 :       2401 :       if (vtab == NULL)
    2663                 :            :         {
    2664                 :        432 :           gfc_get_symbol (name, ns, &vtab);
    2665                 :        432 :           vtab->ts.type = BT_DERIVED;
    2666                 :        432 :           if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
    2667                 :            :                                &gfc_current_locus))
    2668                 :          0 :             goto cleanup;
    2669                 :        432 :           vtab->attr.target = 1;
    2670                 :        432 :           vtab->attr.save = SAVE_IMPLICIT;
    2671                 :        432 :           vtab->attr.vtab = 1;
    2672                 :        432 :           vtab->attr.access = ACCESS_PUBLIC;
    2673                 :        432 :           gfc_set_sym_referenced (vtab);
    2674                 :        432 :           name = xasprintf ("__vtype_%s", tname);
    2675                 :            : 
    2676                 :        432 :           gfc_find_symbol (name, ns, 0, &vtype);
    2677                 :        432 :           if (vtype == NULL)
    2678                 :            :             {
    2679                 :        432 :               gfc_component *c;
    2680                 :        432 :               int hash;
    2681                 :        432 :               gfc_namespace *sub_ns;
    2682                 :        432 :               gfc_namespace *contained;
    2683                 :        432 :               gfc_expr *e;
    2684                 :        432 :               size_t e_size;
    2685                 :            : 
    2686                 :        432 :               gfc_get_symbol (name, ns, &vtype);
    2687                 :        432 :               if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
    2688                 :            :                                    &gfc_current_locus))
    2689                 :          0 :                 goto cleanup;
    2690                 :        432 :               vtype->attr.access = ACCESS_PUBLIC;
    2691                 :        432 :               vtype->attr.vtype = 1;
    2692                 :        432 :               gfc_set_sym_referenced (vtype);
    2693                 :            : 
    2694                 :            :               /* Add component '_hash'.  */
    2695                 :        432 :               if (!gfc_add_component (vtype, "_hash", &c))
    2696                 :          0 :                 goto cleanup;
    2697                 :        432 :               c->ts.type = BT_INTEGER;
    2698                 :        432 :               c->ts.kind = 4;
    2699                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2700                 :        432 :               hash = gfc_intrinsic_hash_value (ts);
    2701                 :        432 :               c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
    2702                 :            :                                                  NULL, hash);
    2703                 :            : 
    2704                 :            :               /* Add component '_size'.  */
    2705                 :        432 :               if (!gfc_add_component (vtype, "_size", &c))
    2706                 :          0 :                 goto cleanup;
    2707                 :        432 :               c->ts.type = BT_INTEGER;
    2708                 :        432 :               c->ts.kind = gfc_size_kind;
    2709                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2710                 :            : 
    2711                 :            :               /* Build a minimal expression to make use of
    2712                 :            :                  target-memory.c/gfc_element_size for 'size'.  Special handling
    2713                 :            :                  for character arrays, that are not constant sized: to support
    2714                 :            :                  len (str) * kind, only the kind information is stored in the
    2715                 :            :                  vtab.  */
    2716                 :        432 :               e = gfc_get_expr ();
    2717                 :        432 :               e->ts = *ts;
    2718                 :        432 :               e->expr_type = EXPR_VARIABLE;
    2719                 :        432 :               if (ts->type == BT_CHARACTER)
    2720                 :        127 :                 e_size = ts->kind;
    2721                 :            :               else
    2722                 :        305 :                 gfc_element_size (e, &e_size);
    2723                 :        432 :               c->initializer = gfc_get_int_expr (gfc_size_kind,
    2724                 :            :                                                  NULL,
    2725                 :            :                                                  e_size);
    2726                 :        432 :               gfc_free_expr (e);
    2727                 :            : 
    2728                 :            :               /* Add component _extends.  */
    2729                 :        432 :               if (!gfc_add_component (vtype, "_extends", &c))
    2730                 :          0 :                 goto cleanup;
    2731                 :        432 :               c->attr.pointer = 1;
    2732                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2733                 :        432 :               c->ts.type = BT_VOID;
    2734                 :        432 :               c->initializer = gfc_get_null_expr (NULL);
    2735                 :            : 
    2736                 :            :               /* Add component _def_init.  */
    2737                 :        432 :               if (!gfc_add_component (vtype, "_def_init", &c))
    2738                 :          0 :                 goto cleanup;
    2739                 :        432 :               c->attr.pointer = 1;
    2740                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2741                 :        432 :               c->ts.type = BT_VOID;
    2742                 :        432 :               c->initializer = gfc_get_null_expr (NULL);
    2743                 :            : 
    2744                 :            :               /* Add component _copy.  */
    2745                 :        432 :               if (!gfc_add_component (vtype, "_copy", &c))
    2746                 :          0 :                 goto cleanup;
    2747                 :        432 :               c->attr.proc_pointer = 1;
    2748                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2749                 :        432 :               c->tb = XCNEW (gfc_typebound_proc);
    2750                 :        432 :               c->tb->ppc = 1;
    2751                 :            : 
    2752                 :        432 :               if (ts->type != BT_CHARACTER)
    2753                 :        305 :                 name = xasprintf ("__copy_%s", tname);
    2754                 :            :               else
    2755                 :            :                 {
    2756                 :            :                   /* __copy is always the same for characters.
    2757                 :            :                      Check to see if copy function already exists.  */
    2758                 :        127 :                   name = xasprintf ("__copy_character_%d", ts->kind);
    2759                 :        127 :                   contained = ns->contained;
    2760                 :        426 :                   for (; contained; contained = contained->sibling)
    2761                 :        299 :                     if (contained->proc_name
    2762                 :        299 :                         && strcmp (name, contained->proc_name->name) == 0)
    2763                 :            :                       {
    2764                 :          0 :                         copy = contained->proc_name;
    2765                 :          0 :                         goto got_char_copy;
    2766                 :            :                       }
    2767                 :            :                 }
    2768                 :            : 
    2769                 :            :               /* Set up namespace.  */
    2770                 :        432 :               sub_ns = gfc_get_namespace (ns, 0);
    2771                 :        432 :               sub_ns->sibling = ns->contained;
    2772                 :        432 :               ns->contained = sub_ns;
    2773                 :        432 :               sub_ns->resolved = 1;
    2774                 :            :               /* Set up procedure symbol.  */
    2775                 :        432 :               gfc_get_symbol (name, sub_ns, &copy);
    2776                 :        432 :               sub_ns->proc_name = copy;
    2777                 :        432 :               copy->attr.flavor = FL_PROCEDURE;
    2778                 :        432 :               copy->attr.subroutine = 1;
    2779                 :        432 :               copy->attr.pure = 1;
    2780                 :        432 :               copy->attr.if_source = IFSRC_DECL;
    2781                 :            :               /* This is elemental so that arrays are automatically
    2782                 :            :                  treated correctly by the scalarizer.  */
    2783                 :        432 :               copy->attr.elemental = 1;
    2784                 :        432 :               if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
    2785                 :        126 :                 copy->module = ns->proc_name->name;
    2786                 :        432 :               gfc_set_sym_referenced (copy);
    2787                 :            :               /* Set up formal arguments.  */
    2788                 :        432 :               gfc_get_symbol ("src", sub_ns, &src);
    2789                 :        432 :               src->ts.type = ts->type;
    2790                 :        432 :               src->ts.kind = ts->kind;
    2791                 :        432 :               src->attr.flavor = FL_VARIABLE;
    2792                 :        432 :               src->attr.dummy = 1;
    2793                 :        432 :               src->attr.intent = INTENT_IN;
    2794                 :        432 :               gfc_set_sym_referenced (src);
    2795                 :        432 :               copy->formal = gfc_get_formal_arglist ();
    2796                 :        432 :               copy->formal->sym = src;
    2797                 :        432 :               gfc_get_symbol ("dst", sub_ns, &dst);
    2798                 :        432 :               dst->ts.type = ts->type;
    2799                 :        432 :               dst->ts.kind = ts->kind;
    2800                 :        432 :               dst->attr.flavor = FL_VARIABLE;
    2801                 :        432 :               dst->attr.dummy = 1;
    2802                 :        432 :               dst->attr.intent = INTENT_INOUT;
    2803                 :        432 :               gfc_set_sym_referenced (dst);
    2804                 :        432 :               copy->formal->next = gfc_get_formal_arglist ();
    2805                 :        432 :               copy->formal->next->sym = dst;
    2806                 :            :               /* Set up code.  */
    2807                 :        432 :               sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN);
    2808                 :        432 :               sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
    2809                 :        432 :               sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
    2810                 :        432 :             got_char_copy:
    2811                 :            :               /* Set initializer.  */
    2812                 :        432 :               c->initializer = gfc_lval_expr_from_sym (copy);
    2813                 :        432 :               c->ts.interface = copy;
    2814                 :            : 
    2815                 :            :               /* Add component _final.  */
    2816                 :        432 :               if (!gfc_add_component (vtype, "_final", &c))
    2817                 :          0 :                 goto cleanup;
    2818                 :        432 :               c->attr.proc_pointer = 1;
    2819                 :        432 :               c->attr.access = ACCESS_PRIVATE;
    2820                 :        432 :               c->attr.artificial = 1;
    2821                 :        432 :               c->tb = XCNEW (gfc_typebound_proc);
    2822                 :        432 :               c->tb->ppc = 1;
    2823                 :        432 :               c->initializer = gfc_get_null_expr (NULL);
    2824                 :            :             }
    2825                 :        432 :           vtab->ts.u.derived = vtype;
    2826                 :        432 :           vtab->value = gfc_default_initializer (&vtab->ts);
    2827                 :            :         }
    2828                 :       2401 :       free (name);
    2829                 :            :     }
    2830                 :            : 
    2831                 :       2401 :   found_sym = vtab;
    2832                 :            : 
    2833                 :       2401 : cleanup:
    2834                 :            :   /* It is unexpected to have some symbols added at resolution or code
    2835                 :            :      generation time. We commit the changes in order to keep a clean state.  */
    2836                 :       2401 :   if (found_sym)
    2837                 :            :     {
    2838                 :       2401 :       gfc_commit_symbol (vtab);
    2839                 :       2401 :       if (vtype)
    2840                 :        432 :         gfc_commit_symbol (vtype);
    2841                 :       2401 :       if (copy)
    2842                 :        432 :         gfc_commit_symbol (copy);
    2843                 :       2401 :       if (src)
    2844                 :        432 :         gfc_commit_symbol (src);
    2845                 :       2401 :       if (dst)
    2846                 :        432 :         gfc_commit_symbol (dst);
    2847                 :            :     }
    2848                 :            :   else
    2849                 :          0 :     gfc_undo_symbols ();
    2850                 :            : 
    2851                 :       2401 :   return found_sym;
    2852                 :            : }
    2853                 :            : 
    2854                 :            : 
    2855                 :            : /*  Find (or generate) a vtab for an arbitrary type (derived or intrinsic).  */
    2856                 :            : 
    2857                 :            : gfc_symbol *
    2858                 :       9343 : gfc_find_vtab (gfc_typespec *ts)
    2859                 :            : {
    2860                 :       9343 :   switch (ts->type)
    2861                 :            :     {
    2862                 :            :     case BT_UNKNOWN:
    2863                 :            :       return NULL;
    2864                 :       4018 :     case BT_DERIVED:
    2865                 :       4018 :       return gfc_find_derived_vtab (ts->u.derived);
    2866                 :       2745 :     case BT_CLASS:
    2867                 :       2745 :       if (ts->u.derived->components && ts->u.derived->components->ts.u.derived)
    2868                 :       2743 :         return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
    2869                 :            :       else
    2870                 :            :         return NULL;
    2871                 :       2401 :     default:
    2872                 :       2401 :       return find_intrinsic_vtab (ts);
    2873                 :            :     }
    2874                 :            : }
    2875                 :            : 
    2876                 :            : 
    2877                 :            : /* General worker function to find either a type-bound procedure or a
    2878                 :            :    type-bound user operator.  */
    2879                 :            : 
    2880                 :            : static gfc_symtree*
    2881                 :     230576 : find_typebound_proc_uop (gfc_symbol* derived, bool* t,
    2882                 :            :                          const char* name, bool noaccess, bool uop,
    2883                 :            :                          locus* where)
    2884                 :            : {
    2885                 :     230576 :   gfc_symtree* res;
    2886                 :     230576 :   gfc_symtree* root;
    2887                 :            : 
    2888                 :            :   /* Set default to failure.  */
    2889                 :     230576 :   if (t)
    2890                 :     214389 :     *t = false;
    2891                 :            : 
    2892                 :     230576 :   if (derived->f2k_derived)
    2893                 :            :     /* Set correct symbol-root.  */
    2894                 :     211336 :     root = (uop ? derived->f2k_derived->tb_uop_root
    2895                 :            :                 : derived->f2k_derived->tb_sym_root);
    2896                 :            :   else
    2897                 :            :     return NULL;
    2898                 :            : 
    2899                 :            :   /* Try to find it in the current type's namespace.  */
    2900                 :     211336 :   res = gfc_find_symtree (root, name);
    2901                 :     211336 :   if (res && res->n.tb && !res->n.tb->error)
    2902                 :            :     {
    2903                 :            :       /* We found one.  */
    2904                 :       9121 :       if (t)
    2905                 :       5067 :         *t = true;
    2906                 :            : 
    2907                 :       9121 :       if (!noaccess && derived->attr.use_assoc
    2908                 :       2718 :           && res->n.tb->access == ACCESS_PRIVATE)
    2909                 :            :         {
    2910                 :          3 :           if (where)
    2911                 :          2 :             gfc_error ("%qs of %qs is PRIVATE at %L",
    2912                 :            :                        name, derived->name, where);
    2913                 :          3 :           if (t)
    2914                 :          3 :             *t = false;
    2915                 :            :         }
    2916                 :            : 
    2917                 :       9121 :       return res;
    2918                 :            :     }
    2919                 :            : 
    2920                 :            :   /* Otherwise, recurse on parent type if derived is an extension.  */
    2921                 :     202215 :   if (derived->attr.extension)
    2922                 :            :     {
    2923                 :      33708 :       gfc_symbol* super_type;
    2924                 :      33708 :       super_type = gfc_get_derived_super_type (derived);
    2925                 :      33708 :       gcc_assert (super_type);
    2926                 :            : 
    2927                 :      33708 :       return find_typebound_proc_uop (super_type, t, name,
    2928                 :      33708 :                                       noaccess, uop, where);
    2929                 :            :     }
    2930                 :            : 
    2931                 :            :   /* Nothing found.  */
    2932                 :            :   return NULL;
    2933                 :            : }
    2934                 :            : 
    2935                 :            : 
    2936                 :            : /* Find a type-bound procedure or user operator by name for a derived-type
    2937                 :            :    (looking recursively through the super-types).  */
    2938                 :            : 
    2939                 :            : gfc_symtree*
    2940                 :     196738 : gfc_find_typebound_proc (gfc_symbol* derived, bool* t,
    2941                 :            :                          const char* name, bool noaccess, locus* where)
    2942                 :            : {
    2943                 :     196738 :   return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
    2944                 :            : }
    2945                 :            : 
    2946                 :            : gfc_symtree*
    2947                 :        130 : gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
    2948                 :            :                             const char* name, bool noaccess, locus* where)
    2949                 :            : {
    2950                 :        130 :   return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
    2951                 :            : }
    2952                 :            : 
    2953                 :            : 
    2954                 :            : /* Find a type-bound intrinsic operator looking recursively through the
    2955                 :            :    super-type hierarchy.  */
    2956                 :            : 
    2957                 :            : gfc_typebound_proc*
    2958                 :      12900 : gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
    2959                 :            :                                  gfc_intrinsic_op op, bool noaccess,
    2960                 :            :                                  locus* where)
    2961                 :            : {
    2962                 :      12900 :   gfc_typebound_proc* res;
    2963                 :            : 
    2964                 :            :   /* Set default to failure.  */
    2965                 :      12900 :   if (t)
    2966                 :      12899 :     *t = false;
    2967                 :            : 
    2968                 :            :   /* Try to find it in the current type's namespace.  */
    2969                 :      12900 :   if (derived->f2k_derived)
    2970                 :      10376 :     res = derived->f2k_derived->tb_op[op];
    2971                 :            :   else
    2972                 :            :     res = NULL;
    2973                 :            : 
    2974                 :            :   /* Check access.  */
    2975                 :      10376 :   if (res && !res->error)
    2976                 :            :     {
    2977                 :            :       /* We found one.  */
    2978                 :        728 :       if (t)
    2979                 :        727 :         *t = true;
    2980                 :            : 
    2981                 :        728 :       if (!noaccess && derived->attr.use_assoc
    2982                 :        597 :           && res->access == ACCESS_PRIVATE)
    2983                 :            :         {
    2984                 :          2 :           if (where)
    2985                 :          0 :             gfc_error ("%qs of %qs is PRIVATE at %L",
    2986                 :            :                        gfc_op2string (op), derived->name, where);
    2987                 :          2 :           if (t)
    2988                 :          2 :             *t = false;
    2989                 :            :         }
    2990                 :            : 
    2991                 :        728 :       return res;
    2992                 :            :     }
    2993                 :            : 
    2994                 :            :   /* Otherwise, recurse on parent type if derived is an extension.  */
    2995                 :      12172 :   if (derived->attr.extension)
    2996                 :            :     {
    2997                 :        503 :       gfc_symbol* super_type;
    2998                 :        503 :       super_type = gfc_get_derived_super_type (derived);
    2999                 :        503 :       gcc_assert (super_type);
    3000                 :            : 
    3001                 :        503 :       return gfc_find_typebound_intrinsic_op (super_type, t, op,
    3002                 :        503 :                                               noaccess, where);
    3003                 :            :     }
    3004                 :            : 
    3005                 :            :   /* Nothing found.  */
    3006                 :            :   return NULL;
    3007                 :            : }
    3008                 :            : 
    3009                 :            : 
    3010                 :            : /* Get a typebound-procedure symtree or create and insert it if not yet
    3011                 :            :    present.  This is like a very simplified version of gfc_get_sym_tree for
    3012                 :            :    tbp-symtrees rather than regular ones.  */
    3013                 :            : 
    3014                 :            : gfc_symtree*
    3015                 :       6902 : gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
    3016                 :            : {
    3017                 :       6902 :   gfc_symtree *result = gfc_find_symtree (*root, name);
    3018                 :       6902 :   return result ? result : gfc_new_symtree (root, name);
    3019                 :            : }

Generated by: LCOV version 1.0

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto --enable-host-shared. GCC test suite is run with the built compiler.