LCOV - code coverage report
Current view: top level - gcc/fortran - trans.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 1093 1126 97.1 %
Date: 2020-03-28 11:57:23 Functions: 49 49 100.0 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Code translation -- generate GCC trees from gfc_code.
       2                 :            :    Copyright (C) 2002-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Paul Brook
       4                 :            : 
       5                 :            : This file is part of GCC.
       6                 :            : 
       7                 :            : GCC is free software; you can redistribute it and/or modify it under
       8                 :            : the terms of the GNU General Public License as published by the Free
       9                 :            : Software Foundation; either version 3, or (at your option) any later
      10                 :            : version.
      11                 :            : 
      12                 :            : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :            : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :            : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :            : for more details.
      16                 :            : 
      17                 :            : You should have received a copy of the GNU General Public License
      18                 :            : along with GCC; see the file COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */
      20                 :            : 
      21                 :            : #include "config.h"
      22                 :            : #include "system.h"
      23                 :            : #include "coretypes.h"
      24                 :            : #include "options.h"
      25                 :            : #include "tree.h"
      26                 :            : #include "gfortran.h"
      27                 :            : #include "gimple-expr.h"      /* For create_tmp_var_raw.  */
      28                 :            : #include "trans.h"
      29                 :            : #include "stringpool.h"
      30                 :            : #include "fold-const.h"
      31                 :            : #include "tree-iterator.h"
      32                 :            : #include "trans-stmt.h"
      33                 :            : #include "trans-array.h"
      34                 :            : #include "trans-types.h"
      35                 :            : #include "trans-const.h"
      36                 :            : 
      37                 :            : /* Naming convention for backend interface code:
      38                 :            : 
      39                 :            :    gfc_trans_*  translate gfc_code into STMT trees.
      40                 :            : 
      41                 :            :    gfc_conv_*   expression conversion
      42                 :            : 
      43                 :            :    gfc_get_*    get a backend tree representation of a decl or type  */
      44                 :            : 
      45                 :            : static gfc_file *gfc_current_backend_file;
      46                 :            : 
      47                 :            : const char gfc_msg_fault[] = N_("Array reference out of bounds");
      48                 :            : const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
      49                 :            : 
      50                 :            : 
      51                 :            : /* Return a location_t suitable for 'tree' for a gfortran locus.  The way the
      52                 :            :    parser works in gfortran, loc->lb->location contains only the line number
      53                 :            :    and LOCATION_COLUMN is 0; hence, the column has to be added when generating
      54                 :            :    locations for 'tree'.  Cf. error.c's gfc_format_decoder.  */
      55                 :            : 
      56                 :            : location_t
      57                 :     529523 : gfc_get_location (locus *loc)
      58                 :            : {
      59                 :     529523 :   return linemap_position_for_loc_and_offset (line_table, loc->lb->location,
      60                 :     529523 :                                               loc->nextc - loc->lb->line);
      61                 :            : }
      62                 :            : 
      63                 :            : /* Advance along TREE_CHAIN n times.  */
      64                 :            : 
      65                 :            : tree
      66                 :    2696370 : gfc_advance_chain (tree t, int n)
      67                 :            : {
      68                 :    8105790 :   for (; n > 0; n--)
      69                 :            :     {
      70                 :    5409420 :       gcc_assert (t != NULL_TREE);
      71                 :    5409420 :       t = DECL_CHAIN (t);
      72                 :            :     }
      73                 :    2696370 :   return t;
      74                 :            : }
      75                 :            : 
      76                 :            : /* Creates a variable declaration with a given TYPE.  */
      77                 :            : 
      78                 :            : tree
      79                 :     817596 : gfc_create_var_np (tree type, const char *prefix)
      80                 :            : {
      81                 :     817596 :   tree t;
      82                 :            : 
      83                 :     817596 :   t = create_tmp_var_raw (type, prefix);
      84                 :            : 
      85                 :            :   /* No warnings for anonymous variables.  */
      86                 :     817596 :   if (prefix == NULL)
      87                 :     465450 :     TREE_NO_WARNING (t) = 1;
      88                 :            : 
      89                 :     817596 :   return t;
      90                 :            : }
      91                 :            : 
      92                 :            : 
      93                 :            : /* Like above, but also adds it to the current scope.  */
      94                 :            : 
      95                 :            : tree
      96                 :     732636 : gfc_create_var (tree type, const char *prefix)
      97                 :            : {
      98                 :     732636 :   tree tmp;
      99                 :            : 
     100                 :     732636 :   tmp = gfc_create_var_np (type, prefix);
     101                 :            : 
     102                 :     732636 :   pushdecl (tmp);
     103                 :            : 
     104                 :     732636 :   return tmp;
     105                 :            : }
     106                 :            : 
     107                 :            : 
     108                 :            : /* If the expression is not constant, evaluate it now.  We assign the
     109                 :            :    result of the expression to an artificially created variable VAR, and
     110                 :            :    return a pointer to the VAR_DECL node for this variable.  */
     111                 :            : 
     112                 :            : tree
     113                 :    1153870 : gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
     114                 :            : {
     115                 :    1153870 :   tree var;
     116                 :            : 
     117                 :    1153870 :   if (CONSTANT_CLASS_P (expr))
     118                 :            :     return expr;
     119                 :            : 
     120                 :     371222 :   var = gfc_create_var (TREE_TYPE (expr), NULL);
     121                 :     371222 :   gfc_add_modify_loc (loc, pblock, var, expr);
     122                 :            : 
     123                 :     371222 :   return var;
     124                 :            : }
     125                 :            : 
     126                 :            : 
     127                 :            : tree
     128                 :    1133790 : gfc_evaluate_now (tree expr, stmtblock_t * pblock)
     129                 :            : {
     130                 :    1133790 :   return gfc_evaluate_now_loc (input_location, expr, pblock);
     131                 :            : }
     132                 :            : 
     133                 :            : /* Like gfc_evaluate_now, but add the created variable to the
     134                 :            :    function scope.  */
     135                 :            : 
     136                 :            : tree
     137                 :         51 : gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock)
     138                 :            : {
     139                 :         51 :   tree var;
     140                 :         51 :   var = gfc_create_var_np (TREE_TYPE (expr), NULL);
     141                 :         51 :   gfc_add_decl_to_function (var);
     142                 :         51 :   gfc_add_modify (pblock, var, expr);
     143                 :            : 
     144                 :         51 :   return var;
     145                 :            : }
     146                 :            : 
     147                 :            : /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
     148                 :            :    A MODIFY_EXPR is an assignment:
     149                 :            :    LHS <- RHS.  */
     150                 :            : 
     151                 :            : void
     152                 :    1951010 : gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
     153                 :            : {
     154                 :    1951010 :   tree tmp;
     155                 :            : 
     156                 :    1951010 :   tree t1, t2;
     157                 :    1951010 :   t1 = TREE_TYPE (rhs);
     158                 :    1951010 :   t2 = TREE_TYPE (lhs);
     159                 :            :   /* Make sure that the types of the rhs and the lhs are compatible
     160                 :            :      for scalar assignments.  We should probably have something
     161                 :            :      similar for aggregates, but right now removing that check just
     162                 :            :      breaks everything.  */
     163                 :    1951010 :   gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)
     164                 :            :                        || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
     165                 :            : 
     166                 :    1951010 :   tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
     167                 :            :                          rhs);
     168                 :    1951010 :   gfc_add_expr_to_block (pblock, tmp);
     169                 :    1951010 : }
     170                 :            : 
     171                 :            : 
     172                 :            : void
     173                 :    1535460 : gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
     174                 :            : {
     175                 :    1535460 :   gfc_add_modify_loc (input_location, pblock, lhs, rhs);
     176                 :    1535460 : }
     177                 :            : 
     178                 :            : 
     179                 :            : /* Create a new scope/binding level and initialize a block.  Care must be
     180                 :            :    taken when translating expressions as any temporaries will be placed in
     181                 :            :    the innermost scope.  */
     182                 :            : 
     183                 :            : void
     184                 :    1318360 : gfc_start_block (stmtblock_t * block)
     185                 :            : {
     186                 :            :   /* Start a new binding level.  */
     187                 :    1318360 :   pushlevel ();
     188                 :    1318360 :   block->has_scope = 1;
     189                 :            : 
     190                 :            :   /* The block is empty.  */
     191                 :    1318360 :   block->head = NULL_TREE;
     192                 :    1318360 : }
     193                 :            : 
     194                 :            : 
     195                 :            : /* Initialize a block without creating a new scope.  */
     196                 :            : 
     197                 :            : void
     198                 :    6778340 : gfc_init_block (stmtblock_t * block)
     199                 :            : {
     200                 :    6778340 :   block->head = NULL_TREE;
     201                 :    6778340 :   block->has_scope = 0;
     202                 :    6778340 : }
     203                 :            : 
     204                 :            : 
     205                 :            : /* Sometimes we create a scope but it turns out that we don't actually
     206                 :            :    need it.  This function merges the scope of BLOCK with its parent.
     207                 :            :    Only variable decls will be merged, you still need to add the code.  */
     208                 :            : 
     209                 :            : void
     210                 :        100 : gfc_merge_block_scope (stmtblock_t * block)
     211                 :            : {
     212                 :        100 :   tree decl;
     213                 :        100 :   tree next;
     214                 :            : 
     215                 :        100 :   gcc_assert (block->has_scope);
     216                 :        100 :   block->has_scope = 0;
     217                 :            : 
     218                 :            :   /* Remember the decls in this scope.  */
     219                 :        100 :   decl = getdecls ();
     220                 :        100 :   poplevel (0, 0);
     221                 :            : 
     222                 :            :   /* Add them to the parent scope.  */
     223                 :        253 :   while (decl != NULL_TREE)
     224                 :            :     {
     225                 :        153 :       next = DECL_CHAIN (decl);
     226                 :        153 :       DECL_CHAIN (decl) = NULL_TREE;
     227                 :            : 
     228                 :        153 :       pushdecl (decl);
     229                 :        153 :       decl = next;
     230                 :            :     }
     231                 :        100 : }
     232                 :            : 
     233                 :            : 
     234                 :            : /* Finish a scope containing a block of statements.  */
     235                 :            : 
     236                 :            : tree
     237                 :    2285850 : gfc_finish_block (stmtblock_t * stmtblock)
     238                 :            : {
     239                 :    2285850 :   tree decl;
     240                 :    2285850 :   tree expr;
     241                 :    2285850 :   tree block;
     242                 :            : 
     243                 :    2285850 :   expr = stmtblock->head;
     244                 :    2285850 :   if (!expr)
     245                 :     317513 :     expr = build_empty_stmt (input_location);
     246                 :            : 
     247                 :    2285850 :   stmtblock->head = NULL_TREE;
     248                 :            : 
     249                 :    2285850 :   if (stmtblock->has_scope)
     250                 :            :     {
     251                 :    1318250 :       decl = getdecls ();
     252                 :            : 
     253                 :    1318250 :       if (decl)
     254                 :            :         {
     255                 :     326699 :           block = poplevel (1, 0);
     256                 :     326699 :           expr = build3_v (BIND_EXPR, decl, expr, block);
     257                 :            :         }
     258                 :            :       else
     259                 :     991552 :         poplevel (0, 0);
     260                 :            :     }
     261                 :            : 
     262                 :    2285850 :   return expr;
     263                 :            : }
     264                 :            : 
     265                 :            : 
     266                 :            : /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
     267                 :            :    natural type is used.  */
     268                 :            : 
     269                 :            : tree
     270                 :    1003050 : gfc_build_addr_expr (tree type, tree t)
     271                 :            : {
     272                 :    1003050 :   tree base_type = TREE_TYPE (t);
     273                 :    1003050 :   tree natural_type;
     274                 :            : 
     275                 :     395123 :   if (type && POINTER_TYPE_P (type)
     276                 :     395123 :       && TREE_CODE (base_type) == ARRAY_TYPE
     277                 :    1354010 :       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
     278                 :     350961 :          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
     279                 :            :     {
     280                 :     267003 :       tree min_val = size_zero_node;
     281                 :     267003 :       tree type_domain = TYPE_DOMAIN (base_type);
     282                 :     267003 :       if (type_domain && TYPE_MIN_VALUE (type_domain))
     283                 :     267003 :         min_val = TYPE_MIN_VALUE (type_domain);
     284                 :     267003 :       t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
     285                 :            :                             t, min_val, NULL_TREE, NULL_TREE));
     286                 :     267003 :       natural_type = type;
     287                 :            :     }
     288                 :            :   else
     289                 :     736044 :     natural_type = build_pointer_type (base_type);
     290                 :            : 
     291                 :    1003050 :   if (TREE_CODE (t) == INDIRECT_REF)
     292                 :            :     {
     293                 :      63747 :       if (!type)
     294                 :      50589 :         type = natural_type;
     295                 :      63747 :       t = TREE_OPERAND (t, 0);
     296                 :      63747 :       natural_type = TREE_TYPE (t);
     297                 :            :     }
     298                 :            :   else
     299                 :            :     {
     300                 :     939300 :       tree base = get_base_address (t);
     301                 :     939300 :       if (base && DECL_P (base))
     302                 :     662007 :         TREE_ADDRESSABLE (base) = 1;
     303                 :     939300 :       t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
     304                 :            :     }
     305                 :            : 
     306                 :    1003050 :   if (type && natural_type != type)
     307                 :      86366 :     t = convert (type, t);
     308                 :            : 
     309                 :    1003050 :   return t;
     310                 :            : }
     311                 :            : 
     312                 :            : 
     313                 :            : static tree
     314                 :       7483 : get_array_span (tree type, tree decl)
     315                 :            : {
     316                 :       7483 :   tree span;
     317                 :            : 
     318                 :            :   /* Component references are guaranteed to have a reliable value for
     319                 :            :      'span'. Likewise indirect references since they emerge from the
     320                 :            :      conversion of a CFI descriptor or the hidden dummy descriptor.  */
     321                 :       7483 :   if (TREE_CODE (decl) == COMPONENT_REF
     322                 :       8692 :       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
     323                 :       1209 :     return gfc_conv_descriptor_span_get (decl);
     324                 :       6274 :   else if (TREE_CODE (decl) == INDIRECT_REF
     325                 :       6357 :            && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
     326                 :         83 :     return gfc_conv_descriptor_span_get (decl);
     327                 :            : 
     328                 :            :   /* Return the span for deferred character length array references.  */
     329                 :       6191 :   if (type && TREE_CODE (type) == ARRAY_TYPE
     330                 :       1470 :       && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
     331                 :       1470 :       && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
     332                 :        515 :           || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
     333                 :       7177 :       && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
     334                 :        955 :           || TREE_CODE (decl) == FUNCTION_DECL
     335                 :        955 :           || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
     336                 :        955 :                                         == DECL_CONTEXT (decl)))
     337                 :            :     {
     338                 :        974 :       span = fold_convert (gfc_array_index_type,
     339                 :            :                            TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
     340                 :        974 :       span = fold_build2 (MULT_EXPR, gfc_array_index_type,
     341                 :            :                           fold_convert (gfc_array_index_type,
     342                 :            :                                         TYPE_SIZE_UNIT (TREE_TYPE (type))),
     343                 :            :                           span);
     344                 :            :     }
     345                 :       5217 :   else if (type && TREE_CODE (type) == ARRAY_TYPE
     346                 :        496 :            && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
     347                 :       5713 :            && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
     348                 :            :     {
     349                 :          0 :       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
     350                 :          0 :         span = gfc_conv_descriptor_span_get (decl);
     351                 :            :       else
     352                 :            :         span = NULL_TREE;
     353                 :            :     }
     354                 :            :   /* Likewise for class array or pointer array references.  */
     355                 :       5217 :   else if (TREE_CODE (decl) == FIELD_DECL
     356                 :       5217 :            || VAR_OR_FUNCTION_DECL_P (decl)
     357                 :       1698 :            || TREE_CODE (decl) == PARM_DECL)
     358                 :            :     {
     359                 :       5217 :       if (GFC_DECL_CLASS (decl))
     360                 :            :         {
     361                 :            :           /* When a temporary is in place for the class array, then the
     362                 :            :              original class' declaration is stored in the saved
     363                 :            :              descriptor.  */
     364                 :          0 :           if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
     365                 :          0 :             decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     366                 :            :           else
     367                 :            :             {
     368                 :            :               /* Allow for dummy arguments and other good things.  */
     369                 :          0 :               if (POINTER_TYPE_P (TREE_TYPE (decl)))
     370                 :          0 :                 decl = build_fold_indirect_ref_loc (input_location, decl);
     371                 :            : 
     372                 :            :               /* Check if '_data' is an array descriptor.  If it is not,
     373                 :            :                  the array must be one of the components of the class
     374                 :            :                  object, so return a null span.  */
     375                 :          0 :               if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
     376                 :            :                                           gfc_class_data_get (decl))))
     377                 :            :                 return NULL_TREE;
     378                 :            :             }
     379                 :          0 :           span = gfc_class_vtab_size_get (decl);
     380                 :            :         }
     381                 :       5217 :       else if (GFC_DECL_PTR_ARRAY_P (decl))
     382                 :            :         {
     383                 :       5067 :           if (TREE_CODE (decl) == PARM_DECL)
     384                 :       1698 :             decl = build_fold_indirect_ref_loc (input_location, decl);
     385                 :       5067 :           span = gfc_conv_descriptor_span_get (decl);
     386                 :            :         }
     387                 :            :       else
     388                 :            :         span = NULL_TREE;
     389                 :            :     }
     390                 :            :   else
     391                 :            :     span = NULL_TREE;
     392                 :            : 
     393                 :            :   return span;
     394                 :            : }
     395                 :            : 
     396                 :            : 
     397                 :            : /* Build an ARRAY_REF with its natural type.  */
     398                 :            : 
     399                 :            : tree
     400                 :     727796 : gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
     401                 :            : {
     402                 :     727796 :   tree type = TREE_TYPE (base);
     403                 :     727796 :   tree tmp;
     404                 :     727796 :   tree span = NULL_TREE;
     405                 :            : 
     406                 :     727796 :   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
     407                 :            :     {
     408                 :         70 :       gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
     409                 :            : 
     410                 :         70 :       return fold_convert (TYPE_MAIN_VARIANT (type), base);
     411                 :            :     }
     412                 :            : 
     413                 :            :   /* Scalar coarray, there is nothing to do.  */
     414                 :     727726 :   if (TREE_CODE (type) != ARRAY_TYPE)
     415                 :            :     {
     416                 :          4 :       gcc_assert (decl == NULL_TREE);
     417                 :          4 :       gcc_assert (integer_zerop (offset));
     418                 :            :       return base;
     419                 :            :     }
     420                 :            : 
     421                 :     727722 :   type = TREE_TYPE (type);
     422                 :            : 
     423                 :     727722 :   if (DECL_P (base))
     424                 :     127330 :     TREE_ADDRESSABLE (base) = 1;
     425                 :            : 
     426                 :            :   /* Strip NON_LVALUE_EXPR nodes.  */
     427                 :     748042 :   STRIP_TYPE_NOPS (offset);
     428                 :            : 
     429                 :            :   /* If decl or vptr are non-null, pointer arithmetic for the array reference
     430                 :            :      is likely. Generate the 'span' for the array reference.  */
     431                 :     727722 :   if (vptr)
     432                 :       1560 :     span = gfc_vptr_size_get (vptr);
     433                 :     726162 :   else if (decl)
     434                 :       7483 :     span = get_array_span (type, decl);
     435                 :            : 
     436                 :            :   /* If a non-null span has been generated reference the element with
     437                 :            :      pointer arithmetic.  */
     438                 :       9043 :   if (span != NULL_TREE)
     439                 :            :     {
     440                 :       8893 :       offset = fold_build2_loc (input_location, MULT_EXPR,
     441                 :            :                                 gfc_array_index_type,
     442                 :            :                                 offset, span);
     443                 :       8893 :       tmp = gfc_build_addr_expr (pvoid_type_node, base);
     444                 :       8893 :       tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
     445                 :       8893 :       tmp = fold_convert (build_pointer_type (type), tmp);
     446                 :       8893 :       if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
     447                 :      12154 :           || !TYPE_STRING_FLAG (type))
     448                 :       7286 :         tmp = build_fold_indirect_ref_loc (input_location, tmp);
     449                 :       8893 :       return tmp;
     450                 :            :     }
     451                 :            :   /* Otherwise use a straightforward array reference.  */
     452                 :            :   else
     453                 :     718829 :     return build4_loc (input_location, ARRAY_REF, type, base, offset,
     454                 :            :                        NULL_TREE, NULL_TREE);
     455                 :            : }
     456                 :            : 
     457                 :            : 
     458                 :            : /* Generate a call to print a runtime error possibly including multiple
     459                 :            :    arguments and a locus.  */
     460                 :            : 
     461                 :            : static tree
     462                 :      47570 : trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid,
     463                 :            :                             va_list ap)
     464                 :            : {
     465                 :      47570 :   stmtblock_t block;
     466                 :      47570 :   tree tmp;
     467                 :      47570 :   tree arg, arg2;
     468                 :      47570 :   tree *argarray;
     469                 :      47570 :   tree fntype;
     470                 :      47570 :   char *message;
     471                 :      47570 :   const char *p;
     472                 :      47570 :   int line, nargs, i;
     473                 :      47570 :   location_t loc;
     474                 :            : 
     475                 :            :   /* Compute the number of extra arguments from the format string.  */
     476                 :    2338550 :   for (p = msgid, nargs = 0; *p; p++)
     477                 :    2290980 :     if (*p == '%')
     478                 :            :       {
     479                 :      67839 :         p++;
     480                 :      67839 :         if (*p != '%')
     481                 :      67459 :           nargs++;
     482                 :            :       }
     483                 :            : 
     484                 :            :   /* The code to generate the error.  */
     485                 :      47570 :   gfc_start_block (&block);
     486                 :            : 
     487                 :      47570 :   if (where)
     488                 :            :     {
     489                 :      34711 :       line = LOCATION_LINE (where->lb->location);
     490                 :      34711 :       message = xasprintf ("At line %d of file %s",  line,
     491                 :      34711 :                            where->lb->file->filename);
     492                 :            :     }
     493                 :            :   else
     494                 :      38577 :     message = xasprintf ("In file '%s', around line %d",
     495                 :      12859 :                          gfc_source_file, LOCATION_LINE (input_location) + 1);
     496                 :            : 
     497                 :      47570 :   arg = gfc_build_addr_expr (pchar_type_node,
     498                 :            :                              gfc_build_localized_cstring_const (message));
     499                 :      47570 :   free (message);
     500                 :            : 
     501                 :      47570 :   message = xasprintf ("%s", _(msgid));
     502                 :      47570 :   arg2 = gfc_build_addr_expr (pchar_type_node,
     503                 :            :                               gfc_build_localized_cstring_const (message));
     504                 :      47570 :   free (message);
     505                 :            : 
     506                 :            :   /* Build the argument array.  */
     507                 :      47570 :   argarray = XALLOCAVEC (tree, nargs + 2);
     508                 :      47570 :   argarray[0] = arg;
     509                 :      47570 :   argarray[1] = arg2;
     510                 :     115029 :   for (i = 0; i < nargs; i++)
     511                 :      67459 :     argarray[2 + i] = va_arg (ap, tree);
     512                 :            : 
     513                 :            :   /* Build the function call to runtime_(warning,error)_at; because of the
     514                 :            :      variable number of arguments, we can't use build_call_expr_loc dinput_location,
     515                 :            :      irectly.  */
     516                 :      47570 :   fntype = TREE_TYPE (errorfunc);
     517                 :            : 
     518                 :      47570 :   loc = where ? gfc_get_location (where) : input_location;
     519                 :      47570 :   tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
     520                 :            :                                    fold_build1_loc (loc, ADDR_EXPR,
     521                 :            :                                              build_pointer_type (fntype),
     522                 :            :                                              errorfunc),
     523                 :            :                                    nargs + 2, argarray);
     524                 :      47570 :   gfc_add_expr_to_block (&block, tmp);
     525                 :            : 
     526                 :      47570 :   return gfc_finish_block (&block);
     527                 :            : }
     528                 :            : 
     529                 :            : 
     530                 :            : tree
     531                 :      15426 : gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
     532                 :            : {
     533                 :      15426 :   va_list ap;
     534                 :      15426 :   tree result;
     535                 :            : 
     536                 :      15426 :   va_start (ap, msgid);
     537                 :      15426 :   result = trans_runtime_error_vararg (error
     538                 :            :                                        ? gfor_fndecl_runtime_error_at
     539                 :            :                                        : gfor_fndecl_runtime_warning_at,
     540                 :            :                                        where, msgid, ap);
     541                 :      15426 :   va_end (ap);
     542                 :      15426 :   return result;
     543                 :            : }
     544                 :            : 
     545                 :            : 
     546                 :            : /* Generate a runtime error if COND is true.  */
     547                 :            : 
     548                 :            : void
     549                 :      54397 : gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
     550                 :            :                          locus * where, const char * msgid, ...)
     551                 :            : {
     552                 :      54397 :   va_list ap;
     553                 :      54397 :   stmtblock_t block;
     554                 :      54397 :   tree body;
     555                 :      54397 :   tree tmp;
     556                 :      54397 :   tree tmpvar = NULL;
     557                 :            : 
     558                 :      54397 :   if (integer_zerop (cond))
     559                 :      35082 :     return;
     560                 :            : 
     561                 :      19315 :   if (once)
     562                 :            :     {
     563                 :         24 :        tmpvar = gfc_create_var (logical_type_node, "print_warning");
     564                 :         24 :        TREE_STATIC (tmpvar) = 1;
     565                 :         24 :        DECL_INITIAL (tmpvar) = logical_true_node;
     566                 :         24 :        gfc_add_expr_to_block (pblock, tmpvar);
     567                 :            :     }
     568                 :            : 
     569                 :      19315 :   gfc_start_block (&block);
     570                 :            : 
     571                 :            :   /* For error, runtime_error_at already implies PRED_NORETURN.  */
     572                 :      19315 :   if (!error && once)
     573                 :         24 :     gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
     574                 :            :                                                        NOT_TAKEN));
     575                 :            : 
     576                 :            :   /* The code to generate the error.  */
     577                 :      19315 :   va_start (ap, msgid);
     578                 :      19315 :   gfc_add_expr_to_block (&block,
     579                 :            :                          trans_runtime_error_vararg
     580                 :            :                          (error ? gfor_fndecl_runtime_error_at
     581                 :            :                           : gfor_fndecl_runtime_warning_at,
     582                 :            :                           where, msgid, ap));
     583                 :      19315 :   va_end (ap);
     584                 :            : 
     585                 :      19315 :   if (once)
     586                 :         24 :     gfc_add_modify (&block, tmpvar, logical_false_node);
     587                 :            : 
     588                 :      19315 :   body = gfc_finish_block (&block);
     589                 :            : 
     590                 :      19315 :   if (integer_onep (cond))
     591                 :            :     {
     592                 :         28 :       gfc_add_expr_to_block (pblock, body);
     593                 :            :     }
     594                 :            :   else
     595                 :            :     {
     596                 :      19287 :       if (once)
     597                 :         20 :         cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
     598                 :            :                                 long_integer_type_node, tmpvar, cond);
     599                 :            :       else
     600                 :      19267 :         cond = fold_convert (long_integer_type_node, cond);
     601                 :            : 
     602                 :      19287 :       tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
     603                 :            :                              cond, body,
     604                 :            :                              build_empty_stmt (gfc_get_location (where)));
     605                 :      19287 :       gfc_add_expr_to_block (pblock, tmp);
     606                 :            :     }
     607                 :            : }
     608                 :            : 
     609                 :            : 
     610                 :            : static tree
     611                 :      12829 : trans_os_error_at (locus* where, const char* msgid, ...)
     612                 :            : {
     613                 :      12829 :   va_list ap;
     614                 :      12829 :   tree result;
     615                 :            : 
     616                 :      12829 :   va_start (ap, msgid);
     617                 :      12829 :   result = trans_runtime_error_vararg (gfor_fndecl_os_error_at,
     618                 :            :                                        where, msgid, ap);
     619                 :      12829 :   va_end (ap);
     620                 :      12829 :   return result;
     621                 :            : }
     622                 :            : 
     623                 :            : 
     624                 :            : 
     625                 :            : /* Call malloc to allocate size bytes of memory, with special conditions:
     626                 :            :       + if size == 0, return a malloced area of size 1,
     627                 :            :       + if malloc returns NULL, issue a runtime error.  */
     628                 :            : tree
     629                 :      15286 : gfc_call_malloc (stmtblock_t * block, tree type, tree size)
     630                 :            : {
     631                 :      15286 :   tree tmp, malloc_result, null_result, res, malloc_tree;
     632                 :      15286 :   stmtblock_t block2;
     633                 :            : 
     634                 :            :   /* Create a variable to hold the result.  */
     635                 :      15286 :   res = gfc_create_var (prvoid_type_node, NULL);
     636                 :            : 
     637                 :            :   /* Call malloc.  */
     638                 :      15286 :   gfc_start_block (&block2);
     639                 :            : 
     640                 :      15286 :   size = fold_convert (size_type_node, size);
     641                 :      15286 :   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
     642                 :      15286 :                           build_int_cst (size_type_node, 1));
     643                 :            : 
     644                 :      15286 :   malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
     645                 :      15286 :   gfc_add_modify (&block2, res,
     646                 :            :                   fold_convert (prvoid_type_node,
     647                 :            :                                 build_call_expr_loc (input_location,
     648                 :            :                                                      malloc_tree, 1, size)));
     649                 :            : 
     650                 :            :   /* Optionally check whether malloc was successful.  */
     651                 :      15286 :   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
     652                 :            :     {
     653                 :        103 :       null_result = fold_build2_loc (input_location, EQ_EXPR,
     654                 :            :                                      logical_type_node, res,
     655                 :        103 :                                      build_int_cst (pvoid_type_node, 0));
     656                 :        103 :       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
     657                 :            :                              null_result,
     658                 :            :                              trans_os_error_at (NULL,
     659                 :            :                                                 "Error allocating %lu bytes",
     660                 :            :                                                 fold_convert
     661                 :            :                                                 (long_unsigned_type_node,
     662                 :            :                                                  size)),
     663                 :            :                              build_empty_stmt (input_location));
     664                 :        103 :       gfc_add_expr_to_block (&block2, tmp);
     665                 :            :     }
     666                 :            : 
     667                 :      15286 :   malloc_result = gfc_finish_block (&block2);
     668                 :      15286 :   gfc_add_expr_to_block (block, malloc_result);
     669                 :            : 
     670                 :      15286 :   if (type != NULL)
     671                 :      12198 :     res = fold_convert (type, res);
     672                 :      15286 :   return res;
     673                 :            : }
     674                 :            : 
     675                 :            : 
     676                 :            : /* Allocate memory, using an optional status argument.
     677                 :            : 
     678                 :            :    This function follows the following pseudo-code:
     679                 :            : 
     680                 :            :     void *
     681                 :            :     allocate (size_t size, integer_type stat)
     682                 :            :     {
     683                 :            :       void *newmem;
     684                 :            : 
     685                 :            :       if (stat requested)
     686                 :            :         stat = 0;
     687                 :            : 
     688                 :            :       newmem = malloc (MAX (size, 1));
     689                 :            :       if (newmem == NULL)
     690                 :            :       {
     691                 :            :         if (stat)
     692                 :            :           *stat = LIBERROR_ALLOCATION;
     693                 :            :         else
     694                 :            :           runtime_error ("Allocation would exceed memory limit");
     695                 :            :       }
     696                 :            :       return newmem;
     697                 :            :     }  */
     698                 :            : void
     699                 :      12152 : gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
     700                 :            :                            tree size, tree status)
     701                 :            : {
     702                 :      12152 :   tree tmp, error_cond;
     703                 :      12152 :   stmtblock_t on_error;
     704                 :      12401 :   tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
     705                 :            : 
     706                 :            :   /* If successful and stat= is given, set status to 0.  */
     707                 :      12152 :   if (status != NULL_TREE)
     708                 :        249 :       gfc_add_expr_to_block (block,
     709                 :            :              fold_build2_loc (input_location, MODIFY_EXPR, status_type,
     710                 :        249 :                               status, build_int_cst (status_type, 0)));
     711                 :            : 
     712                 :            :   /* The allocation itself.  */
     713                 :      12152 :   size = fold_convert (size_type_node, size);
     714                 :      24304 :   gfc_add_modify (block, pointer,
     715                 :      24304 :           fold_convert (TREE_TYPE (pointer),
     716                 :            :                 build_call_expr_loc (input_location,
     717                 :            :                              builtin_decl_explicit (BUILT_IN_MALLOC), 1,
     718                 :            :                              fold_build2_loc (input_location,
     719                 :            :                                       MAX_EXPR, size_type_node, size,
     720                 :            :                                       build_int_cst (size_type_node, 1)))));
     721                 :            : 
     722                 :            :   /* What to do in case of error.  */
     723                 :      12152 :   gfc_start_block (&on_error);
     724                 :      12152 :   if (status != NULL_TREE)
     725                 :            :     {
     726                 :        249 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
     727                 :        249 :                              build_int_cst (status_type, LIBERROR_ALLOCATION));
     728                 :        249 :       gfc_add_expr_to_block (&on_error, tmp);
     729                 :            :     }
     730                 :            :   else
     731                 :            :     {
     732                 :            :       /* Here, os_error_at already implies PRED_NORETURN.  */
     733                 :      11903 :       tree lusize = fold_convert (long_unsigned_type_node, size);
     734                 :      11903 :       tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize);
     735                 :      11903 :       gfc_add_expr_to_block (&on_error, tmp);
     736                 :            :     }
     737                 :            : 
     738                 :      12152 :   error_cond = fold_build2_loc (input_location, EQ_EXPR,
     739                 :            :                                 logical_type_node, pointer,
     740                 :      12152 :                                 build_int_cst (prvoid_type_node, 0));
     741                 :      12152 :   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
     742                 :            :                          gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC),
     743                 :            :                          gfc_finish_block (&on_error),
     744                 :            :                          build_empty_stmt (input_location));
     745                 :            : 
     746                 :      12152 :   gfc_add_expr_to_block (block, tmp);
     747                 :      12152 : }
     748                 :            : 
     749                 :            : 
     750                 :            : /* Allocate memory, using an optional status argument.
     751                 :            : 
     752                 :            :    This function follows the following pseudo-code:
     753                 :            : 
     754                 :            :     void *
     755                 :            :     allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
     756                 :            :     {
     757                 :            :       void *newmem;
     758                 :            : 
     759                 :            :       newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
     760                 :            :       return newmem;
     761                 :            :     }  */
     762                 :            : void
     763                 :        598 : gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size,
     764                 :            :                             tree token, tree status, tree errmsg, tree errlen,
     765                 :            :                             gfc_coarray_regtype alloc_type)
     766                 :            : {
     767                 :        598 :   tree tmp, pstat;
     768                 :            : 
     769                 :        598 :   gcc_assert (token != NULL_TREE);
     770                 :            : 
     771                 :            :   /* The allocation itself.  */
     772                 :        598 :   if (status == NULL_TREE)
     773                 :        586 :     pstat  = null_pointer_node;
     774                 :            :   else
     775                 :         12 :     pstat  = gfc_build_addr_expr (NULL_TREE, status);
     776                 :            : 
     777                 :        598 :   if (errmsg == NULL_TREE)
     778                 :            :     {
     779                 :        586 :       gcc_assert(errlen == NULL_TREE);
     780                 :        586 :       errmsg = null_pointer_node;
     781                 :        586 :       errlen = build_int_cst (integer_type_node, 0);
     782                 :            :     }
     783                 :            : 
     784                 :        598 :   size = fold_convert (size_type_node, size);
     785                 :        598 :   tmp = build_call_expr_loc (input_location,
     786                 :            :              gfor_fndecl_caf_register, 7,
     787                 :            :              fold_build2_loc (input_location,
     788                 :            :                               MAX_EXPR, size_type_node, size, size_one_node),
     789                 :            :              build_int_cst (integer_type_node, alloc_type),
     790                 :            :              token, gfc_build_addr_expr (pvoid_type_node, pointer),
     791                 :            :              pstat, errmsg, errlen);
     792                 :            : 
     793                 :        598 :   gfc_add_expr_to_block (block, tmp);
     794                 :            : 
     795                 :            :   /* It guarantees memory consistency within the same segment */
     796                 :        598 :   tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
     797                 :        598 :   tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
     798                 :            :                     gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
     799                 :            :                     tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
     800                 :        598 :   ASM_VOLATILE_P (tmp) = 1;
     801                 :        598 :   gfc_add_expr_to_block (block, tmp);
     802                 :        598 : }
     803                 :            : 
     804                 :            : 
     805                 :            : /* Generate code for an ALLOCATE statement when the argument is an
     806                 :            :    allocatable variable.  If the variable is currently allocated, it is an
     807                 :            :    error to allocate it again.
     808                 :            : 
     809                 :            :    This function follows the following pseudo-code:
     810                 :            : 
     811                 :            :     void *
     812                 :            :     allocate_allocatable (void *mem, size_t size, integer_type stat)
     813                 :            :     {
     814                 :            :       if (mem == NULL)
     815                 :            :         return allocate (size, stat);
     816                 :            :       else
     817                 :            :       {
     818                 :            :         if (stat)
     819                 :            :           stat = LIBERROR_ALLOCATION;
     820                 :            :         else
     821                 :            :           runtime_error ("Attempting to allocate already allocated variable");
     822                 :            :       }
     823                 :            :     }
     824                 :            : 
     825                 :            :     expr must be set to the original expression being allocated for its locus
     826                 :            :     and variable name in case a runtime error has to be printed.  */
     827                 :            : void
     828                 :       8810 : gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
     829                 :            :                           tree token, tree status, tree errmsg, tree errlen,
     830                 :            :                           tree label_finish, gfc_expr* expr, int corank)
     831                 :            : {
     832                 :       8810 :   stmtblock_t alloc_block;
     833                 :       8810 :   tree tmp, null_mem, alloc, error;
     834                 :       8810 :   tree type = TREE_TYPE (mem);
     835                 :       8810 :   symbol_attribute caf_attr;
     836                 :       8810 :   bool need_assign = false, refs_comp = false;
     837                 :       8810 :   gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
     838                 :            : 
     839                 :       8810 :   size = fold_convert (size_type_node, size);
     840                 :       8810 :   null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
     841                 :            :                                             logical_type_node, mem,
     842                 :       8810 :                                             build_int_cst (type, 0)),
     843                 :            :                            PRED_FORTRAN_REALLOC);
     844                 :            : 
     845                 :            :   /* If mem is NULL, we call gfc_allocate_using_malloc or
     846                 :            :      gfc_allocate_using_lib.  */
     847                 :       8810 :   gfc_start_block (&alloc_block);
     848                 :            : 
     849                 :       8810 :   if (flag_coarray == GFC_FCOARRAY_LIB)
     850                 :        338 :     caf_attr = gfc_caf_attr (expr, true, &refs_comp);
     851                 :            : 
     852                 :       8810 :   if (flag_coarray == GFC_FCOARRAY_LIB
     853                 :        338 :       && (corank > 0 || caf_attr.codimension))
     854                 :            :     {
     855                 :        309 :       tree cond, sub_caf_tree;
     856                 :        309 :       gfc_se se;
     857                 :        309 :       bool compute_special_caf_types_size = false;
     858                 :            : 
     859                 :        309 :       if (expr->ts.type == BT_DERIVED
     860                 :         87 :           && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
     861                 :         87 :           && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
     862                 :            :         {
     863                 :            :           compute_special_caf_types_size = true;
     864                 :            :           caf_alloc_type = GFC_CAF_LOCK_ALLOC;
     865                 :            :         }
     866                 :        305 :       else if (expr->ts.type == BT_DERIVED
     867                 :         83 :                && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
     868                 :         83 :                && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
     869                 :            :         {
     870                 :            :           compute_special_caf_types_size = true;
     871                 :            :           caf_alloc_type = GFC_CAF_EVENT_ALLOC;
     872                 :            :         }
     873                 :        304 :       else if (!caf_attr.coarray_comp && refs_comp)
     874                 :            :         /* Only allocatable components in a derived type coarray can be
     875                 :            :            allocate only.  */
     876                 :        180 :         caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
     877                 :            : 
     878                 :        309 :       gfc_init_se (&se, NULL);
     879                 :        309 :       sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
     880                 :        309 :       if (sub_caf_tree == NULL_TREE)
     881                 :        114 :         sub_caf_tree = token;
     882                 :            : 
     883                 :            :       /* When mem is an array ref, then strip the .data-ref.  */
     884                 :        309 :       if (TREE_CODE (mem) == COMPONENT_REF
     885                 :        618 :           && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem))))
     886                 :        309 :         tmp = TREE_OPERAND (mem, 0);
     887                 :            :       else
     888                 :            :         tmp = mem;
     889                 :            : 
     890                 :        356 :       if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp))
     891                 :         47 :             && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0)
     892                 :        356 :           && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
     893                 :            :         {
     894                 :        105 :           symbol_attribute attr;
     895                 :            : 
     896                 :        105 :           gfc_clear_attr (&attr);
     897                 :        105 :           tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr);
     898                 :        105 :           need_assign = true;
     899                 :            :         }
     900                 :        309 :       gfc_add_block_to_block (&alloc_block, &se.pre);
     901                 :            : 
     902                 :            :       /* In the front end, we represent the lock variable as pointer. However,
     903                 :            :          the FE only passes the pointer around and leaves the actual
     904                 :            :          representation to the library. Hence, we have to convert back to the
     905                 :            :          number of elements.  */
     906                 :        309 :       if (compute_special_caf_types_size)
     907                 :         10 :         size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
     908                 :          5 :                                 size, TYPE_SIZE_UNIT (ptr_type_node));
     909                 :            : 
     910                 :        309 :       gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree,
     911                 :            :                                   status, errmsg, errlen, caf_alloc_type);
     912                 :        309 :       if (need_assign)
     913                 :        105 :         gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem),
     914                 :            :                                            gfc_conv_descriptor_data_get (tmp)));
     915                 :        309 :       if (status != NULL_TREE)
     916                 :            :         {
     917                 :         12 :           TREE_USED (label_finish) = 1;
     918                 :         12 :           tmp = build1_v (GOTO_EXPR, label_finish);
     919                 :         24 :           cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
     920                 :         12 :                                   status, build_zero_cst (TREE_TYPE (status)));
     921                 :         12 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
     922                 :            :                                  gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
     923                 :            :                                  tmp, build_empty_stmt (input_location));
     924                 :         12 :           gfc_add_expr_to_block (&alloc_block, tmp);
     925                 :        309 :         }
     926                 :            :     }
     927                 :            :   else
     928                 :       8501 :     gfc_allocate_using_malloc (&alloc_block, mem, size, status);
     929                 :            : 
     930                 :       8810 :   alloc = gfc_finish_block (&alloc_block);
     931                 :            : 
     932                 :            :   /* If mem is not NULL, we issue a runtime error or set the
     933                 :            :      status variable.  */
     934                 :       8810 :   if (expr)
     935                 :            :     {
     936                 :       8810 :       tree varname;
     937                 :            : 
     938                 :       8810 :       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
     939                 :       8810 :       varname = gfc_build_cstring_const (expr->symtree->name);
     940                 :       8810 :       varname = gfc_build_addr_expr (pchar_type_node, varname);
     941                 :            : 
     942                 :       8810 :       error = gfc_trans_runtime_error (true, &expr->where,
     943                 :            :                                        "Attempting to allocate already"
     944                 :            :                                        " allocated variable '%s'",
     945                 :            :                                        varname);
     946                 :            :     }
     947                 :            :   else
     948                 :          0 :     error = gfc_trans_runtime_error (true, NULL,
     949                 :            :                                      "Attempting to allocate already allocated"
     950                 :            :                                      " variable");
     951                 :            : 
     952                 :       8810 :   if (status != NULL_TREE)
     953                 :            :     {
     954                 :        234 :       tree status_type = TREE_TYPE (status);
     955                 :            : 
     956                 :        234 :       error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
     957                 :        234 :               status, build_int_cst (status_type, LIBERROR_ALLOCATION));
     958                 :            :     }
     959                 :            : 
     960                 :       8810 :   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
     961                 :            :                          error, alloc);
     962                 :       8810 :   gfc_add_expr_to_block (block, tmp);
     963                 :       8810 : }
     964                 :            : 
     965                 :            : 
     966                 :            : /* Free a given variable.  */
     967                 :            : 
     968                 :            : tree
     969                 :      15633 : gfc_call_free (tree var)
     970                 :            : {
     971                 :      15633 :   return build_call_expr_loc (input_location,
     972                 :            :                               builtin_decl_explicit (BUILT_IN_FREE),
     973                 :      15633 :                               1, fold_convert (pvoid_type_node, var));
     974                 :            : }
     975                 :            : 
     976                 :            : 
     977                 :            : /* Build a call to a FINAL procedure, which finalizes "var".  */
     978                 :            : 
     979                 :            : static tree
     980                 :       2101 : gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
     981                 :            :                       bool fini_coarray, gfc_expr *class_size)
     982                 :            : {
     983                 :       2101 :   stmtblock_t block;
     984                 :       2101 :   gfc_se se;
     985                 :       2101 :   tree final_fndecl, array, size, tmp;
     986                 :       2101 :   symbol_attribute attr;
     987                 :            : 
     988                 :       2101 :   gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
     989                 :       2101 :   gcc_assert (var);
     990                 :            : 
     991                 :       2101 :   gfc_start_block (&block);
     992                 :       2101 :   gfc_init_se (&se, NULL);
     993                 :       2101 :   gfc_conv_expr (&se, final_wrapper);
     994                 :       2101 :   final_fndecl = se.expr;
     995                 :       2101 :   if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
     996                 :        114 :     final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
     997                 :            : 
     998                 :       2101 :   if (ts.type == BT_DERIVED)
     999                 :            :     {
    1000                 :        114 :       tree elem_size;
    1001                 :            : 
    1002                 :        114 :       gcc_assert (!class_size);
    1003                 :        114 :       elem_size = gfc_typenode_for_spec (&ts);
    1004                 :        114 :       elem_size = TYPE_SIZE_UNIT (elem_size);
    1005                 :        114 :       size = fold_convert (gfc_array_index_type, elem_size);
    1006                 :            : 
    1007                 :        114 :       gfc_init_se (&se, NULL);
    1008                 :        114 :       se.want_pointer = 1;
    1009                 :        114 :       if (var->rank)
    1010                 :            :         {
    1011                 :         51 :           se.descriptor_only = 1;
    1012                 :         51 :           gfc_conv_expr_descriptor (&se, var);
    1013                 :         51 :           array = se.expr;
    1014                 :            :         }
    1015                 :            :       else
    1016                 :            :         {
    1017                 :         63 :           gfc_conv_expr (&se, var);
    1018                 :         63 :           gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
    1019                 :         63 :           array = se.expr;
    1020                 :            : 
    1021                 :            :           /* No copy back needed, hence set attr's allocatable/pointer
    1022                 :            :              to zero.  */
    1023                 :         63 :           gfc_clear_attr (&attr);
    1024                 :         63 :           gfc_init_se (&se, NULL);
    1025                 :         63 :           array = gfc_conv_scalar_to_descriptor (&se, array, attr);
    1026                 :         63 :           gcc_assert (se.post.head == NULL_TREE);
    1027                 :            :         }
    1028                 :            :     }
    1029                 :            :   else
    1030                 :            :     {
    1031                 :       1987 :       gfc_expr *array_expr;
    1032                 :       1987 :       gcc_assert (class_size);
    1033                 :       1987 :       gfc_init_se (&se, NULL);
    1034                 :       1987 :       gfc_conv_expr (&se, class_size);
    1035                 :       1987 :       gfc_add_block_to_block (&block, &se.pre);
    1036                 :       1987 :       gcc_assert (se.post.head == NULL_TREE);
    1037                 :       1987 :       size = se.expr;
    1038                 :            : 
    1039                 :       1987 :       array_expr = gfc_copy_expr (var);
    1040                 :       1987 :       gfc_init_se (&se, NULL);
    1041                 :       1987 :       se.want_pointer = 1;
    1042                 :       1987 :       if (array_expr->rank)
    1043                 :            :         {
    1044                 :        835 :           gfc_add_class_array_ref (array_expr);
    1045                 :        835 :           se.descriptor_only = 1;
    1046                 :        835 :           gfc_conv_expr_descriptor (&se, array_expr);
    1047                 :        835 :           array = se.expr;
    1048                 :            :         }
    1049                 :            :       else
    1050                 :            :         {
    1051                 :       1152 :           gfc_add_data_component (array_expr);
    1052                 :       1152 :           gfc_conv_expr (&se, array_expr);
    1053                 :       1152 :           gfc_add_block_to_block (&block, &se.pre);
    1054                 :       1152 :           gcc_assert (se.post.head == NULL_TREE);
    1055                 :       1152 :           array = se.expr;
    1056                 :            : 
    1057                 :       1152 :           if (!gfc_is_coarray (array_expr))
    1058                 :            :             {
    1059                 :            :               /* No copy back needed, hence set attr's allocatable/pointer
    1060                 :            :                  to zero.  */
    1061                 :       1113 :               gfc_clear_attr (&attr);
    1062                 :       1113 :               gfc_init_se (&se, NULL);
    1063                 :       1113 :               array = gfc_conv_scalar_to_descriptor (&se, array, attr);
    1064                 :            :             }
    1065                 :       1152 :           gcc_assert (se.post.head == NULL_TREE);
    1066                 :            :         }
    1067                 :       1987 :       gfc_free_expr (array_expr);
    1068                 :            :     }
    1069                 :            : 
    1070                 :       2101 :   if (!POINTER_TYPE_P (TREE_TYPE (array)))
    1071                 :       1176 :     array = gfc_build_addr_expr (NULL, array);
    1072                 :            : 
    1073                 :       2101 :   gfc_add_block_to_block (&block, &se.pre);
    1074                 :       2101 :   tmp = build_call_expr_loc (input_location,
    1075                 :            :                              final_fndecl, 3, array,
    1076                 :            :                              size, fini_coarray ? boolean_true_node
    1077                 :            :                                                 : boolean_false_node);
    1078                 :       2101 :   gfc_add_block_to_block (&block, &se.post);
    1079                 :       2101 :   gfc_add_expr_to_block (&block, tmp);
    1080                 :       2101 :   return gfc_finish_block (&block);
    1081                 :            : }
    1082                 :            : 
    1083                 :            : 
    1084                 :            : bool
    1085                 :       1906 : gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
    1086                 :            :                              bool fini_coarray)
    1087                 :            : {
    1088                 :       1906 :   gfc_se se;
    1089                 :       1906 :   stmtblock_t block2;
    1090                 :       1906 :   tree final_fndecl, size, array, tmp, cond;
    1091                 :       1906 :   symbol_attribute attr;
    1092                 :       1906 :   gfc_expr *final_expr = NULL;
    1093                 :            : 
    1094                 :       1906 :   if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
    1095                 :            :     return false;
    1096                 :            : 
    1097                 :       1906 :   gfc_init_block (&block2);
    1098                 :            : 
    1099                 :       1906 :   if (comp->ts.type == BT_DERIVED)
    1100                 :            :     {
    1101                 :       1555 :       if (comp->attr.pointer)
    1102                 :            :         return false;
    1103                 :            : 
    1104                 :       1555 :       gfc_is_finalizable (comp->ts.u.derived, &final_expr);
    1105                 :       1555 :       if (!final_expr)
    1106                 :            :         return false;
    1107                 :            : 
    1108                 :         15 :       gfc_init_se (&se, NULL);
    1109                 :         15 :       gfc_conv_expr (&se, final_expr);
    1110                 :         15 :       final_fndecl = se.expr;
    1111                 :         15 :       size = gfc_typenode_for_spec (&comp->ts);
    1112                 :         15 :       size = TYPE_SIZE_UNIT (size);
    1113                 :         15 :       size = fold_convert (gfc_array_index_type, size);
    1114                 :            : 
    1115                 :         15 :       array = decl;
    1116                 :            :     }
    1117                 :            :   else /* comp->ts.type == BT_CLASS.  */
    1118                 :            :     {
    1119                 :        351 :       if (CLASS_DATA (comp)->attr.class_pointer)
    1120                 :            :         return false;
    1121                 :            : 
    1122                 :        351 :       gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
    1123                 :        351 :       final_fndecl = gfc_class_vtab_final_get (decl);
    1124                 :        351 :       size = gfc_class_vtab_size_get (decl);
    1125                 :        351 :       array = gfc_class_data_get (decl);
    1126                 :            :     }
    1127                 :            : 
    1128                 :        366 :   if (comp->attr.allocatable
    1129                 :        366 :       || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
    1130                 :            :     {
    1131                 :        353 :       tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
    1132                 :        353 :             ?  gfc_conv_descriptor_data_get (array) : array;
    1133                 :        706 :       cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1134                 :        353 :                             tmp, fold_convert (TREE_TYPE (tmp),
    1135                 :            :                                                  null_pointer_node));
    1136                 :            :     }
    1137                 :            :   else
    1138                 :         13 :     cond = logical_true_node;
    1139                 :            : 
    1140                 :        366 :   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
    1141                 :            :     {
    1142                 :        197 :       gfc_clear_attr (&attr);
    1143                 :        197 :       gfc_init_se (&se, NULL);
    1144                 :        197 :       array = gfc_conv_scalar_to_descriptor (&se, array, attr);
    1145                 :        197 :       gfc_add_block_to_block (&block2, &se.pre);
    1146                 :        197 :       gcc_assert (se.post.head == NULL_TREE);
    1147                 :            :     }
    1148                 :            : 
    1149                 :        366 :   if (!POINTER_TYPE_P (TREE_TYPE (array)))
    1150                 :        366 :     array = gfc_build_addr_expr (NULL, array);
    1151                 :            : 
    1152                 :        366 :   if (!final_expr)
    1153                 :            :     {
    1154                 :        698 :       tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1155                 :            :                              final_fndecl,
    1156                 :        349 :                              fold_convert (TREE_TYPE (final_fndecl),
    1157                 :            :                                            null_pointer_node));
    1158                 :        349 :       cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    1159                 :            :                               logical_type_node, cond, tmp);
    1160                 :            :     }
    1161                 :            : 
    1162                 :        366 :   if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
    1163                 :        366 :     final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
    1164                 :            : 
    1165                 :        366 :   tmp = build_call_expr_loc (input_location,
    1166                 :            :                              final_fndecl, 3, array,
    1167                 :            :                              size, fini_coarray ? boolean_true_node
    1168                 :            :                                                 : boolean_false_node);
    1169                 :        366 :   gfc_add_expr_to_block (&block2, tmp);
    1170                 :        366 :   tmp = gfc_finish_block (&block2);
    1171                 :            : 
    1172                 :        366 :   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
    1173                 :            :                          build_empty_stmt (input_location));
    1174                 :        366 :   gfc_add_expr_to_block (block, tmp);
    1175                 :            : 
    1176                 :        366 :   return true;
    1177                 :            : }
    1178                 :            : 
    1179                 :            : 
    1180                 :            : /* Add a call to the finalizer, using the passed *expr. Returns
    1181                 :            :    true when a finalizer call has been inserted.  */
    1182                 :            : 
    1183                 :            : bool
    1184                 :      15095 : gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
    1185                 :            : {
    1186                 :      15095 :   tree tmp;
    1187                 :      15095 :   gfc_ref *ref;
    1188                 :      15095 :   gfc_expr *expr;
    1189                 :      15095 :   gfc_expr *final_expr = NULL;
    1190                 :      15095 :   gfc_expr *elem_size = NULL;
    1191                 :      15095 :   bool has_finalizer = false;
    1192                 :            : 
    1193                 :      15095 :   if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
    1194                 :            :     return false;
    1195                 :            : 
    1196                 :       3253 :   if (expr2->ts.type == BT_DERIVED)
    1197                 :            :     {
    1198                 :       1266 :       gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
    1199                 :       1266 :       if (!final_expr)
    1200                 :            :         return false;
    1201                 :            :     }
    1202                 :            : 
    1203                 :            :   /* If we have a class array, we need go back to the class
    1204                 :            :      container.  */
    1205                 :       2101 :   expr = gfc_copy_expr (expr2);
    1206                 :            : 
    1207                 :       2101 :   if (expr->ref && expr->ref->next && !expr->ref->next->next
    1208                 :        562 :       && expr->ref->next->type == REF_ARRAY
    1209                 :        538 :       && expr->ref->type == REF_COMPONENT
    1210                 :        538 :       && strcmp (expr->ref->u.c.component->name, "_data") == 0)
    1211                 :            :     {
    1212                 :        537 :       gfc_free_ref_list (expr->ref);
    1213                 :        537 :       expr->ref = NULL;
    1214                 :            :     }
    1215                 :            :   else
    1216                 :       2218 :     for (ref = expr->ref; ref; ref = ref->next)
    1217                 :        654 :       if (ref->next && ref->next->next && !ref->next->next->next
    1218                 :        167 :          && ref->next->next->type == REF_ARRAY
    1219                 :        154 :          && ref->next->type == REF_COMPONENT
    1220                 :        154 :          && strcmp (ref->next->u.c.component->name, "_data") == 0)
    1221                 :            :        {
    1222                 :        154 :          gfc_free_ref_list (ref->next);
    1223                 :        154 :          ref->next = NULL;
    1224                 :            :        }
    1225                 :            : 
    1226                 :       2101 :   if (expr->ts.type == BT_CLASS)
    1227                 :            :     {
    1228                 :       1987 :       has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
    1229                 :            : 
    1230                 :       1987 :       if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
    1231                 :          3 :         expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
    1232                 :            : 
    1233                 :       1987 :       final_expr = gfc_copy_expr (expr);
    1234                 :       1987 :       gfc_add_vptr_component (final_expr);
    1235                 :       1987 :       gfc_add_final_component (final_expr);
    1236                 :            : 
    1237                 :       1987 :       elem_size = gfc_copy_expr (expr);
    1238                 :       1987 :       gfc_add_vptr_component (elem_size);
    1239                 :       1987 :       gfc_add_size_component (elem_size);
    1240                 :            :     }
    1241                 :            : 
    1242                 :       2101 :   gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
    1243                 :            : 
    1244                 :       2101 :   tmp = gfc_build_final_call (expr->ts, final_expr, expr,
    1245                 :            :                               false, elem_size);
    1246                 :            : 
    1247                 :       2101 :   if (expr->ts.type == BT_CLASS && !has_finalizer)
    1248                 :            :     {
    1249                 :       1987 :       tree cond;
    1250                 :       1987 :       gfc_se se;
    1251                 :            : 
    1252                 :       1987 :       gfc_init_se (&se, NULL);
    1253                 :       1987 :       se.want_pointer = 1;
    1254                 :       1987 :       gfc_conv_expr (&se, final_expr);
    1255                 :       1987 :       cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1256                 :       1987 :                               se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
    1257                 :            : 
    1258                 :            :       /* For CLASS(*) not only sym->_vtab->_final can be NULL
    1259                 :            :          but already sym->_vtab itself.  */
    1260                 :       1987 :       if (UNLIMITED_POLY (expr))
    1261                 :            :         {
    1262                 :        421 :           tree cond2;
    1263                 :        421 :           gfc_expr *vptr_expr;
    1264                 :            : 
    1265                 :        421 :           vptr_expr = gfc_copy_expr (expr);
    1266                 :        421 :           gfc_add_vptr_component (vptr_expr);
    1267                 :            : 
    1268                 :        421 :           gfc_init_se (&se, NULL);
    1269                 :        421 :           se.want_pointer = 1;
    1270                 :        421 :           gfc_conv_expr (&se, vptr_expr);
    1271                 :        421 :           gfc_free_expr (vptr_expr);
    1272                 :            : 
    1273                 :        421 :           cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1274                 :            :                                    se.expr,
    1275                 :        421 :                                    build_int_cst (TREE_TYPE (se.expr), 0));
    1276                 :        421 :           cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
    1277                 :            :                                   logical_type_node, cond2, cond);
    1278                 :            :         }
    1279                 :            : 
    1280                 :       1987 :       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1281                 :            :                              cond, tmp, build_empty_stmt (input_location));
    1282                 :            :     }
    1283                 :            : 
    1284                 :       2101 :   gfc_add_expr_to_block (block, tmp);
    1285                 :            : 
    1286                 :       2101 :   return true;
    1287                 :            : }
    1288                 :            : 
    1289                 :            : 
    1290                 :            : /* User-deallocate; we emit the code directly from the front-end, and the
    1291                 :            :    logic is the same as the previous library function:
    1292                 :            : 
    1293                 :            :     void
    1294                 :            :     deallocate (void *pointer, GFC_INTEGER_4 * stat)
    1295                 :            :     {
    1296                 :            :       if (!pointer)
    1297                 :            :         {
    1298                 :            :           if (stat)
    1299                 :            :             *stat = 1;
    1300                 :            :           else
    1301                 :            :             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
    1302                 :            :         }
    1303                 :            :       else
    1304                 :            :         {
    1305                 :            :           free (pointer);
    1306                 :            :           if (stat)
    1307                 :            :             *stat = 0;
    1308                 :            :         }
    1309                 :            :     }
    1310                 :            : 
    1311                 :            :    In this front-end version, status doesn't have to be GFC_INTEGER_4.
    1312                 :            :    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
    1313                 :            :    even when no status variable is passed to us (this is used for
    1314                 :            :    unconditional deallocation generated by the front-end at end of
    1315                 :            :    each procedure).
    1316                 :            : 
    1317                 :            :    If a runtime-message is possible, `expr' must point to the original
    1318                 :            :    expression being deallocated for its locus and variable name.
    1319                 :            : 
    1320                 :            :    For coarrays, "pointer" must be the array descriptor and not its
    1321                 :            :    "data" component.
    1322                 :            : 
    1323                 :            :    COARRAY_DEALLOC_MODE gives the mode unregister coarrays.  Available modes are
    1324                 :            :    the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be
    1325                 :            :    analyzed and set by this routine, and -2 to indicate that a non-coarray is to
    1326                 :            :    be deallocated.  */
    1327                 :            : tree
    1328                 :      11550 : gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
    1329                 :            :                             tree errlen, tree label_finish,
    1330                 :            :                             bool can_fail, gfc_expr* expr,
    1331                 :            :                             int coarray_dealloc_mode, tree add_when_allocated,
    1332                 :            :                             tree caf_token)
    1333                 :            : {
    1334                 :      11550 :   stmtblock_t null, non_null;
    1335                 :      11550 :   tree cond, tmp, error;
    1336                 :      11550 :   tree status_type = NULL_TREE;
    1337                 :      11550 :   tree token = NULL_TREE;
    1338                 :      11550 :   gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
    1339                 :            : 
    1340                 :      11550 :   if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
    1341                 :            :     {
    1342                 :        354 :       if (flag_coarray == GFC_FCOARRAY_LIB)
    1343                 :            :         {
    1344                 :        210 :           if (caf_token)
    1345                 :            :             token = caf_token;
    1346                 :            :           else
    1347                 :            :             {
    1348                 :        148 :               tree caf_type, caf_decl = pointer;
    1349                 :        148 :               pointer = gfc_conv_descriptor_data_get (caf_decl);
    1350                 :        148 :               caf_type = TREE_TYPE (caf_decl);
    1351                 :        148 :               STRIP_NOPS (pointer);
    1352                 :        148 :               if (GFC_DESCRIPTOR_TYPE_P (caf_type))
    1353                 :        148 :                 token = gfc_conv_descriptor_token (caf_decl);
    1354                 :          0 :               else if (DECL_LANG_SPECIFIC (caf_decl)
    1355                 :          0 :                        && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
    1356                 :        210 :                 token = GFC_DECL_TOKEN (caf_decl);
    1357                 :            :               else
    1358                 :            :                 {
    1359                 :          0 :                   gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
    1360                 :            :                               && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
    1361                 :            :                                  != NULL_TREE);
    1362                 :        210 :                   token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
    1363                 :            :                 }
    1364                 :            :             }
    1365                 :            : 
    1366                 :        210 :           if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
    1367                 :            :             {
    1368                 :          4 :               bool comp_ref;
    1369                 :          4 :               if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
    1370                 :          4 :                   && comp_ref)
    1371                 :            :                 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
    1372                 :            :               // else do a deregister as set by default.
    1373                 :            :             }
    1374                 :            :           else
    1375                 :            :             caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
    1376                 :            :         }
    1377                 :        144 :       else if (flag_coarray == GFC_FCOARRAY_SINGLE)
    1378                 :        144 :         pointer = gfc_conv_descriptor_data_get (pointer);
    1379                 :            :     }
    1380                 :      11196 :   else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
    1381                 :       5492 :     pointer = gfc_conv_descriptor_data_get (pointer);
    1382                 :            : 
    1383                 :      11550 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
    1384                 :      11550 :                           build_int_cst (TREE_TYPE (pointer), 0));
    1385                 :            : 
    1386                 :            :   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
    1387                 :            :      we emit a runtime error.  */
    1388                 :      11550 :   gfc_start_block (&null);
    1389                 :      11550 :   if (!can_fail)
    1390                 :            :     {
    1391                 :       4547 :       tree varname;
    1392                 :            : 
    1393                 :       4547 :       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
    1394                 :            : 
    1395                 :       4547 :       varname = gfc_build_cstring_const (expr->symtree->name);
    1396                 :       4547 :       varname = gfc_build_addr_expr (pchar_type_node, varname);
    1397                 :            : 
    1398                 :       4547 :       error = gfc_trans_runtime_error (true, &expr->where,
    1399                 :            :                                        "Attempt to DEALLOCATE unallocated '%s'",
    1400                 :            :                                        varname);
    1401                 :            :     }
    1402                 :            :   else
    1403                 :       7003 :     error = build_empty_stmt (input_location);
    1404                 :            : 
    1405                 :      11550 :   if (status != NULL_TREE && !integer_zerop (status))
    1406                 :            :     {
    1407                 :       1114 :       tree cond2;
    1408                 :            : 
    1409                 :       1114 :       status_type = TREE_TYPE (TREE_TYPE (status));
    1410                 :       1114 :       cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1411                 :       1114 :                                status, build_int_cst (TREE_TYPE (status), 0));
    1412                 :       1114 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
    1413                 :            :                              fold_build1_loc (input_location, INDIRECT_REF,
    1414                 :            :                                               status_type, status),
    1415                 :       1114 :                              build_int_cst (status_type, 1));
    1416                 :       1114 :       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1417                 :            :                                cond2, tmp, error);
    1418                 :            :     }
    1419                 :            : 
    1420                 :      11550 :   gfc_add_expr_to_block (&null, error);
    1421                 :            : 
    1422                 :            :   /* When POINTER is not NULL, we free it.  */
    1423                 :      11550 :   gfc_start_block (&non_null);
    1424                 :      11550 :   if (add_when_allocated)
    1425                 :        473 :     gfc_add_expr_to_block (&non_null, add_when_allocated);
    1426                 :      11550 :   gfc_add_finalizer_call (&non_null, expr);
    1427                 :      11550 :   if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
    1428                 :        354 :       || flag_coarray != GFC_FCOARRAY_LIB)
    1429                 :            :     {
    1430                 :      11340 :       tmp = build_call_expr_loc (input_location,
    1431                 :            :                                  builtin_decl_explicit (BUILT_IN_FREE), 1,
    1432                 :            :                                  fold_convert (pvoid_type_node, pointer));
    1433                 :      11340 :       gfc_add_expr_to_block (&non_null, tmp);
    1434                 :      11340 :       gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
    1435                 :      11340 :                                                          0));
    1436                 :            : 
    1437                 :      11340 :       if (status != NULL_TREE && !integer_zerop (status))
    1438                 :            :         {
    1439                 :            :           /* We set STATUS to zero if it is present.  */
    1440                 :       1104 :           tree status_type = TREE_TYPE (TREE_TYPE (status));
    1441                 :       1104 :           tree cond2;
    1442                 :            : 
    1443                 :       1104 :           cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1444                 :            :                                    status,
    1445                 :       1104 :                                    build_int_cst (TREE_TYPE (status), 0));
    1446                 :       1104 :           tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
    1447                 :            :                                  fold_build1_loc (input_location, INDIRECT_REF,
    1448                 :            :                                                   status_type, status),
    1449                 :       1104 :                                  build_int_cst (status_type, 0));
    1450                 :       1104 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1451                 :            :                                  gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
    1452                 :            :                                  tmp, build_empty_stmt (input_location));
    1453                 :       1104 :           gfc_add_expr_to_block (&non_null, tmp);
    1454                 :            :         }
    1455                 :            :     }
    1456                 :            :   else
    1457                 :            :     {
    1458                 :        210 :       tree cond2, pstat = null_pointer_node;
    1459                 :            : 
    1460                 :        210 :       if (errmsg == NULL_TREE)
    1461                 :            :         {
    1462                 :        204 :           gcc_assert (errlen == NULL_TREE);
    1463                 :        204 :           errmsg = null_pointer_node;
    1464                 :        204 :           errlen = build_zero_cst (integer_type_node);
    1465                 :            :         }
    1466                 :            :       else
    1467                 :            :         {
    1468                 :          6 :           gcc_assert (errlen != NULL_TREE);
    1469                 :          6 :           if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
    1470                 :          0 :             errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
    1471                 :            :         }
    1472                 :            : 
    1473                 :        210 :       if (status != NULL_TREE && !integer_zerop (status))
    1474                 :            :         {
    1475                 :         10 :           gcc_assert (status_type == integer_type_node);
    1476                 :            :           pstat = status;
    1477                 :            :         }
    1478                 :            : 
    1479                 :        210 :       token = gfc_build_addr_expr  (NULL_TREE, token);
    1480                 :        210 :       gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
    1481                 :        210 :       tmp = build_call_expr_loc (input_location,
    1482                 :            :                                  gfor_fndecl_caf_deregister, 5,
    1483                 :            :                                  token, build_int_cst (integer_type_node,
    1484                 :            :                                                        caf_dereg_type),
    1485                 :            :                                  pstat, errmsg, errlen);
    1486                 :        210 :       gfc_add_expr_to_block (&non_null, tmp);
    1487                 :            : 
    1488                 :            :       /* It guarantees memory consistency within the same segment */
    1489                 :        210 :       tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
    1490                 :        210 :       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    1491                 :            :                         gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
    1492                 :            :                         tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
    1493                 :        210 :       ASM_VOLATILE_P (tmp) = 1;
    1494                 :        210 :       gfc_add_expr_to_block (&non_null, tmp);
    1495                 :            : 
    1496                 :        210 :       if (status != NULL_TREE)
    1497                 :            :         {
    1498                 :         10 :           tree stat = build_fold_indirect_ref_loc (input_location, status);
    1499                 :         10 :           tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
    1500                 :            :                                           void_type_node, pointer,
    1501                 :         10 :                                           build_int_cst (TREE_TYPE (pointer),
    1502                 :         10 :                                                          0));
    1503                 :            : 
    1504                 :         10 :           TREE_USED (label_finish) = 1;
    1505                 :         10 :           tmp = build1_v (GOTO_EXPR, label_finish);
    1506                 :         20 :           cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1507                 :         10 :                                    stat, build_zero_cst (TREE_TYPE (stat)));
    1508                 :         10 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1509                 :            :                                  gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
    1510                 :            :                                  tmp, nullify);
    1511                 :         10 :           gfc_add_expr_to_block (&non_null, tmp);
    1512                 :            :         }
    1513                 :            :       else
    1514                 :        200 :         gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
    1515                 :        200 :                                                            0));
    1516                 :            :     }
    1517                 :            : 
    1518                 :      11550 :   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    1519                 :            :                           gfc_finish_block (&null),
    1520                 :      11550 :                           gfc_finish_block (&non_null));
    1521                 :            : }
    1522                 :            : 
    1523                 :            : 
    1524                 :            : /* Generate code for deallocation of allocatable scalars (variables or
    1525                 :            :    components). Before the object itself is freed, any allocatable
    1526                 :            :    subcomponents are being deallocated.  */
    1527                 :            : 
    1528                 :            : tree
    1529                 :       3235 : gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
    1530                 :            :                                    bool can_fail, gfc_expr* expr,
    1531                 :            :                                    gfc_typespec ts, bool coarray)
    1532                 :            : {
    1533                 :       3235 :   stmtblock_t null, non_null;
    1534                 :       3235 :   tree cond, tmp, error;
    1535                 :       3235 :   bool finalizable, comp_ref;
    1536                 :       3235 :   gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
    1537                 :            : 
    1538                 :       3283 :   if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
    1539                 :       3283 :       && comp_ref)
    1540                 :            :     caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
    1541                 :            : 
    1542                 :       3235 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer,
    1543                 :       3235 :                           build_int_cst (TREE_TYPE (pointer), 0));
    1544                 :            : 
    1545                 :            :   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
    1546                 :            :      we emit a runtime error.  */
    1547                 :       3235 :   gfc_start_block (&null);
    1548                 :       3235 :   if (!can_fail)
    1549                 :            :     {
    1550                 :       2039 :       tree varname;
    1551                 :            : 
    1552                 :       2039 :       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
    1553                 :            : 
    1554                 :       2039 :       varname = gfc_build_cstring_const (expr->symtree->name);
    1555                 :       2039 :       varname = gfc_build_addr_expr (pchar_type_node, varname);
    1556                 :            : 
    1557                 :       2039 :       error = gfc_trans_runtime_error (true, &expr->where,
    1558                 :            :                                        "Attempt to DEALLOCATE unallocated '%s'",
    1559                 :            :                                        varname);
    1560                 :            :     }
    1561                 :            :   else
    1562                 :       1196 :     error = build_empty_stmt (input_location);
    1563                 :            : 
    1564                 :       3235 :   if (status != NULL_TREE && !integer_zerop (status))
    1565                 :            :     {
    1566                 :        473 :       tree status_type = TREE_TYPE (TREE_TYPE (status));
    1567                 :        473 :       tree cond2;
    1568                 :            : 
    1569                 :        473 :       cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1570                 :        473 :                                status, build_int_cst (TREE_TYPE (status), 0));
    1571                 :        473 :       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
    1572                 :            :                              fold_build1_loc (input_location, INDIRECT_REF,
    1573                 :            :                                               status_type, status),
    1574                 :        473 :                              build_int_cst (status_type, 1));
    1575                 :        473 :       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1576                 :            :                                cond2, tmp, error);
    1577                 :            :     }
    1578                 :       3235 :   gfc_add_expr_to_block (&null, error);
    1579                 :            : 
    1580                 :            :   /* When POINTER is not NULL, we free it.  */
    1581                 :       3235 :   gfc_start_block (&non_null);
    1582                 :            : 
    1583                 :            :   /* Free allocatable components.  */
    1584                 :       3235 :   finalizable = gfc_add_finalizer_call (&non_null, expr);
    1585                 :       3235 :   if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
    1586                 :            :     {
    1587                 :        632 :       int caf_mode = coarray
    1588                 :        316 :           ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
    1589                 :            :               ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
    1590                 :            :              | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
    1591                 :          7 :              | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
    1592                 :            :           : 0;
    1593                 :        323 :       if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
    1594                 :          0 :         tmp = gfc_conv_descriptor_data_get (pointer);
    1595                 :            :       else
    1596                 :        316 :         tmp = build_fold_indirect_ref_loc (input_location, pointer);
    1597                 :        316 :       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
    1598                 :        316 :       gfc_add_expr_to_block (&non_null, tmp);
    1599                 :            :     }
    1600                 :            : 
    1601                 :       3235 :   if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
    1602                 :            :     {
    1603                 :       3188 :       tmp = build_call_expr_loc (input_location,
    1604                 :            :                                  builtin_decl_explicit (BUILT_IN_FREE), 1,
    1605                 :            :                                  fold_convert (pvoid_type_node, pointer));
    1606                 :       3188 :       gfc_add_expr_to_block (&non_null, tmp);
    1607                 :            : 
    1608                 :       3188 :       if (status != NULL_TREE && !integer_zerop (status))
    1609                 :            :         {
    1610                 :            :           /* We set STATUS to zero if it is present.  */
    1611                 :        473 :           tree status_type = TREE_TYPE (TREE_TYPE (status));
    1612                 :        473 :           tree cond2;
    1613                 :            : 
    1614                 :        473 :           cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1615                 :            :                                    status,
    1616                 :        473 :                                    build_int_cst (TREE_TYPE (status), 0));
    1617                 :        473 :           tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
    1618                 :            :                                  fold_build1_loc (input_location, INDIRECT_REF,
    1619                 :            :                                                   status_type, status),
    1620                 :        473 :                                  build_int_cst (status_type, 0));
    1621                 :        473 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1622                 :            :                                  cond2, tmp, build_empty_stmt (input_location));
    1623                 :        473 :           gfc_add_expr_to_block (&non_null, tmp);
    1624                 :            :         }
    1625                 :            :     }
    1626                 :            :   else
    1627                 :            :     {
    1628                 :         47 :       tree token;
    1629                 :         47 :       tree pstat = null_pointer_node;
    1630                 :         47 :       gfc_se se;
    1631                 :            : 
    1632                 :         47 :       gfc_init_se (&se, NULL);
    1633                 :         47 :       token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr);
    1634                 :         47 :       gcc_assert (token != NULL_TREE);
    1635                 :            : 
    1636                 :         47 :       if (status != NULL_TREE && !integer_zerop (status))
    1637                 :            :         {
    1638                 :          0 :           gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node);
    1639                 :            :           pstat = status;
    1640                 :            :         }
    1641                 :            : 
    1642                 :         47 :       tmp = build_call_expr_loc (input_location,
    1643                 :            :                                  gfor_fndecl_caf_deregister, 5,
    1644                 :            :                                  token, build_int_cst (integer_type_node,
    1645                 :            :                                                        caf_dereg_type),
    1646                 :            :                                  pstat, null_pointer_node, integer_zero_node);
    1647                 :         47 :       gfc_add_expr_to_block (&non_null, tmp);
    1648                 :            : 
    1649                 :            :       /* It guarantees memory consistency within the same segment.  */
    1650                 :         47 :       tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
    1651                 :         47 :       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    1652                 :            :                         gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
    1653                 :            :                         tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
    1654                 :         47 :       ASM_VOLATILE_P (tmp) = 1;
    1655                 :         47 :       gfc_add_expr_to_block (&non_null, tmp);
    1656                 :            : 
    1657                 :         47 :       if (status != NULL_TREE)
    1658                 :            :         {
    1659                 :          0 :           tree stat = build_fold_indirect_ref_loc (input_location, status);
    1660                 :          0 :           tree cond2;
    1661                 :            : 
    1662                 :          0 :           TREE_USED (label_finish) = 1;
    1663                 :          0 :           tmp = build1_v (GOTO_EXPR, label_finish);
    1664                 :          0 :           cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    1665                 :          0 :                                    stat, build_zero_cst (TREE_TYPE (stat)));
    1666                 :          0 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1667                 :            :                                  gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
    1668                 :            :                                  tmp, build_empty_stmt (input_location));
    1669                 :          0 :           gfc_add_expr_to_block (&non_null, tmp);
    1670                 :            :         }
    1671                 :            :     }
    1672                 :            : 
    1673                 :       3235 :   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
    1674                 :            :                           gfc_finish_block (&null),
    1675                 :       3235 :                           gfc_finish_block (&non_null));
    1676                 :            : }
    1677                 :            : 
    1678                 :            : /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
    1679                 :            :    following pseudo-code:
    1680                 :            : 
    1681                 :            : void *
    1682                 :            : internal_realloc (void *mem, size_t size)
    1683                 :            : {
    1684                 :            :   res = realloc (mem, size);
    1685                 :            :   if (!res && size != 0)
    1686                 :            :     _gfortran_os_error ("Allocation would exceed memory limit");
    1687                 :            : 
    1688                 :            :   return res;
    1689                 :            : }  */
    1690                 :            : tree
    1691                 :        823 : gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
    1692                 :            : {
    1693                 :        823 :   tree res, nonzero, null_result, tmp;
    1694                 :        823 :   tree type = TREE_TYPE (mem);
    1695                 :            : 
    1696                 :            :   /* Only evaluate the size once.  */
    1697                 :        823 :   size = save_expr (fold_convert (size_type_node, size));
    1698                 :            : 
    1699                 :            :   /* Create a variable to hold the result.  */
    1700                 :        823 :   res = gfc_create_var (type, NULL);
    1701                 :            : 
    1702                 :            :   /* Call realloc and check the result.  */
    1703                 :        823 :   tmp = build_call_expr_loc (input_location,
    1704                 :            :                          builtin_decl_explicit (BUILT_IN_REALLOC), 2,
    1705                 :            :                          fold_convert (pvoid_type_node, mem), size);
    1706                 :        823 :   gfc_add_modify (block, res, fold_convert (type, tmp));
    1707                 :        823 :   null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    1708                 :        823 :                                  res, build_int_cst (pvoid_type_node, 0));
    1709                 :        823 :   nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size,
    1710                 :        823 :                              build_int_cst (size_type_node, 0));
    1711                 :        823 :   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
    1712                 :            :                                  null_result, nonzero);
    1713                 :        823 :   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    1714                 :            :                          null_result,
    1715                 :            :                          trans_os_error_at (NULL,
    1716                 :            :                                             "Error reallocating to %lu bytes",
    1717                 :            :                                             fold_convert
    1718                 :            :                                             (long_unsigned_type_node, size)),
    1719                 :            :                          build_empty_stmt (input_location));
    1720                 :        823 :   gfc_add_expr_to_block (block, tmp);
    1721                 :            : 
    1722                 :        823 :   return res;
    1723                 :            : }
    1724                 :            : 
    1725                 :            : 
    1726                 :            : /* Add an expression to another one, either at the front or the back.  */
    1727                 :            : 
    1728                 :            : static void
    1729                 :   10122400 : add_expr_to_chain (tree* chain, tree expr, bool front)
    1730                 :            : {
    1731                 :   10466700 :   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
    1732                 :    4686120 :     return;
    1733                 :            : 
    1734                 :    5436300 :   if (*chain)
    1735                 :            :     {
    1736                 :    2875960 :       if (TREE_CODE (*chain) != STATEMENT_LIST)
    1737                 :            :         {
    1738                 :     868546 :           tree tmp;
    1739                 :            : 
    1740                 :     868546 :           tmp = *chain;
    1741                 :     868546 :           *chain = NULL_TREE;
    1742                 :     868546 :           append_to_statement_list (tmp, chain);
    1743                 :            :         }
    1744                 :            : 
    1745                 :    2875960 :       if (front)
    1746                 :            :         {
    1747                 :      11941 :           tree_stmt_iterator i;
    1748                 :            : 
    1749                 :      11941 :           i = tsi_start (*chain);
    1750                 :      11941 :           tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
    1751                 :            :         }
    1752                 :            :       else
    1753                 :    2864020 :         append_to_statement_list (expr, chain);
    1754                 :            :     }
    1755                 :            :   else
    1756                 :    2560340 :     *chain = expr;
    1757                 :            : }
    1758                 :            : 
    1759                 :            : 
    1760                 :            : /* Add a statement at the end of a block.  */
    1761                 :            : 
    1762                 :            : void
    1763                 :    9574580 : gfc_add_expr_to_block (stmtblock_t * block, tree expr)
    1764                 :            : {
    1765                 :    9574580 :   gcc_assert (block);
    1766                 :    9574580 :   add_expr_to_chain (&block->head, expr, false);
    1767                 :    9574580 : }
    1768                 :            : 
    1769                 :            : 
    1770                 :            : /* Add a statement at the beginning of a block.  */
    1771                 :            : 
    1772                 :            : void
    1773                 :       1357 : gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
    1774                 :            : {
    1775                 :       1357 :   gcc_assert (block);
    1776                 :       1357 :   add_expr_to_chain (&block->head, expr, true);
    1777                 :       1357 : }
    1778                 :            : 
    1779                 :            : 
    1780                 :            : /* Add a block the end of a block.  */
    1781                 :            : 
    1782                 :            : void
    1783                 :    4701060 : gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
    1784                 :            : {
    1785                 :    4701060 :   gcc_assert (append);
    1786                 :    4701060 :   gcc_assert (!append->has_scope);
    1787                 :            : 
    1788                 :    4701060 :   gfc_add_expr_to_block (block, append->head);
    1789                 :    4701060 :   append->head = NULL_TREE;
    1790                 :    4701060 : }
    1791                 :            : 
    1792                 :            : 
    1793                 :            : /* Save the current locus.  The structure may not be complete, and should
    1794                 :            :    only be used with gfc_restore_backend_locus.  */
    1795                 :            : 
    1796                 :            : void
    1797                 :     254511 : gfc_save_backend_locus (locus * loc)
    1798                 :            : {
    1799                 :     254511 :   loc->lb = XCNEW (gfc_linebuf);
    1800                 :     254511 :   loc->lb->location = input_location;
    1801                 :     254511 :   loc->lb->file = gfc_current_backend_file;
    1802                 :     254511 : }
    1803                 :            : 
    1804                 :            : 
    1805                 :            : /* Set the current locus.  */
    1806                 :            : 
    1807                 :            : void
    1808                 :    1957550 : gfc_set_backend_locus (locus * loc)
    1809                 :            : {
    1810                 :    1957550 :   gfc_current_backend_file = loc->lb->file;
    1811                 :    1957550 :   input_location = loc->lb->location;
    1812                 :    1957550 : }
    1813                 :            : 
    1814                 :            : 
    1815                 :            : /* Restore the saved locus. Only used in conjunction with
    1816                 :            :    gfc_save_backend_locus, to free the memory when we are done.  */
    1817                 :            : 
    1818                 :            : void
    1819                 :     253808 : gfc_restore_backend_locus (locus * loc)
    1820                 :            : {
    1821                 :     253808 :   gfc_set_backend_locus (loc);
    1822                 :     253808 :   free (loc->lb);
    1823                 :     253808 : }
    1824                 :            : 
    1825                 :            : 
    1826                 :            : /* Translate an executable statement. The tree cond is used by gfc_trans_do.
    1827                 :            :    This static function is wrapped by gfc_trans_code_cond and
    1828                 :            :    gfc_trans_code.  */
    1829                 :            : 
    1830                 :            : static tree
    1831                 :     275089 : trans_code (gfc_code * code, tree cond)
    1832                 :            : {
    1833                 :     275089 :   stmtblock_t block;
    1834                 :     275089 :   tree res;
    1835                 :            : 
    1836                 :     275089 :   if (!code)
    1837                 :       1151 :     return build_empty_stmt (input_location);
    1838                 :            : 
    1839                 :     273938 :   gfc_start_block (&block);
    1840                 :            : 
    1841                 :            :   /* Translate statements one by one into GENERIC trees until we reach
    1842                 :            :      the end of this gfc_code branch.  */
    1843                 :     964963 :   for (; code; code = code->next)
    1844                 :            :     {
    1845                 :     691025 :       if (code->here != 0)
    1846                 :            :         {
    1847                 :       3467 :           res = gfc_trans_label_here (code);
    1848                 :       3467 :           gfc_add_expr_to_block (&block, res);
    1849                 :            :         }
    1850                 :            : 
    1851                 :     691025 :       gfc_current_locus = code->loc;
    1852                 :     691025 :       gfc_set_backend_locus (&code->loc);
    1853                 :            : 
    1854                 :     691025 :       switch (code->op)
    1855                 :            :         {
    1856                 :            :         case EXEC_NOP:
    1857                 :            :         case EXEC_END_BLOCK:
    1858                 :            :         case EXEC_END_NESTED_BLOCK:
    1859                 :            :         case EXEC_END_PROCEDURE:
    1860                 :            :           res = NULL_TREE;
    1861                 :            :           break;
    1862                 :            : 
    1863                 :     149124 :         case EXEC_ASSIGN:
    1864                 :     149124 :           res = gfc_trans_assign (code);
    1865                 :     149124 :           break;
    1866                 :            : 
    1867                 :        142 :         case EXEC_LABEL_ASSIGN:
    1868                 :        142 :           res = gfc_trans_label_assign (code);
    1869                 :        142 :           break;
    1870                 :            : 
    1871                 :       5726 :         case EXEC_POINTER_ASSIGN:
    1872                 :       5726 :           res = gfc_trans_pointer_assign (code);
    1873                 :       5726 :           break;
    1874                 :            : 
    1875                 :       6335 :         case EXEC_INIT_ASSIGN:
    1876                 :       6335 :           if (code->expr1->ts.type == BT_CLASS)
    1877                 :        270 :             res = gfc_trans_class_init_assign (code);
    1878                 :            :           else
    1879                 :       6065 :             res = gfc_trans_init_assign (code);
    1880                 :            :           break;
    1881                 :            : 
    1882                 :            :         case EXEC_CONTINUE:
    1883                 :            :           res = NULL_TREE;
    1884                 :            :           break;
    1885                 :            : 
    1886                 :         21 :         case EXEC_CRITICAL:
    1887                 :         21 :           res = gfc_trans_critical (code);
    1888                 :         21 :           break;
    1889                 :            : 
    1890                 :         81 :         case EXEC_CYCLE:
    1891                 :         81 :           res = gfc_trans_cycle (code);
    1892                 :         81 :           break;
    1893                 :            : 
    1894                 :        693 :         case EXEC_EXIT:
    1895                 :        693 :           res = gfc_trans_exit (code);
    1896                 :        693 :           break;
    1897                 :            : 
    1898                 :       1225 :         case EXEC_GOTO:
    1899                 :       1225 :           res = gfc_trans_goto (code);
    1900                 :       1225 :           break;
    1901                 :            : 
    1902                 :       1225 :         case EXEC_ENTRY:
    1903                 :       1225 :           res = gfc_trans_entry (code);
    1904                 :       1225 :           break;
    1905                 :            : 
    1906                 :         28 :         case EXEC_PAUSE:
    1907                 :         28 :           res = gfc_trans_pause (code);
    1908                 :         28 :           break;
    1909                 :            : 
    1910                 :     122795 :         case EXEC_STOP:
    1911                 :     122795 :         case EXEC_ERROR_STOP:
    1912                 :     122795 :           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
    1913                 :     122795 :           break;
    1914                 :            : 
    1915                 :      50446 :         case EXEC_CALL:
    1916                 :            :           /* For MVBITS we've got the special exception that we need a
    1917                 :            :              dependency check, too.  */
    1918                 :      50446 :           {
    1919                 :      50446 :             bool is_mvbits = false;
    1920                 :            : 
    1921                 :      50446 :             if (code->resolved_isym)
    1922                 :            :               {
    1923                 :       4901 :                 res = gfc_conv_intrinsic_subroutine (code);
    1924                 :       4901 :                 if (res != NULL_TREE)
    1925                 :            :                   break;
    1926                 :            :               }
    1927                 :            : 
    1928                 :      47180 :             if (code->resolved_isym
    1929                 :       1635 :                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
    1930                 :        155 :               is_mvbits = true;
    1931                 :            : 
    1932                 :      47180 :             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
    1933                 :            :                                   NULL_TREE, false);
    1934                 :            :           }
    1935                 :      47180 :           break;
    1936                 :            : 
    1937                 :        112 :         case EXEC_CALL_PPC:
    1938                 :        112 :           res = gfc_trans_call (code, false, NULL_TREE,
    1939                 :            :                                 NULL_TREE, false);
    1940                 :        112 :           break;
    1941                 :            : 
    1942                 :        567 :         case EXEC_ASSIGN_CALL:
    1943                 :        567 :           res = gfc_trans_call (code, true, NULL_TREE,
    1944                 :            :                                 NULL_TREE, false);
    1945                 :        567 :           break;
    1946                 :            : 
    1947                 :       1712 :         case EXEC_RETURN:
    1948                 :       1712 :           res = gfc_trans_return (code);
    1949                 :       1712 :           break;
    1950                 :            : 
    1951                 :     140173 :         case EXEC_IF:
    1952                 :     140173 :           res = gfc_trans_if (code);
    1953                 :     140173 :           break;
    1954                 :            : 
    1955                 :         62 :         case EXEC_ARITHMETIC_IF:
    1956                 :         62 :           res = gfc_trans_arithmetic_if (code);
    1957                 :         62 :           break;
    1958                 :            : 
    1959                 :       6962 :         case EXEC_BLOCK:
    1960                 :       6962 :           res = gfc_trans_block_construct (code);
    1961                 :       6962 :           break;
    1962                 :            : 
    1963                 :      20797 :         case EXEC_DO:
    1964                 :      20797 :           res = gfc_trans_do (code, cond);
    1965                 :      20797 :           break;
    1966                 :            : 
    1967                 :         47 :         case EXEC_DO_CONCURRENT:
    1968                 :         47 :           res = gfc_trans_do_concurrent (code);
    1969                 :         47 :           break;
    1970                 :            : 
    1971                 :        509 :         case EXEC_DO_WHILE:
    1972                 :        509 :           res = gfc_trans_do_while (code);
    1973                 :        509 :           break;
    1974                 :            : 
    1975                 :        779 :         case EXEC_SELECT:
    1976                 :        779 :           res = gfc_trans_select (code);
    1977                 :        779 :           break;
    1978                 :            : 
    1979                 :       1844 :         case EXEC_SELECT_TYPE:
    1980                 :       1844 :           res = gfc_trans_select_type (code);
    1981                 :       1844 :           break;
    1982                 :            : 
    1983                 :         36 :         case EXEC_SELECT_RANK:
    1984                 :         36 :           res = gfc_trans_select_rank (code);
    1985                 :         36 :           break;
    1986                 :            : 
    1987                 :         67 :         case EXEC_FLUSH:
    1988                 :         67 :           res = gfc_trans_flush (code);
    1989                 :         67 :           break;
    1990                 :            : 
    1991                 :        710 :         case EXEC_SYNC_ALL:
    1992                 :        710 :         case EXEC_SYNC_IMAGES:
    1993                 :        710 :         case EXEC_SYNC_MEMORY:
    1994                 :        710 :           res = gfc_trans_sync (code, code->op);
    1995                 :        710 :           break;
    1996                 :            : 
    1997                 :         84 :         case EXEC_LOCK:
    1998                 :         84 :         case EXEC_UNLOCK:
    1999                 :         84 :           res = gfc_trans_lock_unlock (code, code->op);
    2000                 :         84 :           break;
    2001                 :            : 
    2002                 :         39 :         case EXEC_EVENT_POST:
    2003                 :         39 :         case EXEC_EVENT_WAIT:
    2004                 :         39 :           res = gfc_trans_event_post_wait (code, code->op);
    2005                 :         39 :           break;
    2006                 :            : 
    2007                 :          3 :         case EXEC_FAIL_IMAGE:
    2008                 :          3 :           res = gfc_trans_fail_image (code);
    2009                 :          3 :           break;
    2010                 :            : 
    2011                 :       1822 :         case EXEC_FORALL:
    2012                 :       1822 :           res = gfc_trans_forall (code);
    2013                 :       1822 :           break;
    2014                 :            : 
    2015                 :         24 :         case EXEC_FORM_TEAM:
    2016                 :         24 :           res = gfc_trans_form_team (code);
    2017                 :         24 :           break;
    2018                 :            : 
    2019                 :         18 :         case EXEC_CHANGE_TEAM:
    2020                 :         18 :           res = gfc_trans_change_team (code);
    2021                 :         18 :           break;
    2022                 :            : 
    2023                 :         18 :         case EXEC_END_TEAM:
    2024                 :         18 :           res = gfc_trans_end_team (code);
    2025                 :         18 :           break;
    2026                 :            : 
    2027                 :          0 :         case EXEC_SYNC_TEAM:
    2028                 :          0 :           res = gfc_trans_sync_team (code);
    2029                 :          0 :           break;
    2030                 :            : 
    2031                 :        325 :         case EXEC_WHERE:
    2032                 :        325 :           res = gfc_trans_where (code);
    2033                 :        325 :           break;
    2034                 :            : 
    2035                 :       9640 :         case EXEC_ALLOCATE:
    2036                 :       9640 :           res = gfc_trans_allocate (code);
    2037                 :       9640 :           break;
    2038                 :            : 
    2039                 :       5607 :         case EXEC_DEALLOCATE:
    2040                 :       5607 :           res = gfc_trans_deallocate (code);
    2041                 :       5607 :           break;
    2042                 :            : 
    2043                 :       3331 :         case EXEC_OPEN:
    2044                 :       3331 :           res = gfc_trans_open (code);
    2045                 :       3331 :           break;
    2046                 :            : 
    2047                 :       2862 :         case EXEC_CLOSE:
    2048                 :       2862 :           res = gfc_trans_close (code);
    2049                 :       2862 :           break;
    2050                 :            : 
    2051                 :       5583 :         case EXEC_READ:
    2052                 :       5583 :           res = gfc_trans_read (code);
    2053                 :       5583 :           break;
    2054                 :            : 
    2055                 :      18952 :         case EXEC_WRITE:
    2056                 :      18952 :           res = gfc_trans_write (code);
    2057                 :      18952 :           break;
    2058                 :            : 
    2059                 :         83 :         case EXEC_IOLENGTH:
    2060                 :         83 :           res = gfc_trans_iolength (code);
    2061                 :         83 :           break;
    2062                 :            : 
    2063                 :        389 :         case EXEC_BACKSPACE:
    2064                 :        389 :           res = gfc_trans_backspace (code);
    2065                 :        389 :           break;
    2066                 :            : 
    2067                 :         50 :         case EXEC_ENDFILE:
    2068                 :         50 :           res = gfc_trans_endfile (code);
    2069                 :         50 :           break;
    2070                 :            : 
    2071                 :        753 :         case EXEC_INQUIRE:
    2072                 :        753 :           res = gfc_trans_inquire (code);
    2073                 :        753 :           break;
    2074                 :            : 
    2075                 :         56 :         case EXEC_WAIT:
    2076                 :         56 :           res = gfc_trans_wait (code);
    2077                 :         56 :           break;
    2078                 :            : 
    2079                 :       1948 :         case EXEC_REWIND:
    2080                 :       1948 :           res = gfc_trans_rewind (code);
    2081                 :       1948 :           break;
    2082                 :            : 
    2083                 :      34410 :         case EXEC_TRANSFER:
    2084                 :      34410 :           res = gfc_trans_transfer (code);
    2085                 :      34410 :           break;
    2086                 :            : 
    2087                 :      24618 :         case EXEC_DT_END:
    2088                 :      24618 :           res = gfc_trans_dt_end (code);
    2089                 :      24618 :           break;
    2090                 :            : 
    2091                 :      10454 :         case EXEC_OMP_ATOMIC:
    2092                 :      10454 :         case EXEC_OMP_BARRIER:
    2093                 :      10454 :         case EXEC_OMP_CANCEL:
    2094                 :      10454 :         case EXEC_OMP_CANCELLATION_POINT:
    2095                 :      10454 :         case EXEC_OMP_CRITICAL:
    2096                 :      10454 :         case EXEC_OMP_DISTRIBUTE:
    2097                 :      10454 :         case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
    2098                 :      10454 :         case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    2099                 :      10454 :         case EXEC_OMP_DISTRIBUTE_SIMD:
    2100                 :      10454 :         case EXEC_OMP_DO:
    2101                 :      10454 :         case EXEC_OMP_DO_SIMD:
    2102                 :      10454 :         case EXEC_OMP_FLUSH:
    2103                 :      10454 :         case EXEC_OMP_MASTER:
    2104                 :      10454 :         case EXEC_OMP_ORDERED:
    2105                 :      10454 :         case EXEC_OMP_PARALLEL:
    2106                 :      10454 :         case EXEC_OMP_PARALLEL_DO:
    2107                 :      10454 :         case EXEC_OMP_PARALLEL_DO_SIMD:
    2108                 :      10454 :         case EXEC_OMP_PARALLEL_SECTIONS:
    2109                 :      10454 :         case EXEC_OMP_PARALLEL_WORKSHARE:
    2110                 :      10454 :         case EXEC_OMP_SECTIONS:
    2111                 :      10454 :         case EXEC_OMP_SIMD:
    2112                 :      10454 :         case EXEC_OMP_SINGLE:
    2113                 :      10454 :         case EXEC_OMP_TARGET:
    2114                 :      10454 :         case EXEC_OMP_TARGET_DATA:
    2115                 :      10454 :         case EXEC_OMP_TARGET_ENTER_DATA:
    2116                 :      10454 :         case EXEC_OMP_TARGET_EXIT_DATA:
    2117                 :      10454 :         case EXEC_OMP_TARGET_PARALLEL:
    2118                 :      10454 :         case EXEC_OMP_TARGET_PARALLEL_DO:
    2119                 :      10454 :         case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
    2120                 :      10454 :         case EXEC_OMP_TARGET_SIMD:
    2121                 :      10454 :         case EXEC_OMP_TARGET_TEAMS:
    2122                 :      10454 :         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
    2123                 :      10454 :         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2124                 :      10454 :         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2125                 :      10454 :         case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    2126                 :      10454 :         case EXEC_OMP_TARGET_UPDATE:
    2127                 :      10454 :         case EXEC_OMP_TASK:
    2128                 :      10454 :         case EXEC_OMP_TASKGROUP:
    2129                 :      10454 :         case EXEC_OMP_TASKLOOP:
    2130                 :      10454 :         case EXEC_OMP_TASKLOOP_SIMD:
    2131                 :      10454 :         case EXEC_OMP_TASKWAIT:
    2132                 :      10454 :         case EXEC_OMP_TASKYIELD:
    2133                 :      10454 :         case EXEC_OMP_TEAMS:
    2134                 :      10454 :         case EXEC_OMP_TEAMS_DISTRIBUTE:
    2135                 :      10454 :         case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    2136                 :      10454 :         case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    2137                 :      10454 :         case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
    2138                 :      10454 :         case EXEC_OMP_WORKSHARE:
    2139                 :      10454 :           res = gfc_trans_omp_directive (code);
    2140                 :      10454 :           break;
    2141                 :            : 
    2142                 :       9415 :         case EXEC_OACC_CACHE:
    2143                 :       9415 :         case EXEC_OACC_WAIT:
    2144                 :       9415 :         case EXEC_OACC_UPDATE:
    2145                 :       9415 :         case EXEC_OACC_LOOP:
    2146                 :       9415 :         case EXEC_OACC_HOST_DATA:
    2147                 :       9415 :         case EXEC_OACC_DATA:
    2148                 :       9415 :         case EXEC_OACC_KERNELS:
    2149                 :       9415 :         case EXEC_OACC_KERNELS_LOOP:
    2150                 :       9415 :         case EXEC_OACC_PARALLEL:
    2151                 :       9415 :         case EXEC_OACC_PARALLEL_LOOP:
    2152                 :       9415 :         case EXEC_OACC_SERIAL:
    2153                 :       9415 :         case EXEC_OACC_SERIAL_LOOP:
    2154                 :       9415 :         case EXEC_OACC_ENTER_DATA:
    2155                 :       9415 :         case EXEC_OACC_EXIT_DATA:
    2156                 :       9415 :         case EXEC_OACC_ATOMIC:
    2157                 :       9415 :         case EXEC_OACC_DECLARE:
    2158                 :       9415 :           res = gfc_trans_oacc_directive (code);
    2159                 :       9415 :           break;
    2160                 :            : 
    2161                 :          0 :         default:
    2162                 :          0 :           gfc_internal_error ("gfc_trans_code(): Bad statement code");
    2163                 :            :         }
    2164                 :            : 
    2165                 :     691025 :       gfc_set_backend_locus (&code->loc);
    2166                 :            : 
    2167                 :     695969 :       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
    2168                 :            :         {
    2169                 :     642285 :           if (TREE_CODE (res) != STATEMENT_LIST)
    2170                 :     477836 :             SET_EXPR_LOCATION (res, input_location);
    2171                 :            : 
    2172                 :            :           /* Add the new statement to the block.  */
    2173                 :     642285 :           gfc_add_expr_to_block (&block, res);
    2174                 :            :         }
    2175                 :            :     }
    2176                 :            : 
    2177                 :            :   /* Return the finished block.  */
    2178                 :     273938 :   return gfc_finish_block (&block);
    2179                 :            : }
    2180                 :            : 
    2181                 :            : 
    2182                 :            : /* Translate an executable statement with condition, cond.  The condition is
    2183                 :            :    used by gfc_trans_do to test for IO result conditions inside implied
    2184                 :            :    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
    2185                 :            : 
    2186                 :            : tree
    2187                 :      45415 : gfc_trans_code_cond (gfc_code * code, tree cond)
    2188                 :            : {
    2189                 :      45415 :   return trans_code (code, cond);
    2190                 :            : }
    2191                 :            : 
    2192                 :            : /* Translate an executable statement without condition.  */
    2193                 :            : 
    2194                 :            : tree
    2195                 :     229674 : gfc_trans_code (gfc_code * code)
    2196                 :            : {
    2197                 :     229674 :   return trans_code (code, NULL_TREE);
    2198                 :            : }
    2199                 :            : 
    2200                 :            : 
    2201                 :            : /* This function is called after a complete program unit has been parsed
    2202                 :            :    and resolved.  */
    2203                 :            : 
    2204                 :            : void
    2205                 :      29741 : gfc_generate_code (gfc_namespace * ns)
    2206                 :            : {
    2207                 :      29741 :   ompws_flags = 0;
    2208                 :      29741 :   if (ns->is_block_data)
    2209                 :            :     {
    2210                 :         65 :       gfc_generate_block_data (ns);
    2211                 :         65 :       return;
    2212                 :            :     }
    2213                 :            : 
    2214                 :      29676 :   gfc_generate_function_code (ns);
    2215                 :            : }
    2216                 :            : 
    2217                 :            : 
    2218                 :            : /* This function is called after a complete module has been parsed
    2219                 :            :    and resolved.  */
    2220                 :            : 
    2221                 :            : void
    2222                 :       6716 : gfc_generate_module_code (gfc_namespace * ns)
    2223                 :            : {
    2224                 :       6716 :   gfc_namespace *n;
    2225                 :       6716 :   struct module_htab_entry *entry;
    2226                 :            : 
    2227                 :       6716 :   gcc_assert (ns->proc_name->backend_decl == NULL);
    2228                 :      13432 :   ns->proc_name->backend_decl
    2229                 :       6716 :     = build_decl (gfc_get_location (&ns->proc_name->declared_at),
    2230                 :            :                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
    2231                 :            :                   void_type_node);
    2232                 :       6716 :   entry = gfc_find_module (ns->proc_name->name);
    2233                 :       6716 :   if (entry->namespace_decl)
    2234                 :            :     /* Buggy sourcecode, using a module before defining it?  */
    2235                 :          0 :     entry->decls->empty ();
    2236                 :       6716 :   entry->namespace_decl = ns->proc_name->backend_decl;
    2237                 :            : 
    2238                 :       6716 :   gfc_generate_module_vars (ns);
    2239                 :            : 
    2240                 :            :   /* We need to generate all module function prototypes first, to allow
    2241                 :            :      sibling calls.  */
    2242                 :      22637 :   for (n = ns->contained; n; n = n->sibling)
    2243                 :            :     {
    2244                 :      15921 :       gfc_entry_list *el;
    2245                 :            : 
    2246                 :      15921 :       if (!n->proc_name)
    2247                 :          0 :         continue;
    2248                 :            : 
    2249                 :      15921 :       gfc_create_function_decl (n, false);
    2250                 :      15921 :       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
    2251                 :      15921 :       gfc_module_add_decl (entry, n->proc_name->backend_decl);
    2252                 :      15921 :       for (el = ns->entries; el; el = el->next)
    2253                 :            :         {
    2254                 :          0 :           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
    2255                 :          0 :           gfc_module_add_decl (entry, el->sym->backend_decl);
    2256                 :            :         }
    2257                 :            :     }
    2258                 :            : 
    2259                 :      22637 :   for (n = ns->contained; n; n = n->sibling)
    2260                 :            :     {
    2261                 :      15921 :       if (!n->proc_name)
    2262                 :          0 :         continue;
    2263                 :            : 
    2264                 :      15921 :       gfc_generate_function_code (n);
    2265                 :            :     }
    2266                 :       6716 : }
    2267                 :            : 
    2268                 :            : 
    2269                 :            : /* Initialize an init/cleanup block with existing code.  */
    2270                 :            : 
    2271                 :            : void
    2272                 :      64772 : gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
    2273                 :            : {
    2274                 :      64772 :   gcc_assert (block);
    2275                 :            : 
    2276                 :      64772 :   block->init = NULL_TREE;
    2277                 :      64772 :   block->code = code;
    2278                 :      64772 :   block->cleanup = NULL_TREE;
    2279                 :      64772 : }
    2280                 :            : 
    2281                 :            : 
    2282                 :            : /* Add a new pair of initializers/clean-up code.  */
    2283                 :            : 
    2284                 :            : void
    2285                 :     240852 : gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
    2286                 :            : {
    2287                 :     240852 :   gcc_assert (block);
    2288                 :            : 
    2289                 :            :   /* The new pair of init/cleanup should be "wrapped around" the existing
    2290                 :            :      block of code, thus the initialization is added to the front and the
    2291                 :            :      cleanup to the back.  */
    2292                 :     240852 :   add_expr_to_chain (&block->init, init, true);
    2293                 :     240852 :   add_expr_to_chain (&block->cleanup, cleanup, false);
    2294                 :     240852 : }
    2295                 :            : 
    2296                 :            : 
    2297                 :            : /* Finish up a wrapped block by building a corresponding try-finally expr.  */
    2298                 :            : 
    2299                 :            : tree
    2300                 :      64772 : gfc_finish_wrapped_block (gfc_wrapped_block* block)
    2301                 :            : {
    2302                 :      64772 :   tree result;
    2303                 :            : 
    2304                 :      64772 :   gcc_assert (block);
    2305                 :            : 
    2306                 :            :   /* Build the final expression.  For this, just add init and body together,
    2307                 :            :      and put clean-up with that into a TRY_FINALLY_EXPR.  */
    2308                 :      64772 :   result = block->init;
    2309                 :      64772 :   add_expr_to_chain (&result, block->code, false);
    2310                 :      64772 :   if (block->cleanup)
    2311                 :       9782 :     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
    2312                 :            :                          result, block->cleanup);
    2313                 :            : 
    2314                 :            :   /* Clear the block.  */
    2315                 :      64772 :   block->init = NULL_TREE;
    2316                 :      64772 :   block->code = NULL_TREE;
    2317                 :      64772 :   block->cleanup = NULL_TREE;
    2318                 :            : 
    2319                 :      64772 :   return result;
    2320                 :            : }
    2321                 :            : 
    2322                 :            : 
    2323                 :            : /* Helper function for marking a boolean expression tree as unlikely.  */
    2324                 :            : 
    2325                 :            : tree
    2326                 :      76592 : gfc_unlikely (tree cond, enum br_predictor predictor)
    2327                 :            : {
    2328                 :      76592 :   tree tmp;
    2329                 :            : 
    2330                 :      76592 :   if (optimize)
    2331                 :            :     {
    2332                 :      65496 :       cond = fold_convert (long_integer_type_node, cond);
    2333                 :      65496 :       tmp = build_zero_cst (long_integer_type_node);
    2334                 :      65496 :       cond = build_call_expr_loc (input_location,
    2335                 :            :                                   builtin_decl_explicit (BUILT_IN_EXPECT),
    2336                 :            :                                   3, cond, tmp,
    2337                 :            :                                   build_int_cst (integer_type_node,
    2338                 :            :                                                  predictor));
    2339                 :            :     }
    2340                 :      76592 :   return cond;
    2341                 :            : }
    2342                 :            : 
    2343                 :            : 
    2344                 :            : /* Helper function for marking a boolean expression tree as likely.  */
    2345                 :            : 
    2346                 :            : tree
    2347                 :        374 : gfc_likely (tree cond, enum br_predictor predictor)
    2348                 :            : {
    2349                 :        374 :   tree tmp;
    2350                 :            : 
    2351                 :        374 :   if (optimize)
    2352                 :            :     {
    2353                 :        374 :       cond = fold_convert (long_integer_type_node, cond);
    2354                 :        374 :       tmp = build_one_cst (long_integer_type_node);
    2355                 :        374 :       cond = build_call_expr_loc (input_location,
    2356                 :            :                                   builtin_decl_explicit (BUILT_IN_EXPECT),
    2357                 :            :                                   3, cond, tmp,
    2358                 :            :                                   build_int_cst (integer_type_node,
    2359                 :            :                                                  predictor));
    2360                 :            :     }
    2361                 :        374 :   return cond;
    2362                 :            : }
    2363                 :            : 
    2364                 :            : 
    2365                 :            : /* Get the string length for a deferred character length component.  */
    2366                 :            : 
    2367                 :            : bool
    2368                 :     124422 : gfc_deferred_strlen (gfc_component *c, tree *decl)
    2369                 :            : {
    2370                 :     124422 :   char name[GFC_MAX_SYMBOL_LEN+9];
    2371                 :     124422 :   gfc_component *strlen;
    2372                 :     124422 :   if (!(c->ts.type == BT_CHARACTER
    2373                 :       7716 :         && (c->ts.deferred || c->attr.pdt_string)))
    2374                 :            :     return false;
    2375                 :       2156 :   sprintf (name, "_%s_length", c->name);
    2376                 :       5008 :   for (strlen = c; strlen; strlen = strlen->next)
    2377                 :       4997 :     if (strcmp (strlen->name, name) == 0)
    2378                 :            :       break;
    2379                 :       2156 :   *decl = strlen ? strlen->backend_decl : NULL_TREE;
    2380                 :       2156 :   return strlen != NULL;
    2381                 :            : }

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.