LCOV - code coverage report
Current view: top level - gcc/fortran - frontend-passes.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 95.7 % 2904 2780
Test Date: 2023-09-09 13:19:57 Functions: 98.8 % 86 85
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Pass manager for Fortran front end.
       2                 :             :    Copyright (C) 2010-2023 Free Software Foundation, Inc.
       3                 :             :    Contributed by Thomas K├Ânig.
       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 "gfortran.h"
      26                 :             : #include "dependency.h"
      27                 :             : #include "constructor.h"
      28                 :             : #include "intrinsic.h"
      29                 :             : 
      30                 :             : /* Forward declarations.  */
      31                 :             : 
      32                 :             : static void strip_function_call (gfc_expr *);
      33                 :             : static void optimize_namespace (gfc_namespace *);
      34                 :             : static void optimize_assignment (gfc_code *);
      35                 :             : static bool optimize_op (gfc_expr *);
      36                 :             : static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
      37                 :             : static bool optimize_trim (gfc_expr *);
      38                 :             : static bool optimize_lexical_comparison (gfc_expr *);
      39                 :             : static void optimize_minmaxloc (gfc_expr **);
      40                 :             : static bool is_empty_string (gfc_expr *e);
      41                 :             : static void doloop_warn (gfc_namespace *);
      42                 :             : static int do_intent (gfc_expr **);
      43                 :             : static int do_subscript (gfc_expr **);
      44                 :             : static void optimize_reduction (gfc_namespace *);
      45                 :             : static int callback_reduction (gfc_expr **, int *, void *);
      46                 :             : static void realloc_strings (gfc_namespace *);
      47                 :             : static gfc_expr *create_var (gfc_expr *, const char *vname=NULL);
      48                 :             : static int matmul_to_var_expr (gfc_expr **, int *, void *);
      49                 :             : static int matmul_to_var_code (gfc_code **, int *, void *);
      50                 :             : static int inline_matmul_assign (gfc_code **, int *, void *);
      51                 :             : static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *,
      52                 :             :                                   locus *, gfc_namespace *,
      53                 :             :                                   char *vname=NULL);
      54                 :             : static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *,
      55                 :             :                                                  bool *);
      56                 :             : static int call_external_blas (gfc_code **, int *, void *);
      57                 :             : static int matmul_temp_args (gfc_code **, int *,void *data);
      58                 :             : static int index_interchange (gfc_code **, int*, void *);
      59                 :             : static bool is_fe_temp (gfc_expr *e);
      60                 :             : 
      61                 :             : #ifdef CHECKING_P
      62                 :             : static void check_locus (gfc_namespace *);
      63                 :             : #endif
      64                 :             : 
      65                 :             : /* How deep we are inside an argument list.  */
      66                 :             : 
      67                 :             : static int count_arglist;
      68                 :             : 
      69                 :             : /* Vector of gfc_expr ** we operate on.  */
      70                 :             : 
      71                 :             : static vec<gfc_expr **> expr_array;
      72                 :             : 
      73                 :             : /* Pointer to the gfc_code we currently work on - to be able to insert
      74                 :             :    a block before the statement.  */
      75                 :             : 
      76                 :             : static gfc_code **current_code;
      77                 :             : 
      78                 :             : /* Pointer to the block to be inserted, and the statement we are
      79                 :             :    changing within the block.  */
      80                 :             : 
      81                 :             : static gfc_code *inserted_block, **changed_statement;
      82                 :             : 
      83                 :             : /* The namespace we are currently dealing with.  */
      84                 :             : 
      85                 :             : static gfc_namespace *current_ns;
      86                 :             : 
      87                 :             : /* If we are within any forall loop.  */
      88                 :             : 
      89                 :             : static int forall_level;
      90                 :             : 
      91                 :             : /* Keep track of whether we are within an OMP workshare.  */
      92                 :             : 
      93                 :             : static bool in_omp_workshare;
      94                 :             : 
      95                 :             : /* Keep track of whether we are within an OMP atomic.  */
      96                 :             : 
      97                 :             : static bool in_omp_atomic;
      98                 :             : 
      99                 :             : /* Keep track of whether we are within a WHERE statement.  */
     100                 :             : 
     101                 :             : static bool in_where;
     102                 :             : 
     103                 :             : /* Keep track of iterators for array constructors.  */
     104                 :             : 
     105                 :             : static int iterator_level;
     106                 :             : 
     107                 :             : /* Keep track of DO loop levels.  */
     108                 :             : 
     109                 :             : typedef struct {
     110                 :             :   gfc_code *c;
     111                 :             :   int branch_level;
     112                 :             :   bool seen_goto;
     113                 :             : } do_t;
     114                 :             : 
     115                 :             : static vec<do_t> doloop_list;
     116                 :             : static int doloop_level;
     117                 :             : 
     118                 :             : /* Keep track of if and select case levels.  */
     119                 :             : 
     120                 :             : static int if_level;
     121                 :             : static int select_level;
     122                 :             : 
     123                 :             : /* Vector of gfc_expr * to keep track of DO loops.  */
     124                 :             : 
     125                 :             : struct my_struct *evec;
     126                 :             : 
     127                 :             : /* Keep track of association lists.  */
     128                 :             : 
     129                 :             : static bool in_assoc_list;
     130                 :             : 
     131                 :             : /* Counter for temporary variables.  */
     132                 :             : 
     133                 :             : static int var_num = 1;
     134                 :             : 
     135                 :             : /* What sort of matrix we are dealing with when inlining MATMUL.  */
     136                 :             : 
     137                 :             : enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T };
     138                 :             : 
     139                 :             : /* Keep track of the number of expressions we have inserted so far
     140                 :             :    using create_var.  */
     141                 :             : 
     142                 :             : int n_vars;
     143                 :             : 
     144                 :             : /* Entry point - run all passes for a namespace.  */
     145                 :             : 
     146                 :             : void
     147                 :      245023 : gfc_run_passes (gfc_namespace *ns)
     148                 :             : {
     149                 :             : 
     150                 :             :   /* Warn about dubious DO loops where the index might
     151                 :             :      change.  */
     152                 :             : 
     153                 :      245023 :   doloop_level = 0;
     154                 :      245023 :   if_level = 0;
     155                 :      245023 :   select_level = 0;
     156                 :      245023 :   doloop_warn (ns);
     157                 :      245023 :   doloop_list.release ();
     158                 :      245023 :   int w, e;
     159                 :             : 
     160                 :             : #ifdef CHECKING_P
     161                 :      245023 :   check_locus (ns);
     162                 :             : #endif
     163                 :             : 
     164                 :      245023 :   gfc_get_errors (&w, &e);
     165                 :      245023 :   if (e > 0)
     166                 :        4881 :     return;
     167                 :             : 
     168                 :      240142 :   if (flag_frontend_optimize || flag_frontend_loop_interchange)
     169                 :      201958 :     optimize_namespace (ns);
     170                 :             : 
     171                 :      240142 :   if (flag_frontend_optimize)
     172                 :             :     {
     173                 :      201944 :       optimize_reduction (ns);
     174                 :      201944 :       if (flag_dump_fortran_optimized)
     175                 :           0 :         gfc_dump_parse_tree (ns, stdout);
     176                 :             : 
     177                 :      201944 :       expr_array.release ();
     178                 :             :     }
     179                 :             : 
     180                 :      240142 :   if (flag_realloc_lhs)
     181                 :      240005 :     realloc_strings (ns);
     182                 :             : }
     183                 :             : 
     184                 :             : #ifdef CHECKING_P
     185                 :             : 
     186                 :             : /* Callback function: Warn if there is no location information in a
     187                 :             :    statement.  */
     188                 :             : 
     189                 :             : static int
     190                 :      956516 : check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     191                 :             :                   void *data ATTRIBUTE_UNUSED)
     192                 :             : {
     193                 :      956516 :   current_code = c;
     194                 :      956516 :   if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
     195                 :           0 :     gfc_warning_internal (0, "Inconsistent internal state: "
     196                 :             :                           "No location in statement");
     197                 :             : 
     198                 :      956516 :   return 0;
     199                 :             : }
     200                 :             : 
     201                 :             : 
     202                 :             : /* Callback function: Warn if there is no location information in an
     203                 :             :    expression.  */
     204                 :             : 
     205                 :             : static int
     206                 :     2732351 : check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     207                 :             :                   void *data ATTRIBUTE_UNUSED)
     208                 :             : {
     209                 :             : 
     210                 :     2732351 :   if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
     211                 :           0 :     gfc_warning_internal (0, "Inconsistent internal state: "
     212                 :             :                           "No location in expression near %L",
     213                 :           0 :                           &((*current_code)->loc));
     214                 :     2732351 :   return 0;
     215                 :             : }
     216                 :             : 
     217                 :             : /* Run check for missing location information.  */
     218                 :             : 
     219                 :             : static void
     220                 :      283177 : check_locus (gfc_namespace *ns)
     221                 :             : {
     222                 :      283177 :   gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
     223                 :             : 
     224                 :      322112 :   for (ns = ns->contained; ns; ns = ns->sibling)
     225                 :             :     {
     226                 :       38935 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
     227                 :       38154 :         check_locus (ns);
     228                 :             :     }
     229                 :      283177 : }
     230                 :             : 
     231                 :             : #endif
     232                 :             : 
     233                 :             : /* Callback for each gfc_code node invoked from check_realloc_strings.
     234                 :             :    For an allocatable LHS string which also appears as a variable on
     235                 :             :    the RHS, replace
     236                 :             : 
     237                 :             :    a = a(x:y)
     238                 :             : 
     239                 :             :    with
     240                 :             : 
     241                 :             :    tmp = a(x:y)
     242                 :             :    a = tmp
     243                 :             :  */
     244                 :             : 
     245                 :             : static int
     246                 :      945439 : realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     247                 :             :                          void *data ATTRIBUTE_UNUSED)
     248                 :             : {
     249                 :      945439 :   gfc_expr *expr1, *expr2;
     250                 :      945439 :   gfc_code *co = *c;
     251                 :      945439 :   gfc_expr *n;
     252                 :      945439 :   gfc_ref *ref;
     253                 :      945439 :   bool found_substr;
     254                 :             : 
     255                 :      945439 :   if (co->op != EXEC_ASSIGN)
     256                 :             :     return 0;
     257                 :             : 
     258                 :      193390 :   expr1 = co->expr1;
     259                 :      193390 :   if (expr1->ts.type != BT_CHARACTER
     260                 :       26511 :       || !gfc_expr_attr(expr1).allocatable
     261                 :      195502 :       || !expr1->ts.deferred)
     262                 :      191646 :     return 0;
     263                 :             : 
     264                 :        5164 :   if (is_fe_temp (expr1))
     265                 :             :     return 0;
     266                 :             : 
     267                 :        1676 :   expr2 = gfc_discard_nops (co->expr2);
     268                 :             : 
     269                 :        1676 :   if (expr2->expr_type == EXPR_VARIABLE)
     270                 :             :     {
     271                 :         428 :       found_substr = false;
     272                 :         587 :       for (ref = expr2->ref; ref; ref = ref->next)
     273                 :             :         {
     274                 :         298 :           if (ref->type == REF_SUBSTRING)
     275                 :             :             {
     276                 :             :               found_substr = true;
     277                 :             :               break;
     278                 :             :             }
     279                 :             :         }
     280                 :         428 :       if (!found_substr)
     281                 :             :         return 0;
     282                 :             :     }
     283                 :        1248 :   else if (expr2->expr_type != EXPR_ARRAY
     284                 :        1085 :            && (expr2->expr_type != EXPR_OP
     285                 :          74 :                || expr2->value.op.op != INTRINSIC_CONCAT))
     286                 :             :     return 0;
     287                 :             : 
     288                 :         376 :   if (!gfc_check_dependency (expr1, expr2, true))
     289                 :             :     return 0;
     290                 :             : 
     291                 :             :   /* gfc_check_dependency doesn't always pick up identical expressions.
     292                 :             :      However, eliminating the above sends the compiler into an infinite
     293                 :             :      loop on valid expressions.  Without this check, the gimplifier emits
     294                 :             :      an ICE for a = a, where a is deferred character length.  */
     295                 :          89 :   if (!gfc_dep_compare_expr (expr1, expr2))
     296                 :             :     return 0;
     297                 :             : 
     298                 :          89 :   current_code = c;
     299                 :          89 :   inserted_block = NULL;
     300                 :          89 :   changed_statement = NULL;
     301                 :          89 :   n = create_var (expr2, "realloc_string");
     302                 :          89 :   co->expr2 = n;
     303                 :          89 :   return 0;
     304                 :             : }
     305                 :             : 
     306                 :             : /* Callback for each gfc_code node invoked through gfc_code_walker
     307                 :             :    from optimize_namespace.  */
     308                 :             : 
     309                 :             : static int
     310                 :      796630 : optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     311                 :             :                void *data ATTRIBUTE_UNUSED)
     312                 :             : {
     313                 :             : 
     314                 :      796630 :   gfc_exec_op op;
     315                 :             : 
     316                 :      796630 :   op = (*c)->op;
     317                 :             : 
     318                 :      796630 :   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
     319                 :      796630 :       || op == EXEC_CALL_PPC)
     320                 :       60943 :     count_arglist = 1;
     321                 :             :   else
     322                 :      735687 :     count_arglist = 0;
     323                 :             : 
     324                 :      796630 :   current_code = c;
     325                 :      796630 :   inserted_block = NULL;
     326                 :      796630 :   changed_statement = NULL;
     327                 :             : 
     328                 :      796630 :   if (op == EXEC_ASSIGN)
     329                 :      163863 :     optimize_assignment (*c);
     330                 :      796630 :   return 0;
     331                 :             : }
     332                 :             : 
     333                 :             : /* Callback for each gfc_expr node invoked through gfc_code_walker
     334                 :             :    from optimize_namespace.  */
     335                 :             : 
     336                 :             : static int
     337                 :     2290803 : optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     338                 :             :                void *data ATTRIBUTE_UNUSED)
     339                 :             : {
     340                 :     2290803 :   bool function_expr;
     341                 :             : 
     342                 :     2290803 :   if ((*e)->expr_type == EXPR_FUNCTION)
     343                 :             :     {
     344                 :      199079 :       count_arglist ++;
     345                 :      199079 :       function_expr = true;
     346                 :             :     }
     347                 :             :   else
     348                 :             :     function_expr = false;
     349                 :             : 
     350                 :     2290803 :   if (optimize_trim (*e))
     351                 :         387 :     gfc_simplify_expr (*e, 0);
     352                 :             : 
     353                 :     2290803 :   if (optimize_lexical_comparison (*e))
     354                 :          24 :     gfc_simplify_expr (*e, 0);
     355                 :             : 
     356                 :     2290803 :   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
     357                 :        1238 :     gfc_simplify_expr (*e, 0);
     358                 :             : 
     359                 :     2290803 :   if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
     360                 :      159869 :     switch ((*e)->value.function.isym->id)
     361                 :             :       {
     362                 :        7056 :       case GFC_ISYM_MINLOC:
     363                 :        7056 :       case GFC_ISYM_MAXLOC:
     364                 :        7056 :         optimize_minmaxloc (e);
     365                 :        7056 :         break;
     366                 :             :       default:
     367                 :             :         break;
     368                 :             :       }
     369                 :             : 
     370                 :     2290803 :   if (function_expr)
     371                 :      199079 :     count_arglist --;
     372                 :             : 
     373                 :     2290803 :   return 0;
     374                 :             : }
     375                 :             : 
     376                 :             : /* Auxiliary function to handle the arguments to reduction intrinsics.  If the
     377                 :             :    function is a scalar, just copy it; otherwise returns the new element, the
     378                 :             :    old one can be freed.  */
     379                 :             : 
     380                 :             : static gfc_expr *
     381                 :         371 : copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
     382                 :             : {
     383                 :         371 :   gfc_expr *fcn, *e = c->expr;
     384                 :             : 
     385                 :         371 :   fcn = gfc_copy_expr (e);
     386                 :         371 :   if (c->iterator)
     387                 :             :     {
     388                 :          58 :       gfc_constructor_base newbase;
     389                 :          58 :       gfc_expr *new_expr;
     390                 :          58 :       gfc_constructor *new_c;
     391                 :             : 
     392                 :          58 :       newbase = NULL;
     393                 :          58 :       new_expr = gfc_get_expr ();
     394                 :          58 :       new_expr->expr_type = EXPR_ARRAY;
     395                 :          58 :       new_expr->ts = e->ts;
     396                 :          58 :       new_expr->where = e->where;
     397                 :          58 :       new_expr->rank = 1;
     398                 :          58 :       new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
     399                 :          58 :       new_c->iterator = c->iterator;
     400                 :          58 :       new_expr->value.constructor = newbase;
     401                 :          58 :       c->iterator = NULL;
     402                 :             : 
     403                 :          58 :       fcn = new_expr;
     404                 :             :     }
     405                 :             : 
     406                 :         371 :   if (fcn->rank != 0)
     407                 :             :     {
     408                 :          96 :       gfc_isym_id id = fn->value.function.isym->id;
     409                 :             : 
     410                 :          96 :       if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
     411                 :          65 :         fcn = gfc_build_intrinsic_call (current_ns, id,
     412                 :             :                                         fn->value.function.isym->name,
     413                 :             :                                         fn->where, 3, fcn, NULL, NULL);
     414                 :          31 :       else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
     415                 :          31 :         fcn = gfc_build_intrinsic_call (current_ns, id,
     416                 :             :                                         fn->value.function.isym->name,
     417                 :             :                                         fn->where, 2, fcn, NULL);
     418                 :             :       else
     419                 :           0 :         gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
     420                 :             : 
     421                 :          96 :       fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
     422                 :             :     }
     423                 :             : 
     424                 :         371 :   return fcn;
     425                 :             : }
     426                 :             : 
     427                 :             : /* Callback function for optimization of reductions to scalars.  Transform ANY
     428                 :             :    ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
     429                 :             :    correspondingly.  Handle only the simple cases without MASK and DIM.  */
     430                 :             : 
     431                 :             : static int
     432                 :     2338863 : callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     433                 :             :                     void *data ATTRIBUTE_UNUSED)
     434                 :             : {
     435                 :     2338863 :   gfc_expr *fn, *arg;
     436                 :     2338863 :   gfc_intrinsic_op op;
     437                 :     2338863 :   gfc_isym_id id;
     438                 :     2338863 :   gfc_actual_arglist *a;
     439                 :     2338863 :   gfc_actual_arglist *dim;
     440                 :     2338863 :   gfc_constructor *c;
     441                 :     2338863 :   gfc_expr *res, *new_expr;
     442                 :     2338863 :   gfc_actual_arglist *mask;
     443                 :             : 
     444                 :     2338863 :   fn = *e;
     445                 :             : 
     446                 :     2338863 :   if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
     447                 :      180616 :       || fn->value.function.isym == NULL)
     448                 :             :     return 0;
     449                 :             : 
     450                 :      144492 :   id = fn->value.function.isym->id;
     451                 :             : 
     452                 :      144492 :   if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
     453                 :      143230 :       && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
     454                 :             :     return 0;
     455                 :             : 
     456                 :       25586 :   a = fn->value.function.actual;
     457                 :             : 
     458                 :             :   /* Don't handle MASK or DIM.  */
     459                 :             : 
     460                 :       25586 :   dim = a->next;
     461                 :             : 
     462                 :       25586 :   if (dim->expr != NULL)
     463                 :             :     return 0;
     464                 :             : 
     465                 :       25459 :   if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
     466                 :             :     {
     467                 :        1136 :       mask = dim->next;
     468                 :        1136 :       if ( mask->expr != NULL)
     469                 :             :         return 0;
     470                 :             :     }
     471                 :             : 
     472                 :       25335 :   arg = a->expr;
     473                 :             : 
     474                 :       25335 :   if (arg->expr_type != EXPR_ARRAY)
     475                 :             :     return 0;
     476                 :             : 
     477                 :         143 :   switch (id)
     478                 :             :     {
     479                 :             :     case GFC_ISYM_SUM:
     480                 :             :       op = INTRINSIC_PLUS;
     481                 :             :       break;
     482                 :             : 
     483                 :          13 :     case GFC_ISYM_PRODUCT:
     484                 :          13 :       op = INTRINSIC_TIMES;
     485                 :          13 :       break;
     486                 :             : 
     487                 :          74 :     case GFC_ISYM_ANY:
     488                 :          74 :       op = INTRINSIC_OR;
     489                 :          74 :       break;
     490                 :             : 
     491                 :           3 :     case GFC_ISYM_ALL:
     492                 :           3 :       op = INTRINSIC_AND;
     493                 :           3 :       break;
     494                 :             : 
     495                 :             :     default:
     496                 :             :       return 0;
     497                 :             :     }
     498                 :             : 
     499                 :         143 :   c = gfc_constructor_first (arg->value.constructor);
     500                 :             : 
     501                 :             :   /* Don't do any simplififcation if we have
     502                 :             :      - no element in the constructor or
     503                 :             :      - only have a single element in the array which contains an
     504                 :             :      iterator.  */
     505                 :             : 
     506                 :         143 :   if (c == NULL)
     507                 :             :     return 0;
     508                 :             : 
     509                 :         143 :   res = copy_walk_reduction_arg (c, fn);
     510                 :             : 
     511                 :         143 :   c = gfc_constructor_next (c);
     512                 :         514 :   while (c)
     513                 :             :     {
     514                 :         228 :       new_expr = gfc_get_expr ();
     515                 :         228 :       new_expr->ts = fn->ts;
     516                 :         228 :       new_expr->expr_type = EXPR_OP;
     517                 :         228 :       new_expr->rank = fn->rank;
     518                 :         228 :       new_expr->where = fn->where;
     519                 :         228 :       new_expr->value.op.op = op;
     520                 :         228 :       new_expr->value.op.op1 = res;
     521                 :         228 :       new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
     522                 :         228 :       res = new_expr;
     523                 :         228 :       c = gfc_constructor_next (c);
     524                 :             :     }
     525                 :             : 
     526                 :         143 :   gfc_simplify_expr (res, 0);
     527                 :         143 :   *e = res;
     528                 :         143 :   gfc_free_expr (fn);
     529                 :             : 
     530                 :         143 :   return 0;
     531                 :             : }
     532                 :             : 
     533                 :             : /* Callback function for common function elimination, called from cfe_expr_0.
     534                 :             :    Put all eligible function expressions into expr_array.  */
     535                 :             : 
     536                 :             : static int
     537                 :     2263757 : cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     538                 :             :           void *data ATTRIBUTE_UNUSED)
     539                 :             : {
     540                 :             : 
     541                 :     2263757 :   if ((*e)->expr_type != EXPR_FUNCTION)
     542                 :             :     return 0;
     543                 :             : 
     544                 :             :   /* We don't do character functions with unknown charlens.  */
     545                 :      196642 :   if ((*e)->ts.type == BT_CHARACTER
     546                 :        8955 :       && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
     547                 :        6495 :           || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
     548                 :             :     return 0;
     549                 :             : 
     550                 :             :   /* We don't do function elimination within FORALL statements, it can
     551                 :             :      lead to wrong-code in certain circumstances.  */
     552                 :             : 
     553                 :      192510 :   if (forall_level > 0)
     554                 :             :     return 0;
     555                 :             : 
     556                 :             :   /* Function elimination inside an iterator could lead to functions which
     557                 :             :      depend on iterator variables being moved outside.  FIXME: We should check
     558                 :             :      if the functions do indeed depend on the iterator variable.  */
     559                 :             : 
     560                 :      191398 :   if (iterator_level > 0)
     561                 :             :     return 0;
     562                 :             : 
     563                 :             :   /* If we don't know the shape at compile time, we create an allocatable
     564                 :             :      temporary variable to hold the intermediate result, but only if
     565                 :             :      allocation on assignment is active.  */
     566                 :             : 
     567                 :      191171 :   if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs)
     568                 :             :     return 0;
     569                 :             : 
     570                 :             :   /* Skip the test for pure functions if -faggressive-function-elimination
     571                 :             :      is specified.  */
     572                 :      191154 :   if ((*e)->value.function.esym)
     573                 :             :     {
     574                 :             :       /* Don't create an array temporary for elemental functions.  */
     575                 :       34815 :       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
     576                 :             :         return 0;
     577                 :             : 
     578                 :             :       /* Only eliminate potentially impure functions if the
     579                 :             :          user specifically requested it.  */
     580                 :       34172 :       if (!flag_aggressive_function_elimination
     581                 :       34156 :           && !(*e)->value.function.esym->attr.pure
     582                 :       20152 :           && !(*e)->value.function.esym->attr.implicit_pure)
     583                 :             :         return 0;
     584                 :             :     }
     585                 :             : 
     586                 :      173415 :   if ((*e)->value.function.isym)
     587                 :             :     {
     588                 :             :       /* Conversions are handled on the fly by the middle end,
     589                 :             :          transpose during trans-* stages and TRANSFER by the middle end.  */
     590                 :      153965 :       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
     591                 :      133863 :           || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
     592                 :      285310 :           || gfc_inline_intrinsic_function_p (*e))
     593                 :       25029 :         return 0;
     594                 :             : 
     595                 :             :       /* Don't create an array temporary for elemental functions,
     596                 :             :          as this would be wasteful of memory.
     597                 :             :          FIXME: Create a scalar temporary during scalarization.  */
     598                 :      128936 :       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
     599                 :             :         return 0;
     600                 :             : 
     601                 :      125329 :       if (!(*e)->value.function.isym->pure)
     602                 :             :         return 0;
     603                 :             :     }
     604                 :             : 
     605                 :      138271 :   expr_array.safe_push (e);
     606                 :      138271 :   return 0;
     607                 :             : }
     608                 :             : 
     609                 :             : /* Auxiliary function to check if an expression is a temporary created by
     610                 :             :    create var.  */
     611                 :             : 
     612                 :             : static bool
     613                 :        2886 : is_fe_temp (gfc_expr *e)
     614                 :             : {
     615                 :        2886 :   if (e->expr_type != EXPR_VARIABLE)
     616                 :             :     return false;
     617                 :             : 
     618                 :        1744 :   return e->symtree->n.sym->attr.fe_temp;
     619                 :             : }
     620                 :             : 
     621                 :             : /* Determine the length of a string, if it can be evaluated as a constant
     622                 :             :    expression.  Return a newly allocated gfc_expr or NULL on failure.
     623                 :             :    If the user specified a substring which is potentially longer than
     624                 :             :    the string itself, the string will be padded with spaces, which
     625                 :             :    is harmless.  */
     626                 :             : 
     627                 :             : static gfc_expr *
     628                 :          91 : constant_string_length (gfc_expr *e)
     629                 :             : {
     630                 :             : 
     631                 :          91 :   gfc_expr *length;
     632                 :          91 :   gfc_ref *ref;
     633                 :          91 :   gfc_expr *res;
     634                 :          91 :   mpz_t value;
     635                 :             : 
     636                 :          91 :   if (e->ts.u.cl)
     637                 :             :     {
     638                 :          91 :       length = e->ts.u.cl->length;
     639                 :          91 :       if (length && length->expr_type == EXPR_CONSTANT)
     640                 :           4 :         return gfc_copy_expr(length);
     641                 :             :     }
     642                 :             : 
     643                 :             :   /* See if there is a substring. If it has a constant length, return
     644                 :             :      that and NULL otherwise.  */
     645                 :         105 :   for (ref = e->ref; ref; ref = ref->next)
     646                 :             :     {
     647                 :          67 :       if (ref->type == REF_SUBSTRING)
     648                 :             :         {
     649                 :          49 :           if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
     650                 :             :             {
     651                 :          13 :               res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
     652                 :             :                                            &e->where);
     653                 :             : 
     654                 :          13 :               mpz_add_ui (res->value.integer, value, 1);
     655                 :          13 :               mpz_clear (value);
     656                 :          13 :               return res;
     657                 :             :             }
     658                 :             :           else
     659                 :             :             return NULL;
     660                 :             :         }
     661                 :             :     }
     662                 :             : 
     663                 :             :   /* Return length of char symbol, if constant.  */
     664                 :          38 :   if (e->symtree && e->symtree->n.sym->ts.u.cl
     665                 :           0 :       && e->symtree->n.sym->ts.u.cl->length
     666                 :           0 :       && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
     667                 :           0 :     return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
     668                 :             : 
     669                 :             :   return NULL;
     670                 :             : 
     671                 :             : }
     672                 :             : 
     673                 :             : /* Insert a block at the current position unless it has already
     674                 :             :    been inserted; in this case use the one already there.  */
     675                 :             : 
     676                 :             : static gfc_namespace*
     677                 :        1882 : insert_block ()
     678                 :             : {
     679                 :        1882 :   gfc_namespace *ns;
     680                 :             : 
     681                 :             :   /* If the block hasn't already been created, do so.  */
     682                 :        1882 :   if (inserted_block == NULL)
     683                 :             :     {
     684                 :        1589 :       inserted_block = XCNEW (gfc_code);
     685                 :        1589 :       inserted_block->op = EXEC_BLOCK;
     686                 :        1589 :       inserted_block->loc = (*current_code)->loc;
     687                 :        1589 :       ns = gfc_build_block_ns (current_ns);
     688                 :        1589 :       inserted_block->ext.block.ns = ns;
     689                 :        1589 :       inserted_block->ext.block.assoc = NULL;
     690                 :             : 
     691                 :        1589 :       ns->code = *current_code;
     692                 :             : 
     693                 :             :       /* If the statement has a label,  make sure it is transferred to
     694                 :             :          the newly created block.  */
     695                 :             : 
     696                 :        1589 :       if ((*current_code)->here)
     697                 :             :         {
     698                 :           6 :           inserted_block->here = (*current_code)->here;
     699                 :           6 :           (*current_code)->here = NULL;
     700                 :             :         }
     701                 :             : 
     702                 :        1589 :       inserted_block->next = (*current_code)->next;
     703                 :        1589 :       changed_statement = &(inserted_block->ext.block.ns->code);
     704                 :        1589 :       (*current_code)->next = NULL;
     705                 :             :       /* Insert the BLOCK at the right position.  */
     706                 :        1589 :       *current_code = inserted_block;
     707                 :        1589 :       ns->parent = current_ns;
     708                 :             :     }
     709                 :             :   else
     710                 :         293 :     ns = inserted_block->ext.block.ns;
     711                 :             : 
     712                 :        1882 :   return ns;
     713                 :             : }
     714                 :             : 
     715                 :             : 
     716                 :             : /* Insert a call to the intrinsic len. Use a different name for
     717                 :             :    the symbol tree so we don't run into trouble when the user has
     718                 :             :    renamed len for some reason.  */
     719                 :             : 
     720                 :             : static gfc_expr*
     721                 :          12 : get_len_call (gfc_expr *str)
     722                 :             : {
     723                 :          12 :   gfc_expr *fcn;
     724                 :          12 :   gfc_actual_arglist *actual_arglist;
     725                 :             : 
     726                 :          12 :   fcn = gfc_get_expr ();
     727                 :          12 :   fcn->expr_type = EXPR_FUNCTION;
     728                 :          12 :   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
     729                 :          12 :   actual_arglist = gfc_get_actual_arglist ();
     730                 :          12 :   actual_arglist->expr = str;
     731                 :             : 
     732                 :          12 :   fcn->value.function.actual = actual_arglist;
     733                 :          12 :   fcn->where = str->where;
     734                 :          12 :   fcn->ts.type = BT_INTEGER;
     735                 :          12 :   fcn->ts.kind = gfc_charlen_int_kind;
     736                 :             : 
     737                 :          12 :   gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
     738                 :          12 :   fcn->symtree->n.sym->ts = fcn->ts;
     739                 :          12 :   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
     740                 :          12 :   fcn->symtree->n.sym->attr.function = 1;
     741                 :          12 :   fcn->symtree->n.sym->attr.elemental = 1;
     742                 :          12 :   fcn->symtree->n.sym->attr.referenced = 1;
     743                 :          12 :   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
     744                 :          12 :   gfc_commit_symbol (fcn->symtree->n.sym);
     745                 :             : 
     746                 :          12 :   return fcn;
     747                 :             : }
     748                 :             : 
     749                 :             : 
     750                 :             : /* Returns a new expression (a variable) to be used in place of the old one,
     751                 :             :    with an optional assignment statement before the current statement to set
     752                 :             :    the value of the variable. Creates a new BLOCK for the statement if that
     753                 :             :    hasn't already been done and puts the statement, plus the newly created
     754                 :             :    variables, in that block.  Special cases: If the expression is constant or
     755                 :             :    a temporary which has already been created, just copy it.  */
     756                 :             : 
     757                 :             : static gfc_expr*
     758                 :        1165 : create_var (gfc_expr * e, const char *vname)
     759                 :             : {
     760                 :        1165 :   char name[GFC_MAX_SYMBOL_LEN +1];
     761                 :        1165 :   gfc_symtree *symtree;
     762                 :        1165 :   gfc_symbol *symbol;
     763                 :        1165 :   gfc_expr *result;
     764                 :        1165 :   gfc_code *n;
     765                 :        1165 :   gfc_namespace *ns;
     766                 :        1165 :   int i;
     767                 :        1165 :   bool deferred;
     768                 :             : 
     769                 :        1268 :   if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
     770                 :          23 :     return gfc_copy_expr (e);
     771                 :             : 
     772                 :             :   /* Creation of an array of unknown size requires realloc on assignment.
     773                 :             :      If that is not possible, just return NULL.  */
     774                 :        1142 :   if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
     775                 :             :     return NULL;
     776                 :             : 
     777                 :        1141 :   ns = insert_block ();
     778                 :             : 
     779                 :        1141 :   if (vname)
     780                 :        1141 :     snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
     781                 :             :   else
     782                 :           0 :     snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
     783                 :             : 
     784                 :        1141 :   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
     785                 :           0 :     gcc_unreachable ();
     786                 :             : 
     787                 :        1141 :   symbol = symtree->n.sym;
     788                 :        1141 :   symbol->ts = e->ts;
     789                 :             : 
     790                 :        1141 :   if (e->rank > 0)
     791                 :             :     {
     792                 :         408 :       symbol->as = gfc_get_array_spec ();
     793                 :         408 :       symbol->as->rank = e->rank;
     794                 :             : 
     795                 :         408 :       if (e->shape == NULL)
     796                 :             :         {
     797                 :             :           /* We don't know the shape at compile time, so we use an
     798                 :             :              allocatable.  */
     799                 :         180 :           symbol->as->type = AS_DEFERRED;
     800                 :         180 :           symbol->attr.allocatable = 1;
     801                 :             :         }
     802                 :             :       else
     803                 :             :         {
     804                 :         228 :           symbol->as->type = AS_EXPLICIT;
     805                 :             :           /* Copy the shape.  */
     806                 :         618 :           for (i=0; i<e->rank; i++)
     807                 :             :             {
     808                 :         390 :               gfc_expr *p, *q;
     809                 :             : 
     810                 :         390 :               p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
     811                 :             :                                          &(e->where));
     812                 :         390 :               mpz_set_si (p->value.integer, 1);
     813                 :         390 :               symbol->as->lower[i] = p;
     814                 :             : 
     815                 :         390 :               q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
     816                 :             :                                          &(e->where));
     817                 :         390 :               mpz_set (q->value.integer, e->shape[i]);
     818                 :         390 :               symbol->as->upper[i] = q;
     819                 :             :             }
     820                 :             :         }
     821                 :             :     }
     822                 :             : 
     823                 :        1141 :   deferred = 0;
     824                 :        1141 :   if (e->ts.type == BT_CHARACTER)
     825                 :             :     {
     826                 :          91 :       gfc_expr *length;
     827                 :             : 
     828                 :          91 :       symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
     829                 :          91 :       length = constant_string_length (e);
     830                 :          91 :       if (length)
     831                 :          17 :         symbol->ts.u.cl->length = length;
     832                 :          74 :       else if (e->expr_type == EXPR_VARIABLE
     833                 :          36 :                && e->symtree->n.sym->ts.type == BT_CHARACTER
     834                 :          30 :                && e->ts.u.cl->length)
     835                 :          12 :         symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
     836                 :             :       else
     837                 :             :         {
     838                 :          62 :           symbol->attr.allocatable = 1;
     839                 :          62 :           symbol->ts.u.cl->length = NULL;
     840                 :          62 :           symbol->ts.deferred = 1;
     841                 :          62 :           deferred = 1;
     842                 :             :         }
     843                 :             :     }
     844                 :             : 
     845                 :        1141 :   symbol->attr.flavor = FL_VARIABLE;
     846                 :        1141 :   symbol->attr.referenced = 1;
     847                 :        1141 :   symbol->attr.dimension = e->rank > 0;
     848                 :        1141 :   symbol->attr.fe_temp = 1;
     849                 :        1141 :   gfc_commit_symbol (symbol);
     850                 :             : 
     851                 :        1141 :   result = gfc_get_expr ();
     852                 :        1141 :   result->expr_type = EXPR_VARIABLE;
     853                 :        1141 :   result->ts = symbol->ts;
     854                 :        1141 :   result->ts.deferred = deferred;
     855                 :        1141 :   result->rank = e->rank;
     856                 :        1141 :   result->shape = gfc_copy_shape (e->shape, e->rank);
     857                 :        1141 :   result->symtree = symtree;
     858                 :        1141 :   result->where = e->where;
     859                 :        1141 :   if (e->rank > 0)
     860                 :             :     {
     861                 :         408 :       result->ref = gfc_get_ref ();
     862                 :         408 :       result->ref->type = REF_ARRAY;
     863                 :         408 :       result->ref->u.ar.type = AR_FULL;
     864                 :         408 :       result->ref->u.ar.where = e->where;
     865                 :         408 :       result->ref->u.ar.dimen = e->rank;
     866                 :         816 :       result->ref->u.ar.as = symbol->ts.type == BT_CLASS
     867                 :         408 :                              ? CLASS_DATA (symbol)->as : symbol->as;
     868                 :         408 :       if (warn_array_temporaries)
     869                 :          15 :         gfc_warning (OPT_Warray_temporaries,
     870                 :             :                      "Creating array temporary at %L", &(e->where));
     871                 :             :     }
     872                 :             : 
     873                 :             :   /* Generate the new assignment.  */
     874                 :        1141 :   n = XCNEW (gfc_code);
     875                 :        1141 :   n->op = EXEC_ASSIGN;
     876                 :        1141 :   n->loc = (*current_code)->loc;
     877                 :        1141 :   n->next = *changed_statement;
     878                 :        1141 :   n->expr1 = gfc_copy_expr (result);
     879                 :        1141 :   n->expr2 = e;
     880                 :        1141 :   *changed_statement = n;
     881                 :        1141 :   n_vars ++;
     882                 :             : 
     883                 :        1141 :   return result;
     884                 :             : }
     885                 :             : 
     886                 :             : /* Warn about function elimination.  */
     887                 :             : 
     888                 :             : static void
     889                 :           6 : do_warn_function_elimination (gfc_expr *e)
     890                 :             : {
     891                 :           6 :   const char *name;
     892                 :           6 :   if (e->expr_type == EXPR_FUNCTION
     893                 :           6 :       && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e))
     894                 :             :    {
     895                 :           2 :       if (name)
     896                 :           2 :           gfc_warning (OPT_Wfunction_elimination,
     897                 :             :                       "Removing call to impure function %qs at %L", name,
     898                 :             :                       &(e->where));
     899                 :             :       else
     900                 :           0 :           gfc_warning (OPT_Wfunction_elimination,
     901                 :             :                       "Removing call to impure function at %L",
     902                 :             :                       &(e->where));
     903                 :             :    }
     904                 :           6 : }
     905                 :             : 
     906                 :             : 
     907                 :             : /* Callback function for the code walker for doing common function
     908                 :             :    elimination.  This builds up the list of functions in the expression
     909                 :             :    and goes through them to detect duplicates, which it then replaces
     910                 :             :    by variables.  */
     911                 :             : 
     912                 :             : static int
     913                 :     1077010 : cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
     914                 :             :           void *data ATTRIBUTE_UNUSED)
     915                 :             : {
     916                 :     1077010 :   int i,j;
     917                 :     1077010 :   gfc_expr *newvar;
     918                 :     1077010 :   gfc_expr **ei, **ej;
     919                 :             : 
     920                 :             :   /* Don't do this optimization within OMP workshare/atomic or ASSOC lists.  */
     921                 :             : 
     922                 :     1077010 :   if (in_omp_workshare || in_omp_atomic || in_assoc_list)
     923                 :             :     {
     924                 :       10335 :       *walk_subtrees = 0;
     925                 :       10335 :       return 0;
     926                 :             :     }
     927                 :             : 
     928                 :     1066675 :   expr_array.release ();
     929                 :             : 
     930                 :     1066675 :   gfc_expr_walker (e, cfe_register_funcs, NULL);
     931                 :             : 
     932                 :             :   /* Walk through all the functions.  */
     933                 :             : 
     934                 :     2152614 :   FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
     935                 :             :     {
     936                 :             :       /* Skip if the function has been replaced by a variable already.  */
     937                 :       19264 :       if ((*ei)->expr_type == EXPR_VARIABLE)
     938                 :           0 :         continue;
     939                 :             : 
     940                 :             :       newvar = NULL;
     941                 :       44647 :       for (j=0; j<i; j++)
     942                 :             :         {
     943                 :       25383 :           ej = expr_array[j];
     944                 :       25383 :           if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
     945                 :             :             {
     946                 :         444 :               if (newvar == NULL)
     947                 :         444 :                 newvar = create_var (*ei, "fcn");
     948                 :             : 
     949                 :         444 :               if (warn_function_elimination)
     950                 :           6 :                 do_warn_function_elimination (*ej);
     951                 :             : 
     952                 :         444 :               free (*ej);
     953                 :         444 :               *ej = gfc_copy_expr (newvar);
     954                 :             :             }
     955                 :             :         }
     956                 :       19264 :       if (newvar)
     957                 :         444 :         *ei = newvar;
     958                 :             :     }
     959                 :             : 
     960                 :             :   /* We did all the necessary walking in this function.  */
     961                 :     1066675 :   *walk_subtrees = 0;
     962                 :     1066675 :   return 0;
     963                 :             : }
     964                 :             : 
     965                 :             : /* Callback function for common function elimination, called from
     966                 :             :    gfc_code_walker.  This keeps track of the current code, in order
     967                 :             :    to insert statements as needed.  */
     968                 :             : 
     969                 :             : static int
     970                 :      795039 : cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
     971                 :             : {
     972                 :      795039 :   current_code = c;
     973                 :      795039 :   inserted_block = NULL;
     974                 :      795039 :   changed_statement = NULL;
     975                 :             : 
     976                 :             :   /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
     977                 :             :      and allocation on assignment are prohibited inside WHERE, and finally
     978                 :             :      masking an expression would lead to wrong-code when replacing
     979                 :             : 
     980                 :             :      WHERE (a>0)
     981                 :             :        b = sum(foo(a) + foo(a))
     982                 :             :      END WHERE
     983                 :             : 
     984                 :             :      with
     985                 :             : 
     986                 :             :      WHERE (a > 0)
     987                 :             :        tmp = foo(a)
     988                 :             :        b = sum(tmp + tmp)
     989                 :             :      END WHERE
     990                 :             : */
     991                 :             : 
     992                 :      795039 :   if ((*c)->op == EXEC_WHERE)
     993                 :             :     {
     994                 :         349 :       *walk_subtrees = 0;
     995                 :         349 :       return 0;
     996                 :             :     }
     997                 :             : 
     998                 :             : 
     999                 :             :   return 0;
    1000                 :             : }
    1001                 :             : 
    1002                 :             : /* Dummy function for expression call back, for use when we
    1003                 :             :    really don't want to do any walking.  */
    1004                 :             : 
    1005                 :             : static int
    1006                 :     7711044 : dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
    1007                 :             :                      void *data ATTRIBUTE_UNUSED)
    1008                 :             : {
    1009                 :     7711044 :   *walk_subtrees = 0;
    1010                 :     7711044 :   return 0;
    1011                 :             : }
    1012                 :             : 
    1013                 :             : /* Dummy function for code callback, for use when we really
    1014                 :             :    don't want to do anything.  */
    1015                 :             : int
    1016                 :      958922 : gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
    1017                 :             :                          int *walk_subtrees ATTRIBUTE_UNUSED,
    1018                 :             :                          void *data ATTRIBUTE_UNUSED)
    1019                 :             : {
    1020                 :      958922 :   return 0;
    1021                 :             : }
    1022                 :             : 
    1023                 :             : /* Code callback function for converting
    1024                 :             :    do while(a)
    1025                 :             :    end do
    1026                 :             :    into the equivalent
    1027                 :             :    do
    1028                 :             :      if (.not. a) exit
    1029                 :             :    end do
    1030                 :             :    This is because common function elimination would otherwise place the
    1031                 :             :    temporary variables outside the loop.  */
    1032                 :             : 
    1033                 :             : static int
    1034                 :      794012 : convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    1035                 :             :                   void *data ATTRIBUTE_UNUSED)
    1036                 :             : {
    1037                 :      794012 :   gfc_code *co = *c;
    1038                 :      794012 :   gfc_code *c_if1, *c_if2, *c_exit;
    1039                 :      794012 :   gfc_code *loopblock;
    1040                 :      794012 :   gfc_expr *e_not, *e_cond;
    1041                 :             : 
    1042                 :      794012 :   if (co->op != EXEC_DO_WHILE)
    1043                 :             :     return 0;
    1044                 :             : 
    1045                 :         422 :   if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
    1046                 :             :     return 0;
    1047                 :             : 
    1048                 :         209 :   e_cond = co->expr1;
    1049                 :             : 
    1050                 :             :   /* Generate the condition of the if statement, which is .not. the original
    1051                 :             :      statement.  */
    1052                 :         209 :   e_not = gfc_get_expr ();
    1053                 :         209 :   e_not->ts = e_cond->ts;
    1054                 :         209 :   e_not->where = e_cond->where;
    1055                 :         209 :   e_not->expr_type = EXPR_OP;
    1056                 :         209 :   e_not->value.op.op = INTRINSIC_NOT;
    1057                 :         209 :   e_not->value.op.op1 = e_cond;
    1058                 :             : 
    1059                 :             :   /* Generate the EXIT statement.  */
    1060                 :         209 :   c_exit = XCNEW (gfc_code);
    1061                 :         209 :   c_exit->op = EXEC_EXIT;
    1062                 :         209 :   c_exit->ext.which_construct = co;
    1063                 :         209 :   c_exit->loc = co->loc;
    1064                 :             : 
    1065                 :             :   /* Generate the IF statement.  */
    1066                 :         209 :   c_if2 = XCNEW (gfc_code);
    1067                 :         209 :   c_if2->op = EXEC_IF;
    1068                 :         209 :   c_if2->expr1 = e_not;
    1069                 :         209 :   c_if2->next = c_exit;
    1070                 :         209 :   c_if2->loc = co->loc;
    1071                 :             : 
    1072                 :             :   /* ... plus the one to chain it to.  */
    1073                 :         209 :   c_if1 = XCNEW (gfc_code);
    1074                 :         209 :   c_if1->op = EXEC_IF;
    1075                 :         209 :   c_if1->block = c_if2;
    1076                 :         209 :   c_if1->loc = co->loc;
    1077                 :             : 
    1078                 :             :   /* Make the DO WHILE loop into a DO block by replacing the condition
    1079                 :             :      with a true constant.  */
    1080                 :         209 :   co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
    1081                 :             : 
    1082                 :             :   /* Hang the generated if statement into the loop body.  */
    1083                 :             : 
    1084                 :         209 :   loopblock = co->block->next;
    1085                 :         209 :   co->block->next = c_if1;
    1086                 :         209 :   c_if1->next = loopblock;
    1087                 :             : 
    1088                 :         209 :   return 0;
    1089                 :             : }
    1090                 :             : 
    1091                 :             : /* Code callback function for converting
    1092                 :             :    if (a) then
    1093                 :             :    ...
    1094                 :             :    else if (b) then
    1095                 :             :    end if
    1096                 :             : 
    1097                 :             :    into
    1098                 :             :    if (a) then
    1099                 :             :    else
    1100                 :             :      if (b) then
    1101                 :             :      end if
    1102                 :             :    end if
    1103                 :             : 
    1104                 :             :    because otherwise common function elimination would place the BLOCKs
    1105                 :             :    into the wrong place.  */
    1106                 :             : 
    1107                 :             : static int
    1108                 :      795715 : convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    1109                 :             :                 void *data ATTRIBUTE_UNUSED)
    1110                 :             : {
    1111                 :      795715 :   gfc_code *co = *c;
    1112                 :      795715 :   gfc_code *c_if1, *c_if2, *else_stmt;
    1113                 :             : 
    1114                 :      795715 :   if (co->op != EXEC_IF)
    1115                 :             :     return 0;
    1116                 :             : 
    1117                 :             :   /* This loop starts out with the first ELSE statement.  */
    1118                 :      169733 :   else_stmt = co->block->block;
    1119                 :             : 
    1120                 :      171436 :   while (else_stmt != NULL)
    1121                 :             :     {
    1122                 :        6832 :       gfc_code *next_else;
    1123                 :             : 
    1124                 :             :       /* If there is no condition, we're done.  */
    1125                 :        6832 :       if (else_stmt->expr1 == NULL)
    1126                 :             :         break;
    1127                 :             : 
    1128                 :        1703 :       next_else = else_stmt->block;
    1129                 :             : 
    1130                 :             :       /* Generate the new IF statement.  */
    1131                 :        1703 :       c_if2 = XCNEW (gfc_code);
    1132                 :        1703 :       c_if2->op = EXEC_IF;
    1133                 :        1703 :       c_if2->expr1 = else_stmt->expr1;
    1134                 :        1703 :       c_if2->next = else_stmt->next;
    1135                 :        1703 :       c_if2->loc = else_stmt->loc;
    1136                 :        1703 :       c_if2->block = next_else;
    1137                 :             : 
    1138                 :             :       /* ... plus the one to chain it to.  */
    1139                 :        1703 :       c_if1 = XCNEW (gfc_code);
    1140                 :        1703 :       c_if1->op = EXEC_IF;
    1141                 :        1703 :       c_if1->block = c_if2;
    1142                 :        1703 :       c_if1->loc = else_stmt->loc;
    1143                 :             : 
    1144                 :             :       /* Insert the new IF after the ELSE.  */
    1145                 :        1703 :       else_stmt->expr1 = NULL;
    1146                 :        1703 :       else_stmt->next = c_if1;
    1147                 :        1703 :       else_stmt->block = NULL;
    1148                 :             : 
    1149                 :        1703 :       else_stmt = next_else;
    1150                 :             :     }
    1151                 :             :   /*  Don't walk subtrees.  */
    1152                 :             :   return 0;
    1153                 :             : }
    1154                 :             : 
    1155                 :             : /* Callback function to var_in_expr - return true if expr1 and
    1156                 :             :    expr2 are identical variables. */
    1157                 :             : static int
    1158                 :          23 : var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    1159                 :             :                       void *data)
    1160                 :             : {
    1161                 :          23 :   gfc_expr *expr1 = (gfc_expr *) data;
    1162                 :          23 :   gfc_expr *expr2 = *e;
    1163                 :             : 
    1164                 :          23 :   if (expr2->expr_type != EXPR_VARIABLE)
    1165                 :             :     return 0;
    1166                 :             : 
    1167                 :           3 :   return expr1->symtree->n.sym == expr2->symtree->n.sym;
    1168                 :             : }
    1169                 :             : 
    1170                 :             : /* Return true if expr1 is found in expr2. */
    1171                 :             : 
    1172                 :             : static bool
    1173                 :          22 : var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
    1174                 :             : {
    1175                 :          22 :   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
    1176                 :             : 
    1177                 :          22 :   return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
    1178                 :             : }
    1179                 :             : 
    1180                 :             : struct do_stack
    1181                 :             : {
    1182                 :             :   struct do_stack *prev;
    1183                 :             :   gfc_iterator *iter;
    1184                 :             :   gfc_code *code;
    1185                 :             : } *stack_top;
    1186                 :             : 
    1187                 :             : /* Recursively traverse the block of a WRITE or READ statement, and maybe
    1188                 :             :    optimize by replacing do loops with their analog array slices.  For
    1189                 :             :    example:
    1190                 :             : 
    1191                 :             :      write (*,*) (a(i), i=1,4)
    1192                 :             : 
    1193                 :             :    is replaced with
    1194                 :             : 
    1195                 :             :      write (*,*) a(1:4:1) .  */
    1196                 :             : 
    1197                 :             : static bool
    1198                 :         506 : traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
    1199                 :             : {
    1200                 :         506 :   gfc_code *curr;
    1201                 :         506 :   gfc_expr *new_e, *expr, *start;
    1202                 :         506 :   gfc_ref *ref;
    1203                 :         506 :   struct do_stack ds_push;
    1204                 :         506 :   int i, future_rank = 0;
    1205                 :         506 :   gfc_iterator *iters[GFC_MAX_DIMENSIONS];
    1206                 :         506 :   gfc_expr *e;
    1207                 :             : 
    1208                 :             :   /* Find the first transfer/do statement.  */
    1209                 :         506 :   for (curr = code; curr; curr = curr->next)
    1210                 :             :     {
    1211                 :         506 :       if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER)
    1212                 :             :         break;
    1213                 :             :     }
    1214                 :             : 
    1215                 :             :   /* Ensure it is the only transfer/do statement because cases like
    1216                 :             : 
    1217                 :             :      write (*,*) (a(i), b(i), i=1,4)
    1218                 :             : 
    1219                 :             :      cannot be optimized.  */
    1220                 :             : 
    1221                 :         506 :   if (!curr || curr->next)
    1222                 :             :     return false;
    1223                 :             : 
    1224                 :         473 :   if (curr->op == EXEC_DO)
    1225                 :             :     {
    1226                 :          31 :       if (curr->ext.iterator->var->ref)
    1227                 :             :         return false;
    1228                 :          31 :       ds_push.prev = stack_top;
    1229                 :          31 :       ds_push.iter = curr->ext.iterator;
    1230                 :          31 :       ds_push.code = curr;
    1231                 :          31 :       stack_top = &ds_push;
    1232                 :          31 :       if (traverse_io_block (curr->block->next, has_reached, prev))
    1233                 :             :         {
    1234                 :          23 :           if (curr != stack_top->code && !*has_reached)
    1235                 :             :             {
    1236                 :          23 :               curr->block->next = NULL;
    1237                 :          23 :               gfc_free_statements (curr);
    1238                 :             :             }
    1239                 :             :           else
    1240                 :           0 :             *has_reached = true;
    1241                 :          23 :           return true;
    1242                 :             :         }
    1243                 :             :       return false;
    1244                 :             :     }
    1245                 :             : 
    1246                 :         442 :   gcc_assert (curr->op == EXEC_TRANSFER);
    1247                 :             : 
    1248                 :         442 :   e = curr->expr1;
    1249                 :         442 :   ref = e->ref;
    1250                 :         442 :   if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next)
    1251                 :             :     return false;
    1252                 :             : 
    1253                 :             :   /* Find the iterators belonging to each variable and check conditions.  */
    1254                 :         800 :   for (i = 0; i < ref->u.ar.dimen; i++)
    1255                 :             :     {
    1256                 :         463 :       if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
    1257                 :         463 :           || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
    1258                 :             :         return false;
    1259                 :             : 
    1260                 :         463 :       start = ref->u.ar.start[i];
    1261                 :         463 :       gfc_simplify_expr (start, 0);
    1262                 :         463 :       switch (start->expr_type)
    1263                 :             :         {
    1264                 :         422 :         case EXPR_VARIABLE:
    1265                 :             : 
    1266                 :             :           /* write (*,*) (a(i), i=a%b,1) not handled yet.  */
    1267                 :         422 :           if (start->ref)
    1268                 :             :             return false;
    1269                 :             : 
    1270                 :             :           /*  Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4).  */
    1271                 :         422 :           if (!stack_top || !stack_top->iter
    1272                 :         410 :               || stack_top->iter->var->symtree != start->symtree)
    1273                 :             :             {
    1274                 :             :               /* Check for (a(i,i), i=1,3).  */
    1275                 :             :               int j;
    1276                 :             : 
    1277                 :          77 :               for (j=0; j<i; j++)
    1278                 :          12 :                 if (iters[j] && iters[j]->var->symtree == start->symtree)
    1279                 :             :                   return false;
    1280                 :             : 
    1281                 :          65 :               iters[i] = NULL;
    1282                 :          65 :             }
    1283                 :             :           else
    1284                 :             :             {
    1285                 :         345 :               iters[i] = stack_top->iter;
    1286                 :         345 :               stack_top = stack_top->prev;
    1287                 :         345 :               future_rank++;
    1288                 :             :             }
    1289                 :             :           break;
    1290                 :          12 :         case EXPR_CONSTANT:
    1291                 :          12 :           iters[i] = NULL;
    1292                 :          12 :           break;
    1293                 :          29 :         case EXPR_OP:
    1294                 :          29 :           switch (start->value.op.op)
    1295                 :             :             {
    1296                 :          29 :             case INTRINSIC_PLUS:
    1297                 :          29 :             case INTRINSIC_TIMES:
    1298                 :          29 :               if (start->value.op.op1->expr_type != EXPR_VARIABLE)
    1299                 :           0 :                 std::swap (start->value.op.op1, start->value.op.op2);
    1300                 :          29 :               gcc_fallthrough ();
    1301                 :          29 :             case INTRINSIC_MINUS:
    1302                 :          29 :               if (start->value.op.op1->expr_type!= EXPR_VARIABLE
    1303                 :          29 :                   || start->value.op.op2->expr_type != EXPR_CONSTANT
    1304                 :          24 :                   || start->value.op.op1->ref)
    1305                 :             :                 return false;
    1306                 :          24 :               if (!stack_top || !stack_top->iter
    1307                 :          18 :                   || stack_top->iter->var->symtree
    1308                 :          18 :                   != start->value.op.op1->symtree)
    1309                 :             :                 return false;
    1310                 :          18 :               iters[i] = stack_top->iter;
    1311                 :          18 :               stack_top = stack_top->prev;
    1312                 :          18 :               break;
    1313                 :             :             default:
    1314                 :             :               return false;
    1315                 :             :             }
    1316                 :          18 :           future_rank++;
    1317                 :          18 :           break;
    1318                 :             :         default:
    1319                 :             :           return false;
    1320                 :             :         }
    1321                 :             :     }
    1322                 :             : 
    1323                 :             :   /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
    1324                 :         414 :   for (int i = 1; i < ref->u.ar.dimen; i++)
    1325                 :             :     {
    1326                 :          79 :       if (iters[i])
    1327                 :             :         {
    1328                 :          73 :           gfc_expr *var = iters[i]->var;
    1329                 :         144 :           for (int j = i - 1; j < i; j++)
    1330                 :             :             {
    1331                 :          73 :               if (iters[j]
    1332                 :          73 :                   && (var_in_expr (var, iters[j]->start)
    1333                 :           8 :                       || var_in_expr (var, iters[j]->end)
    1334                 :           6 :                       || var_in_expr (var, iters[j]->step)))
    1335                 :           2 :                   return false;
    1336                 :             :             }
    1337                 :             :         }
    1338                 :             :     }
    1339                 :             : 
    1340                 :             :   /* Create new expr.  */
    1341                 :         335 :   new_e = gfc_copy_expr (curr->expr1);
    1342                 :         335 :   new_e->expr_type = EXPR_VARIABLE;
    1343                 :         335 :   new_e->rank = future_rank;
    1344                 :         335 :   if (curr->expr1->shape)
    1345                 :           0 :     new_e->shape = gfc_get_shape (new_e->rank);
    1346                 :             : 
    1347                 :             :   /* Assign new starts, ends and strides if necessary.  */
    1348                 :         747 :   for (i = 0; i < ref->u.ar.dimen; i++)
    1349                 :             :     {
    1350                 :         412 :       if (!iters[i])
    1351                 :          77 :         continue;
    1352                 :         335 :       start = ref->u.ar.start[i];
    1353                 :         335 :       switch (start->expr_type)
    1354                 :             :         {
    1355                 :           0 :         case EXPR_CONSTANT:
    1356                 :           0 :           gfc_internal_error ("bad expression");
    1357                 :         323 :           break;
    1358                 :         323 :         case EXPR_VARIABLE:
    1359                 :         323 :           new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
    1360                 :         323 :           new_e->ref->u.ar.type = AR_SECTION;
    1361                 :         323 :           gfc_free_expr (new_e->ref->u.ar.start[i]);
    1362                 :         323 :           new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start);
    1363                 :         323 :           new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end);
    1364                 :         323 :           new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
    1365                 :         323 :           break;
    1366                 :          12 :         case EXPR_OP:
    1367                 :          12 :           new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE;
    1368                 :          12 :           new_e->ref->u.ar.type = AR_SECTION;
    1369                 :          12 :           gfc_free_expr (new_e->ref->u.ar.start[i]);
    1370                 :          12 :           expr = gfc_copy_expr (start);
    1371                 :          12 :           expr->value.op.op1 = gfc_copy_expr (iters[i]->start);
    1372                 :          12 :           new_e->ref->u.ar.start[i] = expr;
    1373                 :          12 :           gfc_simplify_expr (new_e->ref->u.ar.start[i], 0);
    1374                 :          12 :           expr = gfc_copy_expr (start);
    1375                 :          12 :           expr->value.op.op1 = gfc_copy_expr (iters[i]->end);
    1376                 :          12 :           new_e->ref->u.ar.end[i] = expr;
    1377                 :          12 :           gfc_simplify_expr (new_e->ref->u.ar.end[i], 0);
    1378                 :          12 :           switch (start->value.op.op)
    1379                 :             :             {
    1380                 :           6 :             case INTRINSIC_MINUS:
    1381                 :           6 :             case INTRINSIC_PLUS:
    1382                 :           6 :               new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step);
    1383                 :           6 :               break;
    1384                 :           6 :             case INTRINSIC_TIMES:
    1385                 :           6 :               expr = gfc_copy_expr (start);
    1386                 :           6 :               expr->value.op.op1 = gfc_copy_expr (iters[i]->step);
    1387                 :           6 :               new_e->ref->u.ar.stride[i] = expr;
    1388                 :           6 :               gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0);
    1389                 :           6 :               break;
    1390                 :           0 :             default:
    1391                 :           0 :               gfc_internal_error ("bad op");
    1392                 :             :             }
    1393                 :             :           break;
    1394                 :           0 :         default:
    1395                 :           0 :           gfc_internal_error ("bad expression");
    1396                 :             :         }
    1397                 :             :     }
    1398                 :         335 :   curr->expr1 = new_e;
    1399                 :             : 
    1400                 :             :   /* Insert modified statement. Check whether the statement needs to be
    1401                 :             :      inserted at the lowest level.  */
    1402                 :         335 :   if (!stack_top->iter)
    1403                 :             :     {
    1404                 :         312 :       if (prev)
    1405                 :             :         {
    1406                 :         312 :           curr->next = prev->next->next;
    1407                 :         312 :           prev->next = curr;
    1408                 :             :         }
    1409                 :             :       else
    1410                 :             :         {
    1411                 :           0 :           curr->next = stack_top->code->block->next->next->next;
    1412                 :           0 :           stack_top->code->block->next = curr;
    1413                 :             :         }
    1414                 :             :     }
    1415                 :             :   else
    1416                 :          23 :     stack_top->code->block->next = curr;
    1417                 :             :   return true;
    1418                 :             : }
    1419                 :             : 
    1420                 :             : /* Function for the gfc_code_walker.  If code is a READ or WRITE statement, it
    1421                 :             :    tries to optimize its block.  */
    1422                 :             : 
    1423                 :             : static int
    1424                 :      733543 : simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
    1425                 :             :                      void *data ATTRIBUTE_UNUSED)
    1426                 :             : {
    1427                 :      733543 :   gfc_code **curr, *prev = NULL;
    1428                 :      733543 :   struct do_stack write, first;
    1429                 :      733543 :   bool b = false;
    1430                 :      733543 :   *walk_subtrees = 1;
    1431                 :      733543 :   if (!(*code)->block
    1432                 :      247910 :       || ((*code)->block->op != EXEC_WRITE
    1433                 :      247910 :           && (*code)->block->op != EXEC_READ))
    1434                 :             :     return 0;
    1435                 :             : 
    1436                 :       24370 :   *walk_subtrees = 0;
    1437                 :       24370 :   write.prev = NULL;
    1438                 :       24370 :   write.iter = NULL;
    1439                 :       24370 :   write.code = *code;
    1440                 :             : 
    1441                 :      108533 :   for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
    1442                 :             :     {
    1443                 :       84163 :       if ((*curr)->op == EXEC_DO)
    1444                 :             :         {
    1445                 :         475 :           first.prev = &write;
    1446                 :         475 :           first.iter = (*curr)->ext.iterator;
    1447                 :         475 :           first.code = *curr;
    1448                 :         475 :           stack_top = &first;
    1449                 :         475 :           traverse_io_block ((*curr)->block->next, &b, prev);
    1450                 :         475 :           stack_top = NULL;
    1451                 :             :         }
    1452                 :       84163 :       prev = *curr;
    1453                 :             :     }
    1454                 :             :   return 0;
    1455                 :             : }
    1456                 :             : 
    1457                 :             : /* Optimize a namespace, including all contained namespaces.
    1458                 :             :   flag_frontend_optimize and flag_frontend_loop_interchange are
    1459                 :             :   handled separately.  */
    1460                 :             : 
    1461                 :             : static void
    1462                 :      233188 : optimize_namespace (gfc_namespace *ns)
    1463                 :             : {
    1464                 :      233188 :   gfc_namespace *saved_ns = gfc_current_ns;
    1465                 :      233188 :   current_ns = ns;
    1466                 :      233188 :   gfc_current_ns = ns;
    1467                 :      233188 :   forall_level = 0;
    1468                 :      233188 :   iterator_level = 0;
    1469                 :      233188 :   in_assoc_list = false;
    1470                 :      233188 :   in_omp_workshare = false;
    1471                 :      233188 :   in_omp_atomic = false;
    1472                 :             : 
    1473                 :      233188 :   if (flag_frontend_optimize)
    1474                 :             :     {
    1475                 :      233165 :       gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
    1476                 :      233165 :       gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
    1477                 :      233165 :       gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
    1478                 :      233165 :       gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
    1479                 :      233165 :       gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
    1480                 :      233165 :       if (flag_inline_matmul_limit != 0 || flag_external_blas)
    1481                 :             :         {
    1482                 :      233158 :           bool found;
    1483                 :      233158 :           do
    1484                 :             :             {
    1485                 :      233158 :               found = false;
    1486                 :      233158 :               gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
    1487                 :             :                                (void *) &found);
    1488                 :             :             }
    1489                 :             :           while (found);
    1490                 :             : 
    1491                 :      233070 :           gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
    1492                 :             :                            NULL);
    1493                 :             :         }
    1494                 :             : 
    1495                 :      233165 :       if (flag_external_blas)
    1496                 :          37 :         gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
    1497                 :             :                          NULL);
    1498                 :             : 
    1499                 :      233165 :       if (flag_inline_matmul_limit != 0)
    1500                 :      233069 :         gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
    1501                 :             :                          NULL);
    1502                 :             :     }
    1503                 :             : 
    1504                 :      233188 :   if (flag_frontend_loop_interchange)
    1505                 :      233130 :     gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
    1506                 :             :                      NULL);
    1507                 :             : 
    1508                 :             :   /* BLOCKs are handled in the expression walker below.  */
    1509                 :      265057 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1510                 :             :     {
    1511                 :       31869 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1512                 :       31230 :         optimize_namespace (ns);
    1513                 :             :     }
    1514                 :      233188 :   gfc_current_ns = saved_ns;
    1515                 :      233188 : }
    1516                 :             : 
    1517                 :             : /* Handle dependencies for allocatable strings which potentially redefine
    1518                 :             :    themselves in an assignment.  */
    1519                 :             : 
    1520                 :             : static void
    1521                 :      276588 : realloc_strings (gfc_namespace *ns)
    1522                 :             : {
    1523                 :      276588 :   current_ns = ns;
    1524                 :      276588 :   gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
    1525                 :             : 
    1526                 :      313988 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1527                 :             :     {
    1528                 :       37400 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1529                 :       36583 :         realloc_strings (ns);
    1530                 :             :     }
    1531                 :             : 
    1532                 :      276588 : }
    1533                 :             : 
    1534                 :             : static void
    1535                 :      233108 : optimize_reduction (gfc_namespace *ns)
    1536                 :             : {
    1537                 :      233108 :   current_ns = ns;
    1538                 :      233108 :   gfc_code_walker (&ns->code, gfc_dummy_code_callback,
    1539                 :             :                    callback_reduction, NULL);
    1540                 :             : 
    1541                 :             : /* BLOCKs are handled in the expression walker below.  */
    1542                 :      264968 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1543                 :             :     {
    1544                 :       31860 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1545                 :       31164 :         optimize_reduction (ns);
    1546                 :             :     }
    1547                 :      233108 : }
    1548                 :             : 
    1549                 :             : /* Replace code like
    1550                 :             :    a = matmul(b,c) + d
    1551                 :             :    with
    1552                 :             :    a = matmul(b,c) ;   a = a + d
    1553                 :             :    where the array function is not elemental and not allocatable
    1554                 :             :    and does not depend on the left-hand side.
    1555                 :             : */
    1556                 :             : 
    1557                 :             : static bool
    1558                 :       40034 : optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
    1559                 :             : {
    1560                 :       40034 :   gfc_expr *e;
    1561                 :             : 
    1562                 :       40034 :   if (!*rhs)
    1563                 :             :     return false;
    1564                 :             : 
    1565                 :       40032 :   e = *rhs;
    1566                 :       40032 :   if (e->expr_type == EXPR_OP)
    1567                 :             :     {
    1568                 :        2731 :       switch (e->value.op.op)
    1569                 :             :         {
    1570                 :             :           /* Unary operators and exponentiation: Only look at a single
    1571                 :             :              operand.  */
    1572                 :         282 :         case INTRINSIC_NOT:
    1573                 :         282 :         case INTRINSIC_UPLUS:
    1574                 :         282 :         case INTRINSIC_UMINUS:
    1575                 :         282 :         case INTRINSIC_PARENTHESES:
    1576                 :         282 :         case INTRINSIC_POWER:
    1577                 :         282 :           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
    1578                 :             :             return true;
    1579                 :             :           break;
    1580                 :             : 
    1581                 :             :         case INTRINSIC_CONCAT:
    1582                 :             :           /* Do not do string concatenations.  */
    1583                 :             :           break;
    1584                 :             : 
    1585                 :        2422 :         default:
    1586                 :             :           /* Binary operators.  */
    1587                 :        2422 :           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
    1588                 :             :             return true;
    1589                 :             : 
    1590                 :        2387 :           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
    1591                 :             :             return true;
    1592                 :             : 
    1593                 :             :           break;
    1594                 :             :         }
    1595                 :             :     }
    1596                 :        4524 :   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
    1597                 :         179 :            && ! (e->value.function.esym
    1598                 :             :                  && (e->value.function.esym->attr.elemental
    1599                 :          45 :                      || e->value.function.esym->attr.allocatable
    1600                 :          25 :                      || e->value.function.esym->ts.type != c->expr1->ts.type
    1601                 :          25 :                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
    1602                 :         158 :            && ! (e->value.function.isym
    1603                 :         134 :                  && (e->value.function.isym->elemental
    1604                 :          52 :                      || e->ts.type != c->expr1->ts.type
    1605                 :          52 :                      || e->ts.kind != c->expr1->ts.kind))
    1606                 :       37377 :            && ! gfc_inline_intrinsic_function_p (e))
    1607                 :             :     {
    1608                 :             : 
    1609                 :          74 :       gfc_code *n;
    1610                 :          74 :       gfc_expr *new_expr;
    1611                 :             : 
    1612                 :             :       /* Insert a new assignment statement after the current one.  */
    1613                 :          74 :       n = XCNEW (gfc_code);
    1614                 :          74 :       n->op = EXEC_ASSIGN;
    1615                 :          74 :       n->loc = c->loc;
    1616                 :          74 :       n->next = c->next;
    1617                 :          74 :       c->next = n;
    1618                 :             : 
    1619                 :          74 :       n->expr1 = gfc_copy_expr (c->expr1);
    1620                 :          74 :       n->expr2 = c->expr2;
    1621                 :          74 :       new_expr = gfc_copy_expr (c->expr1);
    1622                 :          74 :       c->expr2 = e;
    1623                 :          74 :       *rhs = new_expr;
    1624                 :             : 
    1625                 :          74 :       return true;
    1626                 :             : 
    1627                 :             :     }
    1628                 :             : 
    1629                 :             :   /* Nothing to optimize.  */
    1630                 :             :   return false;
    1631                 :             : }
    1632                 :             : 
    1633                 :             : /* Remove unneeded TRIMs at the end of expressions.  */
    1634                 :             : 
    1635                 :             : static bool
    1636                 :      313710 : remove_trim (gfc_expr *rhs)
    1637                 :             : {
    1638                 :      313710 :   bool ret;
    1639                 :             : 
    1640                 :      313710 :   ret = false;
    1641                 :      313710 :   if (!rhs)
    1642                 :             :     return ret;
    1643                 :             : 
    1644                 :             :   /* Check for a // b // trim(c).  Looping is probably not
    1645                 :             :      necessary because the parser usually generates
    1646                 :             :      (// (// a b ) trim(c) ) , but better safe than sorry.  */
    1647                 :             : 
    1648                 :      314256 :   while (rhs->expr_type == EXPR_OP
    1649                 :      314256 :          && rhs->value.op.op == INTRINSIC_CONCAT)
    1650                 :         546 :     rhs = rhs->value.op.op2;
    1651                 :             : 
    1652                 :       56381 :   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
    1653                 :      358793 :          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
    1654                 :             :     {
    1655                 :        1083 :       strip_function_call (rhs);
    1656                 :             :       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
    1657                 :        1083 :       remove_trim (rhs);
    1658                 :        1083 :       ret = true;
    1659                 :             :     }
    1660                 :             : 
    1661                 :             :   return ret;
    1662                 :             : }
    1663                 :             : 
    1664                 :             : /* Optimizations for an assignment.  */
    1665                 :             : 
    1666                 :             : static void
    1667                 :      163863 : optimize_assignment (gfc_code * c)
    1668                 :             : {
    1669                 :      163863 :   gfc_expr *lhs, *rhs;
    1670                 :             : 
    1671                 :      163863 :   lhs = c->expr1;
    1672                 :      163863 :   rhs = c->expr2;
    1673                 :             : 
    1674                 :      163863 :   if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
    1675                 :             :     {
    1676                 :             :       /* Optimize  a = trim(b)  to  a = b.  */
    1677                 :       20677 :       remove_trim (rhs);
    1678                 :             : 
    1679                 :             :       /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
    1680                 :       20677 :       if (is_empty_string (rhs))
    1681                 :        1566 :         rhs->value.character.length = 0;
    1682                 :             :     }
    1683                 :             : 
    1684                 :      163863 :   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
    1685                 :       34943 :     optimize_binop_array_assignment (c, &rhs, false);
    1686                 :      163863 : }
    1687                 :             : 
    1688                 :             : 
    1689                 :             : /* Remove an unneeded function call, modifying the expression.
    1690                 :             :    This replaces the function call with the value of its
    1691                 :             :    first argument.  The rest of the argument list is freed.  */
    1692                 :             : 
    1693                 :             : static void
    1694                 :        1470 : strip_function_call (gfc_expr *e)
    1695                 :             : {
    1696                 :        1470 :   gfc_expr *e1;
    1697                 :        1470 :   gfc_actual_arglist *a;
    1698                 :             : 
    1699                 :        1470 :   a = e->value.function.actual;
    1700                 :             : 
    1701                 :             :   /* We should have at least one argument.  */
    1702                 :        1470 :   gcc_assert (a->expr != NULL);
    1703                 :             : 
    1704                 :        1470 :   e1 = a->expr;
    1705                 :             : 
    1706                 :             :   /* Free the remaining arglist, if any.  */
    1707                 :        1470 :   if (a->next)
    1708                 :           0 :     gfc_free_actual_arglist (a->next);
    1709                 :             : 
    1710                 :             :   /* Graft the argument expression onto the original function.  */
    1711                 :        1470 :   *e = *e1;
    1712                 :        1470 :   free (e1);
    1713                 :             : 
    1714                 :        1470 : }
    1715                 :             : 
    1716                 :             : /* Optimization of lexical comparison functions.  */
    1717                 :             : 
    1718                 :             : static bool
    1719                 :     2290803 : optimize_lexical_comparison (gfc_expr *e)
    1720                 :             : {
    1721                 :     2290803 :   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
    1722                 :             :     return false;
    1723                 :             : 
    1724                 :      159893 :   switch (e->value.function.isym->id)
    1725                 :             :     {
    1726                 :          22 :     case GFC_ISYM_LLE:
    1727                 :          22 :       return optimize_comparison (e, INTRINSIC_LE);
    1728                 :             : 
    1729                 :          22 :     case GFC_ISYM_LGE:
    1730                 :          22 :       return optimize_comparison (e, INTRINSIC_GE);
    1731                 :             : 
    1732                 :          37 :     case GFC_ISYM_LGT:
    1733                 :          37 :       return optimize_comparison (e, INTRINSIC_GT);
    1734                 :             : 
    1735                 :          30 :     case GFC_ISYM_LLT:
    1736                 :          30 :       return optimize_comparison (e, INTRINSIC_LT);
    1737                 :             : 
    1738                 :             :     default:
    1739                 :             :       break;
    1740                 :             :     }
    1741                 :             :   return false;
    1742                 :             : }
    1743                 :             : 
    1744                 :             : /* Combine stuff like [a]>b into [a>b], for easier optimization later.  Do not
    1745                 :             :    do CHARACTER because of possible pessimization involving character
    1746                 :             :    lengths.  */
    1747                 :             : 
    1748                 :             : static bool
    1749                 :      234471 : combine_array_constructor (gfc_expr *e)
    1750                 :             : {
    1751                 :             : 
    1752                 :      234471 :   gfc_expr *op1, *op2;
    1753                 :      234471 :   gfc_expr *scalar;
    1754                 :      234471 :   gfc_expr *new_expr;
    1755                 :      234471 :   gfc_constructor *c, *new_c;
    1756                 :      234471 :   gfc_constructor_base oldbase, newbase;
    1757                 :      234471 :   bool scalar_first;
    1758                 :      234471 :   int n_elem;
    1759                 :      234471 :   bool all_const;
    1760                 :             : 
    1761                 :             :   /* Array constructors have rank one.  */
    1762                 :      234471 :   if (e->rank != 1)
    1763                 :             :     return false;
    1764                 :             : 
    1765                 :             :   /* Don't try to combine association lists, this makes no sense
    1766                 :             :      and leads to an ICE.  */
    1767                 :       26561 :   if (in_assoc_list)
    1768                 :             :     return false;
    1769                 :             : 
    1770                 :             :   /* With FORALL, the BLOCKS created by create_var will cause an ICE.  */
    1771                 :       26553 :   if (forall_level > 0)
    1772                 :             :     return false;
    1773                 :             : 
    1774                 :             :   /* Inside an iterator, things can get hairy; we are likely to create
    1775                 :             :      an invalid temporary variable.  */
    1776                 :       26461 :   if (iterator_level > 0)
    1777                 :             :     return false;
    1778                 :             : 
    1779                 :             :   /* WHERE also doesn't work.  */
    1780                 :       26436 :   if (in_where > 0)
    1781                 :             :     return false;
    1782                 :             : 
    1783                 :       25904 :   op1 = e->value.op.op1;
    1784                 :       25904 :   op2 = e->value.op.op2;
    1785                 :             : 
    1786                 :       25904 :   if (!op1 || !op2)
    1787                 :             :     return false;
    1788                 :             : 
    1789                 :       25903 :   if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
    1790                 :             :     scalar_first = false;
    1791                 :       25831 :   else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
    1792                 :             :     {
    1793                 :             :       scalar_first = true;
    1794                 :             :       op1 = e->value.op.op2;
    1795                 :             :       op2 = e->value.op.op1;
    1796                 :             :     }
    1797                 :             :   else
    1798                 :             :     return false;
    1799                 :             : 
    1800                 :         134 :   if (op2->ts.type == BT_CHARACTER)
    1801                 :             :     return false;
    1802                 :             : 
    1803                 :             :   /* This might be an expanded constructor with very many constant values. If
    1804                 :             :      we perform the operation here, we might end up with a long compile time
    1805                 :             :      and actually longer execution time, so a length bound is in order here.
    1806                 :             :      If the constructor constains something which is not a constant, it did
    1807                 :             :      not come from an expansion, so leave it alone.  */
    1808                 :             : 
    1809                 :             : #define CONSTR_LEN_MAX 4
    1810                 :             : 
    1811                 :          98 :   oldbase = op1->value.constructor;
    1812                 :             : 
    1813                 :          98 :   n_elem = 0;
    1814                 :          98 :   all_const = true;
    1815                 :        1348 :   for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
    1816                 :             :     {
    1817                 :        1280 :       if (c->expr->expr_type != EXPR_CONSTANT)
    1818                 :             :         {
    1819                 :             :           all_const = false;
    1820                 :             :           break;
    1821                 :             :         }
    1822                 :        1250 :       n_elem += 1;
    1823                 :             :     }
    1824                 :             : 
    1825                 :          98 :   if (all_const && n_elem > CONSTR_LEN_MAX)
    1826                 :             :     return false;
    1827                 :             : 
    1828                 :             : #undef CONSTR_LEN_MAX
    1829                 :             : 
    1830                 :          82 :   newbase = NULL;
    1831                 :          82 :   e->expr_type = EXPR_ARRAY;
    1832                 :             : 
    1833                 :          82 :   scalar = create_var (gfc_copy_expr (op2), "constr");
    1834                 :             : 
    1835                 :         360 :   for (c = gfc_constructor_first (oldbase); c;
    1836                 :         278 :        c = gfc_constructor_next (c))
    1837                 :             :     {
    1838                 :         278 :       new_expr = gfc_get_expr ();
    1839                 :         278 :       new_expr->ts = e->ts;
    1840                 :         278 :       new_expr->expr_type = EXPR_OP;
    1841                 :         278 :       new_expr->rank = c->expr->rank;
    1842                 :         278 :       new_expr->where = c->expr->where;
    1843                 :         278 :       new_expr->value.op.op = e->value.op.op;
    1844                 :             : 
    1845                 :         278 :       if (scalar_first)
    1846                 :             :         {
    1847                 :         111 :           new_expr->value.op.op1 = gfc_copy_expr (scalar);
    1848                 :         111 :           new_expr->value.op.op2 = gfc_copy_expr (c->expr);
    1849                 :             :         }
    1850                 :             :       else
    1851                 :             :         {
    1852                 :         167 :           new_expr->value.op.op1 = gfc_copy_expr (c->expr);
    1853                 :         167 :           new_expr->value.op.op2 = gfc_copy_expr (scalar);
    1854                 :             :         }
    1855                 :             : 
    1856                 :         278 :       new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
    1857                 :         278 :       new_c->iterator = c->iterator;
    1858                 :         278 :       c->iterator = NULL;
    1859                 :             :     }
    1860                 :             : 
    1861                 :          82 :   gfc_free_expr (op1);
    1862                 :          82 :   gfc_free_expr (op2);
    1863                 :          82 :   gfc_free_expr (scalar);
    1864                 :             : 
    1865                 :          82 :   e->value.constructor = newbase;
    1866                 :          82 :   return true;
    1867                 :             : }
    1868                 :             : 
    1869                 :             : /* Recursive optimization of operators.  */
    1870                 :             : 
    1871                 :             : static bool
    1872                 :      301179 : optimize_op (gfc_expr *e)
    1873                 :             : {
    1874                 :      301179 :   bool changed;
    1875                 :             : 
    1876                 :      301179 :   gfc_intrinsic_op op = e->value.op.op;
    1877                 :             : 
    1878                 :      301179 :   changed = false;
    1879                 :             : 
    1880                 :             :   /* Only use new-style comparisons.  */
    1881                 :      301179 :   switch(op)
    1882                 :             :     {
    1883                 :             :     case INTRINSIC_EQ_OS:
    1884                 :             :       op = INTRINSIC_EQ;
    1885                 :             :       break;
    1886                 :             : 
    1887                 :             :     case INTRINSIC_GE_OS:
    1888                 :             :       op = INTRINSIC_GE;
    1889                 :             :       break;
    1890                 :             : 
    1891                 :             :     case INTRINSIC_LE_OS:
    1892                 :             :       op = INTRINSIC_LE;
    1893                 :             :       break;
    1894                 :             : 
    1895                 :             :     case INTRINSIC_NE_OS:
    1896                 :             :       op = INTRINSIC_NE;
    1897                 :             :       break;
    1898                 :             : 
    1899                 :             :     case INTRINSIC_GT_OS:
    1900                 :             :       op = INTRINSIC_GT;
    1901                 :             :       break;
    1902                 :             : 
    1903                 :             :     case INTRINSIC_LT_OS:
    1904                 :             :       op = INTRINSIC_LT;
    1905                 :             :       break;
    1906                 :             : 
    1907                 :             :     default:
    1908                 :             :       break;
    1909                 :             :     }
    1910                 :             : 
    1911                 :      242620 :   switch (op)
    1912                 :             :     {
    1913                 :      145852 :     case INTRINSIC_EQ:
    1914                 :      145852 :     case INTRINSIC_GE:
    1915                 :      145852 :     case INTRINSIC_LE:
    1916                 :      145852 :     case INTRINSIC_NE:
    1917                 :      145852 :     case INTRINSIC_GT:
    1918                 :      145852 :     case INTRINSIC_LT:
    1919                 :      145852 :       changed = optimize_comparison (e, op);
    1920                 :             : 
    1921                 :      234471 :       gcc_fallthrough ();
    1922                 :             :       /* Look at array constructors.  */
    1923                 :      234471 :     case INTRINSIC_PLUS:
    1924                 :      234471 :     case INTRINSIC_MINUS:
    1925                 :      234471 :     case INTRINSIC_TIMES:
    1926                 :      234471 :     case INTRINSIC_DIVIDE:
    1927                 :      234471 :       return combine_array_constructor (e) || changed;
    1928                 :             : 
    1929                 :             :     default:
    1930                 :             :       break;
    1931                 :             :     }
    1932                 :             : 
    1933                 :             :   return false;
    1934                 :             : }
    1935                 :             : 
    1936                 :             : 
    1937                 :             : /* Return true if a constant string contains only blanks.  */
    1938                 :             : 
    1939                 :             : static bool
    1940                 :       66407 : is_empty_string (gfc_expr *e)
    1941                 :             : {
    1942                 :       66407 :   int i;
    1943                 :             : 
    1944                 :       66407 :   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
    1945                 :             :     return false;
    1946                 :             : 
    1947                 :       42115 :   for (i=0; i < e->value.character.length; i++)
    1948                 :             :     {
    1949                 :       39819 :       if (e->value.character.string[i] != ' ')
    1950                 :             :         return false;
    1951                 :             :     }
    1952                 :             : 
    1953                 :             :   return true;
    1954                 :             : }
    1955                 :             : 
    1956                 :             : 
    1957                 :             : /* Insert a call to the intrinsic len_trim. Use a different name for
    1958                 :             :    the symbol tree so we don't run into trouble when the user has
    1959                 :             :    renamed len_trim for some reason.  */
    1960                 :             : 
    1961                 :             : static gfc_expr*
    1962                 :        1117 : get_len_trim_call (gfc_expr *str, int kind)
    1963                 :             : {
    1964                 :        1117 :   gfc_expr *fcn;
    1965                 :        1117 :   gfc_actual_arglist *actual_arglist, *next;
    1966                 :             : 
    1967                 :        1117 :   fcn = gfc_get_expr ();
    1968                 :        1117 :   fcn->expr_type = EXPR_FUNCTION;
    1969                 :        1117 :   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
    1970                 :        1117 :   actual_arglist = gfc_get_actual_arglist ();
    1971                 :        1117 :   actual_arglist->expr = str;
    1972                 :        1117 :   next = gfc_get_actual_arglist ();
    1973                 :        1117 :   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
    1974                 :        1117 :   actual_arglist->next = next;
    1975                 :             : 
    1976                 :        1117 :   fcn->value.function.actual = actual_arglist;
    1977                 :        1117 :   fcn->where = str->where;
    1978                 :        1117 :   fcn->ts.type = BT_INTEGER;
    1979                 :        1117 :   fcn->ts.kind = gfc_charlen_int_kind;
    1980                 :             : 
    1981                 :        1117 :   gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
    1982                 :        1117 :   fcn->symtree->n.sym->ts = fcn->ts;
    1983                 :        1117 :   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
    1984                 :        1117 :   fcn->symtree->n.sym->attr.function = 1;
    1985                 :        1117 :   fcn->symtree->n.sym->attr.elemental = 1;
    1986                 :        1117 :   fcn->symtree->n.sym->attr.referenced = 1;
    1987                 :        1117 :   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
    1988                 :        1117 :   gfc_commit_symbol (fcn->symtree->n.sym);
    1989                 :             : 
    1990                 :        1117 :   return fcn;
    1991                 :             : }
    1992                 :             : 
    1993                 :             : 
    1994                 :             : /* Optimize expressions for equality.  */
    1995                 :             : 
    1996                 :             : static bool
    1997                 :      145975 : optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
    1998                 :             : {
    1999                 :      145975 :   gfc_expr *op1, *op2;
    2000                 :      145975 :   bool change;
    2001                 :      145975 :   int eq;
    2002                 :      145975 :   bool result;
    2003                 :      145975 :   gfc_actual_arglist *firstarg, *secondarg;
    2004                 :             : 
    2005                 :      145975 :   if (e->expr_type == EXPR_OP)
    2006                 :             :     {
    2007                 :      145864 :       firstarg = NULL;
    2008                 :      145864 :       secondarg = NULL;
    2009                 :      145864 :       op1 = e->value.op.op1;
    2010                 :      145864 :       op2 = e->value.op.op2;
    2011                 :             :     }
    2012                 :         111 :   else if (e->expr_type == EXPR_FUNCTION)
    2013                 :             :     {
    2014                 :             :       /* One of the lexical comparison functions.  */
    2015                 :         111 :       firstarg = e->value.function.actual;
    2016                 :         111 :       secondarg = firstarg->next;
    2017                 :         111 :       op1 = firstarg->expr;
    2018                 :         111 :       op2 = secondarg->expr;
    2019                 :             :     }
    2020                 :             :   else
    2021                 :           0 :     gcc_unreachable ();
    2022                 :             : 
    2023                 :             :   /* Strip off unneeded TRIM calls from string comparisons.  */
    2024                 :             : 
    2025                 :      145975 :   change = remove_trim (op1);
    2026                 :             : 
    2027                 :      145975 :   if (remove_trim (op2))
    2028                 :          70 :     change = true;
    2029                 :             : 
    2030                 :             :   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
    2031                 :             :   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
    2032                 :             :      handles them well). However, there are also cases that need a non-scalar
    2033                 :             :      argument. For example the any intrinsic. See PR 45380.  */
    2034                 :      145975 :   if (e->rank > 0)
    2035                 :             :     return change;
    2036                 :             : 
    2037                 :             :   /* Replace a == '' with len_trim(a) == 0 and a /= '' with
    2038                 :             :      len_trim(a) != 0 */
    2039                 :      120787 :   if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
    2040                 :       23436 :       && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
    2041                 :             :     {
    2042                 :       22865 :       bool empty_op1, empty_op2;
    2043                 :       22865 :       empty_op1 = is_empty_string (op1);
    2044                 :       22865 :       empty_op2 = is_empty_string (op2);
    2045                 :             : 
    2046                 :       22865 :       if (empty_op1 || empty_op2)
    2047                 :             :         {
    2048                 :         730 :           gfc_expr *fcn;
    2049                 :         730 :           gfc_expr *zero;
    2050                 :         730 :           gfc_expr *str;
    2051                 :             : 
    2052                 :             :           /* This can only happen when an error for comparing
    2053                 :             :              characters of different kinds has already been issued.  */
    2054                 :         730 :           if (empty_op1 && empty_op2)
    2055                 :             :             return false;
    2056                 :             : 
    2057                 :         730 :           zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
    2058                 :         730 :           str = empty_op1 ? op2 : op1;
    2059                 :             : 
    2060                 :         730 :           fcn = get_len_trim_call (str, gfc_charlen_int_kind);
    2061                 :             : 
    2062                 :             : 
    2063                 :         730 :           if (empty_op1)
    2064                 :           0 :             gfc_free_expr (op1);
    2065                 :             :           else
    2066                 :         730 :             gfc_free_expr (op2);
    2067                 :             : 
    2068                 :         730 :           op1 = fcn;
    2069                 :         730 :           op2 = zero;
    2070                 :         730 :           e->value.op.op1 = fcn;
    2071                 :         730 :           e->value.op.op2 = zero;
    2072                 :             :         }
    2073                 :             :     }
    2074                 :             : 
    2075                 :             : 
    2076                 :             :   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
    2077                 :             : 
    2078                 :      120787 :   if (flag_finite_math_only
    2079                 :      120642 :       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
    2080                 :      103923 :           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
    2081                 :             :     {
    2082                 :      103049 :       eq = gfc_dep_compare_expr (op1, op2);
    2083                 :      103049 :       if (eq <= -2)
    2084                 :             :         {
    2085                 :             :           /* Replace A // B < A // C with B < C, and A // B < C // B
    2086                 :             :              with A < C.  */
    2087                 :      102798 :           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
    2088                 :       22465 :               && op1->expr_type == EXPR_OP
    2089                 :          55 :               && op1->value.op.op == INTRINSIC_CONCAT
    2090                 :          55 :               && op2->expr_type == EXPR_OP
    2091                 :          24 :               && op2->value.op.op == INTRINSIC_CONCAT)
    2092                 :             :             {
    2093                 :          24 :               gfc_expr *op1_left = op1->value.op.op1;
    2094                 :          24 :               gfc_expr *op2_left = op2->value.op.op1;
    2095                 :          24 :               gfc_expr *op1_right = op1->value.op.op2;
    2096                 :          24 :               gfc_expr *op2_right = op2->value.op.op2;
    2097                 :             : 
    2098                 :          24 :               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
    2099                 :             :                 {
    2100                 :             :                   /* Watch out for 'A ' // x vs. 'A' // x.  */
    2101                 :             : 
    2102                 :          18 :                   if (op1_left->expr_type == EXPR_CONSTANT
    2103                 :          18 :                         && op2_left->expr_type == EXPR_CONSTANT
    2104                 :          18 :                         && op1_left->value.character.length
    2105                 :          18 :                            != op2_left->value.character.length)
    2106                 :             :                     return change;
    2107                 :             :                   else
    2108                 :             :                     {
    2109                 :           6 :                       free (op1_left);
    2110                 :           6 :                       free (op2_left);
    2111                 :           6 :                       if (firstarg)
    2112                 :             :                         {
    2113                 :           0 :                           firstarg->expr = op1_right;
    2114                 :           0 :                           secondarg->expr = op2_right;
    2115                 :             :                         }
    2116                 :             :                       else
    2117                 :             :                         {
    2118                 :           6 :                           e->value.op.op1 = op1_right;
    2119                 :           6 :                           e->value.op.op2 = op2_right;
    2120                 :             :                         }
    2121                 :           6 :                       optimize_comparison (e, op);
    2122                 :           6 :                       return true;
    2123                 :             :                     }
    2124                 :             :                 }
    2125                 :           6 :               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
    2126                 :             :                 {
    2127                 :           6 :                   free (op1_right);
    2128                 :           6 :                   free (op2_right);
    2129                 :           6 :                   if (firstarg)
    2130                 :             :                     {
    2131                 :           0 :                       firstarg->expr = op1_left;
    2132                 :           0 :                       secondarg->expr = op2_left;
    2133                 :             :                     }
    2134                 :             :                   else
    2135                 :             :                     {
    2136                 :           6 :                       e->value.op.op1 = op1_left;
    2137                 :           6 :                       e->value.op.op2 = op2_left;
    2138                 :             :                     }
    2139                 :             : 
    2140                 :           6 :                   optimize_comparison (e, op);
    2141                 :           6 :                   return true;
    2142                 :             :                 }
    2143                 :             :             }
    2144                 :             :         }
    2145                 :             :       else
    2146                 :             :         {
    2147                 :             :           /* eq can only be -1, 0 or 1 at this point.  */
    2148                 :         251 :           switch (op)
    2149                 :             :             {
    2150                 :          60 :             case INTRINSIC_EQ:
    2151                 :          60 :               result = eq == 0;
    2152                 :          60 :               break;
    2153                 :             : 
    2154                 :          30 :             case INTRINSIC_GE:
    2155                 :          30 :               result = eq >= 0;
    2156                 :          30 :               break;
    2157                 :             : 
    2158                 :          30 :             case INTRINSIC_LE:
    2159                 :          30 :               result = eq <= 0;
    2160                 :          30 :               break;
    2161                 :             : 
    2162                 :          59 :             case INTRINSIC_NE:
    2163                 :          59 :               result = eq != 0;
    2164                 :          59 :               break;
    2165                 :             : 
    2166                 :          42 :             case INTRINSIC_GT:
    2167                 :          42 :               result = eq > 0;
    2168                 :          42 :               break;
    2169                 :             : 
    2170                 :          30 :             case INTRINSIC_LT:
    2171                 :          30 :               result = eq < 0;
    2172                 :          30 :               break;
    2173                 :             : 
    2174                 :           0 :             default:
    2175                 :           0 :               gfc_internal_error ("illegal OP in optimize_comparison");
    2176                 :         251 :               break;
    2177                 :             :             }
    2178                 :             : 
    2179                 :             :           /* Replace the expression by a constant expression.  The typespec
    2180                 :             :              and where remains the way it is.  */
    2181                 :         251 :           free (op1);
    2182                 :         251 :           free (op2);
    2183                 :         251 :           e->expr_type = EXPR_CONSTANT;
    2184                 :         251 :           e->value.logical = result;
    2185                 :         251 :           return true;
    2186                 :             :         }
    2187                 :             :     }
    2188                 :             : 
    2189                 :             :   return change;
    2190                 :             : }
    2191                 :             : 
    2192                 :             : /* Optimize a trim function by replacing it with an equivalent substring
    2193                 :             :    involving a call to len_trim.  This only works for expressions where
    2194                 :             :    variables are trimmed.  Return true if anything was modified.  */
    2195                 :             : 
    2196                 :             : static bool
    2197                 :     2290803 : optimize_trim (gfc_expr *e)
    2198                 :             : {
    2199                 :     2290803 :   gfc_expr *a;
    2200                 :     2290803 :   gfc_ref *ref;
    2201                 :     2290803 :   gfc_expr *fcn;
    2202                 :     2290803 :   gfc_ref **rr = NULL;
    2203                 :             : 
    2204                 :             :   /* Don't do this optimization within an argument list, because
    2205                 :             :      otherwise aliasing issues may occur.  */
    2206                 :             : 
    2207                 :     2290803 :   if (count_arglist != 1)
    2208                 :             :     return false;
    2209                 :             : 
    2210                 :      357402 :   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
    2211                 :        6732 :       || e->value.function.isym == NULL
    2212                 :        4924 :       || e->value.function.isym->id != GFC_ISYM_TRIM)
    2213                 :             :     return false;
    2214                 :             : 
    2215                 :         515 :   a = e->value.function.actual->expr;
    2216                 :             : 
    2217                 :         515 :   if (a->expr_type != EXPR_VARIABLE)
    2218                 :             :     return false;
    2219                 :             : 
    2220                 :             :   /* This would pessimize the idiom a = trim(a) for reallocatable strings.  */
    2221                 :             : 
    2222                 :         504 :   if (a->symtree->n.sym->attr.allocatable)
    2223                 :             :     return false;
    2224                 :             : 
    2225                 :             :   /* Follow all references to find the correct place to put the newly
    2226                 :             :      created reference.  FIXME:  Also handle substring references and
    2227                 :             :      array references.  Array references cause strange regressions at
    2228                 :             :      the moment.  */
    2229                 :             : 
    2230                 :         483 :   if (a->ref)
    2231                 :             :     {
    2232                 :         152 :       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
    2233                 :             :         {
    2234                 :         124 :           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
    2235                 :             :             return false;
    2236                 :             :         }
    2237                 :             :     }
    2238                 :             : 
    2239                 :         387 :   strip_function_call (e);
    2240                 :             : 
    2241                 :         387 :   if (e->ref == NULL)
    2242                 :         359 :     rr = &(e->ref);
    2243                 :             : 
    2244                 :             :   /* Create the reference.  */
    2245                 :             : 
    2246                 :         387 :   ref = gfc_get_ref ();
    2247                 :         387 :   ref->type = REF_SUBSTRING;
    2248                 :             : 
    2249                 :             :   /* Set the start of the reference.  */
    2250                 :             : 
    2251                 :         387 :   ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
    2252                 :             : 
    2253                 :             :   /* Build the function call to len_trim(x, gfc_default_integer_kind).  */
    2254                 :             : 
    2255                 :         387 :   fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind);
    2256                 :             : 
    2257                 :             :   /* Set the end of the reference to the call to len_trim.  */
    2258                 :             : 
    2259                 :         387 :   ref->u.ss.end = fcn;
    2260                 :         387 :   gcc_assert (rr != NULL && *rr == NULL);
    2261                 :         387 :   *rr = ref;
    2262                 :         387 :   return true;
    2263                 :             : }
    2264                 :             : 
    2265                 :             : /* Optimize minloc(b), where b is rank 1 array, into
    2266                 :             :    (/ minloc(b, dim=1) /), and similarly for maxloc,
    2267                 :             :    as the latter forms are expanded inline.  */
    2268                 :             : 
    2269                 :             : static void
    2270                 :        7056 : optimize_minmaxloc (gfc_expr **e)
    2271                 :             : {
    2272                 :        7056 :   gfc_expr *fn = *e;
    2273                 :        7056 :   gfc_actual_arglist *a;
    2274                 :        7056 :   char *name, *p;
    2275                 :             : 
    2276                 :        7056 :   if (fn->rank != 1
    2277                 :        3216 :       || fn->value.function.actual == NULL
    2278                 :        3216 :       || fn->value.function.actual->expr == NULL
    2279                 :        3216 :       || fn->value.function.actual->expr->ts.type == BT_CHARACTER
    2280                 :        3071 :       || fn->value.function.actual->expr->rank != 1)
    2281                 :             :     return;
    2282                 :             : 
    2283                 :        1954 :   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
    2284                 :        1954 :   (*e)->shape = fn->shape;
    2285                 :        1954 :   fn->rank = 0;
    2286                 :        1954 :   fn->shape = NULL;
    2287                 :        1954 :   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
    2288                 :             : 
    2289                 :        1954 :   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
    2290                 :        1954 :   strcpy (name, fn->value.function.name);
    2291                 :        1954 :   p = strstr (name, "loc0");
    2292                 :        1954 :   p[3] = '1';
    2293                 :        1954 :   fn->value.function.name = gfc_get_string ("%s", name);
    2294                 :        1954 :   if (fn->value.function.actual->next)
    2295                 :             :     {
    2296                 :        1954 :       a = fn->value.function.actual->next;
    2297                 :        1954 :       gcc_assert (a->expr == NULL);
    2298                 :             :     }
    2299                 :             :   else
    2300                 :             :     {
    2301                 :           0 :       a = gfc_get_actual_arglist ();
    2302                 :           0 :       fn->value.function.actual->next = a;
    2303                 :             :     }
    2304                 :        1954 :   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    2305                 :             :                                    &fn->where);
    2306                 :        1954 :   mpz_set_ui (a->expr->value.integer, 1);
    2307                 :             : }
    2308                 :             : 
    2309                 :             : /* Data package to hand down for DO loop checks in a contained
    2310                 :             :    procedure.  */
    2311                 :             : typedef struct contained_info
    2312                 :             : {
    2313                 :             :   gfc_symbol *do_var;
    2314                 :             :   gfc_symbol *procedure;
    2315                 :             :   locus where_do;
    2316                 :             : } contained_info;
    2317                 :             : 
    2318                 :             : static enum gfc_exec_op last_io_op;
    2319                 :             : 
    2320                 :             : /* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
    2321                 :             :    contained function call.  */
    2322                 :             : 
    2323                 :             : static int
    2324                 :        5490 : doloop_contained_function_call (gfc_expr **e,
    2325                 :             :                                 int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
    2326                 :             : {
    2327                 :        5490 :   gfc_expr *expr = *e;
    2328                 :        5490 :   gfc_formal_arglist *f;
    2329                 :        5490 :   gfc_actual_arglist *a;
    2330                 :        5490 :   gfc_symbol *sym, *do_var;
    2331                 :        5490 :   contained_info *info;
    2332                 :             : 
    2333                 :        5490 :   if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym
    2334                 :          16 :       || expr->value.function.esym == NULL)
    2335                 :             :     return 0;
    2336                 :             : 
    2337                 :          15 :   sym = expr->value.function.esym;
    2338                 :          15 :   f = gfc_sym_get_dummy_args (sym);
    2339                 :          15 :   if (f == NULL)
    2340                 :             :     return 0;
    2341                 :             : 
    2342                 :          14 :   info = (contained_info *) data;
    2343                 :          14 :   do_var = info->do_var;
    2344                 :          14 :   a = expr->value.function.actual;
    2345                 :             : 
    2346                 :          41 :   while (a && f)
    2347                 :             :     {
    2348                 :          29 :       if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
    2349                 :             :         {
    2350                 :           3 :           if (f->sym->attr.intent == INTENT_OUT)
    2351                 :             :             {
    2352                 :           1 :               gfc_error_now ("Index variable %qs set to undefined as "
    2353                 :             :                              "INTENT(OUT) argument at %L in procedure %qs "
    2354                 :             :                              "called from within DO loop at %L", do_var->name,
    2355                 :           1 :                              &a->expr->where, info->procedure->name,
    2356                 :             :                              &info->where_do);
    2357                 :           1 :               return 1;
    2358                 :             :             }
    2359                 :           2 :           else if (f->sym->attr.intent == INTENT_INOUT)
    2360                 :             :             {
    2361                 :           1 :               gfc_error_now ("Index variable %qs not definable as "
    2362                 :             :                              "INTENT(INOUT) argument at %L in procedure %qs "
    2363                 :             :                              "called from within DO loop at %L", do_var->name,
    2364                 :           1 :                              &a->expr->where, info->procedure->name,
    2365                 :             :                              &info->where_do);
    2366                 :           1 :               return 1;
    2367                 :             :             }
    2368                 :             :         }
    2369                 :          27 :       a = a->next;
    2370                 :          27 :       f = f->next;
    2371                 :             :     }
    2372                 :             :   return 0;
    2373                 :             : }
    2374                 :             : 
    2375                 :             : /* Callback function that goes through the code in a contained
    2376                 :             :    procedure to make sure it does not change a variable in a DO
    2377                 :             :    loop.  */
    2378                 :             : 
    2379                 :             : static int
    2380                 :        2389 : doloop_contained_procedure_code (gfc_code **c,
    2381                 :             :                                  int *walk_subtrees ATTRIBUTE_UNUSED,
    2382                 :             :                                  void *data)
    2383                 :             : {
    2384                 :        2389 :   gfc_code *co = *c;
    2385                 :        2389 :   contained_info *info = (contained_info *) data;
    2386                 :        2389 :   gfc_symbol *do_var = info->do_var;
    2387                 :        2389 :   const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs "
    2388                 :             :                          "called from within DO loop at %L");
    2389                 :        2389 :   static enum gfc_exec_op saved_io_op;
    2390                 :             : 
    2391                 :        2389 :   switch (co->op)
    2392                 :             :     {
    2393                 :         624 :     case EXEC_ASSIGN:
    2394                 :         624 :       if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var)
    2395                 :           4 :         gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name,
    2396                 :             :                        &info->where_do);
    2397                 :             :       break;
    2398                 :             : 
    2399                 :         126 :     case EXEC_DO:
    2400                 :         126 :       if (co->ext.iterator && co->ext.iterator->var
    2401                 :         126 :           && co->ext.iterator->var->symtree->n.sym == do_var)
    2402                 :           1 :         gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name,
    2403                 :             :                    &info->where_do);
    2404                 :             :       break;
    2405                 :             : 
    2406                 :          43 :     case EXEC_READ:
    2407                 :          43 :     case EXEC_WRITE:
    2408                 :          43 :     case EXEC_INQUIRE:
    2409                 :          43 :     case EXEC_IOLENGTH:
    2410                 :          43 :       saved_io_op = last_io_op;
    2411                 :          43 :       last_io_op = co->op;
    2412                 :          43 :       break;
    2413                 :             : 
    2414                 :           1 :     case EXEC_OPEN:
    2415                 :           1 :       if (co->ext.open && co->ext.open->iostat
    2416                 :           1 :           && co->ext.open->iostat->symtree->n.sym == do_var)
    2417                 :           1 :         gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where,
    2418                 :           1 :                        info->procedure->name, &info->where_do);
    2419                 :             :       break;
    2420                 :             : 
    2421                 :           0 :     case EXEC_CLOSE:
    2422                 :           0 :       if (co->ext.close && co->ext.close->iostat
    2423                 :           0 :           && co->ext.close->iostat->symtree->n.sym == do_var)
    2424                 :           0 :         gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where,
    2425                 :           0 :                        info->procedure->name, &info->where_do);
    2426                 :             :       break;
    2427                 :             : 
    2428                 :          93 :     case EXEC_TRANSFER:
    2429                 :          93 :       switch (last_io_op)
    2430                 :             :         {
    2431                 :             : 
    2432                 :           0 :         case EXEC_INQUIRE:
    2433                 :             : #define CHECK_INQ(a) do { if (co->ext.inquire    &&                  \
    2434                 :             :                               co->ext.inquire->a &&                       \
    2435                 :             :                               co->ext.inquire->a->symtree->n.sym == do_var) \
    2436                 :             :               gfc_error_now (errmsg, do_var->name,                   \
    2437                 :             :                              &co->ext.inquire->a->where,           \
    2438                 :             :                              info->procedure->name,                       \
    2439                 :             :                              &info->where_do);                           \
    2440                 :             :           } while (0)
    2441                 :             : 
    2442                 :           0 :           CHECK_INQ(iostat);
    2443                 :           0 :           CHECK_INQ(number);
    2444                 :           0 :           CHECK_INQ(position);
    2445                 :           0 :           CHECK_INQ(recl);
    2446                 :           0 :           CHECK_INQ(position);
    2447                 :           0 :           CHECK_INQ(iolength);
    2448                 :           0 :           CHECK_INQ(strm_pos);
    2449                 :             :           break;
    2450                 :             : #undef CHECK_INQ
    2451                 :             : 
    2452                 :           0 :         case EXEC_READ:
    2453                 :           0 :           if (co->expr1 && co->expr1->symtree
    2454                 :           0 :               && co->expr1->symtree->n.sym == do_var)
    2455                 :           0 :             gfc_error_now (errmsg, do_var->name, &co->expr1->where,
    2456                 :           0 :                            info->procedure->name, &info->where_do);
    2457                 :             : 
    2458                 :             :           /* Fallthrough.  */
    2459                 :             : 
    2460                 :          90 :         case EXEC_WRITE:
    2461                 :          90 :           if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree
    2462                 :           0 :               && co->ext.dt->iostat->symtree->n.sym == do_var)
    2463                 :           0 :             gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where,
    2464                 :           0 :                            info->procedure->name, &info->where_do);
    2465                 :             :           break;
    2466                 :             : 
    2467                 :           3 :         case EXEC_IOLENGTH:
    2468                 :           3 :           if (co->expr1 && co->expr1->symtree
    2469                 :           2 :               && co->expr1->symtree->n.sym == do_var)
    2470                 :           1 :             gfc_error_now (errmsg, do_var->name, &co->expr1->where,
    2471                 :           1 :                            info->procedure->name, &info->where_do);
    2472                 :             :           break;
    2473                 :             : 
    2474                 :           0 :         default:
    2475                 :           0 :           gcc_unreachable ();
    2476                 :             :         }
    2477                 :             :       break;
    2478                 :             : 
    2479                 :          43 :     case EXEC_DT_END:
    2480                 :          43 :       last_io_op = saved_io_op;
    2481                 :          43 :       break;
    2482                 :             : 
    2483                 :          85 :     case EXEC_CALL:
    2484                 :          85 :       gfc_formal_arglist *f;
    2485                 :          85 :       gfc_actual_arglist *a;
    2486                 :             : 
    2487                 :          85 :       f = gfc_sym_get_dummy_args (co->resolved_sym);
    2488                 :          85 :       if (f == NULL)
    2489                 :             :         break;
    2490                 :          58 :       a = co->ext.actual;
    2491                 :             :       /* Slightly different error message here. If there is an error,
    2492                 :             :          return 1 to avoid an infinite loop.  */
    2493                 :         174 :       while (a && f)
    2494                 :             :         {
    2495                 :         116 :           if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var)
    2496                 :             :             {
    2497                 :           2 :               if (f->sym->attr.intent == INTENT_OUT)
    2498                 :             :                 {
    2499                 :           0 :                   gfc_error_now ("Index variable %qs set to undefined as "
    2500                 :             :                                  "INTENT(OUT) argument at %L in subroutine %qs "
    2501                 :             :                                  "called from within DO loop at %L",
    2502                 :             :                                  do_var->name, &a->expr->where,
    2503                 :           0 :                                  info->procedure->name, &info->where_do);
    2504                 :           0 :                   return 1;
    2505                 :             :                 }
    2506                 :           2 :               else if (f->sym->attr.intent == INTENT_INOUT)
    2507                 :             :                 {
    2508                 :           0 :                   gfc_error_now ("Index variable %qs not definable as "
    2509                 :             :                                  "INTENT(INOUT) argument at %L in subroutine %qs "
    2510                 :             :                                  "called from within DO loop at %L", do_var->name,
    2511                 :           0 :                                  &a->expr->where, info->procedure->name,
    2512                 :             :                                  &info->where_do);
    2513                 :           0 :                   return 1;
    2514                 :             :                 }
    2515                 :             :             }
    2516                 :         116 :           a = a->next;
    2517                 :         116 :           f = f->next;
    2518                 :             :         }
    2519                 :             :       break;
    2520                 :             :     default:
    2521                 :             :       break;
    2522                 :             :     }
    2523                 :             :   return 0;
    2524                 :             : }
    2525                 :             : 
    2526                 :             : /* Callback function for code checking that we do not pass a DO variable to an
    2527                 :             :    INTENT(OUT) or INTENT(INOUT) dummy variable.  */
    2528                 :             : 
    2529                 :             : static int
    2530                 :      956516 : doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    2531                 :             :          void *data ATTRIBUTE_UNUSED)
    2532                 :             : {
    2533                 :      956516 :   gfc_code *co;
    2534                 :      956516 :   int i;
    2535                 :      956516 :   gfc_formal_arglist *f;
    2536                 :      956516 :   gfc_actual_arglist *a;
    2537                 :      956516 :   gfc_code *cl;
    2538                 :      956516 :   do_t loop, *lp;
    2539                 :      956516 :   bool seen_goto;
    2540                 :             : 
    2541                 :      956516 :   co = *c;
    2542                 :             : 
    2543                 :             :   /* If the doloop_list grew, we have to truncate it here.  */
    2544                 :             : 
    2545                 :     1189371 :   if ((unsigned) doloop_level < doloop_list.length())
    2546                 :       27738 :     doloop_list.truncate (doloop_level);
    2547                 :             : 
    2548                 :      956516 :   seen_goto = false;
    2549                 :      956516 :   switch (co->op)
    2550                 :             :     {
    2551                 :       36397 :     case EXEC_DO:
    2552                 :             : 
    2553                 :       36397 :       if (co->ext.iterator && co->ext.iterator->var)
    2554                 :       36397 :         loop.c = co;
    2555                 :             :       else
    2556                 :           0 :         loop.c = NULL;
    2557                 :             : 
    2558                 :       36397 :       loop.branch_level = if_level + select_level;
    2559                 :       36397 :       loop.seen_goto = false;
    2560                 :       36397 :       doloop_list.safe_push (loop);
    2561                 :       36397 :       break;
    2562                 :             : 
    2563                 :             :       /* If anything could transfer control away from a suspicious
    2564                 :             :          subscript, make sure to set seen_goto in the current DO loop
    2565                 :             :          (if any).  */
    2566                 :             :     case EXEC_GOTO:
    2567                 :             :     case EXEC_EXIT:
    2568                 :             :     case EXEC_STOP:
    2569                 :             :     case EXEC_ERROR_STOP:
    2570                 :             :     case EXEC_CYCLE:
    2571                 :             :       seen_goto = true;
    2572                 :             :       break;
    2573                 :             : 
    2574                 :        3701 :     case EXEC_OPEN:
    2575                 :        3701 :       if (co->ext.open->err)
    2576                 :             :         seen_goto = true;
    2577                 :             :       break;
    2578                 :             : 
    2579                 :        2948 :     case EXEC_CLOSE:
    2580                 :        2948 :       if (co->ext.close->err)
    2581                 :             :         seen_goto = true;
    2582                 :             :       break;
    2583                 :             : 
    2584                 :        2548 :     case EXEC_BACKSPACE:
    2585                 :        2548 :     case EXEC_ENDFILE:
    2586                 :        2548 :     case EXEC_REWIND:
    2587                 :        2548 :     case EXEC_FLUSH:
    2588                 :             : 
    2589                 :        2548 :       if (co->ext.filepos->err)
    2590                 :             :         seen_goto = true;
    2591                 :             :       break;
    2592                 :             : 
    2593                 :         811 :     case EXEC_INQUIRE:
    2594                 :         811 :       if (co->ext.filepos->err)
    2595                 :             :         seen_goto = true;
    2596                 :             :       break;
    2597                 :             : 
    2598                 :       30321 :     case EXEC_READ:
    2599                 :       30321 :     case EXEC_WRITE:
    2600                 :       30321 :       if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
    2601                 :             :         seen_goto = true;
    2602                 :             :       break;
    2603                 :             : 
    2604                 :             :     case EXEC_WAIT:
    2605                 :             :       if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
    2606                 :             :         loop.seen_goto = true;
    2607                 :             :       break;
    2608                 :             : 
    2609                 :       73665 :     case EXEC_CALL:
    2610                 :       73665 :       if (co->resolved_sym == NULL)
    2611                 :             :         break;
    2612                 :             : 
    2613                 :             :       /* Test if somebody stealthily changes the DO variable from
    2614                 :             :          under us by changing it in a host-associated procedure.  */
    2615                 :       73342 :       if (co->resolved_sym->attr.contained)
    2616                 :             :         {
    2617                 :       39801 :           FOR_EACH_VEC_ELT (doloop_list, i, lp)
    2618                 :             :             {
    2619                 :        3540 :               gfc_symbol *sym = co->resolved_sym;
    2620                 :        3540 :               contained_info info;
    2621                 :        3540 :               gfc_namespace *ns;
    2622                 :             : 
    2623                 :        3540 :               cl = lp->c;
    2624                 :        3540 :               info.do_var = cl->ext.iterator->var->symtree->n.sym;
    2625                 :        3540 :               info.procedure = co->resolved_sym;  /* sym? */
    2626                 :        3540 :               info.where_do = co->loc;
    2627                 :             :               /* Look contained procedures under the namespace of the
    2628                 :             :                  variable.  */
    2629                 :        4166 :               for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
    2630                 :         626 :                 if (ns->proc_name && ns->proc_name == sym)
    2631                 :         244 :                   gfc_code_walker (&ns->code, doloop_contained_procedure_code,
    2632                 :             :                                    doloop_contained_function_call, &info);
    2633                 :             :             }
    2634                 :             :         }
    2635                 :             : 
    2636                 :       73342 :       f = gfc_sym_get_dummy_args (co->resolved_sym);
    2637                 :             : 
    2638                 :             :       /* Withot a formal arglist, there is only unknown INTENT,
    2639                 :             :          which we don't check for.  */
    2640                 :       73342 :       if (f == NULL)
    2641                 :             :         break;
    2642                 :             : 
    2643                 :       52423 :       a = co->ext.actual;
    2644                 :             : 
    2645                 :      187745 :       while (a && f)
    2646                 :             :         {
    2647                 :      150433 :           FOR_EACH_VEC_ELT (doloop_list, i, lp)
    2648                 :             :             {
    2649                 :       15111 :               gfc_symbol *do_sym;
    2650                 :       15111 :               cl = lp->c;
    2651                 :             : 
    2652                 :       15111 :               if (cl == NULL)
    2653                 :             :                 break;
    2654                 :             : 
    2655                 :       15111 :               do_sym = cl->ext.iterator->var->symtree->n.sym;
    2656                 :             : 
    2657                 :       15111 :               if (a->expr && a->expr->symtree && f->sym
    2658                 :        8040 :                   && a->expr->symtree->n.sym == do_sym)
    2659                 :             :                 {
    2660                 :        1370 :                   if (f->sym->attr.intent == INTENT_OUT)
    2661                 :           2 :                     gfc_error_now ("Variable %qs at %L set to undefined "
    2662                 :             :                                    "value inside loop beginning at %L as "
    2663                 :             :                                    "INTENT(OUT) argument to subroutine %qs",
    2664                 :             :                                    do_sym->name, &a->expr->where,
    2665                 :           1 :                                    &(doloop_list[i].c->loc),
    2666                 :           1 :                                    co->symtree->n.sym->name);
    2667                 :        1369 :                   else if (f->sym->attr.intent == INTENT_INOUT)
    2668                 :           2 :                     gfc_error_now ("Variable %qs at %L not definable inside "
    2669                 :             :                                    "loop beginning at %L as INTENT(INOUT) "
    2670                 :             :                                    "argument to subroutine %qs",
    2671                 :             :                                    do_sym->name, &a->expr->where,
    2672                 :           1 :                                    &(doloop_list[i].c->loc),
    2673                 :           1 :                                    co->symtree->n.sym->name);
    2674                 :             :                 }
    2675                 :             :             }
    2676                 :      135322 :           a = a->next;
    2677                 :      135322 :           f = f->next;
    2678                 :             :         }
    2679                 :             : 
    2680                 :             :       break;
    2681                 :             : 
    2682                 :             :     default:
    2683                 :             :       break;
    2684                 :             :     }
    2685                 :      221047 :   if (seen_goto && doloop_level > 0)
    2686                 :        9042 :     doloop_list[doloop_level-1].seen_goto = true;
    2687                 :             : 
    2688                 :      956516 :   return 0;
    2689                 :             : }
    2690                 :             : 
    2691                 :             : /* Callback function to warn about different things within DO loops.  */
    2692                 :             : 
    2693                 :             : static int
    2694                 :     2732351 : do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    2695                 :             :              void *data ATTRIBUTE_UNUSED)
    2696                 :             : {
    2697                 :     2732351 :   do_t *last;
    2698                 :             : 
    2699                 :     2732351 :   if (doloop_list.length () == 0)
    2700                 :             :     return 0;
    2701                 :             : 
    2702                 :      611721 :   if ((*e)->expr_type == EXPR_FUNCTION)
    2703                 :       36488 :     do_intent (e);
    2704                 :             : 
    2705                 :      611721 :   last = &doloop_list.last();
    2706                 :      611721 :   if (last->seen_goto && !warn_do_subscript)
    2707                 :             :     return 0;
    2708                 :             : 
    2709                 :      571130 :   if ((*e)->expr_type == EXPR_VARIABLE)
    2710                 :      280151 :     do_subscript (e);
    2711                 :             : 
    2712                 :             :   return 0;
    2713                 :             : }
    2714                 :             : 
    2715                 :             : typedef struct
    2716                 :             : {
    2717                 :             :   gfc_symbol *sym;
    2718                 :             :   mpz_t val;
    2719                 :             : } insert_index_t;
    2720                 :             : 
    2721                 :             : /* Callback function - if the expression is the variable in data->sym,
    2722                 :             :    replace it with a constant from data->val.  */
    2723                 :             : 
    2724                 :             : static int
    2725                 :      137566 : callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    2726                 :             :                        void *data)
    2727                 :             : {
    2728                 :      137566 :   insert_index_t *d;
    2729                 :      137566 :   gfc_expr *ex, *n;
    2730                 :             : 
    2731                 :      137566 :   ex = (*e);
    2732                 :      137566 :   if (ex->expr_type != EXPR_VARIABLE)
    2733                 :             :     return 0;
    2734                 :             : 
    2735                 :       92618 :   d = (insert_index_t *) data;
    2736                 :       92618 :   if (ex->symtree->n.sym != d->sym)
    2737                 :             :     return 0;
    2738                 :             : 
    2739                 :       49635 :   n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
    2740                 :       49635 :   mpz_set (n->value.integer, d->val);
    2741                 :             : 
    2742                 :       49635 :   gfc_free_expr (ex);
    2743                 :       49635 :   *e = n;
    2744                 :       49635 :   return 0;
    2745                 :             : }
    2746                 :             : 
    2747                 :             : /* In the expression e, replace occurrences of the variable sym with
    2748                 :             :    val.  If this results in a constant expression, return true and
    2749                 :             :    return the value in ret.  Return false if the expression already
    2750                 :             :    is a constant.  Caller has to clear ret in that case.  */
    2751                 :             : 
    2752                 :             : static bool
    2753                 :       88963 : insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
    2754                 :             : {
    2755                 :       88963 :   gfc_expr *n;
    2756                 :       88963 :   insert_index_t data;
    2757                 :       88963 :   bool rc;
    2758                 :             : 
    2759                 :       88963 :   if (e->expr_type == EXPR_CONSTANT)
    2760                 :             :     return false;
    2761                 :             : 
    2762                 :       85104 :   n = gfc_copy_expr (e);
    2763                 :       85104 :   data.sym = sym;
    2764                 :       85104 :   mpz_init_set (data.val, val);
    2765                 :       85104 :   gfc_expr_walker (&n, callback_insert_index, (void *) &data);
    2766                 :             : 
    2767                 :             :   /* Suppress errors here - we could get errors here such as an
    2768                 :             :      out of bounds access for arrays, see PR 90563.  */
    2769                 :       85104 :   gfc_push_suppress_errors ();
    2770                 :       85104 :   gfc_simplify_expr (n, 0);
    2771                 :       85104 :   gfc_pop_suppress_errors ();
    2772                 :             : 
    2773                 :       85104 :   if (n->expr_type == EXPR_CONSTANT)
    2774                 :             :     {
    2775                 :       45574 :       rc = true;
    2776                 :       45574 :       mpz_init_set (ret, n->value.integer);
    2777                 :             :     }
    2778                 :             :   else
    2779                 :             :     rc = false;
    2780                 :             : 
    2781                 :       85104 :   mpz_clear (data.val);
    2782                 :       85104 :   gfc_free_expr (n);
    2783                 :       85104 :   return rc;
    2784                 :             : 
    2785                 :             : }
    2786                 :             : 
    2787                 :             : /* Check array subscripts for possible out-of-bounds accesses in DO
    2788                 :             :    loops with constant bounds.  */
    2789                 :             : 
    2790                 :             : static int
    2791                 :      280151 : do_subscript (gfc_expr **e)
    2792                 :             : {
    2793                 :      280151 :   gfc_expr *v;
    2794                 :      280151 :   gfc_array_ref *ar;
    2795                 :      280151 :   gfc_ref *ref;
    2796                 :      280151 :   int i,j;
    2797                 :      280151 :   gfc_code *dl;
    2798                 :      280151 :   do_t *lp;
    2799                 :             : 
    2800                 :      280151 :   v = *e;
    2801                 :             :   /* Constants are already checked.  */
    2802                 :      280151 :   if (v->expr_type == EXPR_CONSTANT)
    2803                 :             :     return 0;
    2804                 :             : 
    2805                 :             :   /* Wrong warnings will be generated in an associate list.  */
    2806                 :      280151 :   if (in_assoc_list)
    2807                 :             :     return 0;
    2808                 :             : 
    2809                 :             :   /* We already warned about this.  */
    2810                 :      280011 :   if (v->do_not_warn)
    2811                 :             :     return 0;
    2812                 :             : 
    2813                 :      255261 :   v->do_not_warn = 1;
    2814                 :             : 
    2815                 :      323927 :   for (ref = v->ref; ref; ref = ref->next)
    2816                 :             :     {
    2817                 :       71031 :       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
    2818                 :             :         {
    2819                 :             :           ar = & ref->u.ar;
    2820                 :      160522 :           FOR_EACH_VEC_ELT (doloop_list, j, lp)
    2821                 :             :             {
    2822                 :       62378 :               gfc_symbol *do_sym;
    2823                 :       62378 :               mpz_t do_start, do_step, do_end;
    2824                 :       62378 :               bool have_do_start, have_do_end;
    2825                 :       62378 :               bool error_not_proven;
    2826                 :       62378 :               int warn;
    2827                 :       62378 :               int sgn;
    2828                 :             : 
    2829                 :       62378 :               dl = lp->c;
    2830                 :       62378 :               if (dl == NULL)
    2831                 :             :                 break;
    2832                 :             : 
    2833                 :             :               /* If we are within a branch, or a goto or equivalent
    2834                 :             :                  was seen in the DO loop before, then we cannot prove that
    2835                 :             :                  this expression is actually evaluated.  Don't do anything
    2836                 :             :                  unless we want to see it all.  */
    2837                 :       62378 :               error_not_proven = lp->seen_goto
    2838                 :       62378 :                 || lp->branch_level < if_level + select_level;
    2839                 :             : 
    2840                 :       15843 :               if (error_not_proven && !warn_do_subscript)
    2841                 :             :                 break;
    2842                 :             : 
    2843                 :             :               if (error_not_proven)
    2844                 :             :                 warn = OPT_Wdo_subscript;
    2845                 :             :               else
    2846                 :             :                 warn = 0;
    2847                 :             : 
    2848                 :       46541 :               do_sym = dl->ext.iterator->var->symtree->n.sym;
    2849                 :       46541 :               if (do_sym->ts.type != BT_INTEGER)
    2850                 :         666 :                 continue;
    2851                 :             : 
    2852                 :             :               /* If we do not know about the stepsize, the loop may be zero trip.
    2853                 :             :                  Do not warn in this case.  */
    2854                 :             : 
    2855                 :       46535 :               if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
    2856                 :             :                 {
    2857                 :       45876 :                   sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
    2858                 :             :                   /* This can happen, but then the error has been
    2859                 :             :                      reported previously.  */
    2860                 :       45448 :                   if (sgn == 0)
    2861                 :           1 :                     continue;
    2862                 :             : 
    2863                 :       45875 :                   mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
    2864                 :             :                 }
    2865                 :             : 
    2866                 :             :               else
    2867                 :         659 :                 continue;
    2868                 :             : 
    2869                 :       45875 :               if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
    2870                 :             :                 {
    2871                 :       43344 :                   have_do_start = true;
    2872                 :       43344 :                   mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
    2873                 :             :                 }
    2874                 :             :               else
    2875                 :             :                 have_do_start = false;
    2876                 :             : 
    2877                 :       45875 :               if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
    2878                 :             :                 {
    2879                 :       18092 :                   have_do_end = true;
    2880                 :       18092 :                   mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
    2881                 :             :                 }
    2882                 :             :               else
    2883                 :             :                 have_do_end = false;
    2884                 :             : 
    2885                 :       45875 :               if (!have_do_start && !have_do_end)
    2886                 :             :                 {
    2887                 :        2365 :                   mpz_clear (do_step);
    2888                 :        2365 :                   return 0;
    2889                 :             :                 }
    2890                 :             : 
    2891                 :             :               /* No warning inside a zero-trip loop.  */
    2892                 :       43510 :               if (have_do_start && have_do_end)
    2893                 :             :                 {
    2894                 :       17926 :                   int cmp;
    2895                 :             : 
    2896                 :       17926 :                   cmp = mpz_cmp (do_end, do_start);
    2897                 :       17926 :                   if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
    2898                 :             :                     {
    2899                 :          17 :                       mpz_clear (do_start);
    2900                 :          17 :                       mpz_clear (do_end);
    2901                 :          17 :                       mpz_clear (do_step);
    2902                 :          17 :                       break;
    2903                 :             :                     }
    2904                 :             :                 }
    2905                 :             : 
    2906                 :             :               /* May have to correct the end value if the step does not equal
    2907                 :             :                  one.  */
    2908                 :       43493 :               if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
    2909                 :             :                 {
    2910                 :         639 :                   mpz_t diff, rem;
    2911                 :             : 
    2912                 :         639 :                   mpz_init (diff);
    2913                 :         639 :                   mpz_init (rem);
    2914                 :         639 :                   mpz_sub (diff, do_end, do_start);
    2915                 :         639 :                   mpz_tdiv_r (rem, diff, do_step);
    2916                 :         639 :                   mpz_sub (do_end, do_end, rem);
    2917                 :         639 :                   mpz_clear (diff);
    2918                 :         639 :                   mpz_clear (rem);
    2919                 :             :                 }
    2920                 :             : 
    2921                 :      104621 :               for (i = 0; i< ar->dimen; i++)
    2922                 :             :                 {
    2923                 :       61128 :                   mpz_t val;
    2924                 :       61128 :                   if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
    2925                 :      122017 :                       && insert_index (ar->start[i], do_sym, do_start, val))
    2926                 :             :                     {
    2927                 :       31722 :                       if (ar->as->lower[i]
    2928                 :       27829 :                           && ar->as->lower[i]->expr_type == EXPR_CONSTANT
    2929                 :       27768 :                           && ar->as->lower[i]->ts.type == BT_INTEGER
    2930                 :       27768 :                           && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
    2931                 :          14 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2932                 :             :                                      "(%ld < %ld) in loop beginning at %L",
    2933                 :           7 :                                      &ar->start[i]->where, mpz_get_si (val),
    2934                 :             :                                      mpz_get_si (ar->as->lower[i]->value.integer),
    2935                 :           7 :                                      &doloop_list[j].c->loc);
    2936                 :             : 
    2937                 :       31722 :                       if (ar->as->upper[i]
    2938                 :       25181 :                           && ar->as->upper[i]->expr_type == EXPR_CONSTANT
    2939                 :       10760 :                           && ar->as->upper[i]->ts.type == BT_INTEGER
    2940                 :       10759 :                           && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
    2941                 :          62 :                             gfc_warning (warn, "Array reference at %L out of bounds "
    2942                 :             :                                          "(%ld > %ld) in loop beginning at %L",
    2943                 :          31 :                                          &ar->start[i]->where, mpz_get_si (val),
    2944                 :             :                                          mpz_get_si (ar->as->upper[i]->value.integer),
    2945                 :          31 :                                          &doloop_list[j].c->loc);
    2946                 :             : 
    2947                 :       31722 :                       mpz_clear (val);
    2948                 :             :                     }
    2949                 :             : 
    2950                 :       61128 :                   if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
    2951                 :       89202 :                       && insert_index (ar->start[i], do_sym, do_end, val))
    2952                 :             :                     {
    2953                 :       13852 :                       if (ar->as->lower[i]
    2954                 :       11470 :                           && ar->as->lower[i]->expr_type == EXPR_CONSTANT
    2955                 :       11468 :                           && ar->as->lower[i]->ts.type == BT_INTEGER
    2956                 :       11468 :                           && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
    2957                 :           4 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2958                 :             :                                      "(%ld < %ld) in loop beginning at %L",
    2959                 :           2 :                                      &ar->start[i]->where, mpz_get_si (val),
    2960                 :             :                                      mpz_get_si (ar->as->lower[i]->value.integer),
    2961                 :           2 :                                      &doloop_list[j].c->loc);
    2962                 :             : 
    2963                 :       13852 :                       if (ar->as->upper[i]
    2964                 :       10222 :                           && ar->as->upper[i]->expr_type == EXPR_CONSTANT
    2965                 :        9600 :                           && ar->as->upper[i]->ts.type == BT_INTEGER
    2966                 :        9599 :                           && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
    2967                 :          16 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2968                 :             :                                      "(%ld > %ld) in loop beginning at %L",
    2969                 :           8 :                                      &ar->start[i]->where, mpz_get_si (val),
    2970                 :             :                                      mpz_get_si (ar->as->upper[i]->value.integer),
    2971                 :           8 :                                      &doloop_list[j].c->loc);
    2972                 :             : 
    2973                 :       13852 :                       mpz_clear (val);
    2974                 :             :                     }
    2975                 :             :                 }
    2976                 :             : 
    2977                 :       43493 :               if (have_do_start)
    2978                 :       43327 :                 mpz_clear (do_start);
    2979                 :       43493 :               if (have_do_end)
    2980                 :       18075 :                 mpz_clear (do_end);
    2981                 :       43493 :               mpz_clear (do_step);
    2982                 :             :             }
    2983                 :             :         }
    2984                 :             :     }
    2985                 :             :   return 0;
    2986                 :             : }
    2987                 :             : /* Function for functions checking that we do not pass a DO variable
    2988                 :             :    to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */
    2989                 :             : 
    2990                 :             : static int
    2991                 :       36488 : do_intent (gfc_expr **e)
    2992                 :             : {
    2993                 :       36488 :   gfc_formal_arglist *f;
    2994                 :       36488 :   gfc_actual_arglist *a;
    2995                 :       36488 :   gfc_expr *expr;
    2996                 :       36488 :   gfc_code *dl;
    2997                 :       36488 :   do_t *lp;
    2998                 :       36488 :   int i;
    2999                 :       36488 :   gfc_symbol *sym;
    3000                 :             : 
    3001                 :       36488 :   expr = *e;
    3002                 :       36488 :   if (expr->expr_type != EXPR_FUNCTION)
    3003                 :             :     return 0;
    3004                 :             : 
    3005                 :             :   /* Intrinsic functions don't modify their arguments.  */
    3006                 :             : 
    3007                 :       36488 :   if (expr->value.function.isym)
    3008                 :             :     return 0;
    3009                 :             : 
    3010                 :        2462 :   sym = expr->value.function.esym;
    3011                 :        2462 :   if (sym == NULL)
    3012                 :             :     return 0;
    3013                 :             : 
    3014                 :        2268 :   if (sym->attr.contained)
    3015                 :             :     {
    3016                 :         992 :       FOR_EACH_VEC_ELT (doloop_list, i, lp)
    3017                 :             :         {
    3018                 :         600 :           contained_info info;
    3019                 :         600 :           gfc_namespace *ns;
    3020                 :             : 
    3021                 :         600 :           dl = lp->c;
    3022                 :         600 :           info.do_var = dl->ext.iterator->var->symtree->n.sym;
    3023                 :         600 :           info.procedure = sym;
    3024                 :         600 :           info.where_do = expr->where;
    3025                 :             :           /* Look contained procedures under the namespace of the
    3026                 :             :                  variable.  */
    3027                 :         972 :           for (ns = info.do_var->ns->contained; ns; ns = ns->sibling)
    3028                 :         372 :             if (ns->proc_name && ns->proc_name == sym)
    3029                 :         199 :               gfc_code_walker (&ns->code, doloop_contained_procedure_code,
    3030                 :             :                                dummy_expr_callback, &info);
    3031                 :             :         }
    3032                 :             :     }
    3033                 :             : 
    3034                 :        2268 :   f = gfc_sym_get_dummy_args (sym);
    3035                 :             : 
    3036                 :             :   /* Without a formal arglist, there is only unknown INTENT,
    3037                 :             :      which we don't check for.  */
    3038                 :        2268 :   if (f == NULL)
    3039                 :             :     return 0;
    3040                 :             : 
    3041                 :        1133 :   a = expr->value.function.actual;
    3042                 :             : 
    3043                 :        3105 :   while (a && f)
    3044                 :             :     {
    3045                 :        5141 :       FOR_EACH_VEC_ELT (doloop_list, i, lp)
    3046                 :             :         {
    3047                 :        3169 :           gfc_symbol *do_sym;
    3048                 :        3169 :           dl = lp->c;
    3049                 :        3169 :           if (dl == NULL)
    3050                 :             :             break;
    3051                 :             : 
    3052                 :        3169 :           do_sym = dl->ext.iterator->var->symtree->n.sym;
    3053                 :             : 
    3054                 :        3169 :           if (a->expr && a->expr->symtree
    3055                 :        2289 :               && a->expr->symtree->n.sym == do_sym
    3056                 :         330 :               && f->sym)
    3057                 :             :             {
    3058                 :         329 :               if (f->sym->attr.intent == INTENT_OUT)
    3059                 :           2 :                 gfc_error_now ("Variable %qs at %L set to undefined value "
    3060                 :             :                                "inside loop beginning at %L as INTENT(OUT) "
    3061                 :             :                                "argument to function %qs", do_sym->name,
    3062                 :           1 :                                &a->expr->where, &doloop_list[i].c->loc,
    3063                 :           1 :                                expr->symtree->n.sym->name);
    3064                 :         328 :               else if (f->sym->attr.intent == INTENT_INOUT)
    3065                 :           2 :                 gfc_error_now ("Variable %qs at %L not definable inside loop"
    3066                 :             :                                " beginning at %L as INTENT(INOUT) argument to"
    3067                 :             :                                " function %qs", do_sym->name,
    3068                 :           1 :                                &a->expr->where, &doloop_list[i].c->loc,
    3069                 :           1 :                                expr->symtree->n.sym->name);
    3070                 :             :             }
    3071                 :             :         }
    3072                 :        1972 :       a = a->next;
    3073                 :        1972 :       f = f->next;
    3074                 :             :     }
    3075                 :             : 
    3076                 :             :   return 0;
    3077                 :             : }
    3078                 :             : 
    3079                 :             : static void
    3080                 :      283177 : doloop_warn (gfc_namespace *ns)
    3081                 :             : {
    3082                 :      283177 :   gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
    3083                 :             : 
    3084                 :      322112 :   for (ns = ns->contained; ns; ns = ns->sibling)
    3085                 :             :     {
    3086                 :       38935 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    3087                 :       38154 :         doloop_warn (ns);
    3088                 :             :     }
    3089                 :      283177 : }
    3090                 :             : 
    3091                 :             : /* This selction deals with inlining calls to MATMUL.  */
    3092                 :             : 
    3093                 :             : /* Replace calls to matmul outside of straight assignments with a temporary
    3094                 :             :    variable so that later inlining will work.  */
    3095                 :             : 
    3096                 :             : static int
    3097                 :     2292150 : matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
    3098                 :             :                     void *data)
    3099                 :             : {
    3100                 :     2292150 :   gfc_expr *e, *n;
    3101                 :     2292150 :   bool *found = (bool *) data;
    3102                 :             : 
    3103                 :     2292150 :   e = *ep;
    3104                 :             : 
    3105                 :     2292150 :   if (e->expr_type != EXPR_FUNCTION
    3106                 :      197017 :       || e->value.function.isym == NULL
    3107                 :      158302 :       || e->value.function.isym->id != GFC_ISYM_MATMUL)
    3108                 :             :     return 0;
    3109                 :             : 
    3110                 :        1003 :   if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    3111                 :        1001 :       || in_omp_atomic || in_where || in_assoc_list)
    3112                 :             :     return 0;
    3113                 :             : 
    3114                 :             :   /* Check if this is already in the form c = matmul(a,b).  */
    3115                 :             : 
    3116                 :         999 :   if ((*current_code)->expr2 == e)
    3117                 :             :     return 0;
    3118                 :             : 
    3119                 :         182 :   n = create_var (e, "matmul");
    3120                 :             : 
    3121                 :             :   /* If create_var is unable to create a variable (for example if
    3122                 :             :      -fno-realloc-lhs is in force with a variable that does not have bounds
    3123                 :             :      known at compile-time), just return.  */
    3124                 :             : 
    3125                 :         182 :   if (n == NULL)
    3126                 :             :     return 0;
    3127                 :             : 
    3128                 :         181 :   *ep = n;
    3129                 :         181 :   *found = true;
    3130                 :         181 :   return 0;
    3131                 :             : }
    3132                 :             : 
    3133                 :             : /* Set current_code and associated variables so that matmul_to_var_expr can
    3134                 :             :    work.  */
    3135                 :             : 
    3136                 :             : static int
    3137                 :      797940 : matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    3138                 :             :                     void *data ATTRIBUTE_UNUSED)
    3139                 :             : {
    3140                 :      797940 :   if (current_code != c)
    3141                 :             :     {
    3142                 :      786260 :       current_code = c;
    3143                 :      786260 :       inserted_block = NULL;
    3144                 :      786260 :       changed_statement = NULL;
    3145                 :             :     }
    3146                 :             : 
    3147                 :      797940 :   return 0;
    3148                 :             : }
    3149                 :             : 
    3150                 :             : 
    3151                 :             : /* Take a statement of the shape c = matmul(a,b) and create temporaries
    3152                 :             :    for a and b if there is a dependency between the arguments and the
    3153                 :             :    result variable or if a or b are the result of calculations that cannot
    3154                 :             :    be handled by the inliner.  */
    3155                 :             : 
    3156                 :             : static int
    3157                 :      795457 : matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    3158                 :             :                   void *data ATTRIBUTE_UNUSED)
    3159                 :             : {
    3160                 :      795457 :   gfc_expr *expr1, *expr2;
    3161                 :      795457 :   gfc_code *co;
    3162                 :      795457 :   gfc_actual_arglist *a, *b;
    3163                 :      795457 :   bool a_tmp, b_tmp;
    3164                 :      795457 :   gfc_expr *matrix_a, *matrix_b;
    3165                 :      795457 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    3166                 :             : 
    3167                 :      795457 :   co = *c;
    3168                 :             : 
    3169                 :      795457 :   if (co->op != EXEC_ASSIGN)
    3170                 :             :     return 0;
    3171                 :             : 
    3172                 :      163897 :   if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    3173                 :      161493 :       || in_omp_atomic || in_where)
    3174                 :             :     return 0;
    3175                 :             : 
    3176                 :             :   /* This has some duplication with inline_matmul_assign.  This
    3177                 :             :      is because the creation of temporary variables could still fail,
    3178                 :             :      and inline_matmul_assign still needs to be able to handle these
    3179                 :             :      cases.  */
    3180                 :      158249 :   expr1 = co->expr1;
    3181                 :      158249 :   expr2 = co->expr2;
    3182                 :             : 
    3183                 :      158249 :   if (expr2->expr_type != EXPR_FUNCTION
    3184                 :       26999 :       || expr2->value.function.isym == NULL
    3185                 :       19445 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    3186                 :             :     return 0;
    3187                 :             : 
    3188                 :         905 :   a_tmp = false;
    3189                 :         905 :   a = expr2->value.function.actual;
    3190                 :         905 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    3191                 :         905 :   if (matrix_a != NULL)
    3192                 :             :     {
    3193                 :         840 :       if (matrix_a->expr_type == EXPR_VARIABLE
    3194                 :         840 :           && (gfc_check_dependency (matrix_a, expr1, true)
    3195                 :         811 :               || gfc_has_dimen_vector_ref (matrix_a)))
    3196                 :             :         a_tmp = true;
    3197                 :             :     }
    3198                 :             :   else
    3199                 :             :     a_tmp = true;
    3200                 :             : 
    3201                 :         905 :   b_tmp = false;
    3202                 :         905 :   b = a->next;
    3203                 :         905 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    3204                 :         905 :   if (matrix_b != NULL)
    3205                 :             :     {
    3206                 :         837 :       if (matrix_b->expr_type == EXPR_VARIABLE
    3207                 :         837 :           && (gfc_check_dependency (matrix_b, expr1, true)
    3208                 :         829 :               || gfc_has_dimen_vector_ref (matrix_b)))
    3209                 :             :         b_tmp = true;
    3210                 :             :     }
    3211                 :             :   else
    3212                 :             :     b_tmp = true;
    3213                 :             : 
    3214                 :         905 :   if (!a_tmp && !b_tmp)
    3215                 :             :     return 0;
    3216                 :             : 
    3217                 :         149 :   current_code = c;
    3218                 :         149 :   inserted_block = NULL;
    3219                 :         149 :   changed_statement = NULL;
    3220                 :         149 :   if (a_tmp)
    3221                 :             :     {
    3222                 :          96 :       gfc_expr *at;
    3223                 :          96 :       at = create_var (a->expr,"mma");
    3224                 :          96 :       if (at)
    3225                 :          96 :         a->expr = at;
    3226                 :             :     }
    3227                 :         149 :   if (b_tmp)
    3228                 :             :     {
    3229                 :          77 :       gfc_expr *bt;
    3230                 :          77 :       bt = create_var (b->expr,"mmb");
    3231                 :          77 :       if (bt)
    3232                 :          77 :         b->expr = bt;
    3233                 :             :     }
    3234                 :             :   return 0;
    3235                 :             : }
    3236                 :             : 
    3237                 :             : /* Auxiliary function to build and simplify an array inquiry function.
    3238                 :             :    dim is zero-based.  */
    3239                 :             : 
    3240                 :             : static gfc_expr *
    3241                 :        8159 : get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
    3242                 :             : {
    3243                 :        8159 :   gfc_expr *fcn;
    3244                 :        8159 :   gfc_expr *dim_arg, *kind;
    3245                 :        8159 :   const char *name;
    3246                 :        8159 :   gfc_expr *ec;
    3247                 :             : 
    3248                 :        8159 :   switch (id)
    3249                 :             :     {
    3250                 :             :     case GFC_ISYM_LBOUND:
    3251                 :             :       name = "_gfortran_lbound";
    3252                 :             :       break;
    3253                 :             : 
    3254                 :           0 :     case GFC_ISYM_UBOUND:
    3255                 :           0 :       name = "_gfortran_ubound";
    3256                 :           0 :       break;
    3257                 :             : 
    3258                 :        4474 :     case GFC_ISYM_SIZE:
    3259                 :        4474 :       name = "_gfortran_size";
    3260                 :        4474 :       break;
    3261                 :             : 
    3262                 :           0 :     default:
    3263                 :           0 :       gcc_unreachable ();
    3264                 :             :     }
    3265                 :             : 
    3266                 :        8159 :   dim_arg =  gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
    3267                 :        8159 :   if (okind != 0)
    3268                 :         222 :     kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
    3269                 :             :                              okind);
    3270                 :             :   else
    3271                 :        7937 :     kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
    3272                 :             :                              gfc_index_integer_kind);
    3273                 :             : 
    3274                 :        8159 :   ec = gfc_copy_expr (e);
    3275                 :             : 
    3276                 :             :   /* No bounds checking, this will be done before the loops if -fcheck=bounds
    3277                 :             :      is in effect.  */
    3278                 :        8159 :   ec->no_bounds_check = 1;
    3279                 :        8159 :   fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
    3280                 :             :                                   ec, dim_arg,  kind);
    3281                 :        8159 :   gfc_simplify_expr (fcn, 0);
    3282                 :        8159 :   fcn->no_bounds_check = 1;
    3283                 :        8159 :   return fcn;
    3284                 :             : }
    3285                 :             : 
    3286                 :             : /* Builds a logical expression.  */
    3287                 :             : 
    3288                 :             : static gfc_expr*
    3289                 :        1524 : build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
    3290                 :             : {
    3291                 :        1524 :   gfc_typespec ts;
    3292                 :        1524 :   gfc_expr *res;
    3293                 :             : 
    3294                 :        1524 :   ts.type = BT_LOGICAL;
    3295                 :        1524 :   ts.kind = gfc_default_logical_kind;
    3296                 :        1524 :   res = gfc_get_expr ();
    3297                 :        1524 :   res->where = e1->where;
    3298                 :        1524 :   res->expr_type = EXPR_OP;
    3299                 :        1524 :   res->value.op.op = op;
    3300                 :        1524 :   res->value.op.op1 = e1;
    3301                 :        1524 :   res->value.op.op2 = e2;
    3302                 :        1524 :   res->ts = ts;
    3303                 :             : 
    3304                 :        1524 :   return res;
    3305                 :             : }
    3306                 :             : 
    3307                 :             : 
    3308                 :             : /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
    3309                 :             :    compatible typespecs.  */
    3310                 :             : 
    3311                 :             : static gfc_expr *
    3312                 :        7413 : get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
    3313                 :             : {
    3314                 :        7413 :   gfc_expr *res;
    3315                 :             : 
    3316                 :        7413 :   res = gfc_get_expr ();
    3317                 :        7413 :   res->ts = e1->ts;
    3318                 :        7413 :   res->where = e1->where;
    3319                 :        7413 :   res->expr_type = EXPR_OP;
    3320                 :        7413 :   res->value.op.op = op;
    3321                 :        7413 :   res->value.op.op1 = e1;
    3322                 :        7413 :   res->value.op.op2 = e2;
    3323                 :        7413 :   gfc_simplify_expr (res, 0);
    3324                 :        7413 :   return res;
    3325                 :             : }
    3326                 :             : 
    3327                 :             : /* Generate the IF statement for a runtime check if we want to do inlining or
    3328                 :             :    not - putting in the code for both branches and putting it into the syntax
    3329                 :             :    tree is the caller's responsibility.  For fixed array sizes, this should be
    3330                 :             :    removed by DCE. Only called for rank-two matrices A and B.  */
    3331                 :             : 
    3332                 :             : static gfc_code *
    3333                 :         646 : inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a)
    3334                 :             : {
    3335                 :         646 :   gfc_expr *inline_limit;
    3336                 :         646 :   gfc_code *if_1, *if_2, *else_2;
    3337                 :         646 :   gfc_expr *b2, *a2, *a1, *m1, *m2;
    3338                 :         646 :   gfc_typespec ts;
    3339                 :         646 :   gfc_expr *cond;
    3340                 :             : 
    3341                 :         646 :   gcc_assert (rank_a == 1 || rank_a == 2);
    3342                 :             : 
    3343                 :             :   /* Calculation is done in real to avoid integer overflow.  */
    3344                 :             : 
    3345                 :         646 :   inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
    3346                 :             :                                         &a->where);
    3347                 :         646 :   mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
    3348                 :             : 
    3349                 :             :   /* Set the limit according to the rank.  */
    3350                 :         646 :   mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1,
    3351                 :             :                GFC_RND_MODE);
    3352                 :             : 
    3353                 :         646 :   a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3354                 :             : 
    3355                 :             :   /* For a_rank = 1, must use one as the size of a along the second
    3356                 :             :      dimension as to avoid too much code duplication.  */
    3357                 :             : 
    3358                 :         646 :   if (rank_a == 2)
    3359                 :         539 :     a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3360                 :             :   else
    3361                 :         107 :     a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1);
    3362                 :             : 
    3363                 :         646 :   b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3364                 :             : 
    3365                 :         646 :   gfc_clear_ts (&ts);
    3366                 :         646 :   ts.type = BT_REAL;
    3367                 :         646 :   ts.kind = gfc_default_real_kind;
    3368                 :         646 :   gfc_convert_type_warn (a1, &ts, 2, 0);
    3369                 :         646 :   gfc_convert_type_warn (a2, &ts, 2, 0);
    3370                 :         646 :   gfc_convert_type_warn (b2, &ts, 2, 0);
    3371                 :             : 
    3372                 :         646 :   m1 = get_operand (INTRINSIC_TIMES, a1, a2);
    3373                 :         646 :   m2 = get_operand (INTRINSIC_TIMES, m1, b2);
    3374                 :             : 
    3375                 :         646 :   cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
    3376                 :         646 :   gfc_simplify_expr (cond, 0);
    3377                 :             : 
    3378                 :         646 :   else_2 = XCNEW (gfc_code);
    3379                 :         646 :   else_2->op = EXEC_IF;
    3380                 :         646 :   else_2->loc = a->where;
    3381                 :             : 
    3382                 :         646 :   if_2 = XCNEW (gfc_code);
    3383                 :         646 :   if_2->op = EXEC_IF;
    3384                 :         646 :   if_2->expr1 = cond;
    3385                 :         646 :   if_2->loc = a->where;
    3386                 :         646 :   if_2->block = else_2;
    3387                 :             : 
    3388                 :         646 :   if_1 = XCNEW (gfc_code);
    3389                 :         646 :   if_1->op = EXEC_IF;
    3390                 :         646 :   if_1->block = if_2;
    3391                 :         646 :   if_1->loc = a->where;
    3392                 :             : 
    3393                 :         646 :   return if_1;
    3394                 :             : }
    3395                 :             : 
    3396                 :             : 
    3397                 :             : /* Insert code to issue a runtime error if the expressions are not equal.  */
    3398                 :             : 
    3399                 :             : static gfc_code *
    3400                 :         401 : runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
    3401                 :             : {
    3402                 :         401 :   gfc_expr *cond;
    3403                 :         401 :   gfc_code *if_1, *if_2;
    3404                 :         401 :   gfc_code *c;
    3405                 :         401 :   gfc_actual_arglist *a1, *a2, *a3;
    3406                 :             : 
    3407                 :         401 :   gcc_assert (e1->where.lb);
    3408                 :             :   /* Build the call to runtime_error.  */
    3409                 :         401 :   c = XCNEW (gfc_code);
    3410                 :         401 :   c->op = EXEC_CALL;
    3411                 :         401 :   c->loc = e1->where;
    3412                 :             : 
    3413                 :             :   /* Get a null-terminated message string.  */
    3414                 :             : 
    3415                 :         401 :   a1 = gfc_get_actual_arglist ();
    3416                 :         802 :   a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
    3417                 :         401 :                                      msg, strlen(msg)+1);
    3418                 :         401 :   c->ext.actual = a1;
    3419                 :             : 
    3420                 :             :   /* Pass the value of the first expression.  */
    3421                 :         401 :   a2 = gfc_get_actual_arglist ();
    3422                 :         401 :   a2->expr = gfc_copy_expr (e1);
    3423                 :         401 :   a1->next = a2;
    3424                 :             : 
    3425                 :             :   /* Pass the value of the second expression.  */
    3426                 :         401 :   a3 = gfc_get_actual_arglist ();
    3427                 :         401 :   a3->expr = gfc_copy_expr (e2);
    3428                 :         401 :   a2->next = a3;
    3429                 :             : 
    3430                 :         401 :   gfc_check_fe_runtime_error (c->ext.actual);
    3431                 :         401 :   gfc_resolve_fe_runtime_error (c);
    3432                 :             : 
    3433                 :         401 :   if_2 = XCNEW (gfc_code);
    3434                 :         401 :   if_2->op = EXEC_IF;
    3435                 :         401 :   if_2->loc = e1->where;
    3436                 :         401 :   if_2->next = c;
    3437                 :             : 
    3438                 :         401 :   if_1 = XCNEW (gfc_code);
    3439                 :         401 :   if_1->op = EXEC_IF;
    3440                 :         401 :   if_1->block = if_2;
    3441                 :         401 :   if_1->loc = e1->where;
    3442                 :             : 
    3443                 :         401 :   cond = build_logical_expr (INTRINSIC_NE, e1, e2);
    3444                 :         401 :   gfc_simplify_expr (cond, 0);
    3445                 :         401 :   if_2->expr1 = cond;
    3446                 :             : 
    3447                 :         401 :   return if_1;
    3448                 :             : }
    3449                 :             : 
    3450                 :             : /* Handle matrix reallocation.  Caller is responsible to insert into
    3451                 :             :    the code tree.
    3452                 :             : 
    3453                 :             :    For the two-dimensional case, build
    3454                 :             : 
    3455                 :             :   if (allocated(c)) then
    3456                 :             :      if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
    3457                 :             :         deallocate(c)
    3458                 :             :         allocate (c(size(a,1), size(b,2)))
    3459                 :             :      end if
    3460                 :             :   else
    3461                 :             :      allocate (c(size(a,1),size(b,2)))
    3462                 :             :   end if
    3463                 :             : 
    3464                 :             :   and for the other cases correspondingly.
    3465                 :             : */
    3466                 :             : 
    3467                 :             : static gfc_code *
    3468                 :         203 : matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
    3469                 :             :                     enum matrix_case m_case)
    3470                 :             : {
    3471                 :             : 
    3472                 :         203 :   gfc_expr *allocated, *alloc_expr;
    3473                 :         203 :   gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
    3474                 :         203 :   gfc_code *else_alloc;
    3475                 :         203 :   gfc_code *deallocate, *allocate1, *allocate_else;
    3476                 :         203 :   gfc_array_ref *ar;
    3477                 :         203 :   gfc_expr *cond, *ne1, *ne2;
    3478                 :             : 
    3479                 :         203 :   if (warn_realloc_lhs)
    3480                 :          33 :     gfc_warning (OPT_Wrealloc_lhs,
    3481                 :             :                  "Code for reallocating the allocatable array at %L will "
    3482                 :             :                  "be added", &c->where);
    3483                 :             : 
    3484                 :         203 :   alloc_expr = gfc_copy_expr (c);
    3485                 :             : 
    3486                 :         203 :   ar = gfc_find_array_ref (alloc_expr);
    3487                 :         203 :   gcc_assert (ar && ar->type == AR_FULL);
    3488                 :             : 
    3489                 :             :   /* c comes in as a full ref.  Change it into a copy and make it into an
    3490                 :             :      element ref so it has the right form for ALLOCATE.  In the same
    3491                 :             :      switch statement, also generate the size comparison for the secod IF
    3492                 :             :      statement.  */
    3493                 :             : 
    3494                 :         203 :   ar->type = AR_ELEMENT;
    3495                 :             : 
    3496                 :         203 :   switch (m_case)
    3497                 :             :     {
    3498                 :         106 :     case A2B2:
    3499                 :         106 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3500                 :         106 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3501                 :         106 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3502                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3503                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    3504                 :         106 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3505                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3506                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3507                 :         106 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3508                 :         106 :       break;
    3509                 :             : 
    3510                 :          17 :     case A2B2T:
    3511                 :          17 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3512                 :          17 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
    3513                 :             : 
    3514                 :          17 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3515                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3516                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    3517                 :          17 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3518                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3519                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
    3520                 :          17 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3521                 :          17 :       break;
    3522                 :             : 
    3523                 :          14 :     case A2TB2:
    3524                 :             : 
    3525                 :          14 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3526                 :          14 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3527                 :             : 
    3528                 :          14 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3529                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3530                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3531                 :          14 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3532                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3533                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3534                 :          14 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3535                 :          14 :       break;
    3536                 :             : 
    3537                 :          50 :     case A2B1:
    3538                 :          50 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3539                 :          50 :       cond = build_logical_expr (INTRINSIC_NE,
    3540                 :             :                                  get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3541                 :             :                                  get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3542                 :          50 :       break;
    3543                 :             : 
    3544                 :          16 :     case A1B2:
    3545                 :          16 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3546                 :          16 :       cond = build_logical_expr (INTRINSIC_NE,
    3547                 :             :                                  get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3548                 :             :                                  get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3549                 :          16 :       break;
    3550                 :             : 
    3551                 :           0 :     case A2TB2T:
    3552                 :             :       /* This can only happen for BLAS, we do not handle that case in
    3553                 :             :          inline mamtul.  */
    3554                 :           0 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3555                 :           0 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
    3556                 :             : 
    3557                 :           0 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3558                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3559                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3560                 :           0 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3561                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3562                 :             :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
    3563                 :             : 
    3564                 :           0 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3565                 :           0 :       break;
    3566                 :             : 
    3567                 :           0 :     default:
    3568                 :           0 :       gcc_unreachable();
    3569                 :             : 
    3570                 :             :     }
    3571                 :             : 
    3572                 :         203 :   gfc_simplify_expr (cond, 0);
    3573                 :             : 
    3574                 :             :   /* We need two identical allocate statements in two
    3575                 :             :      branches of the IF statement.  */
    3576                 :             : 
    3577                 :         203 :   allocate1 = XCNEW (gfc_code);
    3578                 :         203 :   allocate1->op = EXEC_ALLOCATE;
    3579                 :         203 :   allocate1->ext.alloc.list = gfc_get_alloc ();
    3580                 :         203 :   allocate1->loc = c->where;
    3581                 :         203 :   allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
    3582                 :             : 
    3583                 :         203 :   allocate_else = XCNEW (gfc_code);
    3584                 :         203 :   allocate_else->op = EXEC_ALLOCATE;
    3585                 :         203 :   allocate_else->ext.alloc.list = gfc_get_alloc ();
    3586                 :         203 :   allocate_else->loc = c->where;
    3587                 :         203 :   allocate_else->ext.alloc.list->expr = alloc_expr;
    3588                 :             : 
    3589                 :         203 :   allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
    3590                 :             :                                         "_gfortran_allocated", c->where,
    3591                 :             :                                         1, gfc_copy_expr (c));
    3592                 :             : 
    3593                 :         203 :   deallocate = XCNEW (gfc_code);
    3594                 :         203 :   deallocate->op = EXEC_DEALLOCATE;
    3595                 :         203 :   deallocate->ext.alloc.list = gfc_get_alloc ();
    3596                 :         203 :   deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
    3597                 :         203 :   deallocate->next = allocate1;
    3598                 :         203 :   deallocate->loc = c->where;
    3599                 :             : 
    3600                 :         203 :   if_size_2 = XCNEW (gfc_code);
    3601                 :         203 :   if_size_2->op = EXEC_IF;
    3602                 :         203 :   if_size_2->expr1 = cond;
    3603                 :         203 :   if_size_2->loc = c->where;
    3604                 :         203 :   if_size_2->next = deallocate;
    3605                 :             : 
    3606                 :         203 :   if_size_1 = XCNEW (gfc_code);
    3607                 :         203 :   if_size_1->op = EXEC_IF;
    3608                 :         203 :   if_size_1->block = if_size_2;
    3609                 :         203 :   if_size_1->loc = c->where;
    3610                 :             : 
    3611                 :         203 :   else_alloc = XCNEW (gfc_code);
    3612                 :         203 :   else_alloc->op = EXEC_IF;
    3613                 :         203 :   else_alloc->loc = c->where;
    3614                 :         203 :   else_alloc->next = allocate_else;
    3615                 :             : 
    3616                 :         203 :   if_alloc_2 = XCNEW (gfc_code);
    3617                 :         203 :   if_alloc_2->op = EXEC_IF;
    3618                 :         203 :   if_alloc_2->expr1 = allocated;
    3619                 :         203 :   if_alloc_2->loc = c->where;
    3620                 :         203 :   if_alloc_2->next = if_size_1;
    3621                 :         203 :   if_alloc_2->block = else_alloc;
    3622                 :             : 
    3623                 :         203 :   if_alloc_1 = XCNEW (gfc_code);
    3624                 :         203 :   if_alloc_1->op = EXEC_IF;
    3625                 :         203 :   if_alloc_1->block = if_alloc_2;
    3626                 :         203 :   if_alloc_1->loc = c->where;
    3627                 :             : 
    3628                 :         203 :   return if_alloc_1;
    3629                 :             : }
    3630                 :             : 
    3631                 :             : /* Callback function for has_function_or_op.  */
    3632                 :             : 
    3633                 :             : static int
    3634                 :         675 : is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    3635                 :             :              void *data ATTRIBUTE_UNUSED)
    3636                 :             : {
    3637                 :         675 :   if ((*e) == 0)
    3638                 :             :     return 0;
    3639                 :             :   else
    3640                 :         675 :     return (*e)->expr_type == EXPR_FUNCTION
    3641                 :         675 :       || (*e)->expr_type == EXPR_OP;
    3642                 :             : }
    3643                 :             : 
    3644                 :             : /* Returns true if the expression contains a function.  */
    3645                 :             : 
    3646                 :             : static bool
    3647                 :        1306 : has_function_or_op (gfc_expr **e)
    3648                 :             : {
    3649                 :        1306 :   if (e == NULL)
    3650                 :             :     return false;
    3651                 :             :   else
    3652                 :        1306 :     return gfc_expr_walker (e, is_function_or_op, NULL);
    3653                 :             : }
    3654                 :             : 
    3655                 :             : /* Freeze (assign to a temporary variable) a single expression.  */
    3656                 :             : 
    3657                 :             : static void
    3658                 :        1306 : freeze_expr (gfc_expr **ep)
    3659                 :             : {
    3660                 :        1306 :   gfc_expr *ne;
    3661                 :        1306 :   if (has_function_or_op (ep))
    3662                 :             :     {
    3663                 :         195 :       ne = create_var (*ep, "freeze");
    3664                 :         195 :       *ep = ne;
    3665                 :             :     }
    3666                 :        1306 : }
    3667                 :             : 
    3668                 :             : /* Go through an expression's references and assign them to temporary
    3669                 :             :    variables if they contain functions.  This is usually done prior to
    3670                 :             :    front-end scalarization to avoid multiple invocations of functions.  */
    3671                 :             : 
    3672                 :             : static void
    3673                 :        2223 : freeze_references (gfc_expr *e)
    3674                 :             : {
    3675                 :        2223 :   gfc_ref *r;
    3676                 :        2223 :   gfc_array_ref *ar;
    3677                 :        2223 :   int i;
    3678                 :             : 
    3679                 :        4451 :   for (r=e->ref; r; r=r->next)
    3680                 :             :     {
    3681                 :        2228 :       if (r->type == REF_SUBSTRING)
    3682                 :             :         {
    3683                 :           0 :           if (r->u.ss.start != NULL)
    3684                 :           0 :             freeze_expr (&r->u.ss.start);
    3685                 :             : 
    3686                 :           0 :           if (r->u.ss.end != NULL)
    3687                 :           0 :             freeze_expr (&r->u.ss.end);
    3688                 :             :         }
    3689                 :        2228 :       else if (r->type == REF_ARRAY)
    3690                 :             :         {
    3691                 :        2223 :           ar = &r->u.ar;
    3692                 :        2223 :           switch (ar->type)
    3693                 :             :             {
    3694                 :             :             case AR_FULL:
    3695                 :             :               break;
    3696                 :             : 
    3697                 :             :             case AR_SECTION:
    3698                 :         700 :               for (i=0; i<ar->dimen; i++)
    3699                 :             :                 {
    3700                 :         456 :                   if (ar->dimen_type[i] == DIMEN_RANGE)
    3701                 :             :                     {
    3702                 :         425 :                       freeze_expr (&ar->start[i]);
    3703                 :         425 :                       freeze_expr (&ar->end[i]);
    3704                 :         425 :                       freeze_expr (&ar->stride[i]);
    3705                 :             :                     }
    3706                 :          31 :                   else if (ar->dimen_type[i] == DIMEN_ELEMENT)
    3707                 :             :                     {
    3708                 :          31 :                       freeze_expr (&ar->start[i]);
    3709                 :             :                     }
    3710                 :             :                 }
    3711                 :             :               break;
    3712                 :             : 
    3713                 :             :             case AR_ELEMENT:
    3714                 :           0 :               for (i=0; i<ar->dimen; i++)
    3715                 :           0 :                 freeze_expr (&ar->start[i]);
    3716                 :             :               break;
    3717                 :             : 
    3718                 :             :             default:
    3719                 :             :               break;
    3720                 :             :             }
    3721                 :             :         }
    3722                 :             :     }
    3723                 :        2223 : }
    3724                 :             : 
    3725                 :             : /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise.  */
    3726                 :             : 
    3727                 :             : static gfc_expr *
    3728                 :        3968 : convert_to_index_kind (gfc_expr *e)
    3729                 :             : {
    3730                 :        3968 :   gfc_expr *res;
    3731                 :             : 
    3732                 :        3968 :   gcc_assert (e != NULL);
    3733                 :             : 
    3734                 :        3968 :   res = gfc_copy_expr (e);
    3735                 :             : 
    3736                 :        3968 :   gcc_assert (e->ts.type == BT_INTEGER);
    3737                 :             : 
    3738                 :        3968 :   if (res->ts.kind != gfc_index_integer_kind)
    3739                 :             :     {
    3740                 :           0 :       gfc_typespec ts;
    3741                 :           0 :       gfc_clear_ts (&ts);
    3742                 :           0 :       ts.type = BT_INTEGER;
    3743                 :           0 :       ts.kind = gfc_index_integer_kind;
    3744                 :             : 
    3745                 :           0 :       gfc_convert_type_warn (e, &ts, 2, 0);
    3746                 :             :     }
    3747                 :             : 
    3748                 :        3968 :   return res;
    3749                 :             : }
    3750                 :             : 
    3751                 :             : /* Function to create a DO loop including creation of the
    3752                 :             :    iteration variable.  gfc_expr are copied.*/
    3753                 :             : 
    3754                 :             : static gfc_code *
    3755                 :        1984 : create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
    3756                 :             :                 gfc_namespace *ns, char *vname)
    3757                 :             : {
    3758                 :             : 
    3759                 :        1984 :   char name[GFC_MAX_SYMBOL_LEN +1];
    3760                 :        1984 :   gfc_symtree *symtree;
    3761                 :        1984 :   gfc_symbol *symbol;
    3762                 :        1984 :   gfc_expr *i;
    3763                 :        1984 :   gfc_code *n, *n2;
    3764                 :             : 
    3765                 :             :   /* Create an expression for the iteration variable.  */
    3766                 :        1984 :   if (vname)
    3767                 :           0 :     sprintf (name, "__var_%d_do_%s", var_num++, vname);
    3768                 :             :   else
    3769                 :        1984 :     sprintf (name, "__var_%d_do", var_num++);
    3770                 :             : 
    3771                 :             : 
    3772                 :        1984 :   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
    3773                 :           0 :     gcc_unreachable ();
    3774                 :             : 
    3775                 :             :   /* Create the loop variable.  */
    3776                 :             : 
    3777                 :        1984 :   symbol = symtree->n.sym;
    3778                 :        1984 :   symbol->ts.type = BT_INTEGER;
    3779                 :        1984 :   symbol->ts.kind = gfc_index_integer_kind;
    3780                 :        1984 :   symbol->attr.flavor = FL_VARIABLE;
    3781                 :        1984 :   symbol->attr.referenced = 1;
    3782                 :        1984 :   symbol->attr.dimension = 0;
    3783                 :        1984 :   symbol->attr.fe_temp = 1;
    3784                 :        1984 :   gfc_commit_symbol (symbol);
    3785                 :             : 
    3786                 :        1984 :   i = gfc_get_expr ();
    3787                 :        1984 :   i->expr_type = EXPR_VARIABLE;
    3788                 :        1984 :   i->ts = symbol->ts;
    3789                 :        1984 :   i->rank = 0;
    3790                 :        1984 :   i->where = *where;
    3791                 :        1984 :   i->symtree = symtree;
    3792                 :             : 
    3793                 :             :   /* ... and the nested DO statements.  */
    3794                 :        1984 :   n = XCNEW (gfc_code);
    3795                 :        1984 :   n->op = EXEC_DO;
    3796                 :        1984 :   n->loc = *where;
    3797                 :        1984 :   n->ext.iterator = gfc_get_iterator ();
    3798                 :        1984 :   n->ext.iterator->var = i;
    3799                 :        1984 :   n->ext.iterator->start = convert_to_index_kind (start);
    3800                 :        1984 :   n->ext.iterator->end = convert_to_index_kind (end);
    3801                 :        1984 :   if (step)
    3802                 :           0 :     n->ext.iterator->step = convert_to_index_kind (step);
    3803                 :             :   else
    3804                 :        1984 :     n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
    3805                 :             :                                               where, 1);
    3806                 :             : 
    3807                 :        1984 :   n2 = XCNEW (gfc_code);
    3808                 :        1984 :   n2->op = EXEC_DO;
    3809                 :        1984 :   n2->loc = *where;
    3810                 :        1984 :   n2->next = NULL;
    3811                 :        1984 :   n->block = n2;
    3812                 :        1984 :   return n;
    3813                 :             : }
    3814                 :             : 
    3815                 :             : /* Get the upper bound of the DO loops for matmul along a dimension.  This
    3816                 :             :  is one-based.  */
    3817                 :             : 
    3818                 :             : static gfc_expr*
    3819                 :        1984 : get_size_m1 (gfc_expr *e, int dimen)
    3820                 :             : {
    3821                 :        1984 :   mpz_t size;
    3822                 :        1984 :   gfc_expr *res;
    3823                 :             : 
    3824                 :        1984 :   if (gfc_array_dimen_size (e, dimen - 1, &size))
    3825                 :             :     {
    3826                 :        1385 :       res = gfc_get_constant_expr (BT_INTEGER,
    3827                 :             :                                    gfc_index_integer_kind, &e->where);
    3828                 :        1385 :       mpz_sub_ui (res->value.integer, size, 1);
    3829                 :        1385 :       mpz_clear (size);
    3830                 :             :     }
    3831                 :             :   else
    3832                 :             :     {
    3833                 :         599 :       res = get_operand (INTRINSIC_MINUS,
    3834                 :             :                          get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
    3835                 :             :                          gfc_get_int_expr (gfc_index_integer_kind,
    3836                 :             :                                            &e->where, 1));
    3837                 :         599 :       gfc_simplify_expr (res, 0);
    3838                 :             :     }
    3839                 :             : 
    3840                 :        1984 :   return res;
    3841                 :             : }
    3842                 :             : 
    3843                 :             : /* Function to return a scalarized expression. It is assumed that indices are
    3844                 :             :  zero based to make generation of DO loops easier.  A zero as index will
    3845                 :             :  access the first element along a dimension.  Single element references will
    3846                 :             :  be skipped.  A NULL as an expression will be replaced by a full reference.
    3847                 :             :  This assumes that the index loops have gfc_index_integer_kind, and that all
    3848                 :             :  references have been frozen.  */
    3849                 :             : 
    3850                 :             : static gfc_expr*
    3851                 :        2223 : scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
    3852                 :             : {
    3853                 :        2223 :   gfc_array_ref *ar;
    3854                 :        2223 :   int i;
    3855                 :        2223 :   int rank;
    3856                 :        2223 :   gfc_expr *e;
    3857                 :        2223 :   int i_index;
    3858                 :        2223 :   bool was_fullref;
    3859                 :             : 
    3860                 :        2223 :   e = gfc_copy_expr(e_in);
    3861                 :             : 
    3862                 :        2223 :   rank = e->rank;
    3863                 :             : 
    3864                 :        2223 :   ar = gfc_find_array_ref (e);
    3865                 :             : 
    3866                 :             :   /* We scalarize count_index variables, reducing the rank by count_index.  */
    3867                 :             : 
    3868                 :        2223 :   e->rank = rank - count_index;
    3869                 :             : 
    3870                 :        2223 :   was_fullref = ar->type == AR_FULL;
    3871                 :             : 
    3872                 :        2223 :   if (e->rank == 0)
    3873                 :        2223 :     ar->type = AR_ELEMENT;
    3874                 :             :   else
    3875                 :           0 :     ar->type = AR_SECTION;
    3876                 :             : 
    3877                 :             :   /* Loop over the indices.  For each index, create the expression
    3878                 :             :      index * stride + lbound(e, dim).  */
    3879                 :             : 
    3880                 :             :   i_index = 0;
    3881                 :        6222 :   for (i=0; i < ar->dimen; i++)
    3882                 :             :     {
    3883                 :        3999 :       if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
    3884                 :             :         {
    3885                 :        3968 :           if (index[i_index] != NULL)
    3886                 :             :             {
    3887                 :        3968 :               gfc_expr *lbound, *nindex;
    3888                 :        3968 :               gfc_expr *loopvar;
    3889                 :             : 
    3890                 :        3968 :               loopvar = gfc_copy_expr (index[i_index]);
    3891                 :             : 
    3892                 :        3968 :               if (ar->stride[i])
    3893                 :             :                 {
    3894                 :          72 :                   gfc_expr *tmp;
    3895                 :             : 
    3896                 :          72 :                   tmp = gfc_copy_expr(ar->stride[i]);
    3897                 :          72 :                   if (tmp->ts.kind != gfc_index_integer_kind)
    3898                 :             :                     {
    3899                 :           0 :                       gfc_typespec ts;
    3900                 :           0 :                       gfc_clear_ts (&ts);
    3901                 :           0 :                       ts.type = BT_INTEGER;
    3902                 :           0 :                       ts.kind = gfc_index_integer_kind;
    3903                 :           0 :                       gfc_convert_type (tmp, &ts, 2);
    3904                 :             :                     }
    3905                 :          72 :                   nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
    3906                 :             :                 }
    3907                 :             :               else
    3908                 :             :                 nindex = loopvar;
    3909                 :             : 
    3910                 :             :               /* Calculate the lower bound of the expression.  */
    3911                 :        3968 :               if (ar->start[i])
    3912                 :             :                 {
    3913                 :         283 :                   lbound = gfc_copy_expr (ar->start[i]);
    3914                 :         283 :                   if (lbound->ts.kind != gfc_index_integer_kind)
    3915                 :             :                     {
    3916                 :         283 :                       gfc_typespec ts;
    3917                 :         283 :                       gfc_clear_ts (&ts);
    3918                 :         283 :                       ts.type = BT_INTEGER;
    3919                 :         283 :                       ts.kind = gfc_index_integer_kind;
    3920                 :         283 :                       gfc_convert_type (lbound, &ts, 2);
    3921                 :             : 
    3922                 :             :                     }
    3923                 :             :                 }
    3924                 :             :               else
    3925                 :             :                 {
    3926                 :        3685 :                   gfc_expr *lbound_e;
    3927                 :        3685 :                   gfc_ref *ref;
    3928                 :             : 
    3929                 :        3685 :                   lbound_e = gfc_copy_expr (e_in);
    3930                 :             : 
    3931                 :        3685 :                   for (ref = lbound_e->ref; ref; ref = ref->next)
    3932                 :        3685 :                     if (ref->type == REF_ARRAY
    3933                 :        3685 :                         && (ref->u.ar.type == AR_FULL
    3934                 :         142 :                             || ref->u.ar.type == AR_SECTION))
    3935                 :             :                       break;
    3936                 :             : 
    3937                 :        3685 :                   if (ref->next)
    3938                 :             :                     {
    3939                 :           9 :                       gfc_free_ref_list (ref->next);
    3940                 :           9 :                       ref->next = NULL;
    3941                 :             :                     }
    3942                 :             : 
    3943                 :        3685 :                   if (!was_fullref)
    3944                 :             :                     {
    3945                 :             :                       /* Look at full individual sections, like a(:).  The first index
    3946                 :             :                          is the lbound of a full ref.  */
    3947                 :         142 :                       int j;
    3948                 :         142 :                       gfc_array_ref *ar;
    3949                 :         142 :                       int to;
    3950                 :             : 
    3951                 :         142 :                       ar = &ref->u.ar;
    3952                 :             : 
    3953                 :             :                       /* For assumed size, we need to keep around the final
    3954                 :             :                          reference in order not to get an error on resolution
    3955                 :             :                          below, and we cannot use AR_FULL.  */
    3956                 :             : 
    3957                 :         142 :                       if (ar->as->type == AS_ASSUMED_SIZE)
    3958                 :             :                         {
    3959                 :           2 :                           ar->type = AR_SECTION;
    3960                 :           2 :                           to = ar->dimen - 1;
    3961                 :             :                         }
    3962                 :             :                       else
    3963                 :             :                         {
    3964                 :         140 :                           to = ar->dimen;
    3965                 :         140 :                           ar->type = AR_FULL;
    3966                 :             :                         }
    3967                 :             : 
    3968                 :         430 :                       for (j = 0; j < to; j++)
    3969                 :             :                         {
    3970                 :         288 :                           gfc_free_expr (ar->start[j]);
    3971                 :         288 :                           ar->start[j] = NULL;
    3972                 :         288 :                           gfc_free_expr (ar->end[j]);
    3973                 :         288 :                           ar->end[j] = NULL;
    3974                 :         288 :                           gfc_free_expr (ar->stride[j]);
    3975                 :         288 :                           ar->stride[j] = NULL;
    3976                 :             :                         }
    3977                 :             : 
    3978                 :             :                       /* We have to get rid of the shape, if there is one.  Do
    3979                 :             :                          so by freeing it and calling gfc_resolve to rebuild
    3980                 :             :                          it, if necessary.  */
    3981                 :             : 
    3982                 :         142 :                       if (lbound_e->shape)
    3983                 :          48 :                         gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
    3984                 :             : 
    3985                 :         142 :                       lbound_e->rank = ar->dimen;
    3986                 :         142 :                       gfc_resolve_expr (lbound_e);
    3987                 :             :                     }
    3988                 :        3685 :                   lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
    3989                 :             :                                                    i + 1);
    3990                 :        3685 :                   gfc_free_expr (lbound_e);
    3991                 :             :                 }
    3992                 :             : 
    3993                 :        3968 :               ar->dimen_type[i] = DIMEN_ELEMENT;
    3994                 :             : 
    3995                 :        3968 :               gfc_free_expr (ar->start[i]);
    3996                 :        3968 :               ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
    3997                 :             : 
    3998                 :        3968 :               gfc_free_expr (ar->end[i]);
    3999                 :        3968 :               ar->end[i] = NULL;
    4000                 :        3968 :               gfc_free_expr (ar->stride[i]);
    4001                 :        3968 :               ar->stride[i] = NULL;
    4002                 :        3968 :               gfc_simplify_expr (ar->start[i], 0);
    4003                 :             :             }
    4004                 :           0 :           else if (was_fullref)
    4005                 :             :             {
    4006                 :           0 :               gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
    4007                 :             :             }
    4008                 :        3968 :           i_index ++;
    4009                 :             :         }
    4010                 :             :     }
    4011                 :             : 
    4012                 :             :   /* Bounds checking will be done before the loops if -fcheck=bounds
    4013                 :             :      is in effect. */
    4014                 :        2223 :   e->no_bounds_check = 1;
    4015                 :        2223 :   return e;
    4016                 :             : }
    4017                 :             : 
    4018                 :             : /* Helper function to check for a dimen vector as subscript.  */
    4019                 :             : 
    4020                 :             : bool
    4021                 :        4259 : gfc_has_dimen_vector_ref (gfc_expr *e)
    4022                 :             : {
    4023                 :        4259 :   gfc_array_ref *ar;
    4024                 :        4259 :   int i;
    4025                 :             : 
    4026                 :        4259 :   ar = gfc_find_array_ref (e);
    4027                 :        4259 :   gcc_assert (ar);
    4028                 :        4259 :   if (ar->type == AR_FULL)
    4029                 :             :     return false;
    4030                 :             : 
    4031                 :        1938 :   for (i=0; i<ar->dimen; i++)
    4032                 :        1234 :     if (ar->dimen_type[i] == DIMEN_VECTOR)
    4033                 :             :       return true;
    4034                 :             : 
    4035                 :             :   return false;
    4036                 :             : }
    4037                 :             : 
    4038                 :             : /* If handed an expression of the form
    4039                 :             : 
    4040                 :             :    TRANSPOSE(CONJG(A))
    4041                 :             : 
    4042                 :             :    check if A can be handled by matmul and return if there is an uneven number
    4043                 :             :    of CONJG calls.  Return a pointer to the array when everything is OK, NULL
    4044                 :             :    otherwise. The caller has to check for the correct rank.  */
    4045                 :             : 
    4046                 :             : static gfc_expr*
    4047                 :        3394 : check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
    4048                 :             : {
    4049                 :        3394 :   *conjg = false;
    4050                 :        3394 :   *transpose = false;
    4051                 :             : 
    4052                 :        4234 :   do
    4053                 :             :     {
    4054                 :        3814 :       if (e->expr_type == EXPR_VARIABLE)
    4055                 :             :         {
    4056                 :        3261 :           gcc_assert (e->rank == 1 || e->rank == 2);
    4057                 :             :           return e;
    4058                 :             :         }
    4059                 :         553 :       else if (e->expr_type == EXPR_FUNCTION)
    4060                 :             :         {
    4061                 :         505 :           if (e->value.function.isym == NULL)
    4062                 :             :             return NULL;
    4063                 :             : 
    4064                 :         482 :           if (e->value.function.isym->id == GFC_ISYM_CONJG)
    4065                 :          68 :             *conjg = !*conjg;
    4066                 :         414 :           else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
    4067                 :         352 :             *transpose = !*transpose;
    4068                 :             :           else return NULL;
    4069                 :             :         }
    4070                 :             :       else
    4071                 :             :         return NULL;
    4072                 :             : 
    4073                 :         420 :       e = e->value.function.actual->expr;
    4074                 :             :     }
    4075                 :             :   while(1);
    4076                 :             : 
    4077                 :             :   return NULL;
    4078                 :             : }
    4079                 :             : 
    4080                 :             : /* Macros for unified error messages.  */
    4081                 :             : 
    4082                 :             : #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
    4083                 :             :                      "dimension 1: is %ld, should be %ld")
    4084                 :             : 
    4085                 :             : #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
    4086                 :             :                     "(%ld/%ld)")
    4087                 :             : 
    4088                 :             : #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
    4089                 :             :                     "(%ld/%ld)")
    4090                 :             : 
    4091                 :             : 
    4092                 :             : /* Inline assignments of the form c = matmul(a,b).
    4093                 :             :    Handle only the cases currently where b and c are rank-two arrays.
    4094                 :             : 
    4095                 :             :    This basically translates the code to
    4096                 :             : 
    4097                 :             :    BLOCK
    4098                 :             :      integer i,j,k
    4099                 :             :      c = 0
    4100                 :             :      do j=0, size(b,2)-1
    4101                 :             :        do k=0, size(a, 2)-1
    4102                 :             :          do i=0, size(a, 1)-1
    4103                 :             :             c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
    4104                 :             :             c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
    4105                 :             :             a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
    4106                 :             :             b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
    4107                 :             :          end do
    4108                 :             :        end do
    4109                 :             :      end do
    4110                 :             :    END BLOCK
    4111                 :             : 
    4112                 :             : */
    4113                 :             : 
    4114                 :             : static int
    4115                 :      795739 : inline_matmul_assign (gfc_code **c, int *walk_subtrees,
    4116                 :             :                           void *data ATTRIBUTE_UNUSED)
    4117                 :             : {
    4118                 :      795739 :   gfc_code *co = *c;
    4119                 :      795739 :   gfc_expr *expr1, *expr2;
    4120                 :      795739 :   gfc_expr *matrix_a, *matrix_b;
    4121                 :      795739 :   gfc_actual_arglist *a, *b;
    4122                 :      795739 :   gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
    4123                 :      795739 :   gfc_expr *zero_e;
    4124                 :      795739 :   gfc_expr *u1, *u2, *u3;
    4125                 :      795739 :   gfc_expr *list[2];
    4126                 :      795739 :   gfc_expr *ascalar, *bscalar, *cscalar;
    4127                 :      795739 :   gfc_expr *mult;
    4128                 :      795739 :   gfc_expr *var_1, *var_2, *var_3;
    4129                 :      795739 :   gfc_expr *zero;
    4130                 :      795739 :   gfc_namespace *ns;
    4131                 :      795739 :   gfc_intrinsic_op op_times, op_plus;
    4132                 :      795739 :   enum matrix_case m_case;
    4133                 :      795739 :   int i;
    4134                 :      795739 :   gfc_code *if_limit = NULL;
    4135                 :      795739 :   gfc_code **next_code_point;
    4136                 :      795739 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    4137                 :      795739 :   bool realloc_c;
    4138                 :             : 
    4139                 :      795739 :   if (co->op != EXEC_ASSIGN)
    4140                 :             :     return 0;
    4141                 :             : 
    4142                 :      163745 :   if (in_where || in_assoc_list)
    4143                 :             :     return 0;
    4144                 :             : 
    4145                 :             :   /* The BLOCKS generated for the temporary variables and FORALL don't
    4146                 :             :      mix.  */
    4147                 :      163162 :   if (forall_level > 0)
    4148                 :             :     return 0;
    4149                 :             : 
    4150                 :             :   /* For now don't do anything in OpenMP workshare, it confuses
    4151                 :             :      its translation, which expects only the allowed statements in there.
    4152                 :             :      We should figure out how to parallelize this eventually.  */
    4153                 :      160972 :   if (in_omp_workshare || in_omp_atomic)
    4154                 :             :     return 0;
    4155                 :             : 
    4156                 :      158097 :   expr1 = co->expr1;
    4157                 :      158097 :   expr2 = co->expr2;
    4158                 :      158097 :   if (expr2->expr_type != EXPR_FUNCTION
    4159                 :       26849 :       || expr2->value.function.isym == NULL
    4160                 :       19295 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    4161                 :             :     return 0;
    4162                 :             : 
    4163                 :         755 :   current_code = c;
    4164                 :         755 :   inserted_block = NULL;
    4165                 :         755 :   changed_statement = NULL;
    4166                 :             : 
    4167                 :         755 :   a = expr2->value.function.actual;
    4168                 :         755 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    4169                 :         755 :   if (matrix_a == NULL)
    4170                 :             :     return 0;
    4171                 :             : 
    4172                 :         755 :   b = a->next;
    4173                 :         755 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    4174                 :         755 :   if (matrix_b == NULL)
    4175                 :             :     return 0;
    4176                 :             : 
    4177                 :        1508 :   if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
    4178                 :        1508 :       || gfc_has_dimen_vector_ref (matrix_b))
    4179                 :           2 :     return 0;
    4180                 :             : 
    4181                 :             :   /* We do not handle data dependencies yet.  */
    4182                 :         753 :   if (gfc_check_dependency (expr1, matrix_a, true)
    4183                 :         753 :       || gfc_check_dependency (expr1, matrix_b, true))
    4184                 :           0 :     return 0;
    4185                 :             : 
    4186                 :         753 :   m_case = none;
    4187                 :         753 :   if (matrix_a->rank == 2)
    4188                 :             :     {
    4189                 :         641 :       if (transpose_a)
    4190                 :             :         {
    4191                 :          66 :           if (matrix_b->rank == 2 && !transpose_b)
    4192                 :             :             m_case = A2TB2;
    4193                 :             :         }
    4194                 :             :       else
    4195                 :             :         {
    4196                 :         575 :           if (matrix_b->rank == 1)
    4197                 :             :             m_case = A2B1;
    4198                 :             :           else /* matrix_b->rank == 2 */
    4199                 :             :             {
    4200                 :         443 :               if (transpose_b)
    4201                 :             :                 m_case = A2B2T;
    4202                 :             :               else
    4203                 :         367 :                 m_case = A2B2;
    4204                 :             :             }
    4205                 :             :         }
    4206                 :             :     }
    4207                 :             :   else /* matrix_a->rank == 1 */
    4208                 :             :     {
    4209                 :         112 :       if (matrix_b->rank == 2)
    4210                 :             :         {
    4211                 :         112 :           if (!transpose_b)
    4212                 :             :             m_case = A1B2;
    4213                 :             :         }
    4214                 :             :     }
    4215                 :             : 
    4216                 :         367 :   if (m_case == none)
    4217                 :             :     return 0;
    4218                 :             : 
    4219                 :             :   /* We only handle assignment to numeric or logical variables.  */
    4220                 :         742 :   switch(expr1->ts.type)
    4221                 :             :     {
    4222                 :         741 :     case BT_INTEGER:
    4223                 :         741 :     case BT_LOGICAL:
    4224                 :         741 :     case BT_REAL:
    4225                 :         741 :     case BT_COMPLEX:
    4226                 :         741 :       break;
    4227                 :             : 
    4228                 :             :     default:
    4229                 :             :       return 0;
    4230                 :             :     }
    4231                 :             : 
    4232                 :         741 :   ns = insert_block ();
    4233                 :             : 
    4234                 :             :   /* Assign the type of the zero expression for initializing the resulting
    4235                 :             :      array, and the expression (+ and * for real, integer and complex;
    4236                 :             :      .and. and .or for logical.  */
    4237                 :             : 
    4238                 :         741 :   switch(expr1->ts.type)
    4239                 :             :     {
    4240                 :         140 :     case BT_INTEGER:
    4241                 :         140 :       zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
    4242                 :         140 :       op_times = INTRINSIC_TIMES;
    4243                 :         140 :       op_plus = INTRINSIC_PLUS;
    4244                 :         140 :       break;
    4245                 :             : 
    4246                 :          15 :     case BT_LOGICAL:
    4247                 :          15 :       op_times = INTRINSIC_AND;
    4248                 :          15 :       op_plus = INTRINSIC_OR;
    4249                 :          15 :       zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
    4250                 :             :                                      0);
    4251                 :          15 :       break;
    4252                 :         511 :     case BT_REAL:
    4253                 :         511 :       zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
    4254                 :             :                                       &expr1->where);
    4255                 :         511 :       mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
    4256                 :         511 :       op_times = INTRINSIC_TIMES;
    4257                 :         511 :       op_plus = INTRINSIC_PLUS;
    4258                 :         511 :       break;
    4259                 :             : 
    4260                 :          75 :     case BT_COMPLEX:
    4261                 :          75 :       zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
    4262                 :             :                                       &expr1->where);
    4263                 :          75 :       mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
    4264                 :          75 :       op_times = INTRINSIC_TIMES;
    4265                 :          75 :       op_plus = INTRINSIC_PLUS;
    4266                 :             : 
    4267                 :          75 :       break;
    4268                 :             : 
    4269                 :           0 :     default:
    4270                 :           0 :       gcc_unreachable();
    4271                 :             :     }
    4272                 :             : 
    4273                 :         741 :   current_code = &ns->code;
    4274                 :             : 
    4275                 :             :   /* Freeze the references, keeping track of how many temporary variables were
    4276                 :             :      created.  */
    4277                 :         741 :   n_vars = 0;
    4278                 :         741 :   freeze_references (matrix_a);
    4279                 :         741 :   freeze_references (matrix_b);
    4280                 :         741 :   freeze_references (expr1);
    4281                 :             : 
    4282                 :         741 :   if (n_vars == 0)
    4283                 :         672 :     next_code_point = current_code;
    4284                 :             :   else
    4285                 :             :     {
    4286                 :             :       next_code_point = &ns->code;
    4287                 :         264 :       for (i=0; i<n_vars; i++)
    4288                 :         195 :         next_code_point = &(*next_code_point)->next;
    4289                 :             :     }
    4290                 :             : 
    4291                 :             :   /* Take care of the inline flag.  If the limit check evaluates to a
    4292                 :             :      constant, dead code elimination will eliminate the unneeded branch.  */
    4293                 :             : 
    4294                 :         741 :   if (flag_inline_matmul_limit > 0
    4295                 :         741 :       && (matrix_a->rank == 1 || matrix_a->rank == 2)
    4296                 :         741 :       && matrix_b->rank == 2)
    4297                 :             :     {
    4298                 :         609 :       if_limit = inline_limit_check (matrix_a, matrix_b,
    4299                 :             :                                      flag_inline_matmul_limit,
    4300                 :             :                                      matrix_a->rank);
    4301                 :             : 
    4302                 :             :       /* Insert the original statement into the else branch.  */
    4303                 :         609 :       if_limit->block->block->next = co;
    4304                 :         609 :       co->next = NULL;
    4305                 :             : 
    4306                 :             :       /* ... and the new ones go into the original one.  */
    4307                 :         609 :       *next_code_point = if_limit;
    4308                 :         609 :       next_code_point = &if_limit->block->next;
    4309                 :             :     }
    4310                 :             : 
    4311                 :         741 :   zero_e->no_bounds_check = 1;
    4312                 :             : 
    4313                 :         741 :   assign_zero = XCNEW (gfc_code);
    4314                 :         741 :   assign_zero->op = EXEC_ASSIGN;
    4315                 :         741 :   assign_zero->loc = co->loc;
    4316                 :         741 :   assign_zero->expr1 = gfc_copy_expr (expr1);
    4317                 :         741 :   assign_zero->expr1->no_bounds_check = 1;
    4318                 :         741 :   assign_zero->expr2 = zero_e;
    4319                 :             : 
    4320                 :         741 :   realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
    4321                 :             : 
    4322                 :         741 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4323                 :             :     {
    4324                 :         130 :       gfc_code *test;
    4325                 :         130 :       gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
    4326                 :             : 
    4327                 :         130 :       switch (m_case)
    4328                 :             :         {
    4329                 :          23 :         case A2B1:
    4330                 :             : 
    4331                 :          23 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4332                 :          23 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4333                 :          23 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4334                 :          23 :           *next_code_point = test;
    4335                 :          23 :           next_code_point = &test->next;
    4336                 :             : 
    4337                 :          23 :           if (!realloc_c)
    4338                 :             :             {
    4339                 :          11 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4340                 :          11 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4341                 :          11 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4342                 :          11 :               *next_code_point = test;
    4343                 :          11 :               next_code_point = &test->next;
    4344                 :             :             }
    4345                 :             :           break;
    4346                 :             : 
    4347                 :          16 :         case A1B2:
    4348                 :             : 
    4349                 :          16 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4350                 :          16 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4351                 :          16 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4352                 :          16 :           *next_code_point = test;
    4353                 :          16 :           next_code_point = &test->next;
    4354                 :             : 
    4355                 :          16 :           if (!realloc_c)
    4356                 :             :             {
    4357                 :          11 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4358                 :          11 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4359                 :          11 :               test = runtime_error_ne (c1, b2, C_ERROR_1);
    4360                 :          11 :               *next_code_point = test;
    4361                 :          11 :               next_code_point = &test->next;
    4362                 :             :             }
    4363                 :             :           break;
    4364                 :             : 
    4365                 :          34 :         case A2B2:
    4366                 :             : 
    4367                 :          34 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4368                 :          34 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4369                 :          34 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4370                 :          34 :           *next_code_point = test;
    4371                 :          34 :           next_code_point = &test->next;
    4372                 :             : 
    4373                 :          34 :           if (!realloc_c)
    4374                 :             :             {
    4375                 :          27 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4376                 :          27 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4377                 :          27 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4378                 :          27 :               *next_code_point = test;
    4379                 :          27 :               next_code_point = &test->next;
    4380                 :             : 
    4381                 :          27 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4382                 :          27 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4383                 :          27 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4384                 :          27 :               *next_code_point = test;
    4385                 :          27 :               next_code_point = &test->next;
    4386                 :             :             }
    4387                 :             :           break;
    4388                 :             : 
    4389                 :          44 :         case A2B2T:
    4390                 :             : 
    4391                 :          44 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4392                 :          44 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4393                 :             :           /* matrix_b is transposed, hence dimension 1 for the error message.  */
    4394                 :          44 :           test = runtime_error_ne (b2, a2, B_ERROR_1);
    4395                 :          44 :           *next_code_point = test;
    4396                 :          44 :           next_code_point = &test->next;
    4397                 :             : 
    4398                 :          44 :           if (!realloc_c)
    4399                 :             :             {
    4400                 :          39 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4401                 :          39 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4402                 :          39 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4403                 :          39 :               *next_code_point = test;
    4404                 :          39 :               next_code_point = &test->next;
    4405                 :             : 
    4406                 :          39 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4407                 :          39 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4408                 :          39 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4409                 :          39 :               *next_code_point = test;
    4410                 :          39 :               next_code_point = &test->next;
    4411                 :             :             }
    4412                 :             :           break;
    4413                 :             : 
    4414                 :          13 :         case A2TB2:
    4415                 :             : 
    4416                 :          13 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4417                 :          13 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4418                 :          13 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4419                 :          13 :           *next_code_point = test;
    4420                 :          13 :           next_code_point = &test->next;
    4421                 :             : 
    4422                 :          13 :           if (!realloc_c)
    4423                 :             :             {
    4424                 :          12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4425                 :          12 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4426                 :          12 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4427                 :          12 :               *next_code_point = test;
    4428                 :          12 :               next_code_point = &test->next;
    4429                 :             : 
    4430                 :          12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4431                 :          12 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4432                 :          12 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4433                 :          12 :               *next_code_point = test;
    4434                 :          12 :               next_code_point = &test->next;
    4435                 :             :             }
    4436                 :             :           break;
    4437                 :             : 
    4438                 :             :         default:
    4439                 :             :           gcc_unreachable ();
    4440                 :             :         }
    4441                 :             :     }
    4442                 :             : 
    4443                 :             :   /* Handle the reallocation, if needed.  */
    4444                 :             : 
    4445                 :         711 :   if (realloc_c)
    4446                 :             :     {
    4447                 :         197 :       gfc_code *lhs_alloc;
    4448                 :             : 
    4449                 :         197 :       lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
    4450                 :             : 
    4451                 :         197 :       *next_code_point = lhs_alloc;
    4452                 :         197 :       next_code_point = &lhs_alloc->next;
    4453                 :             : 
    4454                 :             :     }
    4455                 :             : 
    4456                 :         741 :   *next_code_point = assign_zero;
    4457                 :             : 
    4458                 :         741 :   zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
    4459                 :             : 
    4460                 :         741 :   assign_matmul = XCNEW (gfc_code);
    4461                 :         741 :   assign_matmul->op = EXEC_ASSIGN;
    4462                 :         741 :   assign_matmul->loc = co->loc;
    4463                 :             : 
    4464                 :             :   /* Get the bounds for the loops, create them and create the scalarized
    4465                 :             :      expressions.  */
    4466                 :             : 
    4467                 :         741 :   switch (m_case)
    4468                 :             :     {
    4469                 :         366 :     case A2B2:
    4470                 :             : 
    4471                 :         366 :       u1 = get_size_m1 (matrix_b, 2);
    4472                 :         366 :       u2 = get_size_m1 (matrix_a, 2);
    4473                 :         366 :       u3 = get_size_m1 (matrix_a, 1);
    4474                 :             : 
    4475                 :         366 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4476                 :         366 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4477                 :         366 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4478                 :             : 
    4479                 :         366 :       do_1->block->next = do_2;
    4480                 :         366 :       do_2->block->next = do_3;
    4481                 :         366 :       do_3->block->next = assign_matmul;
    4482                 :             : 
    4483                 :         366 :       var_1 = do_1->ext.iterator->var;
    4484                 :         366 :       var_2 = do_2->ext.iterator->var;
    4485                 :         366 :       var_3 = do_3->ext.iterator->var;
    4486                 :             : 
    4487                 :         366 :       list[0] = var_3;
    4488                 :         366 :       list[1] = var_1;
    4489                 :         366 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4490                 :             : 
    4491                 :         366 :       list[0] = var_3;
    4492                 :         366 :       list[1] = var_2;
    4493                 :         366 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4494                 :             : 
    4495                 :         366 :       list[0] = var_2;
    4496                 :         366 :       list[1] = var_1;
    4497                 :         366 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4498                 :             : 
    4499                 :         366 :       break;
    4500                 :             : 
    4501                 :          76 :     case A2B2T:
    4502                 :             : 
    4503                 :          76 :       u1 = get_size_m1 (matrix_b, 1);
    4504                 :          76 :       u2 = get_size_m1 (matrix_a, 2);
    4505                 :          76 :       u3 = get_size_m1 (matrix_a, 1);
    4506                 :             : 
    4507                 :          76 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4508                 :          76 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4509                 :          76 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4510                 :             : 
    4511                 :          76 :       do_1->block->next = do_2;
    4512                 :          76 :       do_2->block->next = do_3;
    4513                 :          76 :       do_3->block->next = assign_matmul;
    4514                 :             : 
    4515                 :          76 :       var_1 = do_1->ext.iterator->var;
    4516                 :          76 :       var_2 = do_2->ext.iterator->var;
    4517                 :          76 :       var_3 = do_3->ext.iterator->var;
    4518                 :             : 
    4519                 :          76 :       list[0] = var_3;
    4520                 :          76 :       list[1] = var_1;
    4521                 :          76 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4522                 :             : 
    4523                 :          76 :       list[0] = var_3;
    4524                 :          76 :       list[1] = var_2;
    4525                 :          76 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4526                 :             : 
    4527                 :          76 :       list[0] = var_1;
    4528                 :          76 :       list[1] = var_2;
    4529                 :          76 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4530                 :             : 
    4531                 :          76 :       break;
    4532                 :             : 
    4533                 :          60 :     case A2TB2:
    4534                 :             : 
    4535                 :          60 :       u1 = get_size_m1 (matrix_a, 2);
    4536                 :          60 :       u2 = get_size_m1 (matrix_b, 2);
    4537                 :          60 :       u3 = get_size_m1 (matrix_a, 1);
    4538                 :             : 
    4539                 :          60 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4540                 :          60 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4541                 :          60 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4542                 :             : 
    4543                 :          60 :       do_1->block->next = do_2;
    4544                 :          60 :       do_2->block->next = do_3;
    4545                 :          60 :       do_3->block->next = assign_matmul;
    4546                 :             : 
    4547                 :          60 :       var_1 = do_1->ext.iterator->var;
    4548                 :          60 :       var_2 = do_2->ext.iterator->var;
    4549                 :          60 :       var_3 = do_3->ext.iterator->var;
    4550                 :             : 
    4551                 :          60 :       list[0] = var_1;
    4552                 :          60 :       list[1] = var_2;
    4553                 :          60 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4554                 :             : 
    4555                 :          60 :       list[0] = var_3;
    4556                 :          60 :       list[1] = var_1;
    4557                 :          60 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4558                 :             : 
    4559                 :          60 :       list[0] = var_3;
    4560                 :          60 :       list[1] = var_2;
    4561                 :          60 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4562                 :             : 
    4563                 :          60 :       break;
    4564                 :             : 
    4565                 :         132 :     case A2B1:
    4566                 :         132 :       u1 = get_size_m1 (matrix_b, 1);
    4567                 :         132 :       u2 = get_size_m1 (matrix_a, 1);
    4568                 :             : 
    4569                 :         132 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4570                 :         132 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4571                 :             : 
    4572                 :         132 :       do_1->block->next = do_2;
    4573                 :         132 :       do_2->block->next = assign_matmul;
    4574                 :             : 
    4575                 :         132 :       var_1 = do_1->ext.iterator->var;
    4576                 :         132 :       var_2 = do_2->ext.iterator->var;
    4577                 :             : 
    4578                 :         132 :       list[0] = var_2;
    4579                 :         132 :       cscalar = scalarized_expr (co->expr1, list, 1);
    4580                 :             : 
    4581                 :         132 :       list[0] = var_2;
    4582                 :         132 :       list[1] = var_1;
    4583                 :         132 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4584                 :             : 
    4585                 :         132 :       list[0] = var_1;
    4586                 :         132 :       bscalar = scalarized_expr (matrix_b, list, 1);
    4587                 :             : 
    4588                 :         132 :       break;
    4589                 :             : 
    4590                 :         107 :     case A1B2:
    4591                 :         107 :       u1 = get_size_m1 (matrix_b, 2);
    4592                 :         107 :       u2 = get_size_m1 (matrix_a, 1);
    4593                 :             : 
    4594                 :         107 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4595                 :         107 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4596                 :             : 
    4597                 :         107 :       do_1->block->next = do_2;
    4598                 :         107 :       do_2->block->next = assign_matmul;
    4599                 :             : 
    4600                 :         107 :       var_1 = do_1->ext.iterator->var;
    4601                 :         107 :       var_2 = do_2->ext.iterator->var;
    4602                 :             : 
    4603                 :         107 :       list[0] = var_1;
    4604                 :         107 :       cscalar = scalarized_expr (co->expr1, list, 1);
    4605                 :             : 
    4606                 :         107 :       list[0] = var_2;
    4607                 :         107 :       ascalar = scalarized_expr (matrix_a, list, 1);
    4608                 :             : 
    4609                 :         107 :       list[0] = var_2;
    4610                 :         107 :       list[1] = var_1;
    4611                 :         107 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4612                 :             : 
    4613                 :         107 :       break;
    4614                 :             : 
    4615                 :             :     default:
    4616                 :             :       gcc_unreachable();
    4617                 :             :     }
    4618                 :             : 
    4619                 :             :   /* Build the conjg call around the variables.  Set the typespec manually
    4620                 :             :      because gfc_build_intrinsic_call sometimes gets this wrong.  */
    4621                 :         741 :   if (conjg_a)
    4622                 :             :     {
    4623                 :          16 :       gfc_typespec ts;
    4624                 :          16 :       ts = matrix_a->ts;
    4625                 :          16 :       ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
    4626                 :             :                                           matrix_a->where, 1, ascalar);
    4627                 :          16 :       ascalar->ts = ts;
    4628                 :             :     }
    4629                 :             : 
    4630                 :         741 :   if (conjg_b)
    4631                 :             :     {
    4632                 :           8 :       gfc_typespec ts;
    4633                 :           8 :       ts = matrix_b->ts;
    4634                 :           8 :       bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
    4635                 :             :                                           matrix_b->where, 1, bscalar);
    4636                 :           8 :       bscalar->ts = ts;
    4637                 :             :     }
    4638                 :             :   /* First loop comes after the zero assignment.  */
    4639                 :         741 :   assign_zero->next = do_1;
    4640                 :             : 
    4641                 :             :   /* Build the assignment expression in the loop.  */
    4642                 :         741 :   assign_matmul->expr1 = gfc_copy_expr (cscalar);
    4643                 :             : 
    4644                 :         741 :   mult = get_operand (op_times, ascalar, bscalar);
    4645                 :         741 :   assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
    4646                 :             : 
    4647                 :             :   /* If we don't want to keep the original statement around in
    4648                 :             :      the else branch, we can free it.  */
    4649                 :             : 
    4650                 :         741 :   if (if_limit == NULL)
    4651                 :         132 :     gfc_free_statements(co);
    4652                 :             :   else
    4653                 :         609 :     co->next = NULL;
    4654                 :             : 
    4655                 :         741 :   gfc_free_expr (zero);
    4656                 :         741 :   *walk_subtrees = 0;
    4657                 :         741 :   return 0;
    4658                 :             : }
    4659                 :             : 
    4660                 :             : /* Change matmul function calls in the form of
    4661                 :             : 
    4662                 :             :    c = matmul(a,b)
    4663                 :             : 
    4664                 :             :    to the corresponding call to a BLAS routine, if applicable.  */
    4665                 :             : 
    4666                 :             : static int
    4667                 :        2802 : call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    4668                 :             :                     void *data ATTRIBUTE_UNUSED)
    4669                 :             : {
    4670                 :        2802 :   gfc_code *co, *co_next;
    4671                 :        2802 :   gfc_expr *expr1, *expr2;
    4672                 :        2802 :   gfc_expr *matrix_a, *matrix_b;
    4673                 :        2802 :   gfc_code *if_limit = NULL;
    4674                 :        2802 :   gfc_actual_arglist *a, *b;
    4675                 :        2802 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    4676                 :        2802 :   gfc_code *call;
    4677                 :        2802 :   const char *blas_name;
    4678                 :        2802 :   const char *transa, *transb;
    4679                 :        2802 :   gfc_expr *c1, *c2, *b1;
    4680                 :        2802 :   gfc_actual_arglist *actual, *next;
    4681                 :        2802 :   bt type;
    4682                 :        2802 :   int kind;
    4683                 :        2802 :   enum matrix_case m_case;
    4684                 :        2802 :   bool realloc_c;
    4685                 :        2802 :   gfc_code **next_code_point;
    4686                 :             : 
    4687                 :             :   /* Many of the tests for inline matmul also apply here.  */
    4688                 :             : 
    4689                 :        2802 :   co = *c;
    4690                 :             : 
    4691                 :        2802 :   if (co->op != EXEC_ASSIGN)
    4692                 :             :     return 0;
    4693                 :             : 
    4694                 :         908 :   if (in_where || in_assoc_list)
    4695                 :             :     return 0;
    4696                 :             : 
    4697                 :             :   /* The BLOCKS generated for the temporary variables and FORALL don't
    4698                 :             :      mix.  */
    4699                 :         908 :   if (forall_level > 0)
    4700                 :             :     return 0;
    4701                 :             : 
    4702                 :             :   /* For now don't do anything in OpenMP workshare, it confuses
    4703                 :             :      its translation, which expects only the allowed statements in there. */
    4704                 :             : 
    4705                 :         908 :   if (in_omp_workshare || in_omp_atomic)
    4706                 :             :     return 0;
    4707                 :             : 
    4708                 :         908 :   expr1 = co->expr1;
    4709                 :         908 :   expr2 = co->expr2;
    4710                 :         908 :   if (expr2->expr_type != EXPR_FUNCTION
    4711                 :         154 :       || expr2->value.function.isym == NULL
    4712                 :         106 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    4713                 :             :     return 0;
    4714                 :             : 
    4715                 :          74 :   type = expr2->ts.type;
    4716                 :          74 :   kind = expr2->ts.kind;
    4717                 :             : 
    4718                 :             :   /* Guard against recursion. */
    4719                 :             : 
    4720                 :          74 :   if (expr2->external_blas)
    4721                 :             :     return 0;
    4722                 :             : 
    4723                 :          37 :   if (type != expr1->ts.type || kind != expr1->ts.kind)
    4724                 :             :     return 0;
    4725                 :             : 
    4726                 :          37 :   if (type == BT_REAL)
    4727                 :             :     {
    4728                 :          17 :       if (kind == 4)
    4729                 :             :         blas_name = "sgemm";
    4730                 :           7 :       else if (kind == 8)
    4731                 :             :         blas_name = "dgemm";
    4732                 :             :       else
    4733                 :             :         return 0;
    4734                 :             :     }
    4735                 :          20 :   else if (type == BT_COMPLEX)
    4736                 :             :     {
    4737                 :          20 :       if (kind == 4)
    4738                 :             :         blas_name = "cgemm";
    4739                 :          10 :       else if (kind == 8)
    4740                 :             :         blas_name = "zgemm";
    4741                 :             :       else
    4742                 :             :         return 0;
    4743                 :             :     }
    4744                 :             :   else
    4745                 :             :     return 0;
    4746                 :             : 
    4747                 :          37 :   a = expr2->value.function.actual;
    4748                 :          37 :   if (a->expr->rank != 2)
    4749                 :             :     return 0;
    4750                 :             : 
    4751                 :          37 :   b = a->next;
    4752                 :          37 :   if (b->expr->rank != 2)
    4753                 :             :     return 0;
    4754                 :             : 
    4755                 :          37 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    4756                 :          37 :   if (matrix_a == NULL)
    4757                 :             :     return 0;
    4758                 :             : 
    4759                 :          37 :   if (transpose_a)
    4760                 :             :     {
    4761                 :          13 :       if (conjg_a)
    4762                 :             :         transa = "C";
    4763                 :             :       else
    4764                 :           9 :         transa = "T";
    4765                 :             :     }
    4766                 :             :   else
    4767                 :             :     transa = "N";
    4768                 :             : 
    4769                 :          37 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    4770                 :          37 :   if (matrix_b == NULL)
    4771                 :             :     return 0;
    4772                 :             : 
    4773                 :          37 :   if (transpose_b)
    4774                 :             :     {
    4775                 :          12 :       if (conjg_b)
    4776                 :             :         transb = "C";
    4777                 :             :       else
    4778                 :           8 :         transb = "T";
    4779                 :             :     }
    4780                 :             :   else
    4781                 :             :     transb = "N";
    4782                 :             : 
    4783                 :          37 :   if (transpose_a)
    4784                 :             :     {
    4785                 :          13 :       if (transpose_b)
    4786                 :             :         m_case = A2TB2T;
    4787                 :             :       else
    4788                 :          13 :         m_case = A2TB2;
    4789                 :             :     }
    4790                 :             :   else
    4791                 :             :     {
    4792                 :          24 :       if (transpose_b)
    4793                 :             :         m_case = A2B2T;
    4794                 :             :       else
    4795                 :          12 :         m_case = A2B2;
    4796                 :             :     }
    4797                 :             : 
    4798                 :          37 :   current_code = c;
    4799                 :          37 :   inserted_block = NULL;
    4800                 :          37 :   changed_statement = NULL;
    4801                 :             : 
    4802                 :          37 :   expr2->external_blas = 1;
    4803                 :             : 
    4804                 :             :   /* We do not handle data dependencies yet.  */
    4805                 :          37 :   if (gfc_check_dependency (expr1, matrix_a, true)
    4806                 :          37 :       || gfc_check_dependency (expr1, matrix_b, true))
    4807                 :           0 :     return 0;
    4808                 :             : 
    4809                 :             :   /* Generate the if statement and hang it into the tree.  */
    4810                 :          37 :   if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2);
    4811                 :          37 :   co_next = co->next;
    4812                 :          37 :   (*current_code) = if_limit;
    4813                 :          37 :   co->next = NULL;
    4814                 :          37 :   if_limit->block->next = co;
    4815                 :             : 
    4816                 :          37 :   call = XCNEW (gfc_code);
    4817                 :          37 :   call->loc = co->loc;
    4818                 :             : 
    4819                 :             :   /* Bounds checking - a bit simpler than for inlining since we only
    4820                 :             :      have to take care of two-dimensional arrays here.  */
    4821                 :             : 
    4822                 :          37 :   realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
    4823                 :          37 :   next_code_point = &(if_limit->block->block->next);
    4824                 :             : 
    4825                 :          37 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4826                 :             :     {
    4827                 :          35 :       gfc_code *test;
    4828                 :             :       //      gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
    4829                 :          35 :       gfc_expr *c1, *a1, *c2, *b2, *a2;
    4830                 :          35 :       switch (m_case)
    4831                 :             :         {
    4832                 :          10 :         case A2B2:
    4833                 :          10 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4834                 :          10 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4835                 :          10 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4836                 :          10 :           *next_code_point = test;
    4837                 :          10 :           next_code_point = &test->next;
    4838                 :             : 
    4839                 :          10 :           if (!realloc_c)
    4840                 :             :             {
    4841                 :           5 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4842                 :           5 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4843                 :           5 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4844                 :           5 :               *next_code_point = test;
    4845                 :           5 :               next_code_point = &test->next;
    4846                 :             : 
    4847                 :           5 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4848                 :           5 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4849                 :           5 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4850                 :           5 :               *next_code_point = test;
    4851                 :           5 :               next_code_point = &test->next;
    4852                 :             :             }
    4853                 :             :           break;
    4854                 :             : 
    4855                 :          12 :         case A2B2T:
    4856                 :             : 
    4857                 :          12 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4858                 :          12 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4859                 :             :           /* matrix_b is transposed, hence dimension 1 for the error message.  */
    4860                 :          12 :           test = runtime_error_ne (b2, a2, B_ERROR_1);
    4861                 :          12 :           *next_code_point = test;
    4862                 :          12 :           next_code_point = &test->next;
    4863                 :             : 
    4864                 :          12 :           if (!realloc_c)
    4865                 :             :             {
    4866                 :          12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4867                 :          12 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4868                 :          12 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4869                 :          12 :               *next_code_point = test;
    4870                 :          12 :               next_code_point = &test->next;
    4871                 :             : 
    4872                 :          12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4873                 :          12 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4874                 :          12 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4875                 :          12 :               *next_code_point = test;
    4876                 :          12 :               next_code_point = &test->next;
    4877                 :             :             }
    4878                 :             :           break;
    4879                 :             : 
    4880                 :          13 :         case A2TB2:
    4881                 :             : 
    4882                 :          13 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4883                 :          13 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4884                 :          13 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4885                 :          13 :           *next_code_point = test;
    4886                 :          13 :           next_code_point = &test->next;
    4887                 :             : 
    4888                 :          13 :           if (!realloc_c)
    4889                 :             :             {
    4890                 :          12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4891                 :          12 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4892                 :          12 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4893                 :          12 :               *next_code_point = test;
    4894                 :          12 :               next_code_point = &test->next;
    4895                 :             : 
    4896                 :          12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4897                 :          12 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4898                 :          12 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4899                 :          12 :               *next_code_point = test;
    4900                 :          12 :               next_code_point = &test->next;
    4901                 :             :             }
    4902                 :             :           break;
    4903                 :             : 
    4904                 :           0 :         case A2TB2T:
    4905                 :           0 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4906                 :           0 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4907                 :           0 :           test = runtime_error_ne (b2, a1, B_ERROR_1);
    4908                 :           0 :           *next_code_point = test;
    4909                 :           0 :           next_code_point = &test->next;
    4910                 :             : 
    4911                 :           0 :           if (!realloc_c)
    4912                 :             :             {
    4913                 :           0 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4914                 :           0 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4915                 :           0 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4916                 :           0 :               *next_code_point = test;
    4917                 :           0 :               next_code_point = &test->next;
    4918                 :             : 
    4919                 :           0 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4920                 :           0 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4921                 :           0 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4922                 :           0 :               *next_code_point = test;
    4923                 :           0 :               next_code_point = &test->next;
    4924                 :             :             }
    4925                 :             :           break;
    4926                 :             : 
    4927                 :           0 :         default:
    4928                 :           0 :           gcc_unreachable ();
    4929                 :             :         }
    4930                 :             :     }
    4931                 :             : 
    4932                 :             :   /* Handle the reallocation, if needed.  */
    4933                 :             : 
    4934                 :          31 :   if (realloc_c)
    4935                 :             :     {
    4936                 :           6 :       gfc_code *lhs_alloc;
    4937                 :             : 
    4938                 :           6 :       lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
    4939                 :           6 :       *next_code_point = lhs_alloc;
    4940                 :           6 :       next_code_point = &lhs_alloc->next;
    4941                 :             :     }
    4942                 :             : 
    4943                 :          37 :   *next_code_point = call;
    4944                 :          37 :   if_limit->next = co_next;
    4945                 :             : 
    4946                 :             :   /* Set up the BLAS call.  */
    4947                 :             : 
    4948                 :          37 :   call->op = EXEC_CALL;
    4949                 :             : 
    4950                 :          37 :   gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
    4951                 :          37 :   call->symtree->n.sym->attr.subroutine = 1;
    4952                 :          37 :   call->symtree->n.sym->attr.procedure = 1;
    4953                 :          37 :   call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
    4954                 :          37 :   call->resolved_sym = call->symtree->n.sym;
    4955                 :          37 :   gfc_commit_symbol (call->resolved_sym);
    4956                 :             : 
    4957                 :             :   /* Argument TRANSA.  */
    4958                 :          37 :   next = gfc_get_actual_arglist ();
    4959                 :          37 :   next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
    4960                 :             :                                        transa, 1);
    4961                 :             : 
    4962                 :          37 :   call->ext.actual = next;
    4963                 :             : 
    4964                 :             :   /* Argument TRANSB.  */
    4965                 :          37 :   actual = next;
    4966                 :          37 :   next = gfc_get_actual_arglist ();
    4967                 :          37 :   next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
    4968                 :             :                                        transb, 1);
    4969                 :          37 :   actual->next = next;
    4970                 :             : 
    4971                 :          37 :   c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
    4972                 :             :                                gfc_integer_4_kind);
    4973                 :          37 :   c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
    4974                 :             :                                gfc_integer_4_kind);
    4975                 :             : 
    4976                 :          37 :   b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
    4977                 :             :                                gfc_integer_4_kind);
    4978                 :             : 
    4979                 :             :   /* Argument M. */
    4980                 :          37 :   actual = next;
    4981                 :          37 :   next = gfc_get_actual_arglist ();
    4982                 :          37 :   next->expr = c1;
    4983                 :          37 :   actual->next = next;
    4984                 :             : 
    4985                 :             :   /* Argument N. */
    4986                 :          37 :   actual = next;
    4987                 :          37 :   next = gfc_get_actual_arglist ();
    4988                 :          37 :   next->expr = c2;
    4989                 :          37 :   actual->next = next;
    4990                 :             : 
    4991                 :             :   /* Argument K.  */
    4992                 :          37 :   actual = next;
    4993                 :          37 :   next = gfc_get_actual_arglist ();
    4994                 :          37 :   next->expr = b1;
    4995                 :          37 :   actual->next = next;
    4996                 :             : 
    4997                 :             :   /* Argument ALPHA - set to one.  */
    4998                 :          37 :   actual = next;
    4999                 :          37 :   next = gfc_get_actual_arglist ();
    5000                 :          37 :   next->expr = gfc_get_constant_expr (type, kind, &co->loc);
    5001                 :          37 :   if (type == BT_REAL)
    5002                 :          17 :     mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
    5003                 :             :   else
    5004                 :          20 :     mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
    5005                 :          37 :   actual->next = next;
    5006                 :             : 
    5007                 :             :   /* Argument A.  */
    5008                 :          37 :   actual = next;
    5009                 :          37 :   next = gfc_get_actual_arglist ();
    5010                 :          37 :   next->expr = gfc_copy_expr (matrix_a);
    5011                 :          37 :   actual->next = next;
    5012                 :             : 
    5013                 :             :   /* Argument LDA.  */
    5014                 :          37 :   actual = next;
    5015                 :          37 :   next = gfc_get_actual_arglist ();
    5016                 :          37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
    5017                 :             :                                        1, gfc_integer_4_kind);
    5018                 :          37 :   actual->next = next;
    5019                 :             : 
    5020                 :             :   /* Argument B.  */
    5021                 :          37 :   actual = next;
    5022                 :          37 :   next = gfc_get_actual_arglist ();
    5023                 :          37 :   next->expr = gfc_copy_expr (matrix_b);
    5024                 :          37 :   actual->next = next;
    5025                 :             : 
    5026                 :             :   /* Argument LDB.  */
    5027                 :          37 :   actual = next;
    5028                 :          37 :   next = gfc_get_actual_arglist ();
    5029                 :          37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
    5030                 :             :                                        1, gfc_integer_4_kind);
    5031                 :          37 :   actual->next = next;
    5032                 :             : 
    5033                 :             :   /* Argument BETA - set to zero.  */
    5034                 :          37 :   actual = next;
    5035                 :          37 :   next = gfc_get_actual_arglist ();
    5036                 :          37 :   next->expr = gfc_get_constant_expr (type, kind, &co->loc);
    5037                 :          37 :   if (type == BT_REAL)
    5038                 :          17 :     mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
    5039                 :             :   else
    5040                 :          20 :     mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
    5041                 :          37 :   actual->next = next;
    5042                 :             : 
    5043                 :             :   /* Argument C.  */
    5044                 :             : 
    5045                 :          37 :   actual = next;
    5046                 :          37 :   next = gfc_get_actual_arglist ();
    5047                 :          37 :   next->expr = gfc_copy_expr (expr1);
    5048                 :          37 :   actual->next = next;
    5049                 :             : 
    5050                 :             :   /* Argument LDC.  */
    5051                 :          37 :   actual = next;
    5052                 :          37 :   next = gfc_get_actual_arglist ();
    5053                 :          37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
    5054                 :             :                                        1, gfc_integer_4_kind);
    5055                 :          37 :   actual->next = next;
    5056                 :             : 
    5057                 :          37 :   return 0;
    5058                 :             : }
    5059                 :             : 
    5060                 :             : 
    5061                 :             : /* Code for index interchange for loops which are grouped together in DO
    5062                 :             :    CONCURRENT or FORALL statements.  This is currently only applied if the
    5063                 :             :    iterations are grouped together in a single statement.
    5064                 :             : 
    5065                 :             :    For this transformation, it is assumed that memory access in strides is
    5066                 :             :    expensive, and that loops which access later indices (which access memory
    5067                 :             :    in bigger strides) should be moved to the first loops.
    5068                 :             : 
    5069                 :             :    For this, a loop over all the statements is executed, counting the times
    5070                 :             :    that the loop iteration values are accessed in each index.  The loop
    5071                 :             :    indices are then sorted to minimize access to later indices from inner
    5072                 :             :    loops.  */
    5073                 :             : 
    5074                 :             : /* Type for holding index information.  */
    5075                 :             : 
    5076                 :             : typedef struct {
    5077                 :             :   gfc_symbol *sym;
    5078                 :             :   gfc_forall_iterator *fa;
    5079                 :             :   int num;
    5080                 :             :   int n[GFC_MAX_DIMENSIONS];
    5081                 :             : } ind_type;
    5082                 :             : 
    5083                 :             : /* Callback function to determine if an expression is the
    5084                 :             :    corresponding variable.  */
    5085                 :             : 
    5086                 :             : static int
    5087                 :      294070 : has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
    5088                 :             : {
    5089                 :      294070 :   gfc_expr *expr = *e;
    5090                 :      294070 :   gfc_symbol *sym;
    5091                 :             : 
    5092                 :      294070 :   if (expr->expr_type != EXPR_VARIABLE)
    5093                 :             :     return 0;
    5094                 :             : 
    5095                 :      225198 :   sym = (gfc_symbol *) data;
    5096                 :      225198 :   return sym == expr->symtree->n.sym;
    5097                 :             : }
    5098                 :             : 
    5099                 :             : /* Callback function to calculate the cost of a certain index.  */
    5100                 :             : 
    5101                 :             : static int
    5102                 :     1119876 : index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    5103                 :             :             void *data)
    5104                 :             : {
    5105                 :     1119876 :   ind_type *ind;
    5106                 :     1119876 :   gfc_expr *expr;
    5107                 :     1119876 :   gfc_array_ref *ar;
    5108                 :     1119876 :   gfc_ref *ref;
    5109                 :     1119876 :   int i,j;
    5110                 :             : 
    5111                 :     1119876 :   expr = *e;
    5112                 :     1119876 :   if (expr->expr_type != EXPR_VARIABLE)
    5113                 :             :     return 0;
    5114                 :             : 
    5115                 :      474849 :   ar = NULL;
    5116                 :      501639 :   for (ref = expr->ref; ref; ref = ref->next)
    5117                 :             :     {
    5118                 :       86684 :       if (ref->type == REF_ARRAY)
    5119                 :             :         {
    5120                 :       59894 :           ar = &ref->u.ar;
    5121                 :       59894 :           break;
    5122                 :             :         }
    5123                 :             :     }
    5124                 :       59894 :   if (ar == NULL || ar->type != AR_ELEMENT)
    5125                 :             :     return 0;
    5126                 :             : 
    5127                 :             :   ind = (ind_type *) data;
    5128                 :      128469 :   for (i = 0; i < ar->dimen; i++)
    5129                 :             :     {
    5130                 :      324518 :       for (j=0; ind[j].sym != NULL; j++)
    5131                 :             :         {
    5132                 :      232810 :           if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
    5133                 :       75761 :               ind[j].n[i]++;
    5134                 :             :         }
    5135                 :             :     }
    5136                 :             :   return 0;
    5137                 :             : }
    5138                 :             : 
    5139                 :             : /* Callback function for qsort, to sort the loop indices. */
    5140                 :             : 
    5141                 :             : static int
    5142                 :       13565 : loop_comp (const void *e1, const void *e2)
    5143                 :             : {
    5144                 :       13565 :   const ind_type *i1 = (const ind_type *) e1;
    5145                 :       13565 :   const ind_type *i2 = (const ind_type *) e2;
    5146                 :       13565 :   int i;
    5147                 :             : 
    5148                 :      180570 :   for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
    5149                 :             :     {
    5150                 :      180030 :       if (i1->n[i] != i2->n[i])
    5151                 :       13025 :         return i1->n[i] - i2->n[i];
    5152                 :             :     }
    5153                 :             :   /* All other things being equal, let's not change the ordering.  */
    5154                 :         540 :   return i2->num - i1->num;
    5155                 :             : }
    5156                 :             : 
    5157                 :             : /* Main function to do the index interchange.  */
    5158                 :             : 
    5159                 :             : static int
    5160                 :      803813 : index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    5161                 :             :                   void *data ATTRIBUTE_UNUSED)
    5162                 :             : {
    5163                 :      803813 :   gfc_code *co;
    5164                 :      803813 :   co = *c;
    5165                 :      803813 :   int n_iter;
    5166                 :      803813 :   gfc_forall_iterator *fa;
    5167                 :      803813 :   ind_type *ind;
    5168                 :      803813 :   int i, j;
    5169                 :             : 
    5170                 :      803813 :   if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
    5171                 :             :     return 0;
    5172                 :             : 
    5173                 :        2357 :   n_iter = 0;
    5174                 :        7296 :   for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    5175                 :        4939 :     n_iter ++;
    5176                 :             : 
    5177                 :             :   /* Nothing to reorder. */
    5178                 :        2357 :   if (n_iter < 2)
    5179                 :             :     return 0;
    5180                 :             : 
    5181                 :        1679 :   ind = XALLOCAVEC (ind_type, n_iter + 1);
    5182                 :             : 
    5183                 :        1679 :   i = 0;
    5184                 :        5940 :   for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    5185                 :             :     {
    5186                 :        4261 :       ind[i].sym = fa->var->symtree->n.sym;
    5187                 :        4261 :       ind[i].fa = fa;
    5188                 :       68176 :       for (j=0; j<GFC_MAX_DIMENSIONS; j++)
    5189                 :       63915 :         ind[i].n[j] = 0;
    5190                 :        4261 :       ind[i].num = i;
    5191                 :        4261 :       i++;
    5192                 :             :     }
    5193                 :        1679 :   ind[n_iter].sym = NULL;
    5194                 :        1679 :   ind[n_iter].fa = NULL;
    5195                 :             : 
    5196                 :        1679 :   gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
    5197                 :        1679 :   qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
    5198                 :             : 
    5199                 :             :   /* Do the actual index interchange.  */
    5200                 :        1679 :   co->ext.forall_iterator = fa = ind[0].fa;
    5201                 :        4261 :   for (i=1; i<n_iter; i++)
    5202                 :             :     {
    5203                 :        2582 :       fa->next = ind[i].fa;
    5204                 :        2582 :       fa = fa->next;
    5205                 :             :     }
    5206                 :        1679 :   fa->next = NULL;
    5207                 :             : 
    5208                 :        1679 :   if (flag_warn_frontend_loop_interchange)
    5209                 :             :     {
    5210                 :           1 :       for (i=1; i<n_iter; i++)
    5211                 :             :         {
    5212                 :           1 :           if (ind[i-1].num > ind[i].num)
    5213                 :             :             {
    5214                 :           1 :               gfc_warning (OPT_Wfrontend_loop_interchange,
    5215                 :             :                            "Interchanging loops at %L", &co->loc);
    5216                 :           1 :               break;
    5217                 :             :             }
    5218                 :             :         }
    5219                 :             :     }
    5220                 :             : 
    5221                 :             :   return 0;
    5222                 :             : }
    5223                 :             : 
    5224                 :             : #define WALK_SUBEXPR(NODE) \
    5225                 :             :   do                                                    \
    5226                 :             :     {                                                   \
    5227                 :             :       result = gfc_expr_walker (&(NODE), exprfn, data);     \
    5228                 :             :       if (result)                                       \
    5229                 :             :         return result;                                  \
    5230                 :             :     }                                                   \
    5231                 :             :   while (0)
    5232                 :             : #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
    5233                 :             : 
    5234                 :             : /* Walk expression *E, calling EXPRFN on each expression in it.  */
    5235                 :             : 
    5236                 :             : int
    5237                 :    84050039 : gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
    5238                 :             : {
    5239                 :    86645490 :   while (*e)
    5240                 :             :     {
    5241                 :    27815465 :       int walk_subtrees = 1;
    5242                 :    27815465 :       gfc_actual_arglist *a;
    5243                 :    27815465 :       gfc_ref *r;
    5244                 :    27815465 :       gfc_constructor *c;
    5245                 :             : 
    5246                 :    27815465 :       int result = exprfn (e, &walk_subtrees, data);
    5247                 :    27815465 :       if (result)
    5248                 :    25220014 :         return result;
    5249                 :    27739341 :       if (walk_subtrees)
    5250                 :    18951287 :         switch ((*e)->expr_type)
    5251                 :             :           {
    5252                 :     2608077 :           case EXPR_OP:
    5253                 :     2608077 :             WALK_SUBEXPR ((*e)->value.op.op1);
    5254                 :     2595451 :             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
    5255                 :             :             /* No fallthru because of the tail recursion above.  */
    5256                 :     1556775 :           case EXPR_FUNCTION:
    5257                 :     4437398 :             for (a = (*e)->value.function.actual; a; a = a->next)
    5258                 :     2880744 :               WALK_SUBEXPR (a->expr);
    5259                 :             :             break;
    5260                 :          69 :           case EXPR_COMPCALL:
    5261                 :          69 :           case EXPR_PPC:
    5262                 :          69 :             WALK_SUBEXPR ((*e)->value.compcall.base_object);
    5263                 :          81 :             for (a = (*e)->value.compcall.actual; a; a = a->next)
    5264                 :          12 :               WALK_SUBEXPR (a->expr);
    5265                 :             :             break;
    5266                 :             : 
    5267                 :      322169 :           case EXPR_STRUCTURE:
    5268                 :      322169 :           case EXPR_ARRAY:
    5269                 :     1688436 :             for (c = gfc_constructor_first ((*e)->value.constructor); c;
    5270                 :     1366267 :                  c = gfc_constructor_next (c))
    5271                 :             :               {
    5272                 :     1366267 :                 if (c->iterator == NULL)
    5273                 :     1359168 :                   WALK_SUBEXPR (c->expr);
    5274                 :             :                 else
    5275                 :             :                   {
    5276                 :        7099 :                     iterator_level ++;
    5277                 :        7099 :                     WALK_SUBEXPR (c->expr);
    5278                 :        7099 :                     iterator_level --;
    5279                 :        7099 :                     WALK_SUBEXPR (c->iterator->var);
    5280                 :        7099 :                     WALK_SUBEXPR (c->iterator->start);
    5281                 :        7099 :                     WALK_SUBEXPR (c->iterator->end);
    5282                 :     1366267 :                     WALK_SUBEXPR (c->iterator->step);
    5283                 :             :                   }
    5284                 :             :               }
    5285                 :             : 
    5286                 :      322169 :             if ((*e)->expr_type != EXPR_ARRAY)
    5287                 :             :               break;
    5288                 :             : 
    5289                 :             :             /* Fall through to the variable case in order to walk the
    5290                 :             :                reference.  */
    5291                 :     7094618 :             gcc_fallthrough ();
    5292                 :             : 
    5293                 :     7094618 :           case EXPR_SUBSTRING:
    5294                 :     7094618 :           case EXPR_VARIABLE:
    5295                 :     9840003 :             for (r = (*e)->ref; r; r = r->next)
    5296                 :             :               {
    5297                 :     2745406 :                 gfc_array_ref *ar;
    5298                 :     2745406 :                 int i;
    5299                 :             : 
    5300                 :     2745406 :                 switch (r->type)
    5301                 :             :                   {
    5302                 :     2212578 :                   case REF_ARRAY:
    5303                 :     2212578 :                     ar = &r->u.ar;
    5304                 :     2212578 :                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
    5305                 :             :                       {
    5306                 :     2258596 :                         for (i=0; i< ar->dimen; i++)
    5307                 :             :                           {
    5308                 :     1277855 :                             WALK_SUBEXPR (ar->start[i]);
    5309                 :     1277834 :                             WALK_SUBEXPR (ar->end[i]);
    5310                 :     1277834 :                             WALK_SUBEXPR (ar->stride[i]);
    5311                 :             :                           }
    5312                 :             :                       }
    5313                 :             : 
    5314                 :             :                     break;
    5315                 :             : 
    5316                 :       75832 :                   case REF_SUBSTRING:
    5317                 :       75832 :                     WALK_SUBEXPR (r->u.ss.start);
    5318                 :       75832 :                     WALK_SUBEXPR (r->u.ss.end);
    5319                 :             :                     break;
    5320                 :             : 
    5321                 :             :                   case REF_COMPONENT:
    5322                 :             :                   case REF_INQUIRY:
    5323                 :             :                     break;
    5324                 :             :                   }
    5325                 :             :               }
    5326                 :             : 
    5327                 :             :           default:
    5328                 :             :             break;
    5329                 :     2595451 :           }
    5330                 :             :       return 0;
    5331                 :             :     }
    5332                 :             :   return 0;
    5333                 :             : }
    5334                 :             : 
    5335                 :             : #define WALK_SUBCODE(NODE) \
    5336                 :             :   do                                                            \
    5337                 :             :     {                                                           \
    5338                 :             :       result = gfc_code_walker (&(NODE), codefn, exprfn, data);     \
    5339                 :             :       if (result)                                               \
    5340                 :             :         return result;                                          \
    5341                 :             :     }                                                           \
    5342                 :             :   while (0)
    5343                 :             : 
    5344                 :             : /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
    5345                 :             :    on each expression in it.  If any of the hooks returns non-zero, that
    5346                 :             :    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
    5347                 :             :    no subcodes or subexpressions are traversed.  */
    5348                 :             : 
    5349                 :             : int
    5350                 :     7253365 : gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
    5351                 :             :                  void *data)
    5352                 :             : {
    5353                 :    19132341 :   for (; *c; c = &(*c)->next)
    5354                 :             :     {
    5355                 :    11879365 :       int walk_subtrees = 1;
    5356                 :    11879365 :       int result = codefn (c, &walk_subtrees, data);
    5357                 :    11879365 :       if (result)
    5358                 :         389 :         return result;
    5359                 :             : 
    5360                 :    11879050 :       if (walk_subtrees)
    5361                 :             :         {
    5362                 :    11853590 :           gfc_code *b;
    5363                 :    11853590 :           gfc_actual_arglist *a;
    5364                 :    11853590 :           gfc_code *co;
    5365                 :    11853590 :           gfc_association_list *alist;
    5366                 :    11853590 :           bool saved_in_omp_workshare;
    5367                 :    11853590 :           bool saved_in_omp_atomic;
    5368                 :    11853590 :           bool saved_in_where;
    5369                 :             : 
    5370                 :             :           /* There might be statement insertions before the current code,
    5371                 :             :              which must not affect the expression walker.  */
    5372                 :             : 
    5373                 :    11853590 :           co = *c;
    5374                 :    11853590 :           saved_in_omp_workshare = in_omp_workshare;
    5375                 :    11853590 :           saved_in_omp_atomic = in_omp_atomic;
    5376                 :    11853590 :           saved_in_where = in_where;
    5377                 :             : 
    5378                 :    11853590 :           switch (co->op)
    5379                 :             :             {
    5380                 :             : 
    5381                 :      127106 :             case EXEC_BLOCK:
    5382                 :      127106 :               WALK_SUBCODE (co->ext.block.ns->code);
    5383                 :      127100 :               if (co->ext.block.assoc)
    5384                 :             :                 {
    5385                 :       62062 :                   bool saved_in_assoc_list = in_assoc_list;
    5386                 :             : 
    5387                 :       62062 :                   in_assoc_list = true;
    5388                 :      125527 :                   for (alist = co->ext.block.assoc; alist; alist = alist->next)
    5389                 :       63465 :                     WALK_SUBEXPR (alist->target);
    5390                 :             : 
    5391                 :       62062 :                   in_assoc_list = saved_in_assoc_list;
    5392                 :             :                 }
    5393                 :             : 
    5394                 :             :               break;
    5395                 :             : 
    5396                 :      464281 :             case EXEC_DO:
    5397                 :      464281 :               doloop_level ++;
    5398                 :      464281 :               WALK_SUBEXPR (co->ext.iterator->var);
    5399                 :      464281 :               WALK_SUBEXPR (co->ext.iterator->start);
    5400                 :      464281 :               WALK_SUBEXPR (co->ext.iterator->end);
    5401                 :      464280 :               WALK_SUBEXPR (co->ext.iterator->step);
    5402                 :             :               break;
    5403                 :             : 
    5404                 :     2519881 :             case EXEC_IF:
    5405                 :     2519881 :               if_level ++;
    5406                 :     2519881 :               break;
    5407                 :             : 
    5408                 :        5494 :             case EXEC_WHERE:
    5409                 :        5494 :               in_where = true;
    5410                 :        5494 :               break;
    5411                 :             : 
    5412                 :      930473 :             case EXEC_CALL:
    5413                 :      930473 :             case EXEC_ASSIGN_CALL:
    5414                 :     3087504 :               for (a = co->ext.actual; a; a = a->next)
    5415                 :     2157031 :                 WALK_SUBEXPR (a->expr);
    5416                 :             :               break;
    5417                 :             : 
    5418                 :        1415 :             case EXEC_CALL_PPC:
    5419                 :        1415 :               WALK_SUBEXPR (co->expr1);
    5420                 :        3410 :               for (a = co->ext.actual; a; a = a->next)
    5421                 :        1995 :                 WALK_SUBEXPR (a->expr);
    5422                 :             :               break;
    5423                 :             : 
    5424                 :       12092 :             case EXEC_SELECT:
    5425                 :       12092 :               WALK_SUBEXPR (co->expr1);
    5426                 :       12092 :               select_level ++;
    5427                 :       37663 :               for (b = co->block; b; b = b->block)
    5428                 :             :                 {
    5429                 :       25571 :                   gfc_case *cp;
    5430                 :       53690 :                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
    5431                 :             :                     {
    5432                 :       28119 :                       WALK_SUBEXPR (cp->low);
    5433                 :       28119 :                       WALK_SUBEXPR (cp->high);
    5434                 :             :                     }
    5435                 :       25571 :                   WALK_SUBCODE (b->next);
    5436                 :             :                 }
    5437                 :       12092 :               continue;
    5438                 :             : 
    5439                 :      233707 :             case EXEC_ALLOCATE:
    5440                 :      233707 :             case EXEC_DEALLOCATE:
    5441                 :      233707 :               {
    5442                 :      233707 :                 gfc_alloc *a;
    5443                 :      521094 :                 for (a = co->ext.alloc.list; a; a = a->next)
    5444                 :      287387 :                   WALK_SUBEXPR (a->expr);
    5445                 :             :                 break;
    5446                 :             :               }
    5447                 :             : 
    5448                 :       47350 :             case EXEC_FORALL:
    5449                 :       47350 :             case EXEC_DO_CONCURRENT:
    5450                 :       47350 :               {
    5451                 :       47350 :                 gfc_forall_iterator *fa;
    5452                 :      151523 :                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    5453                 :             :                   {
    5454                 :      104173 :                     WALK_SUBEXPR (fa->var);
    5455                 :      104173 :                     WALK_SUBEXPR (fa->start);
    5456                 :      104173 :                     WALK_SUBEXPR (fa->end);
    5457                 :      104173 :                     WALK_SUBEXPR (fa->stride);
    5458                 :             :                   }
    5459                 :       47350 :                 if (co->op == EXEC_FORALL)
    5460                 :       46603 :                   forall_level ++;
    5461                 :             :                 break;
    5462                 :             :               }
    5463                 :             : 
    5464                 :       42471 :             case EXEC_OPEN:
    5465                 :       42471 :               WALK_SUBEXPR (co->ext.open->unit);
    5466                 :       42471 :               WALK_SUBEXPR (co->ext.open->file);
    5467                 :       42471 :               WALK_SUBEXPR (co->ext.open->status);
    5468                 :       42471 :               WALK_SUBEXPR (co->ext.open->access);
    5469                 :       42471 :               WALK_SUBEXPR (co->ext.open->form);
    5470                 :       42471 :               WALK_SUBEXPR (co->ext.open->recl);
    5471                 :       42471 :               WALK_SUBEXPR (co->ext.open->blank);
    5472                 :       42471 :               WALK_SUBEXPR (co->ext.open->position);
    5473                 :       42471 :               WALK_SUBEXPR (co->ext.open->action);
    5474                 :       42471 :               WALK_SUBEXPR (co->ext.open->delim);
    5475                 :       42471 :               WALK_SUBEXPR (co->ext.open->pad);
    5476                 :       42471 :               WALK_SUBEXPR (co->ext.open->iostat);
    5477                 :       42471 :               WALK_SUBEXPR (co->ext.open->iomsg);
    5478                 :       42471 :               WALK_SUBEXPR (co->ext.open->convert);
    5479                 :       42471 :               WALK_SUBEXPR (co->ext.open->decimal);
    5480                 :       42471 :               WALK_SUBEXPR (co->ext.open->encoding);
    5481                 :       42471 :               WALK_SUBEXPR (co->ext.open->round);
    5482                 :       42471 :               WALK_SUBEXPR (co->ext.open->sign);
    5483                 :       42471 :               WALK_SUBEXPR (co->ext.open->asynchronous);
    5484                 :       42471 :               WALK_SUBEXPR (co->ext.open->id);
    5485                 :       42471 :               WALK_SUBEXPR (co->ext.open->newunit);
    5486                 :       42471 :               WALK_SUBEXPR (co->ext.open->share);
    5487                 :       42471 :               WALK_SUBEXPR (co->ext.open->cc);
    5488                 :             :               break;
    5489                 :             : 
    5490                 :       35846 :             case EXEC_CLOSE:
    5491                 :       35846 :               WALK_SUBEXPR (co->ext.close->unit);
    5492                 :       35846 :               WALK_SUBEXPR (co->ext.close->status);
    5493                 :       35846 :               WALK_SUBEXPR (co->ext.close->iostat);
    5494                 :       35846 :               WALK_SUBEXPR (co->ext.close->iomsg);
    5495                 :             :               break;
    5496                 :             : 
    5497                 :       30729 :             case EXEC_BACKSPACE:
    5498                 :       30729 :             case EXEC_ENDFILE:
    5499                 :       30729 :             case EXEC_REWIND:
    5500                 :       30729 :             case EXEC_FLUSH:
    5501                 :       30729 :               WALK_SUBEXPR (co->ext.filepos->unit);
    5502                 :       30729 :               WALK_SUBEXPR (co->ext.filepos->iostat);
    5503                 :       30729 :               WALK_SUBEXPR (co->ext.filepos->iomsg);
    5504                 :             :               break;
    5505                 :             : 
    5506                 :        9536 :             case EXEC_INQUIRE:
    5507                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->unit);
    5508                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->file);
    5509                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->iomsg);
    5510                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->iostat);
    5511                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->exist);
    5512                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->opened);
    5513                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->number);
    5514                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->named);
    5515                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->name);
    5516                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->access);
    5517                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->sequential);
    5518                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->direct);
    5519                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->form);
    5520                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->formatted);
    5521                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->unformatted);
    5522                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->recl);
    5523                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->nextrec);
    5524                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->blank);
    5525                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->position);
    5526                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->action);
    5527                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->read);
    5528                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->write);
    5529                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->readwrite);
    5530                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->delim);
    5531                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->encoding);
    5532                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->pad);
    5533                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->iolength);
    5534                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->convert);
    5535                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->strm_pos);
    5536                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->asynchronous);
    5537                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->decimal);
    5538                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->pending);
    5539                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->id);
    5540                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->sign);
    5541                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->size);
    5542                 :        9536 :               WALK_SUBEXPR (co->ext.inquire->round);
    5543                 :             :               break;
    5544                 :             : 
    5545                 :         887 :             case EXEC_WAIT:
    5546                 :         887 :               WALK_SUBEXPR (co->ext.wait->unit);
    5547                 :         887 :               WALK_SUBEXPR (co->ext.wait->iostat);
    5548                 :         887 :               WALK_SUBEXPR (co->ext.wait->iomsg);
    5549                 :         887 :               WALK_SUBEXPR (co->ext.wait->id);
    5550                 :             :               break;
    5551                 :             : 
    5552                 :      338129 :             case EXEC_READ:
    5553                 :      338129 :             case EXEC_WRITE:
    5554                 :      338129 :               WALK_SUBEXPR (co->ext.dt->io_unit);
    5555                 :      338129 :               WALK_SUBEXPR (co->ext.dt->format_expr);
    5556                 :      338129 :               WALK_SUBEXPR (co->ext.dt->rec);
    5557                 :      338129 :               WALK_SUBEXPR (co->ext.dt->advance);
    5558                 :      338129 :               WALK_SUBEXPR (co->ext.dt->iostat);
    5559                 :      338129 :               WALK_SUBEXPR (co->ext.dt->size);
    5560                 :      338129 :               WALK_SUBEXPR (co->ext.dt->iomsg);
    5561                 :      338129 :               WALK_SUBEXPR (co->ext.dt->id);
    5562                 :      338129 :               WALK_SUBEXPR (co->ext.dt->pos);
    5563                 :      338129 :               WALK_SUBEXPR (co->ext.dt->asynchronous);
    5564                 :      338129 :               WALK_SUBEXPR (co->ext.dt->blank);
    5565                 :      338129 :               WALK_SUBEXPR (co->ext.dt->decimal);
    5566                 :      338129 :               WALK_SUBEXPR (co->ext.dt->delim);
    5567                 :      338129 :               WALK_SUBEXPR (co->ext.dt->pad);
    5568                 :      338129 :               WALK_SUBEXPR (co->ext.dt->round);
    5569                 :      338129 :               WALK_SUBEXPR (co->ext.dt->sign);
    5570                 :      338129 :               WALK_SUBEXPR (co->ext.dt->extra_comma);
    5571                 :             :               break;
    5572                 :             : 
    5573                 :       33370 :             case EXEC_OACC_ATOMIC:
    5574                 :       33370 :             case EXEC_OMP_ATOMIC:
    5575                 :       33370 :               in_omp_atomic = true;
    5576                 :       33370 :               break;
    5577                 :             : 
    5578                 :       40477 :             case EXEC_OMP_PARALLEL:
    5579                 :       40477 :             case EXEC_OMP_PARALLEL_DO:
    5580                 :       40477 :             case EXEC_OMP_PARALLEL_DO_SIMD:
    5581                 :       40477 :             case EXEC_OMP_PARALLEL_LOOP:
    5582                 :       40477 :             case EXEC_OMP_PARALLEL_MASKED:
    5583                 :       40477 :             case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
    5584                 :       40477 :             case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
    5585                 :       40477 :             case EXEC_OMP_PARALLEL_MASTER:
    5586                 :       40477 :             case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
    5587                 :       40477 :             case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
    5588                 :       40477 :             case EXEC_OMP_PARALLEL_SECTIONS:
    5589                 :             : 
    5590                 :       40477 :               in_omp_workshare = false;
    5591                 :             : 
    5592                 :             :               /* This goto serves as a shortcut to avoid code
    5593                 :             :                  duplication or a larger if or switch statement.  */
    5594                 :       40477 :               goto check_omp_clauses;
    5595                 :             : 
    5596                 :        1139 :             case EXEC_OMP_WORKSHARE:
    5597                 :        1139 :             case EXEC_OMP_PARALLEL_WORKSHARE:
    5598                 :             : 
    5599                 :        1139 :               in_omp_workshare = true;
    5600                 :             : 
    5601                 :             :               /* Fall through  */
    5602                 :             : 
    5603                 :      171137 :             case EXEC_OMP_CRITICAL:
    5604                 :      171137 :             case EXEC_OMP_DISTRIBUTE:
    5605                 :      171137 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
    5606                 :      171137 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    5607                 :      171137 :             case EXEC_OMP_DISTRIBUTE_SIMD:
    5608                 :      171137 :             case EXEC_OMP_DO:
    5609                 :      171137 :             case EXEC_OMP_DO_SIMD:
    5610                 :      171137 :             case EXEC_OMP_LOOP:
    5611                 :      171137 :             case EXEC_OMP_ORDERED:
    5612                 :      171137 :             case EXEC_OMP_SECTIONS:
    5613                 :      171137 :             case EXEC_OMP_SINGLE:
    5614                 :      171137 :             case EXEC_OMP_END_SINGLE:
    5615                 :      171137 :             case EXEC_OMP_SIMD:
    5616                 :      171137 :             case EXEC_OMP_TASKLOOP:
    5617                 :      171137 :             case EXEC_OMP_TASKLOOP_SIMD:
    5618                 :      171137 :             case EXEC_OMP_TARGET:
    5619                 :      171137 :             case EXEC_OMP_TARGET_DATA:
    5620                 :      171137 :             case EXEC_OMP_TARGET_ENTER_DATA:
    5621                 :      171137 :             case EXEC_OMP_TARGET_EXIT_DATA:
    5622                 :      171137 :             case EXEC_OMP_TARGET_PARALLEL:
    5623                 :      171137 :             case EXEC_OMP_TARGET_PARALLEL_DO:
    5624                 :      171137 :             case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
    5625                 :      171137 :             case EXEC_OMP_TARGET_PARALLEL_LOOP:
    5626                 :      171137 :             case EXEC_OMP_TARGET_SIMD:
    5627                 :      171137 :             case EXEC_OMP_TARGET_TEAMS:
    5628                 :      171137 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
    5629                 :      171137 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5630                 :      171137 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5631                 :      171137 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    5632                 :      171137 :             case EXEC_OMP_TARGET_TEAMS_LOOP:
    5633                 :      171137 :             case EXEC_OMP_TARGET_UPDATE:
    5634                 :      171137 :             case EXEC_OMP_TASK:
    5635                 :      171137 :             case EXEC_OMP_TEAMS:
    5636                 :      171137 :             case EXEC_OMP_TEAMS_DISTRIBUTE:
    5637                 :      171137 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5638                 :      171137 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5639                 :      171137 :             case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
    5640                 :      171137 :             case EXEC_OMP_TEAMS_LOOP:
    5641                 :             : 
    5642                 :             :               /* Come to this label only from the
    5643                 :             :                  EXEC_OMP_PARALLEL_* cases above.  */
    5644                 :             : 
    5645                 :      171137 :             check_omp_clauses:
    5646                 :             : 
    5647                 :      171137 :               if (co->ext.omp_clauses)
    5648                 :             :                 {
    5649                 :      171137 :                   gfc_omp_namelist *n;
    5650                 :      171137 :                   static int list_types[]
    5651                 :             :                     = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
    5652                 :             :                         OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
    5653                 :      171137 :                   size_t idx;
    5654                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
    5655                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
    5656                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
    5657                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
    5658                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
    5659                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
    5660                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower);
    5661                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper);
    5662                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->device);
    5663                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
    5664                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
    5665                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
    5666                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->hint);
    5667                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
    5668                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->priority);
    5669                 :      171137 :                   WALK_SUBEXPR (co->ext.omp_clauses->detach);
    5670                 :     1882507 :                   for (idx = 0; idx < OMP_IF_LAST; idx++)
    5671                 :     1711370 :                     WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
    5672                 :     1197959 :                   for (idx = 0; idx < ARRAY_SIZE (list_types); idx++)
    5673                 :     1026822 :                     for (n = co->ext.omp_clauses->lists[list_types[idx]];
    5674                 :     1144745 :                          n; n = n->next)
    5675                 :      117923 :                       WALK_SUBEXPR (n->expr);
    5676                 :             :                 }
    5677                 :             :               break;
    5678                 :             :             default:
    5679                 :             :               break;
    5680                 :       12092 :             }
    5681                 :             : 
    5682                 :    11841491 :           WALK_SUBEXPR (co->expr1);
    5683                 :    11841485 :           WALK_SUBEXPR (co->expr2);
    5684                 :    11841456 :           WALK_SUBEXPR (co->expr3);
    5685                 :    11841449 :           WALK_SUBEXPR (co->expr4);
    5686                 :    15670817 :           for (b = co->block; b; b = b->block)
    5687                 :             :             {
    5688                 :     3829393 :               WALK_SUBEXPR (b->expr1);
    5689                 :     3829393 :               WALK_SUBEXPR (b->expr2);
    5690                 :     3829393 :               WALK_SUBCODE (b->next);
    5691                 :             :             }
    5692                 :             : 
    5693                 :    11841424 :           if (co->op == EXEC_FORALL)
    5694                 :       46603 :             forall_level --;
    5695                 :             : 
    5696                 :    11841424 :           if (co->op == EXEC_DO)
    5697                 :      464280 :             doloop_level --;
    5698                 :             : 
    5699                 :    11841424 :           if (co->op == EXEC_IF)
    5700                 :     2519856 :             if_level --;
    5701                 :             : 
    5702                 :    11841424 :           if (co->op == EXEC_SELECT)
    5703                 :           0 :             select_level --;
    5704                 :             : 
    5705                 :    11841424 :           in_omp_workshare = saved_in_omp_workshare;
    5706                 :    11841424 :           in_omp_atomic = saved_in_omp_atomic;
    5707                 :    11841424 :           in_where = saved_in_where;
    5708                 :             :         }
    5709                 :             :     }
    5710                 :             :   return 0;
    5711                 :             : }
    5712                 :             : 
    5713                 :             : /* As a post-resolution step, check that all global symbols which are
    5714                 :             :    not declared in the source file match in their call signatures.
    5715                 :             :    We do this by looping over the code (and expressions). The first call
    5716                 :             :    we happen to find is assumed to be canonical.  */
    5717                 :             : 
    5718                 :             : 
    5719                 :             : /* Common tests for argument checking for both functions and subroutines.  */
    5720                 :             : 
    5721                 :             : static int
    5722                 :      114273 : check_externals_procedure (gfc_symbol *sym, locus *loc,
    5723                 :             :                            gfc_actual_arglist *actual)
    5724                 :             : {
    5725                 :      114273 :   gfc_gsymbol *gsym;
    5726                 :      114273 :   gfc_symbol *def_sym = NULL;
    5727                 :             : 
    5728                 :      114273 :  if (sym == NULL || sym->attr.is_bind_c)
    5729                 :             :     return 0;
    5730                 :             : 
    5731                 :      107850 :   if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
    5732                 :             :     return 0;
    5733                 :             : 
    5734                 :       24195 :   if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
    5735                 :             :     return 0;
    5736                 :             : 
    5737                 :       16152 :   gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
    5738                 :       16152 :   if (gsym == NULL)
    5739                 :             :     return 0;
    5740                 :             : 
    5741                 :       15321 :   if (gsym->ns)
    5742                 :       14215 :     gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
    5743                 :             : 
    5744                 :       15321 :   if (def_sym)
    5745                 :             :     {
    5746                 :       14215 :       gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
    5747                 :       14215 :       return 0;
    5748                 :             :     }
    5749                 :             : 
    5750                 :             :   /* First time we have seen this procedure called. Let's create an
    5751                 :             :      "interface" from the call and put it into a new namespace.  */
    5752                 :        1106 :   gfc_namespace *save_ns;
    5753                 :        1106 :   gfc_symbol *new_sym;
    5754                 :             : 
    5755                 :        1106 :   gsym->where = *loc;
    5756                 :        1106 :   save_ns = gfc_current_ns;
    5757                 :        1106 :   gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
    5758                 :        1106 :   gsym->ns->proc_name = sym;
    5759                 :             : 
    5760                 :        1106 :   gfc_get_symbol (sym->name, gsym->ns, &new_sym);
    5761                 :        1106 :   gcc_assert (new_sym);
    5762                 :        1106 :   new_sym->attr = sym->attr;
    5763                 :        1106 :   new_sym->attr.if_source = IFSRC_DECL;
    5764                 :        1106 :   gfc_current_ns = gsym->ns;
    5765                 :             : 
    5766                 :        1106 :   gfc_get_formal_from_actual_arglist (new_sym, actual);
    5767                 :        1106 :   new_sym->declared_at = *loc;
    5768                 :        1106 :   gfc_current_ns = save_ns;
    5769                 :             : 
    5770                 :        1106 :   return 0;
    5771                 :             : 
    5772                 :             : }
    5773                 :             : 
    5774                 :             : /* Callback for calls of external routines.  */
    5775                 :             : 
    5776                 :             : static int
    5777                 :      925175 : check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    5778                 :             :                       void *data ATTRIBUTE_UNUSED)
    5779                 :             : {
    5780                 :      925175 :   gfc_code *co = *c;
    5781                 :      925175 :   gfc_symbol *sym;
    5782                 :      925175 :   locus *loc;
    5783                 :      925175 :   gfc_actual_arglist *actual;
    5784                 :             : 
    5785                 :      925175 :   if (co->op != EXEC_CALL)
    5786                 :             :     return 0;
    5787                 :             : 
    5788                 :       71191 :   sym = co->resolved_sym;
    5789                 :       71191 :   loc = &co->loc;
    5790                 :       71191 :   actual = co->ext.actual;
    5791                 :             : 
    5792                 :       71191 :   return check_externals_procedure (sym, loc, actual);
    5793                 :             : 
    5794                 :             : }
    5795                 :             : 
    5796                 :             : /* Callback for external functions.  */
    5797                 :             : 
    5798                 :             : static int
    5799                 :     2632518 : check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
    5800                 :             :                       void *data ATTRIBUTE_UNUSED)
    5801                 :             : {
    5802                 :     2632518 :   gfc_expr *e = *ep;
    5803                 :     2632518 :   gfc_symbol *sym;
    5804                 :     2632518 :   locus *loc;
    5805                 :     2632518 :   gfc_actual_arglist *actual;
    5806                 :             : 
    5807                 :     2632518 :   if (e->expr_type != EXPR_FUNCTION)
    5808                 :             :     return 0;
    5809                 :             : 
    5810                 :      229748 :   sym = e->value.function.esym;
    5811                 :      229748 :   if (sym == NULL)
    5812                 :             :     return 0;
    5813                 :             : 
    5814                 :       43082 :   loc = &e->where;
    5815                 :       43082 :   actual = e->value.function.actual;
    5816                 :             : 
    5817                 :       43082 :   return check_externals_procedure (sym, loc, actual);
    5818                 :             : }
    5819                 :             : 
    5820                 :             : /* Function to check if any interface clashes with a global
    5821                 :             :    identifier, to be invoked via gfc_traverse_ns.  */
    5822                 :             : 
    5823                 :             : static void
    5824                 :      735644 : check_against_globals (gfc_symbol *sym)
    5825                 :             : {
    5826                 :      735644 :   gfc_gsymbol *gsym;
    5827                 :      735644 :   gfc_symbol *def_sym = NULL;
    5828                 :      735644 :   const char *sym_name;
    5829                 :      735644 :   char buf  [200];
    5830                 :             : 
    5831                 :      735644 :   if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE
    5832                 :      129038 :       || sym->attr.generic || sym->error)
    5833                 :      722178 :     return;
    5834                 :             : 
    5835                 :      121194 :   if (sym->binding_label)
    5836                 :             :     sym_name = sym->binding_label;
    5837                 :             :   else
    5838                 :      109472 :     sym_name = sym->name;
    5839                 :             : 
    5840                 :      121194 :   gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name);
    5841                 :      121194 :   if (gsym && gsym->ns)
    5842                 :       13509 :     gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
    5843                 :             : 
    5844                 :      121194 :   if (!def_sym || def_sym->error || def_sym->attr.generic)
    5845                 :             :     return;
    5846                 :             : 
    5847                 :       13466 :   buf[0] = 0;
    5848                 :       13466 :   gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf),
    5849                 :             :                           NULL, NULL, NULL);
    5850                 :       13466 :   if (buf[0] != 0)
    5851                 :             :     {
    5852                 :           4 :       gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at,
    5853                 :             :                    &sym->declared_at);
    5854                 :           4 :       sym->error = 1;
    5855                 :           4 :       def_sym->error = 1;
    5856                 :             :     }
    5857                 :             : 
    5858                 :             : }
    5859                 :             : 
    5860                 :             : /* Do the code-walkling part for gfc_check_externals.  */
    5861                 :             : 
    5862                 :             : static void
    5863                 :       83148 : gfc_check_externals0 (gfc_namespace *ns)
    5864                 :             : {
    5865                 :       83148 :   gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
    5866                 :             : 
    5867                 :      122070 :   for (ns = ns->contained; ns; ns = ns->sibling)
    5868                 :             :     {
    5869                 :       38922 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    5870                 :       38078 :         gfc_check_externals0 (ns);
    5871                 :             :     }
    5872                 :             : 
    5873                 :       83148 : }
    5874                 :             : 
    5875                 :             : /* Called routine.  */
    5876                 :             : 
    5877                 :             : void
    5878                 :       45070 : gfc_check_externals (gfc_namespace *ns)
    5879                 :             : {
    5880                 :       45070 :   gfc_clear_error ();
    5881                 :             : 
    5882                 :             :   /* Turn errors into warnings if the user indicated this.  */
    5883                 :             : 
    5884                 :       45070 :   if (!pedantic && flag_allow_argument_mismatch)
    5885                 :         995 :     gfc_errors_to_warnings (true);
    5886                 :             : 
    5887                 :       45070 :   gfc_check_externals0 (ns);
    5888                 :       45070 :   gfc_traverse_ns (ns, check_against_globals);
    5889                 :             : 
    5890                 :       45070 :   gfc_errors_to_warnings (false);
    5891                 :       45070 : }
    5892                 :             : 
    5893                 :             : /* Callback function. If there is a call to a subroutine which is
    5894                 :             :    neither pure nor implicit_pure, unset the implicit_pure flag for
    5895                 :             :    the caller and return -1.  */
    5896                 :             : 
    5897                 :             : static int
    5898                 :       22872 : implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    5899                 :             :                     void *sym_data)
    5900                 :             : {
    5901                 :       22872 :   gfc_code *co = *c;
    5902                 :       22872 :   gfc_symbol *caller_sym;
    5903                 :       22872 :   symbol_attribute *a;
    5904                 :             : 
    5905                 :       22872 :   if (co->op != EXEC_CALL || co->resolved_sym == NULL)
    5906                 :             :     return 0;
    5907                 :             : 
    5908                 :          85 :   a = &co->resolved_sym->attr;
    5909                 :          85 :   if (a->intrinsic || a->pure || a->implicit_pure)
    5910                 :             :     return 0;
    5911                 :             : 
    5912                 :          52 :   caller_sym = (gfc_symbol *) sym_data;
    5913                 :          52 :   gfc_unset_implicit_pure (caller_sym);
    5914                 :          52 :   return 1;
    5915                 :             : }
    5916                 :             : 
    5917                 :             : /* Callback function. If there is a call to a function which is
    5918                 :             :    neither pure nor implicit_pure, unset the implicit_pure flag for
    5919                 :             :    the caller and return 1.  */
    5920                 :             : 
    5921                 :             : static int
    5922                 :       49107 : implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data)
    5923                 :             : {
    5924                 :       49107 :   gfc_expr *expr = *e;
    5925                 :       49107 :   gfc_symbol *caller_sym;
    5926                 :       49107 :   gfc_symbol *sym;
    5927                 :       49107 :   symbol_attribute *a;
    5928                 :             : 
    5929                 :       49107 :   if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
    5930                 :             :     return 0;
    5931                 :             : 
    5932                 :         271 :   sym = expr->symtree->n.sym;
    5933                 :         271 :   a = &sym->attr;
    5934                 :         271 :   if (a->pure || a->implicit_pure)
    5935                 :             :     return 0;
    5936                 :             : 
    5937                 :          41 :   caller_sym = (gfc_symbol *) sym_data;
    5938                 :          41 :   gfc_unset_implicit_pure (caller_sym);
    5939                 :          41 :   return 1;
    5940                 :             : }
    5941                 :             : 
    5942                 :             : /* Go through all procedures in the namespace and unset the
    5943                 :             :    implicit_pure attribute for any procedure that calls something not
    5944                 :             :    pure or implicit pure.  */
    5945                 :             : 
    5946                 :             : bool
    5947                 :      116062 : gfc_fix_implicit_pure (gfc_namespace *ns)
    5948                 :             : {
    5949                 :      116062 :   bool changed = false;
    5950                 :      116062 :   gfc_symbol *proc = ns->proc_name;
    5951                 :             : 
    5952                 :      116014 :   if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure
    5953                 :        8853 :       && ns->code
    5954                 :      124897 :       && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr,
    5955                 :             :                           (void *) ns->proc_name))
    5956                 :             :     changed = true;
    5957                 :             : 
    5958                 :      178118 :   for (ns = ns->contained; ns; ns = ns->sibling)
    5959                 :             :     {
    5960                 :       62056 :       if (gfc_fix_implicit_pure (ns))
    5961                 :          94 :         changed = true;
    5962                 :             :     }
    5963                 :             : 
    5964                 :      116062 :   return changed;
    5965                 :             : }
        

Generated by: LCOV version 2.0-1

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,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.