gcc/fortran/trans-array.c

   1 /* Array translation routines
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-array.c-- Various array related code, including scalarization,
  24                    allocation, initialization and other support routines.  */
  25
  26 /* How the scalarizer works.
  27    In gfortran, array expressions use the same core routines as scalar
  28    expressions.
  29    First, a Scalarization State (SS) chain is built.  This is done by walking
  30    the expression tree, and building a linear list of the terms in the
  31    expression.  As the tree is walked, scalar subexpressions are translated.
  32
  33    The scalarization parameters are stored in a gfc_loopinfo structure.
  34    First the start and stride of each term is calculated by
  35    gfc_conv_ss_startstride.  During this process the expressions for the array
  36    descriptors and data pointers are also translated.
  37
  38    If the expression is an assignment, we must then resolve any dependencies.
  39    In fortran all the rhs values of an assignment must be evaluated before
  40    any assignments take place.  This can require a temporary array to store the
  41    values.  We also require a temporary when we are passing array expressions
  42    or vector subscripts as procedure parameters.
  43
  44    Array sections are passed without copying to a temporary.  These use the
  45    scalarizer to determine the shape of the section.  The flag
  46    loop->array_parameter tells the scalarizer that the actual values and loop
  47    variables will not be required.
  48
  49    The function gfc_conv_loop_setup generates the scalarization setup code.
  50    It determines the range of the scalarizing loop variables.  If a temporary
  51    is required, this is created and initialized.  Code for scalar expressions
  52    taken outside the loop is also generated at this time.  Next the offset and
  53    scaling required to translate from loop variables to array indices for each
  54    term is calculated.
  55
  56    A call to gfc_start_scalarized_body marks the start of the scalarized
  57    expression.  This creates a scope and declares the loop variables.  Before
  58    calling this gfc_make_ss_chain_used must be used to indicate which terms
  59    will be used inside this loop.
  60
  61    The scalar gfc_conv_* functions are then used to build the main body of the
  62    scalarization loop.  Scalarization loop variables and precalculated scalar
  63    values are automatically substituted.  Note that gfc_advance_se_ss_chain
  64    must be used, rather than changing the se->ss directly.
  65
  66    For assignment expressions requiring a temporary two sub loops are
  67    generated.  The first stores the result of the expression in the temporary,
  68    the second copies it to the result.  A call to
  69    gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
  70    the start of the copying loop.  The temporary may be less than full rank.
  71
  72    Finally gfc_trans_scalarizing_loops is called to generate the implicit do
  73    loops.  The loops are added to the pre chain of the loopinfo.  The post
  74    chain may still contain cleanup code.
  75
  76    After the loop code has been added into its parent scope gfc_cleanup_loop
  77    is called to free all the SS allocated by the scalarizer.  */
  78
  79 #include "config.h"
  80 #include "system.h"
  81 #include "coretypes.h"
  82 #include "tree.h"
  83 #include "gimple.h"
  84 #include "ggc.h"
  85 #include "toplev.h"
  86 #include "real.h"
  87 #include "flags.h"
  88 #include "gfortran.h"
  89 #include "trans.h"
  90 #include "trans-stmt.h"
  91 #include "trans-types.h"
  92 #include "trans-array.h"
  93 #include "trans-const.h"
  94 #include "dependency.h"
  95
  96 static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
  97 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
  98
  99 /* The contents of this structure aren't actually used, just the address.  */
 100 static gfc_ss gfc_ss_terminator_var;
 101 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
 102
 103
 104 static tree
 105 gfc_array_dataptr_type (tree desc)
 106 {
 107   return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
 108 }
 109
 110
 111 /* Build expressions to access the members of an array descriptor.
 112    It's surprisingly easy to mess up here, so never access
 113    an array descriptor by "brute force", always use these
 114    functions.  This also avoids problems if we change the format
 115    of an array descriptor.
 116
 117    To understand these magic numbers, look at the comments
 118    before gfc_build_array_type() in trans-types.c.
 119
 120    The code within these defines should be the only code which knows the format
 121    of an array descriptor.
 122
 123    Any code just needing to read obtain the bounds of an array should use
 124    gfc_conv_array_* rather than the following functions as these will return
 125    know constant values, and work with arrays which do not have descriptors.
 126
 127    Don't forget to #undef these!  */
 128
 129 #define DATA_FIELD 0
 130 #define OFFSET_FIELD 1
 131 #define DTYPE_FIELD 2
 132 #define DIMENSION_FIELD 3
 133
 134 #define STRIDE_SUBFIELD 0
 135 #define LBOUND_SUBFIELD 1
 136 #define UBOUND_SUBFIELD 2
 137
 138 /* This provides READ-ONLY access to the data field.  The field itself
 139    doesn't have the proper type.  */
 140
 141 tree
 142 gfc_conv_descriptor_data_get (tree desc)
 143 {
 144   tree field, type, t;
 145
 146   type = TREE_TYPE (desc);
 147   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 148
 149   field = TYPE_FIELDS (type);
 150   gcc_assert (DATA_FIELD == 0);
 151
 152   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
 153   t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
 154
 155   return t;
 156 }
 157
 158 /* This provides WRITE access to the data field.
 159
 160    TUPLES_P is true if we are generating tuples.
 161
 162    This function gets called through the following macros:
 163      gfc_conv_descriptor_data_set
 164      gfc_conv_descriptor_data_set.  */
 165
 166 void
 167 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
 168 {
 169   tree field, type, t;
 170
 171   type = TREE_TYPE (desc);
 172   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 173
 174   field = TYPE_FIELDS (type);
 175   gcc_assert (DATA_FIELD == 0);
 176
 177   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
 178   gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
 179 }
 180
 181
 182 /* This provides address access to the data field.  This should only be
 183    used by array allocation, passing this on to the runtime.  */
 184
 185 tree
 186 gfc_conv_descriptor_data_addr (tree desc)
 187 {
 188   tree field, type, t;
 189
 190   type = TREE_TYPE (desc);
 191   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 192
 193   field = TYPE_FIELDS (type);
 194   gcc_assert (DATA_FIELD == 0);
 195
 196   t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
 197   return gfc_build_addr_expr (NULL_TREE, t);
 198 }
 199
 200 static tree
 201 gfc_conv_descriptor_offset (tree desc)
 202 {
 203   tree type;
 204   tree field;
 205
 206   type = TREE_TYPE (desc);
 207   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 208
 209   field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
 210   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
 211
 212   return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 213                       desc, field, NULL_TREE);
 214 }
 215
 216 tree
 217 gfc_conv_descriptor_offset_get (tree desc)
 218 {
 219   return gfc_conv_descriptor_offset (desc);
 220 }
 221
 222 void
 223 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
 224                                 tree value)
 225 {
 226   tree t = gfc_conv_descriptor_offset (desc);
 227   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 228 }
 229
 230
 231 tree
 232 gfc_conv_descriptor_dtype (tree desc)
 233 {
 234   tree field;
 235   tree type;
 236
 237   type = TREE_TYPE (desc);
 238   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 239
 240   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
 241   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
 242
 243   return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 244                       desc, field, NULL_TREE);
 245 }
 246
 247 static tree
 248 gfc_conv_descriptor_dimension (tree desc, tree dim)
 249 {
 250   tree field;
 251   tree type;
 252   tree tmp;
 253
 254   type = TREE_TYPE (desc);
 255   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 256
 257   field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
 258   gcc_assert (field != NULL_TREE
 259           && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
 260           && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
 261
 262   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 263                      desc, field, NULL_TREE);
 264   tmp = gfc_build_array_ref (tmp, dim, NULL);
 265   return tmp;
 266 }
 267
 268 static tree
 269 gfc_conv_descriptor_stride (tree desc, tree dim)
 270 {
 271   tree tmp;
 272   tree field;
 273
 274   tmp = gfc_conv_descriptor_dimension (desc, dim);
 275   field = TYPE_FIELDS (TREE_TYPE (tmp));
 276   field = gfc_advance_chain (field, STRIDE_SUBFIELD);
 277   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
 278
 279   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 280                      tmp, field, NULL_TREE);
 281   return tmp;
 282 }
 283
 284 tree
 285 gfc_conv_descriptor_stride_get (tree desc, tree dim)
 286 {
 287   tree type = TREE_TYPE (desc);
 288   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 289   if (integer_zerop (dim)
 290       && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
 291     return gfc_index_one_node;
 292
 293   return gfc_conv_descriptor_stride (desc, dim);
 294 }
 295
 296 void
 297 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
 298                                 tree dim, tree value)
 299 {
 300   tree t = gfc_conv_descriptor_stride (desc, dim);
 301   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 302 }
 303
 304 static tree
 305 gfc_conv_descriptor_lbound (tree desc, tree dim)
 306 {
 307   tree tmp;
 308   tree field;
 309
 310   tmp = gfc_conv_descriptor_dimension (desc, dim);
 311   field = TYPE_FIELDS (TREE_TYPE (tmp));
 312   field = gfc_advance_chain (field, LBOUND_SUBFIELD);
 313   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
 314
 315   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 316                      tmp, field, NULL_TREE);
 317   return tmp;
 318 }
 319
 320 tree
 321 gfc_conv_descriptor_lbound_get (tree desc, tree dim)
 322 {
 323   return gfc_conv_descriptor_lbound (desc, dim);
 324 }
 325
 326 void
 327 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
 328                                 tree dim, tree value)
 329 {
 330   tree t = gfc_conv_descriptor_lbound (desc, dim);
 331   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 332 }
 333
 334 static tree
 335 gfc_conv_descriptor_ubound (tree desc, tree dim)
 336 {
 337   tree tmp;
 338   tree field;
 339
 340   tmp = gfc_conv_descriptor_dimension (desc, dim);
 341   field = TYPE_FIELDS (TREE_TYPE (tmp));
 342   field = gfc_advance_chain (field, UBOUND_SUBFIELD);
 343   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
 344
 345   tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
 346                      tmp, field, NULL_TREE);
 347   return tmp;
 348 }
 349
 350 tree
 351 gfc_conv_descriptor_ubound_get (tree desc, tree dim)
 352 {
 353   return gfc_conv_descriptor_ubound (desc, dim);
 354 }
 355
 356 void
 357 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
 358                                 tree dim, tree value)
 359 {
 360   tree t = gfc_conv_descriptor_ubound (desc, dim);
 361   gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
 362 }
 363
 364 /* Build a null array descriptor constructor.  */
 365
 366 tree
 367 gfc_build_null_descriptor (tree type)
 368 {
 369   tree field;
 370   tree tmp;
 371
 372   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 373   gcc_assert (DATA_FIELD == 0);
 374   field = TYPE_FIELDS (type);
 375
 376   /* Set a NULL data pointer.  */
 377   tmp = build_constructor_single (type, field, null_pointer_node);
 378   TREE_CONSTANT (tmp) = 1;
 379   /* All other fields are ignored.  */
 380
 381   return tmp;
 382 }
 383
 384
 385 /* Cleanup those #defines.  */
 386
 387 #undef DATA_FIELD
 388 #undef OFFSET_FIELD
 389 #undef DTYPE_FIELD
 390 #undef DIMENSION_FIELD
 391 #undef STRIDE_SUBFIELD
 392 #undef LBOUND_SUBFIELD
 393 #undef UBOUND_SUBFIELD
 394
 395
 396 /* Mark a SS chain as used.  Flags specifies in which loops the SS is used.
 397    flags & 1 = Main loop body.
 398    flags & 2 = temp copy loop.  */
 399
 400 void
 401 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
 402 {
 403   for (; ss != gfc_ss_terminator; ss = ss->next)
 404     ss->useflags = flags;
 405 }
 406
 407 static void gfc_free_ss (gfc_ss *);
 408
 409
 410 /* Free a gfc_ss chain.  */
 411
 412 static void
 413 gfc_free_ss_chain (gfc_ss * ss)
 414 {
 415   gfc_ss *next;
 416
 417   while (ss != gfc_ss_terminator)
 418     {
 419       gcc_assert (ss != NULL);
 420       next = ss->next;
 421       gfc_free_ss (ss);
 422       ss = next;
 423     }
 424 }
 425
 426
 427 /* Free a SS.  */
 428
 429 static void
 430 gfc_free_ss (gfc_ss * ss)
 431 {
 432   int n;
 433
 434   switch (ss->type)
 435     {
 436     case GFC_SS_SECTION:
 437       for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
 438         {
 439           if (ss->data.info.subscript[n])
 440             gfc_free_ss_chain (ss->data.info.subscript[n]);
 441         }
 442       break;
 443
 444     default:
 445       break;
 446     }
 447
 448   gfc_free (ss);
 449 }
 450
 451
 452 /* Free all the SS associated with a loop.  */
 453
 454 void
 455 gfc_cleanup_loop (gfc_loopinfo * loop)
 456 {
 457   gfc_ss *ss;
 458   gfc_ss *next;
 459
 460   ss = loop->ss;
 461   while (ss != gfc_ss_terminator)
 462     {
 463       gcc_assert (ss != NULL);
 464       next = ss->loop_chain;
 465       gfc_free_ss (ss);
 466       ss = next;
 467     }
 468 }
 469
 470
 471 /* Associate a SS chain with a loop.  */
 472
 473 void
 474 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
 475 {
 476   gfc_ss *ss;
 477
 478   if (head == gfc_ss_terminator)
 479     return;
 480
 481   ss = head;
 482   for (; ss && ss != gfc_ss_terminator; ss = ss->next)
 483     {
 484       if (ss->next == gfc_ss_terminator)
 485         ss->loop_chain = loop->ss;
 486       else
 487         ss->loop_chain = ss->next;
 488     }
 489   gcc_assert (ss == gfc_ss_terminator);
 490   loop->ss = head;
 491 }
 492
 493
 494 /* Generate an initializer for a static pointer or allocatable array.  */
 495
 496 void
 497 gfc_trans_static_array_pointer (gfc_symbol * sym)
 498 {
 499   tree type;
 500
 501   gcc_assert (TREE_STATIC (sym->backend_decl));
 502   /* Just zero the data member.  */
 503   type = TREE_TYPE (sym->backend_decl);
 504   DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
 505 }
 506
 507
 508 /* If the bounds of SE's loop have not yet been set, see if they can be
 509    determined from array spec AS, which is the array spec of a called
 510    function.  MAPPING maps the callee's dummy arguments to the values
 511    that the caller is passing.  Add any initialization and finalization
 512    code to SE.  */
 513
 514 void
 515 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
 516                                      gfc_se * se, gfc_array_spec * as)
 517 {
 518   int n, dim;
 519   gfc_se tmpse;
 520   tree lower;
 521   tree upper;
 522   tree tmp;
 523
 524   if (as && as->type == AS_EXPLICIT)
 525     for (dim = 0; dim < se->loop->dimen; dim++)
 526       {
 527         n = se->loop->order[dim];
 528         if (se->loop->to[n] == NULL_TREE)
 529           {
 530             /* Evaluate the lower bound.  */
 531             gfc_init_se (&tmpse, NULL);
 532             gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
 533             gfc_add_block_to_block (&se->pre, &tmpse.pre);
 534             gfc_add_block_to_block (&se->post, &tmpse.post);
 535             lower = fold_convert (gfc_array_index_type, tmpse.expr);
 536
 537             /* ...and the upper bound.  */
 538             gfc_init_se (&tmpse, NULL);
 539             gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
 540             gfc_add_block_to_block (&se->pre, &tmpse.pre);
 541             gfc_add_block_to_block (&se->post, &tmpse.post);
 542             upper = fold_convert (gfc_array_index_type, tmpse.expr);
 543
 544             /* Set the upper bound of the loop to UPPER - LOWER.  */
 545             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
 546             tmp = gfc_evaluate_now (tmp, &se->pre);
 547             se->loop->to[n] = tmp;
 548           }
 549       }
 550 }
 551
 552
 553 /* Generate code to allocate an array temporary, or create a variable to
 554    hold the data.  If size is NULL, zero the descriptor so that the
 555    callee will allocate the array.  If DEALLOC is true, also generate code to
 556    free the array afterwards.
 557
 558    If INITIAL is not NULL, it is packed using internal_pack and the result used
 559    as data instead of allocating a fresh, unitialized area of memory.
 560
 561    Initialization code is added to PRE and finalization code to POST.
 562    DYNAMIC is true if the caller may want to extend the array later
 563    using realloc.  This prevents us from putting the array on the stack.  */
 564
 565 static void
 566 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
 567                                   gfc_ss_info * info, tree size, tree nelem,
 568                                   tree initial, bool dynamic, bool dealloc)
 569 {
 570   tree tmp;
 571   tree desc;
 572   bool onstack;
 573
 574   desc = info->descriptor;
 575   info->offset = gfc_index_zero_node;
 576   if (size == NULL_TREE || integer_zerop (size))
 577     {
 578       /* A callee allocated array.  */
 579       gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
 580       onstack = FALSE;
 581     }
 582   else
 583     {
 584       /* Allocate the temporary.  */
 585       onstack = !dynamic && initial == NULL_TREE
 586                          && gfc_can_put_var_on_stack (size);
 587
 588       if (onstack)
 589         {
 590           /* Make a temporary variable to hold the data.  */
 591           tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (nelem), nelem,
 592                              gfc_index_one_node);
 593           tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 594                                   tmp);
 595           tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
 596                                   tmp);
 597           tmp = gfc_create_var (tmp, "A");
 598           tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 599           gfc_conv_descriptor_data_set (pre, desc, tmp);
 600         }
 601       else
 602         {
 603           /* Allocate memory to hold the data or call internal_pack.  */
 604           if (initial == NULL_TREE)
 605             {
 606               tmp = gfc_call_malloc (pre, NULL, size);
 607               tmp = gfc_evaluate_now (tmp, pre);
 608             }
 609           else
 610             {
 611               tree packed;
 612               tree source_data;
 613               tree was_packed;
 614               stmtblock_t do_copying;
 615
 616               tmp = TREE_TYPE (initial); /* Pointer to descriptor.  */
 617               gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
 618               tmp = TREE_TYPE (tmp); /* The descriptor itself.  */
 619               tmp = gfc_get_element_type (tmp);
 620               gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
 621               packed = gfc_create_var (build_pointer_type (tmp), "data");
 622
 623               tmp = build_call_expr_loc (input_location,
 624                                      gfor_fndecl_in_pack, 1, initial);
 625               tmp = fold_convert (TREE_TYPE (packed), tmp);
 626               gfc_add_modify (pre, packed, tmp);
 627
 628               tmp = build_fold_indirect_ref_loc (input_location,
 629                                              initial);
 630               source_data = gfc_conv_descriptor_data_get (tmp);
 631
 632               /* internal_pack may return source->data without any allocation
 633                  or copying if it is already packed.  If that's the case, we
 634                  need to allocate and copy manually.  */
 635
 636               gfc_start_block (&do_copying);
 637               tmp = gfc_call_malloc (&do_copying, NULL, size);
 638               tmp = fold_convert (TREE_TYPE (packed), tmp);
 639               gfc_add_modify (&do_copying, packed, tmp);
 640               tmp = gfc_build_memcpy_call (packed, source_data, size);
 641               gfc_add_expr_to_block (&do_copying, tmp);
 642
 643               was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
 644                                         packed, source_data);
 645               tmp = gfc_finish_block (&do_copying);
 646               tmp = build3_v (COND_EXPR, was_packed, tmp,
 647                               build_empty_stmt (input_location));
 648               gfc_add_expr_to_block (pre, tmp);
 649
 650               tmp = fold_convert (pvoid_type_node, packed);
 651             }
 652
 653           gfc_conv_descriptor_data_set (pre, desc, tmp);
 654         }
 655     }
 656   info->data = gfc_conv_descriptor_data_get (desc);
 657
 658   /* The offset is zero because we create temporaries with a zero
 659      lower bound.  */
 660   gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
 661
 662   if (dealloc && !onstack)
 663     {
 664       /* Free the temporary.  */
 665       tmp = gfc_conv_descriptor_data_get (desc);
 666       tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
 667       gfc_add_expr_to_block (post, tmp);
 668     }
 669 }
 670
 671
 672 /* Generate code to create and initialize the descriptor for a temporary
 673    array.  This is used for both temporaries needed by the scalarizer, and
 674    functions returning arrays.  Adjusts the loop variables to be
 675    zero-based, and calculates the loop bounds for callee allocated arrays.
 676    Allocate the array unless it's callee allocated (we have a callee
 677    allocated array if 'callee_alloc' is true, or if loop->to[n] is
 678    NULL_TREE for any n).  Also fills in the descriptor, data and offset
 679    fields of info if known.  Returns the size of the array, or NULL for a
 680    callee allocated array.
 681
 682    PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
 683    gfc_trans_allocate_array_storage.
 684  */
 685
 686 tree
 687 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
 688                              gfc_loopinfo * loop, gfc_ss_info * info,
 689                              tree eltype, tree initial, bool dynamic,
 690                              bool dealloc, bool callee_alloc, locus * where)
 691 {
 692   tree type;
 693   tree desc;
 694   tree tmp;
 695   tree size;
 696   tree nelem;
 697   tree cond;
 698   tree or_expr;
 699   int n;
 700   int dim;
 701
 702   gcc_assert (info->dimen > 0);
 703
 704   if (gfc_option.warn_array_temp && where)
 705     gfc_warning ("Creating array temporary at %L", where);
 706
 707   /* Set the lower bound to zero.  */
 708   for (dim = 0; dim < info->dimen; dim++)
 709     {
 710       n = loop->order[dim];
 711       /* Callee allocated arrays may not have a known bound yet.  */
 712       if (loop->to[n])
 713         loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
 714                                         gfc_array_index_type,
 715                                         loop->to[n], loop->from[n]), pre);
 716       loop->from[n] = gfc_index_zero_node;
 717
 718       info->delta[dim] = gfc_index_zero_node;
 719       info->start[dim] = gfc_index_zero_node;
 720       info->end[dim] = gfc_index_zero_node;
 721       info->stride[dim] = gfc_index_one_node;
 722       info->dim[dim] = dim;
 723     }
 724
 725   /* Initialize the descriptor.  */
 726   type =
 727     gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
 728                                GFC_ARRAY_UNKNOWN, true);
 729   desc = gfc_create_var (type, "atmp");
 730   GFC_DECL_PACKED_ARRAY (desc) = 1;
 731
 732   info->descriptor = desc;
 733   size = gfc_index_one_node;
 734
 735   /* Fill in the array dtype.  */
 736   tmp = gfc_conv_descriptor_dtype (desc);
 737   gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
 738
 739   /*
 740      Fill in the bounds and stride.  This is a packed array, so:
 741
 742      size = 1;
 743      for (n = 0; n < rank; n++)
 744        {
 745          stride[n] = size
 746          delta = ubound[n] + 1 - lbound[n];
 747          size = size * delta;
 748        }
 749      size = size * sizeof(element);
 750   */
 751
 752   or_expr = NULL_TREE;
 753
 754   /* If there is at least one null loop->to[n], it is a callee allocated
 755      array.  */
 756   for (n = 0; n < info->dimen; n++)
 757     if (loop->to[n] == NULL_TREE)
 758       {
 759         size = NULL_TREE;
 760         break;
 761       }
 762
 763   for (n = 0; n < info->dimen; n++)
 764      {
 765       if (size == NULL_TREE)
 766         {
 767           /* For a callee allocated array express the loop bounds in terms
 768              of the descriptor fields.  */
 769           tmp =
 770             fold_build2 (MINUS_EXPR, gfc_array_index_type,
 771                          gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
 772                          gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
 773           loop->to[n] = tmp;
 774           continue;
 775         }
 776
 777       /* Store the stride and bound components in the descriptor.  */
 778       gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
 779
 780       gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
 781                                       gfc_index_zero_node);
 782
 783       gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
 784
 785       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
 786                          loop->to[n], gfc_index_one_node);
 787
 788       /* Check whether the size for this dimension is negative.  */
 789       cond = fold_build2 (LE_EXPR, boolean_type_node, tmp,
 790                           gfc_index_zero_node);
 791       cond = gfc_evaluate_now (cond, pre);
 792
 793       if (n == 0)
 794         or_expr = cond;
 795       else
 796         or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
 797
 798       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
 799       size = gfc_evaluate_now (size, pre);
 800     }
 801
 802   /* Get the size of the array.  */
 803
 804   if (size && !callee_alloc)
 805     {
 806       /* If or_expr is true, then the extent in at least one
 807          dimension is zero and the size is set to zero.  */
 808       size = fold_build3 (COND_EXPR, gfc_array_index_type,
 809                           or_expr, gfc_index_zero_node, size);
 810
 811       nelem = size;
 812       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 813                 fold_convert (gfc_array_index_type,
 814                               TYPE_SIZE_UNIT (gfc_get_element_type (type))));
 815     }
 816   else
 817     {
 818       nelem = size;
 819       size = NULL_TREE;
 820     }
 821
 822   gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
 823                                     dynamic, dealloc);
 824
 825   if (info->dimen > loop->temp_dim)
 826     loop->temp_dim = info->dimen;
 827
 828   return size;
 829 }
 830
 831
 832 /* Generate code to transpose array EXPR by creating a new descriptor
 833    in which the dimension specifications have been reversed.  */
 834
 835 void
 836 gfc_conv_array_transpose (gfc_se * se, gfc_expr * expr)
 837 {
 838   tree dest, src, dest_index, src_index;
 839   gfc_loopinfo *loop;
 840   gfc_ss_info *dest_info;
 841   gfc_ss *dest_ss, *src_ss;
 842   gfc_se src_se;
 843   int n;
 844
 845   loop = se->loop;
 846
 847   src_ss = gfc_walk_expr (expr);
 848   dest_ss = se->ss;
 849
 850   dest_info = &dest_ss->data.info;
 851   gcc_assert (dest_info->dimen == 2);
 852
 853   /* Get a descriptor for EXPR.  */
 854   gfc_init_se (&src_se, NULL);
 855   gfc_conv_expr_descriptor (&src_se, expr, src_ss);
 856   gfc_add_block_to_block (&se->pre, &src_se.pre);
 857   gfc_add_block_to_block (&se->post, &src_se.post);
 858   src = src_se.expr;
 859
 860   /* Allocate a new descriptor for the return value.  */
 861   dest = gfc_create_var (TREE_TYPE (src), "atmp");
 862   dest_info->descriptor = dest;
 863   se->expr = dest;
 864
 865   /* Copy across the dtype field.  */
 866   gfc_add_modify (&se->pre,
 867                        gfc_conv_descriptor_dtype (dest),
 868                        gfc_conv_descriptor_dtype (src));
 869
 870   /* Copy the dimension information, renumbering dimension 1 to 0 and
 871      0 to 1.  */
 872   for (n = 0; n < 2; n++)
 873     {
 874       dest_info->delta[n] = gfc_index_zero_node;
 875       dest_info->start[n] = gfc_index_zero_node;
 876       dest_info->end[n] = gfc_index_zero_node;
 877       dest_info->stride[n] = gfc_index_one_node;
 878       dest_info->dim[n] = n;
 879
 880       dest_index = gfc_rank_cst[n];
 881       src_index = gfc_rank_cst[1 - n];
 882
 883       gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
 884                            gfc_conv_descriptor_stride_get (src, src_index));
 885
 886       gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
 887                            gfc_conv_descriptor_lbound_get (src, src_index));
 888
 889       gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
 890                            gfc_conv_descriptor_ubound_get (src, src_index));
 891
 892       if (!loop->to[n])
 893         {
 894           gcc_assert (integer_zerop (loop->from[n]));
 895           loop->to[n] =
 896             fold_build2 (MINUS_EXPR, gfc_array_index_type,
 897                          gfc_conv_descriptor_ubound_get (dest, dest_index),
 898                          gfc_conv_descriptor_lbound_get (dest, dest_index));
 899         }
 900     }
 901
 902   /* Copy the data pointer.  */
 903   dest_info->data = gfc_conv_descriptor_data_get (src);
 904   gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
 905
 906   /* Copy the offset.  This is not changed by transposition; the top-left
 907      element is still at the same offset as before, except where the loop
 908      starts at zero.  */
 909   if (!integer_zerop (loop->from[0]))
 910     dest_info->offset = gfc_conv_descriptor_offset_get (src);
 911   else
 912     dest_info->offset = gfc_index_zero_node;
 913
 914   gfc_conv_descriptor_offset_set (&se->pre, dest,
 915                                   dest_info->offset);
 916
 917   if (dest_info->dimen > loop->temp_dim)
 918     loop->temp_dim = dest_info->dimen;
 919 }
 920
 921
 922 /* Return the number of iterations in a loop that starts at START,
 923    ends at END, and has step STEP.  */
 924
 925 static tree
 926 gfc_get_iteration_count (tree start, tree end, tree step)
 927 {
 928   tree tmp;
 929   tree type;
 930
 931   type = TREE_TYPE (step);
 932   tmp = fold_build2 (MINUS_EXPR, type, end, start);
 933   tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
 934   tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
 935   tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
 936   return fold_convert (gfc_array_index_type, tmp);
 937 }
 938
 939
 940 /* Extend the data in array DESC by EXTRA elements.  */
 941
 942 static void
 943 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
 944 {
 945   tree arg0, arg1;
 946   tree tmp;
 947   tree size;
 948   tree ubound;
 949
 950   if (integer_zerop (extra))
 951     return;
 952
 953   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
 954
 955   /* Add EXTRA to the upper bound.  */
 956   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
 957   gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
 958
 959   /* Get the value of the current data pointer.  */
 960   arg0 = gfc_conv_descriptor_data_get (desc);
 961
 962   /* Calculate the new array size.  */
 963   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
 964   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
 965                      ubound, gfc_index_one_node);
 966   arg1 = fold_build2 (MULT_EXPR, size_type_node,
 967                        fold_convert (size_type_node, tmp),
 968                        fold_convert (size_type_node, size));
 969
 970   /* Call the realloc() function.  */
 971   tmp = gfc_call_realloc (pblock, arg0, arg1);
 972   gfc_conv_descriptor_data_set (pblock, desc, tmp);
 973 }
 974
 975
 976 /* Return true if the bounds of iterator I can only be determined
 977    at run time.  */
 978
 979 static inline bool
 980 gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
 981 {
 982   return (i->start->expr_type != EXPR_CONSTANT
 983           || i->end->expr_type != EXPR_CONSTANT
 984           || i->step->expr_type != EXPR_CONSTANT);
 985 }
 986
 987
 988 /* Split the size of constructor element EXPR into the sum of two terms,
 989    one of which can be determined at compile time and one of which must
 990    be calculated at run time.  Set *SIZE to the former and return true
 991    if the latter might be nonzero.  */
 992
 993 static bool
 994 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
 995 {
 996   if (expr->expr_type == EXPR_ARRAY)
 997     return gfc_get_array_constructor_size (size, expr->value.constructor);
 998   else if (expr->rank > 0)
 999     {
1000       /* Calculate everything at run time.  */
1001       mpz_set_ui (*size, 0);
1002       return true;
1003     }
1004   else
1005     {
1006       /* A single element.  */
1007       mpz_set_ui (*size, 1);
1008       return false;
1009     }
1010 }
1011
1012
1013 /* Like gfc_get_array_constructor_element_size, but applied to the whole
1014    of array constructor C.  */
1015
1016 static bool
1017 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
1018 {
1019   gfc_iterator *i;
1020   mpz_t val;
1021   mpz_t len;
1022   bool dynamic;
1023
1024   mpz_set_ui (*size, 0);
1025   mpz_init (len);
1026   mpz_init (val);
1027
1028   dynamic = false;
1029   for (; c; c = c->next)
1030     {
1031       i = c->iterator;
1032       if (i && gfc_iterator_has_dynamic_bounds (i))
1033         dynamic = true;
1034       else
1035         {
1036           dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
1037           if (i)
1038             {
1039               /* Multiply the static part of the element size by the
1040                  number of iterations.  */
1041               mpz_sub (val, i->end->value.integer, i->start->value.integer);
1042               mpz_fdiv_q (val, val, i->step->value.integer);
1043               mpz_add_ui (val, val, 1);
1044               if (mpz_sgn (val) > 0)
1045                 mpz_mul (len, len, val);
1046               else
1047                 mpz_set_ui (len, 0);
1048             }
1049           mpz_add (*size, *size, len);
1050         }
1051     }
1052   mpz_clear (len);
1053   mpz_clear (val);
1054   return dynamic;
1055 }
1056
1057
1058 /* Make sure offset is a variable.  */
1059
1060 static void
1061 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1062                          tree * offsetvar)
1063 {
1064   /* We should have already created the offset variable.  We cannot
1065      create it here because we may be in an inner scope.  */
1066   gcc_assert (*offsetvar != NULL_TREE);
1067   gfc_add_modify (pblock, *offsetvar, *poffset);
1068   *poffset = *offsetvar;
1069   TREE_USED (*offsetvar) = 1;
1070 }
1071
1072
1073 /* Variables needed for bounds-checking.  */
1074 static bool first_len;
1075 static tree first_len_val;
1076 static bool typespec_chararray_ctor;
1077
1078 static void
1079 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1080                               tree offset, gfc_se * se, gfc_expr * expr)
1081 {
1082   tree tmp;
1083
1084   gfc_conv_expr (se, expr);
1085
1086   /* Store the value.  */
1087   tmp = build_fold_indirect_ref_loc (input_location,
1088                                  gfc_conv_descriptor_data_get (desc));
1089   tmp = gfc_build_array_ref (tmp, offset, NULL);
1090
1091   if (expr->ts.type == BT_CHARACTER)
1092     {
1093       int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1094       tree esize;
1095
1096       esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
1097       esize = fold_convert (gfc_charlen_type_node, esize);
1098       esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
1099                            build_int_cst (gfc_charlen_type_node,
1100                                           gfc_character_kinds[i].bit_size / 8));
1101
1102       gfc_conv_string_parameter (se);
1103       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1104         {
1105           /* The temporary is an array of pointers.  */
1106           se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1107           gfc_add_modify (&se->pre, tmp, se->expr);
1108         }
1109       else
1110         {
1111           /* The temporary is an array of string values.  */
1112           tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1113           /* We know the temporary and the value will be the same length,
1114              so can use memcpy.  */
1115           gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1116                                  se->string_length, se->expr, expr->ts.kind);
1117         }
1118       if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1119         {
1120           if (first_len)
1121             {
1122               gfc_add_modify (&se->pre, first_len_val,
1123                                    se->string_length);
1124               first_len = false;
1125             }
1126           else
1127             {
1128               /* Verify that all constructor elements are of the same
1129                  length.  */
1130               tree cond = fold_build2 (NE_EXPR, boolean_type_node,
1131                                        first_len_val, se->string_length);
1132               gfc_trans_runtime_check
1133                 (true, false, cond, &se->pre, &expr->where,
1134                  "Different CHARACTER lengths (%ld/%ld) in array constructor",
1135                  fold_convert (long_integer_type_node, first_len_val),
1136                  fold_convert (long_integer_type_node, se->string_length));
1137             }
1138         }
1139     }
1140   else
1141     {
1142       /* TODO: Should the frontend already have done this conversion?  */
1143       se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1144       gfc_add_modify (&se->pre, tmp, se->expr);
1145     }
1146
1147   gfc_add_block_to_block (pblock, &se->pre);
1148   gfc_add_block_to_block (pblock, &se->post);
1149 }
1150
1151
1152 /* Add the contents of an array to the constructor.  DYNAMIC is as for
1153    gfc_trans_array_constructor_value.  */
1154
1155 static void
1156 gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1157                                       tree type ATTRIBUTE_UNUSED,
1158                                       tree desc, gfc_expr * expr,
1159                                       tree * poffset, tree * offsetvar,
1160                                       bool dynamic)
1161 {
1162   gfc_se se;
1163   gfc_ss *ss;
1164   gfc_loopinfo loop;
1165   stmtblock_t body;
1166   tree tmp;
1167   tree size;
1168   int n;
1169
1170   /* We need this to be a variable so we can increment it.  */
1171   gfc_put_offset_into_var (pblock, poffset, offsetvar);
1172
1173   gfc_init_se (&se, NULL);
1174
1175   /* Walk the array expression.  */
1176   ss = gfc_walk_expr (expr);
1177   gcc_assert (ss != gfc_ss_terminator);
1178
1179   /* Initialize the scalarizer.  */
1180   gfc_init_loopinfo (&loop);
1181   gfc_add_ss_to_loop (&loop, ss);
1182
1183   /* Initialize the loop.  */
1184   gfc_conv_ss_startstride (&loop);
1185   gfc_conv_loop_setup (&loop, &expr->where);
1186
1187   /* Make sure the constructed array has room for the new data.  */
1188   if (dynamic)
1189     {
1190       /* Set SIZE to the total number of elements in the subarray.  */
1191       size = gfc_index_one_node;
1192       for (n = 0; n < loop.dimen; n++)
1193         {
1194           tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
1195                                          gfc_index_one_node);
1196           size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1197         }
1198
1199       /* Grow the constructed array by SIZE elements.  */
1200       gfc_grow_array (&loop.pre, desc, size);
1201     }
1202
1203   /* Make the loop body.  */
1204   gfc_mark_ss_chain_used (ss, 1);
1205   gfc_start_scalarized_body (&loop, &body);
1206   gfc_copy_loopinfo_to_se (&se, &loop);
1207   se.ss = ss;
1208
1209   gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
1210   gcc_assert (se.ss == gfc_ss_terminator);
1211
1212   /* Increment the offset.  */
1213   tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1214                      *poffset, gfc_index_one_node);
1215   gfc_add_modify (&body, *poffset, tmp);
1216
1217   /* Finish the loop.  */
1218   gfc_trans_scalarizing_loops (&loop, &body);
1219   gfc_add_block_to_block (&loop.pre, &loop.post);
1220   tmp = gfc_finish_block (&loop.pre);
1221   gfc_add_expr_to_block (pblock, tmp);
1222
1223   gfc_cleanup_loop (&loop);
1224 }
1225
1226
1227 /* Assign the values to the elements of an array constructor.  DYNAMIC
1228    is true if descriptor DESC only contains enough data for the static
1229    size calculated by gfc_get_array_constructor_size.  When true, memory
1230    for the dynamic parts must be allocated using realloc.  */
1231
1232 static void
1233 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
1234                                    tree desc, gfc_constructor * c,
1235                                    tree * poffset, tree * offsetvar,
1236                                    bool dynamic)
1237 {
1238   tree tmp;
1239   stmtblock_t body;
1240   gfc_se se;
1241   mpz_t size;
1242
1243   tree shadow_loopvar = NULL_TREE;
1244   gfc_saved_var saved_loopvar;
1245
1246   mpz_init (size);
1247   for (; c; c = c->next)
1248     {
1249       /* If this is an iterator or an array, the offset must be a variable.  */
1250       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
1251         gfc_put_offset_into_var (pblock, poffset, offsetvar);
1252
1253       /* Shadowing the iterator avoids changing its value and saves us from
1254          keeping track of it. Further, it makes sure that there's always a
1255          backend-decl for the symbol, even if there wasn't one before,
1256          e.g. in the case of an iterator that appears in a specification
1257          expression in an interface mapping.  */
1258       if (c->iterator)
1259         {
1260           gfc_symbol *sym = c->iterator->var->symtree->n.sym;
1261           tree type = gfc_typenode_for_spec (&sym->ts);
1262
1263           shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
1264           gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
1265         }
1266
1267       gfc_start_block (&body);
1268
1269       if (c->expr->expr_type == EXPR_ARRAY)
1270         {
1271           /* Array constructors can be nested.  */
1272           gfc_trans_array_constructor_value (&body, type, desc,
1273                                              c->expr->value.constructor,
1274                                              poffset, offsetvar, dynamic);
1275         }
1276       else if (c->expr->rank > 0)
1277         {
1278           gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
1279                                                 poffset, offsetvar, dynamic);
1280         }
1281       else
1282         {
1283           /* This code really upsets the gimplifier so don't bother for now.  */
1284           gfc_constructor *p;
1285           HOST_WIDE_INT n;
1286           HOST_WIDE_INT size;
1287
1288           p = c;
1289           n = 0;
1290           while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
1291             {
1292               p = p->next;
1293               n++;
1294             }
1295           if (n < 4)
1296             {
1297               /* Scalar values.  */
1298               gfc_init_se (&se, NULL);
1299               gfc_trans_array_ctor_element (&body, desc, *poffset,
1300                                             &se, c->expr);
1301
1302               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1303                                       *poffset, gfc_index_one_node);
1304             }
1305           else
1306             {
1307               /* Collect multiple scalar constants into a constructor.  */
1308               tree list;
1309               tree init;
1310               tree bound;
1311               tree tmptype;
1312               HOST_WIDE_INT idx = 0;
1313
1314               p = c;
1315               list = NULL_TREE;
1316               /* Count the number of consecutive scalar constants.  */
1317               while (p && !(p->iterator
1318                             || p->expr->expr_type != EXPR_CONSTANT))
1319                 {
1320                   gfc_init_se (&se, NULL);
1321                   gfc_conv_constant (&se, p->expr);
1322
1323                   if (c->expr->ts.type != BT_CHARACTER)
1324                     se.expr = fold_convert (type, se.expr);
1325                   /* For constant character array constructors we build
1326                      an array of pointers.  */
1327                   else if (POINTER_TYPE_P (type))
1328                     se.expr = gfc_build_addr_expr
1329                                 (gfc_get_pchar_type (p->expr->ts.kind),
1330                                  se.expr);
1331
1332                   list = tree_cons (build_int_cst (gfc_array_index_type,
1333                                                    idx++), se.expr, list);
1334                   c = p;
1335                   p = p->next;
1336                 }
1337
1338               bound = build_int_cst (NULL_TREE, n - 1);
1339               /* Create an array type to hold them.  */
1340               tmptype = build_range_type (gfc_array_index_type,
1341                                           gfc_index_zero_node, bound);
1342               tmptype = build_array_type (type, tmptype);
1343
1344               init = build_constructor_from_list (tmptype, nreverse (list));
1345               TREE_CONSTANT (init) = 1;
1346               TREE_STATIC (init) = 1;
1347               /* Create a static variable to hold the data.  */
1348               tmp = gfc_create_var (tmptype, "data");
1349               TREE_STATIC (tmp) = 1;
1350               TREE_CONSTANT (tmp) = 1;
1351               TREE_READONLY (tmp) = 1;
1352               DECL_INITIAL (tmp) = init;
1353               init = tmp;
1354
1355               /* Use BUILTIN_MEMCPY to assign the values.  */
1356               tmp = gfc_conv_descriptor_data_get (desc);
1357               tmp = build_fold_indirect_ref_loc (input_location,
1358                                              tmp);
1359               tmp = gfc_build_array_ref (tmp, *poffset, NULL);
1360               tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1361               init = gfc_build_addr_expr (NULL_TREE, init);
1362
1363               size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
1364               bound = build_int_cst (NULL_TREE, n * size);
1365               tmp = build_call_expr_loc (input_location,
1366                                      built_in_decls[BUILT_IN_MEMCPY], 3,
1367                                      tmp, init, bound);
1368               gfc_add_expr_to_block (&body, tmp);
1369
1370               *poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1371                                       *poffset,
1372                                       build_int_cst (gfc_array_index_type, n));
1373             }
1374           if (!INTEGER_CST_P (*poffset))
1375             {
1376               gfc_add_modify (&body, *offsetvar, *poffset);
1377               *poffset = *offsetvar;
1378             }
1379         }
1380
1381       /* The frontend should already have done any expansions
1382          at compile-time.  */
1383       if (!c->iterator)
1384         {
1385           /* Pass the code as is.  */
1386           tmp = gfc_finish_block (&body);
1387           gfc_add_expr_to_block (pblock, tmp);
1388         }
1389       else
1390         {
1391           /* Build the implied do-loop.  */
1392           stmtblock_t implied_do_block;
1393           tree cond;
1394           tree end;
1395           tree step;
1396           tree exit_label;
1397           tree loopbody;
1398           tree tmp2;
1399
1400           loopbody = gfc_finish_block (&body);
1401
1402           /* Create a new block that holds the implied-do loop. A temporary
1403              loop-variable is used.  */
1404           gfc_start_block(&implied_do_block);
1405
1406           /* Initialize the loop.  */
1407           gfc_init_se (&se, NULL);
1408           gfc_conv_expr_val (&se, c->iterator->start);
1409           gfc_add_block_to_block (&implied_do_block, &se.pre);
1410           gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
1411
1412           gfc_init_se (&se, NULL);
1413           gfc_conv_expr_val (&se, c->iterator->end);
1414           gfc_add_block_to_block (&implied_do_block, &se.pre);
1415           end = gfc_evaluate_now (se.expr, &implied_do_block);
1416
1417           gfc_init_se (&se, NULL);
1418           gfc_conv_expr_val (&se, c->iterator->step);
1419           gfc_add_block_to_block (&implied_do_block, &se.pre);
1420           step = gfc_evaluate_now (se.expr, &implied_do_block);
1421
1422           /* If this array expands dynamically, and the number of iterations
1423              is not constant, we won't have allocated space for the static
1424              part of C->EXPR's size.  Do that now.  */
1425           if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
1426             {
1427               /* Get the number of iterations.  */
1428               tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
1429
1430               /* Get the static part of C->EXPR's size.  */
1431               gfc_get_array_constructor_element_size (&size, c->expr);
1432               tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1433
1434               /* Grow the array by TMP * TMP2 elements.  */
1435               tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
1436               gfc_grow_array (&implied_do_block, desc, tmp);
1437             }
1438
1439           /* Generate the loop body.  */
1440           exit_label = gfc_build_label_decl (NULL_TREE);
1441           gfc_start_block (&body);
1442
1443           /* Generate the exit condition.  Depending on the sign of
1444              the step variable we have to generate the correct
1445              comparison.  */
1446           tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
1447                              build_int_cst (TREE_TYPE (step), 0));
1448           cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
1449                               fold_build2 (GT_EXPR, boolean_type_node,
1450                                            shadow_loopvar, end),
1451                               fold_build2 (LT_EXPR, boolean_type_node,
1452                                            shadow_loopvar, end));
1453           tmp = build1_v (GOTO_EXPR, exit_label);
1454           TREE_USED (exit_label) = 1;
1455           tmp = build3_v (COND_EXPR, cond, tmp,
1456                           build_empty_stmt (input_location));
1457           gfc_add_expr_to_block (&body, tmp);
1458
1459           /* The main loop body.  */
1460           gfc_add_expr_to_block (&body, loopbody);
1461
1462           /* Increase loop variable by step.  */
1463           tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
1464           gfc_add_modify (&body, shadow_loopvar, tmp);
1465
1466           /* Finish the loop.  */
1467           tmp = gfc_finish_block (&body);
1468           tmp = build1_v (LOOP_EXPR, tmp);
1469           gfc_add_expr_to_block (&implied_do_block, tmp);
1470
1471           /* Add the exit label.  */
1472           tmp = build1_v (LABEL_EXPR, exit_label);
1473           gfc_add_expr_to_block (&implied_do_block, tmp);
1474
1475           /* Finishe the implied-do loop.  */
1476           tmp = gfc_finish_block(&implied_do_block);
1477           gfc_add_expr_to_block(pblock, tmp);
1478
1479           gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
1480         }
1481     }
1482   mpz_clear (size);
1483 }
1484
1485
1486 /* Figure out the string length of a variable reference expression.
1487    Used by get_array_ctor_strlen.  */
1488
1489 static void
1490 get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
1491 {
1492   gfc_ref *ref;
1493   gfc_typespec *ts;
1494   mpz_t char_len;
1495
1496   /* Don't bother if we already know the length is a constant.  */
1497   if (*len && INTEGER_CST_P (*len))
1498     return;
1499
1500   ts = &expr->symtree->n.sym->ts;
1501   for (ref = expr->ref; ref; ref = ref->next)
1502     {
1503       switch (ref->type)
1504         {
1505         case REF_ARRAY:
1506           /* Array references don't change the string length.  */
1507           break;
1508
1509         case REF_COMPONENT:
1510           /* Use the length of the component.  */
1511           ts = &ref->u.c.component->ts;
1512           break;
1513
1514         case REF_SUBSTRING:
1515           if (ref->u.ss.start->expr_type != EXPR_CONSTANT
1516               || ref->u.ss.end->expr_type != EXPR_CONSTANT)
1517             break;
1518           mpz_init_set_ui (char_len, 1);
1519           mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
1520           mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
1521           *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
1522           *len = convert (gfc_charlen_type_node, *len);
1523           mpz_clear (char_len);
1524           return;
1525
1526         default:
1527           /* TODO: Substrings are tricky because we can't evaluate the
1528              expression more than once.  For now we just give up, and hope
1529              we can figure it out elsewhere.  */
1530           return;
1531         }
1532     }
1533
1534   *len = ts->u.cl->backend_decl;
1535 }
1536
1537
1538 /* A catch-all to obtain the string length for anything that is not a
1539    constant, array or variable.  */
1540 static void
1541 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
1542 {
1543   gfc_se se;
1544   gfc_ss *ss;
1545
1546   /* Don't bother if we already know the length is a constant.  */
1547   if (*len && INTEGER_CST_P (*len))
1548     return;
1549
1550   if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
1551         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1552     {
1553       /* This is easy.  */
1554       gfc_conv_const_charlen (e->ts.u.cl);
1555       *len = e->ts.u.cl->backend_decl;
1556     }
1557   else
1558     {
1559       /* Otherwise, be brutal even if inefficient.  */
1560       ss = gfc_walk_expr (e);
1561       gfc_init_se (&se, NULL);
1562
1563       /* No function call, in case of side effects.  */
1564       se.no_function_call = 1;
1565       if (ss == gfc_ss_terminator)
1566         gfc_conv_expr (&se, e);
1567       else
1568         gfc_conv_expr_descriptor (&se, e, ss);
1569
1570       /* Fix the value.  */
1571       *len = gfc_evaluate_now (se.string_length, &se.pre);
1572
1573       gfc_add_block_to_block (block, &se.pre);
1574       gfc_add_block_to_block (block, &se.post);
1575
1576       e->ts.u.cl->backend_decl = *len;
1577     }
1578 }
1579
1580
1581 /* Figure out the string length of a character array constructor.
1582    If len is NULL, don't calculate the length; this happens for recursive calls
1583    when a sub-array-constructor is an element but not at the first position,
1584    so when we're not interested in the length.
1585    Returns TRUE if all elements are character constants.  */
1586
1587 bool
1588 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
1589 {
1590   bool is_const;
1591
1592   is_const = TRUE;
1593
1594   if (c == NULL)
1595     {
1596       if (len)
1597         *len = build_int_cstu (gfc_charlen_type_node, 0);
1598       return is_const;
1599     }
1600
1601   /* Loop over all constructor elements to find out is_const, but in len we
1602      want to store the length of the first, not the last, element.  We can
1603      of course exit the loop as soon as is_const is found to be false.  */
1604   for (; c && is_const; c = c->next)
1605     {
1606       switch (c->expr->expr_type)
1607         {
1608         case EXPR_CONSTANT:
1609           if (len && !(*len && INTEGER_CST_P (*len)))
1610             *len = build_int_cstu (gfc_charlen_type_node,
1611                                    c->expr->value.character.length);
1612           break;
1613
1614         case EXPR_ARRAY:
1615           if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
1616             is_const = false;
1617           break;
1618
1619         case EXPR_VARIABLE:
1620           is_const = false;
1621           if (len)
1622             get_array_ctor_var_strlen (c->expr, len);
1623           break;
1624
1625         default:
1626           is_const = false;
1627           if (len)
1628             get_array_ctor_all_strlen (block, c->expr, len);
1629           break;
1630         }
1631
1632       /* After the first iteration, we don't want the length modified.  */
1633       len = NULL;
1634     }
1635
1636   return is_const;
1637 }
1638
1639 /* Check whether the array constructor C consists entirely of constant
1640    elements, and if so returns the number of those elements, otherwise
1641    return zero.  Note, an empty or NULL array constructor returns zero.  */
1642
1643 unsigned HOST_WIDE_INT
1644 gfc_constant_array_constructor_p (gfc_constructor * c)
1645 {
1646   unsigned HOST_WIDE_INT nelem = 0;
1647
1648   while (c)
1649     {
1650       if (c->iterator
1651           || c->expr->rank > 0
1652           || c->expr->expr_type != EXPR_CONSTANT)
1653         return 0;
1654       c = c->next;
1655       nelem++;
1656     }
1657   return nelem;
1658 }
1659
1660
1661 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
1662    and the tree type of it's elements, TYPE, return a static constant
1663    variable that is compile-time initialized.  */
1664
1665 tree
1666 gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
1667 {
1668   tree tmptype, list, init, tmp;
1669   HOST_WIDE_INT nelem;
1670   gfc_constructor *c;
1671   gfc_array_spec as;
1672   gfc_se se;
1673   int i;
1674
1675   /* First traverse the constructor list, converting the constants
1676      to tree to build an initializer.  */
1677   nelem = 0;
1678   list = NULL_TREE;
1679   c = expr->value.constructor;
1680   while (c)
1681     {
1682       gfc_init_se (&se, NULL);
1683       gfc_conv_constant (&se, c->expr);
1684       if (c->expr->ts.type != BT_CHARACTER)
1685         se.expr = fold_convert (type, se.expr);
1686       else if (POINTER_TYPE_P (type))
1687         se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
1688                                        se.expr);
1689       list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
1690                         se.expr, list);
1691       c = c->next;
1692       nelem++;
1693     }
1694
1695   /* Next determine the tree type for the array.  We use the gfortran
1696      front-end's gfc_get_nodesc_array_type in order to create a suitable
1697      GFC_ARRAY_TYPE_P that may be used by the scalarizer.  */
1698
1699   memset (&as, 0, sizeof (gfc_array_spec));
1700
1701   as.rank = expr->rank;
1702   as.type = AS_EXPLICIT;
1703   if (!expr->shape)
1704     {
1705       as.lower[0] = gfc_int_expr (0);
1706       as.upper[0] = gfc_int_expr (nelem - 1);
1707     }
1708   else
1709     for (i = 0; i < expr->rank; i++)
1710       {
1711         int tmp = (int) mpz_get_si (expr->shape[i]);
1712         as.lower[i] = gfc_int_expr (0);
1713         as.upper[i] = gfc_int_expr (tmp - 1);
1714       }
1715
1716   tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
1717
1718   init = build_constructor_from_list (tmptype, nreverse (list));
1719
1720   TREE_CONSTANT (init) = 1;
1721   TREE_STATIC (init) = 1;
1722
1723   tmp = gfc_create_var (tmptype, "A");
1724   TREE_STATIC (tmp) = 1;
1725   TREE_CONSTANT (tmp) = 1;
1726   TREE_READONLY (tmp) = 1;
1727   DECL_INITIAL (tmp) = init;
1728
1729   return tmp;
1730 }
1731
1732
1733 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
1734    This mostly initializes the scalarizer state info structure with the
1735    appropriate values to directly use the array created by the function
1736    gfc_build_constant_array_constructor.  */
1737
1738 static void
1739 gfc_trans_constant_array_constructor (gfc_loopinfo * loop,
1740                                       gfc_ss * ss, tree type)
1741 {
1742   gfc_ss_info *info;
1743   tree tmp;
1744   int i;
1745
1746   tmp = gfc_build_constant_array_constructor (ss->expr, type);
1747
1748   info = &ss->data.info;
1749
1750   info->descriptor = tmp;
1751   info->data = gfc_build_addr_expr (NULL_TREE, tmp);
1752   info->offset = gfc_index_zero_node;
1753
1754   for (i = 0; i < info->dimen; i++)
1755     {
1756       info->delta[i] = gfc_index_zero_node;
1757       info->start[i] = gfc_index_zero_node;
1758       info->end[i] = gfc_index_zero_node;
1759       info->stride[i] = gfc_index_one_node;
1760       info->dim[i] = i;
1761     }
1762
1763   if (info->dimen > loop->temp_dim)
1764     loop->temp_dim = info->dimen;
1765 }
1766
1767 /* Helper routine of gfc_trans_array_constructor to determine if the
1768    bounds of the loop specified by LOOP are constant and simple enough
1769    to use with gfc_trans_constant_array_constructor.  Returns the
1770    iteration count of the loop if suitable, and NULL_TREE otherwise.  */
1771
1772 static tree
1773 constant_array_constructor_loop_size (gfc_loopinfo * loop)
1774 {
1775   tree size = gfc_index_one_node;
1776   tree tmp;
1777   int i;
1778
1779   for (i = 0; i < loop->dimen; i++)
1780     {
1781       /* If the bounds aren't constant, return NULL_TREE.  */
1782       if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
1783         return NULL_TREE;
1784       if (!integer_zerop (loop->from[i]))
1785         {
1786           /* Only allow nonzero "from" in one-dimensional arrays.  */
1787           if (loop->dimen != 1)
1788             return NULL_TREE;
1789           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1790                              loop->to[i], loop->from[i]);
1791         }
1792       else
1793         tmp = loop->to[i];
1794       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1795                          tmp, gfc_index_one_node);
1796       size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1797     }
1798
1799   return size;
1800 }
1801
1802
1803 /* Array constructors are handled by constructing a temporary, then using that
1804    within the scalarization loop.  This is not optimal, but seems by far the
1805    simplest method.  */
1806
1807 static void
1808 gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
1809 {
1810   gfc_constructor *c;
1811   tree offset;
1812   tree offsetvar;
1813   tree desc;
1814   tree type;
1815   bool dynamic;
1816   bool old_first_len, old_typespec_chararray_ctor;
1817   tree old_first_len_val;
1818
1819   /* Save the old values for nested checking.  */
1820   old_first_len = first_len;
1821   old_first_len_val = first_len_val;
1822   old_typespec_chararray_ctor = typespec_chararray_ctor;
1823
1824   /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
1825      typespec was given for the array constructor.  */
1826   typespec_chararray_ctor = (ss->expr->ts.u.cl
1827                              && ss->expr->ts.u.cl->length_from_typespec);
1828
1829   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1830       && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
1831     {
1832       first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
1833       first_len = true;
1834     }
1835
1836   ss->data.info.dimen = loop->dimen;
1837
1838   c = ss->expr->value.constructor;
1839   if (ss->expr->ts.type == BT_CHARACTER)
1840     {
1841       bool const_string;
1842
1843       /* get_array_ctor_strlen walks the elements of the constructor, if a
1844          typespec was given, we already know the string length and want the one
1845          specified there.  */
1846       if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
1847           && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1848         {
1849           gfc_se length_se;
1850
1851           const_string = false;
1852           gfc_init_se (&length_se, NULL);
1853           gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
1854                               gfc_charlen_type_node);
1855           ss->string_length = length_se.expr;
1856           gfc_add_block_to_block (&loop->pre, &length_se.pre);
1857           gfc_add_block_to_block (&loop->post, &length_se.post);
1858         }
1859       else
1860         const_string = get_array_ctor_strlen (&loop->pre, c,
1861                                               &ss->string_length);
1862
1863       /* Complex character array constructors should have been taken care of
1864          and not end up here.  */
1865       gcc_assert (ss->string_length);
1866
1867       ss->expr->ts.u.cl->backend_decl = ss->string_length;
1868
1869       type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
1870       if (const_string)
1871         type = build_pointer_type (type);
1872     }
1873   else
1874     type = gfc_typenode_for_spec (&ss->expr->ts);
1875
1876   /* See if the constructor determines the loop bounds.  */
1877   dynamic = false;
1878
1879   if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
1880     {
1881       /* We have a multidimensional parameter.  */
1882       int n;
1883       for (n = 0; n < ss->expr->rank; n++)
1884       {
1885         loop->from[n] = gfc_index_zero_node;
1886         loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
1887                                             gfc_index_integer_kind);
1888         loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1889                                    loop->to[n], gfc_index_one_node);
1890       }
1891     }
1892
1893   if (loop->to[0] == NULL_TREE)
1894     {
1895       mpz_t size;
1896
1897       /* We should have a 1-dimensional, zero-based loop.  */
1898       gcc_assert (loop->dimen == 1);
1899       gcc_assert (integer_zerop (loop->from[0]));
1900
1901       /* Split the constructor size into a static part and a dynamic part.
1902          Allocate the static size up-front and record whether the dynamic
1903          size might be nonzero.  */
1904       mpz_init (size);
1905       dynamic = gfc_get_array_constructor_size (&size, c);
1906       mpz_sub_ui (size, size, 1);
1907       loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
1908       mpz_clear (size);
1909     }
1910
1911   /* Special case constant array constructors.  */
1912   if (!dynamic)
1913     {
1914       unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
1915       if (nelem > 0)
1916         {
1917           tree size = constant_array_constructor_loop_size (loop);
1918           if (size && compare_tree_int (size, nelem) == 0)
1919             {
1920               gfc_trans_constant_array_constructor (loop, ss, type);
1921               goto finish;
1922             }
1923         }
1924     }
1925
1926   gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
1927                                type, NULL_TREE, dynamic, true, false, where);
1928
1929   desc = ss->data.info.descriptor;
1930   offset = gfc_index_zero_node;
1931   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
1932   TREE_NO_WARNING (offsetvar) = 1;
1933   TREE_USED (offsetvar) = 0;
1934   gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
1935                                      &offset, &offsetvar, dynamic);
1936
1937   /* If the array grows dynamically, the upper bound of the loop variable
1938      is determined by the array's final upper bound.  */
1939   if (dynamic)
1940     loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
1941
1942   if (TREE_USED (offsetvar))
1943     pushdecl (offsetvar);
1944   else
1945     gcc_assert (INTEGER_CST_P (offset));
1946 #if 0
1947   /* Disable bound checking for now because it's probably broken.  */
1948   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1949     {
1950       gcc_unreachable ();
1951     }
1952 #endif
1953
1954 finish:
1955   /* Restore old values of globals.  */
1956   first_len = old_first_len;
1957   first_len_val = old_first_len_val;
1958   typespec_chararray_ctor = old_typespec_chararray_ctor;
1959 }
1960
1961
1962 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
1963    called after evaluating all of INFO's vector dimensions.  Go through
1964    each such vector dimension and see if we can now fill in any missing
1965    loop bounds.  */
1966
1967 static void
1968 gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info)
1969 {
1970   gfc_se se;
1971   tree tmp;
1972   tree desc;
1973   tree zero;
1974   int n;
1975   int dim;
1976
1977   for (n = 0; n < loop->dimen; n++)
1978     {
1979       dim = info->dim[n];
1980       if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
1981           && loop->to[n] == NULL)
1982         {
1983           /* Loop variable N indexes vector dimension DIM, and we don't
1984              yet know the upper bound of loop variable N.  Set it to the
1985              difference between the vector's upper and lower bounds.  */
1986           gcc_assert (loop->from[n] == gfc_index_zero_node);
1987           gcc_assert (info->subscript[dim]
1988                       && info->subscript[dim]->type == GFC_SS_VECTOR);
1989
1990           gfc_init_se (&se, NULL);
1991           desc = info->subscript[dim]->data.info.descriptor;
1992           zero = gfc_rank_cst[0];
1993           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1994                              gfc_conv_descriptor_ubound_get (desc, zero),
1995                              gfc_conv_descriptor_lbound_get (desc, zero));
1996           tmp = gfc_evaluate_now (tmp, &loop->pre);
1997           loop->to[n] = tmp;
1998         }
1999     }
2000 }
2001
2002
2003 /* Add the pre and post chains for all the scalar expressions in a SS chain
2004    to loop.  This is called after the loop parameters have been calculated,
2005    but before the actual scalarizing loops.  */
2006
2007 static void
2008 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
2009                       locus * where)
2010 {
2011   gfc_se se;
2012   int n;
2013
2014   /* TODO: This can generate bad code if there are ordering dependencies,
2015      e.g., a callee allocated function and an unknown size constructor.  */
2016   gcc_assert (ss != NULL);
2017
2018   for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
2019     {
2020       gcc_assert (ss);
2021
2022       switch (ss->type)
2023         {
2024         case GFC_SS_SCALAR:
2025           /* Scalar expression.  Evaluate this now.  This includes elemental
2026              dimension indices, but not array section bounds.  */
2027           gfc_init_se (&se, NULL);
2028           gfc_conv_expr (&se, ss->expr);
2029           gfc_add_block_to_block (&loop->pre, &se.pre);
2030
2031           if (ss->expr->ts.type != BT_CHARACTER)
2032             {
2033               /* Move the evaluation of scalar expressions outside the
2034                  scalarization loop, except for WHERE assignments.  */
2035               if (subscript)
2036                 se.expr = convert(gfc_array_index_type, se.expr);
2037               if (!ss->where)
2038                 se.expr = gfc_evaluate_now (se.expr, &loop->pre);
2039               gfc_add_block_to_block (&loop->pre, &se.post);
2040             }
2041           else
2042             gfc_add_block_to_block (&loop->post, &se.post);
2043
2044           ss->data.scalar.expr = se.expr;
2045           ss->string_length = se.string_length;
2046           break;
2047
2048         case GFC_SS_REFERENCE:
2049           /* Scalar reference.  Evaluate this now.  */
2050           gfc_init_se (&se, NULL);
2051           gfc_conv_expr_reference (&se, ss->expr);
2052           gfc_add_block_to_block (&loop->pre, &se.pre);
2053           gfc_add_block_to_block (&loop->post, &se.post);
2054
2055           ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
2056           ss->string_length = se.string_length;
2057           break;
2058
2059         case GFC_SS_SECTION:
2060           /* Add the expressions for scalar and vector subscripts.  */
2061           for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2062             if (ss->data.info.subscript[n])
2063               gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
2064                                     where);
2065
2066           gfc_set_vector_loop_bounds (loop, &ss->data.info);
2067           break;
2068
2069         case GFC_SS_VECTOR:
2070           /* Get the vector's descriptor and store it in SS.  */
2071           gfc_init_se (&se, NULL);
2072           gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr));
2073           gfc_add_block_to_block (&loop->pre, &se.pre);
2074           gfc_add_block_to_block (&loop->post, &se.post);
2075           ss->data.info.descriptor = se.expr;
2076           break;
2077
2078         case GFC_SS_INTRINSIC:
2079           gfc_add_intrinsic_ss_code (loop, ss);
2080           break;
2081
2082         case GFC_SS_FUNCTION:
2083           /* Array function return value.  We call the function and save its
2084              result in a temporary for use inside the loop.  */
2085           gfc_init_se (&se, NULL);
2086           se.loop = loop;
2087           se.ss = ss;
2088           gfc_conv_expr (&se, ss->expr);
2089           gfc_add_block_to_block (&loop->pre, &se.pre);
2090           gfc_add_block_to_block (&loop->post, &se.post);
2091           ss->string_length = se.string_length;
2092           break;
2093
2094         case GFC_SS_CONSTRUCTOR:
2095           if (ss->expr->ts.type == BT_CHARACTER
2096                 && ss->string_length == NULL
2097                 && ss->expr->ts.u.cl
2098                 && ss->expr->ts.u.cl->length)
2099             {
2100               gfc_init_se (&se, NULL);
2101               gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
2102                                   gfc_charlen_type_node);
2103               ss->string_length = se.expr;
2104               gfc_add_block_to_block (&loop->pre, &se.pre);
2105               gfc_add_block_to_block (&loop->post, &se.post);
2106             }
2107           gfc_trans_array_constructor (loop, ss, where);
2108           break;
2109
2110         case GFC_SS_TEMP:
2111         case GFC_SS_COMPONENT:
2112           /* Do nothing.  These are handled elsewhere.  */
2113           break;
2114
2115         default:
2116           gcc_unreachable ();
2117         }
2118     }
2119 }
2120
2121
2122 /* Translate expressions for the descriptor and data pointer of a SS.  */
2123 /*GCC ARRAYS*/
2124
2125 static void
2126 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
2127 {
2128   gfc_se se;
2129   tree tmp;
2130
2131   /* Get the descriptor for the array to be scalarized.  */
2132   gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
2133   gfc_init_se (&se, NULL);
2134   se.descriptor_only = 1;
2135   gfc_conv_expr_lhs (&se, ss->expr);
2136   gfc_add_block_to_block (block, &se.pre);
2137   ss->data.info.descriptor = se.expr;
2138   ss->string_length = se.string_length;
2139
2140   if (base)
2141     {
2142       /* Also the data pointer.  */
2143       tmp = gfc_conv_array_data (se.expr);
2144       /* If this is a variable or address of a variable we use it directly.
2145          Otherwise we must evaluate it now to avoid breaking dependency
2146          analysis by pulling the expressions for elemental array indices
2147          inside the loop.  */
2148       if (!(DECL_P (tmp)
2149             || (TREE_CODE (tmp) == ADDR_EXPR
2150                 && DECL_P (TREE_OPERAND (tmp, 0)))))
2151         tmp = gfc_evaluate_now (tmp, block);
2152       ss->data.info.data = tmp;
2153
2154       tmp = gfc_conv_array_offset (se.expr);
2155       ss->data.info.offset = gfc_evaluate_now (tmp, block);
2156     }
2157 }
2158
2159
2160 /* Initialize a gfc_loopinfo structure.  */
2161
2162 void
2163 gfc_init_loopinfo (gfc_loopinfo * loop)
2164 {
2165   int n;
2166
2167   memset (loop, 0, sizeof (gfc_loopinfo));
2168   gfc_init_block (&loop->pre);
2169   gfc_init_block (&loop->post);
2170
2171   /* Initially scalarize in order.  */
2172   for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
2173     loop->order[n] = n;
2174
2175   loop->ss = gfc_ss_terminator;
2176 }
2177
2178
2179 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS
2180    chain.  */
2181
2182 void
2183 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
2184 {
2185   se->loop = loop;
2186 }
2187
2188
2189 /* Return an expression for the data pointer of an array.  */
2190
2191 tree
2192 gfc_conv_array_data (tree descriptor)
2193 {
2194   tree type;
2195
2196   type = TREE_TYPE (descriptor);
2197   if (GFC_ARRAY_TYPE_P (type))
2198     {
2199       if (TREE_CODE (type) == POINTER_TYPE)
2200         return descriptor;
2201       else
2202         {
2203           /* Descriptorless arrays.  */
2204           return gfc_build_addr_expr (NULL_TREE, descriptor);
2205         }
2206     }
2207   else
2208     return gfc_conv_descriptor_data_get (descriptor);
2209 }
2210
2211
2212 /* Return an expression for the base offset of an array.  */
2213
2214 tree
2215 gfc_conv_array_offset (tree descriptor)
2216 {
2217   tree type;
2218
2219   type = TREE_TYPE (descriptor);
2220   if (GFC_ARRAY_TYPE_P (type))
2221     return GFC_TYPE_ARRAY_OFFSET (type);
2222   else
2223     return gfc_conv_descriptor_offset_get (descriptor);
2224 }
2225
2226
2227 /* Get an expression for the array stride.  */
2228
2229 tree
2230 gfc_conv_array_stride (tree descriptor, int dim)
2231 {
2232   tree tmp;
2233   tree type;
2234
2235   type = TREE_TYPE (descriptor);
2236
2237   /* For descriptorless arrays use the array size.  */
2238   tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
2239   if (tmp != NULL_TREE)
2240     return tmp;
2241
2242   tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
2243   return tmp;
2244 }
2245
2246
2247 /* Like gfc_conv_array_stride, but for the lower bound.  */
2248
2249 tree
2250 gfc_conv_array_lbound (tree descriptor, int dim)
2251 {
2252   tree tmp;
2253   tree type;
2254
2255   type = TREE_TYPE (descriptor);
2256
2257   tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
2258   if (tmp != NULL_TREE)
2259     return tmp;
2260
2261   tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
2262   return tmp;
2263 }
2264
2265
2266 /* Like gfc_conv_array_stride, but for the upper bound.  */
2267
2268 tree
2269 gfc_conv_array_ubound (tree descriptor, int dim)
2270 {
2271   tree tmp;
2272   tree type;
2273
2274   type = TREE_TYPE (descriptor);
2275
2276   tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
2277   if (tmp != NULL_TREE)
2278     return tmp;
2279
2280   /* This should only ever happen when passing an assumed shape array
2281      as an actual parameter.  The value will never be used.  */
2282   if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
2283     return gfc_index_zero_node;
2284
2285   tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
2286   return tmp;
2287 }
2288
2289
2290 /* Generate code to perform an array index bound check.  */
2291
2292 static tree
2293 gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
2294                              locus * where, bool check_upper)
2295 {
2296   tree fault;
2297   tree tmp_lo, tmp_up;
2298   char *msg;
2299   const char * name = NULL;
2300
2301   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
2302     return index;
2303
2304   index = gfc_evaluate_now (index, &se->pre);
2305
2306   /* We find a name for the error message.  */
2307   if (se->ss)
2308     name = se->ss->expr->symtree->name;
2309
2310   if (!name && se->loop && se->loop->ss && se->loop->ss->expr
2311       && se->loop->ss->expr->symtree)
2312     name = se->loop->ss->expr->symtree->name;
2313
2314   if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2315       && se->loop->ss->loop_chain->expr
2316       && se->loop->ss->loop_chain->expr->symtree)
2317     name = se->loop->ss->loop_chain->expr->symtree->name;
2318
2319   if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
2320       && se->loop->ss->loop_chain->expr->symtree)
2321     name = se->loop->ss->loop_chain->expr->symtree->name;
2322
2323   if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
2324     {
2325       if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
2326           && se->loop->ss->expr->value.function.name)
2327         name = se->loop->ss->expr->value.function.name;
2328       else
2329         if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
2330             || se->loop->ss->type == GFC_SS_SCALAR)
2331           name = "unnamed constant";
2332     }
2333
2334   /* If upper bound is present, include both bounds in the error message.  */
2335   if (check_upper)
2336     {
2337       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2338       tmp_up = gfc_conv_array_ubound (descriptor, n);
2339
2340       if (name)
2341         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2342                   "outside of expected range (%%ld:%%ld)", n+1, name);
2343       else
2344         asprintf (&msg, "Index '%%ld' of dimension %d "
2345                   "outside of expected range (%%ld:%%ld)", n+1);
2346
2347       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2348       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2349                                fold_convert (long_integer_type_node, index),
2350                                fold_convert (long_integer_type_node, tmp_lo),
2351                                fold_convert (long_integer_type_node, tmp_up));
2352       fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
2353       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354                                fold_convert (long_integer_type_node, index),
2355                                fold_convert (long_integer_type_node, tmp_lo),
2356                                fold_convert (long_integer_type_node, tmp_up));
2357       gfc_free (msg);
2358     }
2359   else
2360     {
2361       tmp_lo = gfc_conv_array_lbound (descriptor, n);
2362
2363       if (name)
2364         asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2365                   "below lower bound of %%ld", n+1, name);
2366       else
2367         asprintf (&msg, "Index '%%ld' of dimension %d "
2368                   "below lower bound of %%ld", n+1);
2369
2370       fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
2371       gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2372                                fold_convert (long_integer_type_node, index),
2373                                fold_convert (long_integer_type_node, tmp_lo));
2374       gfc_free (msg);
2375     }
2376
2377   return index;
2378 }
2379
2380
2381 /* Return the offset for an index.  Performs bound checking for elemental
2382    dimensions.  Single element references are processed separately.  */
2383
2384 static tree
2385 gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
2386                              gfc_array_ref * ar, tree stride)
2387 {
2388   tree index;
2389   tree desc;
2390   tree data;
2391
2392   /* Get the index into the array for this dimension.  */
2393   if (ar)
2394     {
2395       gcc_assert (ar->type != AR_ELEMENT);
2396       switch (ar->dimen_type[dim])
2397         {
2398         case DIMEN_ELEMENT:
2399           /* Elemental dimension.  */
2400           gcc_assert (info->subscript[dim]
2401                       && info->subscript[dim]->type == GFC_SS_SCALAR);
2402           /* We've already translated this value outside the loop.  */
2403           index = info->subscript[dim]->data.scalar.expr;
2404
2405           index = gfc_trans_array_bound_check (se, info->descriptor,
2406                         index, dim, &ar->where,
2407                         (ar->as->type != AS_ASSUMED_SIZE
2408                          && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2409           break;
2410
2411         case DIMEN_VECTOR:
2412           gcc_assert (info && se->loop);
2413           gcc_assert (info->subscript[dim]
2414                       && info->subscript[dim]->type == GFC_SS_VECTOR);
2415           desc = info->subscript[dim]->data.info.descriptor;
2416
2417           /* Get a zero-based index into the vector.  */
2418           index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2419                                se->loop->loopvar[i], se->loop->from[i]);
2420
2421           /* Multiply the index by the stride.  */
2422           index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2423                                index, gfc_conv_array_stride (desc, 0));
2424
2425           /* Read the vector to get an index into info->descriptor.  */
2426           data = build_fold_indirect_ref_loc (input_location,
2427                                           gfc_conv_array_data (desc));
2428           index = gfc_build_array_ref (data, index, NULL);
2429           index = gfc_evaluate_now (index, &se->pre);
2430
2431           /* Do any bounds checking on the final info->descriptor index.  */
2432           index = gfc_trans_array_bound_check (se, info->descriptor,
2433                         index, dim, &ar->where,
2434                         (ar->as->type != AS_ASSUMED_SIZE
2435                          && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
2436           break;
2437
2438         case DIMEN_RANGE:
2439           /* Scalarized dimension.  */
2440           gcc_assert (info && se->loop);
2441
2442           /* Multiply the loop variable by the stride and delta.  */
2443           index = se->loop->loopvar[i];
2444           if (!integer_onep (info->stride[i]))
2445             index = fold_build2 (MULT_EXPR, gfc_array_index_type, index,
2446                                  info->stride[i]);
2447           if (!integer_zerop (info->delta[i]))
2448             index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index,
2449                                  info->delta[i]);
2450           break;
2451
2452         default:
2453           gcc_unreachable ();
2454         }
2455     }
2456   else
2457     {
2458       /* Temporary array or derived type component.  */
2459       gcc_assert (se->loop);
2460       index = se->loop->loopvar[se->loop->order[i]];
2461       if (!integer_zerop (info->delta[i]))
2462         index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2463                              index, info->delta[i]);
2464     }
2465
2466   /* Multiply by the stride.  */
2467   if (!integer_onep (stride))
2468     index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, stride);
2469
2470   return index;
2471 }
2472
2473
2474 /* Build a scalarized reference to an array.  */
2475
2476 static void
2477 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
2478 {
2479   gfc_ss_info *info;
2480   tree decl = NULL_TREE;
2481   tree index;
2482   tree tmp;
2483   int n;
2484
2485   info = &se->ss->data.info;
2486   if (ar)
2487     n = se->loop->order[0];
2488   else
2489     n = 0;
2490
2491   index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
2492                                        info->stride0);
2493   /* Add the offset for this dimension to the stored offset for all other
2494      dimensions.  */
2495   if (!integer_zerop (info->offset))
2496     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
2497
2498   if (se->ss->expr && is_subref_array (se->ss->expr))
2499     decl = se->ss->expr->symtree->n.sym->backend_decl;
2500
2501   tmp = build_fold_indirect_ref_loc (input_location,
2502                                  info->data);
2503   se->expr = gfc_build_array_ref (tmp, index, decl);
2504 }
2505
2506
2507 /* Translate access of temporary array.  */
2508
2509 void
2510 gfc_conv_tmp_array_ref (gfc_se * se)
2511 {
2512   se->string_length = se->ss->string_length;
2513   gfc_conv_scalarized_array_ref (se, NULL);
2514 }
2515
2516
2517 /* Build an array reference.  se->expr already holds the array descriptor.
2518    This should be either a variable, indirect variable reference or component
2519    reference.  For arrays which do not have a descriptor, se->expr will be
2520    the data pointer.
2521    a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/
2522
2523 void
2524 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
2525                     locus * where)
2526 {
2527   int n;
2528   tree index;
2529   tree tmp;
2530   tree stride;
2531   gfc_se indexse;
2532   gfc_se tmpse;
2533
2534   /* Handle scalarized references separately.  */
2535   if (ar->type != AR_ELEMENT)
2536     {
2537       gfc_conv_scalarized_array_ref (se, ar);
2538       gfc_advance_se_ss_chain (se);
2539       return;
2540     }
2541
2542   index = gfc_index_zero_node;
2543
2544   /* Calculate the offsets from all the dimensions.  */
2545   for (n = 0; n < ar->dimen; n++)
2546     {
2547       /* Calculate the index for this dimension.  */
2548       gfc_init_se (&indexse, se);
2549       gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
2550       gfc_add_block_to_block (&se->pre, &indexse.pre);
2551
2552       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2553         {
2554           /* Check array bounds.  */
2555           tree cond;
2556           char *msg;
2557
2558           /* Evaluate the indexse.expr only once.  */
2559           indexse.expr = save_expr (indexse.expr);
2560
2561           /* Lower bound.  */
2562           tmp = gfc_conv_array_lbound (se->expr, n);
2563           if (sym->attr.temporary)
2564             {
2565               gfc_init_se (&tmpse, se);
2566               gfc_conv_expr_type (&tmpse, ar->as->lower[n],
2567                                   gfc_array_index_type);
2568               gfc_add_block_to_block (&se->pre, &tmpse.pre);
2569               tmp = tmpse.expr;
2570             }
2571
2572           cond = fold_build2 (LT_EXPR, boolean_type_node,
2573                               indexse.expr, tmp);
2574           asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2575                     "below lower bound of %%ld", n+1, sym->name);
2576           gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2577                                    fold_convert (long_integer_type_node,
2578                                                  indexse.expr),
2579                                    fold_convert (long_integer_type_node, tmp));
2580           gfc_free (msg);
2581
2582           /* Upper bound, but not for the last dimension of assumed-size
2583              arrays.  */
2584           if (n < ar->dimen - 1
2585               || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
2586             {
2587               tmp = gfc_conv_array_ubound (se->expr, n);
2588               if (sym->attr.temporary)
2589                 {
2590                   gfc_init_se (&tmpse, se);
2591                   gfc_conv_expr_type (&tmpse, ar->as->upper[n],
2592                                       gfc_array_index_type);
2593                   gfc_add_block_to_block (&se->pre, &tmpse.pre);
2594                   tmp = tmpse.expr;
2595                 }
2596
2597               cond = fold_build2 (GT_EXPR, boolean_type_node,
2598                                   indexse.expr, tmp);
2599               asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
2600                         "above upper bound of %%ld", n+1, sym->name);
2601               gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
2602                                    fold_convert (long_integer_type_node,
2603                                                  indexse.expr),
2604                                    fold_convert (long_integer_type_node, tmp));
2605               gfc_free (msg);
2606             }
2607         }
2608
2609       /* Multiply the index by the stride.  */
2610       stride = gfc_conv_array_stride (se->expr, n);
2611       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
2612                          stride);
2613
2614       /* And add it to the total.  */
2615       index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2616     }
2617
2618   tmp = gfc_conv_array_offset (se->expr);
2619   if (!integer_zerop (tmp))
2620     index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
2621
2622   /* Access the calculated element.  */
2623   tmp = gfc_conv_array_data (se->expr);
2624   tmp = build_fold_indirect_ref (tmp);
2625   se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
2626 }
2627
2628
2629 /* Generate the code to be executed immediately before entering a
2630    scalarization loop.  */
2631
2632 static void
2633 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
2634                          stmtblock_t * pblock)
2635 {
2636   tree index;
2637   tree stride;
2638   gfc_ss_info *info;
2639   gfc_ss *ss;
2640   gfc_se se;
2641   int i;
2642
2643   /* This code will be executed before entering the scalarization loop
2644      for this dimension.  */
2645   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2646     {
2647       if ((ss->useflags & flag) == 0)
2648         continue;
2649
2650       if (ss->type != GFC_SS_SECTION
2651           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2652           && ss->type != GFC_SS_COMPONENT)
2653         continue;
2654
2655       info = &ss->data.info;
2656
2657       if (dim >= info->dimen)
2658         continue;
2659
2660       if (dim == info->dimen - 1)
2661         {
2662           /* For the outermost loop calculate the offset due to any
2663              elemental dimensions.  It will have been initialized with the
2664              base offset of the array.  */
2665           if (info->ref)
2666             {
2667               for (i = 0; i < info->ref->u.ar.dimen; i++)
2668                 {
2669                   if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2670                     continue;
2671
2672                   gfc_init_se (&se, NULL);
2673                   se.loop = loop;
2674                   se.expr = info->descriptor;
2675                   stride = gfc_conv_array_stride (info->descriptor, i);
2676                   index = gfc_conv_array_index_offset (&se, info, i, -1,
2677                                                        &info->ref->u.ar,
2678                                                        stride);
2679                   gfc_add_block_to_block (pblock, &se.pre);
2680
2681                   info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2682                                               info->offset, index);
2683                   info->offset = gfc_evaluate_now (info->offset, pblock);
2684                 }
2685
2686               i = loop->order[0];
2687               stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2688             }
2689           else
2690             stride = gfc_conv_array_stride (info->descriptor, 0);
2691
2692           /* Calculate the stride of the innermost loop.  Hopefully this will
2693              allow the backend optimizers to do their stuff more effectively.
2694            */
2695           info->stride0 = gfc_evaluate_now (stride, pblock);
2696         }
2697       else
2698         {
2699           /* Add the offset for the previous loop dimension.  */
2700           gfc_array_ref *ar;
2701
2702           if (info->ref)
2703             {
2704               ar = &info->ref->u.ar;
2705               i = loop->order[dim + 1];
2706             }
2707           else
2708             {
2709               ar = NULL;
2710               i = dim + 1;
2711             }
2712
2713           gfc_init_se (&se, NULL);
2714           se.loop = loop;
2715           se.expr = info->descriptor;
2716           stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
2717           index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
2718                                                ar, stride);
2719           gfc_add_block_to_block (pblock, &se.pre);
2720           info->offset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2721                                       info->offset, index);
2722           info->offset = gfc_evaluate_now (info->offset, pblock);
2723         }
2724
2725       /* Remember this offset for the second loop.  */
2726       if (dim == loop->temp_dim - 1)
2727         info->saved_offset = info->offset;
2728     }
2729 }
2730
2731
2732 /* Start a scalarized expression.  Creates a scope and declares loop
2733    variables.  */
2734
2735 void
2736 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
2737 {
2738   int dim;
2739   int n;
2740   int flags;
2741
2742   gcc_assert (!loop->array_parameter);
2743
2744   for (dim = loop->dimen - 1; dim >= 0; dim--)
2745     {
2746       n = loop->order[dim];
2747
2748       gfc_start_block (&loop->code[n]);
2749
2750       /* Create the loop variable.  */
2751       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
2752
2753       if (dim < loop->temp_dim)
2754         flags = 3;
2755       else
2756         flags = 1;
2757       /* Calculate values that will be constant within this loop.  */
2758       gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
2759     }
2760   gfc_start_block (pbody);
2761 }
2762
2763
2764 /* Generates the actual loop code for a scalarization loop.  */
2765
2766 void
2767 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
2768                                stmtblock_t * pbody)
2769 {
2770   stmtblock_t block;
2771   tree cond;
2772   tree tmp;
2773   tree loopbody;
2774   tree exit_label;
2775   tree stmt;
2776   tree init;
2777   tree incr;
2778
2779   if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
2780       == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
2781       && n == loop->dimen - 1)
2782     {
2783       /* We create an OMP_FOR construct for the outermost scalarized loop.  */
2784       init = make_tree_vec (1);
2785       cond = make_tree_vec (1);
2786       incr = make_tree_vec (1);
2787
2788       /* Cycle statement is implemented with a goto.  Exit statement must not
2789          be present for this loop.  */
2790       exit_label = gfc_build_label_decl (NULL_TREE);
2791       TREE_USED (exit_label) = 1;
2792
2793       /* Label for cycle statements (if needed).  */
2794       tmp = build1_v (LABEL_EXPR, exit_label);
2795       gfc_add_expr_to_block (pbody, tmp);
2796
2797       stmt = make_node (OMP_FOR);
2798
2799       TREE_TYPE (stmt) = void_type_node;
2800       OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
2801
2802       OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
2803                                                  OMP_CLAUSE_SCHEDULE);
2804       OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
2805         = OMP_CLAUSE_SCHEDULE_STATIC;
2806       if (ompws_flags & OMPWS_NOWAIT)
2807         OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
2808           = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
2809
2810       /* Initialize the loopvar.  */
2811       TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
2812                                          loop->from[n]);
2813       OMP_FOR_INIT (stmt) = init;
2814       /* The exit condition.  */
2815       TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
2816                                        loop->loopvar[n], loop->to[n]);
2817       OMP_FOR_COND (stmt) = cond;
2818       /* Increment the loopvar.  */
2819       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2820           loop->loopvar[n], gfc_index_one_node);
2821       TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
2822           void_type_node, loop->loopvar[n], tmp);
2823       OMP_FOR_INCR (stmt) = incr;
2824
2825       ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
2826       gfc_add_expr_to_block (&loop->code[n], stmt);
2827     }
2828   else
2829     {
2830       loopbody = gfc_finish_block (pbody);
2831
2832       /* Initialize the loopvar.  */
2833       if (loop->loopvar[n] != loop->from[n])
2834         gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
2835
2836       exit_label = gfc_build_label_decl (NULL_TREE);
2837
2838       /* Generate the loop body.  */
2839       gfc_init_block (&block);
2840
2841       /* The exit condition.  */
2842       cond = fold_build2 (GT_EXPR, boolean_type_node,
2843                          loop->loopvar[n], loop->to[n]);
2844       tmp = build1_v (GOTO_EXPR, exit_label);
2845       TREE_USED (exit_label) = 1;
2846       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2847       gfc_add_expr_to_block (&block, tmp);
2848
2849       /* The main body.  */
2850       gfc_add_expr_to_block (&block, loopbody);
2851
2852       /* Increment the loopvar.  */
2853       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2854                          loop->loopvar[n], gfc_index_one_node);
2855       gfc_add_modify (&block, loop->loopvar[n], tmp);
2856
2857       /* Build the loop.  */
2858       tmp = gfc_finish_block (&block);
2859       tmp = build1_v (LOOP_EXPR, tmp);
2860       gfc_add_expr_to_block (&loop->code[n], tmp);
2861
2862       /* Add the exit label.  */
2863       tmp = build1_v (LABEL_EXPR, exit_label);
2864       gfc_add_expr_to_block (&loop->code[n], tmp);
2865     }
2866
2867 }
2868
2869
2870 /* Finishes and generates the loops for a scalarized expression.  */
2871
2872 void
2873 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
2874 {
2875   int dim;
2876   int n;
2877   gfc_ss *ss;
2878   stmtblock_t *pblock;
2879   tree tmp;
2880
2881   pblock = body;
2882   /* Generate the loops.  */
2883   for (dim = 0; dim < loop->dimen; dim++)
2884     {
2885       n = loop->order[dim];
2886       gfc_trans_scalarized_loop_end (loop, n, pblock);
2887       loop->loopvar[n] = NULL_TREE;
2888       pblock = &loop->code[n];
2889     }
2890
2891   tmp = gfc_finish_block (pblock);
2892   gfc_add_expr_to_block (&loop->pre, tmp);
2893
2894   /* Clear all the used flags.  */
2895   for (ss = loop->ss; ss; ss = ss->loop_chain)
2896     ss->useflags = 0;
2897 }
2898
2899
2900 /* Finish the main body of a scalarized expression, and start the secondary
2901    copying body.  */
2902
2903 void
2904 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
2905 {
2906   int dim;
2907   int n;
2908   stmtblock_t *pblock;
2909   gfc_ss *ss;
2910
2911   pblock = body;
2912   /* We finish as many loops as are used by the temporary.  */
2913   for (dim = 0; dim < loop->temp_dim - 1; dim++)
2914     {
2915       n = loop->order[dim];
2916       gfc_trans_scalarized_loop_end (loop, n, pblock);
2917       loop->loopvar[n] = NULL_TREE;
2918       pblock = &loop->code[n];
2919     }
2920
2921   /* We don't want to finish the outermost loop entirely.  */
2922   n = loop->order[loop->temp_dim - 1];
2923   gfc_trans_scalarized_loop_end (loop, n, pblock);
2924
2925   /* Restore the initial offsets.  */
2926   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
2927     {
2928       if ((ss->useflags & 2) == 0)
2929         continue;
2930
2931       if (ss->type != GFC_SS_SECTION
2932           && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
2933           && ss->type != GFC_SS_COMPONENT)
2934         continue;
2935
2936       ss->data.info.offset = ss->data.info.saved_offset;
2937     }
2938
2939   /* Restart all the inner loops we just finished.  */
2940   for (dim = loop->temp_dim - 2; dim >= 0; dim--)
2941     {
2942       n = loop->order[dim];
2943
2944       gfc_start_block (&loop->code[n]);
2945
2946       loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
2947
2948       gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
2949     }
2950
2951   /* Start a block for the secondary copying code.  */
2952   gfc_start_block (body);
2953 }
2954
2955
2956 /* Calculate the upper bound of an array section.  */
2957
2958 static tree
2959 gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
2960 {
2961   int dim;
2962   gfc_expr *end;
2963   tree desc;
2964   tree bound;
2965   gfc_se se;
2966   gfc_ss_info *info;
2967
2968   gcc_assert (ss->type == GFC_SS_SECTION);
2969
2970   info = &ss->data.info;
2971   dim = info->dim[n];
2972
2973   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
2974     /* We'll calculate the upper bound once we have access to the
2975        vector's descriptor.  */
2976     return NULL;
2977
2978   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
2979   desc = info->descriptor;
2980   end = info->ref->u.ar.end[dim];
2981
2982   if (end)
2983     {
2984       /* The upper bound was specified.  */
2985       gfc_init_se (&se, NULL);
2986       gfc_conv_expr_type (&se, end, gfc_array_index_type);
2987       gfc_add_block_to_block (pblock, &se.pre);
2988       bound = se.expr;
2989     }
2990   else
2991     {
2992       /* No upper bound was specified, so use the bound of the array.  */
2993       bound = gfc_conv_array_ubound (desc, dim);
2994     }
2995
2996   return bound;
2997 }
2998
2999
3000 /* Calculate the lower bound of an array section.  */
3001
3002 static void
3003 gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
3004 {
3005   gfc_expr *start;
3006   gfc_expr *end;
3007   gfc_expr *stride;
3008   tree desc;
3009   gfc_se se;
3010   gfc_ss_info *info;
3011   int dim;
3012
3013   gcc_assert (ss->type == GFC_SS_SECTION);
3014
3015   info = &ss->data.info;
3016   dim = info->dim[n];
3017
3018   if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
3019     {
3020       /* We use a zero-based index to access the vector.  */
3021       info->start[n] = gfc_index_zero_node;
3022       info->end[n] = gfc_index_zero_node;
3023       info->stride[n] = gfc_index_one_node;
3024       return;
3025     }
3026
3027   gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
3028   desc = info->descriptor;
3029   start = info->ref->u.ar.start[dim];
3030   end = info->ref->u.ar.end[dim];
3031   stride = info->ref->u.ar.stride[dim];
3032
3033   /* Calculate the start of the range.  For vector subscripts this will
3034      be the range of the vector.  */
3035   if (start)
3036     {
3037       /* Specified section start.  */
3038       gfc_init_se (&se, NULL);
3039       gfc_conv_expr_type (&se, start, gfc_array_index_type);
3040       gfc_add_block_to_block (&loop->pre, &se.pre);
3041       info->start[n] = se.expr;
3042     }
3043   else
3044     {
3045       /* No lower bound specified so use the bound of the array.  */
3046       info->start[n] = gfc_conv_array_lbound (desc, dim);
3047     }
3048   info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
3049
3050   /* Similarly calculate the end.  Although this is not used in the
3051      scalarizer, it is needed when checking bounds and where the end
3052      is an expression with side-effects.  */
3053   if (end)
3054     {
3055       /* Specified section start.  */
3056       gfc_init_se (&se, NULL);
3057       gfc_conv_expr_type (&se, end, gfc_array_index_type);
3058       gfc_add_block_to_block (&loop->pre, &se.pre);
3059       info->end[n] = se.expr;
3060     }
3061   else
3062     {
3063       /* No upper bound specified so use the bound of the array.  */
3064       info->end[n] = gfc_conv_array_ubound (desc, dim);
3065     }
3066   info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre);
3067
3068   /* Calculate the stride.  */
3069   if (stride == NULL)
3070     info->stride[n] = gfc_index_one_node;
3071   else
3072     {
3073       gfc_init_se (&se, NULL);
3074       gfc_conv_expr_type (&se, stride, gfc_array_index_type);
3075       gfc_add_block_to_block (&loop->pre, &se.pre);
3076       info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
3077     }
3078 }
3079
3080
3081 /* Calculates the range start and stride for a SS chain.  Also gets the
3082    descriptor and data pointer.  The range of vector subscripts is the size
3083    of the vector.  Array bounds are also checked.  */
3084
3085 void
3086 gfc_conv_ss_startstride (gfc_loopinfo * loop)
3087 {
3088   int n;
3089   tree tmp;
3090   gfc_ss *ss;
3091   tree desc;
3092
3093   loop->dimen = 0;
3094   /* Determine the rank of the loop.  */
3095   for (ss = loop->ss;
3096        ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
3097     {
3098       switch (ss->type)
3099         {
3100         case GFC_SS_SECTION:
3101         case GFC_SS_CONSTRUCTOR:
3102         case GFC_SS_FUNCTION:
3103         case GFC_SS_COMPONENT:
3104           loop->dimen = ss->data.info.dimen;
3105           break;
3106
3107         /* As usual, lbound and ubound are exceptions!.  */
3108         case GFC_SS_INTRINSIC:
3109           switch (ss->expr->value.function.isym->id)
3110             {
3111             case GFC_ISYM_LBOUND:
3112             case GFC_ISYM_UBOUND:
3113               loop->dimen = ss->data.info.dimen;
3114
3115             default:
3116               break;
3117             }
3118
3119         default:
3120           break;
3121         }
3122     }
3123
3124   /* We should have determined the rank of the expression by now.  If
3125      not, that's bad news.  */
3126   gcc_assert (loop->dimen != 0);
3127
3128   /* Loop over all the SS in the chain.  */
3129   for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3130     {
3131       if (ss->expr && ss->expr->shape && !ss->shape)
3132         ss->shape = ss->expr->shape;
3133
3134       switch (ss->type)
3135         {
3136         case GFC_SS_SECTION:
3137           /* Get the descriptor for the array.  */
3138           gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
3139
3140           for (n = 0; n < ss->data.info.dimen; n++)
3141             gfc_conv_section_startstride (loop, ss, n);
3142           break;
3143
3144         case GFC_SS_INTRINSIC:
3145           switch (ss->expr->value.function.isym->id)
3146             {
3147             /* Fall through to supply start and stride.  */
3148             case GFC_ISYM_LBOUND:
3149             case GFC_ISYM_UBOUND:
3150               break;
3151             default:
3152               continue;
3153             }
3154
3155         case GFC_SS_CONSTRUCTOR:
3156         case GFC_SS_FUNCTION:
3157           for (n = 0; n < ss->data.info.dimen; n++)
3158             {
3159               ss->data.info.start[n] = gfc_index_zero_node;
3160               ss->data.info.end[n] = gfc_index_zero_node;
3161               ss->data.info.stride[n] = gfc_index_one_node;
3162             }
3163           break;
3164
3165         default:
3166           break;
3167         }
3168     }
3169
3170   /* The rest is just runtime bound checking.  */
3171   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3172     {
3173       stmtblock_t block;
3174       tree lbound, ubound;
3175       tree end;
3176       tree size[GFC_MAX_DIMENSIONS];
3177       tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
3178       gfc_ss_info *info;
3179       char *msg;
3180       int dim;
3181
3182       gfc_start_block (&block);
3183
3184       for (n = 0; n < loop->dimen; n++)
3185         size[n] = NULL_TREE;
3186
3187       for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
3188         {
3189           stmtblock_t inner;
3190
3191           if (ss->type != GFC_SS_SECTION)
3192             continue;
3193
3194           gfc_start_block (&inner);
3195
3196           /* TODO: range checking for mapped dimensions.  */
3197           info = &ss->data.info;
3198
3199           /* This code only checks ranges.  Elemental and vector
3200              dimensions are checked later.  */
3201           for (n = 0; n < loop->dimen; n++)
3202             {
3203               bool check_upper;
3204
3205               dim = info->dim[n];
3206               if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
3207                 continue;
3208
3209               if (dim == info->ref->u.ar.dimen - 1
3210                   && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
3211                       || info->ref->u.ar.as->cp_was_assumed))
3212                 check_upper = false;
3213               else
3214                 check_upper = true;
3215
3216               /* Zero stride is not allowed.  */
3217               tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
3218                                  gfc_index_zero_node);
3219               asprintf (&msg, "Zero stride is not allowed, for dimension %d "
3220                         "of array '%s'", info->dim[n]+1,
3221                         ss->expr->symtree->name);
3222               gfc_trans_runtime_check (true, false, tmp, &inner,
3223                                        &ss->expr->where, msg);
3224               gfc_free (msg);
3225
3226               desc = ss->data.info.descriptor;
3227
3228               /* This is the run-time equivalent of resolve.c's
3229                  check_dimension().  The logical is more readable there
3230                  than it is here, with all the trees.  */
3231               lbound = gfc_conv_array_lbound (desc, dim);
3232               end = info->end[n];
3233               if (check_upper)
3234                 ubound = gfc_conv_array_ubound (desc, dim);
3235               else
3236                 ubound = NULL;
3237
3238               /* non_zerosized is true when the selected range is not
3239                  empty.  */
3240               stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
3241                                         info->stride[n], gfc_index_zero_node);
3242               tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n],
3243                                  end);
3244               stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3245                                         stride_pos, tmp);
3246
3247               stride_neg = fold_build2 (LT_EXPR, boolean_type_node,
3248                                         info->stride[n], gfc_index_zero_node);
3249               tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n],
3250                                  end);
3251               stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3252                                         stride_neg, tmp);
3253               non_zerosized = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3254                                            stride_pos, stride_neg);
3255
3256               /* Check the start of the range against the lower and upper
3257                  bounds of the array, if the range is not empty.
3258                  If upper bound is present, include both bounds in the
3259                  error message.  */
3260               if (check_upper)
3261                 {
3262                   tmp = fold_build2 (LT_EXPR, boolean_type_node,
3263                                      info->start[n], lbound);
3264                   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3265                                      non_zerosized, tmp);
3266                   tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
3267                                       info->start[n], ubound);
3268                   tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3269                                       non_zerosized, tmp2);
3270                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3271                             "outside of expected range (%%ld:%%ld)",
3272                             info->dim[n]+1, ss->expr->symtree->name);
3273                   gfc_trans_runtime_check (true, false, tmp, &inner,
3274                                            &ss->expr->where, msg,
3275                      fold_convert (long_integer_type_node, info->start[n]),
3276                      fold_convert (long_integer_type_node, lbound),
3277                      fold_convert (long_integer_type_node, ubound));
3278                   gfc_trans_runtime_check (true, false, tmp2, &inner,
3279                                            &ss->expr->where, msg,
3280                      fold_convert (long_integer_type_node, info->start[n]),
3281                      fold_convert (long_integer_type_node, lbound),
3282                      fold_convert (long_integer_type_node, ubound));
3283                   gfc_free (msg);
3284                 }
3285               else
3286                 {
3287                   tmp = fold_build2 (LT_EXPR, boolean_type_node,
3288                                      info->start[n], lbound);
3289                   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3290                                      non_zerosized, tmp);
3291                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3292                             "below lower bound of %%ld",
3293                             info->dim[n]+1, ss->expr->symtree->name);
3294                   gfc_trans_runtime_check (true, false, tmp, &inner,
3295                                            &ss->expr->where, msg,
3296                      fold_convert (long_integer_type_node, info->start[n]),
3297                      fold_convert (long_integer_type_node, lbound));
3298                   gfc_free (msg);
3299                 }
3300
3301               /* Compute the last element of the range, which is not
3302                  necessarily "end" (think 0:5:3, which doesn't contain 5)
3303                  and check it against both lower and upper bounds.  */
3304
3305               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3306                                   info->start[n]);
3307               tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
3308                                   info->stride[n]);
3309               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3310                                   tmp);
3311               tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
3312               tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3313                                  non_zerosized, tmp2);
3314               if (check_upper)
3315                 {
3316                   tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
3317                   tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3318                                       non_zerosized, tmp3);
3319                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3320                             "outside of expected range (%%ld:%%ld)",
3321                             info->dim[n]+1, ss->expr->symtree->name);
3322                   gfc_trans_runtime_check (true, false, tmp2, &inner,
3323                                            &ss->expr->where, msg,
3324                      fold_convert (long_integer_type_node, tmp),
3325                      fold_convert (long_integer_type_node, ubound),
3326                      fold_convert (long_integer_type_node, lbound));
3327                   gfc_trans_runtime_check (true, false, tmp3, &inner,
3328                                            &ss->expr->where, msg,
3329                      fold_convert (long_integer_type_node, tmp),
3330                      fold_convert (long_integer_type_node, ubound),
3331                      fold_convert (long_integer_type_node, lbound));
3332                   gfc_free (msg);
3333                 }
3334               else
3335                 {
3336                   asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
3337                             "below lower bound of %%ld",
3338                             info->dim[n]+1, ss->expr->symtree->name);
3339                   gfc_trans_runtime_check (true, false, tmp2, &inner,
3340                                            &ss->expr->where, msg,
3341                      fold_convert (long_integer_type_node, tmp),
3342                      fold_convert (long_integer_type_node, lbound));
3343                   gfc_free (msg);
3344                 }
3345
3346               /* Check the section sizes match.  */
3347               tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
3348                                  info->start[n]);
3349               tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
3350                                  info->stride[n]);
3351               tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3352                                  gfc_index_one_node, tmp);
3353               tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
3354                                  build_int_cst (gfc_array_index_type, 0));
3355               /* We remember the size of the first section, and check all the
3356                  others against this.  */
3357               if (size[n])
3358                 {
3359                   tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
3360                   asprintf (&msg, "%s, size mismatch for dimension %d "
3361                             "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
3362                             info->dim[n]+1, ss->expr->symtree->name);
3363                   gfc_trans_runtime_check (true, false, tmp3, &inner,
3364                                            &ss->expr->where, msg,
3365                         fold_convert (long_integer_type_node, tmp),
3366                         fold_convert (long_integer_type_node, size[n]));
3367                   gfc_free (msg);
3368                 }
3369               else
3370                 size[n] = gfc_evaluate_now (tmp, &inner);
3371             }
3372
3373           tmp = gfc_finish_block (&inner);
3374
3375           /* For optional arguments, only check bounds if the argument is
3376              present.  */
3377           if (ss->expr->symtree->n.sym->attr.optional
3378               || ss->expr->symtree->n.sym->attr.not_always_present)
3379             tmp = build3_v (COND_EXPR,
3380                             gfc_conv_expr_present (ss->expr->symtree->n.sym),