LCOV - code coverage report
Current view: top level - gcc/fortran - frontend-passes.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 2579 2682 96.2 %
Date: 2020-03-28 11:57:23 Functions: 75 79 94.9 %
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-2020 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                 :     133453 : gfc_run_passes (gfc_namespace *ns)
     148                 :            : {
     149                 :            : 
     150                 :            :   /* Warn about dubious DO loops where the index might
     151                 :            :      change.  */
     152                 :            : 
     153                 :     133453 :   doloop_level = 0;
     154                 :     133453 :   if_level = 0;
     155                 :     133453 :   select_level = 0;
     156                 :     133453 :   doloop_warn (ns);
     157                 :     133453 :   doloop_list.release ();
     158                 :     133453 :   int w, e;
     159                 :            : 
     160                 :            : #ifdef CHECKING_P
     161                 :     133453 :   check_locus (ns);
     162                 :            : #endif
     163                 :            : 
     164                 :     133453 :   gfc_get_errors (&w, &e);
     165                 :     133453 :   if (e > 0)
     166                 :       2907 :     return;
     167                 :            : 
     168                 :     130546 :   if (flag_frontend_optimize || flag_frontend_loop_interchange)
     169                 :     108980 :     optimize_namespace (ns);
     170                 :            : 
     171                 :     130546 :   if (flag_frontend_optimize)
     172                 :            :     {
     173                 :     108972 :       optimize_reduction (ns);
     174                 :     108972 :       if (flag_dump_fortran_optimized)
     175                 :          0 :         gfc_dump_parse_tree (ns, stdout);
     176                 :            : 
     177                 :     108972 :       expr_array.release ();
     178                 :            :     }
     179                 :            : 
     180                 :     130546 :   if (flag_realloc_lhs)
     181                 :     130415 :     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                 :     729649 : check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     191                 :            :                   void *data ATTRIBUTE_UNUSED)
     192                 :            : {
     193                 :     729649 :   current_code = c;
     194                 :     729649 :   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                 :     729649 :   return 0;
     199                 :            : }
     200                 :            : 
     201                 :            : 
     202                 :            : /* Callback function: Warn if there is no location information in an
     203                 :            :    expression.  */
     204                 :            : 
     205                 :            : static int
     206                 :    2108860 : check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     207                 :            :                   void *data ATTRIBUTE_UNUSED)
     208                 :            : {
     209                 :            : 
     210                 :    2108860 :   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                 :    2108860 :   return 0;
     215                 :            : }
     216                 :            : 
     217                 :            : /* Run check for missing location information.  */
     218                 :            : 
     219                 :            : static void
     220                 :     162567 : check_locus (gfc_namespace *ns)
     221                 :            : {
     222                 :     162567 :   gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL);
     223                 :            : 
     224                 :     192159 :   for (ns = ns->contained; ns; ns = ns->sibling)
     225                 :            :     {
     226                 :      29592 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
     227                 :      29114 :         check_locus (ns);
     228                 :            :     }
     229                 :     162567 : }
     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                 :     723218 : realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     247                 :            :                          void *data ATTRIBUTE_UNUSED)
     248                 :            : {
     249                 :     723218 :   gfc_expr *expr1, *expr2;
     250                 :     723218 :   gfc_code *co = *c;
     251                 :     723218 :   gfc_expr *n;
     252                 :     723218 :   gfc_ref *ref;
     253                 :     723218 :   bool found_substr;
     254                 :            : 
     255                 :     723218 :   if (co->op != EXEC_ASSIGN)
     256                 :            :     return 0;
     257                 :            : 
     258                 :     160345 :   expr1 = co->expr1;
     259                 :     160345 :   if (expr1->ts.type != BT_CHARACTER
     260                 :      20646 :       || !gfc_expr_attr(expr1).allocatable
     261                 :     161909 :       || !expr1->ts.deferred)
     262                 :     159051 :     return 0;
     263                 :            : 
     264                 :       3814 :   if (is_fe_temp (expr1))
     265                 :            :     return 0;
     266                 :            : 
     267                 :       1226 :   expr2 = gfc_discard_nops (co->expr2);
     268                 :            : 
     269                 :       1226 :   if (expr2->expr_type == EXPR_VARIABLE)
     270                 :            :     {
     271                 :        415 :       found_substr = false;
     272                 :        555 :       for (ref = expr2->ref; ref; ref = ref->next)
     273                 :            :         {
     274                 :        278 :           if (ref->type == REF_SUBSTRING)
     275                 :            :             {
     276                 :            :               found_substr = true;
     277                 :            :               break;
     278                 :            :             }
     279                 :            :         }
     280                 :        415 :       if (!found_substr)
     281                 :            :         return 0;
     282                 :            :     }
     283                 :        811 :   else if (expr2->expr_type != EXPR_ARRAY
     284                 :        721 :            && (expr2->expr_type != EXPR_OP
     285                 :         73 :                || expr2->value.op.op != INTRINSIC_CONCAT))
     286                 :            :     return 0;
     287                 :            : 
     288                 :        301 :   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                 :         88 :   if (!gfc_dep_compare_expr (expr1, expr2))
     296                 :            :     return 0;
     297                 :            : 
     298                 :         88 :   current_code = c;
     299                 :         88 :   inserted_block = NULL;
     300                 :         88 :   changed_statement = NULL;
     301                 :         88 :   n = create_var (expr2, "realloc_string");
     302                 :         88 :   co->expr2 = n;
     303                 :         88 :   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                 :     608239 : optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
     311                 :            :                void *data ATTRIBUTE_UNUSED)
     312                 :            : {
     313                 :            : 
     314                 :     608239 :   gfc_exec_op op;
     315                 :            : 
     316                 :     608239 :   op = (*c)->op;
     317                 :            : 
     318                 :     608239 :   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
     319                 :     608239 :       || op == EXEC_CALL_PPC)
     320                 :      43732 :     count_arglist = 1;
     321                 :            :   else
     322                 :     564507 :     count_arglist = 0;
     323                 :            : 
     324                 :     608239 :   current_code = c;
     325                 :     608239 :   inserted_block = NULL;
     326                 :     608239 :   changed_statement = NULL;
     327                 :            : 
     328                 :     608239 :   if (op == EXEC_ASSIGN)
     329                 :     135731 :     optimize_assignment (*c);
     330                 :     608239 :   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                 :    1769900 : optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     338                 :            :                void *data ATTRIBUTE_UNUSED)
     339                 :            : {
     340                 :    1769900 :   bool function_expr;
     341                 :            : 
     342                 :    1769900 :   if ((*e)->expr_type == EXPR_FUNCTION)
     343                 :            :     {
     344                 :     151714 :       count_arglist ++;
     345                 :     151714 :       function_expr = true;
     346                 :            :     }
     347                 :            :   else
     348                 :            :     function_expr = false;
     349                 :            : 
     350                 :    1769900 :   if (optimize_trim (*e))
     351                 :        375 :     gfc_simplify_expr (*e, 0);
     352                 :            : 
     353                 :    1769900 :   if (optimize_lexical_comparison (*e))
     354                 :         24 :     gfc_simplify_expr (*e, 0);
     355                 :            : 
     356                 :    1769900 :   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
     357                 :       1287 :     gfc_simplify_expr (*e, 0);
     358                 :            : 
     359                 :    1769900 :   if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
     360                 :     125951 :     switch ((*e)->value.function.isym->id)
     361                 :            :       {
     362                 :       7030 :       case GFC_ISYM_MINLOC:
     363                 :       7030 :       case GFC_ISYM_MAXLOC:
     364                 :       7030 :         optimize_minmaxloc (e);
     365                 :       7030 :         break;
     366                 :            :       default:
     367                 :            :         break;
     368                 :            :       }
     369                 :            : 
     370                 :    1769900 :   if (function_expr)
     371                 :     151714 :     count_arglist --;
     372                 :            : 
     373                 :    1769900 :   return 0;
     374                 :            : }
     375                 :            : 
     376                 :            : /* Auxiliary function to handle the arguments to reduction intrnisics.  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                 :        375 : copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
     382                 :            : {
     383                 :        375 :   gfc_expr *fcn, *e = c->expr;
     384                 :            : 
     385                 :        375 :   fcn = gfc_copy_expr (e);
     386                 :        375 :   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                 :        375 :   if (fcn->rank != 0)
     407                 :            :     {
     408                 :         94 :       gfc_isym_id id = fn->value.function.isym->id;
     409                 :            : 
     410                 :         94 :       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                 :         29 :       else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
     415                 :         29 :         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                 :         94 :       fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
     422                 :            :     }
     423                 :            : 
     424                 :        375 :   return fcn;
     425                 :            : }
     426                 :            : 
     427                 :            : /* Callback function for optimzation of reductions to scalars.  Transform ANY
     428                 :            :    ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
     429                 :            :    correspondingly.  Handly only the simple cases without MASK and DIM.  */
     430                 :            : 
     431                 :            : static int
     432                 :    1814330 : callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     433                 :            :                     void *data ATTRIBUTE_UNUSED)
     434                 :            : {
     435                 :    1814330 :   gfc_expr *fn, *arg;
     436                 :    1814330 :   gfc_intrinsic_op op;
     437                 :    1814330 :   gfc_isym_id id;
     438                 :    1814330 :   gfc_actual_arglist *a;
     439                 :    1814330 :   gfc_actual_arglist *dim;
     440                 :    1814330 :   gfc_constructor *c;
     441                 :    1814330 :   gfc_expr *res, *new_expr;
     442                 :    1814330 :   gfc_actual_arglist *mask;
     443                 :            : 
     444                 :    1814330 :   fn = *e;
     445                 :            : 
     446                 :    1814330 :   if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
     447                 :     135509 :       || fn->value.function.isym == NULL)
     448                 :            :     return 0;
     449                 :            : 
     450                 :     112518 :   id = fn->value.function.isym->id;
     451                 :            : 
     452                 :     112518 :   if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
     453                 :     111302 :       && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
     454                 :            :     return 0;
     455                 :            : 
     456                 :      18840 :   a = fn->value.function.actual;
     457                 :            : 
     458                 :            :   /* Don't handle MASK or DIM.  */
     459                 :            : 
     460                 :      18840 :   dim = a->next;
     461                 :            : 
     462                 :      18840 :   if (dim->expr != NULL)
     463                 :            :     return 0;
     464                 :            : 
     465                 :      18713 :   if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
     466                 :            :     {
     467                 :       1090 :       mask = dim->next;
     468                 :       1090 :       if ( mask->expr != NULL)
     469                 :            :         return 0;
     470                 :            :     }
     471                 :            : 
     472                 :      18589 :   arg = a->expr;
     473                 :            : 
     474                 :      18589 :   if (arg->expr_type != EXPR_ARRAY)
     475                 :            :     return 0;
     476                 :            : 
     477                 :        142 :   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                 :         76 :     case GFC_ISYM_ANY:
     488                 :         76 :       op = INTRINSIC_OR;
     489                 :         76 :       break;
     490                 :            : 
     491                 :          0 :     case GFC_ISYM_ALL:
     492                 :          0 :       op = INTRINSIC_AND;
     493                 :          0 :       break;
     494                 :            : 
     495                 :            :     default:
     496                 :            :       return 0;
     497                 :            :     }
     498                 :            : 
     499                 :        142 :   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                 :        142 :   if (c == NULL)
     507                 :            :     return 0;
     508                 :            : 
     509                 :        142 :   res = copy_walk_reduction_arg (c, fn);
     510                 :            : 
     511                 :        142 :   c = gfc_constructor_next (c);
     512                 :        375 :   while (c)
     513                 :            :     {
     514                 :        233 :       new_expr = gfc_get_expr ();
     515                 :        233 :       new_expr->ts = fn->ts;
     516                 :        233 :       new_expr->expr_type = EXPR_OP;
     517                 :        233 :       new_expr->rank = fn->rank;
     518                 :        233 :       new_expr->where = fn->where;
     519                 :        233 :       new_expr->value.op.op = op;
     520                 :        233 :       new_expr->value.op.op1 = res;
     521                 :        233 :       new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
     522                 :        233 :       res = new_expr;
     523                 :        233 :       c = gfc_constructor_next (c);
     524                 :            :     }
     525                 :            : 
     526                 :        142 :   gfc_simplify_expr (res, 0);
     527                 :        142 :   *e = res;
     528                 :        142 :   gfc_free_expr (fn);
     529                 :            : 
     530                 :        142 :   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                 :    1748920 : cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
     538                 :            :           void *data ATTRIBUTE_UNUSED)
     539                 :            : {
     540                 :            : 
     541                 :    1748920 :   if ((*e)->expr_type != EXPR_FUNCTION)
     542                 :            :     return 0;
     543                 :            : 
     544                 :            :   /* We don't do character functions with unknown charlens.  */
     545                 :     149462 :   if ((*e)->ts.type == BT_CHARACTER
     546                 :       8356 :       && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
     547                 :       6108 :           || (*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                 :     145578 :   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                 :     144501 :   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                 :     144318 :   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                 :     144301 :   if ((*e)->value.function.esym)
     573                 :            :     {
     574                 :            :       /* Don't create an array temporary for elemental functions.  */
     575                 :      21646 :       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                 :      21061 :       if (!flag_aggressive_function_elimination
     581                 :      21045 :           && !(*e)->value.function.esym->attr.pure
     582                 :      14911 :           && !(*e)->value.function.esym->attr.implicit_pure)
     583                 :            :         return 0;
     584                 :            :     }
     585                 :            : 
     586                 :     131407 :   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                 :     120445 :       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
     591                 :     120445 :           || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
     592                 :     120445 :           || gfc_inline_intrinsic_function_p (*e))
     593                 :      21929 :         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                 :      98516 :       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
     599                 :            :         return 0;
     600                 :            : 
     601                 :      95296 :       if (!(*e)->value.function.isym->pure)
     602                 :            :         return 0;
     603                 :            :     }
     604                 :            : 
     605                 :     103049 :   expr_array.safe_push (e);
     606                 :     103049 :   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                 :       2277 : is_fe_temp (gfc_expr *e)
     614                 :            : {
     615                 :       2277 :   if (e->expr_type != EXPR_VARIABLE)
     616                 :            :     return false;
     617                 :            : 
     618                 :       1294 :   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                 :         90 : constant_string_length (gfc_expr *e)
     629                 :            : {
     630                 :            : 
     631                 :         90 :   gfc_expr *length;
     632                 :         90 :   gfc_ref *ref;
     633                 :         90 :   gfc_expr *res;
     634                 :         90 :   mpz_t value;
     635                 :            : 
     636                 :         90 :   if (e->ts.u.cl)
     637                 :            :     {
     638                 :         90 :       length = e->ts.u.cl->length;
     639                 :         90 :       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                 :        104 :   for (ref = e->ref; ref; ref = ref->next)
     646                 :            :     {
     647                 :         66 :       if (ref->type == REF_SUBSTRING)
     648                 :            :         {
     649                 :         48 :           if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
     650                 :            :             {
     651                 :         12 :               res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
     652                 :            :                                            &e->where);
     653                 :            : 
     654                 :         12 :               mpz_add_ui (res->value.integer, value, 1);
     655                 :         12 :               mpz_clear (value);
     656                 :         12 :               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                 :       1679 : insert_block ()
     678                 :            : {
     679                 :       1679 :   gfc_namespace *ns;
     680                 :            : 
     681                 :            :   /* If the block hasn't already been created, do so.  */
     682                 :       1679 :   if (inserted_block == NULL)
     683                 :            :     {
     684                 :       1527 :       inserted_block = XCNEW (gfc_code);
     685                 :       1527 :       inserted_block->op = EXEC_BLOCK;
     686                 :       1527 :       inserted_block->loc = (*current_code)->loc;
     687                 :       1527 :       ns = gfc_build_block_ns (current_ns);
     688                 :       1527 :       inserted_block->ext.block.ns = ns;
     689                 :       1527 :       inserted_block->ext.block.assoc = NULL;
     690                 :            : 
     691                 :       1527 :       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                 :       1527 :       if ((*current_code)->here)
     697                 :            :         {
     698                 :          6 :           inserted_block->here = (*current_code)->here;
     699                 :          6 :           (*current_code)->here = NULL;
     700                 :            :         }
     701                 :            : 
     702                 :       1527 :       inserted_block->next = (*current_code)->next;
     703                 :       1527 :       changed_statement = &(inserted_block->ext.block.ns->code);
     704                 :       1527 :       (*current_code)->next = NULL;
     705                 :            :       /* Insert the BLOCK at the right position.  */
     706                 :       1527 :       *current_code = inserted_block;
     707                 :       1527 :       ns->parent = current_ns;
     708                 :            :     }
     709                 :            :   else
     710                 :        152 :     ns = inserted_block->ext.block.ns;
     711                 :            : 
     712                 :       1679 :   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                 :       1011 : create_var (gfc_expr * e, const char *vname)
     759                 :            : {
     760                 :       1011 :   char name[GFC_MAX_SYMBOL_LEN +1];
     761                 :       1011 :   gfc_symtree *symtree;
     762                 :       1011 :   gfc_symbol *symbol;
     763                 :       1011 :   gfc_expr *result;
     764                 :       1011 :   gfc_code *n;
     765                 :       1011 :   gfc_namespace *ns;
     766                 :       1011 :   int i;
     767                 :       1011 :   bool deferred;
     768                 :            : 
     769                 :       1107 :   if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
     770                 :         28 :     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                 :        983 :   if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL)
     775                 :            :     return NULL;
     776                 :            : 
     777                 :        982 :   ns = insert_block ();
     778                 :            : 
     779                 :        982 :   if (vname)
     780                 :        982 :     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                 :        982 :   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
     785                 :          0 :     gcc_unreachable ();
     786                 :            : 
     787                 :        982 :   symbol = symtree->n.sym;
     788                 :        982 :   symbol->ts = e->ts;
     789                 :            : 
     790                 :        982 :   if (e->rank > 0)
     791                 :            :     {
     792                 :        385 :       symbol->as = gfc_get_array_spec ();
     793                 :        385 :       symbol->as->rank = e->rank;
     794                 :            : 
     795                 :        385 :       if (e->shape == NULL)
     796                 :            :         {
     797                 :            :           /* We don't know the shape at compile time, so we use an
     798                 :            :              allocatable.  */
     799                 :        160 :           symbol->as->type = AS_DEFERRED;
     800                 :        160 :           symbol->attr.allocatable = 1;
     801                 :            :         }
     802                 :            :       else
     803                 :            :         {
     804                 :        225 :           symbol->as->type = AS_EXPLICIT;
     805                 :            :           /* Copy the shape.  */
     806                 :        609 :           for (i=0; i<e->rank; i++)
     807                 :            :             {
     808                 :        384 :               gfc_expr *p, *q;
     809                 :            : 
     810                 :        384 :               p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
     811                 :            :                                          &(e->where));
     812                 :        384 :               mpz_set_si (p->value.integer, 1);
     813                 :        384 :               symbol->as->lower[i] = p;
     814                 :            : 
     815                 :        384 :               q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
     816                 :            :                                          &(e->where));
     817                 :        384 :               mpz_set (q->value.integer, e->shape[i]);
     818                 :        384 :               symbol->as->upper[i] = q;
     819                 :            :             }
     820                 :            :         }
     821                 :            :     }
     822                 :            : 
     823                 :        982 :   deferred = 0;
     824                 :        982 :   if (e->ts.type == BT_CHARACTER)
     825                 :            :     {
     826                 :         90 :       gfc_expr *length;
     827                 :            : 
     828                 :         90 :       symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
     829                 :         90 :       length = constant_string_length (e);
     830                 :         90 :       if (length)
     831                 :         16 :         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                 :        982 :   symbol->attr.flavor = FL_VARIABLE;
     846                 :        982 :   symbol->attr.referenced = 1;
     847                 :        982 :   symbol->attr.dimension = e->rank > 0;
     848                 :        982 :   symbol->attr.fe_temp = 1;
     849                 :        982 :   gfc_commit_symbol (symbol);
     850                 :            : 
     851                 :        982 :   result = gfc_get_expr ();
     852                 :        982 :   result->expr_type = EXPR_VARIABLE;
     853                 :        982 :   result->ts = symbol->ts;
     854                 :        982 :   result->ts.deferred = deferred;
     855                 :        982 :   result->rank = e->rank;
     856                 :        982 :   result->shape = gfc_copy_shape (e->shape, e->rank);
     857                 :        982 :   result->symtree = symtree;
     858                 :        982 :   result->where = e->where;
     859                 :        982 :   if (e->rank > 0)
     860                 :            :     {
     861                 :        385 :       result->ref = gfc_get_ref ();
     862                 :        385 :       result->ref->type = REF_ARRAY;
     863                 :        385 :       result->ref->u.ar.type = AR_FULL;
     864                 :        385 :       result->ref->u.ar.where = e->where;
     865                 :        385 :       result->ref->u.ar.dimen = e->rank;
     866                 :        770 :       result->ref->u.ar.as = symbol->ts.type == BT_CLASS
     867                 :        385 :                              ? CLASS_DATA (symbol)->as : symbol->as;
     868                 :        385 :       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                 :        982 :   n = XCNEW (gfc_code);
     875                 :        982 :   n->op = EXEC_ASSIGN;
     876                 :        982 :   n->loc = (*current_code)->loc;
     877                 :        982 :   n->next = *changed_statement;
     878                 :        982 :   n->expr1 = gfc_copy_expr (result);
     879                 :        982 :   n->expr2 = e;
     880                 :        982 :   *changed_statement = n;
     881                 :        982 :   n_vars ++;
     882                 :            : 
     883                 :        982 :   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                 :     836378 : cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
     914                 :            :           void *data ATTRIBUTE_UNUSED)
     915                 :            : {
     916                 :     836378 :   int i,j;
     917                 :     836378 :   gfc_expr *newvar;
     918                 :     836378 :   gfc_expr **ei, **ej;
     919                 :            : 
     920                 :            :   /* Don't do this optimization within OMP workshare/atomic or ASSOC lists.  */
     921                 :            : 
     922                 :     836378 :   if (in_omp_workshare || in_omp_atomic || in_assoc_list)
     923                 :            :     {
     924                 :       6482 :       *walk_subtrees = 0;
     925                 :       6482 :       return 0;
     926                 :            :     }
     927                 :            : 
     928                 :     829896 :   expr_array.release ();
     929                 :            : 
     930                 :     829896 :   gfc_expr_walker (e, cfe_register_funcs, NULL);
     931                 :            : 
     932                 :            :   /* Walk through all the functions.  */
     933                 :            : 
     934                 :     846570 :   FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
     935                 :            :     {
     936                 :            :       /* Skip if the function has been replaced by a variable already.  */
     937                 :      16674 :       if ((*ei)->expr_type == EXPR_VARIABLE)
     938                 :          0 :         continue;
     939                 :            : 
     940                 :            :       newvar = NULL;
     941                 :      38569 :       for (j=0; j<i; j++)
     942                 :            :         {
     943                 :      21895 :           ej = expr_array[j];
     944                 :      21895 :           if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
     945                 :            :             {
     946                 :        435 :               if (newvar == NULL)
     947                 :        435 :                 newvar = create_var (*ei, "fcn");
     948                 :            : 
     949                 :        435 :               if (warn_function_elimination)
     950                 :          6 :                 do_warn_function_elimination (*ej);
     951                 :            : 
     952                 :        435 :               free (*ej);
     953                 :        435 :               *ej = gfc_copy_expr (newvar);
     954                 :            :             }
     955                 :            :         }
     956                 :      16674 :       if (newvar)
     957                 :        435 :         *ei = newvar;
     958                 :            :     }
     959                 :            : 
     960                 :            :   /* We did all the necessary walking in this function.  */
     961                 :     829896 :   *walk_subtrees = 0;
     962                 :     829896 :   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                 :     606649 : cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
     971                 :            : {
     972                 :     606649 :   current_code = c;
     973                 :     606649 :   inserted_block = NULL;
     974                 :     606649 :   changed_statement = NULL;
     975                 :            : 
     976                 :            :   /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
     977                 :            :      and allocation on assigment 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                 :     606649 :   if ((*c)->op == EXEC_WHERE)
     993                 :            :     {
     994                 :        347 :       *walk_subtrees = 0;
     995                 :        347 :       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                 :    5990380 : dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
    1007                 :            :                      void *data ATTRIBUTE_UNUSED)
    1008                 :            : {
    1009                 :    5990380 :   *walk_subtrees = 0;
    1010                 :    5990380 :   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                 :     769962 : gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
    1017                 :            :                          int *walk_subtrees ATTRIBUTE_UNUSED,
    1018                 :            :                          void *data ATTRIBUTE_UNUSED)
    1019                 :            : {
    1020                 :     769962 :   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                 :     606285 : convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    1035                 :            :                   void *data ATTRIBUTE_UNUSED)
    1036                 :            : {
    1037                 :     606285 :   gfc_code *co = *c;
    1038                 :     606285 :   gfc_code *c_if1, *c_if2, *c_exit;
    1039                 :     606285 :   gfc_code *loopblock;
    1040                 :     606285 :   gfc_expr *e_not, *e_cond;
    1041                 :            : 
    1042                 :     606285 :   if (co->op != EXEC_DO_WHILE)
    1043                 :            :     return 0;
    1044                 :            : 
    1045                 :        451 :   if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
    1046                 :            :     return 0;
    1047                 :            : 
    1048                 :        236 :   e_cond = co->expr1;
    1049                 :            : 
    1050                 :            :   /* Generate the condition of the if statement, which is .not. the original
    1051                 :            :      statement.  */
    1052                 :        236 :   e_not = gfc_get_expr ();
    1053                 :        236 :   e_not->ts = e_cond->ts;
    1054                 :        236 :   e_not->where = e_cond->where;
    1055                 :        236 :   e_not->expr_type = EXPR_OP;
    1056                 :        236 :   e_not->value.op.op = INTRINSIC_NOT;
    1057                 :        236 :   e_not->value.op.op1 = e_cond;
    1058                 :            : 
    1059                 :            :   /* Generate the EXIT statement.  */
    1060                 :        236 :   c_exit = XCNEW (gfc_code);
    1061                 :        236 :   c_exit->op = EXEC_EXIT;
    1062                 :        236 :   c_exit->ext.which_construct = co;
    1063                 :        236 :   c_exit->loc = co->loc;
    1064                 :            : 
    1065                 :            :   /* Generate the IF statement.  */
    1066                 :        236 :   c_if2 = XCNEW (gfc_code);
    1067                 :        236 :   c_if2->op = EXEC_IF;
    1068                 :        236 :   c_if2->expr1 = e_not;
    1069                 :        236 :   c_if2->next = c_exit;
    1070                 :        236 :   c_if2->loc = co->loc;
    1071                 :            : 
    1072                 :            :   /* ... plus the one to chain it to.  */
    1073                 :        236 :   c_if1 = XCNEW (gfc_code);
    1074                 :        236 :   c_if1->op = EXEC_IF;
    1075                 :        236 :   c_if1->block = c_if2;
    1076                 :        236 :   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                 :        236 :   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                 :        236 :   loopblock = co->block->next;
    1085                 :        236 :   co->block->next = c_if1;
    1086                 :        236 :   c_if1->next = loopblock;
    1087                 :            : 
    1088                 :        236 :   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                 :     607323 : convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    1109                 :            :                 void *data ATTRIBUTE_UNUSED)
    1110                 :            : {
    1111                 :     607323 :   gfc_code *co = *c;
    1112                 :     607323 :   gfc_code *c_if1, *c_if2, *else_stmt;
    1113                 :            : 
    1114                 :     607323 :   if (co->op != EXEC_IF)
    1115                 :            :     return 0;
    1116                 :            : 
    1117                 :            :   /* This loop starts out with the first ELSE statement.  */
    1118                 :     121323 :   else_stmt = co->block->block;
    1119                 :            : 
    1120                 :     122361 :   while (else_stmt != NULL)
    1121                 :            :     {
    1122                 :       4456 :       gfc_code *next_else;
    1123                 :            : 
    1124                 :            :       /* If there is no condition, we're done.  */
    1125                 :       4456 :       if (else_stmt->expr1 == NULL)
    1126                 :            :         break;
    1127                 :            : 
    1128                 :       1038 :       next_else = else_stmt->block;
    1129                 :            : 
    1130                 :            :       /* Generate the new IF statement.  */
    1131                 :       1038 :       c_if2 = XCNEW (gfc_code);
    1132                 :       1038 :       c_if2->op = EXEC_IF;
    1133                 :       1038 :       c_if2->expr1 = else_stmt->expr1;
    1134                 :       1038 :       c_if2->next = else_stmt->next;
    1135                 :       1038 :       c_if2->loc = else_stmt->loc;
    1136                 :       1038 :       c_if2->block = next_else;
    1137                 :            : 
    1138                 :            :       /* ... plus the one to chain it to.  */
    1139                 :       1038 :       c_if1 = XCNEW (gfc_code);
    1140                 :       1038 :       c_if1->op = EXEC_IF;
    1141                 :       1038 :       c_if1->block = c_if2;
    1142                 :       1038 :       c_if1->loc = else_stmt->loc;
    1143                 :            : 
    1144                 :            :       /* Insert the new IF after the ELSE.  */
    1145                 :       1038 :       else_stmt->expr1 = NULL;
    1146                 :       1038 :       else_stmt->next = c_if1;
    1147                 :       1038 :       else_stmt->block = NULL;
    1148                 :            : 
    1149                 :       1038 :       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                 :        501 : traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
    1199                 :            : {
    1200                 :        501 :   gfc_code *curr;
    1201                 :        501 :   gfc_expr *new_e, *expr, *start;
    1202                 :        501 :   gfc_ref *ref;
    1203                 :        501 :   struct do_stack ds_push;
    1204                 :        501 :   int i, future_rank = 0;
    1205                 :        501 :   gfc_iterator *iters[GFC_MAX_DIMENSIONS];
    1206                 :        501 :   gfc_expr *e;
    1207                 :            : 
    1208                 :            :   /* Find the first transfer/do statement.  */
    1209                 :        501 :   for (curr = code; curr; curr = curr->next)
    1210                 :            :     {
    1211                 :        501 :       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                 :        501 :   if (!curr || curr->next)
    1222                 :            :     return false;
    1223                 :            : 
    1224                 :        468 :   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                 :        437 :   gcc_assert (curr->op == EXEC_TRANSFER);
    1247                 :            : 
    1248                 :        437 :   e = curr->expr1;
    1249                 :        437 :   ref = e->ref;
    1250                 :        437 :   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                 :        795 :   for (i = 0; i < ref->u.ar.dimen; i++)
    1255                 :            :     {
    1256                 :        458 :       if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref
    1257                 :        458 :           || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
    1258                 :            :         return false;
    1259                 :            : 
    1260                 :        458 :       start = ref->u.ar.start[i];
    1261                 :        458 :       gfc_simplify_expr (start, 0);
    1262                 :        458 :       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                 :            :             }
    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                 :         24 :         case EXPR_OP:
    1294                 :         24 :           switch (start->value.op.op)
    1295                 :            :             {
    1296                 :         24 :             case INTRINSIC_PLUS:
    1297                 :         24 :             case INTRINSIC_TIMES:
    1298                 :         24 :               if (start->value.op.op1->expr_type != EXPR_VARIABLE)
    1299                 :          0 :                 std::swap (start->value.op.op1, start->value.op.op2);
    1300                 :         24 :               gcc_fallthrough ();
    1301                 :         24 :             case INTRINSIC_MINUS:
    1302                 :         24 :               if ((start->value.op.op1->expr_type!= EXPR_VARIABLE
    1303                 :          0 :                    && 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                 :     554919 : simplify_io_impl_do (gfc_code **code, int *walk_subtrees,
    1425                 :            :                      void *data ATTRIBUTE_UNUSED)
    1426                 :            : {
    1427                 :     554919 :   gfc_code **curr, *prev = NULL;
    1428                 :     554919 :   struct do_stack write, first;
    1429                 :     554919 :   bool b = false;
    1430                 :     554919 :   *walk_subtrees = 1;
    1431                 :     554919 :   if (!(*code)->block
    1432                 :     183628 :       || ((*code)->block->op != EXEC_WRITE
    1433                 :     183628 :           && (*code)->block->op != EXEC_READ))
    1434                 :            :     return 0;
    1435                 :            : 
    1436                 :      21137 :   *walk_subtrees = 0;
    1437                 :      21137 :   write.prev = NULL;
    1438                 :      21137 :   write.iter = NULL;
    1439                 :      21137 :   write.code = *code;
    1440                 :            : 
    1441                 :      92927 :   for (curr = &(*code)->block; *curr; curr = &(*curr)->next)
    1442                 :            :     {
    1443                 :      71790 :       if ((*curr)->op == EXEC_DO)
    1444                 :            :         {
    1445                 :        470 :           first.prev = &write;
    1446                 :        470 :           first.iter = (*curr)->ext.iterator;
    1447                 :        470 :           first.code = *curr;
    1448                 :        470 :           stack_top = &first;
    1449                 :        470 :           traverse_io_block ((*curr)->block->next, &b, prev);
    1450                 :        470 :           stack_top = NULL;
    1451                 :            :         }
    1452                 :      71790 :       prev = *curr;
    1453                 :            :     }
    1454                 :            :   return 0;
    1455                 :            : }
    1456                 :            : 
    1457                 :            : /* Optimize a namespace, including all contained namespaces.
    1458                 :            :   flag_frontend_optimize and flag_fronend_loop_interchange are
    1459                 :            :   handled separately.  */
    1460                 :            : 
    1461                 :            : static void
    1462                 :     132834 : optimize_namespace (gfc_namespace *ns)
    1463                 :            : {
    1464                 :     132834 :   gfc_namespace *saved_ns = gfc_current_ns;
    1465                 :     132834 :   current_ns = ns;
    1466                 :     132834 :   gfc_current_ns = ns;
    1467                 :     132834 :   forall_level = 0;
    1468                 :     132834 :   iterator_level = 0;
    1469                 :     132834 :   in_assoc_list = false;
    1470                 :     132834 :   in_omp_workshare = false;
    1471                 :     132834 :   in_omp_atomic = false;
    1472                 :            : 
    1473                 :     132834 :   if (flag_frontend_optimize)
    1474                 :            :     {
    1475                 :     132817 :       gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
    1476                 :     132817 :       gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
    1477                 :     132817 :       gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
    1478                 :     132817 :       gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
    1479                 :     132817 :       gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
    1480                 :     132817 :       if (flag_inline_matmul_limit != 0 || flag_external_blas)
    1481                 :            :         {
    1482                 :     132809 :           bool found;
    1483                 :     132809 :           do
    1484                 :            :             {
    1485                 :     132809 :               found = false;
    1486                 :     132809 :               gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr,
    1487                 :            :                                (void *) &found);
    1488                 :            :             }
    1489                 :            :           while (found);
    1490                 :            : 
    1491                 :     132722 :           gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback,
    1492                 :            :                            NULL);
    1493                 :            :         }
    1494                 :            : 
    1495                 :     132817 :       if (flag_external_blas)
    1496                 :         37 :         gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback,
    1497                 :            :                          NULL);
    1498                 :            : 
    1499                 :     132817 :       if (flag_inline_matmul_limit != 0)
    1500                 :     132721 :         gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback,
    1501                 :            :                          NULL);
    1502                 :            :     }
    1503                 :            : 
    1504                 :     132834 :   if (flag_frontend_loop_interchange)
    1505                 :     132776 :     gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback,
    1506                 :            :                      NULL);
    1507                 :            : 
    1508                 :            :   /* BLOCKs are handled in the expression walker below.  */
    1509                 :     157077 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1510                 :            :     {
    1511                 :      24243 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1512                 :      23854 :         optimize_namespace (ns);
    1513                 :            :     }
    1514                 :     132834 :   gfc_current_ns = saved_ns;
    1515                 :     132834 : }
    1516                 :            : 
    1517                 :            : /* Handle dependencies for allocatable strings which potentially redefine
    1518                 :            :    themselves in an assignment.  */
    1519                 :            : 
    1520                 :            : static void
    1521                 :     158333 : realloc_strings (gfc_namespace *ns)
    1522                 :            : {
    1523                 :     158333 :   current_ns = ns;
    1524                 :     158333 :   gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
    1525                 :            : 
    1526                 :     186770 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1527                 :            :     {
    1528                 :      28437 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1529                 :      27918 :         realloc_strings (ns);
    1530                 :            :     }
    1531                 :            : 
    1532                 :     158333 : }
    1533                 :            : 
    1534                 :            : static void
    1535                 :     132760 : optimize_reduction (gfc_namespace *ns)
    1536                 :            : {
    1537                 :     132760 :   current_ns = ns;
    1538                 :     132760 :   gfc_code_walker (&ns->code, gfc_dummy_code_callback,
    1539                 :            :                    callback_reduction, NULL);
    1540                 :            : 
    1541                 :            : /* BLOCKs are handled in the expression walker below.  */
    1542                 :     156994 :   for (ns = ns->contained; ns; ns = ns->sibling)
    1543                 :            :     {
    1544                 :      24234 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    1545                 :      23788 :         optimize_reduction (ns);
    1546                 :            :     }
    1547                 :     132760 : }
    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                 :      33533 : optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
    1559                 :            : {
    1560                 :      33533 :   gfc_expr *e;
    1561                 :            : 
    1562                 :      33533 :   if (!*rhs)
    1563                 :            :     return false;
    1564                 :            : 
    1565                 :      33533 :   e = *rhs;
    1566                 :      33533 :   if (e->expr_type == EXPR_OP)
    1567                 :            :     {
    1568                 :       2375 :       switch (e->value.op.op)
    1569                 :            :         {
    1570                 :            :           /* Unary operators and exponentiation: Only look at a single
    1571                 :            :              operand.  */
    1572                 :        280 :         case INTRINSIC_NOT:
    1573                 :        280 :         case INTRINSIC_UPLUS:
    1574                 :        280 :         case INTRINSIC_UMINUS:
    1575                 :        280 :         case INTRINSIC_PARENTHESES:
    1576                 :        280 :         case INTRINSIC_POWER:
    1577                 :        280 :           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
    1578                 :          0 :             return true;
    1579                 :            :           break;
    1580                 :            : 
    1581                 :            :         case INTRINSIC_CONCAT:
    1582                 :            :           /* Do not do string concatenations.  */
    1583                 :            :           break;
    1584                 :            : 
    1585                 :       2069 :         default:
    1586                 :            :           /* Binary operators.  */
    1587                 :       2069 :           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
    1588                 :            :             return true;
    1589                 :            : 
    1590                 :       2034 :           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
    1591                 :         40 :             return true;
    1592                 :            : 
    1593                 :            :           break;
    1594                 :            :         }
    1595                 :            :     }
    1596                 :       3825 :   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
    1597                 :        161 :            && ! (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                 :        140 :            && ! (e->value.function.isym
    1603                 :            :                  && (e->value.function.isym->elemental
    1604                 :        116 :                      || e->ts.type != c->expr1->ts.type
    1605                 :         51 :                      || e->ts.kind != c->expr1->ts.kind))
    1606                 :      31233 :            && ! gfc_inline_intrinsic_function_p (e))
    1607                 :            :     {
    1608                 :            : 
    1609                 :         73 :       gfc_code *n;
    1610                 :         73 :       gfc_expr *new_expr;
    1611                 :            : 
    1612                 :            :       /* Insert a new assignment statement after the current one.  */
    1613                 :         73 :       n = XCNEW (gfc_code);
    1614                 :         73 :       n->op = EXEC_ASSIGN;
    1615                 :         73 :       n->loc = c->loc;
    1616                 :         73 :       n->next = c->next;
    1617                 :         73 :       c->next = n;
    1618                 :            : 
    1619                 :         73 :       n->expr1 = gfc_copy_expr (c->expr1);
    1620                 :         73 :       n->expr2 = c->expr2;
    1621                 :         73 :       new_expr = gfc_copy_expr (c->expr1);
    1622                 :         73 :       c->expr2 = e;
    1623                 :         73 :       *rhs = new_expr;
    1624                 :            : 
    1625                 :         73 :       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                 :     235662 : remove_trim (gfc_expr *rhs)
    1637                 :            : {
    1638                 :     235662 :   bool ret;
    1639                 :            : 
    1640                 :     235662 :   ret = false;
    1641                 :     235662 :   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                 :     236197 :   while (rhs->expr_type == EXPR_OP
    1649                 :     236197 :          && rhs->value.op.op == INTRINSIC_CONCAT)
    1650                 :        535 :     rhs = rhs->value.op.op2;
    1651                 :            : 
    1652                 :      41614 :   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
    1653                 :     269603 :          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
    1654                 :            :     {
    1655                 :       1073 :       strip_function_call (rhs);
    1656                 :            :       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
    1657                 :       1073 :       remove_trim (rhs);
    1658                 :       1073 :       ret = true;
    1659                 :            :     }
    1660                 :            : 
    1661                 :            :   return ret;
    1662                 :            : }
    1663                 :            : 
    1664                 :            : /* Optimizations for an assignment.  */
    1665                 :            : 
    1666                 :            : static void
    1667                 :     135731 : optimize_assignment (gfc_code * c)
    1668                 :            : {
    1669                 :     135731 :   gfc_expr *lhs, *rhs;
    1670                 :            : 
    1671                 :     135731 :   lhs = c->expr1;
    1672                 :     135731 :   rhs = c->expr2;
    1673                 :            : 
    1674                 :     135731 :   if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
    1675                 :            :     {
    1676                 :            :       /* Optimize  a = trim(b)  to  a = b.  */
    1677                 :      16275 :       remove_trim (rhs);
    1678                 :            : 
    1679                 :            :       /* Replace a = '   ' by a = '' to optimize away a memcpy.  */
    1680                 :      12461 :       if (is_empty_string (rhs))
    1681                 :       1407 :         rhs->value.character.length = 0;
    1682                 :            :     }
    1683                 :            : 
    1684                 :     135731 :   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
    1685                 :      29150 :     optimize_binop_array_assignment (c, &rhs, false);
    1686                 :     135731 : }
    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                 :       1448 : strip_function_call (gfc_expr *e)
    1695                 :            : {
    1696                 :       1448 :   gfc_expr *e1;
    1697                 :       1448 :   gfc_actual_arglist *a;
    1698                 :            : 
    1699                 :       1448 :   a = e->value.function.actual;
    1700                 :            : 
    1701                 :            :   /* We should have at least one argument.  */
    1702                 :       1448 :   gcc_assert (a->expr != NULL);
    1703                 :            : 
    1704                 :       1448 :   e1 = a->expr;
    1705                 :            : 
    1706                 :            :   /* Free the remaining arglist, if any.  */
    1707                 :       1448 :   if (a->next)
    1708                 :          0 :     gfc_free_actual_arglist (a->next);
    1709                 :            : 
    1710                 :            :   /* Graft the argument expression onto the original function.  */
    1711                 :       1448 :   *e = *e1;
    1712                 :       1448 :   free (e1);
    1713                 :            : 
    1714                 :       1448 : }
    1715                 :            : 
    1716                 :            : /* Optimization of lexical comparison functions.  */
    1717                 :            : 
    1718                 :            : static bool
    1719                 :    1769900 : optimize_lexical_comparison (gfc_expr *e)
    1720                 :            : {
    1721                 :    1769900 :   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
    1722                 :            :     return false;
    1723                 :            : 
    1724                 :     125975 :   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                 :     184766 : combine_array_constructor (gfc_expr *e)
    1750                 :            : {
    1751                 :            : 
    1752                 :     184766 :   gfc_expr *op1, *op2;
    1753                 :     184766 :   gfc_expr *scalar;
    1754                 :     184766 :   gfc_expr *new_expr;
    1755                 :     184766 :   gfc_constructor *c, *new_c;
    1756                 :     184766 :   gfc_constructor_base oldbase, newbase;
    1757                 :     184766 :   bool scalar_first;
    1758                 :     184766 :   int n_elem;
    1759                 :     184766 :   bool all_const;
    1760                 :            : 
    1761                 :            :   /* Array constructors have rank one.  */
    1762                 :     184766 :   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                 :      19421 :   if (in_assoc_list)
    1768                 :            :     return false;
    1769                 :            : 
    1770                 :            :   /* With FORALL, the BLOCKS created by create_var will cause an ICE.  */
    1771                 :      19415 :   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                 :      19343 :   if (iterator_level > 0)
    1777                 :            :     return false;
    1778                 :            : 
    1779                 :            :   /* WHERE also doesn't work.  */
    1780                 :      19318 :   if (in_where > 0)
    1781                 :            :     return false;
    1782                 :            : 
    1783                 :      18788 :   op1 = e->value.op.op1;
    1784                 :      18788 :   op2 = e->value.op.op2;
    1785                 :            : 
    1786                 :      18788 :   if (!op1 || !op2)
    1787                 :            :     return false;
    1788                 :            : 
    1789                 :      18788 :   if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
    1790                 :            :     scalar_first = false;
    1791                 :      18715 :   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                 :        133 :   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                 :         97 :   oldbase = op1->value.constructor;
    1812                 :            : 
    1813                 :         97 :   n_elem = 0;
    1814                 :         97 :   all_const = true;
    1815                 :       1324 :   for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c))
    1816                 :            :     {
    1817                 :       1262 :       if (c->expr->expr_type != EXPR_CONSTANT)
    1818                 :            :         {
    1819                 :            :           all_const = false;
    1820                 :            :           break;
    1821                 :            :         }
    1822                 :       1227 :       n_elem += 1;
    1823                 :            :     }
    1824                 :            : 
    1825                 :         97 :   if (all_const && n_elem > CONSTR_LEN_MAX)
    1826                 :            :     return false;
    1827                 :            : 
    1828                 :            : #undef CONSTR_LEN_MAX
    1829                 :            : 
    1830                 :         81 :   newbase = NULL;
    1831                 :         81 :   e->expr_type = EXPR_ARRAY;
    1832                 :            : 
    1833                 :         81 :   scalar = create_var (gfc_copy_expr (op2), "constr");
    1834                 :            : 
    1835                 :        346 :   for (c = gfc_constructor_first (oldbase); c;
    1836                 :        265 :        c = gfc_constructor_next (c))
    1837                 :            :     {
    1838                 :        265 :       new_expr = gfc_get_expr ();
    1839                 :        265 :       new_expr->ts = e->ts;
    1840                 :        265 :       new_expr->expr_type = EXPR_OP;
    1841                 :        265 :       new_expr->rank = c->expr->rank;
    1842                 :        265 :       new_expr->where = c->expr->where;
    1843                 :        265 :       new_expr->value.op.op = e->value.op.op;
    1844                 :            : 
    1845                 :        265 :       if (scalar_first)
    1846                 :            :         {
    1847                 :        104 :           new_expr->value.op.op1 = gfc_copy_expr (scalar);
    1848                 :        104 :           new_expr->value.op.op2 = gfc_copy_expr (c->expr);
    1849                 :            :         }
    1850                 :            :       else
    1851                 :            :         {
    1852                 :        161 :           new_expr->value.op.op1 = gfc_copy_expr (c->expr);
    1853                 :        161 :           new_expr->value.op.op2 = gfc_copy_expr (scalar);
    1854                 :            :         }
    1855                 :            : 
    1856                 :        265 :       new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
    1857                 :        265 :       new_c->iterator = c->iterator;
    1858                 :        265 :       c->iterator = NULL;
    1859                 :            :     }
    1860                 :            : 
    1861                 :         81 :   gfc_free_expr (op1);
    1862                 :         81 :   gfc_free_expr (op2);
    1863                 :         81 :   gfc_free_expr (scalar);
    1864                 :            : 
    1865                 :         81 :   e->value.constructor = newbase;
    1866                 :         81 :   return true;
    1867                 :            : }
    1868                 :            : 
    1869                 :            : /* Recursive optimization of operators.  */
    1870                 :            : 
    1871                 :            : static bool
    1872                 :     238257 : optimize_op (gfc_expr *e)
    1873                 :            : {
    1874                 :     238257 :   bool changed;
    1875                 :            : 
    1876                 :     238257 :   gfc_intrinsic_op op = e->value.op.op;
    1877                 :            : 
    1878                 :     238257 :   changed = false;
    1879                 :            : 
    1880                 :            :   /* Only use new-style comparisons.  */
    1881                 :     238257 :   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                 :     184036 :   switch (op)
    1912                 :            :     {
    1913                 :     109034 :     case INTRINSIC_EQ:
    1914                 :     109034 :     case INTRINSIC_GE:
    1915                 :     109034 :     case INTRINSIC_LE:
    1916                 :     109034 :     case INTRINSIC_NE:
    1917                 :     109034 :     case INTRINSIC_GT:
    1918                 :     109034 :     case INTRINSIC_LT:
    1919                 :     109034 :       changed = optimize_comparison (e, op);
    1920                 :            : 
    1921                 :     184766 :       gcc_fallthrough ();
    1922                 :            :       /* Look at array constructors.  */
    1923                 :     184766 :     case INTRINSIC_PLUS:
    1924                 :     184766 :     case INTRINSIC_MINUS:
    1925                 :     184766 :     case INTRINSIC_TIMES:
    1926                 :     184766 :     case INTRINSIC_DIVIDE:
    1927                 :     184766 :       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                 :      49887 : is_empty_string (gfc_expr *e)
    1941                 :            : {
    1942                 :      49887 :   int i;
    1943                 :            : 
    1944                 :      16275 :   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
    1945                 :            :     return false;
    1946                 :            : 
    1947                 :      34951 :   for (i=0; i < e->value.character.length; i++)
    1948                 :            :     {
    1949                 :      32824 :       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                 :       1095 : get_len_trim_call (gfc_expr *str, int kind)
    1963                 :            : {
    1964                 :       1095 :   gfc_expr *fcn;
    1965                 :       1095 :   gfc_actual_arglist *actual_arglist, *next;
    1966                 :            : 
    1967                 :       1095 :   fcn = gfc_get_expr ();
    1968                 :       1095 :   fcn->expr_type = EXPR_FUNCTION;
    1969                 :       1095 :   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
    1970                 :       1095 :   actual_arglist = gfc_get_actual_arglist ();
    1971                 :       1095 :   actual_arglist->expr = str;
    1972                 :       1095 :   next = gfc_get_actual_arglist ();
    1973                 :       1095 :   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
    1974                 :       1095 :   actual_arglist->next = next;
    1975                 :            : 
    1976                 :       1095 :   fcn->value.function.actual = actual_arglist;
    1977                 :       1095 :   fcn->where = str->where;
    1978                 :       1095 :   fcn->ts.type = BT_INTEGER;
    1979                 :       1095 :   fcn->ts.kind = gfc_charlen_int_kind;
    1980                 :            : 
    1981                 :       1095 :   gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
    1982                 :       1095 :   fcn->symtree->n.sym->ts = fcn->ts;
    1983                 :       1095 :   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
    1984                 :       1095 :   fcn->symtree->n.sym->attr.function = 1;
    1985                 :       1095 :   fcn->symtree->n.sym->attr.elemental = 1;
    1986                 :       1095 :   fcn->symtree->n.sym->attr.referenced = 1;
    1987                 :       1095 :   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
    1988                 :       1095 :   gfc_commit_symbol (fcn->symtree->n.sym);
    1989                 :            : 
    1990                 :       1095 :   return fcn;
    1991                 :            : }
    1992                 :            : 
    1993                 :            : 
    1994                 :            : /* Optimize expressions for equality.  */
    1995                 :            : 
    1996                 :            : static bool
    1997                 :     109157 : optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
    1998                 :            : {
    1999                 :     109157 :   gfc_expr *op1, *op2;
    2000                 :     109157 :   bool change;
    2001                 :     109157 :   int eq;
    2002                 :     109157 :   bool result;
    2003                 :     109157 :   gfc_actual_arglist *firstarg, *secondarg;
    2004                 :            : 
    2005                 :     109157 :   if (e->expr_type == EXPR_OP)
    2006                 :            :     {
    2007                 :     109046 :       firstarg = NULL;
    2008                 :     109046 :       secondarg = NULL;
    2009                 :     109046 :       op1 = e->value.op.op1;
    2010                 :     109046 :       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                 :     109157 :   change = remove_trim (op1);
    2026                 :            : 
    2027                 :     109157 :   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                 :     109157 :   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                 :      90591 :   if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
    2040                 :      17377 :       && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
    2041                 :            :     {
    2042                 :      16806 :       bool empty_op1, empty_op2;
    2043                 :      16806 :       empty_op1 = is_empty_string (op1);
    2044                 :      16806 :       empty_op2 = is_empty_string (op2);
    2045                 :            : 
    2046                 :      16806 :       if (empty_op1 || empty_op2)
    2047                 :            :         {
    2048                 :        720 :           gfc_expr *fcn;
    2049                 :        720 :           gfc_expr *zero;
    2050                 :        720 :           gfc_expr *str;
    2051                 :            : 
    2052                 :            :           /* This can only happen when an error for comparing
    2053                 :            :              characters of different kinds has already been issued.  */
    2054                 :        720 :           if (empty_op1 && empty_op2)
    2055                 :            :             return false;
    2056                 :            : 
    2057                 :        720 :           zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
    2058                 :        720 :           str = empty_op1 ? op2 : op1;
    2059                 :            : 
    2060                 :        720 :           fcn = get_len_trim_call (str, gfc_charlen_int_kind);
    2061                 :            : 
    2062                 :            : 
    2063                 :        720 :           if (empty_op1)
    2064                 :          0 :             gfc_free_expr (op1);
    2065                 :            :           else
    2066                 :        720 :             gfc_free_expr (op2);
    2067                 :            : 
    2068                 :        720 :           op1 = fcn;
    2069                 :        720 :           op2 = zero;
    2070                 :        720 :           e->value.op.op1 = fcn;
    2071                 :        720 :           e->value.op.op2 = zero;
    2072                 :            :         }
    2073                 :            :     }
    2074                 :            : 
    2075                 :            : 
    2076                 :            :   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
    2077                 :            : 
    2078                 :      90591 :   if (flag_finite_math_only
    2079                 :      90462 :       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
    2080                 :      76724 :           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
    2081                 :            :     {
    2082                 :      75880 :       eq = gfc_dep_compare_expr (op1, op2);
    2083                 :      75880 :       if (eq <= -2)
    2084                 :            :         {
    2085                 :            :           /* Replace A // B < A // C with B < C, and A // B < C // B
    2086                 :            :              with A < C.  */
    2087                 :      75569 :           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
    2088                 :      16396 :               && 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                 :        311 :           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                 :        119 :             case INTRINSIC_NE:
    2163                 :        119 :               result = eq != 0;
    2164                 :        119 :               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                 :        311 :               break;
    2177                 :            :             }
    2178                 :            : 
    2179                 :            :           /* Replace the expression by a constant expression.  The typespec
    2180                 :            :              and where remains the way it is.  */
    2181                 :        311 :           free (op1);
    2182                 :        311 :           free (op2);
    2183                 :        311 :           e->expr_type = EXPR_CONSTANT;
    2184                 :        311 :           e->value.logical = result;
    2185                 :        311 :           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                 :    1769900 : optimize_trim (gfc_expr *e)
    2198                 :            : {
    2199                 :    1769900 :   gfc_expr *a;
    2200                 :    1769900 :   gfc_ref *ref;
    2201                 :    1769900 :   gfc_expr *fcn;
    2202                 :    1769900 :   gfc_ref **rr = NULL;
    2203                 :            : 
    2204                 :            :   /* Don't do this optimization within an argument list, because
    2205                 :            :      otherwise aliasing issues may occur.  */
    2206                 :            : 
    2207                 :    1769900 :   if (count_arglist != 1)
    2208                 :            :     return false;
    2209                 :            : 
    2210                 :     264236 :   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
    2211                 :       6299 :       || e->value.function.isym == NULL
    2212                 :       4672 :       || e->value.function.isym->id != GFC_ISYM_TRIM)
    2213                 :            :     return false;
    2214                 :            : 
    2215                 :        503 :   a = e->value.function.actual->expr;
    2216                 :            : 
    2217                 :        503 :   if (a->expr_type != EXPR_VARIABLE)
    2218                 :            :     return false;
    2219                 :            : 
    2220                 :            :   /* This would pessimize the idiom a = trim(a) for reallocatable strings.  */
    2221                 :            : 
    2222                 :        492 :   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                 :        471 :   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                 :        375 :   strip_function_call (e);
    2240                 :            : 
    2241                 :        375 :   if (e->ref == NULL)
    2242                 :        347 :     rr = &(e->ref);
    2243                 :            : 
    2244                 :            :   /* Create the reference.  */
    2245                 :            : 
    2246                 :        375 :   ref = gfc_get_ref ();
    2247                 :        375 :   ref->type = REF_SUBSTRING;
    2248                 :            : 
    2249                 :            :   /* Set the start of the reference.  */
    2250                 :            : 
    2251                 :        375 :   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                 :        375 :   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                 :        375 :   ref->u.ss.end = fcn;
    2260                 :        375 :   gcc_assert (rr != NULL && *rr == NULL);
    2261                 :        375 :   *rr = ref;
    2262                 :        375 :   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                 :       7030 : optimize_minmaxloc (gfc_expr **e)
    2271                 :            : {
    2272                 :       7030 :   gfc_expr *fn = *e;
    2273                 :       7030 :   gfc_actual_arglist *a;
    2274                 :       7030 :   char *name, *p;
    2275                 :            : 
    2276                 :       7030 :   if (fn->rank != 1
    2277                 :       3211 :       || fn->value.function.actual == NULL
    2278                 :       3211 :       || fn->value.function.actual->expr == NULL
    2279                 :       3211 :       || fn->value.function.actual->expr->rank != 1)
    2280                 :            :     return;
    2281                 :            : 
    2282                 :       1954 :   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
    2283                 :       1954 :   (*e)->shape = fn->shape;
    2284                 :       1954 :   fn->rank = 0;
    2285                 :       1954 :   fn->shape = NULL;
    2286                 :       1954 :   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
    2287                 :            : 
    2288                 :       1954 :   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
    2289                 :       1954 :   strcpy (name, fn->value.function.name);
    2290                 :       1954 :   p = strstr (name, "loc0");
    2291                 :       1954 :   p[3] = '1';
    2292                 :       1954 :   fn->value.function.name = gfc_get_string ("%s", name);
    2293                 :       1954 :   if (fn->value.function.actual->next)
    2294                 :            :     {
    2295                 :       1954 :       a = fn->value.function.actual->next;
    2296                 :       1954 :       gcc_assert (a->expr == NULL);
    2297                 :            :     }
    2298                 :            :   else
    2299                 :            :     {
    2300                 :          0 :       a = gfc_get_actual_arglist ();
    2301                 :          0 :       fn->value.function.actual->next = a;
    2302                 :            :     }
    2303                 :       1954 :   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    2304                 :            :                                    &fn->where);
    2305                 :       1954 :   mpz_set_ui (a->expr->value.integer, 1);
    2306                 :            : }
    2307                 :            : 
    2308                 :            : /* Callback function for code checking that we do not pass a DO variable to an
    2309                 :            :    INTENT(OUT) or INTENT(INOUT) dummy variable.  */
    2310                 :            : 
    2311                 :            : static int
    2312                 :     729649 : doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    2313                 :            :          void *data ATTRIBUTE_UNUSED)
    2314                 :            : {
    2315                 :     729649 :   gfc_code *co;
    2316                 :     729649 :   int i;
    2317                 :     729649 :   gfc_formal_arglist *f;
    2318                 :     729649 :   gfc_actual_arglist *a;
    2319                 :     729649 :   gfc_code *cl;
    2320                 :     729649 :   do_t loop, *lp;
    2321                 :     729649 :   bool seen_goto;
    2322                 :            : 
    2323                 :     729649 :   co = *c;
    2324                 :            : 
    2325                 :            :   /* If the doloop_list grew, we have to truncate it here.  */
    2326                 :            : 
    2327                 :     903104 :   if ((unsigned) doloop_level < doloop_list.length())
    2328                 :      22532 :     doloop_list.truncate (doloop_level);
    2329                 :            : 
    2330                 :     729649 :   seen_goto = false;
    2331                 :     729649 :   switch (co->op)
    2332                 :            :     {
    2333                 :      28723 :     case EXEC_DO:
    2334                 :            : 
    2335                 :      28723 :       if (co->ext.iterator && co->ext.iterator->var)
    2336                 :      28723 :         loop.c = co;
    2337                 :            :       else
    2338                 :          0 :         loop.c = NULL;
    2339                 :            : 
    2340                 :      28723 :       loop.branch_level = if_level + select_level;
    2341                 :      28723 :       loop.seen_goto = false;
    2342                 :      28723 :       doloop_list.safe_push (loop);
    2343                 :      28723 :       break;
    2344                 :            : 
    2345                 :            :       /* If anything could transfer control away from a suspicious
    2346                 :            :          subscript, make sure to set seen_goto in the current DO loop
    2347                 :            :          (if any).  */
    2348                 :            :     case EXEC_GOTO:
    2349                 :            :     case EXEC_EXIT:
    2350                 :            :     case EXEC_STOP:
    2351                 :            :     case EXEC_ERROR_STOP:
    2352                 :            :     case EXEC_CYCLE:
    2353                 :            :       seen_goto = true;
    2354                 :            :       break;
    2355                 :            : 
    2356                 :       3468 :     case EXEC_OPEN:
    2357                 :       3468 :       if (co->ext.open->err)
    2358                 :            :         seen_goto = true;
    2359                 :            :       break;
    2360                 :            : 
    2361                 :       2890 :     case EXEC_CLOSE:
    2362                 :       2890 :       if (co->ext.close->err)
    2363                 :            :         seen_goto = true;
    2364                 :            :       break;
    2365                 :            : 
    2366                 :       2485 :     case EXEC_BACKSPACE:
    2367                 :       2485 :     case EXEC_ENDFILE:
    2368                 :       2485 :     case EXEC_REWIND:
    2369                 :       2485 :     case EXEC_FLUSH:
    2370                 :            : 
    2371                 :       2485 :       if (co->ext.filepos->err)
    2372                 :            :         seen_goto = true;
    2373                 :            :       break;
    2374                 :            : 
    2375                 :        800 :     case EXEC_INQUIRE:
    2376                 :        800 :       if (co->ext.filepos->err)
    2377                 :            :         seen_goto = true;
    2378                 :            :       break;
    2379                 :            : 
    2380                 :      26022 :     case EXEC_READ:
    2381                 :      26022 :     case EXEC_WRITE:
    2382                 :      26022 :       if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor)
    2383                 :            :         seen_goto = true;
    2384                 :            :       break;
    2385                 :            : 
    2386                 :            :     case EXEC_WAIT:
    2387                 :            :       if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor)
    2388                 :            :         loop.seen_goto = true;
    2389                 :            :       break;
    2390                 :            : 
    2391                 :      53156 :     case EXEC_CALL:
    2392                 :            : 
    2393                 :      53156 :       if (co->resolved_sym == NULL)
    2394                 :            :         break;
    2395                 :            : 
    2396                 :      52853 :       f = gfc_sym_get_dummy_args (co->resolved_sym);
    2397                 :            : 
    2398                 :            :       /* Withot a formal arglist, there is only unknown INTENT,
    2399                 :            :          which we don't check for.  */
    2400                 :      52853 :       if (f == NULL)
    2401                 :            :         break;
    2402                 :            : 
    2403                 :      33544 :       a = co->ext.actual;
    2404                 :            : 
    2405                 :     121650 :       while (a && f)
    2406                 :            :         {
    2407                 :      96291 :           FOR_EACH_VEC_ELT (doloop_list, i, lp)
    2408                 :            :             {
    2409                 :       8185 :               gfc_symbol *do_sym;
    2410                 :       8185 :               cl = lp->c;
    2411                 :            : 
    2412                 :       8185 :               if (cl == NULL)
    2413                 :            :                 break;
    2414                 :            : 
    2415                 :       8185 :               do_sym = cl->ext.iterator->var->symtree->n.sym;
    2416                 :            : 
    2417                 :       8185 :               if (a->expr && a->expr->symtree
    2418                 :       4023 :                   && a->expr->symtree->n.sym == do_sym)
    2419                 :            :                 {
    2420                 :        221 :                   if (f->sym->attr.intent == INTENT_OUT)
    2421                 :          1 :                     gfc_error_now ("Variable %qs at %L set to undefined "
    2422                 :            :                                    "value inside loop  beginning at %L as "
    2423                 :            :                                    "INTENT(OUT) argument to subroutine %qs",
    2424                 :            :                                    do_sym->name, &a->expr->where,
    2425                 :          1 :                                    &(doloop_list[i].c->loc),
    2426                 :          1 :                                    co->symtree->n.sym->name);
    2427                 :        220 :                   else if (f->sym->attr.intent == INTENT_INOUT)
    2428                 :          1 :                     gfc_error_now ("Variable %qs at %L not definable inside "
    2429                 :            :                                    "loop beginning at %L as INTENT(INOUT) "
    2430                 :            :                                    "argument to subroutine %qs",
    2431                 :            :                                    do_sym->name, &a->expr->where,
    2432                 :          1 :                                    &(doloop_list[i].c->loc),
    2433                 :          1 :                                    co->symtree->n.sym->name);
    2434                 :            :                 }
    2435                 :            :             }
    2436                 :      88106 :           a = a->next;
    2437                 :      88106 :           f = f->next;
    2438                 :            :         }
    2439                 :            :       break;
    2440                 :            : 
    2441                 :            :     default:
    2442                 :            :       break;
    2443                 :            :     }
    2444                 :     157615 :   if (seen_goto && doloop_level > 0)
    2445                 :       6626 :     doloop_list[doloop_level-1].seen_goto = true;
    2446                 :            : 
    2447                 :     729649 :   return 0;
    2448                 :            : }
    2449                 :            : 
    2450                 :            : /* Callback function to warn about different things within DO loops.  */
    2451                 :            : 
    2452                 :            : static int
    2453                 :    2108860 : do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    2454                 :            :              void *data ATTRIBUTE_UNUSED)
    2455                 :            : {
    2456                 :    2108860 :   do_t *last;
    2457                 :            : 
    2458                 :    2108860 :   if (doloop_list.length () == 0)
    2459                 :            :     return 0;
    2460                 :            : 
    2461                 :     511025 :   if ((*e)->expr_type == EXPR_FUNCTION)
    2462                 :      30074 :     do_intent (e);
    2463                 :            : 
    2464                 :     511025 :   last = &doloop_list.last();
    2465                 :     511025 :   if (last->seen_goto && !warn_do_subscript)
    2466                 :            :     return 0;
    2467                 :            : 
    2468                 :     479664 :   if ((*e)->expr_type == EXPR_VARIABLE)
    2469                 :     234878 :     do_subscript (e);
    2470                 :            : 
    2471                 :            :   return 0;
    2472                 :            : }
    2473                 :            : 
    2474                 :            : typedef struct
    2475                 :            : {
    2476                 :            :   gfc_symbol *sym;
    2477                 :            :   mpz_t val;
    2478                 :            : } insert_index_t;
    2479                 :            : 
    2480                 :            : /* Callback function - if the expression is the variable in data->sym,
    2481                 :            :    replace it with a constant from data->val.  */
    2482                 :            : 
    2483                 :            : static int
    2484                 :     122793 : callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    2485                 :            :                        void *data)
    2486                 :            : {
    2487                 :     122793 :   insert_index_t *d;
    2488                 :     122793 :   gfc_expr *ex, *n;
    2489                 :            : 
    2490                 :     122793 :   ex = (*e);
    2491                 :     122793 :   if (ex->expr_type != EXPR_VARIABLE)
    2492                 :            :     return 0;
    2493                 :            : 
    2494                 :      80506 :   d = (insert_index_t *) data;
    2495                 :      80506 :   if (ex->symtree->n.sym != d->sym)
    2496                 :            :     return 0;
    2497                 :            : 
    2498                 :      42637 :   n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where);
    2499                 :      42637 :   mpz_set (n->value.integer, d->val);
    2500                 :            : 
    2501                 :      42637 :   gfc_free_expr (ex);
    2502                 :      42637 :   *e = n;
    2503                 :      42637 :   return 0;
    2504                 :            : }
    2505                 :            : 
    2506                 :            : /* In the expression e, replace occurrences of the variable sym with
    2507                 :            :    val.  If this results in a constant expression, return true and
    2508                 :            :    return the value in ret.  Return false if the expression already
    2509                 :            :    is a constant.  Caller has to clear ret in that case.  */
    2510                 :            : 
    2511                 :            : static bool
    2512                 :      76700 : insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret)
    2513                 :            : {
    2514                 :      76700 :   gfc_expr *n;
    2515                 :      76700 :   insert_index_t data;
    2516                 :      76700 :   bool rc;
    2517                 :            : 
    2518                 :      76700 :   if (e->expr_type == EXPR_CONSTANT)
    2519                 :            :     return false;
    2520                 :            : 
    2521                 :      73275 :   n = gfc_copy_expr (e);
    2522                 :      73275 :   data.sym = sym;
    2523                 :      73275 :   mpz_init_set (data.val, val);
    2524                 :      73275 :   gfc_expr_walker (&n, callback_insert_index, (void *) &data);
    2525                 :            : 
    2526                 :            :   /* Suppress errors here - we could get errors here such as an
    2527                 :            :      out of bounds access for arrays, see PR 90563.  */
    2528                 :      73275 :   gfc_push_suppress_errors ();
    2529                 :      73275 :   gfc_simplify_expr (n, 0);
    2530                 :      73275 :   gfc_pop_suppress_errors ();
    2531                 :            : 
    2532                 :      73275 :   if (n->expr_type == EXPR_CONSTANT)
    2533                 :            :     {
    2534                 :      38767 :       rc = true;
    2535                 :      38767 :       mpz_init_set (ret, n->value.integer);
    2536                 :            :     }
    2537                 :            :   else
    2538                 :            :     rc = false;
    2539                 :            : 
    2540                 :      73275 :   mpz_clear (data.val);
    2541                 :      73275 :   gfc_free_expr (n);
    2542                 :      73275 :   return rc;
    2543                 :            : 
    2544                 :            : }
    2545                 :            : 
    2546                 :            : /* Check array subscripts for possible out-of-bounds accesses in DO
    2547                 :            :    loops with constant bounds.  */
    2548                 :            : 
    2549                 :            : static int
    2550                 :     234878 : do_subscript (gfc_expr **e)
    2551                 :            : {
    2552                 :     234878 :   gfc_expr *v;
    2553                 :     234878 :   gfc_array_ref *ar;
    2554                 :     234878 :   gfc_ref *ref;
    2555                 :     234878 :   int i,j;
    2556                 :     234878 :   gfc_code *dl;
    2557                 :     234878 :   do_t *lp;
    2558                 :            : 
    2559                 :     234878 :   v = *e;
    2560                 :            :   /* Constants are already checked.  */
    2561                 :     234878 :   if (v->expr_type == EXPR_CONSTANT)
    2562                 :            :     return 0;
    2563                 :            : 
    2564                 :            :   /* Wrong warnings will be generated in an associate list.  */
    2565                 :     234878 :   if (in_assoc_list)
    2566                 :            :     return 0;
    2567                 :            : 
    2568                 :            :   /* We already warned about this.  */
    2569                 :     234733 :   if (v->do_not_warn)
    2570                 :            :     return 0;
    2571                 :            : 
    2572                 :     212669 :   v->do_not_warn = 1;
    2573                 :            : 
    2574                 :     270256 :   for (ref = v->ref; ref; ref = ref->next)
    2575                 :            :     {
    2576                 :      59347 :       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
    2577                 :            :         {
    2578                 :      78989 :           ar = & ref->u.ar;
    2579                 :     136576 :           FOR_EACH_VEC_ELT (doloop_list, j, lp)
    2580                 :            :             {
    2581                 :      53577 :               gfc_symbol *do_sym;
    2582                 :      53577 :               mpz_t do_start, do_step, do_end;
    2583                 :      53577 :               bool have_do_start, have_do_end;
    2584                 :      53577 :               bool error_not_proven;
    2585                 :      53577 :               int warn;
    2586                 :      53577 :               int sgn;
    2587                 :            : 
    2588                 :      53577 :               dl = lp->c;
    2589                 :      53577 :               if (dl == NULL)
    2590                 :            :                 break;
    2591                 :            : 
    2592                 :            :               /* If we are within a branch, or a goto or equivalent
    2593                 :            :                  was seen in the DO loop before, then we cannot prove that
    2594                 :            :                  this expression is actually evaluated.  Don't do anything
    2595                 :            :                  unless we want to see it all.  */
    2596                 :     107160 :               error_not_proven = lp->seen_goto
    2597                 :      53577 :                 || lp->branch_level < if_level + select_level;
    2598                 :            : 
    2599                 :      13724 :               if (error_not_proven && !warn_do_subscript)
    2600                 :            :                 break;
    2601                 :            : 
    2602                 :      39859 :               if (error_not_proven)
    2603                 :            :                 warn = OPT_Wdo_subscript;
    2604                 :            :               else
    2605                 :      39853 :                 warn = 0;
    2606                 :            : 
    2607                 :      39859 :               do_sym = dl->ext.iterator->var->symtree->n.sym;
    2608                 :      39859 :               if (do_sym->ts.type != BT_INTEGER)
    2609                 :        621 :                 continue;
    2610                 :            : 
    2611                 :            :               /* If we do not know about the stepsize, the loop may be zero trip.
    2612                 :            :                  Do not warn in this case.  */
    2613                 :            : 
    2614                 :      39853 :               if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
    2615                 :            :                 {
    2616                 :      39239 :                   sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0);
    2617                 :            :                   /* This can happen, but then the error has been
    2618                 :            :                      reported previously.  */
    2619                 :      38815 :                   if (sgn == 0)
    2620                 :          1 :                     continue;
    2621                 :            : 
    2622                 :      39238 :                   mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
    2623                 :            :                 }
    2624                 :            : 
    2625                 :            :               else
    2626                 :        614 :                 continue;
    2627                 :            : 
    2628                 :      39238 :               if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT)
    2629                 :            :                 {
    2630                 :      37340 :                   have_do_start = true;
    2631                 :      37340 :                   mpz_init_set (do_start, dl->ext.iterator->start->value.integer);
    2632                 :            :                 }
    2633                 :            :               else
    2634                 :            :                 have_do_start = false;
    2635                 :            : 
    2636                 :      39238 :               if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
    2637                 :            :                 {
    2638                 :      15482 :                   have_do_end = true;
    2639                 :      15482 :                   mpz_init_set (do_end, dl->ext.iterator->end->value.integer);
    2640                 :            :                 }
    2641                 :            :               else
    2642                 :            :                 have_do_end = false;
    2643                 :            : 
    2644                 :      39238 :               if (!have_do_start && !have_do_end)
    2645                 :       1760 :                 return 0;
    2646                 :            : 
    2647                 :            :               /* No warning inside a zero-trip loop.  */
    2648                 :      37478 :               if (have_do_start && have_do_end)
    2649                 :            :                 {
    2650                 :      15344 :                   int cmp;
    2651                 :            : 
    2652                 :      15344 :                   cmp = mpz_cmp (do_end, do_start);
    2653                 :      15344 :                   if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))
    2654                 :            :                     break;
    2655                 :            :                 }
    2656                 :            : 
    2657                 :            :               /* May have to correct the end value if the step does not equal
    2658                 :            :                  one.  */
    2659                 :      37461 :               if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0)
    2660                 :            :                 {
    2661                 :        627 :                   mpz_t diff, rem;
    2662                 :            : 
    2663                 :        627 :                   mpz_init (diff);
    2664                 :        627 :                   mpz_init (rem);
    2665                 :        627 :                   mpz_sub (diff, do_end, do_start);
    2666                 :        627 :                   mpz_tdiv_r (rem, diff, do_step);
    2667                 :        627 :                   mpz_sub (do_end, do_end, rem);
    2668                 :        627 :                   mpz_clear (diff);
    2669                 :        627 :                   mpz_clear (rem);
    2670                 :            :                 }
    2671                 :            : 
    2672                 :      90184 :               for (i = 0; i< ar->dimen; i++)
    2673                 :            :                 {
    2674                 :      52723 :                   mpz_t val;
    2675                 :      52723 :                   if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start
    2676                 :     105259 :                       && insert_index (ar->start[i], do_sym, do_start, val))
    2677                 :            :                     {
    2678                 :      27116 :                       if (ar->as->lower[i]
    2679                 :      23858 :                           && ar->as->lower[i]->expr_type == EXPR_CONSTANT
    2680                 :      23821 :                           && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
    2681                 :         14 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2682                 :            :                                      "(%ld < %ld) in loop beginning at %L",
    2683                 :          7 :                                      &ar->start[i]->where, mpz_get_si (val),
    2684                 :            :                                      mpz_get_si (ar->as->lower[i]->value.integer),
    2685                 :          7 :                                      &doloop_list[j].c->loc);
    2686                 :            : 
    2687                 :      27116 :                       if (ar->as->upper[i]
    2688                 :      21734 :                           && ar->as->upper[i]->expr_type == EXPR_CONSTANT
    2689                 :       9406 :                           && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
    2690                 :         62 :                             gfc_warning (warn, "Array reference at %L out of bounds "
    2691                 :            :                                          "(%ld > %ld) in loop beginning at %L",
    2692                 :         31 :                                          &ar->start[i]->where, mpz_get_si (val),
    2693                 :            :                                          mpz_get_si (ar->as->upper[i]->value.integer),
    2694                 :         31 :                                          &doloop_list[j].c->loc);
    2695                 :            : 
    2696                 :      27116 :                       mpz_clear (val);
    2697                 :            :                     }
    2698                 :            : 
    2699                 :      52723 :                   if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end
    2700                 :      76887 :                       && insert_index (ar->start[i], do_sym, do_end, val))
    2701                 :            :                     {
    2702                 :      11651 :                       if (ar->as->lower[i]
    2703                 :       9782 :                           && ar->as->lower[i]->expr_type == EXPR_CONSTANT
    2704                 :       9780 :                           && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0)
    2705                 :          4 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2706                 :            :                                      "(%ld < %ld) in loop beginning at %L",
    2707                 :          2 :                                      &ar->start[i]->where, mpz_get_si (val),
    2708                 :            :                                      mpz_get_si (ar->as->lower[i]->value.integer),
    2709                 :          2 :                                      &doloop_list[j].c->loc);
    2710                 :            : 
    2711                 :      11651 :                       if (ar->as->upper[i]
    2712                 :       8873 :                           && ar->as->upper[i]->expr_type == EXPR_CONSTANT
    2713                 :       8259 :                           && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0)
    2714                 :         16 :                         gfc_warning (warn, "Array reference at %L out of bounds "
    2715                 :            :                                      "(%ld > %ld) in loop beginning at %L",
    2716                 :          8 :                                      &ar->start[i]->where, mpz_get_si (val),
    2717                 :            :                                      mpz_get_si (ar->as->upper[i]->value.integer),
    2718                 :          8 :                                      &doloop_list[j].c->loc);
    2719                 :            : 
    2720                 :      11651 :                       mpz_clear (val);
    2721                 :            :                     }
    2722                 :            :                 }
    2723                 :            :             }
    2724                 :            :         }
    2725                 :            :     }
    2726                 :            :   return 0;
    2727                 :            : }
    2728                 :            : /* Function for functions checking that we do not pass a DO variable
    2729                 :            :    to an INTENT(OUT) or INTENT(INOUT) dummy variable.  */
    2730                 :            : 
    2731                 :            : static int
    2732                 :      30074 : do_intent (gfc_expr **e)
    2733                 :            : {
    2734                 :      30074 :   gfc_formal_arglist *f;
    2735                 :      30074 :   gfc_actual_arglist *a;
    2736                 :      30074 :   gfc_expr *expr;
    2737                 :      30074 :   gfc_code *dl;
    2738                 :      30074 :   do_t *lp;
    2739                 :      30074 :   int i;
    2740                 :            : 
    2741                 :      30074 :   expr = *e;
    2742                 :      30074 :   if (expr->expr_type != EXPR_FUNCTION)
    2743                 :            :     return 0;
    2744                 :            : 
    2745                 :            :   /* Intrinsic functions don't modify their arguments.  */
    2746                 :            : 
    2747                 :      30074 :   if (expr->value.function.isym)
    2748                 :            :     return 0;
    2749                 :            : 
    2750                 :       1834 :   f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
    2751                 :            : 
    2752                 :            :   /* Without a formal arglist, there is only unknown INTENT,
    2753                 :            :      which we don't check for.  */
    2754                 :       1834 :   if (f == NULL)
    2755                 :            :     return 0;
    2756                 :            : 
    2757                 :        569 :   a = expr->value.function.actual;
    2758                 :            : 
    2759                 :       1562 :   while (a && f)
    2760                 :            :     {
    2761                 :       2128 :       FOR_EACH_VEC_ELT (doloop_list, i, lp)
    2762                 :            :         {
    2763                 :       1135 :           gfc_symbol *do_sym;
    2764                 :       1135 :           dl = lp->c;
    2765                 :       1135 :           if (dl == NULL)
    2766                 :            :             break;
    2767                 :            : 
    2768                 :       1135 :           do_sym = dl->ext.iterator->var->symtree->n.sym;
    2769                 :            : 
    2770                 :       1135 :           if (a->expr && a->expr->symtree
    2771                 :        889 :               && a->expr->symtree->n.sym == do_sym)
    2772                 :            :             {
    2773                 :        187 :               if (f->sym->attr.intent == INTENT_OUT)
    2774                 :          1 :                 gfc_error_now ("Variable %qs at %L set to undefined value "
    2775                 :            :                                "inside loop beginning at %L as INTENT(OUT) "
    2776                 :            :                                "argument to function %qs", do_sym->name,
    2777                 :          1 :                                &a->expr->where, &doloop_list[i].c->loc,
    2778                 :          1 :                                expr->symtree->n.sym->name);
    2779                 :        186 :               else if (f->sym->attr.intent == INTENT_INOUT)
    2780                 :          1 :                 gfc_error_now ("Variable %qs at %L not definable inside loop"
    2781                 :            :                                " beginning at %L as INTENT(INOUT) argument to"
    2782                 :            :                                " function %qs", do_sym->name,
    2783                 :          1 :                                &a->expr->where, &doloop_list[i].c->loc,
    2784                 :          1 :                                expr->symtree->n.sym->name);
    2785                 :            :             }
    2786                 :            :         }
    2787                 :        993 :       a = a->next;
    2788                 :        993 :       f = f->next;
    2789                 :            :     }
    2790                 :            : 
    2791                 :            :   return 0;
    2792                 :            : }
    2793                 :            : 
    2794                 :            : static void
    2795                 :     162567 : doloop_warn (gfc_namespace *ns)
    2796                 :            : {
    2797                 :     162567 :   gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
    2798                 :            : 
    2799                 :     192159 :   for (ns = ns->contained; ns; ns = ns->sibling)
    2800                 :            :     {
    2801                 :      29592 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    2802                 :      29114 :         doloop_warn (ns);
    2803                 :            :     }
    2804                 :     162567 : }
    2805                 :            : 
    2806                 :            : /* This selction deals with inlining calls to MATMUL.  */
    2807                 :            : 
    2808                 :            : /* Replace calls to matmul outside of straight assignments with a temporary
    2809                 :            :    variable so that later inlining will work.  */
    2810                 :            : 
    2811                 :            : static int
    2812                 :    1771240 : matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
    2813                 :            :                     void *data)
    2814                 :            : {
    2815                 :    1771240 :   gfc_expr *e, *n;
    2816                 :    1771240 :   bool *found = (bool *) data;
    2817                 :            : 
    2818                 :    1771240 :   e = *ep;
    2819                 :            : 
    2820                 :    1771240 :   if (e->expr_type != EXPR_FUNCTION
    2821                 :     149653 :       || e->value.function.isym == NULL
    2822                 :     124373 :       || e->value.function.isym->id != GFC_ISYM_MATMUL)
    2823                 :            :     return 0;
    2824                 :            : 
    2825                 :        951 :   if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    2826                 :        949 :       || in_omp_atomic || in_where || in_assoc_list)
    2827                 :            :     return 0;
    2828                 :            : 
    2829                 :            :   /* Check if this is already in the form c = matmul(a,b).  */
    2830                 :            : 
    2831                 :        947 :   if ((*current_code)->expr2 == e)
    2832                 :            :     return 0;
    2833                 :            : 
    2834                 :        181 :   n = create_var (e, "matmul");
    2835                 :            : 
    2836                 :            :   /* If create_var is unable to create a variable (for example if
    2837                 :            :      -fno-realloc-lhs is in force with a variable that does not have bounds
    2838                 :            :      known at compile-time), just return.  */
    2839                 :            : 
    2840                 :        181 :   if (n == NULL)
    2841                 :            :     return 0;
    2842                 :            : 
    2843                 :        180 :   *ep = n;
    2844                 :        180 :   *found = true;
    2845                 :        180 :   return 0;
    2846                 :            : }
    2847                 :            : 
    2848                 :            : /* Set current_code and associated variables so that matmul_to_var_expr can
    2849                 :            :    work.  */
    2850                 :            : 
    2851                 :            : static int
    2852                 :     609530 : matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    2853                 :            :                     void *data ATTRIBUTE_UNUSED)
    2854                 :            : {
    2855                 :     609530 :   if (current_code != c)
    2856                 :            :     {
    2857                 :     601229 :       current_code = c;
    2858                 :     601229 :       inserted_block = NULL;
    2859                 :     601229 :       changed_statement = NULL;
    2860                 :            :     }
    2861                 :            : 
    2862                 :     609530 :   return 0;
    2863                 :            : }
    2864                 :            : 
    2865                 :            : 
    2866                 :            : /* Take a statement of the shape c = matmul(a,b) and create temporaries
    2867                 :            :    for a and b if there is a dependency between the arguments and the
    2868                 :            :    result variable or if a or b are the result of calculations that cannot
    2869                 :            :    be handled by the inliner.  */
    2870                 :            : 
    2871                 :            : static int
    2872                 :     607009 : matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    2873                 :            :                   void *data ATTRIBUTE_UNUSED)
    2874                 :            : {
    2875                 :     607009 :   gfc_expr *expr1, *expr2;
    2876                 :     607009 :   gfc_code *co;
    2877                 :     607009 :   gfc_actual_arglist *a, *b;
    2878                 :     607009 :   bool a_tmp, b_tmp;
    2879                 :     607009 :   gfc_expr *matrix_a, *matrix_b;
    2880                 :     607009 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    2881                 :            : 
    2882                 :     607009 :   co = *c;
    2883                 :            : 
    2884                 :     607009 :   if (co->op != EXEC_ASSIGN)
    2885                 :            :     return 0;
    2886                 :            : 
    2887                 :     135715 :   if (forall_level > 0 || iterator_level > 0 || in_omp_workshare
    2888                 :     133366 :       || in_omp_atomic || in_where)
    2889                 :            :     return 0;
    2890                 :            : 
    2891                 :            :   /* This has some duplication with inline_matmul_assign.  This
    2892                 :            :      is because the creation of temporary variables could still fail,
    2893                 :            :      and inline_matmul_assign still needs to be able to handle these
    2894                 :            :      cases.  */
    2895                 :     131179 :   expr1 = co->expr1;
    2896                 :     131179 :   expr2 = co->expr2;
    2897                 :            : 
    2898                 :     131179 :   if (expr2->expr_type != EXPR_FUNCTION
    2899                 :      20462 :       || expr2->value.function.isym == NULL
    2900                 :      15970 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    2901                 :            :     return 0;
    2902                 :            : 
    2903                 :        833 :   a_tmp = false;
    2904                 :        833 :   a = expr2->value.function.actual;
    2905                 :        833 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    2906                 :        833 :   if (matrix_a != NULL)
    2907                 :            :     {
    2908                 :        779 :       if (matrix_a->expr_type == EXPR_VARIABLE
    2909                 :        779 :           && (gfc_check_dependency (matrix_a, expr1, true)
    2910                 :        750 :               || gfc_has_dimen_vector_ref (matrix_a)))
    2911                 :            :         a_tmp = true;
    2912                 :            :     }
    2913                 :            :   else
    2914                 :            :     a_tmp = true;
    2915                 :            : 
    2916                 :        833 :   b_tmp = false;
    2917                 :        833 :   b = a->next;
    2918                 :        833 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    2919                 :        833 :   if (matrix_b != NULL)
    2920                 :            :     {
    2921                 :        776 :       if (matrix_b->expr_type == EXPR_VARIABLE
    2922                 :        776 :           && (gfc_check_dependency (matrix_b, expr1, true)
    2923                 :        768 :               || gfc_has_dimen_vector_ref (matrix_b)))
    2924                 :            :         b_tmp = true;
    2925                 :            :     }
    2926                 :            :   else
    2927                 :            :     b_tmp = true;
    2928                 :            : 
    2929                 :        833 :   if (!a_tmp && !b_tmp)
    2930                 :            :     return 0;
    2931                 :            : 
    2932                 :        128 :   current_code = c;
    2933                 :        128 :   inserted_block = NULL;
    2934                 :        128 :   changed_statement = NULL;
    2935                 :        128 :   if (a_tmp)
    2936                 :            :     {
    2937                 :         85 :       gfc_expr *at;
    2938                 :         85 :       at = create_var (a->expr,"mma");
    2939                 :         85 :       if (at)
    2940                 :         85 :         a->expr = at;
    2941                 :            :     }
    2942                 :        128 :   if (b_tmp)
    2943                 :            :     {
    2944                 :         66 :       gfc_expr *bt;
    2945                 :         66 :       bt = create_var (b->expr,"mmb");
    2946                 :         66 :       if (bt)
    2947                 :         66 :         b->expr = bt;
    2948                 :            :     }
    2949                 :            :   return 0;
    2950                 :            : }
    2951                 :            : 
    2952                 :            : /* Auxiliary function to build and simplify an array inquiry function.
    2953                 :            :    dim is zero-based.  */
    2954                 :            : 
    2955                 :            : static gfc_expr *
    2956                 :       7759 : get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0)
    2957                 :            : {
    2958                 :       7759 :   gfc_expr *fcn;
    2959                 :       7759 :   gfc_expr *dim_arg, *kind;
    2960                 :       7759 :   const char *name;
    2961                 :       7759 :   gfc_expr *ec;
    2962                 :            : 
    2963                 :       7759 :   switch (id)
    2964                 :            :     {
    2965                 :            :     case GFC_ISYM_LBOUND:
    2966                 :            :       name = "_gfortran_lbound";
    2967                 :            :       break;
    2968                 :            : 
    2969                 :          0 :     case GFC_ISYM_UBOUND:
    2970                 :          0 :       name = "_gfortran_ubound";
    2971                 :          0 :       break;
    2972                 :            : 
    2973                 :       4198 :     case GFC_ISYM_SIZE:
    2974                 :       4198 :       name = "_gfortran_size";
    2975                 :       4198 :       break;
    2976                 :            : 
    2977                 :          0 :     default:
    2978                 :          0 :       gcc_unreachable ();
    2979                 :            :     }
    2980                 :            : 
    2981                 :       7759 :   dim_arg =  gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim);
    2982                 :       7759 :   if (okind != 0)
    2983                 :        222 :     kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
    2984                 :            :                              okind);
    2985                 :            :   else
    2986                 :       7537 :     kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where,
    2987                 :            :                              gfc_index_integer_kind);
    2988                 :            : 
    2989                 :       7759 :   ec = gfc_copy_expr (e);
    2990                 :            : 
    2991                 :            :   /* No bounds checking, this will be done before the loops if -fcheck=bounds
    2992                 :            :      is in effect.  */
    2993                 :       7759 :   ec->no_bounds_check = 1;
    2994                 :       7759 :   fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3,
    2995                 :            :                                   ec, dim_arg,  kind);
    2996                 :       7759 :   gfc_simplify_expr (fcn, 0);
    2997                 :       7759 :   fcn->no_bounds_check = 1;
    2998                 :       7759 :   return fcn;
    2999                 :            : }
    3000                 :            : 
    3001                 :            : /* Builds a logical expression.  */
    3002                 :            : 
    3003                 :            : static gfc_expr*
    3004                 :       1413 : build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
    3005                 :            : {
    3006                 :       1413 :   gfc_typespec ts;
    3007                 :       1413 :   gfc_expr *res;
    3008                 :            : 
    3009                 :       1413 :   ts.type = BT_LOGICAL;
    3010                 :       1413 :   ts.kind = gfc_default_logical_kind;
    3011                 :          0 :   res = gfc_get_expr ();
    3012                 :       1413 :   res->where = e1->where;
    3013                 :       1413 :   res->expr_type = EXPR_OP;
    3014                 :       1413 :   res->value.op.op = op;
    3015                 :       1413 :   res->value.op.op1 = e1;
    3016                 :       1413 :   res->value.op.op2 = e2;
    3017                 :       1413 :   res->ts = ts;
    3018                 :            : 
    3019                 :       1413 :   return res;
    3020                 :            : }
    3021                 :            : 
    3022                 :            : 
    3023                 :            : /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
    3024                 :            :    compatible typespecs.  */
    3025                 :            : 
    3026                 :            : static gfc_expr *
    3027                 :       6809 : get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2)
    3028                 :            : {
    3029                 :       6809 :   gfc_expr *res;
    3030                 :            : 
    3031                 :       6809 :   res = gfc_get_expr ();
    3032                 :       6809 :   res->ts = e1->ts;
    3033                 :       6809 :   res->where = e1->where;
    3034                 :       6809 :   res->expr_type = EXPR_OP;
    3035                 :       6809 :   res->value.op.op = op;
    3036                 :       6809 :   res->value.op.op1 = e1;
    3037                 :       6809 :   res->value.op.op2 = e2;
    3038                 :       6809 :   gfc_simplify_expr (res, 0);
    3039                 :       6809 :   return res;
    3040                 :            : }
    3041                 :            : 
    3042                 :            : /* Generate the IF statement for a runtime check if we want to do inlining or
    3043                 :            :    not - putting in the code for both branches and putting it into the syntax
    3044                 :            :    tree is the caller's responsibility.  For fixed array sizes, this should be
    3045                 :            :    removed by DCE. Only called for rank-two matrices A and B.  */
    3046                 :            : 
    3047                 :            : static gfc_code *
    3048                 :        535 : inline_limit_check (gfc_expr *a, gfc_expr *b, int limit)
    3049                 :            : {
    3050                 :        535 :   gfc_expr *inline_limit;
    3051                 :        535 :   gfc_code *if_1, *if_2, *else_2;
    3052                 :        535 :   gfc_expr *b2, *a2, *a1, *m1, *m2;
    3053                 :        535 :   gfc_typespec ts;
    3054                 :        535 :   gfc_expr *cond;
    3055                 :            : 
    3056                 :            :   /* Calculation is done in real to avoid integer overflow.  */
    3057                 :            : 
    3058                 :        535 :   inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind,
    3059                 :            :                                         &a->where);
    3060                 :        535 :   mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE);
    3061                 :        535 :   mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3,
    3062                 :            :                GFC_RND_MODE);
    3063                 :            : 
    3064                 :        535 :   a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3065                 :        535 :   a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3066                 :        535 :   b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3067                 :            : 
    3068                 :        535 :   gfc_clear_ts (&ts);
    3069                 :        535 :   ts.type = BT_REAL;
    3070                 :        535 :   ts.kind = gfc_default_real_kind;
    3071                 :        535 :   gfc_convert_type_warn (a1, &ts, 2, 0);
    3072                 :        535 :   gfc_convert_type_warn (a2, &ts, 2, 0);
    3073                 :        535 :   gfc_convert_type_warn (b2, &ts, 2, 0);
    3074                 :            : 
    3075                 :        535 :   m1 = get_operand (INTRINSIC_TIMES, a1, a2);
    3076                 :        535 :   m2 = get_operand (INTRINSIC_TIMES, m1, b2);
    3077                 :            : 
    3078                 :        535 :   cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit);
    3079                 :        535 :   gfc_simplify_expr (cond, 0);
    3080                 :            : 
    3081                 :        535 :   else_2 = XCNEW (gfc_code);
    3082                 :        535 :   else_2->op = EXEC_IF;
    3083                 :        535 :   else_2->loc = a->where;
    3084                 :            : 
    3085                 :        535 :   if_2 = XCNEW (gfc_code);
    3086                 :        535 :   if_2->op = EXEC_IF;
    3087                 :        535 :   if_2->expr1 = cond;
    3088                 :        535 :   if_2->loc = a->where;
    3089                 :        535 :   if_2->block = else_2;
    3090                 :            : 
    3091                 :        535 :   if_1 = XCNEW (gfc_code);
    3092                 :        535 :   if_1->op = EXEC_IF;
    3093                 :        535 :   if_1->block = if_2;
    3094                 :        535 :   if_1->loc = a->where;
    3095                 :            : 
    3096                 :        535 :   return if_1;
    3097                 :            : }
    3098                 :            : 
    3099                 :            : 
    3100                 :            : /* Insert code to issue a runtime error if the expressions are not equal.  */
    3101                 :            : 
    3102                 :            : static gfc_code *
    3103                 :        401 : runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
    3104                 :            : {
    3105                 :        401 :   gfc_expr *cond;
    3106                 :        401 :   gfc_code *if_1, *if_2;
    3107                 :        401 :   gfc_code *c;
    3108                 :        401 :   gfc_actual_arglist *a1, *a2, *a3;
    3109                 :            : 
    3110                 :        401 :   gcc_assert (e1->where.lb);
    3111                 :            :   /* Build the call to runtime_error.  */
    3112                 :        401 :   c = XCNEW (gfc_code);
    3113                 :        401 :   c->op = EXEC_CALL;
    3114                 :        401 :   c->loc = e1->where;
    3115                 :            : 
    3116                 :            :   /* Get a null-terminated message string.  */
    3117                 :            : 
    3118                 :        401 :   a1 = gfc_get_actual_arglist ();
    3119                 :        802 :   a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where,
    3120                 :        401 :                                      msg, strlen(msg)+1);
    3121                 :        401 :   c->ext.actual = a1;
    3122                 :            : 
    3123                 :            :   /* Pass the value of the first expression.  */
    3124                 :        401 :   a2 = gfc_get_actual_arglist ();
    3125                 :        401 :   a2->expr = gfc_copy_expr (e1);
    3126                 :        401 :   a1->next = a2;
    3127                 :            : 
    3128                 :            :   /* Pass the value of the second expression.  */
    3129                 :        401 :   a3 = gfc_get_actual_arglist ();
    3130                 :        401 :   a3->expr = gfc_copy_expr (e2);
    3131                 :        401 :   a2->next = a3;
    3132                 :            : 
    3133                 :        401 :   gfc_check_fe_runtime_error (c->ext.actual);
    3134                 :        401 :   gfc_resolve_fe_runtime_error (c);
    3135                 :            : 
    3136                 :        401 :   if_2 = XCNEW (gfc_code);
    3137                 :        401 :   if_2->op = EXEC_IF;
    3138                 :        401 :   if_2->loc = e1->where;
    3139                 :        401 :   if_2->next = c;
    3140                 :            : 
    3141                 :        401 :   if_1 = XCNEW (gfc_code);
    3142                 :        401 :   if_1->op = EXEC_IF;
    3143                 :        401 :   if_1->block = if_2;
    3144                 :        401 :   if_1->loc = e1->where;
    3145                 :            : 
    3146                 :        401 :   cond = build_logical_expr (INTRINSIC_NE, e1, e2);
    3147                 :        401 :   gfc_simplify_expr (cond, 0);
    3148                 :        401 :   if_2->expr1 = cond;
    3149                 :            : 
    3150                 :        401 :   return if_1;
    3151                 :            : }
    3152                 :            : 
    3153                 :            : /* Handle matrix reallocation.  Caller is responsible to insert into
    3154                 :            :    the code tree.
    3155                 :            : 
    3156                 :            :    For the two-dimensional case, build
    3157                 :            : 
    3158                 :            :   if (allocated(c)) then
    3159                 :            :      if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
    3160                 :            :         deallocate(c)
    3161                 :            :         allocate (c(size(a,1), size(b,2)))
    3162                 :            :      end if
    3163                 :            :   else
    3164                 :            :      allocate (c(size(a,1),size(b,2)))
    3165                 :            :   end if
    3166                 :            : 
    3167                 :            :   and for the other cases correspondingly.
    3168                 :            : */
    3169                 :            : 
    3170                 :            : static gfc_code *
    3171                 :        203 : matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b,
    3172                 :            :                     enum matrix_case m_case)
    3173                 :            : {
    3174                 :            : 
    3175                 :        203 :   gfc_expr *allocated, *alloc_expr;
    3176                 :        203 :   gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2;
    3177                 :        203 :   gfc_code *else_alloc;
    3178                 :        203 :   gfc_code *deallocate, *allocate1, *allocate_else;
    3179                 :        203 :   gfc_array_ref *ar;
    3180                 :        203 :   gfc_expr *cond, *ne1, *ne2;
    3181                 :            : 
    3182                 :        203 :   if (warn_realloc_lhs)
    3183                 :         33 :     gfc_warning (OPT_Wrealloc_lhs,
    3184                 :            :                  "Code for reallocating the allocatable array at %L will "
    3185                 :            :                  "be added", &c->where);
    3186                 :            : 
    3187                 :        203 :   alloc_expr = gfc_copy_expr (c);
    3188                 :            : 
    3189                 :        203 :   ar = gfc_find_array_ref (alloc_expr);
    3190                 :        203 :   gcc_assert (ar && ar->type == AR_FULL);
    3191                 :            : 
    3192                 :            :   /* c comes in as a full ref.  Change it into a copy and make it into an
    3193                 :            :      element ref so it has the right form for ALLOCATE.  In the same
    3194                 :            :      switch statement, also generate the size comparison for the secod IF
    3195                 :            :      statement.  */
    3196                 :            : 
    3197                 :        203 :   ar->type = AR_ELEMENT;
    3198                 :            : 
    3199                 :        203 :   switch (m_case)
    3200                 :            :     {
    3201                 :        106 :     case A2B2:
    3202                 :        106 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3203                 :        106 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3204                 :        106 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3205                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3206                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    3207                 :        106 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3208                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3209                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3210                 :        106 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3211                 :        106 :       break;
    3212                 :            : 
    3213                 :         17 :     case A2B2T:
    3214                 :         17 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3215                 :         17 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
    3216                 :            : 
    3217                 :         17 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3218                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3219                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 1));
    3220                 :         17 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3221                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3222                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
    3223                 :         17 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3224                 :         17 :       break;
    3225                 :            : 
    3226                 :         14 :     case A2TB2:
    3227                 :            : 
    3228                 :         14 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3229                 :         14 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3230                 :            : 
    3231                 :         14 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3232                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3233                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3234                 :         14 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3235                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3236                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3237                 :         14 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3238                 :         14 :       break;
    3239                 :            : 
    3240                 :         50 :     case A2B1:
    3241                 :         50 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1);
    3242                 :         50 :       cond = build_logical_expr (INTRINSIC_NE,
    3243                 :            :                                  get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3244                 :            :                                  get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3245                 :         50 :       break;
    3246                 :            : 
    3247                 :         16 :     case A1B2:
    3248                 :         16 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2);
    3249                 :         16 :       cond = build_logical_expr (INTRINSIC_NE,
    3250                 :            :                                  get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3251                 :            :                                  get_array_inq_function (GFC_ISYM_SIZE, b, 2));
    3252                 :         16 :       break;
    3253                 :            : 
    3254                 :          0 :     case A2TB2T:
    3255                 :            :       /* This can only happen for BLAS, we do not handle that case in
    3256                 :            :          inline mamtul.  */
    3257                 :          0 :       ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2);
    3258                 :          0 :       ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1);
    3259                 :            : 
    3260                 :          0 :       ne1 = build_logical_expr (INTRINSIC_NE,
    3261                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 1),
    3262                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, a, 2));
    3263                 :          0 :       ne2 = build_logical_expr (INTRINSIC_NE,
    3264                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, c, 2),
    3265                 :            :                                 get_array_inq_function (GFC_ISYM_SIZE, b, 1));
    3266                 :            : 
    3267                 :          0 :       cond = build_logical_expr (INTRINSIC_OR, ne1, ne2);
    3268                 :          0 :       break;
    3269                 :            : 
    3270                 :          0 :     default:
    3271                 :          0 :       gcc_unreachable();
    3272                 :            : 
    3273                 :            :     }
    3274                 :            : 
    3275                 :        203 :   gfc_simplify_expr (cond, 0);
    3276                 :            : 
    3277                 :            :   /* We need two identical allocate statements in two
    3278                 :            :      branches of the IF statement.  */
    3279                 :            : 
    3280                 :        203 :   allocate1 = XCNEW (gfc_code);
    3281                 :        203 :   allocate1->op = EXEC_ALLOCATE;
    3282                 :        203 :   allocate1->ext.alloc.list = gfc_get_alloc ();
    3283                 :        203 :   allocate1->loc = c->where;
    3284                 :        203 :   allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr);
    3285                 :            : 
    3286                 :        203 :   allocate_else = XCNEW (gfc_code);
    3287                 :        203 :   allocate_else->op = EXEC_ALLOCATE;
    3288                 :        203 :   allocate_else->ext.alloc.list = gfc_get_alloc ();
    3289                 :        203 :   allocate_else->loc = c->where;
    3290                 :        203 :   allocate_else->ext.alloc.list->expr = alloc_expr;
    3291                 :            : 
    3292                 :        203 :   allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED,
    3293                 :            :                                         "_gfortran_allocated", c->where,
    3294                 :            :                                         1, gfc_copy_expr (c));
    3295                 :            : 
    3296                 :        203 :   deallocate = XCNEW (gfc_code);
    3297                 :        203 :   deallocate->op = EXEC_DEALLOCATE;
    3298                 :        203 :   deallocate->ext.alloc.list = gfc_get_alloc ();
    3299                 :        203 :   deallocate->ext.alloc.list->expr = gfc_copy_expr (c);
    3300                 :        203 :   deallocate->next = allocate1;
    3301                 :        203 :   deallocate->loc = c->where;
    3302                 :            : 
    3303                 :        203 :   if_size_2 = XCNEW (gfc_code);
    3304                 :        203 :   if_size_2->op = EXEC_IF;
    3305                 :        203 :   if_size_2->expr1 = cond;
    3306                 :        203 :   if_size_2->loc = c->where;
    3307                 :        203 :   if_size_2->next = deallocate;
    3308                 :            : 
    3309                 :        203 :   if_size_1 = XCNEW (gfc_code);
    3310                 :        203 :   if_size_1->op = EXEC_IF;
    3311                 :        203 :   if_size_1->block = if_size_2;
    3312                 :        203 :   if_size_1->loc = c->where;
    3313                 :            : 
    3314                 :        203 :   else_alloc = XCNEW (gfc_code);
    3315                 :        203 :   else_alloc->op = EXEC_IF;
    3316                 :        203 :   else_alloc->loc = c->where;
    3317                 :        203 :   else_alloc->next = allocate_else;
    3318                 :            : 
    3319                 :        203 :   if_alloc_2 = XCNEW (gfc_code);
    3320                 :        203 :   if_alloc_2->op = EXEC_IF;
    3321                 :        203 :   if_alloc_2->expr1 = allocated;
    3322                 :        203 :   if_alloc_2->loc = c->where;
    3323                 :        203 :   if_alloc_2->next = if_size_1;
    3324                 :        203 :   if_alloc_2->block = else_alloc;
    3325                 :            : 
    3326                 :        203 :   if_alloc_1 = XCNEW (gfc_code);
    3327                 :        203 :   if_alloc_1->op = EXEC_IF;
    3328                 :        203 :   if_alloc_1->block = if_alloc_2;
    3329                 :        203 :   if_alloc_1->loc = c->where;
    3330                 :            : 
    3331                 :        203 :   return if_alloc_1;
    3332                 :            : }
    3333                 :            : 
    3334                 :            : /* Callback function for has_function_or_op.  */
    3335                 :            : 
    3336                 :            : static int
    3337                 :        495 : is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    3338                 :            :              void *data ATTRIBUTE_UNUSED)
    3339                 :            : {
    3340                 :        495 :   if ((*e) == 0)
    3341                 :            :     return 0;
    3342                 :            :   else
    3343                 :        495 :     return (*e)->expr_type == EXPR_FUNCTION
    3344                 :        495 :       || (*e)->expr_type == EXPR_OP;
    3345                 :            : }
    3346                 :            : 
    3347                 :            : /* Returns true if the expression contains a function.  */
    3348                 :            : 
    3349                 :            : static bool
    3350                 :       1036 : has_function_or_op (gfc_expr **e)
    3351                 :            : {
    3352                 :          0 :   if (e == NULL)
    3353                 :            :     return false;
    3354                 :            :   else
    3355                 :       1036 :     return gfc_expr_walker (e, is_function_or_op, NULL);
    3356                 :            : }
    3357                 :            : 
    3358                 :            : /* Freeze (assign to a temporary variable) a single expression.  */
    3359                 :            : 
    3360                 :            : static void
    3361                 :       1036 : freeze_expr (gfc_expr **ep)
    3362                 :            : {
    3363                 :       1036 :   gfc_expr *ne;
    3364                 :       2072 :   if (has_function_or_op (ep))
    3365                 :            :     {
    3366                 :         75 :       ne = create_var (*ep, "freeze");
    3367                 :         75 :       *ep = ne;
    3368                 :            :     }
    3369                 :       1036 : }
    3370                 :            : 
    3371                 :            : /* Go through an expression's references and assign them to temporary
    3372                 :            :    variables if they contain functions.  This is usually done prior to
    3373                 :            :    front-end scalarization to avoid multiple invocations of functions.  */
    3374                 :            : 
    3375                 :            : static void
    3376                 :       2091 : freeze_references (gfc_expr *e)
    3377                 :            : {
    3378                 :       2091 :   gfc_ref *r;
    3379                 :       2091 :   gfc_array_ref *ar;
    3380                 :       2091 :   int i;
    3381                 :            : 
    3382                 :       4187 :   for (r=e->ref; r; r=r->next)
    3383                 :            :     {
    3384                 :       2096 :       if (r->type == REF_SUBSTRING)
    3385                 :            :         {
    3386                 :          0 :           if (r->u.ss.start != NULL)
    3387                 :          0 :             freeze_expr (&r->u.ss.start);
    3388                 :            : 
    3389                 :          0 :           if (r->u.ss.end != NULL)
    3390                 :          0 :             freeze_expr (&r->u.ss.end);
    3391                 :            :         }
    3392                 :       2096 :       else if (r->type == REF_ARRAY)
    3393                 :            :         {
    3394                 :       2091 :           ar = &r->u.ar;
    3395                 :       2091 :           switch (ar->type)
    3396                 :            :             {
    3397                 :            :             case AR_FULL:
    3398                 :            :               break;
    3399                 :            : 
    3400                 :            :             case AR_SECTION:
    3401                 :        550 :               for (i=0; i<ar->dimen; i++)
    3402                 :            :                 {
    3403                 :        366 :                   if (ar->dimen_type[i] == DIMEN_RANGE)
    3404                 :            :                     {
    3405                 :        335 :                       freeze_expr (&ar->start[i]);
    3406                 :        335 :                       freeze_expr (&ar->end[i]);
    3407                 :        335 :                       freeze_expr (&ar->stride[i]);
    3408                 :            :                     }
    3409                 :         31 :                   else if (ar->dimen_type[i] == DIMEN_ELEMENT)
    3410                 :            :                     {
    3411                 :         31 :                       freeze_expr (&ar->start[i]);
    3412                 :            :                     }
    3413                 :            :                 }
    3414                 :            :               break;
    3415                 :            : 
    3416                 :            :             case AR_ELEMENT:
    3417                 :          0 :               for (i=0; i<ar->dimen; i++)
    3418                 :          0 :                 freeze_expr (&ar->start[i]);
    3419                 :            :               break;
    3420                 :            : 
    3421                 :            :             default:
    3422                 :            :               break;
    3423                 :            :             }
    3424                 :            :         }
    3425                 :            :     }
    3426                 :       2091 : }
    3427                 :            : 
    3428                 :            : /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise.  */
    3429                 :            : 
    3430                 :            : static gfc_expr *
    3431                 :       3784 : convert_to_index_kind (gfc_expr *e)
    3432                 :            : {
    3433                 :       3784 :   gfc_expr *res;
    3434                 :            : 
    3435                 :       3784 :   gcc_assert (e != NULL);
    3436                 :            : 
    3437                 :       3784 :   res = gfc_copy_expr (e);
    3438                 :            : 
    3439                 :       3784 :   gcc_assert (e->ts.type == BT_INTEGER);
    3440                 :            : 
    3441                 :       3784 :   if (res->ts.kind != gfc_index_integer_kind)
    3442                 :            :     {
    3443                 :          0 :       gfc_typespec ts;
    3444                 :          0 :       gfc_clear_ts (&ts);
    3445                 :          0 :       ts.type = BT_INTEGER;
    3446                 :          0 :       ts.kind = gfc_index_integer_kind;
    3447                 :            : 
    3448                 :          0 :       gfc_convert_type_warn (e, &ts, 2, 0);
    3449                 :            :     }
    3450                 :            : 
    3451                 :       3784 :   return res;
    3452                 :            : }
    3453                 :            : 
    3454                 :            : /* Function to create a DO loop including creation of the
    3455                 :            :    iteration variable.  gfc_expr are copied.*/
    3456                 :            : 
    3457                 :            : static gfc_code *
    3458                 :       1892 : create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
    3459                 :            :                 gfc_namespace *ns, char *vname)
    3460                 :            : {
    3461                 :            : 
    3462                 :       1892 :   char name[GFC_MAX_SYMBOL_LEN +1];
    3463                 :       1892 :   gfc_symtree *symtree;
    3464                 :       1892 :   gfc_symbol *symbol;
    3465                 :       1892 :   gfc_expr *i;
    3466                 :       1892 :   gfc_code *n, *n2;
    3467                 :            : 
    3468                 :            :   /* Create an expression for the iteration variable.  */
    3469                 :       1892 :   if (vname)
    3470                 :          0 :     sprintf (name, "__var_%d_do_%s", var_num++, vname);
    3471                 :            :   else
    3472                 :       1892 :     sprintf (name, "__var_%d_do", var_num++);
    3473                 :            : 
    3474                 :            : 
    3475                 :       1892 :   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
    3476                 :          0 :     gcc_unreachable ();
    3477                 :            : 
    3478                 :            :   /* Create the loop variable.  */
    3479                 :            : 
    3480                 :       1892 :   symbol = symtree->n.sym;
    3481                 :       1892 :   symbol->ts.type = BT_INTEGER;
    3482                 :       1892 :   symbol->ts.kind = gfc_index_integer_kind;
    3483                 :       1892 :   symbol->attr.flavor = FL_VARIABLE;
    3484                 :       1892 :   symbol->attr.referenced = 1;
    3485                 :       1892 :   symbol->attr.dimension = 0;
    3486                 :       1892 :   symbol->attr.fe_temp = 1;
    3487                 :       1892 :   gfc_commit_symbol (symbol);
    3488                 :            : 
    3489                 :       1892 :   i = gfc_get_expr ();
    3490                 :       1892 :   i->expr_type = EXPR_VARIABLE;
    3491                 :       1892 :   i->ts = symbol->ts;
    3492                 :       1892 :   i->rank = 0;
    3493                 :       1892 :   i->where = *where;
    3494                 :       1892 :   i->symtree = symtree;
    3495                 :            : 
    3496                 :            :   /* ... and the nested DO statements.  */
    3497                 :       1892 :   n = XCNEW (gfc_code);
    3498                 :       1892 :   n->op = EXEC_DO;
    3499                 :       1892 :   n->loc = *where;
    3500                 :       1892 :   n->ext.iterator = gfc_get_iterator ();
    3501                 :       1892 :   n->ext.iterator->var = i;
    3502                 :       1892 :   n->ext.iterator->start = convert_to_index_kind (start);
    3503                 :       1892 :   n->ext.iterator->end = convert_to_index_kind (end);
    3504                 :       1892 :   if (step)
    3505                 :          0 :     n->ext.iterator->step = convert_to_index_kind (step);
    3506                 :            :   else
    3507                 :       1892 :     n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind,
    3508                 :            :                                               where, 1);
    3509                 :            : 
    3510                 :       1892 :   n2 = XCNEW (gfc_code);
    3511                 :       1892 :   n2->op = EXEC_DO;
    3512                 :       1892 :   n2->loc = *where;
    3513                 :       1892 :   n2->next = NULL;
    3514                 :       1892 :   n->block = n2;
    3515                 :       1892 :   return n;
    3516                 :            : }
    3517                 :            : 
    3518                 :            : /* Get the upper bound of the DO loops for matmul along a dimension.  This
    3519                 :            :  is one-based.  */
    3520                 :            : 
    3521                 :            : static gfc_expr*
    3522                 :       1892 : get_size_m1 (gfc_expr *e, int dimen)
    3523                 :            : {
    3524                 :       1892 :   mpz_t size;
    3525                 :       1892 :   gfc_expr *res;
    3526                 :            : 
    3527                 :       1892 :   if (gfc_array_dimen_size (e, dimen - 1, &size))
    3528                 :            :     {
    3529                 :       1343 :       res = gfc_get_constant_expr (BT_INTEGER,
    3530                 :            :                                    gfc_index_integer_kind, &e->where);
    3531                 :       1343 :       mpz_sub_ui (res->value.integer, size, 1);
    3532                 :       1343 :       mpz_clear (size);
    3533                 :            :     }
    3534                 :            :   else
    3535                 :            :     {
    3536                 :        549 :       res = get_operand (INTRINSIC_MINUS,
    3537                 :            :                          get_array_inq_function (GFC_ISYM_SIZE, e, dimen),
    3538                 :            :                          gfc_get_int_expr (gfc_index_integer_kind,
    3539                 :            :                                            &e->where, 1));
    3540                 :        549 :       gfc_simplify_expr (res, 0);
    3541                 :            :     }
    3542                 :            : 
    3543                 :       1892 :   return res;
    3544                 :            : }
    3545                 :            : 
    3546                 :            : /* Function to return a scalarized expression. It is assumed that indices are
    3547                 :            :  zero based to make generation of DO loops easier.  A zero as index will
    3548                 :            :  access the first element along a dimension.  Single element references will
    3549                 :            :  be skipped.  A NULL as an expression will be replaced by a full reference.
    3550                 :            :  This assumes that the index loops have gfc_index_integer_kind, and that all
    3551                 :            :  references have been frozen.  */
    3552                 :            : 
    3553                 :            : static gfc_expr*
    3554                 :       2091 : scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
    3555                 :            : {
    3556                 :       2091 :   gfc_array_ref *ar;
    3557                 :       2091 :   int i;
    3558                 :       2091 :   int rank;
    3559                 :       2091 :   gfc_expr *e;
    3560                 :       2091 :   int i_index;
    3561                 :       2091 :   bool was_fullref;
    3562                 :            : 
    3563                 :       2091 :   e = gfc_copy_expr(e_in);
    3564                 :            : 
    3565                 :       2091 :   rank = e->rank;
    3566                 :            : 
    3567                 :       2091 :   ar = gfc_find_array_ref (e);
    3568                 :            : 
    3569                 :            :   /* We scalarize count_index variables, reducing the rank by count_index.  */
    3570                 :            : 
    3571                 :       2091 :   e->rank = rank - count_index;
    3572                 :            : 
    3573                 :       2091 :   was_fullref = ar->type == AR_FULL;
    3574                 :            : 
    3575                 :       2091 :   if (e->rank == 0)
    3576                 :       2091 :     ar->type = AR_ELEMENT;
    3577                 :            :   else
    3578                 :          0 :     ar->type = AR_SECTION;
    3579                 :            : 
    3580                 :            :   /* Loop over the indices.  For each index, create the expression
    3581                 :            :      index * stride + lbound(e, dim).  */
    3582                 :            : 
    3583                 :            :   i_index = 0;
    3584                 :       5906 :   for (i=0; i < ar->dimen; i++)
    3585                 :            :     {
    3586                 :       3815 :       if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE)
    3587                 :            :         {
    3588                 :       3784 :           if (index[i_index] != NULL)
    3589                 :            :             {
    3590                 :       3784 :               gfc_expr *lbound, *nindex;
    3591                 :       3784 :               gfc_expr *loopvar;
    3592                 :            : 
    3593                 :       3784 :               loopvar = gfc_copy_expr (index[i_index]);
    3594                 :            : 
    3595                 :       3784 :               if (ar->stride[i])
    3596                 :            :                 {
    3597                 :         12 :                   gfc_expr *tmp;
    3598                 :            : 
    3599                 :         12 :                   tmp = gfc_copy_expr(ar->stride[i]);
    3600                 :         12 :                   if (tmp->ts.kind != gfc_index_integer_kind)
    3601                 :            :                     {
    3602                 :          0 :                       gfc_typespec ts;
    3603                 :          0 :                       gfc_clear_ts (&ts);
    3604                 :          0 :                       ts.type = BT_INTEGER;
    3605                 :          0 :                       ts.kind = gfc_index_integer_kind;
    3606                 :          0 :                       gfc_convert_type (tmp, &ts, 2);
    3607                 :            :                     }
    3608                 :         12 :                   nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp);
    3609                 :            :                 }
    3610                 :            :               else
    3611                 :            :                 nindex = loopvar;
    3612                 :            : 
    3613                 :            :               /* Calculate the lower bound of the expression.  */
    3614                 :       3784 :               if (ar->start[i])
    3615                 :            :                 {
    3616                 :        223 :                   lbound = gfc_copy_expr (ar->start[i]);
    3617                 :        223 :                   if (lbound->ts.kind != gfc_index_integer_kind)
    3618                 :            :                     {
    3619                 :        223 :                       gfc_typespec ts;
    3620                 :        223 :                       gfc_clear_ts (&ts);
    3621                 :        223 :                       ts.type = BT_INTEGER;
    3622                 :        223 :                       ts.kind = gfc_index_integer_kind;
    3623                 :        223 :                       gfc_convert_type (lbound, &ts, 2);
    3624                 :            : 
    3625                 :            :                     }
    3626                 :            :                 }
    3627                 :            :               else
    3628                 :            :                 {
    3629                 :       3561 :                   gfc_expr *lbound_e;
    3630                 :       3561 :                   gfc_ref *ref;
    3631                 :            : 
    3632                 :       3561 :                   lbound_e = gfc_copy_expr (e_in);
    3633                 :            : 
    3634                 :       3561 :                   for (ref = lbound_e->ref; ref; ref = ref->next)
    3635                 :       3561 :                     if (ref->type == REF_ARRAY
    3636                 :       3561 :                         && (ref->u.ar.type == AR_FULL
    3637                 :        112 :                             || ref->u.ar.type == AR_SECTION))
    3638                 :            :                       break;
    3639                 :            : 
    3640                 :       3561 :                   if (ref->next)
    3641                 :            :                     {
    3642                 :          9 :                       gfc_free_ref_list (ref->next);
    3643                 :          9 :                       ref->next = NULL;
    3644                 :            :                     }
    3645                 :            : 
    3646                 :       3561 :                   if (!was_fullref)
    3647                 :            :                     {
    3648                 :            :                       /* Look at full individual sections, like a(:).  The first index
    3649                 :            :                          is the lbound of a full ref.  */
    3650                 :        112 :                       int j;
    3651                 :        112 :                       gfc_array_ref *ar;
    3652                 :        112 :                       int to;
    3653                 :            : 
    3654                 :        112 :                       ar = &ref->u.ar;
    3655                 :            : 
    3656                 :            :                       /* For assumed size, we need to keep around the final
    3657                 :            :                          reference in order not to get an error on resolution
    3658                 :            :                          below, and we cannot use AR_FULL.  */
    3659                 :            : 
    3660                 :        112 :                       if (ar->as->type == AS_ASSUMED_SIZE)
    3661                 :            :                         {
    3662                 :          2 :                           ar->type = AR_SECTION;
    3663                 :          2 :                           to = ar->dimen - 1;
    3664                 :            :                         }
    3665                 :            :                       else
    3666                 :            :                         {
    3667                 :        110 :                           to = ar->dimen;
    3668                 :        110 :                           ar->type = AR_FULL;
    3669                 :            :                         }
    3670                 :            : 
    3671                 :        340 :                       for (j = 0; j < to; j++)
    3672                 :            :                         {
    3673                 :        228 :                           gfc_free_expr (ar->start[j]);
    3674                 :        228 :                           ar->start[j] = NULL;
    3675                 :        228 :                           gfc_free_expr (ar->end[j]);
    3676                 :        228 :                           ar->end[j] = NULL;
    3677                 :        228 :                           gfc_free_expr (ar->stride[j]);
    3678                 :        228 :                           ar->stride[j] = NULL;
    3679                 :            :                         }
    3680                 :            : 
    3681                 :            :                       /* We have to get rid of the shape, if there is one.  Do
    3682                 :            :                          so by freeing it and calling gfc_resolve to rebuild
    3683                 :            :                          it, if necessary.  */
    3684                 :            : 
    3685                 :        112 :                       if (lbound_e->shape)
    3686                 :         48 :                         gfc_free_shape (&(lbound_e->shape), lbound_e->rank);
    3687                 :            : 
    3688                 :        112 :                       lbound_e->rank = ar->dimen;
    3689                 :        112 :                       gfc_resolve_expr (lbound_e);
    3690                 :            :                     }
    3691                 :       3561 :                   lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e,
    3692                 :            :                                                    i + 1);
    3693                 :       3561 :                   gfc_free_expr (lbound_e);
    3694                 :            :                 }
    3695                 :            : 
    3696                 :       3784 :               ar->dimen_type[i] = DIMEN_ELEMENT;
    3697                 :            : 
    3698                 :       3784 :               gfc_free_expr (ar->start[i]);
    3699                 :       3784 :               ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound);
    3700                 :            : 
    3701                 :       3784 :               gfc_free_expr (ar->end[i]);
    3702                 :       3784 :               ar->end[i] = NULL;
    3703                 :       3784 :               gfc_free_expr (ar->stride[i]);
    3704                 :       3784 :               ar->stride[i] = NULL;
    3705                 :       3784 :               gfc_simplify_expr (ar->start[i], 0);
    3706                 :            :             }
    3707                 :          0 :           else if (was_fullref)
    3708                 :            :             {
    3709                 :          0 :               gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
    3710                 :            :             }
    3711                 :       3784 :           i_index ++;
    3712                 :            :         }
    3713                 :            :     }
    3714                 :            : 
    3715                 :            :   /* Bounds checking will be done before the loops if -fcheck=bounds
    3716                 :            :      is in effect. */
    3717                 :       2091 :   e->no_bounds_check = 1;
    3718                 :       2091 :   return e;
    3719                 :            : }
    3720                 :            : 
    3721                 :            : /* Helper function to check for a dimen vector as subscript.  */
    3722                 :            : 
    3723                 :            : bool
    3724                 :       3987 : gfc_has_dimen_vector_ref (gfc_expr *e)
    3725                 :            : {
    3726                 :       3987 :   gfc_array_ref *ar;
    3727                 :       3987 :   int i;
    3728                 :            : 
    3729                 :       3987 :   ar = gfc_find_array_ref (e);
    3730                 :       3987 :   gcc_assert (ar);
    3731                 :       3987 :   if (ar->type == AR_FULL)
    3732                 :            :     return false;
    3733                 :            : 
    3734                 :       1588 :   for (i=0; i<ar->dimen; i++)
    3735                 :       1024 :     if (ar->dimen_type[i] == DIMEN_VECTOR)
    3736                 :            :       return true;
    3737                 :            : 
    3738                 :            :   return false;
    3739                 :            : }
    3740                 :            : 
    3741                 :            : /* If handed an expression of the form
    3742                 :            : 
    3743                 :            :    TRANSPOSE(CONJG(A))
    3744                 :            : 
    3745                 :            :    check if A can be handled by matmul and return if there is an uneven number
    3746                 :            :    of CONJG calls.  Return a pointer to the array when everything is OK, NULL
    3747                 :            :    otherwise. The caller has to check for the correct rank.  */
    3748                 :            : 
    3749                 :            : static gfc_expr*
    3750                 :       3148 : check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose)
    3751                 :            : {
    3752                 :       3148 :   *conjg = false;
    3753                 :       3148 :   *transpose = false;
    3754                 :            : 
    3755                 :       3956 :   do
    3756                 :            :     {
    3757                 :       3552 :       if (e->expr_type == EXPR_VARIABLE)
    3758                 :            :         {
    3759                 :       3037 :           gcc_assert (e->rank == 1 || e->rank == 2);
    3760                 :            :           return e;
    3761                 :            :         }
    3762                 :        515 :       else if (e->expr_type == EXPR_FUNCTION)
    3763                 :            :         {
    3764                 :        469 :           if (e->value.function.isym == NULL)
    3765                 :            :             return NULL;
    3766                 :            : 
    3767                 :        446 :           if (e->value.function.isym->id == GFC_ISYM_CONJG)
    3768                 :         66 :             *conjg = !*conjg;
    3769                 :        380 :           else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE)
    3770                 :        338 :             *transpose = !*transpose;
    3771                 :            :           else return NULL;
    3772                 :            :         }
    3773                 :            :       else
    3774                 :            :         return NULL;
    3775                 :            : 
    3776                 :        404 :       e = e->value.function.actual->expr;
    3777                 :            :     }
    3778                 :            :   while(1);
    3779                 :            : 
    3780                 :            :   return NULL;
    3781                 :            : }
    3782                 :            : 
    3783                 :            : /* Macros for unified error messages.  */
    3784                 :            : 
    3785                 :            : #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
    3786                 :            :                      "dimension 1: is %ld, should be %ld")
    3787                 :            : 
    3788                 :            : #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
    3789                 :            :                     "(%ld/%ld)")
    3790                 :            : 
    3791                 :            : #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
    3792                 :            :                     "(%ld/%ld)")
    3793                 :            : 
    3794                 :            : 
    3795                 :            : /* Inline assignments of the form c = matmul(a,b).
    3796                 :            :    Handle only the cases currently where b and c are rank-two arrays.
    3797                 :            : 
    3798                 :            :    This basically translates the code to
    3799                 :            : 
    3800                 :            :    BLOCK
    3801                 :            :      integer i,j,k
    3802                 :            :      c = 0
    3803                 :            :      do j=0, size(b,2)-1
    3804                 :            :        do k=0, size(a, 2)-1
    3805                 :            :          do i=0, size(a, 1)-1
    3806                 :            :             c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
    3807                 :            :             c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
    3808                 :            :             a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
    3809                 :            :             b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
    3810                 :            :          end do
    3811                 :            :        end do
    3812                 :            :      end do
    3813                 :            :    END BLOCK
    3814                 :            : 
    3815                 :            : */
    3816                 :            : 
    3817                 :            : static int
    3818                 :     607291 : inline_matmul_assign (gfc_code **c, int *walk_subtrees,
    3819                 :            :                           void *data ATTRIBUTE_UNUSED)
    3820                 :            : {
    3821                 :     607291 :   gfc_code *co = *c;
    3822                 :     607291 :   gfc_expr *expr1, *expr2;
    3823                 :     607291 :   gfc_expr *matrix_a, *matrix_b;
    3824                 :     607291 :   gfc_actual_arglist *a, *b;
    3825                 :     607291 :   gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul;
    3826                 :     607291 :   gfc_expr *zero_e;
    3827                 :     607291 :   gfc_expr *u1, *u2, *u3;
    3828                 :     607291 :   gfc_expr *list[2];
    3829                 :     607291 :   gfc_expr *ascalar, *bscalar, *cscalar;
    3830                 :     607291 :   gfc_expr *mult;
    3831                 :     607291 :   gfc_expr *var_1, *var_2, *var_3;
    3832                 :     607291 :   gfc_expr *zero;
    3833                 :     607291 :   gfc_namespace *ns;
    3834                 :     607291 :   gfc_intrinsic_op op_times, op_plus;
    3835                 :     607291 :   enum matrix_case m_case;
    3836                 :     607291 :   int i;
    3837                 :     607291 :   gfc_code *if_limit = NULL;
    3838                 :     607291 :   gfc_code **next_code_point;
    3839                 :     607291 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    3840                 :     607291 :   bool realloc_c;
    3841                 :            : 
    3842                 :     607291 :   if (co->op != EXEC_ASSIGN)
    3843                 :            :     return 0;
    3844                 :            : 
    3845                 :     135584 :   if (in_where || in_assoc_list)
    3846                 :            :     return 0;
    3847                 :            : 
    3848                 :            :   /* The BLOCKS generated for the temporary variables and FORALL don't
    3849                 :            :      mix.  */
    3850                 :     135003 :   if (forall_level > 0)
    3851                 :            :     return 0;
    3852                 :            : 
    3853                 :            :   /* For now don't do anything in OpenMP workshare, it confuses
    3854                 :            :      its translation, which expects only the allowed statements in there.
    3855                 :            :      We should figure out how to parallelize this eventually.  */
    3856                 :     132858 :   if (in_omp_workshare || in_omp_atomic)
    3857                 :            :     return 0;
    3858                 :            : 
    3859                 :     131048 :   expr1 = co->expr1;
    3860                 :     131048 :   expr2 = co->expr2;
    3861                 :     131048 :   if (expr2->expr_type != EXPR_FUNCTION
    3862                 :      20333 :       || expr2->value.function.isym == NULL
    3863                 :      15841 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    3864                 :            :     return 0;
    3865                 :            : 
    3866                 :        704 :   current_code = c;
    3867                 :        704 :   inserted_block = NULL;
    3868                 :        704 :   changed_statement = NULL;
    3869                 :            : 
    3870                 :        704 :   a = expr2->value.function.actual;
    3871                 :        704 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    3872                 :        704 :   if (matrix_a == NULL)
    3873                 :            :     return 0;
    3874                 :            : 
    3875                 :        704 :   b = a->next;
    3876                 :        704 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    3877                 :        704 :   if (matrix_b == NULL)
    3878                 :            :     return 0;
    3879                 :            : 
    3880                 :       1406 :   if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a)
    3881                 :       1406 :       || gfc_has_dimen_vector_ref (matrix_b))
    3882                 :          2 :     return 0;
    3883                 :            : 
    3884                 :            :   /* We do not handle data dependencies yet.  */
    3885                 :        702 :   if (gfc_check_dependency (expr1, matrix_a, true)
    3886                 :        702 :       || gfc_check_dependency (expr1, matrix_b, true))
    3887                 :          0 :     return 0;
    3888                 :            : 
    3889                 :        702 :   m_case = none;
    3890                 :        702 :   if (matrix_a->rank == 2)
    3891                 :            :     {
    3892                 :        630 :       if (transpose_a)
    3893                 :            :         {
    3894                 :         59 :           if (matrix_b->rank == 2 && !transpose_b)
    3895                 :            :             m_case = A2TB2;
    3896                 :            :         }
    3897                 :            :       else
    3898                 :            :         {
    3899                 :        571 :           if (matrix_b->rank == 1)
    3900                 :            :             m_case = A2B1;
    3901                 :            :           else /* matrix_b->rank == 2 */
    3902                 :            :             {
    3903                 :        439 :               if (transpose_b)
    3904                 :            :                 m_case = A2B2T;
    3905                 :            :               else
    3906                 :        363 :                 m_case = A2B2;
    3907                 :            :             }
    3908                 :            :         }
    3909                 :            :     }
    3910                 :            :   else /* matrix_a->rank == 1 */
    3911                 :            :     {
    3912                 :         72 :       if (matrix_b->rank == 2)
    3913                 :            :         {
    3914                 :         72 :           if (!transpose_b)
    3915                 :            :             m_case = A1B2;
    3916                 :            :         }
    3917                 :            :     }
    3918                 :            : 
    3919                 :        363 :   if (m_case == none)
    3920                 :            :     return 0;
    3921                 :            : 
    3922                 :        697 :   ns = insert_block ();
    3923                 :            : 
    3924                 :            :   /* Assign the type of the zero expression for initializing the resulting
    3925                 :            :      array, and the expression (+ and * for real, integer and complex;
    3926                 :            :      .and. and .or for logical.  */
    3927                 :            : 
    3928                 :        697 :   switch(expr1->ts.type)
    3929                 :            :     {
    3930                 :        128 :     case BT_INTEGER:
    3931                 :        128 :       zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0);
    3932                 :        128 :       op_times = INTRINSIC_TIMES;
    3933                 :        128 :       op_plus = INTRINSIC_PLUS;
    3934                 :        128 :       break;
    3935                 :            : 
    3936                 :         15 :     case BT_LOGICAL:
    3937                 :         15 :       op_times = INTRINSIC_AND;
    3938                 :         15 :       op_plus = INTRINSIC_OR;
    3939                 :         15 :       zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where,
    3940                 :            :                                      0);
    3941                 :         15 :       break;
    3942                 :        481 :     case BT_REAL:
    3943                 :        481 :       zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind,
    3944                 :            :                                       &expr1->where);
    3945                 :        481 :       mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE);
    3946                 :        481 :       op_times = INTRINSIC_TIMES;
    3947                 :        481 :       op_plus = INTRINSIC_PLUS;
    3948                 :        481 :       break;
    3949                 :            : 
    3950                 :         73 :     case BT_COMPLEX:
    3951                 :         73 :       zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind,
    3952                 :            :                                       &expr1->where);
    3953                 :         73 :       mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE);
    3954                 :         73 :       op_times = INTRINSIC_TIMES;
    3955                 :         73 :       op_plus = INTRINSIC_PLUS;
    3956                 :            : 
    3957                 :         73 :       break;
    3958                 :            : 
    3959                 :          0 :     default:
    3960                 :          0 :       gcc_unreachable();
    3961                 :            :     }
    3962                 :            : 
    3963                 :        697 :   current_code = &ns->code;
    3964                 :            : 
    3965                 :            :   /* Freeze the references, keeping track of how many temporary variables were
    3966                 :            :      created.  */
    3967                 :        697 :   n_vars = 0;
    3968                 :        697 :   freeze_references (matrix_a);
    3969                 :        697 :   freeze_references (matrix_b);
    3970                 :        697 :   freeze_references (expr1);
    3971                 :            : 
    3972                 :        697 :   if (n_vars == 0)
    3973                 :        668 :     next_code_point = current_code;
    3974                 :            :   else
    3975                 :            :     {
    3976                 :            :       next_code_point = &ns->code;
    3977                 :        104 :       for (i=0; i<n_vars; i++)
    3978                 :         75 :         next_code_point = &(*next_code_point)->next;
    3979                 :            :     }
    3980                 :            : 
    3981                 :            :   /* Take care of the inline flag.  If the limit check evaluates to a
    3982                 :            :      constant, dead code elimination will eliminate the unneeded branch.  */
    3983                 :            : 
    3984                 :        697 :   if (flag_inline_matmul_limit > 0 && matrix_a->rank == 2
    3985                 :        630 :       && matrix_b->rank == 2)
    3986                 :            :     {
    3987                 :        498 :       if_limit = inline_limit_check (matrix_a, matrix_b,
    3988                 :            :                                      flag_inline_matmul_limit);
    3989                 :            : 
    3990                 :            :       /* Insert the original statement into the else branch.  */
    3991                 :        498 :       if_limit->block->block->next = co;
    3992                 :        498 :       co->next = NULL;
    3993                 :            : 
    3994                 :            :       /* ... and the new ones go into the original one.  */
    3995                 :        498 :       *next_code_point = if_limit;
    3996                 :        498 :       next_code_point = &if_limit->block->next;
    3997                 :            :     }
    3998                 :            : 
    3999                 :        697 :   zero_e->no_bounds_check = 1;
    4000                 :            : 
    4001                 :        697 :   assign_zero = XCNEW (gfc_code);
    4002                 :        697 :   assign_zero->op = EXEC_ASSIGN;
    4003                 :        697 :   assign_zero->loc = co->loc;
    4004                 :        697 :   assign_zero->expr1 = gfc_copy_expr (expr1);
    4005                 :        697 :   assign_zero->expr1->no_bounds_check = 1;
    4006                 :        697 :   assign_zero->expr2 = zero_e;
    4007                 :            : 
    4008                 :        697 :   realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
    4009                 :            : 
    4010                 :        697 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4011                 :            :     {
    4012                 :        130 :       gfc_code *test;
    4013                 :        130 :       gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
    4014                 :            : 
    4015                 :        130 :       switch (m_case)
    4016                 :            :         {
    4017                 :         23 :         case A2B1:
    4018                 :            : 
    4019                 :         23 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4020                 :         23 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4021                 :         23 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4022                 :         23 :           *next_code_point = test;
    4023                 :         23 :           next_code_point = &test->next;
    4024                 :            : 
    4025                 :         23 :           if (!realloc_c)
    4026                 :            :             {
    4027                 :         11 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4028                 :         11 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4029                 :         11 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4030                 :         11 :               *next_code_point = test;
    4031                 :         11 :               next_code_point = &test->next;
    4032                 :            :             }
    4033                 :            :           break;
    4034                 :            : 
    4035                 :         16 :         case A1B2:
    4036                 :            : 
    4037                 :         16 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4038                 :         16 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4039                 :         16 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4040                 :         16 :           *next_code_point = test;
    4041                 :         16 :           next_code_point = &test->next;
    4042                 :            : 
    4043                 :         16 :           if (!realloc_c)
    4044                 :            :             {
    4045                 :         11 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4046                 :         11 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4047                 :         11 :               test = runtime_error_ne (c1, b2, C_ERROR_1);
    4048                 :         11 :               *next_code_point = test;
    4049                 :         11 :               next_code_point = &test->next;
    4050                 :            :             }
    4051                 :            :           break;
    4052                 :            : 
    4053                 :         34 :         case A2B2:
    4054                 :            : 
    4055                 :         34 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4056                 :         34 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4057                 :         34 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4058                 :         34 :           *next_code_point = test;
    4059                 :         34 :           next_code_point = &test->next;
    4060                 :            : 
    4061                 :         34 :           if (!realloc_c)
    4062                 :            :             {
    4063                 :         27 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4064                 :         27 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4065                 :         27 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4066                 :         27 :               *next_code_point = test;
    4067                 :         27 :               next_code_point = &test->next;
    4068                 :            : 
    4069                 :         27 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4070                 :         27 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4071                 :         27 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4072                 :         27 :               *next_code_point = test;
    4073                 :         27 :               next_code_point = &test->next;
    4074                 :            :             }
    4075                 :            :           break;
    4076                 :            : 
    4077                 :         44 :         case A2B2T:
    4078                 :            : 
    4079                 :         44 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4080                 :         44 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4081                 :            :           /* matrix_b is transposed, hence dimension 1 for the error message.  */
    4082                 :         44 :           test = runtime_error_ne (b2, a2, B_ERROR_1);
    4083                 :         44 :           *next_code_point = test;
    4084                 :         44 :           next_code_point = &test->next;
    4085                 :            : 
    4086                 :         44 :           if (!realloc_c)
    4087                 :            :             {
    4088                 :         39 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4089                 :         39 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4090                 :         39 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4091                 :         39 :               *next_code_point = test;
    4092                 :         39 :               next_code_point = &test->next;
    4093                 :            : 
    4094                 :         39 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4095                 :         39 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4096                 :         39 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4097                 :         39 :               *next_code_point = test;
    4098                 :         39 :               next_code_point = &test->next;
    4099                 :            :             }
    4100                 :            :           break;
    4101                 :            : 
    4102                 :         13 :         case A2TB2:
    4103                 :            : 
    4104                 :         13 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4105                 :         13 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4106                 :         13 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4107                 :         13 :           *next_code_point = test;
    4108                 :         13 :           next_code_point = &test->next;
    4109                 :            : 
    4110                 :         13 :           if (!realloc_c)
    4111                 :            :             {
    4112                 :         12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4113                 :         12 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4114                 :         12 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4115                 :         12 :               *next_code_point = test;
    4116                 :         12 :               next_code_point = &test->next;
    4117                 :            : 
    4118                 :         12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4119                 :         12 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4120                 :         12 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4121                 :         12 :               *next_code_point = test;
    4122                 :         12 :               next_code_point = &test->next;
    4123                 :            :             }
    4124                 :            :           break;
    4125                 :            : 
    4126                 :            :         default:
    4127                 :            :           gcc_unreachable ();
    4128                 :            :         }
    4129                 :            :     }
    4130                 :            : 
    4131                 :            :   /* Handle the reallocation, if needed.  */
    4132                 :            : 
    4133                 :        697 :   if (realloc_c)
    4134                 :            :     {
    4135                 :        197 :       gfc_code *lhs_alloc;
    4136                 :            : 
    4137                 :        197 :       lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
    4138                 :            : 
    4139                 :        197 :       *next_code_point = lhs_alloc;
    4140                 :        197 :       next_code_point = &lhs_alloc->next;
    4141                 :            : 
    4142                 :            :     }
    4143                 :            : 
    4144                 :        697 :   *next_code_point = assign_zero;
    4145                 :            : 
    4146                 :        697 :   zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0);
    4147                 :            : 
    4148                 :        697 :   assign_matmul = XCNEW (gfc_code);
    4149                 :        697 :   assign_matmul->op = EXEC_ASSIGN;
    4150                 :        697 :   assign_matmul->loc = co->loc;
    4151                 :            : 
    4152                 :            :   /* Get the bounds for the loops, create them and create the scalarized
    4153                 :            :      expressions.  */
    4154                 :            : 
    4155                 :        697 :   switch (m_case)
    4156                 :            :     {
    4157                 :        363 :     case A2B2:
    4158                 :            : 
    4159                 :        363 :       u1 = get_size_m1 (matrix_b, 2);
    4160                 :        363 :       u2 = get_size_m1 (matrix_a, 2);
    4161                 :        363 :       u3 = get_size_m1 (matrix_a, 1);
    4162                 :            : 
    4163                 :        363 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4164                 :        363 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4165                 :        363 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4166                 :            : 
    4167                 :        363 :       do_1->block->next = do_2;
    4168                 :        363 :       do_2->block->next = do_3;
    4169                 :        363 :       do_3->block->next = assign_matmul;
    4170                 :            : 
    4171                 :        363 :       var_1 = do_1->ext.iterator->var;
    4172                 :        363 :       var_2 = do_2->ext.iterator->var;
    4173                 :        363 :       var_3 = do_3->ext.iterator->var;
    4174                 :            : 
    4175                 :        363 :       list[0] = var_3;
    4176                 :        363 :       list[1] = var_1;
    4177                 :        363 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4178                 :            : 
    4179                 :        363 :       list[0] = var_3;
    4180                 :        363 :       list[1] = var_2;
    4181                 :        363 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4182                 :            : 
    4183                 :        363 :       list[0] = var_2;
    4184                 :        363 :       list[1] = var_1;
    4185                 :        363 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4186                 :            : 
    4187                 :        363 :       break;
    4188                 :            : 
    4189                 :         76 :     case A2B2T:
    4190                 :            : 
    4191                 :         76 :       u1 = get_size_m1 (matrix_b, 1);
    4192                 :         76 :       u2 = get_size_m1 (matrix_a, 2);
    4193                 :         76 :       u3 = get_size_m1 (matrix_a, 1);
    4194                 :            : 
    4195                 :         76 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4196                 :         76 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4197                 :         76 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4198                 :            : 
    4199                 :         76 :       do_1->block->next = do_2;
    4200                 :         76 :       do_2->block->next = do_3;
    4201                 :         76 :       do_3->block->next = assign_matmul;
    4202                 :            : 
    4203                 :         76 :       var_1 = do_1->ext.iterator->var;
    4204                 :         76 :       var_2 = do_2->ext.iterator->var;
    4205                 :         76 :       var_3 = do_3->ext.iterator->var;
    4206                 :            : 
    4207                 :         76 :       list[0] = var_3;
    4208                 :         76 :       list[1] = var_1;
    4209                 :         76 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4210                 :            : 
    4211                 :         76 :       list[0] = var_3;
    4212                 :         76 :       list[1] = var_2;
    4213                 :         76 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4214                 :            : 
    4215                 :         76 :       list[0] = var_1;
    4216                 :         76 :       list[1] = var_2;
    4217                 :         76 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4218                 :            : 
    4219                 :         76 :       break;
    4220                 :            : 
    4221                 :         59 :     case A2TB2:
    4222                 :            : 
    4223                 :         59 :       u1 = get_size_m1 (matrix_a, 2);
    4224                 :         59 :       u2 = get_size_m1 (matrix_b, 2);
    4225                 :         59 :       u3 = get_size_m1 (matrix_a, 1);
    4226                 :            : 
    4227                 :         59 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4228                 :         59 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4229                 :         59 :       do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns);
    4230                 :            : 
    4231                 :         59 :       do_1->block->next = do_2;
    4232                 :         59 :       do_2->block->next = do_3;
    4233                 :         59 :       do_3->block->next = assign_matmul;
    4234                 :            : 
    4235                 :         59 :       var_1 = do_1->ext.iterator->var;
    4236                 :         59 :       var_2 = do_2->ext.iterator->var;
    4237                 :         59 :       var_3 = do_3->ext.iterator->var;
    4238                 :            : 
    4239                 :         59 :       list[0] = var_1;
    4240                 :         59 :       list[1] = var_2;
    4241                 :         59 :       cscalar = scalarized_expr (co->expr1, list, 2);
    4242                 :            : 
    4243                 :         59 :       list[0] = var_3;
    4244                 :         59 :       list[1] = var_1;
    4245                 :         59 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4246                 :            : 
    4247                 :         59 :       list[0] = var_3;
    4248                 :         59 :       list[1] = var_2;
    4249                 :         59 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4250                 :            : 
    4251                 :         59 :       break;
    4252                 :            : 
    4253                 :        132 :     case A2B1:
    4254                 :        132 :       u1 = get_size_m1 (matrix_b, 1);
    4255                 :        132 :       u2 = get_size_m1 (matrix_a, 1);
    4256                 :            : 
    4257                 :        132 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4258                 :        132 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4259                 :            : 
    4260                 :        132 :       do_1->block->next = do_2;
    4261                 :        132 :       do_2->block->next = assign_matmul;
    4262                 :            : 
    4263                 :        132 :       var_1 = do_1->ext.iterator->var;
    4264                 :        132 :       var_2 = do_2->ext.iterator->var;
    4265                 :            : 
    4266                 :        132 :       list[0] = var_2;
    4267                 :        132 :       cscalar = scalarized_expr (co->expr1, list, 1);
    4268                 :            : 
    4269                 :        132 :       list[0] = var_2;
    4270                 :        132 :       list[1] = var_1;
    4271                 :        132 :       ascalar = scalarized_expr (matrix_a, list, 2);
    4272                 :            : 
    4273                 :        132 :       list[0] = var_1;
    4274                 :        132 :       bscalar = scalarized_expr (matrix_b, list, 1);
    4275                 :            : 
    4276                 :        132 :       break;
    4277                 :            : 
    4278                 :         67 :     case A1B2:
    4279                 :         67 :       u1 = get_size_m1 (matrix_b, 2);
    4280                 :         67 :       u2 = get_size_m1 (matrix_a, 1);
    4281                 :            : 
    4282                 :         67 :       do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns);
    4283                 :         67 :       do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns);
    4284                 :            : 
    4285                 :         67 :       do_1->block->next = do_2;
    4286                 :         67 :       do_2->block->next = assign_matmul;
    4287                 :            : 
    4288                 :         67 :       var_1 = do_1->ext.iterator->var;
    4289                 :         67 :       var_2 = do_2->ext.iterator->var;
    4290                 :            : 
    4291                 :         67 :       list[0] = var_1;
    4292                 :         67 :       cscalar = scalarized_expr (co->expr1, list, 1);
    4293                 :            : 
    4294                 :         67 :       list[0] = var_2;
    4295                 :         67 :       ascalar = scalarized_expr (matrix_a, list, 1);
    4296                 :            : 
    4297                 :         67 :       list[0] = var_2;
    4298                 :         67 :       list[1] = var_1;
    4299                 :         67 :       bscalar = scalarized_expr (matrix_b, list, 2);
    4300                 :            : 
    4301                 :         67 :       break;
    4302                 :            : 
    4303                 :            :     default:
    4304                 :            :       gcc_unreachable();
    4305                 :            :     }
    4306                 :            : 
    4307                 :            :   /* Build the conjg call around the variables.  Set the typespec manually
    4308                 :            :      because gfc_build_intrinsic_call sometimes gets this wrong.  */
    4309                 :        697 :   if (conjg_a)
    4310                 :            :     {
    4311                 :         16 :       gfc_typespec ts;
    4312                 :         16 :       ts = matrix_a->ts;
    4313                 :         16 :       ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
    4314                 :            :                                           matrix_a->where, 1, ascalar);
    4315                 :         16 :       ascalar->ts = ts;
    4316                 :            :     }
    4317                 :            : 
    4318                 :        697 :   if (conjg_b)
    4319                 :            :     {
    4320                 :          7 :       gfc_typespec ts;
    4321                 :          7 :       ts = matrix_b->ts;
    4322                 :          7 :       bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg",
    4323                 :            :                                           matrix_b->where, 1, bscalar);
    4324                 :          7 :       bscalar->ts = ts;
    4325                 :            :     }
    4326                 :            :   /* First loop comes after the zero assignment.  */
    4327                 :        697 :   assign_zero->next = do_1;
    4328                 :            : 
    4329                 :            :   /* Build the assignment expression in the loop.  */
    4330                 :        697 :   assign_matmul->expr1 = gfc_copy_expr (cscalar);
    4331                 :            : 
    4332                 :        697 :   mult = get_operand (op_times, ascalar, bscalar);
    4333                 :        697 :   assign_matmul->expr2 = get_operand (op_plus, cscalar, mult);
    4334                 :            : 
    4335                 :            :   /* If we don't want to keep the original statement around in
    4336                 :            :      the else branch, we can free it.  */
    4337                 :            : 
    4338                 :        697 :   if (if_limit == NULL)
    4339                 :        199 :     gfc_free_statements(co);
    4340                 :            :   else
    4341                 :        498 :     co->next = NULL;
    4342                 :            : 
    4343                 :        697 :   gfc_free_expr (zero);
    4344                 :        697 :   *walk_subtrees = 0;
    4345                 :        697 :   return 0;
    4346                 :            : }
    4347                 :            : 
    4348                 :            : /* Change matmul function calls in the form of
    4349                 :            : 
    4350                 :            :    c = matmul(a,b)
    4351                 :            : 
    4352                 :            :    to the corresponding call to a BLAS routine, if applicable.  */
    4353                 :            : 
    4354                 :            : static int
    4355                 :       2802 : call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    4356                 :            :                     void *data ATTRIBUTE_UNUSED)
    4357                 :            : {
    4358                 :       2802 :   gfc_code *co, *co_next;
    4359                 :       2802 :   gfc_expr *expr1, *expr2;
    4360                 :       2802 :   gfc_expr *matrix_a, *matrix_b;
    4361                 :       2802 :   gfc_code *if_limit = NULL;
    4362                 :       2802 :   gfc_actual_arglist *a, *b;
    4363                 :       2802 :   bool conjg_a, conjg_b, transpose_a, transpose_b;
    4364                 :       2802 :   gfc_code *call;
    4365                 :       2802 :   const char *blas_name;
    4366                 :       2802 :   const char *transa, *transb;
    4367                 :       2802 :   gfc_expr *c1, *c2, *b1;
    4368                 :       2802 :   gfc_actual_arglist *actual, *next;
    4369                 :       2802 :   bt type;
    4370                 :       2802 :   int kind;
    4371                 :       2802 :   enum matrix_case m_case;
    4372                 :       2802 :   bool realloc_c;
    4373                 :       2802 :   gfc_code **next_code_point;
    4374                 :            : 
    4375                 :            :   /* Many of the tests for inline matmul also apply here.  */
    4376                 :            : 
    4377                 :       2802 :   co = *c;
    4378                 :            : 
    4379                 :       2802 :   if (co->op != EXEC_ASSIGN)
    4380                 :            :     return 0;
    4381                 :            : 
    4382                 :        908 :   if (in_where || in_assoc_list)
    4383                 :            :     return 0;
    4384                 :            : 
    4385                 :            :   /* The BLOCKS generated for the temporary variables and FORALL don't
    4386                 :            :      mix.  */
    4387                 :        908 :   if (forall_level > 0)
    4388                 :            :     return 0;
    4389                 :            : 
    4390                 :            :   /* For now don't do anything in OpenMP workshare, it confuses
    4391                 :            :      its translation, which expects only the allowed statements in there. */
    4392                 :            : 
    4393                 :        908 :   if (in_omp_workshare || in_omp_atomic)
    4394                 :            :     return 0;
    4395                 :            : 
    4396                 :        908 :   expr1 = co->expr1;
    4397                 :        908 :   expr2 = co->expr2;
    4398                 :        908 :   if (expr2->expr_type != EXPR_FUNCTION
    4399                 :        154 :       || expr2->value.function.isym == NULL
    4400                 :        106 :       || expr2->value.function.isym->id != GFC_ISYM_MATMUL)
    4401                 :            :     return 0;
    4402                 :            : 
    4403                 :         74 :   type = expr2->ts.type;
    4404                 :         74 :   kind = expr2->ts.kind;
    4405                 :            : 
    4406                 :            :   /* Guard against recursion. */
    4407                 :            : 
    4408                 :         74 :   if (expr2->external_blas)
    4409                 :            :     return 0;
    4410                 :            : 
    4411                 :         37 :   if (type != expr1->ts.type || kind != expr1->ts.kind)
    4412                 :            :     return 0;
    4413                 :            : 
    4414                 :         37 :   if (type == BT_REAL)
    4415                 :            :     {
    4416                 :         17 :       if (kind == 4)
    4417                 :            :         blas_name = "sgemm";
    4418                 :          7 :       else if (kind == 8)
    4419                 :            :         blas_name = "dgemm";
    4420                 :            :       else
    4421                 :            :         return 0;
    4422                 :            :     }
    4423                 :         20 :   else if (type == BT_COMPLEX)
    4424                 :            :     {
    4425                 :         20 :       if (kind == 4)
    4426                 :            :         blas_name = "cgemm";
    4427                 :         10 :       else if (kind == 8)
    4428                 :            :         blas_name = "zgemm";
    4429                 :            :       else
    4430                 :            :         return 0;
    4431                 :            :     }
    4432                 :            :   else
    4433                 :            :     return 0;
    4434                 :            : 
    4435                 :         37 :   a = expr2->value.function.actual;
    4436                 :         37 :   if (a->expr->rank != 2)
    4437                 :            :     return 0;
    4438                 :            : 
    4439                 :         37 :   b = a->next;
    4440                 :         37 :   if (b->expr->rank != 2)
    4441                 :            :     return 0;
    4442                 :            : 
    4443                 :         37 :   matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a);
    4444                 :         37 :   if (matrix_a == NULL)
    4445                 :            :     return 0;
    4446                 :            : 
    4447                 :         37 :   if (transpose_a)
    4448                 :            :     {
    4449                 :         13 :       if (conjg_a)
    4450                 :            :         transa = "C";
    4451                 :            :       else
    4452                 :          9 :         transa = "T";
    4453                 :            :     }
    4454                 :            :   else
    4455                 :            :     transa = "N";
    4456                 :            : 
    4457                 :         37 :   matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b);
    4458                 :         37 :   if (matrix_b == NULL)
    4459                 :            :     return 0;
    4460                 :            : 
    4461                 :         37 :   if (transpose_b)
    4462                 :            :     {
    4463                 :         12 :       if (conjg_b)
    4464                 :            :         transb = "C";
    4465                 :            :       else
    4466                 :          8 :         transb = "T";
    4467                 :            :     }
    4468                 :            :   else
    4469                 :            :     transb = "N";
    4470                 :            : 
    4471                 :         37 :   if (transpose_a)
    4472                 :            :     {
    4473                 :         13 :       if (transpose_b)
    4474                 :            :         m_case = A2TB2T;
    4475                 :            :       else
    4476                 :         13 :         m_case = A2TB2;
    4477                 :            :     }
    4478                 :            :   else
    4479                 :            :     {
    4480                 :         24 :       if (transpose_b)
    4481                 :            :         m_case = A2B2T;
    4482                 :            :       else
    4483                 :         12 :         m_case = A2B2;
    4484                 :            :     }
    4485                 :            : 
    4486                 :         37 :   current_code = c;
    4487                 :         37 :   inserted_block = NULL;
    4488                 :         37 :   changed_statement = NULL;
    4489                 :            : 
    4490                 :         37 :   expr2->external_blas = 1;
    4491                 :            : 
    4492                 :            :   /* We do not handle data dependencies yet.  */
    4493                 :         37 :   if (gfc_check_dependency (expr1, matrix_a, true)
    4494                 :         37 :       || gfc_check_dependency (expr1, matrix_b, true))
    4495                 :          0 :     return 0;
    4496                 :            : 
    4497                 :            :   /* Generate the if statement and hang it into the tree.  */
    4498                 :         37 :   if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit);
    4499                 :         37 :   co_next = co->next;
    4500                 :         37 :   (*current_code) = if_limit;
    4501                 :         37 :   co->next = NULL;
    4502                 :         37 :   if_limit->block->next = co;
    4503                 :            : 
    4504                 :         37 :   call = XCNEW (gfc_code);
    4505                 :         37 :   call->loc = co->loc;
    4506                 :            : 
    4507                 :            :   /* Bounds checking - a bit simpler than for inlining since we only
    4508                 :            :      have to take care of two-dimensional arrays here.  */
    4509                 :            : 
    4510                 :         37 :   realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1);
    4511                 :         37 :   next_code_point = &(if_limit->block->block->next);
    4512                 :            : 
    4513                 :         37 :   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    4514                 :            :     {
    4515                 :         35 :       gfc_code *test;
    4516                 :            :       //      gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
    4517                 :         35 :       gfc_expr *c1, *a1, *c2, *b2, *a2;
    4518                 :         35 :       switch (m_case)
    4519                 :            :         {
    4520                 :         10 :         case A2B2:
    4521                 :         10 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4522                 :         10 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4523                 :         10 :           test = runtime_error_ne (b1, a2, B_ERROR_1);
    4524                 :         10 :           *next_code_point = test;
    4525                 :         10 :           next_code_point = &test->next;
    4526                 :            : 
    4527                 :         10 :           if (!realloc_c)
    4528                 :            :             {
    4529                 :          5 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4530                 :          5 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4531                 :          5 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4532                 :          5 :               *next_code_point = test;
    4533                 :          5 :               next_code_point = &test->next;
    4534                 :            : 
    4535                 :          5 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4536                 :          5 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4537                 :          5 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4538                 :          5 :               *next_code_point = test;
    4539                 :          5 :               next_code_point = &test->next;
    4540                 :            :             }
    4541                 :            :           break;
    4542                 :            : 
    4543                 :         12 :         case A2B2T:
    4544                 :            : 
    4545                 :         12 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4546                 :         12 :           a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4547                 :            :           /* matrix_b is transposed, hence dimension 1 for the error message.  */
    4548                 :         12 :           test = runtime_error_ne (b2, a2, B_ERROR_1);
    4549                 :         12 :           *next_code_point = test;
    4550                 :         12 :           next_code_point = &test->next;
    4551                 :            : 
    4552                 :         12 :           if (!realloc_c)
    4553                 :            :             {
    4554                 :         12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4555                 :         12 :               a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4556                 :         12 :               test = runtime_error_ne (c1, a1, C_ERROR_1);
    4557                 :         12 :               *next_code_point = test;
    4558                 :         12 :               next_code_point = &test->next;
    4559                 :            : 
    4560                 :         12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4561                 :         12 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4562                 :         12 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4563                 :         12 :               *next_code_point = test;
    4564                 :         12 :               next_code_point = &test->next;
    4565                 :            :             }
    4566                 :            :           break;
    4567                 :            : 
    4568                 :         13 :         case A2TB2:
    4569                 :            : 
    4570                 :         13 :           b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4571                 :         13 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4572                 :         13 :           test = runtime_error_ne (b1, a1, B_ERROR_1);
    4573                 :         13 :           *next_code_point = test;
    4574                 :         13 :           next_code_point = &test->next;
    4575                 :            : 
    4576                 :         13 :           if (!realloc_c)
    4577                 :            :             {
    4578                 :         12 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4579                 :         12 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4580                 :         12 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4581                 :         12 :               *next_code_point = test;
    4582                 :         12 :               next_code_point = &test->next;
    4583                 :            : 
    4584                 :         12 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4585                 :         12 :               b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4586                 :         12 :               test = runtime_error_ne (c2, b2, C_ERROR_2);
    4587                 :         12 :               *next_code_point = test;
    4588                 :         12 :               next_code_point = &test->next;
    4589                 :            :             }
    4590                 :            :           break;
    4591                 :            : 
    4592                 :          0 :         case A2TB2T:
    4593                 :          0 :           b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2);
    4594                 :          0 :           a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1);
    4595                 :          0 :           test = runtime_error_ne (b2, a1, B_ERROR_1);
    4596                 :          0 :           *next_code_point = test;
    4597                 :          0 :           next_code_point = &test->next;
    4598                 :            : 
    4599                 :          0 :           if (!realloc_c)
    4600                 :            :             {
    4601                 :          0 :               c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1);
    4602                 :          0 :               a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2);
    4603                 :          0 :               test = runtime_error_ne (c1, a2, C_ERROR_1);
    4604                 :          0 :               *next_code_point = test;
    4605                 :          0 :               next_code_point = &test->next;
    4606                 :            : 
    4607                 :          0 :               c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2);
    4608                 :          0 :               b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1);
    4609                 :          0 :               test = runtime_error_ne (c2, b1, C_ERROR_2);
    4610                 :          0 :               *next_code_point = test;
    4611                 :          0 :               next_code_point = &test->next;
    4612                 :            :             }
    4613                 :            :           break;
    4614                 :            : 
    4615                 :          0 :         default:
    4616                 :          0 :           gcc_unreachable ();
    4617                 :            :         }
    4618                 :            :     }
    4619                 :            : 
    4620                 :            :   /* Handle the reallocation, if needed.  */
    4621                 :            : 
    4622                 :         37 :   if (realloc_c)
    4623                 :            :     {
    4624                 :          6 :       gfc_code *lhs_alloc;
    4625                 :            : 
    4626                 :          6 :       lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case);
    4627                 :          6 :       *next_code_point = lhs_alloc;
    4628                 :          6 :       next_code_point = &lhs_alloc->next;
    4629                 :            :     }
    4630                 :            : 
    4631                 :         37 :   *next_code_point = call;
    4632                 :         37 :   if_limit->next = co_next;
    4633                 :            : 
    4634                 :            :   /* Set up the BLAS call.  */
    4635                 :            : 
    4636                 :         37 :   call->op = EXEC_CALL;
    4637                 :            : 
    4638                 :         37 :   gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true);
    4639                 :         37 :   call->symtree->n.sym->attr.subroutine = 1;
    4640                 :         37 :   call->symtree->n.sym->attr.procedure = 1;
    4641                 :         37 :   call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
    4642                 :         37 :   call->resolved_sym = call->symtree->n.sym;
    4643                 :         37 :   gfc_commit_symbol (call->resolved_sym);
    4644                 :            : 
    4645                 :            :   /* Argument TRANSA.  */
    4646                 :         37 :   next = gfc_get_actual_arglist ();
    4647                 :         37 :   next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
    4648                 :            :                                        transa, 1);
    4649                 :            : 
    4650                 :         37 :   call->ext.actual = next;
    4651                 :            : 
    4652                 :            :   /* Argument TRANSB.  */
    4653                 :         37 :   actual = next;
    4654                 :         37 :   next = gfc_get_actual_arglist ();
    4655                 :         37 :   next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc,
    4656                 :            :                                        transb, 1);
    4657                 :         37 :   actual->next = next;
    4658                 :            : 
    4659                 :         37 :   c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1,
    4660                 :            :                                gfc_integer_4_kind);
    4661                 :         37 :   c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2,
    4662                 :            :                                gfc_integer_4_kind);
    4663                 :            : 
    4664                 :         37 :   b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1,
    4665                 :            :                                gfc_integer_4_kind);
    4666                 :            : 
    4667                 :            :   /* Argument M. */
    4668                 :         37 :   actual = next;
    4669                 :         37 :   next = gfc_get_actual_arglist ();
    4670                 :         37 :   next->expr = c1;
    4671                 :         37 :   actual->next = next;
    4672                 :            : 
    4673                 :            :   /* Argument N. */
    4674                 :         37 :   actual = next;
    4675                 :         37 :   next = gfc_get_actual_arglist ();
    4676                 :         37 :   next->expr = c2;
    4677                 :         37 :   actual->next = next;
    4678                 :            : 
    4679                 :            :   /* Argument K.  */
    4680                 :         37 :   actual = next;
    4681                 :         37 :   next = gfc_get_actual_arglist ();
    4682                 :         37 :   next->expr = b1;
    4683                 :         37 :   actual->next = next;
    4684                 :            : 
    4685                 :            :   /* Argument ALPHA - set to one.  */
    4686                 :         37 :   actual = next;
    4687                 :         37 :   next = gfc_get_actual_arglist ();
    4688                 :         37 :   next->expr = gfc_get_constant_expr (type, kind, &co->loc);
    4689                 :         37 :   if (type == BT_REAL)
    4690                 :         17 :     mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE);
    4691                 :            :   else
    4692                 :         20 :     mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE);
    4693                 :         37 :   actual->next = next;
    4694                 :            : 
    4695                 :            :   /* Argument A.  */
    4696                 :         37 :   actual = next;
    4697                 :         37 :   next = gfc_get_actual_arglist ();
    4698                 :         37 :   next->expr = gfc_copy_expr (matrix_a);
    4699                 :         37 :   actual->next = next;
    4700                 :            : 
    4701                 :            :   /* Argument LDA.  */
    4702                 :         37 :   actual = next;
    4703                 :         37 :   next = gfc_get_actual_arglist ();
    4704                 :         37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a),
    4705                 :            :                                        1, gfc_integer_4_kind);
    4706                 :         37 :   actual->next = next;
    4707                 :            : 
    4708                 :            :   /* Argument B.  */
    4709                 :         37 :   actual = next;
    4710                 :         37 :   next = gfc_get_actual_arglist ();
    4711                 :         37 :   next->expr = gfc_copy_expr (matrix_b);
    4712                 :         37 :   actual->next = next;
    4713                 :            : 
    4714                 :            :   /* Argument LDB.  */
    4715                 :         37 :   actual = next;
    4716                 :         37 :   next = gfc_get_actual_arglist ();
    4717                 :         37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b),
    4718                 :            :                                        1, gfc_integer_4_kind);
    4719                 :         37 :   actual->next = next;
    4720                 :            : 
    4721                 :            :   /* Argument BETA - set to zero.  */
    4722                 :         37 :   actual = next;
    4723                 :         37 :   next = gfc_get_actual_arglist ();
    4724                 :         37 :   next->expr = gfc_get_constant_expr (type, kind, &co->loc);
    4725                 :         37 :   if (type == BT_REAL)
    4726                 :         17 :     mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE);
    4727                 :            :   else
    4728                 :         20 :     mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE);
    4729                 :         37 :   actual->next = next;
    4730                 :            : 
    4731                 :            :   /* Argument C.  */
    4732                 :            : 
    4733                 :         37 :   actual = next;
    4734                 :         37 :   next = gfc_get_actual_arglist ();
    4735                 :         37 :   next->expr = gfc_copy_expr (expr1);
    4736                 :         37 :   actual->next = next;
    4737                 :            : 
    4738                 :            :   /* Argument LDC.  */
    4739                 :         37 :   actual = next;
    4740                 :         37 :   next = gfc_get_actual_arglist ();
    4741                 :         37 :   next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1),
    4742                 :            :                                        1, gfc_integer_4_kind);
    4743                 :         37 :   actual->next = next;
    4744                 :            : 
    4745                 :         37 :   return 0;
    4746                 :            : }
    4747                 :            : 
    4748                 :            : 
    4749                 :            : /* Code for index interchange for loops which are grouped together in DO
    4750                 :            :    CONCURRENT or FORALL statements.  This is currently only applied if the
    4751                 :            :    iterations are grouped together in a single statement.
    4752                 :            : 
    4753                 :            :    For this transformation, it is assumed that memory access in strides is
    4754                 :            :    expensive, and that loops which access later indices (which access memory
    4755                 :            :    in bigger strides) should be moved to the first loops.
    4756                 :            : 
    4757                 :            :    For this, a loop over all the statements is executed, counting the times
    4758                 :            :    that the loop iteration values are accessed in each index.  The loop
    4759                 :            :    indices are then sorted to minimize access to later indices from inner
    4760                 :            :    loops.  */
    4761                 :            : 
    4762                 :            : /* Type for holding index information.  */
    4763                 :            : 
    4764                 :            : typedef struct {
    4765                 :            :   gfc_symbol *sym;
    4766                 :            :   gfc_forall_iterator *fa;
    4767                 :            :   int num;
    4768                 :            :   int n[GFC_MAX_DIMENSIONS];
    4769                 :            : } ind_type;
    4770                 :            : 
    4771                 :            : /* Callback function to determine if an expression is the
    4772                 :            :    corresponding variable.  */
    4773                 :            : 
    4774                 :            : static int
    4775                 :     294070 : has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
    4776                 :            : {
    4777                 :     294070 :   gfc_expr *expr = *e;
    4778                 :     294070 :   gfc_symbol *sym;
    4779                 :            : 
    4780                 :     294070 :   if (expr->expr_type != EXPR_VARIABLE)
    4781                 :            :     return 0;
    4782                 :            : 
    4783                 :     225198 :   sym = (gfc_symbol *) data;
    4784                 :     225198 :   return sym == expr->symtree->n.sym;
    4785                 :            : }
    4786                 :            : 
    4787                 :            : /* Callback function to calculate the cost of a certain index.  */
    4788                 :            : 
    4789                 :            : static int
    4790                 :    1119880 : index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
    4791                 :            :             void *data)
    4792                 :            : {
    4793                 :    1119880 :   ind_type *ind;
    4794                 :    1119880 :   gfc_expr *expr;
    4795                 :    1119880 :   gfc_array_ref *ar;
    4796                 :    1119880 :   gfc_ref *ref;
    4797                 :    1119880 :   int i,j;
    4798                 :            : 
    4799                 :    1119880 :   expr = *e;
    4800                 :    1119880 :   if (expr->expr_type != EXPR_VARIABLE)
    4801                 :            :     return 0;
    4802                 :            : 
    4803                 :     474849 :   ar = NULL;
    4804                 :     501639 :   for (ref = expr->ref; ref; ref = ref->next)
    4805                 :            :     {
    4806                 :      86684 :       if (ref->type == REF_ARRAY)
    4807                 :            :         {
    4808                 :      59894 :           ar = &ref->u.ar;
    4809                 :      59894 :           break;
    4810                 :            :         }
    4811                 :            :     }
    4812                 :     474849 :   if (ar == NULL || ar->type != AR_ELEMENT)
    4813                 :            :     return 0;
    4814                 :            : 
    4815                 :     128469 :   ind = (ind_type *) data;
    4816                 :     128469 :   for (i = 0; i < ar->dimen; i++)
    4817                 :            :     {
    4818                 :     324518 :       for (j=0; ind[j].sym != NULL; j++)
    4819                 :            :         {
    4820                 :     232810 :           if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym)))
    4821                 :      75761 :               ind[j].n[i]++;
    4822                 :            :         }
    4823                 :            :     }
    4824                 :            :   return 0;
    4825                 :            : }
    4826                 :            : 
    4827                 :            : /* Callback function for qsort, to sort the loop indices. */
    4828                 :            : 
    4829                 :            : static int
    4830                 :      13565 : loop_comp (const void *e1, const void *e2)
    4831                 :            : {
    4832                 :      13565 :   const ind_type *i1 = (const ind_type *) e1;
    4833                 :      13565 :   const ind_type *i2 = (const ind_type *) e2;
    4834                 :      13565 :   int i;
    4835                 :            : 
    4836                 :     180570 :   for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--)
    4837                 :            :     {
    4838                 :     180030 :       if (i1->n[i] != i2->n[i])
    4839                 :      13025 :         return i1->n[i] - i2->n[i];
    4840                 :            :     }
    4841                 :            :   /* All other things being equal, let's not change the ordering.  */
    4842                 :        540 :   return i2->num - i1->num;
    4843                 :            : }
    4844                 :            : 
    4845                 :            : /* Main function to do the index interchange.  */
    4846                 :            : 
    4847                 :            : static int
    4848                 :     614833 : index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    4849                 :            :                   void *data ATTRIBUTE_UNUSED)
    4850                 :            : {
    4851                 :     614833 :   gfc_code *co;
    4852                 :     614833 :   co = *c;
    4853                 :     614833 :   int n_iter;
    4854                 :     614833 :   gfc_forall_iterator *fa;
    4855                 :     614833 :   ind_type *ind;
    4856                 :     614833 :   int i, j;
    4857                 :            : 
    4858                 :     614833 :   if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
    4859                 :            :     return 0;
    4860                 :            : 
    4861                 :       2312 :   n_iter = 0;
    4862                 :       7206 :   for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    4863                 :       4894 :     n_iter ++;
    4864                 :            : 
    4865                 :            :   /* Nothing to reorder. */
    4866                 :       2312 :   if (n_iter < 2)
    4867                 :            :     return 0;
    4868                 :            : 
    4869                 :       1679 :   ind = XALLOCAVEC (ind_type, n_iter + 1);
    4870                 :            : 
    4871                 :       1679 :   i = 0;
    4872                 :       5940 :   for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    4873                 :            :     {
    4874                 :       4261 :       ind[i].sym = fa->var->symtree->n.sym;
    4875                 :       4261 :       ind[i].fa = fa;
    4876                 :      68176 :       for (j=0; j<GFC_MAX_DIMENSIONS; j++)
    4877                 :      63915 :         ind[i].n[j] = 0;
    4878                 :       4261 :       ind[i].num = i;
    4879                 :       4261 :       i++;
    4880                 :            :     }
    4881                 :       1679 :   ind[n_iter].sym = NULL;
    4882                 :       1679 :   ind[n_iter].fa = NULL;
    4883                 :            : 
    4884                 :       1679 :   gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind);
    4885                 :       1679 :   qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp);
    4886                 :            : 
    4887                 :            :   /* Do the actual index interchange.  */
    4888                 :       1679 :   co->ext.forall_iterator = fa = ind[0].fa;
    4889                 :       4261 :   for (i=1; i<n_iter; i++)
    4890                 :            :     {
    4891                 :       2582 :       fa->next = ind[i].fa;
    4892                 :       2582 :       fa = fa->next;
    4893                 :            :     }
    4894                 :       1679 :   fa->next = NULL;
    4895                 :            : 
    4896                 :       1679 :   if (flag_warn_frontend_loop_interchange)
    4897                 :            :     {
    4898                 :          1 :       for (i=1; i<n_iter; i++)
    4899                 :            :         {
    4900                 :          1 :           if (ind[i-1].num > ind[i].num)
    4901                 :            :             {
    4902                 :          1 :               gfc_warning (OPT_Wfrontend_loop_interchange,
    4903                 :            :                            "Interchanging loops at %L", &co->loc);
    4904                 :          1 :               break;
    4905                 :            :             }
    4906                 :            :         }
    4907                 :            :     }
    4908                 :            : 
    4909                 :            :   return 0;
    4910                 :            : }
    4911                 :            : 
    4912                 :            : #define WALK_SUBEXPR(NODE) \
    4913                 :            :   do                                                    \
    4914                 :            :     {                                                   \
    4915                 :            :       result = gfc_expr_walker (&(NODE), exprfn, data);     \
    4916                 :            :       if (result)                                       \
    4917                 :            :         return result;                                  \
    4918                 :            :     }                                                   \
    4919                 :            :   while (0)
    4920                 :            : #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
    4921                 :            : 
    4922                 :            : /* Walk expression *E, calling EXPRFN on each expression in it.  */
    4923                 :            : 
    4924                 :            : int
    4925                 :   64346800 : gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
    4926                 :            : {
    4927                 :   66459600 :   while (*e)
    4928                 :            :     {
    4929                 :   21859100 :       int walk_subtrees = 1;
    4930                 :   21859100 :       gfc_actual_arglist *a;
    4931                 :   21859100 :       gfc_ref *r;
    4932                 :   21859100 :       gfc_constructor *c;
    4933                 :            : 
    4934                 :   21859100 :       int result = exprfn (e, &walk_subtrees, data);
    4935                 :   21859100 :       if (result)
    4936                 :   19746300 :         return result;
    4937                 :   21783100 :       if (walk_subtrees)
    4938                 :   14956300 :         switch ((*e)->expr_type)
    4939                 :            :           {
    4940                 :    2125380 :           case EXPR_OP:
    4941                 :    2125380 :             WALK_SUBEXPR ((*e)->value.op.op1);
    4942                 :    2112760 :             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
    4943                 :            :             break;
    4944                 :    1195710 :           case EXPR_FUNCTION:
    4945                 :    3401880 :             for (a = (*e)->value.function.actual; a; a = a->next)
    4946                 :    2206280 :               WALK_SUBEXPR (a->expr);
    4947                 :            :             break;
    4948                 :         63 :           case EXPR_COMPCALL:
    4949                 :         63 :           case EXPR_PPC:
    4950                 :         63 :             WALK_SUBEXPR ((*e)->value.compcall.base_object);
    4951                 :         75 :             for (a = (*e)->value.compcall.actual; a; a = a->next)
    4952                 :         12 :               WALK_SUBEXPR (a->expr);
    4953                 :            :             break;
    4954                 :            : 
    4955                 :     233933 :           case EXPR_STRUCTURE:
    4956                 :     233933 :           case EXPR_ARRAY:
    4957                 :    1175240 :             for (c = gfc_constructor_first ((*e)->value.constructor); c;
    4958                 :     941310 :                  c = gfc_constructor_next (c))
    4959                 :            :               {
    4960                 :     941310 :                 if (c->iterator == NULL)
    4961                 :     935597 :                   WALK_SUBEXPR (c->expr);
    4962                 :            :                 else
    4963                 :            :                   {
    4964                 :       5713 :                     iterator_level ++;
    4965                 :       5713 :                     WALK_SUBEXPR (c->expr);
    4966                 :       5713 :                     iterator_level --;
    4967                 :       5713 :                     WALK_SUBEXPR (c->iterator->var);
    4968                 :       5713 :                     WALK_SUBEXPR (c->iterator->start);
    4969                 :       5713 :                     WALK_SUBEXPR (c->iterator->end);
    4970                 :       5713 :                     WALK_SUBEXPR (c->iterator->step);
    4971                 :            :                   }
    4972                 :            :               }
    4973                 :            : 
    4974                 :     233933 :             if ((*e)->expr_type != EXPR_ARRAY)
    4975                 :            :               break;
    4976                 :            : 
    4977                 :            :             /* Fall through to the variable case in order to walk the
    4978                 :            :                reference.  */
    4979                 :    5691850 :             gcc_fallthrough ();
    4980                 :            : 
    4981                 :    5691850 :           case EXPR_SUBSTRING:
    4982                 :    5691850 :           case EXPR_VARIABLE:
    4983                 :    7763830 :             for (r = (*e)->ref; r; r = r->next)
    4984                 :            :               {
    4985                 :    2072000 :                 gfc_array_ref *ar;
    4986                 :    2072000 :                 int i;
    4987                 :            : 
    4988                 :    2072000 :                 switch (r->type)
    4989                 :            :                   {
    4990                 :    1658080 :                   case REF_ARRAY:
    4991                 :    1658080 :                     ar = &r->u.ar;
    4992                 :    1658080 :                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
    4993                 :            :                       {
    4994                 :    1804600 :                         for (i=0; i< ar->dimen; i++)
    4995                 :            :                           {
    4996                 :    1028720 :                             WALK_SUBEXPR (ar->start[i]);
    4997                 :    1028700 :                             WALK_SUBEXPR (ar->end[i]);
    4998                 :    1028700 :                             WALK_SUBEXPR (ar->stride[i]);
    4999                 :            :                           }
    5000                 :            :                       }
    5001                 :            : 
    5002                 :            :                     break;
    5003                 :            : 
    5004                 :      68826 :                   case REF_SUBSTRING:
    5005                 :      68826 :                     WALK_SUBEXPR (r->u.ss.start);
    5006                 :      68826 :                     WALK_SUBEXPR (r->u.ss.end);
    5007                 :            :                     break;
    5008                 :            : 
    5009                 :            :                   case REF_COMPONENT:
    5010                 :            :                   case REF_INQUIRY:
    5011                 :            :                     break;
    5012                 :            :                   }
    5013                 :            :               }
    5014                 :            : 
    5015                 :            :           default:
    5016                 :    2112760 :             break;
    5017                 :            :           }
    5018                 :            :       return 0;
    5019                 :            :     }
    5020                 :            :   return 0;
    5021                 :            : }
    5022                 :            : 
    5023                 :            : #define WALK_SUBCODE(NODE) \
    5024                 :            :   do                                                            \
    5025                 :            :     {                                                           \
    5026                 :            :       result = gfc_code_walker (&(NODE), codefn, exprfn, data);     \
    5027                 :            :       if (result)                                               \
    5028                 :            :         return result;                                          \
    5029                 :            :     }                                                           \
    5030                 :            :   while (0)
    5031                 :            : 
    5032                 :            : /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
    5033                 :            :    on each expression in it.  If any of the hooks returns non-zero, that
    5034                 :            :    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
    5035                 :            :    no subcodes or subexpressions are traversed.  */
    5036                 :            : 
    5037                 :            : int
    5038                 :    4810570 : gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
    5039                 :            :                  void *data)
    5040                 :            : {
    5041                 :   13900200 :   for (; *c; c = &(*c)->next)
    5042                 :            :     {
    5043                 :    9089670 :       int walk_subtrees = 1;
    5044                 :    9089670 :       int result = codefn (c, &walk_subtrees, data);
    5045                 :    9089670 :       if (result)
    5046                 :          0 :         return result;
    5047                 :            : 
    5048                 :    9089670 :       if (walk_subtrees)
    5049                 :            :         {
    5050                 :    9067490 :           gfc_code *b;
    5051                 :    9067490 :           gfc_actual_arglist *a;
    5052                 :    9067490 :           gfc_code *co;
    5053                 :    9067490 :           gfc_association_list *alist;
    5054                 :    9067490 :           bool saved_in_omp_workshare;
    5055                 :    9067490 :           bool saved_in_omp_atomic;
    5056                 :    9067490 :           bool saved_in_where;
    5057                 :            : 
    5058                 :            :           /* There might be statement insertions before the current code,
    5059                 :            :              which must not affect the expression walker.  */
    5060                 :            : 
    5061                 :    9067490 :           co = *c;
    5062                 :    9067490 :           saved_in_omp_workshare = in_omp_workshare;
    5063                 :    9067490 :           saved_in_omp_atomic = in_omp_atomic;
    5064                 :    9067490 :           saved_in_where = in_where;
    5065                 :            : 
    5066                 :    9067490 :           switch (co->op)
    5067                 :            :             {
    5068                 :            : 
    5069                 :      68604 :             case EXEC_BLOCK:
    5070                 :      68604 :               WALK_SUBCODE (co->ext.block.ns->code);
    5071                 :      68604 :               if (co->ext.block.assoc)
    5072                 :            :                 {
    5073                 :      38458 :                   bool saved_in_assoc_list = in_assoc_list;
    5074                 :            : 
    5075                 :      38458 :                   in_assoc_list = true;
    5076                 :      78305 :                   for (alist = co->ext.block.assoc; alist; alist = alist->next)
    5077                 :      39847 :                     WALK_SUBEXPR (alist->target);
    5078                 :            : 
    5079                 :      38458 :                   in_assoc_list = saved_in_assoc_list;
    5080                 :            :                 }
    5081                 :            : 
    5082                 :            :               break;
    5083                 :            : 
    5084                 :     370230 :             case EXEC_DO:
    5085                 :     370230 :               doloop_level ++;
    5086                 :     370230 :               WALK_SUBEXPR (co->ext.iterator->var);
    5087                 :     370230 :               WALK_SUBEXPR (co->ext.iterator->start);
    5088                 :     370230 :               WALK_SUBEXPR (co->ext.iterator->end);
    5089                 :     370230 :               WALK_SUBEXPR (co->ext.iterator->step);
    5090                 :            :               break;
    5091                 :            : 
    5092                 :    1810980 :             case EXEC_IF:
    5093                 :    1810980 :               if_level ++;
    5094                 :    1810980 :               break;
    5095                 :            : 
    5096                 :       5468 :             case EXEC_WHERE:
    5097                 :       5468 :               in_where = true;
    5098                 :       5468 :               break;
    5099                 :            : 
    5100                 :     676868 :             case EXEC_CALL:
    5101                 :     676868 :             case EXEC_ASSIGN_CALL:
    5102                 :    2239100 :               for (a = co->ext.actual; a; a = a->next)
    5103                 :    1562230 :                 WALK_SUBEXPR (a->expr);
    5104                 :            :               break;
    5105                 :            : 
    5106                 :       1415 :             case EXEC_CALL_PPC:
    5107                 :       1415 :               WALK_SUBEXPR (co->expr1);
    5108                 :       3410 :               for (a = co->ext.actual; a; a = a->next)
    5109                 :       1995 :                 WALK_SUBEXPR (a->expr);
    5110                 :            :               break;
    5111                 :            : 
    5112                 :      10029 :             case EXEC_SELECT:
    5113                 :      10029 :               WALK_SUBEXPR (co->expr1);
    5114                 :      10029 :               select_level ++;
    5115                 :      34469 :               for (b = co->block; b; b = b->block)
    5116                 :            :                 {
    5117                 :      24440 :                   gfc_case *cp;
    5118                 :      51428 :                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
    5119                 :            :                     {
    5120                 :      26988 :                       WALK_SUBEXPR (cp->low);
    5121                 :      26988 :                       WALK_SUBEXPR (cp->high);
    5122                 :            :                     }
    5123                 :      24440 :                   WALK_SUBCODE (b->next);
    5124                 :            :                 }
    5125                 :      10029 :               continue;
    5126                 :            : 
    5127                 :     188145 :             case EXEC_ALLOCATE:
    5128                 :     188145 :             case EXEC_DEALLOCATE:
    5129                 :     188145 :               {
    5130                 :     188145 :                 gfc_alloc *a;
    5131                 :     413365 :                 for (a = co->ext.alloc.list; a; a = a->next)
    5132                 :     225220 :                   WALK_SUBEXPR (a->expr);
    5133                 :            :                 break;
    5134                 :            :               }
    5135                 :            : 
    5136                 :      46562 :             case EXEC_FORALL:
    5137                 :      46562 :             case EXEC_DO_CONCURRENT:
    5138                 :      46562 :               {
    5139                 :      46562 :                 gfc_forall_iterator *fa;
    5140                 :     149947 :                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
    5141                 :            :                   {
    5142                 :     103385 :                     WALK_SUBEXPR (fa->var);
    5143                 :     103385 :                     WALK_SUBEXPR (fa->start);
    5144                 :     103385 :                     WALK_SUBEXPR (fa->end);
    5145                 :     103385 :                     WALK_SUBEXPR (fa->stride);
    5146                 :            :                   }
    5147                 :      46562 :                 if (co->op == EXEC_FORALL)
    5148                 :      45815 :                   forall_level ++;
    5149                 :            :                 break;
    5150                 :            :               }
    5151                 :            : 
    5152                 :      41514 :             case EXEC_OPEN:
    5153                 :      41514 :               WALK_SUBEXPR (co->ext.open->unit);
    5154                 :      41514 :               WALK_SUBEXPR (co->ext.open->file);
    5155                 :      41514 :               WALK_SUBEXPR (co->ext.open->status);
    5156                 :      41514 :               WALK_SUBEXPR (co->ext.open->access);
    5157                 :      41514 :               WALK_SUBEXPR (co->ext.open->form);
    5158                 :      41514 :               WALK_SUBEXPR (co->ext.open->recl);
    5159                 :      41514 :               WALK_SUBEXPR (co->ext.open->blank);
    5160                 :      41514 :               WALK_SUBEXPR (co->ext.open->position);
    5161                 :      41514 :               WALK_SUBEXPR (co->ext.open->action);
    5162                 :      41514 :               WALK_SUBEXPR (co->ext.open->delim);
    5163                 :      41514 :               WALK_SUBEXPR (co->ext.open->pad);
    5164                 :      41514 :               WALK_SUBEXPR (co->ext.open->iostat);
    5165                 :      41514 :               WALK_SUBEXPR (co->ext.open->iomsg);
    5166                 :      41514 :               WALK_SUBEXPR (co->ext.open->convert);
    5167                 :      41514 :               WALK_SUBEXPR (co->ext.open->decimal);
    5168                 :      41514 :               WALK_SUBEXPR (co->ext.open->encoding);
    5169                 :      41514 :               WALK_SUBEXPR (co->ext.open->round);
    5170                 :      41514 :               WALK_SUBEXPR (co->ext.open->sign);
    5171                 :      41514 :               WALK_SUBEXPR (co->ext.open->asynchronous);
    5172                 :      41514 :               WALK_SUBEXPR (co->ext.open->id);
    5173                 :      41514 :               WALK_SUBEXPR (co->ext.open->newunit);
    5174                 :      41514 :               WALK_SUBEXPR (co->ext.open->share);
    5175                 :      41514 :               WALK_SUBEXPR (co->ext.open->cc);
    5176                 :            :               break;
    5177                 :            : 
    5178                 :      35392 :             case EXEC_CLOSE:
    5179                 :      35392 :               WALK_SUBEXPR (co->ext.close->unit);
    5180                 :      35392 :               WALK_SUBEXPR (co->ext.close->status);
    5181                 :      35392 :               WALK_SUBEXPR (co->ext.close->iostat);
    5182                 :      35392 :               WALK_SUBEXPR (co->ext.close->iomsg);
    5183                 :            :               break;
    5184                 :            : 
    5185                 :      30428 :             case EXEC_BACKSPACE:
    5186                 :      30428 :             case EXEC_ENDFILE:
    5187                 :      30428 :             case EXEC_REWIND:
    5188                 :      30428 :             case EXEC_FLUSH:
    5189                 :      30428 :               WALK_SUBEXPR (co->ext.filepos->unit);
    5190                 :      30428 :               WALK_SUBEXPR (co->ext.filepos->iostat);
    5191                 :      30428 :               WALK_SUBEXPR (co->ext.filepos->iomsg);
    5192                 :            :               break;
    5193                 :            : 
    5194                 :       9503 :             case EXEC_INQUIRE:
    5195                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->unit);
    5196                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->file);
    5197                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->iomsg);
    5198                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->iostat);
    5199                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->exist);
    5200                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->opened);
    5201                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->number);
    5202                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->named);
    5203                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->name);
    5204                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->access);
    5205                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->sequential);
    5206                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->direct);
    5207                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->form);
    5208                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->formatted);
    5209                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->unformatted);
    5210                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->recl);
    5211                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->nextrec);
    5212                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->blank);
    5213                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->position);
    5214                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->action);
    5215                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->read);
    5216                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->write);
    5217                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->readwrite);
    5218                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->delim);
    5219                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->encoding);
    5220                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->pad);
    5221                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->iolength);
    5222                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->convert);
    5223                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->strm_pos);
    5224                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->asynchronous);
    5225                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->decimal);
    5226                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->pending);
    5227                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->id);
    5228                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->sign);
    5229                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->size);
    5230                 :       9503 :               WALK_SUBEXPR (co->ext.inquire->round);
    5231                 :            :               break;
    5232                 :            : 
    5233                 :        700 :             case EXEC_WAIT:
    5234                 :        700 :               WALK_SUBEXPR (co->ext.wait->unit);
    5235                 :        700 :               WALK_SUBEXPR (co->ext.wait->iostat);
    5236                 :        700 :               WALK_SUBEXPR (co->ext.wait->iomsg);
    5237                 :        700 :               WALK_SUBEXPR (co->ext.wait->id);
    5238                 :            :               break;
    5239                 :            : 
    5240                 :     292215 :             case EXEC_READ:
    5241                 :     292215 :             case EXEC_WRITE:
    5242                 :     292215 :               WALK_SUBEXPR (co->ext.dt->io_unit);
    5243                 :     292215 :               WALK_SUBEXPR (co->ext.dt->format_expr);
    5244                 :     292215 :               WALK_SUBEXPR (co->ext.dt->rec);
    5245                 :     292215 :               WALK_SUBEXPR (co->ext.dt->advance);
    5246                 :     292215 :               WALK_SUBEXPR (co->ext.dt->iostat);
    5247                 :     292215 :               WALK_SUBEXPR (co->ext.dt->size);
    5248                 :     292215 :               WALK_SUBEXPR (co->ext.dt->iomsg);
    5249                 :     292215 :               WALK_SUBEXPR (co->ext.dt->id);
    5250                 :     292215 :               WALK_SUBEXPR (co->ext.dt->pos);
    5251                 :     292215 :               WALK_SUBEXPR (co->ext.dt->asynchronous);
    5252                 :     292215 :               WALK_SUBEXPR (co->ext.dt->blank);
    5253                 :     292215 :               WALK_SUBEXPR (co->ext.dt->decimal);
    5254                 :     292215 :               WALK_SUBEXPR (co->ext.dt->delim);
    5255                 :     292215 :               WALK_SUBEXPR (co->ext.dt->pad);
    5256                 :     292215 :               WALK_SUBEXPR (co->ext.dt->round);
    5257                 :     292215 :               WALK_SUBEXPR (co->ext.dt->sign);
    5258                 :     292215 :               WALK_SUBEXPR (co->ext.dt->extra_comma);
    5259                 :            :               break;
    5260                 :            : 
    5261                 :      20385 :             case EXEC_OACC_ATOMIC:
    5262                 :      20385 :             case EXEC_OMP_ATOMIC:
    5263                 :      20385 :               in_omp_atomic = true;
    5264                 :      20385 :               break;
    5265                 :            : 
    5266                 :      30060 :             case EXEC_OMP_PARALLEL:
    5267                 :      30060 :             case EXEC_OMP_PARALLEL_DO:
    5268                 :      30060 :             case EXEC_OMP_PARALLEL_DO_SIMD:
    5269                 :      30060 :             case EXEC_OMP_PARALLEL_SECTIONS:
    5270                 :            : 
    5271                 :      30060 :               in_omp_workshare = false;
    5272                 :            : 
    5273                 :            :               /* This goto serves as a shortcut to avoid code
    5274                 :            :                  duplication or a larger if or switch statement.  */
    5275                 :      30060 :               goto check_omp_clauses;
    5276                 :            : 
    5277                 :       1001 :             case EXEC_OMP_WORKSHARE:
    5278                 :       1001 :             case EXEC_OMP_PARALLEL_WORKSHARE:
    5279                 :            : 
    5280                 :       1001 :               in_omp_workshare = true;
    5281                 :            : 
    5282                 :            :               /* Fall through  */
    5283                 :            : 
    5284                 :     108587 :             case EXEC_OMP_CRITICAL:
    5285                 :     108587 :             case EXEC_OMP_DISTRIBUTE:
    5286                 :     108587 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
    5287                 :     108587 :             case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
    5288                 :     108587 :             case EXEC_OMP_DISTRIBUTE_SIMD:
    5289                 :     108587 :             case EXEC_OMP_DO:
    5290                 :     108587 :             case EXEC_OMP_DO_SIMD:
    5291                 :     108587 :             case EXEC_OMP_ORDERED:
    5292                 :     108587 :             case EXEC_OMP_SECTIONS:
    5293                 :     108587 :             case EXEC_OMP_SINGLE:
    5294                 :     108587 :             case EXEC_OMP_END_SINGLE:
    5295                 :     108587 :             case EXEC_OMP_SIMD:
    5296                 :     108587 :             case EXEC_OMP_TASKLOOP:
    5297                 :     108587 :             case EXEC_OMP_TASKLOOP_SIMD:
    5298                 :     108587 :             case EXEC_OMP_TARGET:
    5299                 :     108587 :             case EXEC_OMP_TARGET_DATA:
    5300                 :     108587 :             case EXEC_OMP_TARGET_ENTER_DATA:
    5301                 :     108587 :             case EXEC_OMP_TARGET_EXIT_DATA:
    5302                 :     108587 :             case EXEC_OMP_TARGET_PARALLEL:
    5303                 :     108587 :             case EXEC_OMP_TARGET_PARALLEL_DO:
    5304                 :     108587 :             case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
    5305                 :     108587 :             case EXEC_OMP_TARGET_SIMD:
    5306                 :     108587 :             case EXEC_OMP_TARGET_TEAMS:
    5307                 :     108587 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
    5308                 :     108587 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5309                 :     108587 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5310                 :     108587 :             case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
    5311                 :     108587 :             case EXEC_OMP_TARGET_UPDATE:
    5312                 :     108587 :             case EXEC_OMP_TASK:
    5313                 :     108587 :             case EXEC_OMP_TEAMS:
    5314                 :     108587 :             case EXEC_OMP_TEAMS_DISTRIBUTE:
    5315                 :     108587 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
    5316                 :     108587 :             case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
    5317                 :     108587 :             case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
    5318                 :            : 
    5319                 :            :               /* Come to this label only from the
    5320                 :            :                  EXEC_OMP_PARALLEL_* cases above.  */
    5321                 :            : 
    5322                 :     108587 :             check_omp_clauses:
    5323                 :            : 
    5324                 :     108587 :               if (co->ext.omp_clauses)
    5325                 :            :                 {
    5326                 :     108114 :                   gfc_omp_namelist *n;
    5327                 :     108114 :                   static int list_types[]
    5328                 :            :                     = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
    5329                 :            :                         OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
    5330                 :     108114 :                   size_t idx;
    5331                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
    5332                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
    5333                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
    5334                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
    5335                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
    5336                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
    5337                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
    5338                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->device);
    5339                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
    5340                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
    5341                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->grainsize);
    5342                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->hint);
    5343                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->num_tasks);
    5344                 :     108114 :                   WALK_SUBEXPR (co->ext.omp_clauses->priority);
    5345                 :     973026 :                   for (idx = 0; idx < OMP_IF_LAST; idx++)
    5346                 :     864912 :                     WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]);
    5347                 :     648684 :                   for (idx = 0;
    5348                 :     756798 :                        idx < sizeof (list_types) / sizeof (list_types[0]);
    5349                 :            :                        idx++)
    5350                 :     648684 :                     for (n = co->ext.omp_clauses->lists[list_types[idx]];
    5351                 :     735756 :                          n; n = n->next)
    5352                 :      87072 :                       WALK_SUBEXPR (n->expr);
    5353                 :            :                 }
    5354                 :            :               break;
    5355                 :            :             default:
    5356                 :      10029 :               break;
    5357                 :            :             }
    5358                 :            : 
    5359                 :    9057460 :           WALK_SUBEXPR (co->expr1);
    5360                 :    9057460 :           WALK_SUBEXPR (co->expr2);
    5361                 :    9057460 :           WALK_SUBEXPR (co->expr3);
    5362                 :    9057460 :           WALK_SUBEXPR (co->expr4);
    5363                 :   11891600 :           for (b = co->block; b; b = b->block)
    5364                 :            :             {
    5365                 :    2834110 :               WALK_SUBEXPR (b->expr1);
    5366                 :    2834110 :               WALK_SUBEXPR (b->expr2);
    5367                 :    2834110 :               WALK_SUBCODE (b->next);
    5368                 :            :             }
    5369                 :            : 
    5370                 :    9057460 :           if (co->op == EXEC_FORALL)
    5371                 :      45815 :             forall_level --;
    5372                 :            : 
    5373                 :    9057460 :           if (co->op == EXEC_DO)
    5374                 :     370230 :             doloop_level --;
    5375                 :            : 
    5376                 :    9057460 :           if (co->op == EXEC_IF)
    5377                 :    1810980 :             if_level --;
    5378                 :            : 
    5379                 :    9057460 :           if (co->op == EXEC_SELECT)
    5380                 :          0 :             select_level --;
    5381                 :            : 
    5382                 :    9057460 :           in_omp_workshare = saved_in_omp_workshare;
    5383                 :    9057460 :           in_omp_atomic = saved_in_omp_atomic;
    5384                 :    9057460 :           in_where = saved_in_where;
    5385                 :            :         }
    5386                 :            :     }
    5387                 :            :   return 0;
    5388                 :            : }
    5389                 :            : 
    5390                 :            : /* As a post-resolution step, check that all global symbols which are
    5391                 :            :    not declared in the source file match in their call signatures.
    5392                 :            :    We do this by looping over the code (and expressions). The first call
    5393                 :            :    we happen to find is assumed to be canonical.  */
    5394                 :            : 
    5395                 :            : 
    5396                 :            : /* Common tests for argument checking for both functions and subroutines.  */
    5397                 :            : 
    5398                 :            : static int
    5399                 :      79142 : check_externals_procedure (gfc_symbol *sym, locus *loc,
    5400                 :            :                            gfc_actual_arglist *actual)
    5401                 :            : {
    5402                 :      79142 :   gfc_gsymbol *gsym;
    5403                 :      79142 :   gfc_symbol *def_sym = NULL;
    5404                 :            : 
    5405                 :      79142 :  if (sym == NULL || sym->attr.is_bind_c)
    5406                 :            :     return 0;
    5407                 :            : 
    5408                 :      77621 :   if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN)
    5409                 :            :     return 0;
    5410                 :            : 
    5411                 :      22022 :   if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL)
    5412                 :            :     return 0;
    5413                 :            : 
    5414                 :      15704 :   gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
    5415                 :      15704 :   if (gsym == NULL)
    5416                 :            :     return 0;
    5417                 :            : 
    5418                 :      14897 :   if (gsym->ns)
    5419                 :      13892 :     gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym);
    5420                 :            : 
    5421                 :      14897 :   if (def_sym)
    5422                 :            :     {
    5423                 :      13892 :       gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc);
    5424                 :      13892 :       return 0;
    5425                 :            :     }
    5426                 :            : 
    5427                 :            :   /* First time we have seen this procedure called. Let's create an
    5428                 :            :      "interface" from the call and put it into a new namespace.  */
    5429                 :       1005 :   gfc_namespace *save_ns;
    5430                 :       1005 :   gfc_symbol *new_sym;
    5431                 :            : 
    5432                 :       1005 :   gsym->where = *loc;
    5433                 :       1005 :   save_ns = gfc_current_ns;
    5434                 :       1005 :   gsym->ns = gfc_get_namespace (gfc_current_ns, 0);
    5435                 :       1005 :   gsym->ns->proc_name = sym;
    5436                 :            : 
    5437                 :       1005 :   gfc_get_symbol (sym->name, gsym->ns, &new_sym);
    5438                 :       1005 :   gcc_assert (new_sym);
    5439                 :       1005 :   new_sym->attr = sym->attr;
    5440                 :       1005 :   new_sym->attr.if_source = IFSRC_DECL;
    5441                 :       1005 :   gfc_current_ns = gsym->ns;
    5442                 :            : 
    5443                 :       1005 :   gfc_get_formal_from_actual_arglist (new_sym, actual);
    5444                 :       1005 :   gfc_current_ns = save_ns;
    5445                 :            : 
    5446                 :       1005 :   return 0;
    5447                 :            : 
    5448                 :            : }
    5449                 :            : 
    5450                 :            : /* Callback for calls of external routines.  */
    5451                 :            : 
    5452                 :            : static int
    5453                 :     712315 : check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
    5454                 :            :                       void *data ATTRIBUTE_UNUSED)
    5455                 :            : {
    5456                 :     712315 :   gfc_code *co = *c;
    5457                 :     712315 :   gfc_symbol *sym;
    5458                 :     712315 :   locus *loc;
    5459                 :     712315 :   gfc_actual_arglist *actual;
    5460                 :            : 
    5461                 :     712315 :   if (co->op != EXEC_CALL)
    5462                 :            :     return 0;
    5463                 :            : 
    5464                 :      51719 :   sym = co->resolved_sym;
    5465                 :      51719 :   loc = &co->loc;
    5466                 :      51719 :   actual = co->ext.actual;
    5467                 :            : 
    5468                 :      51719 :   return check_externals_procedure (sym, loc, actual);
    5469                 :            : 
    5470                 :            : }
    5471                 :            : 
    5472                 :            : /* Callback for external functions.  */
    5473                 :            : 
    5474                 :            : static int
    5475                 :    2048280 : check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
    5476                 :            :                       void *data ATTRIBUTE_UNUSED)
    5477                 :            : {
    5478                 :    2048280 :   gfc_expr *e = *ep;
    5479                 :    2048280 :   gfc_symbol *sym;
    5480                 :    2048280 :   locus *loc;
    5481                 :    2048280 :   gfc_actual_arglist *actual;
    5482                 :            : 
    5483                 :    2048280 :   if (e->expr_type != EXPR_FUNCTION)
    5484                 :            :     return 0;
    5485                 :            : 
    5486                 :     176204 :   sym = e->value.function.esym;
    5487                 :     176204 :   if (sym == NULL)
    5488                 :            :     return 0;
    5489                 :            : 
    5490                 :      27423 :   loc = &e->where;
    5491                 :      27423 :   actual = e->value.function.actual;
    5492                 :            : 
    5493                 :      27423 :   return check_externals_procedure (sym, loc, actual);
    5494                 :            : }
    5495                 :            : 
    5496                 :            : /* Called routine.  */
    5497                 :            : 
    5498                 :            : void
    5499                 :      67993 : gfc_check_externals (gfc_namespace *ns)
    5500                 :            : {
    5501                 :            : 
    5502                 :      67993 :   gfc_clear_error ();
    5503                 :            : 
    5504                 :            :   /* Turn errors into warnings if the user indicated this.  */
    5505                 :            : 
    5506                 :      67993 :   if (!pedantic && flag_allow_argument_mismatch)
    5507                 :       1432 :     gfc_errors_to_warnings (true);
    5508                 :            : 
    5509                 :      67993 :   gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL);
    5510                 :            : 
    5511                 :      97572 :   for (ns = ns->contained; ns; ns = ns->sibling)
    5512                 :            :     {
    5513                 :      29579 :       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
    5514                 :      29038 :         gfc_check_externals (ns);
    5515                 :            :     }
    5516                 :            : 
    5517                 :      67993 :   gfc_errors_to_warnings (false);
    5518                 :      67993 : }

Generated by: LCOV version 1.0

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