1 /* Array translation routines 2 Copyright (C) 2002-2019 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 5 6 This file is part of GCC. 7 8 GCC is free software; you can redistribute it and/or modify it under 9 the terms of the GNU General Public License as published by the Free 10 Software Foundation; either version 3, or (at your option) any later 11 version. 12 13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14 WARRANTY; without even the implied warranty of MERCHANTABILITY or 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16 for more details. 17 18 You should have received a copy of the GNU General Public License 19 along with GCC; see the file COPYING3. If not see 20 <http://www.gnu.org/licenses/>. */ 21 22 /* trans-array.c-- Various array related code, including scalarization, 23 allocation, initialization and other support routines. */ 24 25 /* How the scalarizer works. 26 In gfortran, array expressions use the same core routines as scalar 27 expressions. 28 First, a Scalarization State (SS) chain is built. This is done by walking 29 the expression tree, and building a linear list of the terms in the 30 expression. As the tree is walked, scalar subexpressions are translated. 31 32 The scalarization parameters are stored in a gfc_loopinfo structure. 33 First the start and stride of each term is calculated by 34 gfc_conv_ss_startstride. During this process the expressions for the array 35 descriptors and data pointers are also translated. 36 37 If the expression is an assignment, we must then resolve any dependencies. 38 In Fortran all the rhs values of an assignment must be evaluated before 39 any assignments take place. This can require a temporary array to store the 40 values. We also require a temporary when we are passing array expressions 41 or vector subscripts as procedure parameters. 42 43 Array sections are passed without copying to a temporary. These use the 44 scalarizer to determine the shape of the section. The flag 45 loop->array_parameter tells the scalarizer that the actual values and loop 46 variables will not be required. 47 48 The function gfc_conv_loop_setup generates the scalarization setup code. 49 It determines the range of the scalarizing loop variables. If a temporary 50 is required, this is created and initialized. Code for scalar expressions 51 taken outside the loop is also generated at this time. Next the offset and 52 scaling required to translate from loop variables to array indices for each 53 term is calculated. 54 55 A call to gfc_start_scalarized_body marks the start of the scalarized 56 expression. This creates a scope and declares the loop variables. Before 57 calling this gfc_make_ss_chain_used must be used to indicate which terms 58 will be used inside this loop. 59 60 The scalar gfc_conv_* functions are then used to build the main body of the 61 scalarization loop. Scalarization loop variables and precalculated scalar 62 values are automatically substituted. Note that gfc_advance_se_ss_chain 63 must be used, rather than changing the se->ss directly. 64 65 For assignment expressions requiring a temporary two sub loops are 66 generated. The first stores the result of the expression in the temporary, 67 the second copies it to the result. A call to 68 gfc_trans_scalarized_loop_boundary marks the end of the main loop code and 69 the start of the copying loop. The temporary may be less than full rank. 70 71 Finally gfc_trans_scalarizing_loops is called to generate the implicit do 72 loops. The loops are added to the pre chain of the loopinfo. The post 73 chain may still contain cleanup code. 74 75 After the loop code has been added into its parent scope gfc_cleanup_loop 76 is called to free all the SS allocated by the scalarizer. */ 77 78 #include "config.h" 79 #include "system.h" 80 #include "coretypes.h" 81 #include "options.h" 82 #include "tree.h" 83 #include "gfortran.h" 84 #include "gimple-expr.h" 85 #include "trans.h" 86 #include "fold-const.h" 87 #include "constructor.h" 88 #include "trans-types.h" 89 #include "trans-array.h" 90 #include "trans-const.h" 91 #include "dependency.h" 92 93 static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); 94 95 /* The contents of this structure aren't actually used, just the address. */ 96 static gfc_ss gfc_ss_terminator_var; 97 gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; 98 99 100 static tree 101 gfc_array_dataptr_type (tree desc) 102 { 103 return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); 104 } 105 106 107 /* Build expressions to access the members of an array descriptor. 108 It's surprisingly easy to mess up here, so never access 109 an array descriptor by "brute force", always use these 110 functions. This also avoids problems if we change the format 111 of an array descriptor. 112 113 To understand these magic numbers, look at the comments 114 before gfc_build_array_type() in trans-types.c. 115 116 The code within these defines should be the only code which knows the format 117 of an array descriptor. 118 119 Any code just needing to read obtain the bounds of an array should use 120 gfc_conv_array_* rather than the following functions as these will return 121 know constant values, and work with arrays which do not have descriptors. 122 123 Don't forget to #undef these! */ 124 125 #define DATA_FIELD 0 126 #define OFFSET_FIELD 1 127 #define DTYPE_FIELD 2 128 #define SPAN_FIELD 3 129 #define DIMENSION_FIELD 4 130 #define CAF_TOKEN_FIELD 5 131 132 #define STRIDE_SUBFIELD 0 133 #define LBOUND_SUBFIELD 1 134 #define UBOUND_SUBFIELD 2 135 136 /* This provides READ-ONLY access to the data field. The field itself 137 doesn't have the proper type. */ 138 139 tree 140 gfc_conv_descriptor_data_get (tree desc) 141 { 142 tree field, type, t; 143 144 type = TREE_TYPE (desc); 145 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 146 147 field = TYPE_FIELDS (type); 148 gcc_assert (DATA_FIELD == 0); 149 150 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, 151 field, NULL_TREE); 152 t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t); 153 154 return t; 155 } 156 157 /* This provides WRITE access to the data field. 158 159 TUPLES_P is true if we are generating tuples. 160 161 This function gets called through the following macros: 162 gfc_conv_descriptor_data_set 163 gfc_conv_descriptor_data_set. */ 164 165 void 166 gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) 167 { 168 tree field, type, t; 169 170 type = TREE_TYPE (desc); 171 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 172 173 field = TYPE_FIELDS (type); 174 gcc_assert (DATA_FIELD == 0); 175 176 t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, 177 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_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc, 197 field, NULL_TREE); 198 return gfc_build_addr_expr (NULL_TREE, t); 199 } 200 201 static tree 202 gfc_conv_descriptor_offset (tree desc) 203 { 204 tree type; 205 tree field; 206 207 type = TREE_TYPE (desc); 208 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 209 210 field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); 211 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); 212 213 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 214 desc, field, NULL_TREE); 215 } 216 217 tree 218 gfc_conv_descriptor_offset_get (tree desc) 219 { 220 return gfc_conv_descriptor_offset (desc); 221 } 222 223 void 224 gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, 225 tree value) 226 { 227 tree t = gfc_conv_descriptor_offset (desc); 228 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); 229 } 230 231 232 tree 233 gfc_conv_descriptor_dtype (tree desc) 234 { 235 tree field; 236 tree type; 237 238 type = TREE_TYPE (desc); 239 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 240 241 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); 242 gcc_assert (field != NULL_TREE 243 && TREE_TYPE (field) == get_dtype_type_node ()); 244 245 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 246 desc, field, NULL_TREE); 247 } 248 249 static tree 250 gfc_conv_descriptor_span (tree desc) 251 { 252 tree type; 253 tree field; 254 255 type = TREE_TYPE (desc); 256 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 257 258 field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); 259 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); 260 261 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 262 desc, field, NULL_TREE); 263 } 264 265 tree 266 gfc_conv_descriptor_span_get (tree desc) 267 { 268 return gfc_conv_descriptor_span (desc); 269 } 270 271 void 272 gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, 273 tree value) 274 { 275 tree t = gfc_conv_descriptor_span (desc); 276 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); 277 } 278 279 280 tree 281 gfc_conv_descriptor_rank (tree desc) 282 { 283 tree tmp; 284 tree dtype; 285 286 dtype = gfc_conv_descriptor_dtype (desc); 287 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); 288 gcc_assert (tmp != NULL_TREE 289 && TREE_TYPE (tmp) == signed_char_type_node); 290 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), 291 dtype, tmp, NULL_TREE); 292 } 293 294 295 /* Return the element length from the descriptor dtype field. */ 296 297 tree 298 gfc_conv_descriptor_elem_len (tree desc) 299 { 300 tree tmp; 301 tree dtype; 302 303 dtype = gfc_conv_descriptor_dtype (desc); 304 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), 305 GFC_DTYPE_ELEM_LEN); 306 gcc_assert (tmp != NULL_TREE 307 && TREE_TYPE (tmp) == size_type_node); 308 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), 309 dtype, tmp, NULL_TREE); 310 } 311 312 313 tree 314 gfc_conv_descriptor_attribute (tree desc) 315 { 316 tree tmp; 317 tree dtype; 318 319 dtype = gfc_conv_descriptor_dtype (desc); 320 tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), 321 GFC_DTYPE_ATTRIBUTE); 322 gcc_assert (tmp!= NULL_TREE 323 && TREE_TYPE (tmp) == short_integer_type_node); 324 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), 325 dtype, tmp, NULL_TREE); 326 } 327 328 329 tree 330 gfc_get_descriptor_dimension (tree desc) 331 { 332 tree type, field; 333 334 type = TREE_TYPE (desc); 335 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 336 337 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); 338 gcc_assert (field != NULL_TREE 339 && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE 340 && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); 341 342 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 343 desc, field, NULL_TREE); 344 } 345 346 347 static tree 348 gfc_conv_descriptor_dimension (tree desc, tree dim) 349 { 350 tree tmp; 351 352 tmp = gfc_get_descriptor_dimension (desc); 353 354 return gfc_build_array_ref (tmp, dim, NULL); 355 } 356 357 358 tree 359 gfc_conv_descriptor_token (tree desc) 360 { 361 tree type; 362 tree field; 363 364 type = TREE_TYPE (desc); 365 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 366 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); 367 field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); 368 369 /* Should be a restricted pointer - except in the finalization wrapper. */ 370 gcc_assert (field != NULL_TREE 371 && (TREE_TYPE (field) == prvoid_type_node 372 || TREE_TYPE (field) == pvoid_type_node)); 373 374 return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 375 desc, field, NULL_TREE); 376 } 377 378 379 static tree 380 gfc_conv_descriptor_stride (tree desc, tree dim) 381 { 382 tree tmp; 383 tree field; 384 385 tmp = gfc_conv_descriptor_dimension (desc, dim); 386 field = TYPE_FIELDS (TREE_TYPE (tmp)); 387 field = gfc_advance_chain (field, STRIDE_SUBFIELD); 388 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); 389 390 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 391 tmp, field, NULL_TREE); 392 return tmp; 393 } 394 395 tree 396 gfc_conv_descriptor_stride_get (tree desc, tree dim) 397 { 398 tree type = TREE_TYPE (desc); 399 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 400 if (integer_zerop (dim) 401 && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE 402 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT 403 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT 404 ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) 405 return gfc_index_one_node; 406 407 return gfc_conv_descriptor_stride (desc, dim); 408 } 409 410 void 411 gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, 412 tree dim, tree value) 413 { 414 tree t = gfc_conv_descriptor_stride (desc, dim); 415 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); 416 } 417 418 static tree 419 gfc_conv_descriptor_lbound (tree desc, tree dim) 420 { 421 tree tmp; 422 tree field; 423 424 tmp = gfc_conv_descriptor_dimension (desc, dim); 425 field = TYPE_FIELDS (TREE_TYPE (tmp)); 426 field = gfc_advance_chain (field, LBOUND_SUBFIELD); 427 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); 428 429 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 430 tmp, field, NULL_TREE); 431 return tmp; 432 } 433 434 tree 435 gfc_conv_descriptor_lbound_get (tree desc, tree dim) 436 { 437 return gfc_conv_descriptor_lbound (desc, dim); 438 } 439 440 void 441 gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, 442 tree dim, tree value) 443 { 444 tree t = gfc_conv_descriptor_lbound (desc, dim); 445 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); 446 } 447 448 static tree 449 gfc_conv_descriptor_ubound (tree desc, tree dim) 450 { 451 tree tmp; 452 tree field; 453 454 tmp = gfc_conv_descriptor_dimension (desc, dim); 455 field = TYPE_FIELDS (TREE_TYPE (tmp)); 456 field = gfc_advance_chain (field, UBOUND_SUBFIELD); 457 gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); 458 459 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 460 tmp, field, NULL_TREE); 461 return tmp; 462 } 463 464 tree 465 gfc_conv_descriptor_ubound_get (tree desc, tree dim) 466 { 467 return gfc_conv_descriptor_ubound (desc, dim); 468 } 469 470 void 471 gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, 472 tree dim, tree value) 473 { 474 tree t = gfc_conv_descriptor_ubound (desc, dim); 475 gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); 476 } 477 478 /* Build a null array descriptor constructor. */ 479 480 tree 481 gfc_build_null_descriptor (tree type) 482 { 483 tree field; 484 tree tmp; 485 486 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 487 gcc_assert (DATA_FIELD == 0); 488 field = TYPE_FIELDS (type); 489 490 /* Set a NULL data pointer. */ 491 tmp = build_constructor_single (type, field, null_pointer_node); 492 TREE_CONSTANT (tmp) = 1; 493 /* All other fields are ignored. */ 494 495 return tmp; 496 } 497 498 499 /* Modify a descriptor such that the lbound of a given dimension is the value 500 specified. This also updates ubound and offset accordingly. */ 501 502 void 503 gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, 504 int dim, tree new_lbound) 505 { 506 tree offs, ubound, lbound, stride; 507 tree diff, offs_diff; 508 509 new_lbound = fold_convert (gfc_array_index_type, new_lbound); 510 511 offs = gfc_conv_descriptor_offset_get (desc); 512 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); 513 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); 514 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); 515 516 /* Get difference (new - old) by which to shift stuff. */ 517 diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 518 new_lbound, lbound); 519 520 /* Shift ubound and offset accordingly. This has to be done before 521 updating the lbound, as they depend on the lbound expression! */ 522 ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 523 ubound, diff); 524 gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); 525 offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 526 diff, stride); 527 offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 528 offs, offs_diff); 529 gfc_conv_descriptor_offset_set (block, desc, offs); 530 531 /* Finally set lbound to value we want. */ 532 gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); 533 } 534 535 536 /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ 537 538 void 539 gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, 540 tree *dtype_off, tree *span_off, 541 tree *dim_off, tree *dim_size, 542 tree *stride_suboff, tree *lower_suboff, 543 tree *upper_suboff) 544 { 545 tree field; 546 tree type; 547 548 type = TYPE_MAIN_VARIANT (desc_type); 549 field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD); 550 *data_off = byte_position (field); 551 field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); 552 *dtype_off = byte_position (field); 553 field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); 554 *span_off = byte_position (field); 555 field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); 556 *dim_off = byte_position (field); 557 type = TREE_TYPE (TREE_TYPE (field)); 558 *dim_size = TYPE_SIZE_UNIT (type); 559 field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); 560 *stride_suboff = byte_position (field); 561 field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); 562 *lower_suboff = byte_position (field); 563 field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); 564 *upper_suboff = byte_position (field); 565 } 566 567 568 /* Cleanup those #defines. */ 569 570 #undef DATA_FIELD 571 #undef OFFSET_FIELD 572 #undef DTYPE_FIELD 573 #undef SPAN_FIELD 574 #undef DIMENSION_FIELD 575 #undef CAF_TOKEN_FIELD 576 #undef STRIDE_SUBFIELD 577 #undef LBOUND_SUBFIELD 578 #undef UBOUND_SUBFIELD 579 580 581 /* Mark a SS chain as used. Flags specifies in which loops the SS is used. 582 flags & 1 = Main loop body. 583 flags & 2 = temp copy loop. */ 584 585 void 586 gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) 587 { 588 for (; ss != gfc_ss_terminator; ss = ss->next) 589 ss->info->useflags = flags; 590 } 591 592 593 /* Free a gfc_ss chain. */ 594 595 void 596 gfc_free_ss_chain (gfc_ss * ss) 597 { 598 gfc_ss *next; 599 600 while (ss != gfc_ss_terminator) 601 { 602 gcc_assert (ss != NULL); 603 next = ss->next; 604 gfc_free_ss (ss); 605 ss = next; 606 } 607 } 608 609 610 static void 611 free_ss_info (gfc_ss_info *ss_info) 612 { 613 int n; 614 615 ss_info->refcount--; 616 if (ss_info->refcount > 0) 617 return; 618 619 gcc_assert (ss_info->refcount == 0); 620 621 switch (ss_info->type) 622 { 623 case GFC_SS_SECTION: 624 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 625 if (ss_info->data.array.subscript[n]) 626 gfc_free_ss_chain (ss_info->data.array.subscript[n]); 627 break; 628 629 default: 630 break; 631 } 632 633 free (ss_info); 634 } 635 636 637 /* Free a SS. */ 638 639 void 640 gfc_free_ss (gfc_ss * ss) 641 { 642 free_ss_info (ss->info); 643 free (ss); 644 } 645 646 647 /* Creates and initializes an array type gfc_ss struct. */ 648 649 gfc_ss * 650 gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) 651 { 652 gfc_ss *ss; 653 gfc_ss_info *ss_info; 654 int i; 655 656 ss_info = gfc_get_ss_info (); 657 ss_info->refcount++; 658 ss_info->type = type; 659 ss_info->expr = expr; 660 661 ss = gfc_get_ss (); 662 ss->info = ss_info; 663 ss->next = next; 664 ss->dimen = dimen; 665 for (i = 0; i < ss->dimen; i++) 666 ss->dim[i] = i; 667 668 return ss; 669 } 670 671 672 /* Creates and initializes a temporary type gfc_ss struct. */ 673 674 gfc_ss * 675 gfc_get_temp_ss (tree type, tree string_length, int dimen) 676 { 677 gfc_ss *ss; 678 gfc_ss_info *ss_info; 679 int i; 680 681 ss_info = gfc_get_ss_info (); 682 ss_info->refcount++; 683 ss_info->type = GFC_SS_TEMP; 684 ss_info->string_length = string_length; 685 ss_info->data.temp.type = type; 686 687 ss = gfc_get_ss (); 688 ss->info = ss_info; 689 ss->next = gfc_ss_terminator; 690 ss->dimen = dimen; 691 for (i = 0; i < ss->dimen; i++) 692 ss->dim[i] = i; 693 694 return ss; 695 } 696 697 698 /* Creates and initializes a scalar type gfc_ss struct. */ 699 700 gfc_ss * 701 gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) 702 { 703 gfc_ss *ss; 704 gfc_ss_info *ss_info; 705 706 ss_info = gfc_get_ss_info (); 707 ss_info->refcount++; 708 ss_info->type = GFC_SS_SCALAR; 709 ss_info->expr = expr; 710 711 ss = gfc_get_ss (); 712 ss->info = ss_info; 713 ss->next = next; 714 715 return ss; 716 } 717 718 719 /* Free all the SS associated with a loop. */ 720 721 void 722 gfc_cleanup_loop (gfc_loopinfo * loop) 723 { 724 gfc_loopinfo *loop_next, **ploop; 725 gfc_ss *ss; 726 gfc_ss *next; 727 728 ss = loop->ss; 729 while (ss != gfc_ss_terminator) 730 { 731 gcc_assert (ss != NULL); 732 next = ss->loop_chain; 733 gfc_free_ss (ss); 734 ss = next; 735 } 736 737 /* Remove reference to self in the parent loop. */ 738 if (loop->parent) 739 for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) 740 if (*ploop == loop) 741 { 742 *ploop = loop->next; 743 break; 744 } 745 746 /* Free non-freed nested loops. */ 747 for (loop = loop->nested; loop; loop = loop_next) 748 { 749 loop_next = loop->next; 750 gfc_cleanup_loop (loop); 751 free (loop); 752 } 753 } 754 755 756 static void 757 set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) 758 { 759 int n; 760 761 for (; ss != gfc_ss_terminator; ss = ss->next) 762 { 763 ss->loop = loop; 764 765 if (ss->info->type == GFC_SS_SCALAR 766 || ss->info->type == GFC_SS_REFERENCE 767 || ss->info->type == GFC_SS_TEMP) 768 continue; 769 770 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 771 if (ss->info->data.array.subscript[n] != NULL) 772 set_ss_loop (ss->info->data.array.subscript[n], loop); 773 } 774 } 775 776 777 /* Associate a SS chain with a loop. */ 778 779 void 780 gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) 781 { 782 gfc_ss *ss; 783 gfc_loopinfo *nested_loop; 784 785 if (head == gfc_ss_terminator) 786 return; 787 788 set_ss_loop (head, loop); 789 790 ss = head; 791 for (; ss && ss != gfc_ss_terminator; ss = ss->next) 792 { 793 if (ss->nested_ss) 794 { 795 nested_loop = ss->nested_ss->loop; 796 797 /* More than one ss can belong to the same loop. Hence, we add the 798 loop to the chain only if it is different from the previously 799 added one, to avoid duplicate nested loops. */ 800 if (nested_loop != loop->nested) 801 { 802 gcc_assert (nested_loop->parent == NULL); 803 nested_loop->parent = loop; 804 805 gcc_assert (nested_loop->next == NULL); 806 nested_loop->next = loop->nested; 807 loop->nested = nested_loop; 808 } 809 else 810 gcc_assert (nested_loop->parent == loop); 811 } 812 813 if (ss->next == gfc_ss_terminator) 814 ss->loop_chain = loop->ss; 815 else 816 ss->loop_chain = ss->next; 817 } 818 gcc_assert (ss == gfc_ss_terminator); 819 loop->ss = head; 820 } 821 822 823 /* Returns true if the expression is an array pointer. */ 824 825 static bool 826 is_pointer_array (tree expr) 827 { 828 if (expr == NULL_TREE 829 || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) 830 || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) 831 return false; 832 833 if (TREE_CODE (expr) == VAR_DECL 834 && GFC_DECL_PTR_ARRAY_P (expr)) 835 return true; 836 837 if (TREE_CODE (expr) == PARM_DECL 838 && GFC_DECL_PTR_ARRAY_P (expr)) 839 return true; 840 841 if (TREE_CODE (expr) == INDIRECT_REF 842 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) 843 return true; 844 845 /* The field declaration is marked as an pointer array. */ 846 if (TREE_CODE (expr) == COMPONENT_REF 847 && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) 848 && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) 849 return true; 850 851 return false; 852 } 853 854 855 /* If the symbol or expression reference a CFI descriptor, return the 856 pointer to the converted gfc descriptor. If an array reference is 857 present as the last argument, check that it is the one applied to 858 the CFI descriptor in the expression. Note that the CFI object is 859 always the symbol in the expression! */ 860 861 static bool 862 get_CFI_desc (gfc_symbol *sym, gfc_expr *expr, 863 tree *desc, gfc_array_ref *ar) 864 { 865 tree tmp; 866 867 if (!is_CFI_desc (sym, expr)) 868 return false; 869 870 if (expr && ar) 871 { 872 if (!(expr->ref && expr->ref->type == REF_ARRAY) 873 || (&expr->ref->u.ar != ar)) 874 return false; 875 } 876 877 if (sym == NULL) 878 tmp = expr->symtree->n.sym->backend_decl; 879 else 880 tmp = sym->backend_decl; 881 882 if (tmp && DECL_LANG_SPECIFIC (tmp)) 883 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); 884 885 *desc = tmp; 886 return true; 887 } 888 889 890 /* Return the span of an array. */ 891 892 tree 893 gfc_get_array_span (tree desc, gfc_expr *expr) 894 { 895 tree tmp; 896 897 if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL)) 898 { 899 if (POINTER_TYPE_P (TREE_TYPE (desc))) 900 desc = build_fold_indirect_ref_loc (input_location, desc); 901 902 /* This will have the span field set. */ 903 tmp = gfc_conv_descriptor_span_get (desc); 904 } 905 else if (TREE_CODE (desc) == COMPONENT_REF 906 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) 907 && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) 908 { 909 /* The descriptor is a class _data field and so use the vtable 910 size for the receiving span field. */ 911 tmp = gfc_get_vptr_from_expr (desc); 912 tmp = gfc_vptr_size_get (tmp); 913 } 914 else if (expr && expr->expr_type == EXPR_VARIABLE 915 && expr->symtree->n.sym->ts.type == BT_CLASS 916 && expr->ref->type == REF_COMPONENT 917 && expr->ref->next->type == REF_ARRAY 918 && expr->ref->next->next == NULL 919 && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) 920 { 921 /* Dummys come in sometimes with the descriptor detached from 922 the class field or declaration. */ 923 tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); 924 tmp = gfc_vptr_size_get (tmp); 925 } 926 else 927 { 928 /* If none of the fancy stuff works, the span is the element 929 size of the array. Attempt to deal with unbounded character 930 types if possible. Otherwise, return NULL_TREE. */ 931 tmp = gfc_get_element_type (TREE_TYPE (desc)); 932 if (tmp && TREE_CODE (tmp) == ARRAY_TYPE 933 && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE 934 || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp))))) 935 { 936 if (expr->expr_type == EXPR_VARIABLE 937 && expr->ts.type == BT_CHARACTER) 938 tmp = fold_convert (gfc_array_index_type, 939 gfc_get_expr_charlen (expr)); 940 else 941 tmp = NULL_TREE; 942 } 943 else 944 tmp = fold_convert (gfc_array_index_type, 945 size_in_bytes (tmp)); 946 } 947 return tmp; 948 } 949 950 951 /* Generate an initializer for a static pointer or allocatable array. */ 952 953 void 954 gfc_trans_static_array_pointer (gfc_symbol * sym) 955 { 956 tree type; 957 958 gcc_assert (TREE_STATIC (sym->backend_decl)); 959 /* Just zero the data member. */ 960 type = TREE_TYPE (sym->backend_decl); 961 DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); 962 } 963 964 965 /* If the bounds of SE's loop have not yet been set, see if they can be 966 determined from array spec AS, which is the array spec of a called 967 function. MAPPING maps the callee's dummy arguments to the values 968 that the caller is passing. Add any initialization and finalization 969 code to SE. */ 970 971 void 972 gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, 973 gfc_se * se, gfc_array_spec * as) 974 { 975 int n, dim, total_dim; 976 gfc_se tmpse; 977 gfc_ss *ss; 978 tree lower; 979 tree upper; 980 tree tmp; 981 982 total_dim = 0; 983 984 if (!as || as->type != AS_EXPLICIT) 985 return; 986 987 for (ss = se->ss; ss; ss = ss->parent) 988 { 989 total_dim += ss->loop->dimen; 990 for (n = 0; n < ss->loop->dimen; n++) 991 { 992 /* The bound is known, nothing to do. */ 993 if (ss->loop->to[n] != NULL_TREE) 994 continue; 995 996 dim = ss->dim[n]; 997 gcc_assert (dim < as->rank); 998 gcc_assert (ss->loop->dimen <= as->rank); 999 1000 /* Evaluate the lower bound. */ 1001 gfc_init_se (&tmpse, NULL); 1002 gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); 1003 gfc_add_block_to_block (&se->pre, &tmpse.pre); 1004 gfc_add_block_to_block (&se->post, &tmpse.post); 1005 lower = fold_convert (gfc_array_index_type, tmpse.expr); 1006 1007 /* ...and the upper bound. */ 1008 gfc_init_se (&tmpse, NULL); 1009 gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); 1010 gfc_add_block_to_block (&se->pre, &tmpse.pre); 1011 gfc_add_block_to_block (&se->post, &tmpse.post); 1012 upper = fold_convert (gfc_array_index_type, tmpse.expr); 1013 1014 /* Set the upper bound of the loop to UPPER - LOWER. */ 1015 tmp = fold_build2_loc (input_location, MINUS_EXPR, 1016 gfc_array_index_type, upper, lower); 1017 tmp = gfc_evaluate_now (tmp, &se->pre); 1018 ss->loop->to[n] = tmp; 1019 } 1020 } 1021 1022 gcc_assert (total_dim == as->rank); 1023 } 1024 1025 1026 /* Generate code to allocate an array temporary, or create a variable to 1027 hold the data. If size is NULL, zero the descriptor so that the 1028 callee will allocate the array. If DEALLOC is true, also generate code to 1029 free the array afterwards. 1030 1031 If INITIAL is not NULL, it is packed using internal_pack and the result used 1032 as data instead of allocating a fresh, unitialized area of memory. 1033 1034 Initialization code is added to PRE and finalization code to POST. 1035 DYNAMIC is true if the caller may want to extend the array later 1036 using realloc. This prevents us from putting the array on the stack. */ 1037 1038 static void 1039 gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, 1040 gfc_array_info * info, tree size, tree nelem, 1041 tree initial, bool dynamic, bool dealloc) 1042 { 1043 tree tmp; 1044 tree desc; 1045 bool onstack; 1046 1047 desc = info->descriptor; 1048 info->offset = gfc_index_zero_node; 1049 if (size == NULL_TREE || integer_zerop (size)) 1050 { 1051 /* A callee allocated array. */ 1052 gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); 1053 onstack = FALSE; 1054 } 1055 else 1056 { 1057 /* Allocate the temporary. */ 1058 onstack = !dynamic && initial == NULL_TREE 1059 && (flag_stack_arrays 1060 || gfc_can_put_var_on_stack (size)); 1061 1062 if (onstack) 1063 { 1064 /* Make a temporary variable to hold the data. */ 1065 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), 1066 nelem, gfc_index_one_node); 1067 tmp = gfc_evaluate_now (tmp, pre); 1068 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, 1069 tmp); 1070 tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), 1071 tmp); 1072 tmp = gfc_create_var (tmp, "A"); 1073 /* If we're here only because of -fstack-arrays we have to 1074 emit a DECL_EXPR to make the gimplifier emit alloca calls. */ 1075 if (!gfc_can_put_var_on_stack (size)) 1076 gfc_add_expr_to_block (pre, 1077 fold_build1_loc (input_location, 1078 DECL_EXPR, TREE_TYPE (tmp), 1079 tmp)); 1080 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 1081 gfc_conv_descriptor_data_set (pre, desc, tmp); 1082 } 1083 else 1084 { 1085 /* Allocate memory to hold the data or call internal_pack. */ 1086 if (initial == NULL_TREE) 1087 { 1088 tmp = gfc_call_malloc (pre, NULL, size); 1089 tmp = gfc_evaluate_now (tmp, pre); 1090 } 1091 else 1092 { 1093 tree packed; 1094 tree source_data; 1095 tree was_packed; 1096 stmtblock_t do_copying; 1097 1098 tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ 1099 gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); 1100 tmp = TREE_TYPE (tmp); /* The descriptor itself. */ 1101 tmp = gfc_get_element_type (tmp); 1102 gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc))); 1103 packed = gfc_create_var (build_pointer_type (tmp), "data"); 1104 1105 tmp = build_call_expr_loc (input_location, 1106 gfor_fndecl_in_pack, 1, initial); 1107 tmp = fold_convert (TREE_TYPE (packed), tmp); 1108 gfc_add_modify (pre, packed, tmp); 1109 1110 tmp = build_fold_indirect_ref_loc (input_location, 1111 initial); 1112 source_data = gfc_conv_descriptor_data_get (tmp); 1113 1114 /* internal_pack may return source->data without any allocation 1115 or copying if it is already packed. If that's the case, we 1116 need to allocate and copy manually. */ 1117 1118 gfc_start_block (&do_copying); 1119 tmp = gfc_call_malloc (&do_copying, NULL, size); 1120 tmp = fold_convert (TREE_TYPE (packed), tmp); 1121 gfc_add_modify (&do_copying, packed, tmp); 1122 tmp = gfc_build_memcpy_call (packed, source_data, size); 1123 gfc_add_expr_to_block (&do_copying, tmp); 1124 1125 was_packed = fold_build2_loc (input_location, EQ_EXPR, 1126 logical_type_node, packed, 1127 source_data); 1128 tmp = gfc_finish_block (&do_copying); 1129 tmp = build3_v (COND_EXPR, was_packed, tmp, 1130 build_empty_stmt (input_location)); 1131 gfc_add_expr_to_block (pre, tmp); 1132 1133 tmp = fold_convert (pvoid_type_node, packed); 1134 } 1135 1136 gfc_conv_descriptor_data_set (pre, desc, tmp); 1137 } 1138 } 1139 info->data = gfc_conv_descriptor_data_get (desc); 1140 1141 /* The offset is zero because we create temporaries with a zero 1142 lower bound. */ 1143 gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); 1144 1145 if (dealloc && !onstack) 1146 { 1147 /* Free the temporary. */ 1148 tmp = gfc_conv_descriptor_data_get (desc); 1149 tmp = gfc_call_free (tmp); 1150 gfc_add_expr_to_block (post, tmp); 1151 } 1152 } 1153 1154 1155 /* Get the scalarizer array dimension corresponding to actual array dimension 1156 given by ARRAY_DIM. 1157 1158 For example, if SS represents the array ref a(1,:,:,1), it is a 1159 bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, 1160 and 1 for ARRAY_DIM=2. 1161 If SS represents transpose(a(:,1,1,:)), it is again a bidimensional 1162 scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for 1163 ARRAY_DIM=3. 1164 If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer 1165 array. If called on the inner ss, the result would be respectively 0,1,2 for 1166 ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 1167 for ARRAY_DIM=1,2. */ 1168 1169 static int 1170 get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) 1171 { 1172 int array_ref_dim; 1173 int n; 1174 1175 array_ref_dim = 0; 1176 1177 for (; ss; ss = ss->parent) 1178 for (n = 0; n < ss->dimen; n++) 1179 if (ss->dim[n] < array_dim) 1180 array_ref_dim++; 1181 1182 return array_ref_dim; 1183 } 1184 1185 1186 static gfc_ss * 1187 innermost_ss (gfc_ss *ss) 1188 { 1189 while (ss->nested_ss != NULL) 1190 ss = ss->nested_ss; 1191 1192 return ss; 1193 } 1194 1195 1196 1197 /* Get the array reference dimension corresponding to the given loop dimension. 1198 It is different from the true array dimension given by the dim array in 1199 the case of a partial array reference (i.e. a(:,:,1,:) for example) 1200 It is different from the loop dimension in the case of a transposed array. 1201 */ 1202 1203 static int 1204 get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) 1205 { 1206 return get_scalarizer_dim_for_array_dim (innermost_ss (ss), 1207 ss->dim[loop_dim]); 1208 } 1209 1210 1211 /* Generate code to create and initialize the descriptor for a temporary 1212 array. This is used for both temporaries needed by the scalarizer, and 1213 functions returning arrays. Adjusts the loop variables to be 1214 zero-based, and calculates the loop bounds for callee allocated arrays. 1215 Allocate the array unless it's callee allocated (we have a callee 1216 allocated array if 'callee_alloc' is true, or if loop->to[n] is 1217 NULL_TREE for any n). Also fills in the descriptor, data and offset 1218 fields of info if known. Returns the size of the array, or NULL for a 1219 callee allocated array. 1220 1221 'eltype' == NULL signals that the temporary should be a class object. 1222 The 'initial' expression is used to obtain the size of the dynamic 1223 type; otherwise the allocation and initialization proceeds as for any 1224 other expression 1225 1226 PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for 1227 gfc_trans_allocate_array_storage. */ 1228 1229 tree 1230 gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, 1231 tree eltype, tree initial, bool dynamic, 1232 bool dealloc, bool callee_alloc, locus * where) 1233 { 1234 gfc_loopinfo *loop; 1235 gfc_ss *s; 1236 gfc_array_info *info; 1237 tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; 1238 tree type; 1239 tree desc; 1240 tree tmp; 1241 tree size; 1242 tree nelem; 1243 tree cond; 1244 tree or_expr; 1245 tree elemsize; 1246 tree class_expr = NULL_TREE; 1247 int n, dim, tmp_dim; 1248 int total_dim = 0; 1249 1250 /* This signals a class array for which we need the size of the 1251 dynamic type. Generate an eltype and then the class expression. */ 1252 if (eltype == NULL_TREE && initial) 1253 { 1254 gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); 1255 class_expr = build_fold_indirect_ref_loc (input_location, initial); 1256 eltype = TREE_TYPE (class_expr); 1257 eltype = gfc_get_element_type (eltype); 1258 /* Obtain the structure (class) expression. */ 1259 class_expr = TREE_OPERAND (class_expr, 0); 1260 gcc_assert (class_expr); 1261 } 1262 1263 memset (from, 0, sizeof (from)); 1264 memset (to, 0, sizeof (to)); 1265 1266 info = &ss->info->data.array; 1267 1268 gcc_assert (ss->dimen > 0); 1269 gcc_assert (ss->loop->dimen == ss->dimen); 1270 1271 if (warn_array_temporaries && where) 1272 gfc_warning (OPT_Warray_temporaries, 1273 "Creating array temporary at %L", where); 1274 1275 /* Set the lower bound to zero. */ 1276 for (s = ss; s; s = s->parent) 1277 { 1278 loop = s->loop; 1279 1280 total_dim += loop->dimen; 1281 for (n = 0; n < loop->dimen; n++) 1282 { 1283 dim = s->dim[n]; 1284 1285 /* Callee allocated arrays may not have a known bound yet. */ 1286 if (loop->to[n]) 1287 loop->to[n] = gfc_evaluate_now ( 1288 fold_build2_loc (input_location, MINUS_EXPR, 1289 gfc_array_index_type, 1290 loop->to[n], loop->from[n]), 1291 pre); 1292 loop->from[n] = gfc_index_zero_node; 1293 1294 /* We have just changed the loop bounds, we must clear the 1295 corresponding specloop, so that delta calculation is not skipped 1296 later in gfc_set_delta. */ 1297 loop->specloop[n] = NULL; 1298 1299 /* We are constructing the temporary's descriptor based on the loop 1300 dimensions. As the dimensions may be accessed in arbitrary order 1301 (think of transpose) the size taken from the n'th loop may not map 1302 to the n'th dimension of the array. We need to reconstruct loop 1303 infos in the right order before using it to set the descriptor 1304 bounds. */ 1305 tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); 1306 from[tmp_dim] = loop->from[n]; 1307 to[tmp_dim] = loop->to[n]; 1308 1309 info->delta[dim] = gfc_index_zero_node; 1310 info->start[dim] = gfc_index_zero_node; 1311 info->end[dim] = gfc_index_zero_node; 1312 info->stride[dim] = gfc_index_one_node; 1313 } 1314 } 1315 1316 /* Initialize the descriptor. */ 1317 type = 1318 gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, 1319 GFC_ARRAY_UNKNOWN, true); 1320 desc = gfc_create_var (type, "atmp"); 1321 GFC_DECL_PACKED_ARRAY (desc) = 1; 1322 1323 info->descriptor = desc; 1324 size = gfc_index_one_node; 1325 1326 /* Emit a DECL_EXPR for the variable sized array type in 1327 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type 1328 sizes works correctly. */ 1329 tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type)); 1330 if (! TYPE_NAME (arraytype)) 1331 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, 1332 NULL_TREE, arraytype); 1333 gfc_add_expr_to_block (pre, build1 (DECL_EXPR, 1334 arraytype, TYPE_NAME (arraytype))); 1335 1336 /* Fill in the array dtype. */ 1337 tmp = gfc_conv_descriptor_dtype (desc); 1338 gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); 1339 1340 /* 1341 Fill in the bounds and stride. This is a packed array, so: 1342 1343 size = 1; 1344 for (n = 0; n < rank; n++) 1345 { 1346 stride[n] = size 1347 delta = ubound[n] + 1 - lbound[n]; 1348 size = size * delta; 1349 } 1350 size = size * sizeof(element); 1351 */ 1352 1353 or_expr = NULL_TREE; 1354 1355 /* If there is at least one null loop->to[n], it is a callee allocated 1356 array. */ 1357 for (n = 0; n < total_dim; n++) 1358 if (to[n] == NULL_TREE) 1359 { 1360 size = NULL_TREE; 1361 break; 1362 } 1363 1364 if (size == NULL_TREE) 1365 for (s = ss; s; s = s->parent) 1366 for (n = 0; n < s->loop->dimen; n++) 1367 { 1368 dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); 1369 1370 /* For a callee allocated array express the loop bounds in terms 1371 of the descriptor fields. */ 1372 tmp = fold_build2_loc (input_location, 1373 MINUS_EXPR, gfc_array_index_type, 1374 gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), 1375 gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); 1376 s->loop->to[n] = tmp; 1377 } 1378 else 1379 { 1380 for (n = 0; n < total_dim; n++) 1381 { 1382 /* Store the stride and bound components in the descriptor. */ 1383 gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); 1384 1385 gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], 1386 gfc_index_zero_node); 1387 1388 gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); 1389 1390 tmp = fold_build2_loc (input_location, PLUS_EXPR, 1391 gfc_array_index_type, 1392 to[n], gfc_index_one_node); 1393 1394 /* Check whether the size for this dimension is negative. */ 1395 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, 1396 tmp, gfc_index_zero_node); 1397 cond = gfc_evaluate_now (cond, pre); 1398 1399 if (n == 0) 1400 or_expr = cond; 1401 else 1402 or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1403 logical_type_node, or_expr, cond); 1404 1405 size = fold_build2_loc (input_location, MULT_EXPR, 1406 gfc_array_index_type, size, tmp); 1407 size = gfc_evaluate_now (size, pre); 1408 } 1409 } 1410 1411 if (class_expr == NULL_TREE) 1412 elemsize = fold_convert (gfc_array_index_type, 1413 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 1414 else 1415 elemsize = gfc_class_vtab_size_get (class_expr); 1416 1417 /* Get the size of the array. */ 1418 if (size && !callee_alloc) 1419 { 1420 /* If or_expr is true, then the extent in at least one 1421 dimension is zero and the size is set to zero. */ 1422 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, 1423 or_expr, gfc_index_zero_node, size); 1424 1425 nelem = size; 1426 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 1427 size, elemsize); 1428 } 1429 else 1430 { 1431 nelem = size; 1432 size = NULL_TREE; 1433 } 1434 1435 /* Set the span. */ 1436 tmp = fold_convert (gfc_array_index_type, elemsize); 1437 gfc_conv_descriptor_span_set (pre, desc, tmp); 1438 1439 gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, 1440 dynamic, dealloc); 1441 1442 while (ss->parent) 1443 ss = ss->parent; 1444 1445 if (ss->dimen > ss->loop->temp_dim) 1446 ss->loop->temp_dim = ss->dimen; 1447 1448 return size; 1449 } 1450 1451 1452 /* Return the number of iterations in a loop that starts at START, 1453 ends at END, and has step STEP. */ 1454 1455 static tree 1456 gfc_get_iteration_count (tree start, tree end, tree step) 1457 { 1458 tree tmp; 1459 tree type; 1460 1461 type = TREE_TYPE (step); 1462 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); 1463 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); 1464 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, 1465 build_int_cst (type, 1)); 1466 tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, 1467 build_int_cst (type, 0)); 1468 return fold_convert (gfc_array_index_type, tmp); 1469 } 1470 1471 1472 /* Extend the data in array DESC by EXTRA elements. */ 1473 1474 static void 1475 gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) 1476 { 1477 tree arg0, arg1; 1478 tree tmp; 1479 tree size; 1480 tree ubound; 1481 1482 if (integer_zerop (extra)) 1483 return; 1484 1485 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); 1486 1487 /* Add EXTRA to the upper bound. */ 1488 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1489 ubound, extra); 1490 gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); 1491 1492 /* Get the value of the current data pointer. */ 1493 arg0 = gfc_conv_descriptor_data_get (desc); 1494 1495 /* Calculate the new array size. */ 1496 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); 1497 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1498 ubound, gfc_index_one_node); 1499 arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 1500 fold_convert (size_type_node, tmp), 1501 fold_convert (size_type_node, size)); 1502 1503 /* Call the realloc() function. */ 1504 tmp = gfc_call_realloc (pblock, arg0, arg1); 1505 gfc_conv_descriptor_data_set (pblock, desc, tmp); 1506 } 1507 1508 1509 /* Return true if the bounds of iterator I can only be determined 1510 at run time. */ 1511 1512 static inline bool 1513 gfc_iterator_has_dynamic_bounds (gfc_iterator * i) 1514 { 1515 return (i->start->expr_type != EXPR_CONSTANT 1516 || i->end->expr_type != EXPR_CONSTANT 1517 || i->step->expr_type != EXPR_CONSTANT); 1518 } 1519 1520 1521 /* Split the size of constructor element EXPR into the sum of two terms, 1522 one of which can be determined at compile time and one of which must 1523 be calculated at run time. Set *SIZE to the former and return true 1524 if the latter might be nonzero. */ 1525 1526 static bool 1527 gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) 1528 { 1529 if (expr->expr_type == EXPR_ARRAY) 1530 return gfc_get_array_constructor_size (size, expr->value.constructor); 1531 else if (expr->rank > 0) 1532 { 1533 /* Calculate everything at run time. */ 1534 mpz_set_ui (*size, 0); 1535 return true; 1536 } 1537 else 1538 { 1539 /* A single element. */ 1540 mpz_set_ui (*size, 1); 1541 return false; 1542 } 1543 } 1544 1545 1546 /* Like gfc_get_array_constructor_element_size, but applied to the whole 1547 of array constructor C. */ 1548 1549 static bool 1550 gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) 1551 { 1552 gfc_constructor *c; 1553 gfc_iterator *i; 1554 mpz_t val; 1555 mpz_t len; 1556 bool dynamic; 1557 1558 mpz_set_ui (*size, 0); 1559 mpz_init (len); 1560 mpz_init (val); 1561 1562 dynamic = false; 1563 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1564 { 1565 i = c->iterator; 1566 if (i && gfc_iterator_has_dynamic_bounds (i)) 1567 dynamic = true; 1568 else 1569 { 1570 dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); 1571 if (i) 1572 { 1573 /* Multiply the static part of the element size by the 1574 number of iterations. */ 1575 mpz_sub (val, i->end->value.integer, i->start->value.integer); 1576 mpz_fdiv_q (val, val, i->step->value.integer); 1577 mpz_add_ui (val, val, 1); 1578 if (mpz_sgn (val) > 0) 1579 mpz_mul (len, len, val); 1580 else 1581 mpz_set_ui (len, 0); 1582 } 1583 mpz_add (*size, *size, len); 1584 } 1585 } 1586 mpz_clear (len); 1587 mpz_clear (val); 1588 return dynamic; 1589 } 1590 1591 1592 /* Make sure offset is a variable. */ 1593 1594 static void 1595 gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, 1596 tree * offsetvar) 1597 { 1598 /* We should have already created the offset variable. We cannot 1599 create it here because we may be in an inner scope. */ 1600 gcc_assert (*offsetvar != NULL_TREE); 1601 gfc_add_modify (pblock, *offsetvar, *poffset); 1602 *poffset = *offsetvar; 1603 TREE_USED (*offsetvar) = 1; 1604 } 1605 1606 1607 /* Variables needed for bounds-checking. */ 1608 static bool first_len; 1609 static tree first_len_val; 1610 static bool typespec_chararray_ctor; 1611 1612 static void 1613 gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, 1614 tree offset, gfc_se * se, gfc_expr * expr) 1615 { 1616 tree tmp; 1617 1618 gfc_conv_expr (se, expr); 1619 1620 /* Store the value. */ 1621 tmp = build_fold_indirect_ref_loc (input_location, 1622 gfc_conv_descriptor_data_get (desc)); 1623 tmp = gfc_build_array_ref (tmp, offset, NULL); 1624 1625 if (expr->ts.type == BT_CHARACTER) 1626 { 1627 int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); 1628 tree esize; 1629 1630 esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); 1631 esize = fold_convert (gfc_charlen_type_node, esize); 1632 esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 1633 TREE_TYPE (esize), esize, 1634 build_int_cst (TREE_TYPE (esize), 1635 gfc_character_kinds[i].bit_size / 8)); 1636 1637 gfc_conv_string_parameter (se); 1638 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 1639 { 1640 /* The temporary is an array of pointers. */ 1641 se->expr = fold_convert (TREE_TYPE (tmp), se->expr); 1642 gfc_add_modify (&se->pre, tmp, se->expr); 1643 } 1644 else 1645 { 1646 /* The temporary is an array of string values. */ 1647 tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); 1648 /* We know the temporary and the value will be the same length, 1649 so can use memcpy. */ 1650 gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, 1651 se->string_length, se->expr, expr->ts.kind); 1652 } 1653 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) 1654 { 1655 if (first_len) 1656 { 1657 gfc_add_modify (&se->pre, first_len_val, 1658 fold_convert (TREE_TYPE (first_len_val), 1659 se->string_length)); 1660 first_len = false; 1661 } 1662 else 1663 { 1664 /* Verify that all constructor elements are of the same 1665 length. */ 1666 tree rhs = fold_convert (TREE_TYPE (first_len_val), 1667 se->string_length); 1668 tree cond = fold_build2_loc (input_location, NE_EXPR, 1669 logical_type_node, first_len_val, 1670 rhs); 1671 gfc_trans_runtime_check 1672 (true, false, cond, &se->pre, &expr->where, 1673 "Different CHARACTER lengths (%ld/%ld) in array constructor", 1674 fold_convert (long_integer_type_node, first_len_val), 1675 fold_convert (long_integer_type_node, se->string_length)); 1676 } 1677 } 1678 } 1679 else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) 1680 && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) 1681 { 1682 /* Assignment of a CLASS array constructor to a derived type array. */ 1683 if (expr->expr_type == EXPR_FUNCTION) 1684 se->expr = gfc_evaluate_now (se->expr, pblock); 1685 se->expr = gfc_class_data_get (se->expr); 1686 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 1687 se->expr = fold_convert (TREE_TYPE (tmp), se->expr); 1688 gfc_add_modify (&se->pre, tmp, se->expr); 1689 } 1690 else 1691 { 1692 /* TODO: Should the frontend already have done this conversion? */ 1693 se->expr = fold_convert (TREE_TYPE (tmp), se->expr); 1694 gfc_add_modify (&se->pre, tmp, se->expr); 1695 } 1696 1697 gfc_add_block_to_block (pblock, &se->pre); 1698 gfc_add_block_to_block (pblock, &se->post); 1699 } 1700 1701 1702 /* Add the contents of an array to the constructor. DYNAMIC is as for 1703 gfc_trans_array_constructor_value. */ 1704 1705 static void 1706 gfc_trans_array_constructor_subarray (stmtblock_t * pblock, 1707 tree type ATTRIBUTE_UNUSED, 1708 tree desc, gfc_expr * expr, 1709 tree * poffset, tree * offsetvar, 1710 bool dynamic) 1711 { 1712 gfc_se se; 1713 gfc_ss *ss; 1714 gfc_loopinfo loop; 1715 stmtblock_t body; 1716 tree tmp; 1717 tree size; 1718 int n; 1719 1720 /* We need this to be a variable so we can increment it. */ 1721 gfc_put_offset_into_var (pblock, poffset, offsetvar); 1722 1723 gfc_init_se (&se, NULL); 1724 1725 /* Walk the array expression. */ 1726 ss = gfc_walk_expr (expr); 1727 gcc_assert (ss != gfc_ss_terminator); 1728 1729 /* Initialize the scalarizer. */ 1730 gfc_init_loopinfo (&loop); 1731 gfc_add_ss_to_loop (&loop, ss); 1732 1733 /* Initialize the loop. */ 1734 gfc_conv_ss_startstride (&loop); 1735 gfc_conv_loop_setup (&loop, &expr->where); 1736 1737 /* Make sure the constructed array has room for the new data. */ 1738 if (dynamic) 1739 { 1740 /* Set SIZE to the total number of elements in the subarray. */ 1741 size = gfc_index_one_node; 1742 for (n = 0; n < loop.dimen; n++) 1743 { 1744 tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], 1745 gfc_index_one_node); 1746 size = fold_build2_loc (input_location, MULT_EXPR, 1747 gfc_array_index_type, size, tmp); 1748 } 1749 1750 /* Grow the constructed array by SIZE elements. */ 1751 gfc_grow_array (&loop.pre, desc, size); 1752 } 1753 1754 /* Make the loop body. */ 1755 gfc_mark_ss_chain_used (ss, 1); 1756 gfc_start_scalarized_body (&loop, &body); 1757 gfc_copy_loopinfo_to_se (&se, &loop); 1758 se.ss = ss; 1759 1760 gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); 1761 gcc_assert (se.ss == gfc_ss_terminator); 1762 1763 /* Increment the offset. */ 1764 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1765 *poffset, gfc_index_one_node); 1766 gfc_add_modify (&body, *poffset, tmp); 1767 1768 /* Finish the loop. */ 1769 gfc_trans_scalarizing_loops (&loop, &body); 1770 gfc_add_block_to_block (&loop.pre, &loop.post); 1771 tmp = gfc_finish_block (&loop.pre); 1772 gfc_add_expr_to_block (pblock, tmp); 1773 1774 gfc_cleanup_loop (&loop); 1775 } 1776 1777 1778 /* Assign the values to the elements of an array constructor. DYNAMIC 1779 is true if descriptor DESC only contains enough data for the static 1780 size calculated by gfc_get_array_constructor_size. When true, memory 1781 for the dynamic parts must be allocated using realloc. */ 1782 1783 static void 1784 gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, 1785 tree desc, gfc_constructor_base base, 1786 tree * poffset, tree * offsetvar, 1787 bool dynamic) 1788 { 1789 tree tmp; 1790 tree start = NULL_TREE; 1791 tree end = NULL_TREE; 1792 tree step = NULL_TREE; 1793 stmtblock_t body; 1794 gfc_se se; 1795 mpz_t size; 1796 gfc_constructor *c; 1797 1798 tree shadow_loopvar = NULL_TREE; 1799 gfc_saved_var saved_loopvar; 1800 1801 mpz_init (size); 1802 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 1803 { 1804 /* If this is an iterator or an array, the offset must be a variable. */ 1805 if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) 1806 gfc_put_offset_into_var (pblock, poffset, offsetvar); 1807 1808 /* Shadowing the iterator avoids changing its value and saves us from 1809 keeping track of it. Further, it makes sure that there's always a 1810 backend-decl for the symbol, even if there wasn't one before, 1811 e.g. in the case of an iterator that appears in a specification 1812 expression in an interface mapping. */ 1813 if (c->iterator) 1814 { 1815 gfc_symbol *sym; 1816 tree type; 1817 1818 /* Evaluate loop bounds before substituting the loop variable 1819 in case they depend on it. Such a case is invalid, but it is 1820 not more expensive to do the right thing here. 1821 See PR 44354. */ 1822 gfc_init_se (&se, NULL); 1823 gfc_conv_expr_val (&se, c->iterator->start); 1824 gfc_add_block_to_block (pblock, &se.pre); 1825 start = gfc_evaluate_now (se.expr, pblock); 1826 1827 gfc_init_se (&se, NULL); 1828 gfc_conv_expr_val (&se, c->iterator->end); 1829 gfc_add_block_to_block (pblock, &se.pre); 1830 end = gfc_evaluate_now (se.expr, pblock); 1831 1832 gfc_init_se (&se, NULL); 1833 gfc_conv_expr_val (&se, c->iterator->step); 1834 gfc_add_block_to_block (pblock, &se.pre); 1835 step = gfc_evaluate_now (se.expr, pblock); 1836 1837 sym = c->iterator->var->symtree->n.sym; 1838 type = gfc_typenode_for_spec (&sym->ts); 1839 1840 shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); 1841 gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); 1842 } 1843 1844 gfc_start_block (&body); 1845 1846 if (c->expr->expr_type == EXPR_ARRAY) 1847 { 1848 /* Array constructors can be nested. */ 1849 gfc_trans_array_constructor_value (&body, type, desc, 1850 c->expr->value.constructor, 1851 poffset, offsetvar, dynamic); 1852 } 1853 else if (c->expr->rank > 0) 1854 { 1855 gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, 1856 poffset, offsetvar, dynamic); 1857 } 1858 else 1859 { 1860 /* This code really upsets the gimplifier so don't bother for now. */ 1861 gfc_constructor *p; 1862 HOST_WIDE_INT n; 1863 HOST_WIDE_INT size; 1864 1865 p = c; 1866 n = 0; 1867 while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) 1868 { 1869 p = gfc_constructor_next (p); 1870 n++; 1871 } 1872 if (n < 4) 1873 { 1874 /* Scalar values. */ 1875 gfc_init_se (&se, NULL); 1876 gfc_trans_array_ctor_element (&body, desc, *poffset, 1877 &se, c->expr); 1878 1879 *poffset = fold_build2_loc (input_location, PLUS_EXPR, 1880 gfc_array_index_type, 1881 *poffset, gfc_index_one_node); 1882 } 1883 else 1884 { 1885 /* Collect multiple scalar constants into a constructor. */ 1886 vec<constructor_elt, va_gc> *v = NULL; 1887 tree init; 1888 tree bound; 1889 tree tmptype; 1890 HOST_WIDE_INT idx = 0; 1891 1892 p = c; 1893 /* Count the number of consecutive scalar constants. */ 1894 while (p && !(p->iterator 1895 || p->expr->expr_type != EXPR_CONSTANT)) 1896 { 1897 gfc_init_se (&se, NULL); 1898 gfc_conv_constant (&se, p->expr); 1899 1900 if (c->expr->ts.type != BT_CHARACTER) 1901 se.expr = fold_convert (type, se.expr); 1902 /* For constant character array constructors we build 1903 an array of pointers. */ 1904 else if (POINTER_TYPE_P (type)) 1905 se.expr = gfc_build_addr_expr 1906 (gfc_get_pchar_type (p->expr->ts.kind), 1907 se.expr); 1908 1909 CONSTRUCTOR_APPEND_ELT (v, 1910 build_int_cst (gfc_array_index_type, 1911 idx++), 1912 se.expr); 1913 c = p; 1914 p = gfc_constructor_next (p); 1915 } 1916 1917 bound = size_int (n - 1); 1918 /* Create an array type to hold them. */ 1919 tmptype = build_range_type (gfc_array_index_type, 1920 gfc_index_zero_node, bound); 1921 tmptype = build_array_type (type, tmptype); 1922 1923 init = build_constructor (tmptype, v); 1924 TREE_CONSTANT (init) = 1; 1925 TREE_STATIC (init) = 1; 1926 /* Create a static variable to hold the data. */ 1927 tmp = gfc_create_var (tmptype, "data"); 1928 TREE_STATIC (tmp) = 1; 1929 TREE_CONSTANT (tmp) = 1; 1930 TREE_READONLY (tmp) = 1; 1931 DECL_INITIAL (tmp) = init; 1932 init = tmp; 1933 1934 /* Use BUILTIN_MEMCPY to assign the values. */ 1935 tmp = gfc_conv_descriptor_data_get (desc); 1936 tmp = build_fold_indirect_ref_loc (input_location, 1937 tmp); 1938 tmp = gfc_build_array_ref (tmp, *poffset, NULL); 1939 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 1940 init = gfc_build_addr_expr (NULL_TREE, init); 1941 1942 size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); 1943 bound = build_int_cst (size_type_node, n * size); 1944 tmp = build_call_expr_loc (input_location, 1945 builtin_decl_explicit (BUILT_IN_MEMCPY), 1946 3, tmp, init, bound); 1947 gfc_add_expr_to_block (&body, tmp); 1948 1949 *poffset = fold_build2_loc (input_location, PLUS_EXPR, 1950 gfc_array_index_type, *poffset, 1951 build_int_cst (gfc_array_index_type, n)); 1952 } 1953 if (!INTEGER_CST_P (*poffset)) 1954 { 1955 gfc_add_modify (&body, *offsetvar, *poffset); 1956 *poffset = *offsetvar; 1957 } 1958 } 1959 1960 /* The frontend should already have done any expansions 1961 at compile-time. */ 1962 if (!c->iterator) 1963 { 1964 /* Pass the code as is. */ 1965 tmp = gfc_finish_block (&body); 1966 gfc_add_expr_to_block (pblock, tmp); 1967 } 1968 else 1969 { 1970 /* Build the implied do-loop. */ 1971 stmtblock_t implied_do_block; 1972 tree cond; 1973 tree exit_label; 1974 tree loopbody; 1975 tree tmp2; 1976 1977 loopbody = gfc_finish_block (&body); 1978 1979 /* Create a new block that holds the implied-do loop. A temporary 1980 loop-variable is used. */ 1981 gfc_start_block(&implied_do_block); 1982 1983 /* Initialize the loop. */ 1984 gfc_add_modify (&implied_do_block, shadow_loopvar, start); 1985 1986 /* If this array expands dynamically, and the number of iterations 1987 is not constant, we won't have allocated space for the static 1988 part of C->EXPR's size. Do that now. */ 1989 if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) 1990 { 1991 /* Get the number of iterations. */ 1992 tmp = gfc_get_iteration_count (shadow_loopvar, end, step); 1993 1994 /* Get the static part of C->EXPR's size. */ 1995 gfc_get_array_constructor_element_size (&size, c->expr); 1996 tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); 1997 1998 /* Grow the array by TMP * TMP2 elements. */ 1999 tmp = fold_build2_loc (input_location, MULT_EXPR, 2000 gfc_array_index_type, tmp, tmp2); 2001 gfc_grow_array (&implied_do_block, desc, tmp); 2002 } 2003 2004 /* Generate the loop body. */ 2005 exit_label = gfc_build_label_decl (NULL_TREE); 2006 gfc_start_block (&body); 2007 2008 /* Generate the exit condition. Depending on the sign of 2009 the step variable we have to generate the correct 2010 comparison. */ 2011 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, 2012 step, build_int_cst (TREE_TYPE (step), 0)); 2013 cond = fold_build3_loc (input_location, COND_EXPR, 2014 logical_type_node, tmp, 2015 fold_build2_loc (input_location, GT_EXPR, 2016 logical_type_node, shadow_loopvar, end), 2017 fold_build2_loc (input_location, LT_EXPR, 2018 logical_type_node, shadow_loopvar, end)); 2019 tmp = build1_v (GOTO_EXPR, exit_label); 2020 TREE_USED (exit_label) = 1; 2021 tmp = build3_v (COND_EXPR, cond, tmp, 2022 build_empty_stmt (input_location)); 2023 gfc_add_expr_to_block (&body, tmp); 2024 2025 /* The main loop body. */ 2026 gfc_add_expr_to_block (&body, loopbody); 2027 2028 /* Increase loop variable by step. */ 2029 tmp = fold_build2_loc (input_location, PLUS_EXPR, 2030 TREE_TYPE (shadow_loopvar), shadow_loopvar, 2031 step); 2032 gfc_add_modify (&body, shadow_loopvar, tmp); 2033 2034 /* Finish the loop. */ 2035 tmp = gfc_finish_block (&body); 2036 tmp = build1_v (LOOP_EXPR, tmp); 2037 gfc_add_expr_to_block (&implied_do_block, tmp); 2038 2039 /* Add the exit label. */ 2040 tmp = build1_v (LABEL_EXPR, exit_label); 2041 gfc_add_expr_to_block (&implied_do_block, tmp); 2042 2043 /* Finish the implied-do loop. */ 2044 tmp = gfc_finish_block(&implied_do_block); 2045 gfc_add_expr_to_block(pblock, tmp); 2046 2047 gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); 2048 } 2049 } 2050 mpz_clear (size); 2051 } 2052 2053 2054 /* The array constructor code can create a string length with an operand 2055 in the form of a temporary variable. This variable will retain its 2056 context (current_function_decl). If we store this length tree in a 2057 gfc_charlen structure which is shared by a variable in another 2058 context, the resulting gfc_charlen structure with a variable in a 2059 different context, we could trip the assertion in expand_expr_real_1 2060 when it sees that a variable has been created in one context and 2061 referenced in another. 2062 2063 If this might be the case, we create a new gfc_charlen structure and 2064 link it into the current namespace. */ 2065 2066 static void 2067 store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl) 2068 { 2069 if (force_new_cl) 2070 { 2071 gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp); 2072 *clp = new_cl; 2073 } 2074 (*clp)->backend_decl = len; 2075 } 2076 2077 /* A catch-all to obtain the string length for anything that is not 2078 a substring of non-constant length, a constant, array or variable. */ 2079 2080 static void 2081 get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) 2082 { 2083 gfc_se se; 2084 2085 /* Don't bother if we already know the length is a constant. */ 2086 if (*len && INTEGER_CST_P (*len)) 2087 return; 2088 2089 if (!e->ref && e->ts.u.cl && e->ts.u.cl->length 2090 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2091 { 2092 /* This is easy. */ 2093 gfc_conv_const_charlen (e->ts.u.cl); 2094 *len = e->ts.u.cl->backend_decl; 2095 } 2096 else 2097 { 2098 /* Otherwise, be brutal even if inefficient. */ 2099 gfc_init_se (&se, NULL); 2100 2101 /* No function call, in case of side effects. */ 2102 se.no_function_call = 1; 2103 if (e->rank == 0) 2104 gfc_conv_expr (&se, e); 2105 else 2106 gfc_conv_expr_descriptor (&se, e); 2107 2108 /* Fix the value. */ 2109 *len = gfc_evaluate_now (se.string_length, &se.pre); 2110 2111 gfc_add_block_to_block (block, &se.pre); 2112 gfc_add_block_to_block (block, &se.post); 2113 2114 store_backend_decl (&e->ts.u.cl, *len, true); 2115 } 2116 } 2117 2118 2119 /* Figure out the string length of a variable reference expression. 2120 Used by get_array_ctor_strlen. */ 2121 2122 static void 2123 get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) 2124 { 2125 gfc_ref *ref; 2126 gfc_typespec *ts; 2127 mpz_t char_len; 2128 2129 /* Don't bother if we already know the length is a constant. */ 2130 if (*len && INTEGER_CST_P (*len)) 2131 return; 2132 2133 ts = &expr->symtree->n.sym->ts; 2134 for (ref = expr->ref; ref; ref = ref->next) 2135 { 2136 switch (ref->type) 2137 { 2138 case REF_ARRAY: 2139 /* Array references don't change the string length. */ 2140 if (ts->deferred) 2141 get_array_ctor_all_strlen (block, expr, len); 2142 break; 2143 2144 case REF_COMPONENT: 2145 /* Use the length of the component. */ 2146 ts = &ref->u.c.component->ts; 2147 break; 2148 2149 case REF_SUBSTRING: 2150 if (ref->u.ss.end == NULL 2151 || ref->u.ss.start->expr_type != EXPR_CONSTANT 2152 || ref->u.ss.end->expr_type != EXPR_CONSTANT) 2153 { 2154 /* Note that this might evaluate expr. */ 2155 get_array_ctor_all_strlen (block, expr, len); 2156 return; 2157 } 2158 mpz_init_set_ui (char_len, 1); 2159 mpz_add (char_len, char_len, ref->u.ss.end->value.integer); 2160 mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); 2161 *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); 2162 mpz_clear (char_len); 2163 return; 2164 2165 case REF_INQUIRY: 2166 break; 2167 2168 default: 2169 gcc_unreachable (); 2170 } 2171 } 2172 2173 *len = ts->u.cl->backend_decl; 2174 } 2175 2176 2177 /* Figure out the string length of a character array constructor. 2178 If len is NULL, don't calculate the length; this happens for recursive calls 2179 when a sub-array-constructor is an element but not at the first position, 2180 so when we're not interested in the length. 2181 Returns TRUE if all elements are character constants. */ 2182 2183 bool 2184 get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) 2185 { 2186 gfc_constructor *c; 2187 bool is_const; 2188 2189 is_const = TRUE; 2190 2191 if (gfc_constructor_first (base) == NULL) 2192 { 2193 if (len) 2194 *len = build_int_cstu (gfc_charlen_type_node, 0); 2195 return is_const; 2196 } 2197 2198 /* Loop over all constructor elements to find out is_const, but in len we 2199 want to store the length of the first, not the last, element. We can 2200 of course exit the loop as soon as is_const is found to be false. */ 2201 for (c = gfc_constructor_first (base); 2202 c && is_const; c = gfc_constructor_next (c)) 2203 { 2204 switch (c->expr->expr_type) 2205 { 2206 case EXPR_CONSTANT: 2207 if (len && !(*len && INTEGER_CST_P (*len))) 2208 *len = build_int_cstu (gfc_charlen_type_node, 2209 c->expr->value.character.length); 2210 break; 2211 2212 case EXPR_ARRAY: 2213 if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) 2214 is_const = false; 2215 break; 2216 2217 case EXPR_VARIABLE: 2218 is_const = false; 2219 if (len) 2220 get_array_ctor_var_strlen (block, c->expr, len); 2221 break; 2222 2223 default: 2224 is_const = false; 2225 if (len) 2226 get_array_ctor_all_strlen (block, c->expr, len); 2227 break; 2228 } 2229 2230 /* After the first iteration, we don't want the length modified. */ 2231 len = NULL; 2232 } 2233 2234 return is_const; 2235 } 2236 2237 /* Check whether the array constructor C consists entirely of constant 2238 elements, and if so returns the number of those elements, otherwise 2239 return zero. Note, an empty or NULL array constructor returns zero. */ 2240 2241 unsigned HOST_WIDE_INT 2242 gfc_constant_array_constructor_p (gfc_constructor_base base) 2243 { 2244 unsigned HOST_WIDE_INT nelem = 0; 2245 2246 gfc_constructor *c = gfc_constructor_first (base); 2247 while (c) 2248 { 2249 if (c->iterator 2250 || c->expr->rank > 0 2251 || c->expr->expr_type != EXPR_CONSTANT) 2252 return 0; 2253 c = gfc_constructor_next (c); 2254 nelem++; 2255 } 2256 return nelem; 2257 } 2258 2259 2260 /* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, 2261 and the tree type of it's elements, TYPE, return a static constant 2262 variable that is compile-time initialized. */ 2263 2264 tree 2265 gfc_build_constant_array_constructor (gfc_expr * expr, tree type) 2266 { 2267 tree tmptype, init, tmp; 2268 HOST_WIDE_INT nelem; 2269 gfc_constructor *c; 2270 gfc_array_spec as; 2271 gfc_se se; 2272 int i; 2273 vec<constructor_elt, va_gc> *v = NULL; 2274 2275 /* First traverse the constructor list, converting the constants 2276 to tree to build an initializer. */ 2277 nelem = 0; 2278 c = gfc_constructor_first (expr->value.constructor); 2279 while (c) 2280 { 2281 gfc_init_se (&se, NULL); 2282 gfc_conv_constant (&se, c->expr); 2283 if (c->expr->ts.type != BT_CHARACTER) 2284 se.expr = fold_convert (type, se.expr); 2285 else if (POINTER_TYPE_P (type)) 2286 se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), 2287 se.expr); 2288 CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), 2289 se.expr); 2290 c = gfc_constructor_next (c); 2291 nelem++; 2292 } 2293 2294 /* Next determine the tree type for the array. We use the gfortran 2295 front-end's gfc_get_nodesc_array_type in order to create a suitable 2296 GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ 2297 2298 memset (&as, 0, sizeof (gfc_array_spec)); 2299 2300 as.rank = expr->rank; 2301 as.type = AS_EXPLICIT; 2302 if (!expr->shape) 2303 { 2304 as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); 2305 as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, 2306 NULL, nelem - 1); 2307 } 2308 else 2309 for (i = 0; i < expr->rank; i++) 2310 { 2311 int tmp = (int) mpz_get_si (expr->shape[i]); 2312 as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); 2313 as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, 2314 NULL, tmp - 1); 2315 } 2316 2317 tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); 2318 2319 /* as is not needed anymore. */ 2320 for (i = 0; i < as.rank + as.corank; i++) 2321 { 2322 gfc_free_expr (as.lower[i]); 2323 gfc_free_expr (as.upper[i]); 2324 } 2325 2326 init = build_constructor (tmptype, v); 2327 2328 TREE_CONSTANT (init) = 1; 2329 TREE_STATIC (init) = 1; 2330 2331 tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"), 2332 tmptype); 2333 DECL_ARTIFICIAL (tmp) = 1; 2334 DECL_IGNORED_P (tmp) = 1; 2335 TREE_STATIC (tmp) = 1; 2336 TREE_CONSTANT (tmp) = 1; 2337 TREE_READONLY (tmp) = 1; 2338 DECL_INITIAL (tmp) = init; 2339 pushdecl (tmp); 2340 2341 return tmp; 2342 } 2343 2344 2345 /* Translate a constant EXPR_ARRAY array constructor for the scalarizer. 2346 This mostly initializes the scalarizer state info structure with the 2347 appropriate values to directly use the array created by the function 2348 gfc_build_constant_array_constructor. */ 2349 2350 static void 2351 trans_constant_array_constructor (gfc_ss * ss, tree type) 2352 { 2353 gfc_array_info *info; 2354 tree tmp; 2355 int i; 2356 2357 tmp = gfc_build_constant_array_constructor (ss->info->expr, type); 2358 2359 info = &ss->info->data.array; 2360 2361 info->descriptor = tmp; 2362 info->data = gfc_build_addr_expr (NULL_TREE, tmp); 2363 info->offset = gfc_index_zero_node; 2364 2365 for (i = 0; i < ss->dimen; i++) 2366 { 2367 info->delta[i] = gfc_index_zero_node; 2368 info->start[i] = gfc_index_zero_node; 2369 info->end[i] = gfc_index_zero_node; 2370 info->stride[i] = gfc_index_one_node; 2371 } 2372 } 2373 2374 2375 static int 2376 get_rank (gfc_loopinfo *loop) 2377 { 2378 int rank; 2379 2380 rank = 0; 2381 for (; loop; loop = loop->parent) 2382 rank += loop->dimen; 2383 2384 return rank; 2385 } 2386 2387 2388 /* Helper routine of gfc_trans_array_constructor to determine if the 2389 bounds of the loop specified by LOOP are constant and simple enough 2390 to use with trans_constant_array_constructor. Returns the 2391 iteration count of the loop if suitable, and NULL_TREE otherwise. */ 2392 2393 static tree 2394 constant_array_constructor_loop_size (gfc_loopinfo * l) 2395 { 2396 gfc_loopinfo *loop; 2397 tree size = gfc_index_one_node; 2398 tree tmp; 2399 int i, total_dim; 2400 2401 total_dim = get_rank (l); 2402 2403 for (loop = l; loop; loop = loop->parent) 2404 { 2405 for (i = 0; i < loop->dimen; i++) 2406 { 2407 /* If the bounds aren't constant, return NULL_TREE. */ 2408 if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) 2409 return NULL_TREE; 2410 if (!integer_zerop (loop->from[i])) 2411 { 2412 /* Only allow nonzero "from" in one-dimensional arrays. */ 2413 if (total_dim != 1) 2414 return NULL_TREE; 2415 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2416 gfc_array_index_type, 2417 loop->to[i], loop->from[i]); 2418 } 2419 else 2420 tmp = loop->to[i]; 2421 tmp = fold_build2_loc (input_location, PLUS_EXPR, 2422 gfc_array_index_type, tmp, gfc_index_one_node); 2423 size = fold_build2_loc (input_location, MULT_EXPR, 2424 gfc_array_index_type, size, tmp); 2425 } 2426 } 2427 2428 return size; 2429 } 2430 2431 2432 static tree * 2433 get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) 2434 { 2435 gfc_ss *ss; 2436 int n; 2437 2438 gcc_assert (array->nested_ss == NULL); 2439 2440 for (ss = array; ss; ss = ss->parent) 2441 for (n = 0; n < ss->loop->dimen; n++) 2442 if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) 2443 return &(ss->loop->to[n]); 2444 2445 gcc_unreachable (); 2446 } 2447 2448 2449 static gfc_loopinfo * 2450 outermost_loop (gfc_loopinfo * loop) 2451 { 2452 while (loop->parent != NULL) 2453 loop = loop->parent; 2454 2455 return loop; 2456 } 2457 2458 2459 /* Array constructors are handled by constructing a temporary, then using that 2460 within the scalarization loop. This is not optimal, but seems by far the 2461 simplest method. */ 2462 2463 static void 2464 trans_array_constructor (gfc_ss * ss, locus * where) 2465 { 2466 gfc_constructor_base c; 2467 tree offset; 2468 tree offsetvar; 2469 tree desc; 2470 tree type; 2471 tree tmp; 2472 tree *loop_ubound0; 2473 bool dynamic; 2474 bool old_first_len, old_typespec_chararray_ctor; 2475 tree old_first_len_val; 2476 gfc_loopinfo *loop, *outer_loop; 2477 gfc_ss_info *ss_info; 2478 gfc_expr *expr; 2479 gfc_ss *s; 2480 tree neg_len; 2481 char *msg; 2482 2483 /* Save the old values for nested checking. */ 2484 old_first_len = first_len; 2485 old_first_len_val = first_len_val; 2486 old_typespec_chararray_ctor = typespec_chararray_ctor; 2487 2488 loop = ss->loop; 2489 outer_loop = outermost_loop (loop); 2490 ss_info = ss->info; 2491 expr = ss_info->expr; 2492 2493 /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no 2494 typespec was given for the array constructor. */ 2495 typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER 2496 && expr->ts.u.cl 2497 && expr->ts.u.cl->length_from_typespec); 2498 2499 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 2500 && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) 2501 { 2502 first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); 2503 first_len = true; 2504 } 2505 2506 gcc_assert (ss->dimen == ss->loop->dimen); 2507 2508 c = expr->value.constructor; 2509 if (expr->ts.type == BT_CHARACTER) 2510 { 2511 bool const_string; 2512 bool force_new_cl = false; 2513 2514 /* get_array_ctor_strlen walks the elements of the constructor, if a 2515 typespec was given, we already know the string length and want the one 2516 specified there. */ 2517 if (typespec_chararray_ctor && expr->ts.u.cl->length 2518 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) 2519 { 2520 gfc_se length_se; 2521 2522 const_string = false; 2523 gfc_init_se (&length_se, NULL); 2524 gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, 2525 gfc_charlen_type_node); 2526 ss_info->string_length = length_se.expr; 2527 2528 /* Check if the character length is negative. If it is, then 2529 set LEN = 0. */ 2530 neg_len = fold_build2_loc (input_location, LT_EXPR, 2531 logical_type_node, ss_info->string_length, 2532 build_zero_cst (TREE_TYPE 2533 (ss_info->string_length))); 2534 /* Print a warning if bounds checking is enabled. */ 2535 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 2536 { 2537 msg = xasprintf ("Negative character length treated as LEN = 0"); 2538 gfc_trans_runtime_check (false, true, neg_len, &length_se.pre, 2539 where, msg); 2540 free (msg); 2541 } 2542 2543 ss_info->string_length 2544 = fold_build3_loc (input_location, COND_EXPR, 2545 gfc_charlen_type_node, neg_len, 2546 build_zero_cst 2547 (TREE_TYPE (ss_info->string_length)), 2548 ss_info->string_length); 2549 ss_info->string_length = gfc_evaluate_now (ss_info->string_length, 2550 &length_se.pre); 2551 gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); 2552 gfc_add_block_to_block (&outer_loop->post, &length_se.post); 2553 } 2554 else 2555 { 2556 const_string = get_array_ctor_strlen (&outer_loop->pre, c, 2557 &ss_info->string_length); 2558 force_new_cl = true; 2559 } 2560 2561 /* Complex character array constructors should have been taken care of 2562 and not end up here. */ 2563 gcc_assert (ss_info->string_length); 2564 2565 store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl); 2566 2567 type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); 2568 if (const_string) 2569 type = build_pointer_type (type); 2570 } 2571 else 2572 type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS 2573 ? &CLASS_DATA (expr)->ts : &expr->ts); 2574 2575 /* See if the constructor determines the loop bounds. */ 2576 dynamic = false; 2577 2578 loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); 2579 2580 if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) 2581 { 2582 /* We have a multidimensional parameter. */ 2583 for (s = ss; s; s = s->parent) 2584 { 2585 int n; 2586 for (n = 0; n < s->loop->dimen; n++) 2587 { 2588 s->loop->from[n] = gfc_index_zero_node; 2589 s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], 2590 gfc_index_integer_kind); 2591 s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, 2592 gfc_array_index_type, 2593 s->loop->to[n], 2594 gfc_index_one_node); 2595 } 2596 } 2597 } 2598 2599 if (*loop_ubound0 == NULL_TREE) 2600 { 2601 mpz_t size; 2602 2603 /* We should have a 1-dimensional, zero-based loop. */ 2604 gcc_assert (loop->parent == NULL && loop->nested == NULL); 2605 gcc_assert (loop->dimen == 1); 2606 gcc_assert (integer_zerop (loop->from[0])); 2607 2608 /* Split the constructor size into a static part and a dynamic part. 2609 Allocate the static size up-front and record whether the dynamic 2610 size might be nonzero. */ 2611 mpz_init (size); 2612 dynamic = gfc_get_array_constructor_size (&size, c); 2613 mpz_sub_ui (size, size, 1); 2614 loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); 2615 mpz_clear (size); 2616 } 2617 2618 /* Special case constant array constructors. */ 2619 if (!dynamic) 2620 { 2621 unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); 2622 if (nelem > 0) 2623 { 2624 tree size = constant_array_constructor_loop_size (loop); 2625 if (size && compare_tree_int (size, nelem) == 0) 2626 { 2627 trans_constant_array_constructor (ss, type); 2628 goto finish; 2629 } 2630 } 2631 } 2632 2633 gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, 2634 NULL_TREE, dynamic, true, false, where); 2635 2636 desc = ss_info->data.array.descriptor; 2637 offset = gfc_index_zero_node; 2638 offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); 2639 TREE_NO_WARNING (offsetvar) = 1; 2640 TREE_USED (offsetvar) = 0; 2641 gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, 2642 &offset, &offsetvar, dynamic); 2643 2644 /* If the array grows dynamically, the upper bound of the loop variable 2645 is determined by the array's final upper bound. */ 2646 if (dynamic) 2647 { 2648 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2649 gfc_array_index_type, 2650 offsetvar, gfc_index_one_node); 2651 tmp = gfc_evaluate_now (tmp, &outer_loop->pre); 2652 gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); 2653 if (*loop_ubound0 && VAR_P (*loop_ubound0)) 2654 gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); 2655 else 2656 *loop_ubound0 = tmp; 2657 } 2658 2659 if (TREE_USED (offsetvar)) 2660 pushdecl (offsetvar); 2661 else 2662 gcc_assert (INTEGER_CST_P (offset)); 2663 2664 #if 0 2665 /* Disable bound checking for now because it's probably broken. */ 2666 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 2667 { 2668 gcc_unreachable (); 2669 } 2670 #endif 2671 2672 finish: 2673 /* Restore old values of globals. */ 2674 first_len = old_first_len; 2675 first_len_val = old_first_len_val; 2676 typespec_chararray_ctor = old_typespec_chararray_ctor; 2677 } 2678 2679 2680 /* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is 2681 called after evaluating all of INFO's vector dimensions. Go through 2682 each such vector dimension and see if we can now fill in any missing 2683 loop bounds. */ 2684 2685 static void 2686 set_vector_loop_bounds (gfc_ss * ss) 2687 { 2688 gfc_loopinfo *loop, *outer_loop; 2689 gfc_array_info *info; 2690 gfc_se se; 2691 tree tmp; 2692 tree desc; 2693 tree zero; 2694 int n; 2695 int dim; 2696 2697 outer_loop = outermost_loop (ss->loop); 2698 2699 info = &ss->info->data.array; 2700 2701 for (; ss; ss = ss->parent) 2702 { 2703 loop = ss->loop; 2704 2705 for (n = 0; n < loop->dimen; n++) 2706 { 2707 dim = ss->dim[n]; 2708 if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR 2709 || loop->to[n] != NULL) 2710 continue; 2711 2712 /* Loop variable N indexes vector dimension DIM, and we don't 2713 yet know the upper bound of loop variable N. Set it to the 2714 difference between the vector's upper and lower bounds. */ 2715 gcc_assert (loop->from[n] == gfc_index_zero_node); 2716 gcc_assert (info->subscript[dim] 2717 && info->subscript[dim]->info->type == GFC_SS_VECTOR); 2718 2719 gfc_init_se (&se, NULL); 2720 desc = info->subscript[dim]->info->data.array.descriptor; 2721 zero = gfc_rank_cst[0]; 2722 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2723 gfc_array_index_type, 2724 gfc_conv_descriptor_ubound_get (desc, zero), 2725 gfc_conv_descriptor_lbound_get (desc, zero)); 2726 tmp = gfc_evaluate_now (tmp, &outer_loop->pre); 2727 loop->to[n] = tmp; 2728 } 2729 } 2730 } 2731 2732 2733 /* Tells whether a scalar argument to an elemental procedure is saved out 2734 of a scalarization loop as a value or as a reference. */ 2735 2736 bool 2737 gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) 2738 { 2739 if (ss_info->type != GFC_SS_REFERENCE) 2740 return false; 2741 2742 if (ss_info->data.scalar.needs_temporary) 2743 return false; 2744 2745 /* If the actual argument can be absent (in other words, it can 2746 be a NULL reference), don't try to evaluate it; pass instead 2747 the reference directly. */ 2748 if (ss_info->can_be_null_ref) 2749 return true; 2750 2751 /* If the expression is of polymorphic type, it's actual size is not known, 2752 so we avoid copying it anywhere. */ 2753 if (ss_info->data.scalar.dummy_arg 2754 && ss_info->data.scalar.dummy_arg->ts.type == BT_CLASS 2755 && ss_info->expr->ts.type == BT_CLASS) 2756 return true; 2757 2758 /* If the expression is a data reference of aggregate type, 2759 and the data reference is not used on the left hand side, 2760 avoid a copy by saving a reference to the content. */ 2761 if (!ss_info->data.scalar.needs_temporary 2762 && (ss_info->expr->ts.type == BT_DERIVED 2763 || ss_info->expr->ts.type == BT_CLASS) 2764 && gfc_expr_is_variable (ss_info->expr)) 2765 return true; 2766 2767 /* Otherwise the expression is evaluated to a temporary variable before the 2768 scalarization loop. */ 2769 return false; 2770 } 2771 2772 2773 /* Add the pre and post chains for all the scalar expressions in a SS chain 2774 to loop. This is called after the loop parameters have been calculated, 2775 but before the actual scalarizing loops. */ 2776 2777 static void 2778 gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, 2779 locus * where) 2780 { 2781 gfc_loopinfo *nested_loop, *outer_loop; 2782 gfc_se se; 2783 gfc_ss_info *ss_info; 2784 gfc_array_info *info; 2785 gfc_expr *expr; 2786 int n; 2787 2788 /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, 2789 arguments could get evaluated multiple times. */ 2790 if (ss->is_alloc_lhs) 2791 return; 2792 2793 outer_loop = outermost_loop (loop); 2794 2795 /* TODO: This can generate bad code if there are ordering dependencies, 2796 e.g., a callee allocated function and an unknown size constructor. */ 2797 gcc_assert (ss != NULL); 2798 2799 for (; ss != gfc_ss_terminator; ss = ss->loop_chain) 2800 { 2801 gcc_assert (ss); 2802 2803 /* Cross loop arrays are handled from within the most nested loop. */ 2804 if (ss->nested_ss != NULL) 2805 continue; 2806 2807 ss_info = ss->info; 2808 expr = ss_info->expr; 2809 info = &ss_info->data.array; 2810 2811 switch (ss_info->type) 2812 { 2813 case GFC_SS_SCALAR: 2814 /* Scalar expression. Evaluate this now. This includes elemental 2815 dimension indices, but not array section bounds. */ 2816 gfc_init_se (&se, NULL); 2817 gfc_conv_expr (&se, expr); 2818 gfc_add_block_to_block (&outer_loop->pre, &se.pre); 2819 2820 if (expr->ts.type != BT_CHARACTER 2821 && !gfc_is_alloc_class_scalar_function (expr)) 2822 { 2823 /* Move the evaluation of scalar expressions outside the 2824 scalarization loop, except for WHERE assignments. */ 2825 if (subscript) 2826 se.expr = convert(gfc_array_index_type, se.expr); 2827 if (!ss_info->where) 2828 se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); 2829 gfc_add_block_to_block (&outer_loop->pre, &se.post); 2830 } 2831 else 2832 gfc_add_block_to_block (&outer_loop->post, &se.post); 2833 2834 ss_info->data.scalar.value = se.expr; 2835 ss_info->string_length = se.string_length; 2836 break; 2837 2838 case GFC_SS_REFERENCE: 2839 /* Scalar argument to elemental procedure. */ 2840 gfc_init_se (&se, NULL); 2841 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) 2842 gfc_conv_expr_reference (&se, expr); 2843 else 2844 { 2845 /* Evaluate the argument outside the loop and pass 2846 a reference to the value. */ 2847 gfc_conv_expr (&se, expr); 2848 } 2849 2850 /* Ensure that a pointer to the string is stored. */ 2851 if (expr->ts.type == BT_CHARACTER) 2852 gfc_conv_string_parameter (&se); 2853 2854 gfc_add_block_to_block (&outer_loop->pre, &se.pre); 2855 gfc_add_block_to_block (&outer_loop->post, &se.post); 2856 if (gfc_is_class_scalar_expr (expr)) 2857 /* This is necessary because the dynamic type will always be 2858 large than the declared type. In consequence, assigning 2859 the value to a temporary could segfault. 2860 OOP-TODO: see if this is generally correct or is the value 2861 has to be written to an allocated temporary, whose address 2862 is passed via ss_info. */ 2863 ss_info->data.scalar.value = se.expr; 2864 else 2865 ss_info->data.scalar.value = gfc_evaluate_now (se.expr, 2866 &outer_loop->pre); 2867 2868 ss_info->string_length = se.string_length; 2869 break; 2870 2871 case GFC_SS_SECTION: 2872 /* Add the expressions for scalar and vector subscripts. */ 2873 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 2874 if (info->subscript[n]) 2875 gfc_add_loop_ss_code (loop, info->subscript[n], true, where); 2876 2877 set_vector_loop_bounds (ss); 2878 break; 2879 2880 case GFC_SS_VECTOR: 2881 /* Get the vector's descriptor and store it in SS. */ 2882 gfc_init_se (&se, NULL); 2883 gfc_conv_expr_descriptor (&se, expr); 2884 gfc_add_block_to_block (&outer_loop->pre, &se.pre); 2885 gfc_add_block_to_block (&outer_loop->post, &se.post); 2886 info->descriptor = se.expr; 2887 break; 2888 2889 case GFC_SS_INTRINSIC: 2890 gfc_add_intrinsic_ss_code (loop, ss); 2891 break; 2892 2893 case GFC_SS_FUNCTION: 2894 /* Array function return value. We call the function and save its 2895 result in a temporary for use inside the loop. */ 2896 gfc_init_se (&se, NULL); 2897 se.loop = loop; 2898 se.ss = ss; 2899 if (gfc_is_class_array_function (expr)) 2900 expr->must_finalize = 1; 2901 gfc_conv_expr (&se, expr); 2902 gfc_add_block_to_block (&outer_loop->pre, &se.pre); 2903 gfc_add_block_to_block (&outer_loop->post, &se.post); 2904 ss_info->string_length = se.string_length; 2905 break; 2906 2907 case GFC_SS_CONSTRUCTOR: 2908 if (expr->ts.type == BT_CHARACTER 2909 && ss_info->string_length == NULL 2910 && expr->ts.u.cl 2911 && expr->ts.u.cl->length 2912 && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2913 { 2914 gfc_init_se (&se, NULL); 2915 gfc_conv_expr_type (&se, expr->ts.u.cl->length, 2916 gfc_charlen_type_node); 2917 ss_info->string_length = se.expr; 2918 gfc_add_block_to_block (&outer_loop->pre, &se.pre); 2919 gfc_add_block_to_block (&outer_loop->post, &se.post); 2920 } 2921 trans_array_constructor (ss, where); 2922 break; 2923 2924 case GFC_SS_TEMP: 2925 case GFC_SS_COMPONENT: 2926 /* Do nothing. These are handled elsewhere. */ 2927 break; 2928 2929 default: 2930 gcc_unreachable (); 2931 } 2932 } 2933 2934 if (!subscript) 2935 for (nested_loop = loop->nested; nested_loop; 2936 nested_loop = nested_loop->next) 2937 gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); 2938 } 2939 2940 2941 /* Translate expressions for the descriptor and data pointer of a SS. */ 2942 /*GCC ARRAYS*/ 2943 2944 static void 2945 gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) 2946 { 2947 gfc_se se; 2948 gfc_ss_info *ss_info; 2949 gfc_array_info *info; 2950 tree tmp; 2951 2952 ss_info = ss->info; 2953 info = &ss_info->data.array; 2954 2955 /* Get the descriptor for the array to be scalarized. */ 2956 gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); 2957 gfc_init_se (&se, NULL); 2958 se.descriptor_only = 1; 2959 gfc_conv_expr_lhs (&se, ss_info->expr); 2960 gfc_add_block_to_block (block, &se.pre); 2961 info->descriptor = se.expr; 2962 ss_info->string_length = se.string_length; 2963 2964 if (base) 2965 { 2966 if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred 2967 && ss_info->expr->ts.u.cl->length == NULL) 2968 { 2969 /* Emit a DECL_EXPR for the variable sized array type in 2970 GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type 2971 sizes works correctly. */ 2972 tree arraytype = TREE_TYPE ( 2973 GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); 2974 if (! TYPE_NAME (arraytype)) 2975 TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, 2976 NULL_TREE, arraytype); 2977 gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, 2978 TYPE_NAME (arraytype))); 2979 } 2980 /* Also the data pointer. */ 2981 tmp = gfc_conv_array_data (se.expr); 2982 /* If this is a variable or address of a variable we use it directly. 2983 Otherwise we must evaluate it now to avoid breaking dependency 2984 analysis by pulling the expressions for elemental array indices 2985 inside the loop. */ 2986 if (!(DECL_P (tmp) 2987 || (TREE_CODE (tmp) == ADDR_EXPR 2988 && DECL_P (TREE_OPERAND (tmp, 0))))) 2989 tmp = gfc_evaluate_now (tmp, block); 2990 info->data = tmp; 2991 2992 tmp = gfc_conv_array_offset (se.expr); 2993 info->offset = gfc_evaluate_now (tmp, block); 2994 2995 /* Make absolutely sure that the saved_offset is indeed saved 2996 so that the variable is still accessible after the loops 2997 are translated. */ 2998 info->saved_offset = info->offset; 2999 } 3000 } 3001 3002 3003 /* Initialize a gfc_loopinfo structure. */ 3004 3005 void 3006 gfc_init_loopinfo (gfc_loopinfo * loop) 3007 { 3008 int n; 3009 3010 memset (loop, 0, sizeof (gfc_loopinfo)); 3011 gfc_init_block (&loop->pre); 3012 gfc_init_block (&loop->post); 3013 3014 /* Initially scalarize in order and default to no loop reversal. */ 3015 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 3016 { 3017 loop->order[n] = n; 3018 loop->reverse[n] = GFC_INHIBIT_REVERSE; 3019 } 3020 3021 loop->ss = gfc_ss_terminator; 3022 } 3023 3024 3025 /* Copies the loop variable info to a gfc_se structure. Does not copy the SS 3026 chain. */ 3027 3028 void 3029 gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) 3030 { 3031 se->loop = loop; 3032 } 3033 3034 3035 /* Return an expression for the data pointer of an array. */ 3036 3037 tree 3038 gfc_conv_array_data (tree descriptor) 3039 { 3040 tree type; 3041 3042 type = TREE_TYPE (descriptor); 3043 if (GFC_ARRAY_TYPE_P (type)) 3044 { 3045 if (TREE_CODE (type) == POINTER_TYPE) 3046 return descriptor; 3047 else 3048 { 3049 /* Descriptorless arrays. */ 3050 return gfc_build_addr_expr (NULL_TREE, descriptor); 3051 } 3052 } 3053 else 3054 return gfc_conv_descriptor_data_get (descriptor); 3055 } 3056 3057 3058 /* Return an expression for the base offset of an array. */ 3059 3060 tree 3061 gfc_conv_array_offset (tree descriptor) 3062 { 3063 tree type; 3064 3065 type = TREE_TYPE (descriptor); 3066 if (GFC_ARRAY_TYPE_P (type)) 3067 return GFC_TYPE_ARRAY_OFFSET (type); 3068 else 3069 return gfc_conv_descriptor_offset_get (descriptor); 3070 } 3071 3072 3073 /* Get an expression for the array stride. */ 3074 3075 tree 3076 gfc_conv_array_stride (tree descriptor, int dim) 3077 { 3078 tree tmp; 3079 tree type; 3080 3081 type = TREE_TYPE (descriptor); 3082 3083 /* For descriptorless arrays use the array size. */ 3084 tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); 3085 if (tmp != NULL_TREE) 3086 return tmp; 3087 3088 tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); 3089 return tmp; 3090 } 3091 3092 3093 /* Like gfc_conv_array_stride, but for the lower bound. */ 3094 3095 tree 3096 gfc_conv_array_lbound (tree descriptor, int dim) 3097 { 3098 tree tmp; 3099 tree type; 3100 3101 type = TREE_TYPE (descriptor); 3102 3103 tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); 3104 if (tmp != NULL_TREE) 3105 return tmp; 3106 3107 tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); 3108 return tmp; 3109 } 3110 3111 3112 /* Like gfc_conv_array_stride, but for the upper bound. */ 3113 3114 tree 3115 gfc_conv_array_ubound (tree descriptor, int dim) 3116 { 3117 tree tmp; 3118 tree type; 3119 3120 type = TREE_TYPE (descriptor); 3121 3122 tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); 3123 if (tmp != NULL_TREE) 3124 return tmp; 3125 3126 /* This should only ever happen when passing an assumed shape array 3127 as an actual parameter. The value will never be used. */ 3128 if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) 3129 return gfc_index_zero_node; 3130 3131 tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); 3132 return tmp; 3133 } 3134 3135 3136 /* Generate code to perform an array index bound check. */ 3137 3138 static tree 3139 trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, 3140 locus * where, bool check_upper) 3141 { 3142 tree fault; 3143 tree tmp_lo, tmp_up; 3144 tree descriptor; 3145 char *msg; 3146 const char * name = NULL; 3147 3148 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) 3149 return index; 3150 3151 descriptor = ss->info->data.array.descriptor; 3152 3153 index = gfc_evaluate_now (index, &se->pre); 3154 3155 /* We find a name for the error message. */ 3156 name = ss->info->expr->symtree->n.sym->name; 3157 gcc_assert (name != NULL); 3158 3159 if (VAR_P (descriptor)) 3160 name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); 3161 3162 /* If upper bound is present, include both bounds in the error message. */ 3163 if (check_upper) 3164 { 3165 tmp_lo = gfc_conv_array_lbound (descriptor, n); 3166 tmp_up = gfc_conv_array_ubound (descriptor, n); 3167 3168 if (name) 3169 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 3170 "outside of expected range (%%ld:%%ld)", n+1, name); 3171 else 3172 msg = xasprintf ("Index '%%ld' of dimension %d " 3173 "outside of expected range (%%ld:%%ld)", n+1); 3174 3175 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 3176 index, tmp_lo); 3177 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, 3178 fold_convert (long_integer_type_node, index), 3179 fold_convert (long_integer_type_node, tmp_lo), 3180 fold_convert (long_integer_type_node, tmp_up)); 3181 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, 3182 index, tmp_up); 3183 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, 3184 fold_convert (long_integer_type_node, index), 3185 fold_convert (long_integer_type_node, tmp_lo), 3186 fold_convert (long_integer_type_node, tmp_up)); 3187 free (msg); 3188 } 3189 else 3190 { 3191 tmp_lo = gfc_conv_array_lbound (descriptor, n); 3192 3193 if (name) 3194 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 3195 "below lower bound of %%ld", n+1, name); 3196 else 3197 msg = xasprintf ("Index '%%ld' of dimension %d " 3198 "below lower bound of %%ld", n+1); 3199 3200 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 3201 index, tmp_lo); 3202 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, 3203 fold_convert (long_integer_type_node, index), 3204 fold_convert (long_integer_type_node, tmp_lo)); 3205 free (msg); 3206 } 3207 3208 return index; 3209 } 3210 3211 3212 /* Return the offset for an index. Performs bound checking for elemental 3213 dimensions. Single element references are processed separately. 3214 DIM is the array dimension, I is the loop dimension. */ 3215 3216 static tree 3217 conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, 3218 gfc_array_ref * ar, tree stride) 3219 { 3220 gfc_array_info *info; 3221 tree index; 3222 tree desc; 3223 tree data; 3224 3225 info = &ss->info->data.array; 3226 3227 /* Get the index into the array for this dimension. */ 3228 if (ar) 3229 { 3230 gcc_assert (ar->type != AR_ELEMENT); 3231 switch (ar->dimen_type[dim]) 3232 { 3233 case DIMEN_THIS_IMAGE: 3234 gcc_unreachable (); 3235 break; 3236 case DIMEN_ELEMENT: 3237 /* Elemental dimension. */ 3238 gcc_assert (info->subscript[dim] 3239 && info->subscript[dim]->info->type == GFC_SS_SCALAR); 3240 /* We've already translated this value outside the loop. */ 3241 index = info->subscript[dim]->info->data.scalar.value; 3242 3243 index = trans_array_bound_check (se, ss, index, dim, &ar->where, 3244 ar->as->type != AS_ASSUMED_SIZE 3245 || dim < ar->dimen - 1); 3246 break; 3247 3248 case DIMEN_VECTOR: 3249 gcc_assert (info && se->loop); 3250 gcc_assert (info->subscript[dim] 3251 && info->subscript[dim]->info->type == GFC_SS_VECTOR); 3252 desc = info->subscript[dim]->info->data.array.descriptor; 3253 3254 /* Get a zero-based index into the vector. */ 3255 index = fold_build2_loc (input_location, MINUS_EXPR, 3256 gfc_array_index_type, 3257 se->loop->loopvar[i], se->loop->from[i]); 3258 3259 /* Multiply the index by the stride. */ 3260 index = fold_build2_loc (input_location, MULT_EXPR, 3261 gfc_array_index_type, 3262 index, gfc_conv_array_stride (desc, 0)); 3263 3264 /* Read the vector to get an index into info->descriptor. */ 3265 data = build_fold_indirect_ref_loc (input_location, 3266 gfc_conv_array_data (desc)); 3267 index = gfc_build_array_ref (data, index, NULL); 3268 index = gfc_evaluate_now (index, &se->pre); 3269 index = fold_convert (gfc_array_index_type, index); 3270 3271 /* Do any bounds checking on the final info->descriptor index. */ 3272 index = trans_array_bound_check (se, ss, index, dim, &ar->where, 3273 ar->as->type != AS_ASSUMED_SIZE 3274 || dim < ar->dimen - 1); 3275 break; 3276 3277 case DIMEN_RANGE: 3278 /* Scalarized dimension. */ 3279 gcc_assert (info && se->loop); 3280 3281 /* Multiply the loop variable by the stride and delta. */ 3282 index = se->loop->loopvar[i]; 3283 if (!integer_onep (info->stride[dim])) 3284 index = fold_build2_loc (input_location, MULT_EXPR, 3285 gfc_array_index_type, index, 3286 info->stride[dim]); 3287 if (!integer_zerop (info->delta[dim])) 3288 index = fold_build2_loc (input_location, PLUS_EXPR, 3289 gfc_array_index_type, index, 3290 info->delta[dim]); 3291 break; 3292 3293 default: 3294 gcc_unreachable (); 3295 } 3296 } 3297 else 3298 { 3299 /* Temporary array or derived type component. */ 3300 gcc_assert (se->loop); 3301 index = se->loop->loopvar[se->loop->order[i]]; 3302 3303 /* Pointer functions can have stride[0] different from unity. 3304 Use the stride returned by the function call and stored in 3305 the descriptor for the temporary. */ 3306 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION 3307 && se->ss->info->expr 3308 && se->ss->info->expr->symtree 3309 && se->ss->info->expr->symtree->n.sym->result 3310 && se->ss->info->expr->symtree->n.sym->result->attr.pointer) 3311 stride = gfc_conv_descriptor_stride_get (info->descriptor, 3312 gfc_rank_cst[dim]); 3313 3314 if (info->delta[dim] && !integer_zerop (info->delta[dim])) 3315 index = fold_build2_loc (input_location, PLUS_EXPR, 3316 gfc_array_index_type, index, info->delta[dim]); 3317 } 3318 3319 /* Multiply by the stride. */ 3320 if (stride != NULL && !integer_onep (stride)) 3321 index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 3322 index, stride); 3323 3324 return index; 3325 } 3326 3327 3328 /* Build a scalarized array reference using the vptr 'size'. */ 3329 3330 static bool 3331 build_class_array_ref (gfc_se *se, tree base, tree index) 3332 { 3333 tree type; 3334 tree size; 3335 tree offset; 3336 tree decl = NULL_TREE; 3337 tree tmp; 3338 gfc_expr *expr = se->ss->info->expr; 3339 gfc_ref *ref; 3340 gfc_ref *class_ref = NULL; 3341 gfc_typespec *ts; 3342 3343 if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr) 3344 && GFC_DECL_SAVED_DESCRIPTOR (se->expr) 3345 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr)))) 3346 decl = se->expr; 3347 else 3348 { 3349 if (expr == NULL 3350 || (expr->ts.type != BT_CLASS 3351 && !gfc_is_class_array_function (expr) 3352 && !gfc_is_class_array_ref (expr, NULL))) 3353 return false; 3354 3355 if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) 3356 ts = &expr->symtree->n.sym->ts; 3357 else 3358 ts = NULL; 3359 3360 for (ref = expr->ref; ref; ref = ref->next) 3361 { 3362 if (ref->type == REF_COMPONENT 3363 && ref->u.c.component->ts.type == BT_CLASS 3364 && ref->next && ref->next->type == REF_COMPONENT 3365 && strcmp (ref->next->u.c.component->name, "_data") == 0 3366 && ref->next->next 3367 && ref->next->next->type == REF_ARRAY 3368 && ref->next->next->u.ar.type != AR_ELEMENT) 3369 { 3370 ts = &ref->u.c.component->ts; 3371 class_ref = ref; 3372 break; 3373 } 3374 } 3375 3376 if (ts == NULL) 3377 return false; 3378 } 3379 3380 if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function 3381 && expr->symtree->n.sym == expr->symtree->n.sym->result 3382 && expr->symtree->n.sym->backend_decl == current_function_decl) 3383 { 3384 decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); 3385 } 3386 else if (expr && gfc_is_class_array_function (expr)) 3387 { 3388 size = NULL_TREE; 3389 decl = NULL_TREE; 3390 for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0)) 3391 { 3392 tree type; 3393 type = TREE_TYPE (tmp); 3394 while (type) 3395 { 3396 if (GFC_CLASS_TYPE_P (type)) 3397 decl = tmp; 3398 if (type != TYPE_CANONICAL (type)) 3399 type = TYPE_CANONICAL (type); 3400 else 3401 type = NULL_TREE; 3402 } 3403 if (VAR_P (tmp)) 3404 break; 3405 } 3406 3407 if (decl == NULL_TREE) 3408 return false; 3409 3410 se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); 3411 } 3412 else if (class_ref == NULL) 3413 { 3414 if (decl == NULL_TREE) 3415 decl = expr->symtree->n.sym->backend_decl; 3416 /* For class arrays the tree containing the class is stored in 3417 GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. 3418 For all others it's sym's backend_decl directly. */ 3419 if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) 3420 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 3421 } 3422 else 3423 { 3424 /* Remove everything after the last class reference, convert the 3425 expression and then recover its tailend once more. */ 3426 gfc_se tmpse; 3427 ref = class_ref->next; 3428 class_ref->next = NULL; 3429 gfc_init_se (&tmpse, NULL); 3430 gfc_conv_expr (&tmpse, expr); 3431 gfc_add_block_to_block (&se->pre, &tmpse.pre); 3432 decl = tmpse.expr; 3433 class_ref->next = ref; 3434 } 3435 3436 if (POINTER_TYPE_P (TREE_TYPE (decl))) 3437 decl = build_fold_indirect_ref_loc (input_location, decl); 3438 3439 if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) 3440 return false; 3441 3442 size = gfc_class_vtab_size_get (decl); 3443 3444 /* For unlimited polymorphic entities then _len component needs to be 3445 multiplied with the size. If no _len component is present, then 3446 gfc_class_len_or_zero_get () return a zero_node. */ 3447 tmp = gfc_class_len_or_zero_get (decl); 3448 if (!integer_zerop (tmp)) 3449 size = fold_build2 (MULT_EXPR, TREE_TYPE (index), 3450 fold_convert (TREE_TYPE (index), size), 3451 fold_build2 (MAX_EXPR, TREE_TYPE (index), 3452 fold_convert (TREE_TYPE (index), tmp), 3453 fold_convert (TREE_TYPE (index), 3454 integer_one_node))); 3455 else 3456 size = fold_convert (TREE_TYPE (index), size); 3457 3458 /* Build the address of the element. */ 3459 type = TREE_TYPE (TREE_TYPE (base)); 3460 offset = fold_build2_loc (input_location, MULT_EXPR, 3461 gfc_array_index_type, 3462 index, size); 3463 tmp = gfc_build_addr_expr (pvoid_type_node, base); 3464 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); 3465 tmp = fold_convert (build_pointer_type (type), tmp); 3466 3467 /* Return the element in the se expression. */ 3468 se->expr = build_fold_indirect_ref_loc (input_location, tmp); 3469 return true; 3470 } 3471 3472 3473 /* Build a scalarized reference to an array. */ 3474 3475 static void 3476 gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) 3477 { 3478 gfc_array_info *info; 3479 tree decl = NULL_TREE; 3480 tree index; 3481 tree base; 3482 gfc_ss *ss; 3483 gfc_expr *expr; 3484 int n; 3485 3486 ss = se->ss; 3487 expr = ss->info->expr; 3488 info = &ss->info->data.array; 3489 if (ar) 3490 n = se->loop->order[0]; 3491 else 3492 n = 0; 3493 3494 index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); 3495 /* Add the offset for this dimension to the stored offset for all other 3496 dimensions. */ 3497 if (info->offset && !integer_zerop (info->offset)) 3498 index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 3499 index, info->offset); 3500 3501 base = build_fold_indirect_ref_loc (input_location, info->data); 3502 3503 /* Use the vptr 'size' field to access the element of a class array. */ 3504 if (build_class_array_ref (se, base, index)) 3505 return; 3506 3507 if (get_CFI_desc (NULL, expr, &decl, ar)) 3508 decl = build_fold_indirect_ref_loc (input_location, decl); 3509 3510 /* A pointer array component can be detected from its field decl. Fix 3511 the descriptor, mark the resulting variable decl and pass it to 3512 gfc_build_array_ref. */ 3513 if (is_pointer_array (info->descriptor) 3514 || (expr && expr->ts.deferred && info->descriptor 3515 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) 3516 { 3517 if (TREE_CODE (info->descriptor) == COMPONENT_REF) 3518 decl = info->descriptor; 3519 else if (TREE_CODE (info->descriptor) == INDIRECT_REF) 3520 decl = TREE_OPERAND (info->descriptor, 0); 3521 3522 if (decl == NULL_TREE) 3523 decl = info->descriptor; 3524 } 3525 3526 se->expr = gfc_build_array_ref (base, index, decl); 3527 } 3528 3529 3530 /* Translate access of temporary array. */ 3531 3532 void 3533 gfc_conv_tmp_array_ref (gfc_se * se) 3534 { 3535 se->string_length = se->ss->info->string_length; 3536 gfc_conv_scalarized_array_ref (se, NULL); 3537 gfc_advance_se_ss_chain (se); 3538 } 3539 3540 /* Add T to the offset pair *OFFSET, *CST_OFFSET. */ 3541 3542 static void 3543 add_to_offset (tree *cst_offset, tree *offset, tree t) 3544 { 3545 if (TREE_CODE (t) == INTEGER_CST) 3546 *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); 3547 else 3548 { 3549 if (!integer_zerop (*offset)) 3550 *offset = fold_build2_loc (input_location, PLUS_EXPR, 3551 gfc_array_index_type, *offset, t); 3552 else 3553 *offset = t; 3554 } 3555 } 3556 3557 3558 static tree 3559 build_array_ref (tree desc, tree offset, tree decl, tree vptr) 3560 { 3561 tree tmp; 3562 tree type; 3563 tree cdesc; 3564 3565 /* For class arrays the class declaration is stored in the saved 3566 descriptor. */ 3567 if (INDIRECT_REF_P (desc) 3568 && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) 3569 && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) 3570 cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( 3571 TREE_OPERAND (desc, 0))); 3572 else 3573 cdesc = desc; 3574 3575 /* Class container types do not always have the GFC_CLASS_TYPE_P 3576 but the canonical type does. */ 3577 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) 3578 && TREE_CODE (cdesc) == COMPONENT_REF) 3579 { 3580 type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); 3581 if (TYPE_CANONICAL (type) 3582 && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) 3583 vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); 3584 } 3585 3586 tmp = gfc_conv_array_data (desc); 3587 tmp = build_fold_indirect_ref_loc (input_location, tmp); 3588 tmp = gfc_build_array_ref (tmp, offset, decl, vptr); 3589 return tmp; 3590 } 3591 3592 3593 /* Build an array reference. se->expr already holds the array descriptor. 3594 This should be either a variable, indirect variable reference or component 3595 reference. For arrays which do not have a descriptor, se->expr will be 3596 the data pointer. 3597 a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ 3598 3599 void 3600 gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, 3601 locus * where) 3602 { 3603 int n; 3604 tree offset, cst_offset; 3605 tree tmp; 3606 tree stride; 3607 tree decl = NULL_TREE; 3608 gfc_se indexse; 3609 gfc_se tmpse; 3610 gfc_symbol * sym = expr->symtree->n.sym; 3611 char *var_name = NULL; 3612 3613 if (ar->dimen == 0) 3614 { 3615 gcc_assert (ar->codimen); 3616 3617 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) 3618 se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); 3619 else 3620 { 3621 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) 3622 && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) 3623 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 3624 3625 /* Use the actual tree type and not the wrapped coarray. */ 3626 if (!se->want_pointer) 3627 se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), 3628 se->expr); 3629 } 3630 3631 return; 3632 } 3633 3634 /* Handle scalarized references separately. */ 3635 if (ar->type != AR_ELEMENT) 3636 { 3637 gfc_conv_scalarized_array_ref (se, ar); 3638 gfc_advance_se_ss_chain (se); 3639 return; 3640 } 3641 3642 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 3643 { 3644 size_t len; 3645 gfc_ref *ref; 3646 3647 len = strlen (sym->name) + 1; 3648 for (ref = expr->ref; ref; ref = ref->next) 3649 { 3650 if (ref->type == REF_ARRAY && &ref->u.ar == ar) 3651 break; 3652 if (ref->type == REF_COMPONENT) 3653 len += 2 + strlen (ref->u.c.component->name); 3654 } 3655 3656 var_name = XALLOCAVEC (char, len); 3657 strcpy (var_name, sym->name); 3658 3659 for (ref = expr->ref; ref; ref = ref->next) 3660 { 3661 if (ref->type == REF_ARRAY && &ref->u.ar == ar) 3662 break; 3663 if (ref->type == REF_COMPONENT) 3664 { 3665 strcat (var_name, "%%"); 3666 strcat (var_name, ref->u.c.component->name); 3667 } 3668 } 3669 } 3670 3671 cst_offset = offset = gfc_index_zero_node; 3672 add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr)); 3673 3674 /* Calculate the offsets from all the dimensions. Make sure to associate 3675 the final offset so that we form a chain of loop invariant summands. */ 3676 for (n = ar->dimen - 1; n >= 0; n--) 3677 { 3678 /* Calculate the index for this dimension. */ 3679 gfc_init_se (&indexse, se); 3680 gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); 3681 gfc_add_block_to_block (&se->pre, &indexse.pre); 3682 3683 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check) 3684 { 3685 /* Check array bounds. */ 3686 tree cond; 3687 char *msg; 3688 3689 /* Evaluate the indexse.expr only once. */ 3690 indexse.expr = save_expr (indexse.expr); 3691 3692 /* Lower bound. */ 3693 tmp = gfc_conv_array_lbound (se->expr, n); 3694 if (sym->attr.temporary) 3695 { 3696 gfc_init_se (&tmpse, se); 3697 gfc_conv_expr_type (&tmpse, ar->as->lower[n], 3698 gfc_array_index_type); 3699 gfc_add_block_to_block (&se->pre, &tmpse.pre); 3700 tmp = tmpse.expr; 3701 } 3702 3703 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 3704 indexse.expr, tmp); 3705 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 3706 "below lower bound of %%ld", n+1, var_name); 3707 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, 3708 fold_convert (long_integer_type_node, 3709 indexse.expr), 3710 fold_convert (long_integer_type_node, tmp)); 3711 free (msg); 3712 3713 /* Upper bound, but not for the last dimension of assumed-size 3714 arrays. */ 3715 if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) 3716 { 3717 tmp = gfc_conv_array_ubound (se->expr, n); 3718 if (sym->attr.temporary) 3719 { 3720 gfc_init_se (&tmpse, se); 3721 gfc_conv_expr_type (&tmpse, ar->as->upper[n], 3722 gfc_array_index_type); 3723 gfc_add_block_to_block (&se->pre, &tmpse.pre); 3724 tmp = tmpse.expr; 3725 } 3726 3727 cond = fold_build2_loc (input_location, GT_EXPR, 3728 logical_type_node, indexse.expr, tmp); 3729 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 3730 "above upper bound of %%ld", n+1, var_name); 3731 gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, 3732 fold_convert (long_integer_type_node, 3733 indexse.expr), 3734 fold_convert (long_integer_type_node, tmp)); 3735 free (msg); 3736 } 3737 } 3738 3739 /* Multiply the index by the stride. */ 3740 stride = gfc_conv_array_stride (se->expr, n); 3741 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 3742 indexse.expr, stride); 3743 3744 /* And add it to the total. */ 3745 add_to_offset (&cst_offset, &offset, tmp); 3746 } 3747 3748 if (!integer_zerop (cst_offset)) 3749 offset = fold_build2_loc (input_location, PLUS_EXPR, 3750 gfc_array_index_type, offset, cst_offset); 3751 3752 /* A pointer array component can be detected from its field decl. Fix 3753 the descriptor, mark the resulting variable decl and pass it to 3754 build_array_ref. */ 3755 if (get_CFI_desc (sym, expr, &decl, ar)) 3756 decl = build_fold_indirect_ref_loc (input_location, decl); 3757 if (!expr->ts.deferred && !sym->attr.codimension 3758 && is_pointer_array (se->expr)) 3759 { 3760 if (TREE_CODE (se->expr) == COMPONENT_REF) 3761 decl = se->expr; 3762 else if (TREE_CODE (se->expr) == INDIRECT_REF) 3763 decl = TREE_OPERAND (se->expr, 0); 3764 else 3765 decl = se->expr; 3766 } 3767 else if (expr->ts.deferred 3768 || (sym->ts.type == BT_CHARACTER 3769 && sym->attr.select_type_temporary)) 3770 { 3771 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) 3772 { 3773 decl = se->expr; 3774 if (TREE_CODE (decl) == INDIRECT_REF) 3775 decl = TREE_OPERAND (decl, 0); 3776 } 3777 else 3778 decl = sym->backend_decl; 3779 } 3780 else if (sym->ts.type == BT_CLASS) 3781 decl = NULL_TREE; 3782 3783 se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); 3784 } 3785 3786 3787 /* Add the offset corresponding to array's ARRAY_DIM dimension and loop's 3788 LOOP_DIM dimension (if any) to array's offset. */ 3789 3790 static void 3791 add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, 3792 gfc_array_ref *ar, int array_dim, int loop_dim) 3793 { 3794 gfc_se se; 3795 gfc_array_info *info; 3796 tree stride, index; 3797 3798 info = &ss->info->data.array; 3799 3800 gfc_init_se (&se, NULL); 3801 se.loop = loop; 3802 se.expr = info->descriptor; 3803 stride = gfc_conv_array_stride (info->descriptor, array_dim); 3804 index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride); 3805 gfc_add_block_to_block (pblock, &se.pre); 3806 3807 info->offset = fold_build2_loc (input_location, PLUS_EXPR, 3808 gfc_array_index_type, 3809 info->offset, index); 3810 info->offset = gfc_evaluate_now (info->offset, pblock); 3811 } 3812 3813 3814 /* Generate the code to be executed immediately before entering a 3815 scalarization loop. */ 3816 3817 static void 3818 gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, 3819 stmtblock_t * pblock) 3820 { 3821 tree stride; 3822 gfc_ss_info *ss_info; 3823 gfc_array_info *info; 3824 gfc_ss_type ss_type; 3825 gfc_ss *ss, *pss; 3826 gfc_loopinfo *ploop; 3827 gfc_array_ref *ar; 3828 int i; 3829 3830 /* This code will be executed before entering the scalarization loop 3831 for this dimension. */ 3832 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 3833 { 3834 ss_info = ss->info; 3835 3836 if ((ss_info->useflags & flag) == 0) 3837 continue; 3838 3839 ss_type = ss_info->type; 3840 if (ss_type != GFC_SS_SECTION 3841 && ss_type != GFC_SS_FUNCTION 3842 && ss_type != GFC_SS_CONSTRUCTOR 3843 && ss_type != GFC_SS_COMPONENT) 3844 continue; 3845 3846 info = &ss_info->data.array; 3847 3848 gcc_assert (dim < ss->dimen); 3849 gcc_assert (ss->dimen == loop->dimen); 3850 3851 if (info->ref) 3852 ar = &info->ref->u.ar; 3853 else 3854 ar = NULL; 3855 3856 if (dim == loop->dimen - 1 && loop->parent != NULL) 3857 { 3858 /* If we are in the outermost dimension of this loop, the previous 3859 dimension shall be in the parent loop. */ 3860 gcc_assert (ss->parent != NULL); 3861 3862 pss = ss->parent; 3863 ploop = loop->parent; 3864 3865 /* ss and ss->parent are about the same array. */ 3866 gcc_assert (ss_info == pss->info); 3867 } 3868 else 3869 { 3870 ploop = loop; 3871 pss = ss; 3872 } 3873 3874 if (dim == loop->dimen - 1) 3875 i = 0; 3876 else 3877 i = dim + 1; 3878 3879 /* For the time being, there is no loop reordering. */ 3880 gcc_assert (i == ploop->order[i]); 3881 i = ploop->order[i]; 3882 3883 if (dim == loop->dimen - 1 && loop->parent == NULL) 3884 { 3885 stride = gfc_conv_array_stride (info->descriptor, 3886 innermost_ss (ss)->dim[i]); 3887 3888 /* Calculate the stride of the innermost loop. Hopefully this will 3889 allow the backend optimizers to do their stuff more effectively. 3890 */ 3891 info->stride0 = gfc_evaluate_now (stride, pblock); 3892 3893 /* For the outermost loop calculate the offset due to any 3894 elemental dimensions. It will have been initialized with the 3895 base offset of the array. */ 3896 if (info->ref) 3897 { 3898 for (i = 0; i < ar->dimen; i++) 3899 { 3900 if (ar->dimen_type[i] != DIMEN_ELEMENT) 3901 continue; 3902 3903 add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1); 3904 } 3905 } 3906 } 3907 else 3908 /* Add the offset for the previous loop dimension. */ 3909 add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); 3910 3911 /* Remember this offset for the second loop. */ 3912 if (dim == loop->temp_dim - 1 && loop->parent == NULL) 3913 info->saved_offset = info->offset; 3914 } 3915 } 3916 3917 3918 /* Start a scalarized expression. Creates a scope and declares loop 3919 variables. */ 3920 3921 void 3922 gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) 3923 { 3924 int dim; 3925 int n; 3926 int flags; 3927 3928 gcc_assert (!loop->array_parameter); 3929 3930 for (dim = loop->dimen - 1; dim >= 0; dim--) 3931 { 3932 n = loop->order[dim]; 3933 3934 gfc_start_block (&loop->code[n]); 3935 3936 /* Create the loop variable. */ 3937 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); 3938 3939 if (dim < loop->temp_dim) 3940 flags = 3; 3941 else 3942 flags = 1; 3943 /* Calculate values that will be constant within this loop. */ 3944 gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); 3945 } 3946 gfc_start_block (pbody); 3947 } 3948 3949 3950 /* Generates the actual loop code for a scalarization loop. */ 3951 3952 void 3953 gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, 3954 stmtblock_t * pbody) 3955 { 3956 stmtblock_t block; 3957 tree cond; 3958 tree tmp; 3959 tree loopbody; 3960 tree exit_label; 3961 tree stmt; 3962 tree init; 3963 tree incr; 3964 3965 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS 3966 | OMPWS_SCALARIZER_BODY)) 3967 == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) 3968 && n == loop->dimen - 1) 3969 { 3970 /* We create an OMP_FOR construct for the outermost scalarized loop. */ 3971 init = make_tree_vec (1); 3972 cond = make_tree_vec (1); 3973 incr = make_tree_vec (1); 3974 3975 /* Cycle statement is implemented with a goto. Exit statement must not 3976 be present for this loop. */ 3977 exit_label = gfc_build_label_decl (NULL_TREE); 3978 TREE_USED (exit_label) = 1; 3979 3980 /* Label for cycle statements (if needed). */ 3981 tmp = build1_v (LABEL_EXPR, exit_label); 3982 gfc_add_expr_to_block (pbody, tmp); 3983 3984 stmt = make_node (OMP_FOR); 3985 3986 TREE_TYPE (stmt) = void_type_node; 3987 OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody); 3988 3989 OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location, 3990 OMP_CLAUSE_SCHEDULE); 3991 OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt)) 3992 = OMP_CLAUSE_SCHEDULE_STATIC; 3993 if (ompws_flags & OMPWS_NOWAIT) 3994 OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt)) 3995 = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT); 3996 3997 /* Initialize the loopvar. */ 3998 TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n], 3999 loop->from[n]); 4000 OMP_FOR_INIT (stmt) = init; 4001 /* The exit condition. */ 4002 TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, 4003 logical_type_node, 4004 loop->loopvar[n], loop->to[n]); 4005 SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); 4006 OMP_FOR_COND (stmt) = cond; 4007 /* Increment the loopvar. */ 4008 tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4009 loop->loopvar[n], gfc_index_one_node); 4010 TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, 4011 void_type_node, loop->loopvar[n], tmp); 4012 OMP_FOR_INCR (stmt) = incr; 4013 4014 ompws_flags &= ~OMPWS_CURR_SINGLEUNIT; 4015 gfc_add_expr_to_block (&loop->code[n], stmt); 4016 } 4017 else 4018 { 4019 bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) 4020 && (loop->temp_ss == NULL); 4021 4022 loopbody = gfc_finish_block (pbody); 4023 4024 if (reverse_loop) 4025 std::swap (loop->from[n], loop->to[n]); 4026 4027 /* Initialize the loopvar. */ 4028 if (loop->loopvar[n] != loop->from[n]) 4029 gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); 4030 4031 exit_label = gfc_build_label_decl (NULL_TREE); 4032 4033 /* Generate the loop body. */ 4034 gfc_init_block (&block); 4035 4036 /* The exit condition. */ 4037 cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, 4038 logical_type_node, loop->loopvar[n], loop->to[n]); 4039 tmp = build1_v (GOTO_EXPR, exit_label); 4040 TREE_USED (exit_label) = 1; 4041 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); 4042 gfc_add_expr_to_block (&block, tmp); 4043 4044 /* The main body. */ 4045 gfc_add_expr_to_block (&block, loopbody); 4046 4047 /* Increment the loopvar. */ 4048 tmp = fold_build2_loc (input_location, 4049 reverse_loop ? MINUS_EXPR : PLUS_EXPR, 4050 gfc_array_index_type, loop->loopvar[n], 4051 gfc_index_one_node); 4052 4053 gfc_add_modify (&block, loop->loopvar[n], tmp); 4054 4055 /* Build the loop. */ 4056 tmp = gfc_finish_block (&block); 4057 tmp = build1_v (LOOP_EXPR, tmp); 4058 gfc_add_expr_to_block (&loop->code[n], tmp); 4059 4060 /* Add the exit label. */ 4061 tmp = build1_v (LABEL_EXPR, exit_label); 4062 gfc_add_expr_to_block (&loop->code[n], tmp); 4063 } 4064 4065 } 4066 4067 4068 /* Finishes and generates the loops for a scalarized expression. */ 4069 4070 void 4071 gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) 4072 { 4073 int dim; 4074 int n; 4075 gfc_ss *ss; 4076 stmtblock_t *pblock; 4077 tree tmp; 4078 4079 pblock = body; 4080 /* Generate the loops. */ 4081 for (dim = 0; dim < loop->dimen; dim++) 4082 { 4083 n = loop->order[dim]; 4084 gfc_trans_scalarized_loop_end (loop, n, pblock); 4085 loop->loopvar[n] = NULL_TREE; 4086 pblock = &loop->code[n]; 4087 } 4088 4089 tmp = gfc_finish_block (pblock); 4090 gfc_add_expr_to_block (&loop->pre, tmp); 4091 4092 /* Clear all the used flags. */ 4093 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4094 if (ss->parent == NULL) 4095 ss->info->useflags = 0; 4096 } 4097 4098 4099 /* Finish the main body of a scalarized expression, and start the secondary 4100 copying body. */ 4101 4102 void 4103 gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) 4104 { 4105 int dim; 4106 int n; 4107 stmtblock_t *pblock; 4108 gfc_ss *ss; 4109 4110 pblock = body; 4111 /* We finish as many loops as are used by the temporary. */ 4112 for (dim = 0; dim < loop->temp_dim - 1; dim++) 4113 { 4114 n = loop->order[dim]; 4115 gfc_trans_scalarized_loop_end (loop, n, pblock); 4116 loop->loopvar[n] = NULL_TREE; 4117 pblock = &loop->code[n]; 4118 } 4119 4120 /* We don't want to finish the outermost loop entirely. */ 4121 n = loop->order[loop->temp_dim - 1]; 4122 gfc_trans_scalarized_loop_end (loop, n, pblock); 4123 4124 /* Restore the initial offsets. */ 4125 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4126 { 4127 gfc_ss_type ss_type; 4128 gfc_ss_info *ss_info; 4129 4130 ss_info = ss->info; 4131 4132 if ((ss_info->useflags & 2) == 0) 4133 continue; 4134 4135 ss_type = ss_info->type; 4136 if (ss_type != GFC_SS_SECTION 4137 && ss_type != GFC_SS_FUNCTION 4138 && ss_type != GFC_SS_CONSTRUCTOR 4139 && ss_type != GFC_SS_COMPONENT) 4140 continue; 4141 4142 ss_info->data.array.offset = ss_info->data.array.saved_offset; 4143 } 4144 4145 /* Restart all the inner loops we just finished. */ 4146 for (dim = loop->temp_dim - 2; dim >= 0; dim--) 4147 { 4148 n = loop->order[dim]; 4149 4150 gfc_start_block (&loop->code[n]); 4151 4152 loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); 4153 4154 gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); 4155 } 4156 4157 /* Start a block for the secondary copying code. */ 4158 gfc_start_block (body); 4159 } 4160 4161 4162 /* Precalculate (either lower or upper) bound of an array section. 4163 BLOCK: Block in which the (pre)calculation code will go. 4164 BOUNDS[DIM]: Where the bound value will be stored once evaluated. 4165 VALUES[DIM]: Specified bound (NULL <=> unspecified). 4166 DESC: Array descriptor from which the bound will be picked if unspecified 4167 (either lower or upper bound according to LBOUND). */ 4168 4169 static void 4170 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, 4171 tree desc, int dim, bool lbound, bool deferred) 4172 { 4173 gfc_se se; 4174 gfc_expr * input_val = values[dim]; 4175 tree *output = &bounds[dim]; 4176 4177 4178 if (input_val) 4179 { 4180 /* Specified section bound. */ 4181 gfc_init_se (&se, NULL); 4182 gfc_conv_expr_type (&se, input_val, gfc_array_index_type); 4183 gfc_add_block_to_block (block, &se.pre); 4184 *output = se.expr; 4185 } 4186 else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 4187 { 4188 /* The gfc_conv_array_lbound () routine returns a constant zero for 4189 deferred length arrays, which in the scalarizer wreaks havoc, when 4190 copying to a (newly allocated) one-based array. 4191 Keep returning the actual result in sync for both bounds. */ 4192 *output = lbound ? gfc_conv_descriptor_lbound_get (desc, 4193 gfc_rank_cst[dim]): 4194 gfc_conv_descriptor_ubound_get (desc, 4195 gfc_rank_cst[dim]); 4196 } 4197 else 4198 { 4199 /* No specific bound specified so use the bound of the array. */ 4200 *output = lbound ? gfc_conv_array_lbound (desc, dim) : 4201 gfc_conv_array_ubound (desc, dim); 4202 } 4203 *output = gfc_evaluate_now (*output, block); 4204 } 4205 4206 4207 /* Calculate the lower bound of an array section. */ 4208 4209 static void 4210 gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) 4211 { 4212 gfc_expr *stride = NULL; 4213 tree desc; 4214 gfc_se se; 4215 gfc_array_info *info; 4216 gfc_array_ref *ar; 4217 4218 gcc_assert (ss->info->type == GFC_SS_SECTION); 4219 4220 info = &ss->info->data.array; 4221 ar = &info->ref->u.ar; 4222 4223 if (ar->dimen_type[dim] == DIMEN_VECTOR) 4224 { 4225 /* We use a zero-based index to access the vector. */ 4226 info->start[dim] = gfc_index_zero_node; 4227 info->end[dim] = NULL; 4228 info->stride[dim] = gfc_index_one_node; 4229 return; 4230 } 4231 4232 gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE 4233 || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); 4234 desc = info->descriptor; 4235 stride = ar->stride[dim]; 4236 4237 4238 /* Calculate the start of the range. For vector subscripts this will 4239 be the range of the vector. */ 4240 evaluate_bound (block, info->start, ar->start, desc, dim, true, 4241 ar->as->type == AS_DEFERRED); 4242 4243 /* Similarly calculate the end. Although this is not used in the 4244 scalarizer, it is needed when checking bounds and where the end 4245 is an expression with side-effects. */ 4246 evaluate_bound (block, info->end, ar->end, desc, dim, false, 4247 ar->as->type == AS_DEFERRED); 4248 4249 4250 /* Calculate the stride. */ 4251 if (stride == NULL) 4252 info->stride[dim] = gfc_index_one_node; 4253 else 4254 { 4255 gfc_init_se (&se, NULL); 4256 gfc_conv_expr_type (&se, stride, gfc_array_index_type); 4257 gfc_add_block_to_block (block, &se.pre); 4258 info->stride[dim] = gfc_evaluate_now (se.expr, block); 4259 } 4260 } 4261 4262 4263 /* Calculates the range start and stride for a SS chain. Also gets the 4264 descriptor and data pointer. The range of vector subscripts is the size 4265 of the vector. Array bounds are also checked. */ 4266 4267 void 4268 gfc_conv_ss_startstride (gfc_loopinfo * loop) 4269 { 4270 int n; 4271 tree tmp; 4272 gfc_ss *ss; 4273 tree desc; 4274 4275 gfc_loopinfo * const outer_loop = outermost_loop (loop); 4276 4277 loop->dimen = 0; 4278 /* Determine the rank of the loop. */ 4279 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4280 { 4281 switch (ss->info->type) 4282 { 4283 case GFC_SS_SECTION: 4284 case GFC_SS_CONSTRUCTOR: 4285 case GFC_SS_FUNCTION: 4286 case GFC_SS_COMPONENT: 4287 loop->dimen = ss->dimen; 4288 goto done; 4289 4290 /* As usual, lbound and ubound are exceptions!. */ 4291 case GFC_SS_INTRINSIC: 4292 switch (ss->info->expr->value.function.isym->id) 4293 { 4294 case GFC_ISYM_LBOUND: 4295 case GFC_ISYM_UBOUND: 4296 case GFC_ISYM_LCOBOUND: 4297 case GFC_ISYM_UCOBOUND: 4298 case GFC_ISYM_THIS_IMAGE: 4299 loop->dimen = ss->dimen; 4300 goto done; 4301 4302 default: 4303 break; 4304 } 4305 4306 default: 4307 break; 4308 } 4309 } 4310 4311 /* We should have determined the rank of the expression by now. If 4312 not, that's bad news. */ 4313 gcc_unreachable (); 4314 4315 done: 4316 /* Loop over all the SS in the chain. */ 4317 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4318 { 4319 gfc_ss_info *ss_info; 4320 gfc_array_info *info; 4321 gfc_expr *expr; 4322 4323 ss_info = ss->info; 4324 expr = ss_info->expr; 4325 info = &ss_info->data.array; 4326 4327 if (expr && expr->shape && !info->shape) 4328 info->shape = expr->shape; 4329 4330 switch (ss_info->type) 4331 { 4332 case GFC_SS_SECTION: 4333 /* Get the descriptor for the array. If it is a cross loops array, 4334 we got the descriptor already in the outermost loop. */ 4335 if (ss->parent == NULL) 4336 gfc_conv_ss_descriptor (&outer_loop->pre, ss, 4337 !loop->array_parameter); 4338 4339 for (n = 0; n < ss->dimen; n++) 4340 gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]); 4341 break; 4342 4343 case GFC_SS_INTRINSIC: 4344 switch (expr->value.function.isym->id) 4345 { 4346 /* Fall through to supply start and stride. */ 4347 case GFC_ISYM_LBOUND: 4348 case GFC_ISYM_UBOUND: 4349 { 4350 gfc_expr *arg; 4351 4352 /* This is the variant without DIM=... */ 4353 gcc_assert (expr->value.function.actual->next->expr == NULL); 4354 4355 arg = expr->value.function.actual->expr; 4356 if (arg->rank == -1) 4357 { 4358 gfc_se se; 4359 tree rank, tmp; 4360 4361 /* The rank (hence the return value's shape) is unknown, 4362 we have to retrieve it. */ 4363 gfc_init_se (&se, NULL); 4364 se.descriptor_only = 1; 4365 gfc_conv_expr (&se, arg); 4366 /* This is a bare variable, so there is no preliminary 4367 or cleanup code. */ 4368 gcc_assert (se.pre.head == NULL_TREE 4369 && se.post.head == NULL_TREE); 4370 rank = gfc_conv_descriptor_rank (se.expr); 4371 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4372 gfc_array_index_type, 4373 fold_convert (gfc_array_index_type, 4374 rank), 4375 gfc_index_one_node); 4376 info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre); 4377 info->start[0] = gfc_index_zero_node; 4378 info->stride[0] = gfc_index_one_node; 4379 continue; 4380 } 4381 /* Otherwise fall through GFC_SS_FUNCTION. */ 4382 gcc_fallthrough (); 4383 } 4384 case GFC_ISYM_LCOBOUND: 4385 case GFC_ISYM_UCOBOUND: 4386 case GFC_ISYM_THIS_IMAGE: 4387 break; 4388 4389 default: 4390 continue; 4391 } 4392 4393 /* FALLTHRU */ 4394 case GFC_SS_CONSTRUCTOR: 4395 case GFC_SS_FUNCTION: 4396 for (n = 0; n < ss->dimen; n++) 4397 { 4398 int dim = ss->dim[n]; 4399 4400 info->start[dim] = gfc_index_zero_node; 4401 info->end[dim] = gfc_index_zero_node; 4402 info->stride[dim] = gfc_index_one_node; 4403 } 4404 break; 4405 4406 default: 4407 break; 4408 } 4409 } 4410 4411 /* The rest is just runtime bounds checking. */ 4412 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 4413 { 4414 stmtblock_t block; 4415 tree lbound, ubound; 4416 tree end; 4417 tree size[GFC_MAX_DIMENSIONS]; 4418 tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; 4419 gfc_array_info *info; 4420 char *msg; 4421 int dim; 4422 4423 gfc_start_block (&block); 4424 4425 for (n = 0; n < loop->dimen; n++) 4426 size[n] = NULL_TREE; 4427 4428 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4429 { 4430 stmtblock_t inner; 4431 gfc_ss_info *ss_info; 4432 gfc_expr *expr; 4433 locus *expr_loc; 4434 const char *expr_name; 4435 4436 ss_info = ss->info; 4437 if (ss_info->type != GFC_SS_SECTION) 4438 continue; 4439 4440 /* Catch allocatable lhs in f2003. */ 4441 if (flag_realloc_lhs && ss->no_bounds_check) 4442 continue; 4443 4444 expr = ss_info->expr; 4445 expr_loc = &expr->where; 4446 expr_name = expr->symtree->name; 4447 4448 gfc_start_block (&inner); 4449 4450 /* TODO: range checking for mapped dimensions. */ 4451 info = &ss_info->data.array; 4452 4453 /* This code only checks ranges. Elemental and vector 4454 dimensions are checked later. */ 4455 for (n = 0; n < loop->dimen; n++) 4456 { 4457 bool check_upper; 4458 4459 dim = ss->dim[n]; 4460 if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) 4461 continue; 4462 4463 if (dim == info->ref->u.ar.dimen - 1 4464 && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) 4465 check_upper = false; 4466 else 4467 check_upper = true; 4468 4469 /* Zero stride is not allowed. */ 4470 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 4471 info->stride[dim], gfc_index_zero_node); 4472 msg = xasprintf ("Zero stride is not allowed, for dimension %d " 4473 "of array '%s'", dim + 1, expr_name); 4474 gfc_trans_runtime_check (true, false, tmp, &inner, 4475 expr_loc, msg); 4476 free (msg); 4477 4478 desc = info->descriptor; 4479 4480 /* This is the run-time equivalent of resolve.c's 4481 check_dimension(). The logical is more readable there 4482 than it is here, with all the trees. */ 4483 lbound = gfc_conv_array_lbound (desc, dim); 4484 end = info->end[dim]; 4485 if (check_upper) 4486 ubound = gfc_conv_array_ubound (desc, dim); 4487 else 4488 ubound = NULL; 4489 4490 /* non_zerosized is true when the selected range is not 4491 empty. */ 4492 stride_pos = fold_build2_loc (input_location, GT_EXPR, 4493 logical_type_node, info->stride[dim], 4494 gfc_index_zero_node); 4495 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, 4496 info->start[dim], end); 4497 stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4498 logical_type_node, stride_pos, tmp); 4499 4500 stride_neg = fold_build2_loc (input_location, LT_EXPR, 4501 logical_type_node, 4502 info->stride[dim], gfc_index_zero_node); 4503 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 4504 info->start[dim], end); 4505 stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4506 logical_type_node, 4507 stride_neg, tmp); 4508 non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, 4509 logical_type_node, 4510 stride_pos, stride_neg); 4511 4512 /* Check the start of the range against the lower and upper 4513 bounds of the array, if the range is not empty. 4514 If upper bound is present, include both bounds in the 4515 error message. */ 4516 if (check_upper) 4517 { 4518 tmp = fold_build2_loc (input_location, LT_EXPR, 4519 logical_type_node, 4520 info->start[dim], lbound); 4521 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4522 logical_type_node, 4523 non_zerosized, tmp); 4524 tmp2 = fold_build2_loc (input_location, GT_EXPR, 4525 logical_type_node, 4526 info->start[dim], ubound); 4527 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4528 logical_type_node, 4529 non_zerosized, tmp2); 4530 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 4531 "outside of expected range (%%ld:%%ld)", 4532 dim + 1, expr_name); 4533 gfc_trans_runtime_check (true, false, tmp, &inner, 4534 expr_loc, msg, 4535 fold_convert (long_integer_type_node, info->start[dim]), 4536 fold_convert (long_integer_type_node, lbound), 4537 fold_convert (long_integer_type_node, ubound)); 4538 gfc_trans_runtime_check (true, false, tmp2, &inner, 4539 expr_loc, msg, 4540 fold_convert (long_integer_type_node, info->start[dim]), 4541 fold_convert (long_integer_type_node, lbound), 4542 fold_convert (long_integer_type_node, ubound)); 4543 free (msg); 4544 } 4545 else 4546 { 4547 tmp = fold_build2_loc (input_location, LT_EXPR, 4548 logical_type_node, 4549 info->start[dim], lbound); 4550 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4551 logical_type_node, non_zerosized, tmp); 4552 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 4553 "below lower bound of %%ld", 4554 dim + 1, expr_name); 4555 gfc_trans_runtime_check (true, false, tmp, &inner, 4556 expr_loc, msg, 4557 fold_convert (long_integer_type_node, info->start[dim]), 4558 fold_convert (long_integer_type_node, lbound)); 4559 free (msg); 4560 } 4561 4562 /* Compute the last element of the range, which is not 4563 necessarily "end" (think 0:5:3, which doesn't contain 5) 4564 and check it against both lower and upper bounds. */ 4565 4566 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4567 gfc_array_index_type, end, 4568 info->start[dim]); 4569 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, 4570 gfc_array_index_type, tmp, 4571 info->stride[dim]); 4572 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4573 gfc_array_index_type, end, tmp); 4574 tmp2 = fold_build2_loc (input_location, LT_EXPR, 4575 logical_type_node, tmp, lbound); 4576 tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4577 logical_type_node, non_zerosized, tmp2); 4578 if (check_upper) 4579 { 4580 tmp3 = fold_build2_loc (input_location, GT_EXPR, 4581 logical_type_node, tmp, ubound); 4582 tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 4583 logical_type_node, non_zerosized, tmp3); 4584 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 4585 "outside of expected range (%%ld:%%ld)", 4586 dim + 1, expr_name); 4587 gfc_trans_runtime_check (true, false, tmp2, &inner, 4588 expr_loc, msg, 4589 fold_convert (long_integer_type_node, tmp), 4590 fold_convert (long_integer_type_node, ubound), 4591 fold_convert (long_integer_type_node, lbound)); 4592 gfc_trans_runtime_check (true, false, tmp3, &inner, 4593 expr_loc, msg, 4594 fold_convert (long_integer_type_node, tmp), 4595 fold_convert (long_integer_type_node, ubound), 4596 fold_convert (long_integer_type_node, lbound)); 4597 free (msg); 4598 } 4599 else 4600 { 4601 msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " 4602 "below lower bound of %%ld", 4603 dim + 1, expr_name); 4604 gfc_trans_runtime_check (true, false, tmp2, &inner, 4605 expr_loc, msg, 4606 fold_convert (long_integer_type_node, tmp), 4607 fold_convert (long_integer_type_node, lbound)); 4608 free (msg); 4609 } 4610 4611 /* Check the section sizes match. */ 4612 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4613 gfc_array_index_type, end, 4614 info->start[dim]); 4615 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, 4616 gfc_array_index_type, tmp, 4617 info->stride[dim]); 4618 tmp = fold_build2_loc (input_location, PLUS_EXPR, 4619 gfc_array_index_type, 4620 gfc_index_one_node, tmp); 4621 tmp = fold_build2_loc (input_location, MAX_EXPR, 4622 gfc_array_index_type, tmp, 4623 build_int_cst (gfc_array_index_type, 0)); 4624 /* We remember the size of the first section, and check all the 4625 others against this. */ 4626 if (size[n]) 4627 { 4628 tmp3 = fold_build2_loc (input_location, NE_EXPR, 4629 logical_type_node, tmp, size[n]); 4630 msg = xasprintf ("Array bound mismatch for dimension %d " 4631 "of array '%s' (%%ld/%%ld)", 4632 dim + 1, expr_name); 4633 4634 gfc_trans_runtime_check (true, false, tmp3, &inner, 4635 expr_loc, msg, 4636 fold_convert (long_integer_type_node, tmp), 4637 fold_convert (long_integer_type_node, size[n])); 4638 4639 free (msg); 4640 } 4641 else 4642 size[n] = gfc_evaluate_now (tmp, &inner); 4643 } 4644 4645 tmp = gfc_finish_block (&inner); 4646 4647 /* For optional arguments, only check bounds if the argument is 4648 present. */ 4649 if (expr->symtree->n.sym->attr.optional 4650 || expr->symtree->n.sym->attr.not_always_present) 4651 tmp = build3_v (COND_EXPR, 4652 gfc_conv_expr_present (expr->symtree->n.sym), 4653 tmp, build_empty_stmt (input_location)); 4654 4655 gfc_add_expr_to_block (&block, tmp); 4656 4657 } 4658 4659 tmp = gfc_finish_block (&block); 4660 gfc_add_expr_to_block (&outer_loop->pre, tmp); 4661 } 4662 4663 for (loop = loop->nested; loop; loop = loop->next) 4664 gfc_conv_ss_startstride (loop); 4665 } 4666 4667 /* Return true if both symbols could refer to the same data object. Does 4668 not take account of aliasing due to equivalence statements. */ 4669 4670 static int 4671 symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, 4672 bool lsym_target, bool rsym_pointer, bool rsym_target) 4673 { 4674 /* Aliasing isn't possible if the symbols have different base types. */ 4675 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) 4676 return 0; 4677 4678 /* Pointers can point to other pointers and target objects. */ 4679 4680 if ((lsym_pointer && (rsym_pointer || rsym_target)) 4681 || (rsym_pointer && (lsym_pointer || lsym_target))) 4682 return 1; 4683 4684 /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 4685 and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already 4686 checked above. */ 4687 if (lsym_target && rsym_target 4688 && ((lsym->attr.dummy && !lsym->attr.contiguous 4689 && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) 4690 || (rsym->attr.dummy && !rsym->attr.contiguous 4691 && (!rsym->attr.dimension 4692 || rsym->as->type == AS_ASSUMED_SHAPE)))) 4693 return 1; 4694 4695 return 0; 4696 } 4697 4698 4699 /* Return true if the two SS could be aliased, i.e. both point to the same data 4700 object. */ 4701 /* TODO: resolve aliases based on frontend expressions. */ 4702 4703 static int 4704 gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) 4705 { 4706 gfc_ref *lref; 4707 gfc_ref *rref; 4708 gfc_expr *lexpr, *rexpr; 4709 gfc_symbol *lsym; 4710 gfc_symbol *rsym; 4711 bool lsym_pointer, lsym_target, rsym_pointer, rsym_target; 4712 4713 lexpr = lss->info->expr; 4714 rexpr = rss->info->expr; 4715 4716 lsym = lexpr->symtree->n.sym; 4717 rsym = rexpr->symtree->n.sym; 4718 4719 lsym_pointer = lsym->attr.pointer; 4720 lsym_target = lsym->attr.target; 4721 rsym_pointer = rsym->attr.pointer; 4722 rsym_target = rsym->attr.target; 4723 4724 if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target, 4725 rsym_pointer, rsym_target)) 4726 return 1; 4727 4728 if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS 4729 && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS) 4730 return 0; 4731 4732 /* For derived types we must check all the component types. We can ignore 4733 array references as these will have the same base type as the previous 4734 component ref. */ 4735 for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) 4736 { 4737 if (lref->type != REF_COMPONENT) 4738 continue; 4739 4740 lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer; 4741 lsym_target = lsym_target || lref->u.c.sym->attr.target; 4742 4743 if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target, 4744 rsym_pointer, rsym_target)) 4745 return 1; 4746 4747 if ((lsym_pointer && (rsym_pointer || rsym_target)) 4748 || (rsym_pointer && (lsym_pointer || lsym_target))) 4749 { 4750 if (gfc_compare_types (&lref->u.c.component->ts, 4751 &rsym->ts)) 4752 return 1; 4753 } 4754 4755 for (rref = rexpr->ref; rref != rss->info->data.array.ref; 4756 rref = rref->next) 4757 { 4758 if (rref->type != REF_COMPONENT) 4759 continue; 4760 4761 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; 4762 rsym_target = lsym_target || rref->u.c.sym->attr.target; 4763 4764 if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym, 4765 lsym_pointer, lsym_target, 4766 rsym_pointer, rsym_target)) 4767 return 1; 4768 4769 if ((lsym_pointer && (rsym_pointer || rsym_target)) 4770 || (rsym_pointer && (lsym_pointer || lsym_target))) 4771 { 4772 if (gfc_compare_types (&lref->u.c.component->ts, 4773 &rref->u.c.sym->ts)) 4774 return 1; 4775 if (gfc_compare_types (&lref->u.c.sym->ts, 4776 &rref->u.c.component->ts)) 4777 return 1; 4778 if (gfc_compare_types (&lref->u.c.component->ts, 4779 &rref->u.c.component->ts)) 4780 return 1; 4781 } 4782 } 4783 } 4784 4785 lsym_pointer = lsym->attr.pointer; 4786 lsym_target = lsym->attr.target; 4787 lsym_pointer = lsym->attr.pointer; 4788 lsym_target = lsym->attr.target; 4789 4790 for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) 4791 { 4792 if (rref->type != REF_COMPONENT) 4793 break; 4794 4795 rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; 4796 rsym_target = lsym_target || rref->u.c.sym->attr.target; 4797 4798 if (symbols_could_alias (rref->u.c.sym, lsym, 4799 lsym_pointer, lsym_target, 4800 rsym_pointer, rsym_target)) 4801 return 1; 4802 4803 if ((lsym_pointer && (rsym_pointer || rsym_target)) 4804 || (rsym_pointer && (lsym_pointer || lsym_target))) 4805 { 4806 if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts)) 4807 return 1; 4808 } 4809 } 4810 4811 return 0; 4812 } 4813 4814 4815 /* Resolve array data dependencies. Creates a temporary if required. */ 4816 /* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to 4817 dependency.c. */ 4818 4819 void 4820 gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, 4821 gfc_ss * rss) 4822 { 4823 gfc_ss *ss; 4824 gfc_ref *lref; 4825 gfc_ref *rref; 4826 gfc_ss_info *ss_info; 4827 gfc_expr *dest_expr; 4828 gfc_expr *ss_expr; 4829 int nDepend = 0; 4830 int i, j; 4831 4832 loop->temp_ss = NULL; 4833 dest_expr = dest->info->expr; 4834 4835 for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) 4836 { 4837 ss_info = ss->info; 4838 ss_expr = ss_info->expr; 4839 4840 if (ss_info->array_outer_dependency) 4841 { 4842 nDepend = 1; 4843 break; 4844 } 4845 4846 if (ss_info->type != GFC_SS_SECTION) 4847 { 4848 if (flag_realloc_lhs 4849 && dest_expr != ss_expr 4850 && gfc_is_reallocatable_lhs (dest_expr) 4851 && ss_expr->rank) 4852 nDepend = gfc_check_dependency (dest_expr, ss_expr, true); 4853 4854 /* Check for cases like c(:)(1:2) = c(2)(2:3) */ 4855 if (!nDepend && dest_expr->rank > 0 4856 && dest_expr->ts.type == BT_CHARACTER 4857 && ss_expr->expr_type == EXPR_VARIABLE) 4858 4859 nDepend = gfc_check_dependency (dest_expr, ss_expr, false); 4860 4861 if (ss_info->type == GFC_SS_REFERENCE 4862 && gfc_check_dependency (dest_expr, ss_expr, false)) 4863 ss_info->data.scalar.needs_temporary = 1; 4864 4865 if (nDepend) 4866 break; 4867 else 4868 continue; 4869 } 4870 4871 if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym) 4872 { 4873 if (gfc_could_be_alias (dest, ss) 4874 || gfc_are_equivalenced_arrays (dest_expr, ss_expr)) 4875 { 4876 nDepend = 1; 4877 break; 4878 } 4879 } 4880 else 4881 { 4882 lref = dest_expr->ref; 4883 rref = ss_expr->ref; 4884 4885 nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); 4886 4887 if (nDepend == 1) 4888 break; 4889 4890 for (i = 0; i < dest->dimen; i++) 4891 for (j = 0; j < ss->dimen; j++) 4892 if (i != j 4893 && dest->dim[i] == ss->dim[j]) 4894 { 4895 /* If we don't access array elements in the same order, 4896 there is a dependency. */ 4897 nDepend = 1; 4898 goto temporary; 4899 } 4900 #if 0 4901 /* TODO : loop shifting. */ 4902 if (nDepend == 1) 4903 { 4904 /* Mark the dimensions for LOOP SHIFTING */ 4905 for (n = 0; n < loop->dimen; n++) 4906 { 4907 int dim = dest->data.info.dim[n]; 4908 4909 if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) 4910 depends[n] = 2; 4911 else if (! gfc_is_same_range (&lref->u.ar, 4912 &rref->u.ar, dim, 0)) 4913 depends[n] = 1; 4914 } 4915 4916 /* Put all the dimensions with dependencies in the 4917 innermost loops. */ 4918 dim = 0; 4919 for (n = 0; n < loop->dimen; n++) 4920 { 4921 gcc_assert (loop->order[n] == n); 4922 if (depends[n]) 4923 loop->order[dim++] = n; 4924 } 4925 for (n = 0; n < loop->dimen; n++) 4926 { 4927 if (! depends[n]) 4928 loop->order[dim++] = n; 4929 } 4930 4931 gcc_assert (dim == loop->dimen); 4932 break; 4933 } 4934 #endif 4935 } 4936 } 4937 4938 temporary: 4939 4940 if (nDepend == 1) 4941 { 4942 tree base_type = gfc_typenode_for_spec (&dest_expr->ts); 4943 if (GFC_ARRAY_TYPE_P (base_type) 4944 || GFC_DESCRIPTOR_TYPE_P (base_type)) 4945 base_type = gfc_get_element_type (base_type); 4946 loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length, 4947 loop->dimen); 4948 gfc_add_ss_to_loop (loop, loop->temp_ss); 4949 } 4950 else 4951 loop->temp_ss = NULL; 4952 } 4953 4954 4955 /* Browse through each array's information from the scalarizer and set the loop 4956 bounds according to the "best" one (per dimension), i.e. the one which 4957 provides the most information (constant bounds, shape, etc.). */ 4958 4959 static void 4960 set_loop_bounds (gfc_loopinfo *loop) 4961 { 4962 int n, dim, spec_dim; 4963 gfc_array_info *info; 4964 gfc_array_info *specinfo; 4965 gfc_ss *ss; 4966 tree tmp; 4967 gfc_ss **loopspec; 4968 bool dynamic[GFC_MAX_DIMENSIONS]; 4969 mpz_t *cshape; 4970 mpz_t i; 4971 bool nonoptional_arr; 4972 4973 gfc_loopinfo * const outer_loop = outermost_loop (loop); 4974 4975 loopspec = loop->specloop; 4976 4977 mpz_init (i); 4978 for (n = 0; n < loop->dimen; n++) 4979 { 4980 loopspec[n] = NULL; 4981 dynamic[n] = false; 4982 4983 /* If there are both optional and nonoptional array arguments, scalarize 4984 over the nonoptional; otherwise, it does not matter as then all 4985 (optional) arrays have to be present per F2008, 125.2.12p3(6). */ 4986 4987 nonoptional_arr = false; 4988 4989 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 4990 if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP 4991 && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) 4992 { 4993 nonoptional_arr = true; 4994 break; 4995 } 4996 4997 /* We use one SS term, and use that to determine the bounds of the 4998 loop for this dimension. We try to pick the simplest term. */ 4999 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 5000 { 5001 gfc_ss_type ss_type; 5002 5003 ss_type = ss->info->type; 5004 if (ss_type == GFC_SS_SCALAR 5005 || ss_type == GFC_SS_TEMP 5006 || ss_type == GFC_SS_REFERENCE 5007 || (ss->info->can_be_null_ref && nonoptional_arr)) 5008 continue; 5009 5010 info = &ss->info->data.array; 5011 dim = ss->dim[n]; 5012 5013 if (loopspec[n] != NULL) 5014 { 5015 specinfo = &loopspec[n]->info->data.array; 5016 spec_dim = loopspec[n]->dim[n]; 5017 } 5018 else 5019 { 5020 /* Silence uninitialized warnings. */ 5021 specinfo = NULL; 5022 spec_dim = 0; 5023 } 5024 5025 if (info->shape) 5026 { 5027 gcc_assert (info->shape[dim]); 5028 /* The frontend has worked out the size for us. */ 5029 if (!loopspec[n] 5030 || !specinfo->shape 5031 || !integer_zerop (specinfo->start[spec_dim])) 5032 /* Prefer zero-based descriptors if possible. */ 5033 loopspec[n] = ss; 5034 continue; 5035 } 5036 5037 if (ss_type == GFC_SS_CONSTRUCTOR) 5038 { 5039 gfc_constructor_base base; 5040 /* An unknown size constructor will always be rank one. 5041 Higher rank constructors will either have known shape, 5042 or still be wrapped in a call to reshape. */ 5043 gcc_assert (loop->dimen == 1); 5044 5045 /* Always prefer to use the constructor bounds if the size 5046 can be determined at compile time. Prefer not to otherwise, 5047 since the general case involves realloc, and it's better to 5048 avoid that overhead if possible. */ 5049 base = ss->info->expr->value.constructor; 5050 dynamic[n] = gfc_get_array_constructor_size (&i, base); 5051 if (!dynamic[n] || !loopspec[n]) 5052 loopspec[n] = ss; 5053 continue; 5054 } 5055 5056 /* Avoid using an allocatable lhs in an assignment, since 5057 there might be a reallocation coming. */ 5058 if (loopspec[n] && ss->is_alloc_lhs) 5059 continue; 5060 5061 if (!loopspec[n]) 5062 loopspec[n] = ss; 5063 /* Criteria for choosing a loop specifier (most important first): 5064 doesn't need realloc 5065 stride of one 5066 known stride 5067 known lower bound 5068 known upper bound 5069 */ 5070 else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) 5071 loopspec[n] = ss; 5072 else if (integer_onep (info->stride[dim]) 5073 && !integer_onep (specinfo->stride[spec_dim])) 5074 loopspec[n] = ss; 5075 else if (INTEGER_CST_P (info->stride[dim]) 5076 && !INTEGER_CST_P (specinfo->stride[spec_dim])) 5077 loopspec[n] = ss; 5078 else if (INTEGER_CST_P (info->start[dim]) 5079 && !INTEGER_CST_P (specinfo->start[spec_dim]) 5080 && integer_onep (info->stride[dim]) 5081 == integer_onep (specinfo->stride[spec_dim]) 5082 && INTEGER_CST_P (info->stride[dim]) 5083 == INTEGER_CST_P (specinfo->stride[spec_dim])) 5084 loopspec[n] = ss; 5085 /* We don't work out the upper bound. 5086 else if (INTEGER_CST_P (info->finish[n]) 5087 && ! INTEGER_CST_P (specinfo->finish[n])) 5088 loopspec[n] = ss; */ 5089 } 5090 5091 /* We should have found the scalarization loop specifier. If not, 5092 that's bad news. */ 5093 gcc_assert (loopspec[n]); 5094 5095 info = &loopspec[n]->info->data.array; 5096 dim = loopspec[n]->dim[n]; 5097 5098 /* Set the extents of this range. */ 5099 cshape = info->shape; 5100 if (cshape && INTEGER_CST_P (info->start[dim]) 5101 && INTEGER_CST_P (info->stride[dim])) 5102 { 5103 loop->from[n] = info->start[dim]; 5104 mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); 5105 mpz_sub_ui (i, i, 1); 5106 /* To = from + (size - 1) * stride. */ 5107 tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); 5108 if (!integer_onep (info->stride[dim])) 5109 tmp = fold_build2_loc (input_location, MULT_EXPR, 5110 gfc_array_index_type, tmp, 5111 info->stride[dim]); 5112 loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR, 5113 gfc_array_index_type, 5114 loop->from[n], tmp); 5115 } 5116 else 5117 { 5118 loop->from[n] = info->start[dim]; 5119 switch (loopspec[n]->info->type) 5120 { 5121 case GFC_SS_CONSTRUCTOR: 5122 /* The upper bound is calculated when we expand the 5123 constructor. */ 5124 gcc_assert (loop->to[n] == NULL_TREE); 5125 break; 5126 5127 case GFC_SS_SECTION: 5128 /* Use the end expression if it exists and is not constant, 5129 so that it is only evaluated once. */ 5130 loop->to[n] = info->end[dim]; 5131 break; 5132 5133 case GFC_SS_FUNCTION: 5134 /* The loop bound will be set when we generate the call. */ 5135 gcc_assert (loop->to[n] == NULL_TREE); 5136 break; 5137 5138 case GFC_SS_INTRINSIC: 5139 { 5140 gfc_expr *expr = loopspec[n]->info->expr; 5141 5142 /* The {l,u}bound of an assumed rank. */ 5143 gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND 5144 || expr->value.function.isym->id == GFC_ISYM_UBOUND) 5145 && expr->value.function.actual->next->expr == NULL 5146 && expr->value.function.actual->expr->rank == -1); 5147 5148 loop->to[n] = info->end[dim]; 5149 break; 5150 } 5151 5152 case GFC_SS_COMPONENT: 5153 { 5154 if (info->end[dim] != NULL_TREE) 5155 { 5156 loop->to[n] = info->end[dim]; 5157 break; 5158 } 5159 else 5160 gcc_unreachable (); 5161 } 5162 5163 default: 5164 gcc_unreachable (); 5165 } 5166 } 5167 5168 /* Transform everything so we have a simple incrementing variable. */ 5169 if (integer_onep (info->stride[dim])) 5170 info->delta[dim] = gfc_index_zero_node; 5171 else 5172 { 5173 /* Set the delta for this section. */ 5174 info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre); 5175 /* Number of iterations is (end - start + step) / step. 5176 with start = 0, this simplifies to 5177 last = end / step; 5178 for (i = 0; i<=last; i++){...}; */ 5179 tmp = fold_build2_loc (input_location, MINUS_EXPR, 5180 gfc_array_index_type, loop->to[n], 5181 loop->from[n]); 5182 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, 5183 gfc_array_index_type, tmp, info->stride[dim]); 5184 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, 5185 tmp, build_int_cst (gfc_array_index_type, -1)); 5186 loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre); 5187 /* Make the loop variable start at 0. */ 5188 loop->from[n] = gfc_index_zero_node; 5189 } 5190 } 5191 mpz_clear (i); 5192 5193 for (loop = loop->nested; loop; loop = loop->next) 5194 set_loop_bounds (loop); 5195 } 5196 5197 5198 /* Initialize the scalarization loop. Creates the loop variables. Determines 5199 the range of the loop variables. Creates a temporary if required. 5200 Also generates code for scalar expressions which have been 5201 moved outside the loop. */ 5202 5203 void 5204 gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) 5205 { 5206 gfc_ss *tmp_ss; 5207 tree tmp; 5208 5209 set_loop_bounds (loop); 5210 5211 /* Add all the scalar code that can be taken out of the loops. 5212 This may include calculating the loop bounds, so do it before 5213 allocating the temporary. */ 5214 gfc_add_loop_ss_code (loop, loop->ss, false, where); 5215 5216 tmp_ss = loop->temp_ss; 5217 /* If we want a temporary then create it. */ 5218 if (tmp_ss != NULL) 5219 { 5220 gfc_ss_info *tmp_ss_info; 5221 5222 tmp_ss_info = tmp_ss->info; 5223 gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); 5224 gcc_assert (loop->parent == NULL); 5225 5226 /* Make absolutely sure that this is a complete type. */ 5227 if (tmp_ss_info->string_length) 5228 tmp_ss_info->data.temp.type 5229 = gfc_get_character_type_len_for_eltype 5230 (TREE_TYPE (tmp_ss_info->data.temp.type), 5231 tmp_ss_info->string_length); 5232 5233 tmp = tmp_ss_info->data.temp.type; 5234 memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); 5235 tmp_ss_info->type = GFC_SS_SECTION; 5236 5237 gcc_assert (tmp_ss->dimen != 0); 5238 5239 gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, 5240 NULL_TREE, false, true, false, where); 5241 } 5242 5243 /* For array parameters we don't have loop variables, so don't calculate the 5244 translations. */ 5245 if (!loop->array_parameter) 5246 gfc_set_delta (loop); 5247 } 5248 5249 5250 /* Calculates how to transform from loop variables to array indices for each 5251 array: once loop bounds are chosen, sets the difference (DELTA field) between 5252 loop bounds and array reference bounds, for each array info. */ 5253 5254 void 5255 gfc_set_delta (gfc_loopinfo *loop) 5256 { 5257 gfc_ss *ss, **loopspec; 5258 gfc_array_info *info; 5259 tree tmp; 5260 int n, dim; 5261 5262 gfc_loopinfo * const outer_loop = outermost_loop (loop); 5263 5264 loopspec = loop->specloop; 5265 5266 /* Calculate the translation from loop variables to array indices. */ 5267 for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) 5268 { 5269 gfc_ss_type ss_type; 5270 5271 ss_type = ss->info->type; 5272 if (ss_type != GFC_SS_SECTION 5273 && ss_type != GFC_SS_COMPONENT 5274 && ss_type != GFC_SS_CONSTRUCTOR) 5275 continue; 5276 5277 info = &ss->info->data.array; 5278 5279 for (n = 0; n < ss->dimen; n++) 5280 { 5281 /* If we are specifying the range the delta is already set. */ 5282 if (loopspec[n] != ss) 5283 { 5284 dim = ss->dim[n]; 5285 5286 /* Calculate the offset relative to the loop variable. 5287 First multiply by the stride. */ 5288 tmp = loop->from[n]; 5289 if (!integer_onep (info->stride[dim])) 5290 tmp = fold_build2_loc (input_location, MULT_EXPR, 5291 gfc_array_index_type, 5292 tmp, info->stride[dim]); 5293 5294 /* Then subtract this from our starting value. */ 5295 tmp = fold_build2_loc (input_location, MINUS_EXPR, 5296 gfc_array_index_type, 5297 info->start[dim], tmp); 5298 5299 info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); 5300 } 5301 } 5302 } 5303 5304 for (loop = loop->nested; loop; loop = loop->next) 5305 gfc_set_delta (loop); 5306 } 5307 5308 5309 /* Calculate the size of a given array dimension from the bounds. This 5310 is simply (ubound - lbound + 1) if this expression is positive 5311 or 0 if it is negative (pick either one if it is zero). Optionally 5312 (if or_expr is present) OR the (expression != 0) condition to it. */ 5313 5314 tree 5315 gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) 5316 { 5317 tree res; 5318 tree cond; 5319 5320 /* Calculate (ubound - lbound + 1). */ 5321 res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 5322 ubound, lbound); 5323 res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, 5324 gfc_index_one_node); 5325 5326 /* Check whether the size for this dimension is negative. */ 5327 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res, 5328 gfc_index_zero_node); 5329 res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, 5330 gfc_index_zero_node, res); 5331 5332 /* Build OR expression. */ 5333 if (or_expr) 5334 *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, 5335 logical_type_node, *or_expr, cond); 5336 5337 return res; 5338 } 5339 5340 5341 /* For an array descriptor, get the total number of elements. This is just 5342 the product of the extents along from_dim to to_dim. */ 5343 5344 static tree 5345 gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) 5346 { 5347 tree res; 5348 int dim; 5349 5350 res = gfc_index_one_node; 5351 5352 for (dim = from_dim; dim < to_dim; ++dim) 5353 { 5354 tree lbound; 5355 tree ubound; 5356 tree extent; 5357 5358 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); 5359 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); 5360 5361 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); 5362 res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 5363 res, extent); 5364 } 5365 5366 return res; 5367 } 5368 5369 5370 /* Full size of an array. */ 5371 5372 tree 5373 gfc_conv_descriptor_size (tree desc, int rank) 5374 { 5375 return gfc_conv_descriptor_size_1 (desc, 0, rank); 5376 } 5377 5378 5379 /* Size of a coarray for all dimensions but the last. */ 5380 5381 tree 5382 gfc_conv_descriptor_cosize (tree desc, int rank, int corank) 5383 { 5384 return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1); 5385 } 5386 5387 5388 /* Fills in an array descriptor, and returns the size of the array. 5389 The size will be a simple_val, ie a variable or a constant. Also 5390 calculates the offset of the base. The pointer argument overflow, 5391 which should be of integer type, will increase in value if overflow 5392 occurs during the size calculation. Returns the size of the array. 5393 { 5394 stride = 1; 5395 offset = 0; 5396 for (n = 0; n < rank; n++) 5397 { 5398 a.lbound[n] = specified_lower_bound; 5399 offset = offset + a.lbond[n] * stride; 5400 size = 1 - lbound; 5401 a.ubound[n] = specified_upper_bound; 5402 a.stride[n] = stride; 5403 size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound 5404 overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); 5405 stride = stride * size; 5406 } 5407 for (n = rank; n < rank+corank; n++) 5408 (Set lcobound/ucobound as above.) 5409 element_size = sizeof (array element); 5410 if (!rank) 5411 return element_size 5412 stride = (size_t) stride; 5413 overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); 5414 stride = stride * element_size; 5415 return (stride); 5416 } */ 5417 /*GCC ARRAYS*/ 5418 5419 static tree 5420 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, 5421 gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, 5422 stmtblock_t * descriptor_block, tree * overflow, 5423 tree expr3_elem_size, tree *nelems, gfc_expr *expr3, 5424 tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, 5425 tree *element_size) 5426 { 5427 tree type; 5428 tree tmp; 5429 tree size; 5430 tree offset; 5431 tree stride; 5432 tree or_expr; 5433 tree thencase; 5434 tree elsecase; 5435 tree cond; 5436 tree var; 5437 stmtblock_t thenblock; 5438 stmtblock_t elseblock; 5439 gfc_expr *ubound; 5440 gfc_se se; 5441 int n; 5442 5443 type = TREE_TYPE (descriptor); 5444 5445 stride = gfc_index_one_node; 5446 offset = gfc_index_zero_node; 5447 5448 /* Set the dtype before the alloc, because registration of coarrays needs 5449 it initialized. */ 5450 if (expr->ts.type == BT_CHARACTER 5451 && expr->ts.deferred 5452 && VAR_P (expr->ts.u.cl->backend_decl)) 5453 { 5454 type = gfc_typenode_for_spec (&expr->ts); 5455 tmp = gfc_conv_descriptor_dtype (descriptor); 5456 gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); 5457 } 5458 else if (expr->ts.type == BT_CHARACTER 5459 && expr->ts.deferred 5460 && TREE_CODE (descriptor) == COMPONENT_REF) 5461 { 5462 /* Deferred character components have their string length tucked away 5463 in a hidden field of the derived type. Obtain that and use it to 5464 set the dtype. The charlen backend decl is zero because the field 5465 type is zero length. */ 5466 gfc_ref *ref; 5467 tmp = NULL_TREE; 5468 for (ref = expr->ref; ref; ref = ref->next) 5469 if (ref->type == REF_COMPONENT 5470 && gfc_deferred_strlen (ref->u.c.component, &tmp)) 5471 break; 5472 gcc_assert (tmp != NULL_TREE); 5473 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), 5474 TREE_OPERAND (descriptor, 0), tmp, NULL_TREE); 5475 tmp = fold_convert (gfc_charlen_type_node, tmp); 5476 type = gfc_get_character_type_len (expr->ts.kind, tmp); 5477 tmp = gfc_conv_descriptor_dtype (descriptor); 5478 gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); 5479 } 5480 else 5481 { 5482 tmp = gfc_conv_descriptor_dtype (descriptor); 5483 gfc_add_modify (pblock, tmp, gfc_get_dtype (type)); 5484 } 5485 5486 or_expr = logical_false_node; 5487 5488 for (n = 0; n < rank; n++) 5489 { 5490 tree conv_lbound; 5491 tree conv_ubound; 5492 5493 /* We have 3 possibilities for determining the size of the array: 5494 lower == NULL => lbound = 1, ubound = upper[n] 5495 upper[n] = NULL => lbound = 1, ubound = lower[n] 5496 upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ 5497 ubound = upper[n]; 5498 5499 /* Set lower bound. */ 5500 gfc_init_se (&se, NULL); 5501 if (expr3_desc != NULL_TREE) 5502 { 5503 if (e3_has_nodescriptor) 5504 /* The lbound of nondescriptor arrays like array constructors, 5505 nonallocatable/nonpointer function results/variables, 5506 start at zero, but when allocating it, the standard expects 5507 the array to start at one. */ 5508 se.expr = gfc_index_one_node; 5509 else 5510 se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, 5511 gfc_rank_cst[n]); 5512 } 5513 else if (lower == NULL) 5514 se.expr = gfc_index_one_node; 5515 else 5516 { 5517 gcc_assert (lower[n]); 5518 if (ubound) 5519 { 5520 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); 5521 gfc_add_block_to_block (pblock, &se.pre); 5522 } 5523 else 5524 { 5525 se.expr = gfc_index_one_node; 5526 ubound = lower[n]; 5527 } 5528 } 5529 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, 5530 gfc_rank_cst[n], se.expr); 5531 conv_lbound = se.expr; 5532 5533 /* Work out the offset for this component. */ 5534 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 5535 se.expr, stride); 5536 offset = fold_build2_loc (input_location, MINUS_EXPR, 5537 gfc_array_index_type, offset, tmp); 5538 5539 /* Set upper bound. */ 5540 gfc_init_se (&se, NULL); 5541 if (expr3_desc != NULL_TREE) 5542 { 5543 if (e3_has_nodescriptor) 5544 { 5545 /* The lbound of nondescriptor arrays like array constructors, 5546 nonallocatable/nonpointer function results/variables, 5547 start at zero, but when allocating it, the standard expects 5548 the array to start at one. Therefore fix the upper bound to be 5549 (desc.ubound - desc.lbound) + 1. */ 5550 tmp = fold_build2_loc (input_location, MINUS_EXPR, 5551 gfc_array_index_type, 5552 gfc_conv_descriptor_ubound_get ( 5553 expr3_desc, gfc_rank_cst[n]), 5554 gfc_conv_descriptor_lbound_get ( 5555 expr3_desc, gfc_rank_cst[n])); 5556 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5557 gfc_array_index_type, tmp, 5558 gfc_index_one_node); 5559 se.expr = gfc_evaluate_now (tmp, pblock); 5560 } 5561 else 5562 se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, 5563 gfc_rank_cst[n]); 5564 } 5565 else 5566 { 5567 gcc_assert (ubound); 5568 gfc_conv_expr_type (&se, ubound, gfc_array_index_type); 5569 gfc_add_block_to_block (pblock, &se.pre); 5570 if (ubound->expr_type == EXPR_FUNCTION) 5571 se.expr = gfc_evaluate_now (se.expr, pblock); 5572 } 5573 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, 5574 gfc_rank_cst[n], se.expr); 5575 conv_ubound = se.expr; 5576 5577 /* Store the stride. */ 5578 gfc_conv_descriptor_stride_set (descriptor_block, descriptor, 5579 gfc_rank_cst[n], stride); 5580 5581 /* Calculate size and check whether extent is negative. */ 5582 size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); 5583 size = gfc_evaluate_now (size, pblock); 5584 5585 /* Check whether multiplying the stride by the number of 5586 elements in this dimension would overflow. We must also check 5587 whether the current dimension has zero size in order to avoid 5588 division by zero. 5589 */ 5590 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 5591 gfc_array_index_type, 5592 fold_convert (gfc_array_index_type, 5593 TYPE_MAX_VALUE (gfc_array_index_type)), 5594 size); 5595 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, 5596 logical_type_node, tmp, stride), 5597 PRED_FORTRAN_OVERFLOW); 5598 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, 5599 integer_one_node, integer_zero_node); 5600 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, 5601 logical_type_node, size, 5602 gfc_index_zero_node), 5603 PRED_FORTRAN_SIZE_ZERO); 5604 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, 5605 integer_zero_node, tmp); 5606 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, 5607 *overflow, tmp); 5608 *overflow = gfc_evaluate_now (tmp, pblock); 5609 5610 /* Multiply the stride by the number of elements in this dimension. */ 5611 stride = fold_build2_loc (input_location, MULT_EXPR, 5612 gfc_array_index_type, stride, size); 5613 stride = gfc_evaluate_now (stride, pblock); 5614 } 5615 5616 for (n = rank; n < rank + corank; n++) 5617 { 5618 ubound = upper[n]; 5619 5620 /* Set lower bound. */ 5621 gfc_init_se (&se, NULL); 5622 if (lower == NULL || lower[n] == NULL) 5623 { 5624 gcc_assert (n == rank + corank - 1); 5625 se.expr = gfc_index_one_node; 5626 } 5627 else 5628 { 5629 if (ubound || n == rank + corank - 1) 5630 { 5631 gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); 5632 gfc_add_block_to_block (pblock, &se.pre); 5633 } 5634 else 5635 { 5636 se.expr = gfc_index_one_node; 5637 ubound = lower[n]; 5638 } 5639 } 5640 gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, 5641 gfc_rank_cst[n], se.expr); 5642 5643 if (n < rank + corank - 1) 5644 { 5645 gfc_init_se (&se, NULL); 5646 gcc_assert (ubound); 5647 gfc_conv_expr_type (&se, ubound, gfc_array_index_type); 5648 gfc_add_block_to_block (pblock, &se.pre); 5649 gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, 5650 gfc_rank_cst[n], se.expr); 5651 } 5652 } 5653 5654 /* The stride is the number of elements in the array, so multiply by the 5655 size of an element to get the total size. Obviously, if there is a 5656 SOURCE expression (expr3) we must use its element size. */ 5657 if (expr3_elem_size != NULL_TREE) 5658 tmp = expr3_elem_size; 5659 else if (expr3 != NULL) 5660 { 5661 if (expr3->ts.type == BT_CLASS) 5662 { 5663 gfc_se se_sz; 5664 gfc_expr *sz = gfc_copy_expr (expr3); 5665 gfc_add_vptr_component (sz); 5666 gfc_add_size_component (sz); 5667 gfc_init_se (&se_sz, NULL); 5668 gfc_conv_expr (&se_sz, sz); 5669 gfc_free_expr (sz); 5670 tmp = se_sz.expr; 5671 } 5672 else 5673 { 5674 tmp = gfc_typenode_for_spec (&expr3->ts); 5675 tmp = TYPE_SIZE_UNIT (tmp); 5676 } 5677 } 5678 else 5679 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 5680 5681 /* Convert to size_t. */ 5682 *element_size = fold_convert (size_type_node, tmp); 5683 5684 if (rank == 0) 5685 return *element_size; 5686 5687 *nelems = gfc_evaluate_now (stride, pblock); 5688 stride = fold_convert (size_type_node, stride); 5689 5690 /* First check for overflow. Since an array of type character can 5691 have zero element_size, we must check for that before 5692 dividing. */ 5693 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 5694 size_type_node, 5695 TYPE_MAX_VALUE (size_type_node), *element_size); 5696 cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, 5697 logical_type_node, tmp, stride), 5698 PRED_FORTRAN_OVERFLOW); 5699 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, 5700 integer_one_node, integer_zero_node); 5701 cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, 5702 logical_type_node, *element_size, 5703 build_int_cst (size_type_node, 0)), 5704 PRED_FORTRAN_SIZE_ZERO); 5705 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, 5706 integer_zero_node, tmp); 5707 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, 5708 *overflow, tmp); 5709 *overflow = gfc_evaluate_now (tmp, pblock); 5710 5711 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 5712 stride, *element_size); 5713 5714 if (poffset != NULL) 5715 { 5716 offset = gfc_evaluate_now (offset, pblock); 5717 *poffset = offset; 5718 } 5719 5720 if (integer_zerop (or_expr)) 5721 return size; 5722 if (integer_onep (or_expr)) 5723 return build_int_cst (size_type_node, 0); 5724 5725 var = gfc_create_var (TREE_TYPE (size), "size"); 5726 gfc_start_block (&thenblock); 5727 gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0)); 5728 thencase = gfc_finish_block (&thenblock); 5729 5730 gfc_start_block (&elseblock); 5731 gfc_add_modify (&elseblock, var, size); 5732 elsecase = gfc_finish_block (&elseblock); 5733 5734 tmp = gfc_evaluate_now (or_expr, pblock); 5735 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); 5736 gfc_add_expr_to_block (pblock, tmp); 5737 5738 return var; 5739 } 5740 5741 5742 /* Retrieve the last ref from the chain. This routine is specific to 5743 gfc_array_allocate ()'s needs. */ 5744 5745 bool 5746 retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) 5747 { 5748 gfc_ref *ref, *prev_ref; 5749 5750 ref = *ref_in; 5751 /* Prevent warnings for uninitialized variables. */ 5752 prev_ref = *prev_ref_in; 5753 while (ref && ref->next != NULL) 5754 { 5755 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT 5756 || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); 5757 prev_ref = ref; 5758 ref = ref->next; 5759 } 5760 5761 if (ref == NULL || ref->type != REF_ARRAY) 5762 return false; 5763 5764 *ref_in = ref; 5765 *prev_ref_in = prev_ref; 5766 return true; 5767 } 5768 5769 /* Initializes the descriptor and generates a call to _gfor_allocate. Does 5770 the work for an ALLOCATE statement. */ 5771 /*GCC ARRAYS*/ 5772 5773 bool 5774 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, 5775 tree errlen, tree label_finish, tree expr3_elem_size, 5776 tree *nelems, gfc_expr *expr3, tree e3_arr_desc, 5777 bool e3_has_nodescriptor) 5778 { 5779 tree tmp; 5780 tree pointer; 5781 tree offset = NULL_TREE; 5782 tree token = NULL_TREE; 5783 tree size; 5784 tree msg; 5785 tree error = NULL_TREE; 5786 tree overflow; /* Boolean storing whether size calculation overflows. */ 5787 tree var_overflow = NULL_TREE; 5788 tree cond; 5789 tree set_descriptor; 5790 tree not_prev_allocated = NULL_TREE; 5791 tree element_size = NULL_TREE; 5792 stmtblock_t set_descriptor_block; 5793 stmtblock_t elseblock; 5794 gfc_expr **lower; 5795 gfc_expr **upper; 5796 gfc_ref *ref, *prev_ref = NULL, *coref; 5797 bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, 5798 non_ulimate_coarray_ptr_comp; 5799 5800 ref = expr->ref; 5801 5802 /* Find the last reference in the chain. */ 5803 if (!retrieve_last_ref (&ref, &prev_ref)) 5804 return false; 5805 5806 /* Take the allocatable and coarray properties solely from the expr-ref's 5807 attributes and not from source=-expression. */ 5808 if (!prev_ref) 5809 { 5810 allocatable = expr->symtree->n.sym->attr.allocatable; 5811 dimension = expr->symtree->n.sym->attr.dimension; 5812 non_ulimate_coarray_ptr_comp = false; 5813 } 5814 else 5815 { 5816 allocatable = prev_ref->u.c.component->attr.allocatable; 5817 /* Pointer components in coarrayed derived types must be treated 5818 specially in that they are registered without a check if the are 5819 already associated. This does not hold for ultimate coarray 5820 pointers. */ 5821 non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer 5822 && !prev_ref->u.c.component->attr.codimension); 5823 dimension = prev_ref->u.c.component->attr.dimension; 5824 } 5825 5826 /* For allocatable/pointer arrays in derived types, one of the refs has to be 5827 a coarray. In this case it does not matter whether we are on this_image 5828 or not. */ 5829 coarray = false; 5830 for (coref = expr->ref; coref; coref = coref->next) 5831 if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0) 5832 { 5833 coarray = true; 5834 break; 5835 } 5836 5837 if (!dimension) 5838 gcc_assert (coarray); 5839 5840 if (ref->u.ar.type == AR_FULL && expr3 != NULL) 5841 { 5842 gfc_ref *old_ref = ref; 5843 /* F08:C633: Array shape from expr3. */ 5844 ref = expr3->ref; 5845 5846 /* Find the last reference in the chain. */ 5847 if (!retrieve_last_ref (&ref, &prev_ref)) 5848 { 5849 if (expr3->expr_type == EXPR_FUNCTION 5850 && gfc_expr_attr (expr3).dimension) 5851 ref = old_ref; 5852 else 5853 return false; 5854 } 5855 alloc_w_e3_arr_spec = true; 5856 } 5857 5858 /* Figure out the size of the array. */ 5859 switch (ref->u.ar.type) 5860 { 5861 case AR_ELEMENT: 5862 if (!coarray) 5863 { 5864 lower = NULL; 5865 upper = ref->u.ar.start; 5866 break; 5867 } 5868 /* Fall through. */ 5869 5870 case AR_SECTION: 5871 lower = ref->u.ar.start; 5872 upper = ref->u.ar.end; 5873 break; 5874 5875 case AR_FULL: 5876 gcc_assert (ref->u.ar.as->type == AS_EXPLICIT 5877 || alloc_w_e3_arr_spec); 5878 5879 lower = ref->u.ar.as->lower; 5880 upper = ref->u.ar.as->upper; 5881 break; 5882 5883 default: 5884 gcc_unreachable (); 5885 break; 5886 } 5887 5888 overflow = integer_zero_node; 5889 5890 if (expr->ts.type == BT_CHARACTER 5891 && TREE_CODE (se->string_length) == COMPONENT_REF 5892 && expr->ts.u.cl->backend_decl != se->string_length 5893 && VAR_P (expr->ts.u.cl->backend_decl)) 5894 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, 5895 fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), 5896 se->string_length)); 5897 5898 gfc_init_block (&set_descriptor_block); 5899 /* Take the corank only from the actual ref and not from the coref. The 5900 later will mislead the generation of the array dimensions for allocatable/ 5901 pointer components in derived types. */ 5902 size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank 5903 : ref->u.ar.as->rank, 5904 coarray ? ref->u.ar.as->corank : 0, 5905 &offset, lower, upper, 5906 &se->pre, &set_descriptor_block, &overflow, 5907 expr3_elem_size, nelems, expr3, e3_arr_desc, 5908 e3_has_nodescriptor, expr, &element_size); 5909 5910 if (dimension) 5911 { 5912 var_overflow = gfc_create_var (integer_type_node, "overflow"); 5913 gfc_add_modify (&se->pre, var_overflow, overflow); 5914 5915 if (status == NULL_TREE) 5916 { 5917 /* Generate the block of code handling overflow. */ 5918 msg = gfc_build_addr_expr (pchar_type_node, 5919 gfc_build_localized_cstring_const 5920 ("Integer overflow when calculating the amount of " 5921 "memory to allocate")); 5922 error = build_call_expr_loc (input_location, 5923 gfor_fndecl_runtime_error, 1, msg); 5924 } 5925 else 5926 { 5927 tree status_type = TREE_TYPE (status); 5928 stmtblock_t set_status_block; 5929 5930 gfc_start_block (&set_status_block); 5931 gfc_add_modify (&set_status_block, status, 5932 build_int_cst (status_type, LIBERROR_ALLOCATION)); 5933 error = gfc_finish_block (&set_status_block); 5934 } 5935 } 5936 5937 /* Allocate memory to store the data. */ 5938 if (POINTER_TYPE_P (TREE_TYPE (se->expr))) 5939 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 5940 5941 if (coarray && flag_coarray == GFC_FCOARRAY_LIB) 5942 { 5943 pointer = non_ulimate_coarray_ptr_comp ? se->expr 5944 : gfc_conv_descriptor_data_get (se->expr); 5945 token = gfc_conv_descriptor_token (se->expr); 5946 token = gfc_build_addr_expr (NULL_TREE, token); 5947 } 5948 else 5949 pointer = gfc_conv_descriptor_data_get (se->expr); 5950 STRIP_NOPS (pointer); 5951 5952 if (allocatable) 5953 { 5954 not_prev_allocated = gfc_create_var (logical_type_node, 5955 "not_prev_allocated"); 5956 tmp = fold_build2_loc (input_location, EQ_EXPR, 5957 logical_type_node, pointer, 5958 build_int_cst (TREE_TYPE (pointer), 0)); 5959 5960 gfc_add_modify (&se->pre, not_prev_allocated, tmp); 5961 } 5962 5963 gfc_start_block (&elseblock); 5964 5965 /* The allocatable variant takes the old pointer as first argument. */ 5966 if (allocatable) 5967 gfc_allocate_allocatable (&elseblock, pointer, size, token, 5968 status, errmsg, errlen, label_finish, expr, 5969 coref != NULL ? coref->u.ar.as->corank : 0); 5970 else if (non_ulimate_coarray_ptr_comp && token) 5971 /* The token is set only for GFC_FCOARRAY_LIB mode. */ 5972 gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, 5973 errmsg, errlen, 5974 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); 5975 else 5976 gfc_allocate_using_malloc (&elseblock, pointer, size, status); 5977 5978 if (dimension) 5979 { 5980 cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, 5981 logical_type_node, var_overflow, integer_zero_node), 5982 PRED_FORTRAN_OVERFLOW); 5983 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5984 error, gfc_finish_block (&elseblock)); 5985 } 5986 else 5987 tmp = gfc_finish_block (&elseblock); 5988 5989 gfc_add_expr_to_block (&se->pre, tmp); 5990 5991 /* Update the array descriptor with the offset and the span. */ 5992 if (dimension) 5993 { 5994 gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); 5995 tmp = fold_convert (gfc_array_index_type, element_size); 5996 gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); 5997 } 5998 5999 set_descriptor = gfc_finish_block (&set_descriptor_block); 6000 if (status != NULL_TREE) 6001 { 6002 cond = fold_build2_loc (input_location, EQ_EXPR, 6003 logical_type_node, status, 6004 build_int_cst (TREE_TYPE (status), 0)); 6005 6006 if (not_prev_allocated != NULL_TREE) 6007 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 6008 logical_type_node, cond, not_prev_allocated); 6009 6010 gfc_add_expr_to_block (&se->pre, 6011 fold_build3_loc (input_location, COND_EXPR, void_type_node, 6012 cond, 6013 set_descriptor, 6014 build_empty_stmt (input_location))); 6015 } 6016 else 6017 gfc_add_expr_to_block (&se->pre, set_descriptor); 6018 6019 return true; 6020 } 6021 6022 6023 /* Create an array constructor from an initialization expression. 6024 We assume the frontend already did any expansions and conversions. */ 6025 6026 tree 6027 gfc_conv_array_initializer (tree type, gfc_expr * expr) 6028 { 6029 gfc_constructor *c; 6030 tree tmp; 6031 gfc_se se; 6032 tree index, range; 6033 vec<constructor_elt, va_gc> *v = NULL; 6034 6035 if (expr->expr_type == EXPR_VARIABLE 6036 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER 6037 && expr->symtree->n.sym->value) 6038 expr = expr->symtree->n.sym->value; 6039 6040 switch (expr->expr_type) 6041 { 6042 case EXPR_CONSTANT: 6043 case EXPR_STRUCTURE: 6044 /* A single scalar or derived type value. Create an array with all 6045 elements equal to that value. */ 6046 gfc_init_se (&se, NULL); 6047 6048 if (expr->expr_type == EXPR_CONSTANT) 6049 gfc_conv_constant (&se, expr); 6050 else 6051 gfc_conv_structure (&se, expr, 1); 6052 6053 CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type, 6054 TYPE_MIN_VALUE (TYPE_DOMAIN (type)), 6055 TYPE_MAX_VALUE (TYPE_DOMAIN (type))), 6056 se.expr); 6057 break; 6058 6059 case EXPR_ARRAY: 6060 /* Create a vector of all the elements. */ 6061 for (c = gfc_constructor_first (expr->value.constructor); 6062 c; c = gfc_constructor_next (c)) 6063 { 6064 if (c->iterator) 6065 { 6066 /* Problems occur when we get something like 6067 integer :: a(lots) = (/(i, i=1, lots)/) */ 6068 gfc_fatal_error ("The number of elements in the array " 6069 "constructor at %L requires an increase of " 6070 "the allowed %d upper limit. See " 6071 "%<-fmax-array-constructor%> option", 6072 &expr->where, flag_max_array_constructor); 6073 return NULL_TREE; 6074 } 6075 if (mpz_cmp_si (c->offset, 0) != 0) 6076 index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); 6077 else 6078 index = NULL_TREE; 6079 6080 if (mpz_cmp_si (c->repeat, 1) > 0) 6081 { 6082 tree tmp1, tmp2; 6083 mpz_t maxval; 6084 6085 mpz_init (maxval); 6086 mpz_add (maxval, c->offset, c->repeat); 6087 mpz_sub_ui (maxval, maxval, 1); 6088 tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); 6089 if (mpz_cmp_si (c->offset, 0) != 0) 6090 { 6091 mpz_add_ui (maxval, c->offset, 1); 6092 tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); 6093 } 6094 else 6095 tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); 6096 6097 range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); 6098 mpz_clear (maxval); 6099 } 6100 else 6101 range = NULL; 6102 6103 gfc_init_se (&se, NULL); 6104 switch (c->expr->expr_type) 6105 { 6106 case EXPR_CONSTANT: 6107 gfc_conv_constant (&se, c->expr); 6108 6109 /* See gfortran.dg/charlen_15.f90 for instance. */ 6110 if (TREE_CODE (se.expr) == STRING_CST 6111 && TREE_CODE (type) == ARRAY_TYPE) 6112 { 6113 tree atype = type; 6114 while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE) 6115 atype = TREE_TYPE (atype); 6116 gcc_checking_assert (TREE_CODE (TREE_TYPE (atype)) 6117 == INTEGER_TYPE); 6118 gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr)) 6119 == TREE_TYPE (atype)); 6120 if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr))) 6121 > tree_to_uhwi (TYPE_SIZE_UNIT (atype))) 6122 { 6123 unsigned HOST_WIDE_INT size 6124 = tree_to_uhwi (TYPE_SIZE_UNIT (atype)); 6125 const char *p = TREE_STRING_POINTER (se.expr); 6126 6127 se.expr = build_string (size, p); 6128 } 6129 TREE_TYPE (se.expr) = atype; 6130 } 6131 break; 6132 6133 case EXPR_STRUCTURE: 6134 gfc_conv_structure (&se, c->expr, 1); 6135 break; 6136 6137 default: 6138 /* Catch those occasional beasts that do not simplify 6139 for one reason or another, assuming that if they are 6140 standard defying the frontend will catch them. */ 6141 gfc_conv_expr (&se, c->expr); 6142 break; 6143 } 6144 6145 if (range == NULL_TREE) 6146 CONSTRUCTOR_APPEND_ELT (v, index, se.expr); 6147 else 6148 { 6149 if (index != NULL_TREE) 6150 CONSTRUCTOR_APPEND_ELT (v, index, se.expr); 6151 CONSTRUCTOR_APPEND_ELT (v, range, se.expr); 6152 } 6153 } 6154 break; 6155 6156 case EXPR_NULL: 6157 return gfc_build_null_descriptor (type); 6158 6159 default: 6160 gcc_unreachable (); 6161 } 6162 6163 /* Create a constructor from the list of elements. */ 6164 tmp = build_constructor (type, v); 6165 TREE_CONSTANT (tmp) = 1; 6166 return tmp; 6167 } 6168 6169 6170 /* Generate code to evaluate non-constant coarray cobounds. */ 6171 6172 void 6173 gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, 6174 const gfc_symbol *sym) 6175 { 6176 int dim; 6177 tree ubound; 6178 tree lbound; 6179 gfc_se se; 6180 gfc_array_spec *as; 6181 6182 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; 6183 6184 for (dim = as->rank; dim < as->rank + as->corank; dim++) 6185 { 6186 /* Evaluate non-constant array bound expressions. */ 6187 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); 6188 if (as->lower[dim] && !INTEGER_CST_P (lbound)) 6189 { 6190 gfc_init_se (&se, NULL); 6191 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); 6192 gfc_add_block_to_block (pblock, &se.pre); 6193 gfc_add_modify (pblock, lbound, se.expr); 6194 } 6195 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); 6196 if (as->upper[dim] && !INTEGER_CST_P (ubound)) 6197 { 6198 gfc_init_se (&se, NULL); 6199 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); 6200 gfc_add_block_to_block (pblock, &se.pre); 6201 gfc_add_modify (pblock, ubound, se.expr); 6202 } 6203 } 6204 } 6205 6206 6207 /* Generate code to evaluate non-constant array bounds. Sets *poffset and 6208 returns the size (in elements) of the array. */ 6209 6210 static tree 6211 gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, 6212 stmtblock_t * pblock) 6213 { 6214 gfc_array_spec *as; 6215 tree size; 6216 tree stride; 6217 tree offset; 6218 tree ubound; 6219 tree lbound; 6220 tree tmp; 6221 gfc_se se; 6222 6223 int dim; 6224 6225 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; 6226 6227 size = gfc_index_one_node; 6228 offset = gfc_index_zero_node; 6229 for (dim = 0; dim < as->rank; dim++) 6230 { 6231 /* Evaluate non-constant array bound expressions. */ 6232 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); 6233 if (as->lower[dim] && !INTEGER_CST_P (lbound)) 6234 { 6235 gfc_init_se (&se, NULL); 6236 gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); 6237 gfc_add_block_to_block (pblock, &se.pre); 6238 gfc_add_modify (pblock, lbound, se.expr); 6239 } 6240 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); 6241 if (as->upper[dim] && !INTEGER_CST_P (ubound)) 6242 { 6243 gfc_init_se (&se, NULL); 6244 gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); 6245 gfc_add_block_to_block (pblock, &se.pre); 6246 gfc_add_modify (pblock, ubound, se.expr); 6247 } 6248 /* The offset of this dimension. offset = offset - lbound * stride. */ 6249 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 6250 lbound, size); 6251 offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 6252 offset, tmp); 6253 6254 /* The size of this dimension, and the stride of the next. */ 6255 if (dim + 1 < as->rank) 6256 stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); 6257 else 6258 stride = GFC_TYPE_ARRAY_SIZE (type); 6259 6260 if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) 6261 { 6262 /* Calculate stride = size * (ubound + 1 - lbound). */ 6263 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6264 gfc_array_index_type, 6265 gfc_index_one_node, lbound); 6266 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6267 gfc_array_index_type, ubound, tmp); 6268 tmp = fold_build2_loc (input_location, MULT_EXPR, 6269 gfc_array_index_type, size, tmp); 6270 if (stride) 6271 gfc_add_modify (pblock, stride, tmp); 6272 else 6273 stride = gfc_evaluate_now (tmp, pblock); 6274 6275 /* Make sure that negative size arrays are translated 6276 to being zero size. */ 6277 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 6278 stride, gfc_index_zero_node); 6279 tmp = fold_build3_loc (input_location, COND_EXPR, 6280 gfc_array_index_type, tmp, 6281 stride, gfc_index_zero_node); 6282 gfc_add_modify (pblock, stride, tmp); 6283 } 6284 6285 size = stride; 6286 } 6287 6288 gfc_trans_array_cobounds (type, pblock, sym); 6289 gfc_trans_vla_type_sizes (sym, pblock); 6290 6291 *poffset = offset; 6292 return size; 6293 } 6294 6295 6296 /* Generate code to initialize/allocate an array variable. */ 6297 6298 void 6299 gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, 6300 gfc_wrapped_block * block) 6301 { 6302 stmtblock_t init; 6303 tree type; 6304 tree tmp = NULL_TREE; 6305 tree size; 6306 tree offset; 6307 tree space; 6308 tree inittree; 6309 bool onstack; 6310 6311 gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); 6312 6313 /* Do nothing for USEd variables. */ 6314 if (sym->attr.use_assoc) 6315 return; 6316 6317 type = TREE_TYPE (decl); 6318 gcc_assert (GFC_ARRAY_TYPE_P (type)); 6319 onstack = TREE_CODE (type) != POINTER_TYPE; 6320 6321 gfc_init_block (&init); 6322 6323 /* Evaluate character string length. */ 6324 if (sym->ts.type == BT_CHARACTER 6325 && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) 6326 { 6327 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 6328 6329 gfc_trans_vla_type_sizes (sym, &init); 6330 6331 /* Emit a DECL_EXPR for this variable, which will cause the 6332 gimplifier to allocate storage, and all that good stuff. */ 6333 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); 6334 gfc_add_expr_to_block (&init, tmp); 6335 } 6336 6337 if (onstack) 6338 { 6339 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 6340 return; 6341 } 6342 6343 type = TREE_TYPE (type); 6344 6345 gcc_assert (!sym->attr.use_assoc); 6346 gcc_assert (!TREE_STATIC (decl)); 6347 gcc_assert (!sym->module); 6348 6349 if (sym->ts.type == BT_CHARACTER 6350 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) 6351 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 6352 6353 size = gfc_trans_array_bounds (type, sym, &offset, &init); 6354 6355 /* Don't actually allocate space for Cray Pointees. */ 6356 if (sym->attr.cray_pointee) 6357 { 6358 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) 6359 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); 6360 6361 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 6362 return; 6363 } 6364 6365 if (flag_stack_arrays) 6366 { 6367 gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); 6368 space = build_decl (sym->declared_at.lb->location, 6369 VAR_DECL, create_tmp_var_name ("A"), 6370 TREE_TYPE (TREE_TYPE (decl))); 6371 gfc_trans_vla_type_sizes (sym, &init); 6372 } 6373 else 6374 { 6375 /* The size is the number of elements in the array, so multiply by the 6376 size of an element to get the total size. */ 6377 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 6378 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 6379 size, fold_convert (gfc_array_index_type, tmp)); 6380 6381 /* Allocate memory to hold the data. */ 6382 tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); 6383 gfc_add_modify (&init, decl, tmp); 6384 6385 /* Free the temporary. */ 6386 tmp = gfc_call_free (decl); 6387 space = NULL_TREE; 6388 } 6389 6390 /* Set offset of the array. */ 6391 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) 6392 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); 6393 6394 /* Automatic arrays should not have initializers. */ 6395 gcc_assert (!sym->value); 6396 6397 inittree = gfc_finish_block (&init); 6398 6399 if (space) 6400 { 6401 tree addr; 6402 pushdecl (space); 6403 6404 /* Don't create new scope, emit the DECL_EXPR in exactly the scope 6405 where also space is located. */ 6406 gfc_init_block (&init); 6407 tmp = fold_build1_loc (input_location, DECL_EXPR, 6408 TREE_TYPE (space), space); 6409 gfc_add_expr_to_block (&init, tmp); 6410 addr = fold_build1_loc (sym->declared_at.lb->location, 6411 ADDR_EXPR, TREE_TYPE (decl), space); 6412 gfc_add_modify (&init, decl, addr); 6413 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 6414 tmp = NULL_TREE; 6415 } 6416 gfc_add_init_cleanup (block, inittree, tmp); 6417 } 6418 6419 6420 /* Generate entry and exit code for g77 calling convention arrays. */ 6421 6422 void 6423 gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) 6424 { 6425 tree parm; 6426 tree type; 6427 locus loc; 6428 tree offset; 6429 tree tmp; 6430 tree stmt; 6431 stmtblock_t init; 6432 6433 gfc_save_backend_locus (&loc); 6434 gfc_set_backend_locus (&sym->declared_at); 6435 6436 /* Descriptor type. */ 6437 parm = sym->backend_decl; 6438 type = TREE_TYPE (parm); 6439 gcc_assert (GFC_ARRAY_TYPE_P (type)); 6440 6441 gfc_start_block (&init); 6442 6443 if (sym->ts.type == BT_CHARACTER 6444 && VAR_P (sym->ts.u.cl->backend_decl)) 6445 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 6446 6447 /* Evaluate the bounds of the array. */ 6448 gfc_trans_array_bounds (type, sym, &offset, &init); 6449 6450 /* Set the offset. */ 6451 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) 6452 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); 6453 6454 /* Set the pointer itself if we aren't using the parameter directly. */ 6455 if (TREE_CODE (parm) != PARM_DECL) 6456 { 6457 tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); 6458 gfc_add_modify (&init, parm, tmp); 6459 } 6460 stmt = gfc_finish_block (&init); 6461 6462 gfc_restore_backend_locus (&loc); 6463 6464 /* Add the initialization code to the start of the function. */ 6465 6466 if (sym->attr.optional || sym->attr.not_always_present) 6467 { 6468 tmp = gfc_conv_expr_present (sym); 6469 stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); 6470 } 6471 6472 gfc_add_init_cleanup (block, stmt, NULL_TREE); 6473 } 6474 6475 6476 /* Modify the descriptor of an array parameter so that it has the 6477 correct lower bound. Also move the upper bound accordingly. 6478 If the array is not packed, it will be copied into a temporary. 6479 For each dimension we set the new lower and upper bounds. Then we copy the 6480 stride and calculate the offset for this dimension. We also work out 6481 what the stride of a packed array would be, and see it the two match. 6482 If the array need repacking, we set the stride to the values we just 6483 calculated, recalculate the offset and copy the array data. 6484 Code is also added to copy the data back at the end of the function. 6485 */ 6486 6487 void 6488 gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, 6489 gfc_wrapped_block * block) 6490 { 6491 tree size; 6492 tree type; 6493 tree offset; 6494 locus loc; 6495 stmtblock_t init; 6496 tree stmtInit, stmtCleanup; 6497 tree lbound; 6498 tree ubound; 6499 tree dubound; 6500 tree dlbound; 6501 tree dumdesc; 6502 tree tmp; 6503 tree stride, stride2; 6504 tree stmt_packed; 6505 tree stmt_unpacked; 6506 tree partial; 6507 gfc_se se; 6508 int n; 6509 int checkparm; 6510 int no_repack; 6511 bool optional_arg; 6512 gfc_array_spec *as; 6513 bool is_classarray = IS_CLASS_ARRAY (sym); 6514 6515 /* Do nothing for pointer and allocatable arrays. */ 6516 if ((sym->ts.type != BT_CLASS && sym->attr.pointer) 6517 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) 6518 || sym->attr.allocatable 6519 || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) 6520 return; 6521 6522 if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) 6523 { 6524 gfc_trans_g77_array (sym, block); 6525 return; 6526 } 6527 6528 loc.nextc = NULL; 6529 gfc_save_backend_locus (&loc); 6530 /* loc.nextc is not set by save_backend_locus but the location routines 6531 depend on it. */ 6532 if (loc.nextc == NULL) 6533 loc.nextc = loc.lb->line; 6534 gfc_set_backend_locus (&sym->declared_at); 6535 6536 /* Descriptor type. */ 6537 type = TREE_TYPE (tmpdesc); 6538 gcc_assert (GFC_ARRAY_TYPE_P (type)); 6539 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); 6540 if (is_classarray) 6541 /* For a class array the dummy array descriptor is in the _class 6542 component. */ 6543 dumdesc = gfc_class_data_get (dumdesc); 6544 else 6545 dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); 6546 as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; 6547 gfc_start_block (&init); 6548 6549 if (sym->ts.type == BT_CHARACTER 6550 && VAR_P (sym->ts.u.cl->backend_decl)) 6551 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 6552 6553 checkparm = (as->type == AS_EXPLICIT 6554 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); 6555 6556 no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) 6557 || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); 6558 6559 if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) 6560 { 6561 /* For non-constant shape arrays we only check if the first dimension 6562 is contiguous. Repacking higher dimensions wouldn't gain us 6563 anything as we still don't know the array stride. */ 6564 partial = gfc_create_var (logical_type_node, "partial"); 6565 TREE_USED (partial) = 1; 6566 tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); 6567 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, 6568 gfc_index_one_node); 6569 gfc_add_modify (&init, partial, tmp); 6570 } 6571 else 6572 partial = NULL_TREE; 6573 6574 /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive 6575 here, however I think it does the right thing. */ 6576 if (no_repack) 6577 { 6578 /* Set the first stride. */ 6579 stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); 6580 stride = gfc_evaluate_now (stride, &init); 6581 6582 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 6583 stride, gfc_index_zero_node); 6584 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, 6585 tmp, gfc_index_one_node, stride); 6586 stride = GFC_TYPE_ARRAY_STRIDE (type, 0); 6587 gfc_add_modify (&init, stride, tmp); 6588 6589 /* Allow the user to disable array repacking. */ 6590 stmt_unpacked = NULL_TREE; 6591 } 6592 else 6593 { 6594 gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); 6595 /* A library call to repack the array if necessary. */ 6596 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); 6597 stmt_unpacked = build_call_expr_loc (input_location, 6598 gfor_fndecl_in_pack, 1, tmp); 6599 6600 stride = gfc_index_one_node; 6601 6602 if (warn_array_temporaries) 6603 gfc_warning (OPT_Warray_temporaries, 6604 "Creating array temporary at %L", &loc); 6605 } 6606 6607 /* This is for the case where the array data is used directly without 6608 calling the repack function. */ 6609 if (no_repack || partial != NULL_TREE) 6610 stmt_packed = gfc_conv_descriptor_data_get (dumdesc); 6611 else 6612 stmt_packed = NULL_TREE; 6613 6614 /* Assign the data pointer. */ 6615 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) 6616 { 6617 /* Don't repack unknown shape arrays when the first stride is 1. */ 6618 tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), 6619 partial, stmt_packed, stmt_unpacked); 6620 } 6621 else 6622 tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; 6623 gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); 6624 6625 offset = gfc_index_zero_node; 6626 size = gfc_index_one_node; 6627 6628 /* Evaluate the bounds of the array. */ 6629 for (n = 0; n < as->rank; n++) 6630 { 6631 if (checkparm || !as->upper[n]) 6632 { 6633 /* Get the bounds of the actual parameter. */ 6634 dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); 6635 dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); 6636 } 6637 else 6638 { 6639 dubound = NULL_TREE; 6640 dlbound = NULL_TREE; 6641 } 6642 6643 lbound = GFC_TYPE_ARRAY_LBOUND (type, n); 6644 if (!INTEGER_CST_P (lbound)) 6645 { 6646 gfc_init_se (&se, NULL); 6647 gfc_conv_expr_type (&se, as->lower[n], 6648 gfc_array_index_type); 6649 gfc_add_block_to_block (&init, &se.pre); 6650 gfc_add_modify (&init, lbound, se.expr); 6651 } 6652 6653 ubound = GFC_TYPE_ARRAY_UBOUND (type, n); 6654 /* Set the desired upper bound. */ 6655 if (as->upper[n]) 6656 { 6657 /* We know what we want the upper bound to be. */ 6658 if (!INTEGER_CST_P (ubound)) 6659 { 6660 gfc_init_se (&se, NULL); 6661 gfc_conv_expr_type (&se, as->upper[n], 6662 gfc_array_index_type); 6663 gfc_add_block_to_block (&init, &se.pre); 6664 gfc_add_modify (&init, ubound, se.expr); 6665 } 6666 6667 /* Check the sizes match. */ 6668 if (checkparm) 6669 { 6670 /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ 6671 char * msg; 6672 tree temp; 6673 6674 temp = fold_build2_loc (input_location, MINUS_EXPR, 6675 gfc_array_index_type, ubound, lbound); 6676 temp = fold_build2_loc (input_location, PLUS_EXPR, 6677 gfc_array_index_type, 6678 gfc_index_one_node, temp); 6679 stride2 = fold_build2_loc (input_location, MINUS_EXPR, 6680 gfc_array_index_type, dubound, 6681 dlbound); 6682 stride2 = fold_build2_loc (input_location, PLUS_EXPR, 6683 gfc_array_index_type, 6684 gfc_index_one_node, stride2); 6685 tmp = fold_build2_loc (input_location, NE_EXPR, 6686 gfc_array_index_type, temp, stride2); 6687 msg = xasprintf ("Dimension %d of array '%s' has extent " 6688 "%%ld instead of %%ld", n+1, sym->name); 6689 6690 gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, 6691 fold_convert (long_integer_type_node, temp), 6692 fold_convert (long_integer_type_node, stride2)); 6693 6694 free (msg); 6695 } 6696 } 6697 else 6698 { 6699 /* For assumed shape arrays move the upper bound by the same amount 6700 as the lower bound. */ 6701 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6702 gfc_array_index_type, dubound, dlbound); 6703 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6704 gfc_array_index_type, tmp, lbound); 6705 gfc_add_modify (&init, ubound, tmp); 6706 } 6707 /* The offset of this dimension. offset = offset - lbound * stride. */ 6708 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 6709 lbound, stride); 6710 offset = fold_build2_loc (input_location, MINUS_EXPR, 6711 gfc_array_index_type, offset, tmp); 6712 6713 /* The size of this dimension, and the stride of the next. */ 6714 if (n + 1 < as->rank) 6715 { 6716 stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); 6717 6718 if (no_repack || partial != NULL_TREE) 6719 stmt_unpacked = 6720 gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); 6721 6722 /* Figure out the stride if not a known constant. */ 6723 if (!INTEGER_CST_P (stride)) 6724 { 6725 if (no_repack) 6726 stmt_packed = NULL_TREE; 6727 else 6728 { 6729 /* Calculate stride = size * (ubound + 1 - lbound). */ 6730 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6731 gfc_array_index_type, 6732 gfc_index_one_node, lbound); 6733 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6734 gfc_array_index_type, ubound, tmp); 6735 size = fold_build2_loc (input_location, MULT_EXPR, 6736 gfc_array_index_type, size, tmp); 6737 stmt_packed = size; 6738 } 6739 6740 /* Assign the stride. */ 6741 if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) 6742 tmp = fold_build3_loc (input_location, COND_EXPR, 6743 gfc_array_index_type, partial, 6744 stmt_unpacked, stmt_packed); 6745 else 6746 tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; 6747 gfc_add_modify (&init, stride, tmp); 6748 } 6749 } 6750 else 6751 { 6752 stride = GFC_TYPE_ARRAY_SIZE (type); 6753 6754 if (stride && !INTEGER_CST_P (stride)) 6755 { 6756 /* Calculate size = stride * (ubound + 1 - lbound). */ 6757 tmp = fold_build2_loc (input_location, MINUS_EXPR, 6758 gfc_array_index_type, 6759 gfc_index_one_node, lbound); 6760 tmp = fold_build2_loc (input_location, PLUS_EXPR, 6761 gfc_array_index_type, 6762 ubound, tmp); 6763 tmp = fold_build2_loc (input_location, MULT_EXPR, 6764 gfc_array_index_type, 6765 GFC_TYPE_ARRAY_STRIDE (type, n), tmp); 6766 gfc_add_modify (&init, stride, tmp); 6767 } 6768 } 6769 } 6770 6771 gfc_trans_array_cobounds (type, &init, sym); 6772 6773 /* Set the offset. */ 6774 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) 6775 gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); 6776 6777 gfc_trans_vla_type_sizes (sym, &init); 6778 6779 stmtInit = gfc_finish_block (&init); 6780 6781 /* Only do the entry/initialization code if the arg is present. */ 6782 dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); 6783 optional_arg = (sym->attr.optional 6784 || (sym->ns->proc_name->attr.entry_master 6785 && sym->attr.dummy)); 6786 if (optional_arg) 6787 { 6788 tmp = gfc_conv_expr_present (sym); 6789 stmtInit = build3_v (COND_EXPR, tmp, stmtInit, 6790 build_empty_stmt (input_location)); 6791 } 6792 6793 /* Cleanup code. */ 6794 if (no_repack) 6795 stmtCleanup = NULL_TREE; 6796 else 6797 { 6798 stmtblock_t cleanup; 6799 gfc_start_block (&cleanup); 6800 6801 if (sym->attr.intent != INTENT_IN) 6802 { 6803 /* Copy the data back. */ 6804 tmp = build_call_expr_loc (input_location, 6805 gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); 6806 gfc_add_expr_to_block (&cleanup, tmp); 6807 } 6808 6809 /* Free the temporary. */ 6810 tmp = gfc_call_free (tmpdesc); 6811 gfc_add_expr_to_block (&cleanup, tmp); 6812 6813 stmtCleanup = gfc_finish_block (&cleanup); 6814 6815 /* Only do the cleanup if the array was repacked. */ 6816 if (is_classarray) 6817 /* For a class array the dummy array descriptor is in the _class 6818 component. */ 6819 tmp = gfc_class_data_get (dumdesc); 6820 else 6821 tmp = build_fold_indirect_ref_loc (input_location, dumdesc); 6822 tmp = gfc_conv_descriptor_data_get (tmp); 6823 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 6824 tmp, tmpdesc); 6825 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, 6826 build_empty_stmt (input_location)); 6827 6828 if (optional_arg) 6829 { 6830 tmp = gfc_conv_expr_present (sym); 6831 stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, 6832 build_empty_stmt (input_location)); 6833 } 6834 } 6835 6836 /* We don't need to free any memory allocated by internal_pack as it will 6837 be freed at the end of the function by pop_context. */ 6838 gfc_add_init_cleanup (block, stmtInit, stmtCleanup); 6839 6840 gfc_restore_backend_locus (&loc); 6841 } 6842 6843 6844 /* Calculate the overall offset, including subreferences. */ 6845 void 6846 gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, 6847 bool subref, gfc_expr *expr) 6848 { 6849 tree tmp; 6850 tree field; 6851 tree stride; 6852 tree index; 6853 gfc_ref *ref; 6854 gfc_se start; 6855 int n; 6856 6857 /* If offset is NULL and this is not a subreferenced array, there is 6858 nothing to do. */ 6859 if (offset == NULL_TREE) 6860 { 6861 if (subref) 6862 offset = gfc_index_zero_node; 6863 else 6864 return; 6865 } 6866 6867 tmp = build_array_ref (desc, offset, NULL, NULL); 6868 6869 /* Offset the data pointer for pointer assignments from arrays with 6870 subreferences; e.g. my_integer => my_type(:)%integer_component. */ 6871 if (subref) 6872 { 6873 /* Go past the array reference. */ 6874 for (ref = expr->ref; ref; ref = ref->next) 6875 if (ref->type == REF_ARRAY && 6876 ref->u.ar.type != AR_ELEMENT) 6877 { 6878 ref = ref->next; 6879 break; 6880 } 6881 6882 /* Calculate the offset for each subsequent subreference. */ 6883 for (; ref; ref = ref->next) 6884 { 6885 switch (ref->type) 6886 { 6887 case REF_COMPONENT: 6888 field = ref->u.c.component->backend_decl; 6889 gcc_assert (field && TREE_CODE (field) == FIELD_DECL); 6890 tmp = fold_build3_loc (input_location, COMPONENT_REF, 6891 TREE_TYPE (field), 6892 tmp, field, NULL_TREE); 6893 break; 6894 6895 case REF_SUBSTRING: 6896 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); 6897 gfc_init_se (&start, NULL); 6898 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); 6899 gfc_add_block_to_block (block, &start.pre); 6900 tmp = gfc_build_array_ref (tmp, start.expr, NULL); 6901 break; 6902 6903 case REF_ARRAY: 6904 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE 6905 && ref->u.ar.type == AR_ELEMENT); 6906 6907 /* TODO - Add bounds checking. */ 6908 stride = gfc_index_one_node; 6909 index = gfc_index_zero_node; 6910 for (n = 0; n < ref->u.ar.dimen; n++) 6911 { 6912 tree itmp; 6913 tree jtmp; 6914 6915 /* Update the index. */ 6916 gfc_init_se (&start, NULL); 6917 gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type); 6918 itmp = gfc_evaluate_now (start.expr, block); 6919 gfc_init_se (&start, NULL); 6920 gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); 6921 jtmp = gfc_evaluate_now (start.expr, block); 6922 itmp = fold_build2_loc (input_location, MINUS_EXPR, 6923 gfc_array_index_type, itmp, jtmp); 6924 itmp = fold_build2_loc (input_location, MULT_EXPR, 6925 gfc_array_index_type, itmp, stride); 6926 index = fold_build2_loc (input_location, PLUS_EXPR, 6927 gfc_array_index_type, itmp, index); 6928 index = gfc_evaluate_now (index, block); 6929 6930 /* Update the stride. */ 6931 gfc_init_se (&start, NULL); 6932 gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); 6933 itmp = fold_build2_loc (input_location, MINUS_EXPR, 6934 gfc_array_index_type, start.expr, 6935 jtmp); 6936 itmp = fold_build2_loc (input_location, PLUS_EXPR, 6937 gfc_array_index_type, 6938 gfc_index_one_node, itmp); 6939 stride = fold_build2_loc (input_location, MULT_EXPR, 6940 gfc_array_index_type, stride, itmp); 6941 stride = gfc_evaluate_now (stride, block); 6942 } 6943 6944 /* Apply the index to obtain the array element. */ 6945 tmp = gfc_build_array_ref (tmp, index, NULL); 6946 break; 6947 6948 default: 6949 gcc_unreachable (); 6950 break; 6951 } 6952 } 6953 } 6954 6955 /* Set the target data pointer. */ 6956 offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); 6957 gfc_conv_descriptor_data_set (block, parm, offset); 6958 } 6959 6960 6961 /* gfc_conv_expr_descriptor needs the string length an expression 6962 so that the size of the temporary can be obtained. This is done 6963 by adding up the string lengths of all the elements in the 6964 expression. Function with non-constant expressions have their 6965 string lengths mapped onto the actual arguments using the 6966 interface mapping machinery in trans-expr.c. */ 6967 static void 6968 get_array_charlen (gfc_expr *expr, gfc_se *se) 6969 { 6970 gfc_interface_mapping mapping; 6971 gfc_formal_arglist *formal; 6972 gfc_actual_arglist *arg; 6973 gfc_se tse; 6974 gfc_expr *e; 6975 6976 if (expr->ts.u.cl->length 6977 && gfc_is_constant_expr (expr->ts.u.cl->length)) 6978 { 6979 if (!expr->ts.u.cl->backend_decl) 6980 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); 6981 return; 6982 } 6983 6984 switch (expr->expr_type) 6985 { 6986 case EXPR_ARRAY: 6987 6988 /* This is somewhat brutal. The expression for the first 6989 element of the array is evaluated and assigned to a 6990 new string length for the original expression. */ 6991 e = gfc_constructor_first (expr->value.constructor)->expr; 6992 6993 gfc_init_se (&tse, NULL); 6994 if (e->rank) 6995 gfc_conv_expr_descriptor (&tse, e); 6996 else 6997 gfc_conv_expr (&tse, e); 6998 6999 gfc_add_block_to_block (&se->pre, &tse.pre); 7000 gfc_add_block_to_block (&se->post, &tse.post); 7001 7002 if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl)) 7003 { 7004 expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 7005 expr->ts.u.cl->backend_decl = 7006 gfc_create_var (gfc_charlen_type_node, "sln"); 7007 } 7008 7009 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, 7010 tse.string_length); 7011 7012 return; 7013 7014 case EXPR_OP: 7015 get_array_charlen (expr->value.op.op1, se); 7016 7017 /* For parentheses the expression ts.u.cl is identical. */ 7018 if (expr->value.op.op == INTRINSIC_PARENTHESES) 7019 return; 7020 7021 expr->ts.u.cl->backend_decl = 7022 gfc_create_var (gfc_charlen_type_node, "sln"); 7023 7024 if (expr->value.op.op2) 7025 { 7026 get_array_charlen (expr->value.op.op2, se); 7027 7028 gcc_assert (expr->value.op.op == INTRINSIC_CONCAT); 7029 7030 /* Add the string lengths and assign them to the expression 7031 string length backend declaration. */ 7032 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, 7033 fold_build2_loc (input_location, PLUS_EXPR, 7034 gfc_charlen_type_node, 7035 expr->value.op.op1->ts.u.cl->backend_decl, 7036 expr->value.op.op2->ts.u.cl->backend_decl)); 7037 } 7038 else 7039 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, 7040 expr->value.op.op1->ts.u.cl->backend_decl); 7041 break; 7042 7043 case EXPR_FUNCTION: 7044 if (expr->value.function.esym == NULL 7045 || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) 7046 { 7047 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); 7048 break; 7049 } 7050 7051 /* Map expressions involving the dummy arguments onto the actual 7052 argument expressions. */ 7053 gfc_init_interface_mapping (&mapping); 7054 formal = gfc_sym_get_dummy_args (expr->symtree->n.sym); 7055 arg = expr->value.function.actual; 7056 7057 /* Set se = NULL in the calls to the interface mapping, to suppress any 7058 backend stuff. */ 7059 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) 7060 { 7061 if (!arg->expr) 7062 continue; 7063 if (formal->sym) 7064 gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); 7065 } 7066 7067 gfc_init_se (&tse, NULL); 7068 7069 /* Build the expression for the character length and convert it. */ 7070 gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); 7071 7072 gfc_add_block_to_block (&se->pre, &tse.pre); 7073 gfc_add_block_to_block (&se->post, &tse.post); 7074 tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); 7075 tse.expr = fold_build2_loc (input_location, MAX_EXPR, 7076 TREE_TYPE (tse.expr), tse.expr, 7077 build_zero_cst (TREE_TYPE (tse.expr))); 7078 expr->ts.u.cl->backend_decl = tse.expr; 7079 gfc_free_interface_mapping (&mapping); 7080 break; 7081 7082 default: 7083 gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); 7084 break; 7085 } 7086 } 7087 7088 7089 /* Helper function to check dimensions. */ 7090 static bool 7091 transposed_dims (gfc_ss *ss) 7092 { 7093 int n; 7094 7095 for (n = 0; n < ss->dimen; n++) 7096 if (ss->dim[n] != n) 7097 return true; 7098 return false; 7099 } 7100 7101 7102 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an 7103 AR_FULL, suitable for the scalarizer. */ 7104 7105 static gfc_ss * 7106 walk_coarray (gfc_expr *e) 7107 { 7108 gfc_ss *ss; 7109 7110 gcc_assert (gfc_get_corank (e) > 0); 7111 7112 ss = gfc_walk_expr (e); 7113 7114 /* Fix scalar coarray. */ 7115 if (ss == gfc_ss_terminator) 7116 { 7117 gfc_ref *ref; 7118 7119 ref = e->ref; 7120 while (ref) 7121 { 7122 if (ref->type == REF_ARRAY 7123 && ref->u.ar.codimen > 0) 7124 break; 7125 7126 ref = ref->next; 7127 } 7128 7129 gcc_assert (ref != NULL); 7130 if (ref->u.ar.type == AR_ELEMENT) 7131 ref->u.ar.type = AR_SECTION; 7132 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); 7133 } 7134 7135 return ss; 7136 } 7137 7138 7139 /* Convert an array for passing as an actual argument. Expressions and 7140 vector subscripts are evaluated and stored in a temporary, which is then 7141 passed. For whole arrays the descriptor is passed. For array sections 7142 a modified copy of the descriptor is passed, but using the original data. 7143 7144 This function is also used for array pointer assignments, and there 7145 are three cases: 7146 7147 - se->want_pointer && !se->direct_byref 7148 EXPR is an actual argument. On exit, se->expr contains a 7149 pointer to the array descriptor. 7150 7151 - !se->want_pointer && !se->direct_byref 7152 EXPR is an actual argument to an intrinsic function or the 7153 left-hand side of a pointer assignment. On exit, se->expr 7154 contains the descriptor for EXPR. 7155 7156 - !se->want_pointer && se->direct_byref 7157 EXPR is the right-hand side of a pointer assignment and 7158 se->expr is the descriptor for the previously-evaluated 7159 left-hand side. The function creates an assignment from 7160 EXPR to se->expr. 7161 7162 7163 The se->force_tmp flag disables the non-copying descriptor optimization 7164 that is used for transpose. It may be used in cases where there is an 7165 alias between the transpose argument and another argument in the same 7166 function call. */ 7167 7168 void 7169 gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) 7170 { 7171 gfc_ss *ss; 7172 gfc_ss_type ss_type; 7173 gfc_ss_info *ss_info; 7174 gfc_loopinfo loop; 7175 gfc_array_info *info; 7176 int need_tmp; 7177 int n; 7178 tree tmp; 7179 tree desc; 7180 stmtblock_t block; 7181 tree start; 7182 tree offset; 7183 int full; 7184 bool subref_array_target = false; 7185 bool deferred_array_component = false; 7186 gfc_expr *arg, *ss_expr; 7187 7188 if (se->want_coarray) 7189 ss = walk_coarray (expr); 7190 else 7191 ss = gfc_walk_expr (expr); 7192 7193 gcc_assert (ss != NULL); 7194 gcc_assert (ss != gfc_ss_terminator); 7195 7196 ss_info = ss->info; 7197 ss_type = ss_info->type; 7198 ss_expr = ss_info->expr; 7199 7200 /* Special case: TRANSPOSE which needs no temporary. */ 7201 while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym 7202 && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL) 7203 { 7204 /* This is a call to transpose which has already been handled by the 7205 scalarizer, so that we just need to get its argument's descriptor. */ 7206 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); 7207 expr = expr->value.function.actual->expr; 7208 } 7209 7210 /* Special case things we know we can pass easily. */ 7211 switch (expr->expr_type) 7212 { 7213 case EXPR_VARIABLE: 7214 /* If we have a linear array section, we can pass it directly. 7215 Otherwise we need to copy it into a temporary. */ 7216 7217 gcc_assert (ss_type == GFC_SS_SECTION); 7218 gcc_assert (ss_expr == expr); 7219 info = &ss_info->data.array; 7220 7221 /* Get the descriptor for the array. */ 7222 gfc_conv_ss_descriptor (&se->pre, ss, 0); 7223 desc = info->descriptor; 7224 7225 /* The charlen backend decl for deferred character components cannot 7226 be used because it is fixed at zero. Instead, the hidden string 7227 length component is used. */ 7228 if (expr->ts.type == BT_CHARACTER 7229 && expr->ts.deferred 7230 && TREE_CODE (desc) == COMPONENT_REF) 7231 deferred_array_component = true; 7232 7233 subref_array_target = se->direct_byref && is_subref_array (expr); 7234 need_tmp = gfc_ref_needs_temporary_p (expr->ref) 7235 && !subref_array_target; 7236 7237 if (se->force_tmp) 7238 need_tmp = 1; 7239 else if (se->force_no_tmp) 7240 need_tmp = 0; 7241 7242 if (need_tmp) 7243 full = 0; 7244 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) 7245 { 7246 /* Create a new descriptor if the array doesn't have one. */ 7247 full = 0; 7248 } 7249 else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) 7250 full = 1; 7251 else if (se->direct_byref) 7252 full = 0; 7253 else 7254 full = gfc_full_array_ref_p (info->ref, NULL); 7255 7256 if (full && !transposed_dims (ss)) 7257 { 7258 if (se->direct_byref && !se->byref_noassign) 7259 { 7260 /* Copy the descriptor for pointer assignments. */ 7261 gfc_add_modify (&se->pre, se->expr, desc); 7262 7263 /* Add any offsets from subreferences. */ 7264 gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, 7265 subref_array_target, expr); 7266 7267 /* ....and set the span field. */ 7268 tmp = gfc_get_array_span (desc, expr); 7269 if (tmp != NULL_TREE && !integer_zerop (tmp)) 7270 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); 7271 } 7272 else if (se->want_pointer) 7273 { 7274 /* We pass full arrays directly. This means that pointers and 7275 allocatable arrays should also work. */ 7276 se->expr = gfc_build_addr_expr (NULL_TREE, desc); 7277 } 7278 else 7279 { 7280 se->expr = desc; 7281 } 7282 7283 if (expr->ts.type == BT_CHARACTER && !deferred_array_component) 7284 se->string_length = gfc_get_expr_charlen (expr); 7285 /* The ss_info string length is returned set to the value of the 7286 hidden string length component. */ 7287 else if (deferred_array_component) 7288 se->string_length = ss_info->string_length; 7289 7290 gfc_free_ss_chain (ss); 7291 return; 7292 } 7293 break; 7294 7295 case EXPR_FUNCTION: 7296 /* A transformational function return value will be a temporary 7297 array descriptor. We still need to go through the scalarizer 7298 to create the descriptor. Elemental functions are handled as 7299 arbitrary expressions, i.e. copy to a temporary. */ 7300 7301 if (se->direct_byref) 7302 { 7303 gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr); 7304 7305 /* For pointer assignments pass the descriptor directly. */ 7306 if (se->ss == NULL) 7307 se->ss = ss; 7308 else 7309 gcc_assert (se->ss == ss); 7310 7311 if (!is_pointer_array (se->expr)) 7312 { 7313 tmp = gfc_get_element_type (TREE_TYPE (se->expr)); 7314 tmp = fold_convert (gfc_array_index_type, 7315 size_in_bytes (tmp)); 7316 gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); 7317 } 7318 7319 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 7320 gfc_conv_expr (se, expr); 7321 7322 gfc_free_ss_chain (ss); 7323 return; 7324 } 7325 7326 if (ss_expr != expr || ss_type != GFC_SS_FUNCTION) 7327 { 7328 if (ss_expr != expr) 7329 /* Elemental function. */ 7330 gcc_assert ((expr->value.function.esym != NULL 7331 && expr->value.function.esym->attr.elemental) 7332 || (expr->value.function.isym != NULL 7333 && expr->value.function.isym->elemental) 7334 || gfc_inline_intrinsic_function_p (expr)); 7335 else 7336 gcc_assert (ss_type == GFC_SS_INTRINSIC); 7337 7338 need_tmp = 1; 7339 if (expr->ts.type == BT_CHARACTER 7340 && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) 7341 get_array_charlen (expr, se); 7342 7343 info = NULL; 7344 } 7345 else 7346 { 7347 /* Transformational function. */ 7348 info = &ss_info->data.array; 7349 need_tmp = 0; 7350 } 7351 break; 7352 7353 case EXPR_ARRAY: 7354 /* Constant array constructors don't need a temporary. */ 7355 if (ss_type == GFC_SS_CONSTRUCTOR 7356 && expr->ts.type != BT_CHARACTER 7357 && gfc_constant_array_constructor_p (expr->value.constructor)) 7358 { 7359 need_tmp = 0; 7360 info = &ss_info->data.array; 7361 } 7362 else 7363 { 7364 need_tmp = 1; 7365 info = NULL; 7366 } 7367 break; 7368 7369 default: 7370 /* Something complicated. Copy it into a temporary. */ 7371 need_tmp = 1; 7372 info = NULL; 7373 break; 7374 } 7375 7376 /* If we are creating a temporary, we don't need to bother about aliases 7377 anymore. */ 7378 if (need_tmp) 7379 se->force_tmp = 0; 7380 7381 gfc_init_loopinfo (&loop); 7382 7383 /* Associate the SS with the loop. */ 7384 gfc_add_ss_to_loop (&loop, ss); 7385 7386 /* Tell the scalarizer not to bother creating loop variables, etc. */ 7387 if (!need_tmp) 7388 loop.array_parameter = 1; 7389 else 7390 /* The right-hand side of a pointer assignment mustn't use a temporary. */ 7391 gcc_assert (!se->direct_byref); 7392 7393 /* Do we need bounds checking or not? */ 7394 ss->no_bounds_check = expr->no_bounds_check; 7395 7396 /* Setup the scalarizing loops and bounds. */ 7397 gfc_conv_ss_startstride (&loop); 7398 7399 if (need_tmp) 7400 { 7401 if (expr->ts.type == BT_CHARACTER 7402 && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY)) 7403 get_array_charlen (expr, se); 7404 7405 /* Tell the scalarizer to make a temporary. */ 7406 loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), 7407 ((expr->ts.type == BT_CHARACTER) 7408 ? expr->ts.u.cl->backend_decl 7409 : NULL), 7410 loop.dimen); 7411 7412 se->string_length = loop.temp_ss->info->string_length; 7413 gcc_assert (loop.temp_ss->dimen == loop.dimen); 7414 gfc_add_ss_to_loop (&loop, loop.temp_ss); 7415 } 7416 7417 gfc_conv_loop_setup (&loop, & expr->where); 7418 7419 if (need_tmp) 7420 { 7421 /* Copy into a temporary and pass that. We don't need to copy the data 7422 back because expressions and vector subscripts must be INTENT_IN. */ 7423 /* TODO: Optimize passing function return values. */ 7424 gfc_se lse; 7425 gfc_se rse; 7426 bool deep_copy; 7427 7428 /* Start the copying loops. */ 7429 gfc_mark_ss_chain_used (loop.temp_ss, 1); 7430 gfc_mark_ss_chain_used (ss, 1); 7431 gfc_start_scalarized_body (&loop, &block); 7432 7433 /* Copy each data element. */ 7434 gfc_init_se (&lse, NULL); 7435 gfc_copy_loopinfo_to_se (&lse, &loop); 7436 gfc_init_se (&rse, NULL); 7437 gfc_copy_loopinfo_to_se (&rse, &loop); 7438 7439 lse.ss = loop.temp_ss; 7440 rse.ss = ss; 7441 7442 gfc_conv_scalarized_array_ref (&lse, NULL); 7443 if (expr->ts.type == BT_CHARACTER) 7444 { 7445 gfc_conv_expr (&rse, expr); 7446 if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) 7447 rse.expr = build_fold_indirect_ref_loc (input_location, 7448 rse.expr); 7449 } 7450 else 7451 gfc_conv_expr_val (&rse, expr); 7452 7453 gfc_add_block_to_block (&block, &rse.pre); 7454 gfc_add_block_to_block (&block, &lse.pre); 7455 7456 lse.string_length = rse.string_length; 7457 7458 deep_copy = !se->data_not_needed 7459 && (expr->expr_type == EXPR_VARIABLE 7460 || expr->expr_type == EXPR_ARRAY); 7461 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, 7462 deep_copy, false); 7463 gfc_add_expr_to_block (&block, tmp); 7464 7465 /* Finish the copying loops. */ 7466 gfc_trans_scalarizing_loops (&loop, &block); 7467 7468 desc = loop.temp_ss->info->data.array.descriptor; 7469 } 7470 else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) 7471 { 7472 desc = info->descriptor; 7473 se->string_length = ss_info->string_length; 7474 } 7475 else 7476 { 7477 /* We pass sections without copying to a temporary. Make a new 7478 descriptor and point it at the section we want. The loop variable 7479 limits will be the limits of the section. 7480 A function may decide to repack the array to speed up access, but 7481 we're not bothered about that here. */ 7482 int dim, ndim, codim; 7483 tree parm; 7484 tree parmtype; 7485 tree stride; 7486 tree from; 7487 tree to; 7488 tree base; 7489 bool onebased = false, rank_remap; 7490 7491 ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; 7492 rank_remap = ss->dimen < ndim; 7493 7494 if (se->want_coarray) 7495 { 7496 gfc_array_ref *ar = &info->ref->u.ar; 7497 7498 codim = gfc_get_corank (expr); 7499 for (n = 0; n < codim - 1; n++) 7500 { 7501 /* Make sure we are not lost somehow. */ 7502 gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); 7503 7504 /* Make sure the call to gfc_conv_section_startstride won't 7505 generate unnecessary code to calculate stride. */ 7506 gcc_assert (ar->stride[n + ndim] == NULL); 7507 7508 gfc_conv_section_startstride (&loop.pre, ss, n + ndim); 7509 loop.from[n + loop.dimen] = info->start[n + ndim]; 7510 loop.to[n + loop.dimen] = info->end[n + ndim]; 7511 } 7512 7513 gcc_assert (n == codim - 1); 7514 evaluate_bound (&loop.pre, info->start, ar->start, 7515 info->descriptor, n + ndim, true, 7516 ar->as->type == AS_DEFERRED); 7517 loop.from[n + loop.dimen] = info->start[n + ndim]; 7518 } 7519 else 7520 codim = 0; 7521 7522 /* Set the string_length for a character array. */ 7523 if (expr->ts.type == BT_CHARACTER) 7524 { 7525 se->string_length = gfc_get_expr_charlen (expr); 7526 if (VAR_P (se->string_length) 7527 && expr->ts.u.cl->backend_decl == se->string_length) 7528 tmp = ss_info->string_length; 7529 else 7530 tmp = se->string_length; 7531 7532 if (expr->ts.deferred) 7533 gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); 7534 } 7535 7536 /* If we have an array section or are assigning make sure that 7537 the lower bound is 1. References to the full 7538 array should otherwise keep the original bounds. */ 7539 if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer) 7540 for (dim = 0; dim < loop.dimen; dim++) 7541 if (!integer_onep (loop.from[dim])) 7542 { 7543 tmp = fold_build2_loc (input_location, MINUS_EXPR, 7544 gfc_array_index_type, gfc_index_one_node, 7545 loop.from[dim]); 7546 loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR, 7547 gfc_array_index_type, 7548 loop.to[dim], tmp); 7549 loop.from[dim] = gfc_index_one_node; 7550 } 7551 7552 desc = info->descriptor; 7553 if (se->direct_byref && !se->byref_noassign) 7554 { 7555 /* For pointer assignments we fill in the destination. */ 7556 parm = se->expr; 7557 parmtype = TREE_TYPE (parm); 7558 } 7559 else 7560 { 7561 /* Otherwise make a new one. */ 7562 if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) 7563 parmtype = gfc_typenode_for_spec (&expr->ts); 7564 else 7565 parmtype = gfc_get_element_type (TREE_TYPE (desc)); 7566 7567 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, 7568 loop.from, loop.to, 0, 7569 GFC_ARRAY_UNKNOWN, false); 7570 parm = gfc_create_var (parmtype, "parm"); 7571 7572 /* When expression is a class object, then add the class' handle to 7573 the parm_decl. */ 7574 if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE) 7575 { 7576 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); 7577 gfc_se classse; 7578 7579 /* class_expr can be NULL, when no _class ref is in expr. 7580 We must not fix this here with a gfc_fix_class_ref (). */ 7581 if (class_expr) 7582 { 7583 gfc_init_se (&classse, NULL); 7584 gfc_conv_expr (&classse, class_expr); 7585 gfc_free_expr (class_expr); 7586 7587 gcc_assert (classse.pre.head == NULL_TREE 7588 && classse.post.head == NULL_TREE); 7589 gfc_allocate_lang_decl (parm); 7590 GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr; 7591 } 7592 } 7593 } 7594 7595 /* Set the span field. */ 7596 if (expr->ts.type == BT_CHARACTER && ss_info->string_length) 7597 tmp = ss_info->string_length; 7598 else 7599 tmp = gfc_get_array_span (desc, expr); 7600 if (tmp != NULL_TREE) 7601 gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); 7602 7603 offset = gfc_index_zero_node; 7604 7605 /* The following can be somewhat confusing. We have two 7606 descriptors, a new one and the original array. 7607 {parm, parmtype, dim} refer to the new one. 7608 {desc, type, n, loop} refer to the original, which maybe 7609 a descriptorless array. 7610 The bounds of the scalarization are the bounds of the section. 7611 We don't have to worry about numeric overflows when calculating 7612 the offsets because all elements are within the array data. */ 7613 7614 /* Set the dtype. */ 7615 tmp = gfc_conv_descriptor_dtype (parm); 7616 gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); 7617 7618 /* Set offset for assignments to pointer only to zero if it is not 7619 the full array. */ 7620 if ((se->direct_byref || se->use_offset) 7621 && ((info->ref && info->ref->u.ar.type != AR_FULL) 7622 || (expr->expr_type == EXPR_ARRAY && se->use_offset))) 7623 base = gfc_index_zero_node; 7624 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) 7625 base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre); 7626 else 7627 base = NULL_TREE; 7628 7629 for (n = 0; n < ndim; n++) 7630 { 7631 stride = gfc_conv_array_stride (desc, n); 7632 7633 /* Work out the offset. */ 7634 if (info->ref 7635 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) 7636 { 7637 gcc_assert (info->subscript[n] 7638 && info->subscript[n]->info->type == GFC_SS_SCALAR); 7639 start = info->subscript[n]->info->data.scalar.value; 7640 } 7641 else 7642 { 7643 /* Evaluate and remember the start of the section. */ 7644 start = info->start[n]; 7645 stride = gfc_evaluate_now (stride, &loop.pre); 7646 } 7647 7648 tmp = gfc_conv_array_lbound (desc, n); 7649 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), 7650 start, tmp); 7651 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), 7652 tmp, stride); 7653 offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), 7654 offset, tmp); 7655 7656 if (info->ref 7657 && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) 7658 { 7659 /* For elemental dimensions, we only need the offset. */ 7660 continue; 7661 } 7662 7663 /* Vector subscripts need copying and are handled elsewhere. */ 7664 if (info->ref) 7665 gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); 7666 7667 /* look for the corresponding scalarizer dimension: dim. */ 7668 for (dim = 0; dim < ndim; dim++) 7669 if (ss->dim[dim] == n) 7670 break; 7671 7672 /* loop exited early: the DIM being looked for has been found. */ 7673 gcc_assert (dim < ndim); 7674 7675 /* Set the new lower bound. */ 7676 from = loop.from[dim]; 7677 to = loop.to[dim]; 7678 7679 onebased = integer_onep (from); 7680 gfc_conv_descriptor_lbound_set (&loop.pre, parm, 7681 gfc_rank_cst[dim], from); 7682 7683 /* Set the new upper bound. */ 7684 gfc_conv_descriptor_ubound_set (&loop.pre, parm, 7685 gfc_rank_cst[dim], to); 7686 7687 /* Multiply the stride by the section stride to get the 7688 total stride. */ 7689 stride = fold_build2_loc (input_location, MULT_EXPR, 7690 gfc_array_index_type, 7691 stride, info->stride[n]); 7692 7693 if ((se->direct_byref || se->use_offset) 7694 && ((info->ref && info->ref->u.ar.type != AR_FULL) 7695 || (expr->expr_type == EXPR_ARRAY && se->use_offset))) 7696 { 7697 base = fold_build2_loc (input_location, MINUS_EXPR, 7698 TREE_TYPE (base), base, stride); 7699 } 7700 else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset) 7701 { 7702 bool toonebased; 7703 tmp = gfc_conv_array_lbound (desc, n); 7704 toonebased = integer_onep (tmp); 7705 // lb(arr) - from (- start + 1) 7706 tmp = fold_build2_loc (input_location, MINUS_EXPR, 7707 TREE_TYPE (base), tmp, from); 7708 if (onebased && toonebased) 7709 { 7710 tmp = fold_build2_loc (input_location, MINUS_EXPR, 7711 TREE_TYPE (base), tmp, start); 7712 tmp = fold_build2_loc (input_location, PLUS_EXPR, 7713 TREE_TYPE (base), tmp, 7714 gfc_index_one_node); 7715 } 7716 tmp = fold_build2_loc (input_location, MULT_EXPR, 7717 TREE_TYPE (base), tmp, 7718 gfc_conv_array_stride (desc, n)); 7719 base = fold_build2_loc (input_location, PLUS_EXPR, 7720 TREE_TYPE (base), tmp, base); 7721 } 7722 7723 /* Store the new stride. */ 7724 gfc_conv_descriptor_stride_set (&loop.pre, parm, 7725 gfc_rank_cst[dim], stride); 7726 } 7727 7728 for (n = loop.dimen; n < loop.dimen + codim; n++) 7729 { 7730 from = loop.from[n]; 7731 to = loop.to[n]; 7732 gfc_conv_descriptor_lbound_set (&loop.pre, parm, 7733 gfc_rank_cst[n], from); 7734 if (n < loop.dimen + codim - 1) 7735 gfc_conv_descriptor_ubound_set (&loop.pre, parm, 7736 gfc_rank_cst[n], to); 7737 } 7738 7739 if (se->data_not_needed) 7740 gfc_conv_descriptor_data_set (&loop.pre, parm, 7741 gfc_index_zero_node); 7742 else 7743 /* Point the data pointer at the 1st element in the section. */ 7744 gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, 7745 subref_array_target, expr); 7746 7747 /* Force the offset to be -1, when the lower bound of the highest 7748 dimension is one and the symbol is present and is not a 7749 pointer/allocatable or associated. */ 7750 if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) 7751 && !se->data_not_needed) 7752 || (se->use_offset && base != NULL_TREE)) 7753 { 7754 /* Set the offset depending on base. */ 7755 tmp = rank_remap && !se->direct_byref ? 7756 fold_build2_loc (input_location, PLUS_EXPR, 7757 gfc_array_index_type, base, 7758 offset) 7759 : base; 7760 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); 7761 } 7762 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) 7763 && !se->data_not_needed 7764 && (!rank_remap || se->use_offset)) 7765 { 7766 gfc_conv_descriptor_offset_set (&loop.pre, parm, 7767 gfc_conv_descriptor_offset_get (desc)); 7768 } 7769 else if (onebased && (!rank_remap || se->use_offset) 7770 && expr->symtree 7771 && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS 7772 && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) 7773 && !expr->symtree->n.sym->attr.allocatable 7774 && !expr->symtree->n.sym->attr.pointer 7775 && !expr->symtree->n.sym->attr.host_assoc 7776 && !expr->symtree->n.sym->attr.use_assoc) 7777 { 7778 /* Set the offset to -1. */ 7779 mpz_t minus_one; 7780 mpz_init_set_si (minus_one, -1); 7781 tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind); 7782 gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); 7783 } 7784 else 7785 { 7786 /* Only the callee knows what the correct offset it, so just set 7787 it to zero here. */ 7788 gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); 7789 } 7790 desc = parm; 7791 } 7792 7793 /* For class arrays add the class tree into the saved descriptor to 7794 enable getting of _vptr and the like. */ 7795 if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) 7796 && IS_CLASS_ARRAY (expr->symtree->n.sym)) 7797 { 7798 gfc_allocate_lang_decl (desc); 7799 GFC_DECL_SAVED_DESCRIPTOR (desc) = 7800 DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ? 7801 GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) 7802 : expr->symtree->n.sym->backend_decl; 7803 } 7804 else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc) 7805 && IS_CLASS_ARRAY (expr)) 7806 { 7807 tree vtype; 7808 gfc_allocate_lang_decl (desc); 7809 tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class"); 7810 GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp; 7811 vtype = gfc_class_vptr_get (tmp); 7812 gfc_add_modify (&se->pre, vtype, 7813 gfc_build_addr_expr (TREE_TYPE (vtype), 7814 gfc_find_vtab (&expr->ts)->backend_decl)); 7815 } 7816 if (!se->direct_byref || se->byref_noassign) 7817 { 7818 /* Get a pointer to the new descriptor. */ 7819 if (se->want_pointer) 7820 se->expr = gfc_build_addr_expr (NULL_TREE, desc); 7821 else 7822 se->expr = desc; 7823 } 7824 7825 gfc_add_block_to_block (&se->pre, &loop.pre); 7826 gfc_add_block_to_block (&se->post, &loop.post); 7827 7828 /* Cleanup the scalarizer. */ 7829 gfc_cleanup_loop (&loop); 7830 } 7831 7832 /* Helper function for gfc_conv_array_parameter if array size needs to be 7833 computed. */ 7834 7835 static void 7836 array_parameter_size (tree desc, gfc_expr *expr, tree *size) 7837 { 7838 tree elem; 7839 if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) 7840 *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); 7841 else if (expr->rank > 1) 7842 *size = build_call_expr_loc (input_location, 7843 gfor_fndecl_size0, 1, 7844 gfc_build_addr_expr (NULL, desc)); 7845 else 7846 { 7847 tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node); 7848 tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node); 7849 7850 *size = fold_build2_loc (input_location, MINUS_EXPR, 7851 gfc_array_index_type, ubound, lbound); 7852 *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 7853 *size, gfc_index_one_node); 7854 *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, 7855 *size, gfc_index_zero_node); 7856 } 7857 elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); 7858 *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 7859 *size, fold_convert (gfc_array_index_type, elem)); 7860 } 7861 7862 /* Convert an array for passing as an actual parameter. */ 7863 7864 void 7865 gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, 7866 const gfc_symbol *fsym, const char *proc_name, 7867 tree *size) 7868 { 7869 tree ptr; 7870 tree desc; 7871 tree tmp = NULL_TREE; 7872 tree stmt; 7873 tree parent = DECL_CONTEXT (current_function_decl); 7874 bool full_array_var; 7875 bool this_array_result; 7876 bool contiguous; 7877 bool no_pack; 7878 bool array_constructor; 7879 bool good_allocatable; 7880 bool ultimate_ptr_comp; 7881 bool ultimate_alloc_comp; 7882 gfc_symbol *sym; 7883 stmtblock_t block; 7884 gfc_ref *ref; 7885 7886 ultimate_ptr_comp = false; 7887 ultimate_alloc_comp = false; 7888 7889 for (ref = expr->ref; ref; ref = ref->next) 7890 { 7891 if (ref->next == NULL) 7892 break; 7893 7894 if (ref->type == REF_COMPONENT) 7895 { 7896 ultimate_ptr_comp = ref->u.c.component->attr.pointer; 7897 ultimate_alloc_comp = ref->u.c.component->attr.allocatable; 7898 } 7899 } 7900 7901 full_array_var = false; 7902 contiguous = false; 7903 7904 if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) 7905 full_array_var = gfc_full_array_ref_p (ref, &contiguous); 7906 7907 sym = full_array_var ? expr->symtree->n.sym : NULL; 7908 7909 /* The symbol should have an array specification. */ 7910 gcc_assert (!sym || sym->as || ref->u.ar.as); 7911 7912 if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) 7913 { 7914 get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); 7915 expr->ts.u.cl->backend_decl = tmp; 7916 se->string_length = tmp; 7917 } 7918 7919 /* Is this the result of the enclosing procedure? */ 7920 this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); 7921 if (this_array_result 7922 && (sym->backend_decl != current_function_decl) 7923 && (sym->backend_decl != parent)) 7924 this_array_result = false; 7925 7926 /* Passing address of the array if it is not pointer or assumed-shape. */ 7927 if (full_array_var && g77 && !this_array_result 7928 && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) 7929 { 7930 tmp = gfc_get_symbol_decl (sym); 7931 7932 if (sym->ts.type == BT_CHARACTER) 7933 se->string_length = sym->ts.u.cl->backend_decl; 7934 7935 if (!sym->attr.pointer 7936 && sym->as 7937 && sym->as->type != AS_ASSUMED_SHAPE 7938 && sym->as->type != AS_DEFERRED 7939 && sym->as->type != AS_ASSUMED_RANK 7940 && !sym->attr.allocatable) 7941 { 7942 /* Some variables are declared directly, others are declared as 7943 pointers and allocated on the heap. */ 7944 if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp))) 7945 se->expr = tmp; 7946 else 7947 se->expr = gfc_build_addr_expr (NULL_TREE, tmp); 7948 if (size) 7949 array_parameter_size (tmp, expr, size); 7950 return; 7951 } 7952 7953 if (sym->attr.allocatable) 7954 { 7955 if (sym->attr.dummy || sym->attr.result) 7956 { 7957 gfc_conv_expr_descriptor (se, expr); 7958 tmp = se->expr; 7959 } 7960 if (size) 7961 array_parameter_size (tmp, expr, size); 7962 se->expr = gfc_conv_array_data (tmp); 7963 return; 7964 } 7965 } 7966 7967 /* A convenient reduction in scope. */ 7968 contiguous = g77 && !this_array_result && contiguous; 7969 7970 /* There is no need to pack and unpack the array, if it is contiguous 7971 and not a deferred- or assumed-shape array, or if it is simply 7972 contiguous. */ 7973 no_pack = ((sym && sym->as 7974 && !sym->attr.pointer 7975 && sym->as->type != AS_DEFERRED 7976 && sym->as->type != AS_ASSUMED_RANK 7977 && sym->as->type != AS_ASSUMED_SHAPE) 7978 || 7979 (ref && ref->u.ar.as 7980 && ref->u.ar.as->type != AS_DEFERRED 7981 && ref->u.ar.as->type != AS_ASSUMED_RANK 7982 && ref->u.ar.as->type != AS_ASSUMED_SHAPE) 7983 || 7984 gfc_is_simply_contiguous (expr, false, true)); 7985 7986 no_pack = contiguous && no_pack; 7987 7988 /* If we have an EXPR_OP or a function returning an explicit-shaped 7989 or allocatable array, an array temporary will be generated which 7990 does not need to be packed / unpacked if passed to an 7991 explicit-shape dummy array. */ 7992 7993 if (g77) 7994 { 7995 if (expr->expr_type == EXPR_OP) 7996 no_pack = 1; 7997 else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym) 7998 { 7999 gfc_symbol *result = expr->value.function.esym->result; 8000 if (result->attr.dimension 8001 && (result->as->type == AS_EXPLICIT 8002 || result->attr.allocatable 8003 || result->attr.contiguous)) 8004 no_pack = 1; 8005 } 8006 } 8007 8008 /* Array constructors are always contiguous and do not need packing. */ 8009 array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; 8010 8011 /* Same is true of contiguous sections from allocatable variables. */ 8012 good_allocatable = contiguous 8013 && expr->symtree 8014 && expr->symtree->n.sym->attr.allocatable; 8015 8016 /* Or ultimate allocatable components. */ 8017 ultimate_alloc_comp = contiguous && ultimate_alloc_comp; 8018 8019 if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) 8020 { 8021 gfc_conv_expr_descriptor (se, expr); 8022 /* Deallocate the allocatable components of structures that are 8023 not variable. */ 8024 if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) 8025 && expr->ts.u.derived->attr.alloc_comp 8026 && expr->expr_type != EXPR_VARIABLE) 8027 { 8028 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank); 8029 8030 /* The components shall be deallocated before their containing entity. */ 8031 gfc_prepend_expr_to_block (&se->post, tmp); 8032 } 8033 if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) 8034 se->string_length = expr->ts.u.cl->backend_decl; 8035 if (size) 8036 array_parameter_size (se->expr, expr, size); 8037 se->expr = gfc_conv_array_data (se->expr); 8038 return; 8039 } 8040 8041 if (this_array_result) 8042 { 8043 /* Result of the enclosing function. */ 8044 gfc_conv_expr_descriptor (se, expr); 8045 if (size) 8046 array_parameter_size (se->expr, expr, size); 8047 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 8048 8049 if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE 8050 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) 8051 se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, 8052 se->expr)); 8053 8054 return; 8055 } 8056 else 8057 { 8058 /* Every other type of array. */ 8059 se->want_pointer = 1; 8060 gfc_conv_expr_descriptor (se, expr); 8061 8062 if (size) 8063 array_parameter_size (build_fold_indirect_ref_loc (input_location, 8064 se->expr), 8065 expr, size); 8066 } 8067 8068 /* Deallocate the allocatable components of structures that are 8069 not variable, for descriptorless arguments. 8070 Arguments with a descriptor are handled in gfc_conv_procedure_call. */ 8071 if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) 8072 && expr->ts.u.derived->attr.alloc_comp 8073 && expr->expr_type != EXPR_VARIABLE) 8074 { 8075 tmp = build_fold_indirect_ref_loc (input_location, se->expr); 8076 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); 8077 8078 /* The components shall be deallocated before their containing entity. */ 8079 gfc_prepend_expr_to_block (&se->post, tmp); 8080 } 8081 8082 if (g77 || (fsym && fsym->attr.contiguous 8083 && !gfc_is_simply_contiguous (expr, false, true))) 8084 { 8085 tree origptr = NULL_TREE; 8086 8087 desc = se->expr; 8088 8089 /* For contiguous arrays, save the original value of the descriptor. */ 8090 if (!g77) 8091 { 8092 origptr = gfc_create_var (pvoid_type_node, "origptr"); 8093 tmp = build_fold_indirect_ref_loc (input_location, desc); 8094 tmp = gfc_conv_array_data (tmp); 8095 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 8096 TREE_TYPE (origptr), origptr, 8097 fold_convert (TREE_TYPE (origptr), tmp)); 8098 gfc_add_expr_to_block (&se->pre, tmp); 8099 } 8100 8101 /* Repack the array. */ 8102 if (warn_array_temporaries) 8103 { 8104 if (fsym) 8105 gfc_warning (OPT_Warray_temporaries, 8106 "Creating array temporary at %L for argument %qs", 8107 &expr->where, fsym->name); 8108 else 8109 gfc_warning (OPT_Warray_temporaries, 8110 "Creating array temporary at %L", &expr->where); 8111 } 8112 8113 ptr = build_call_expr_loc (input_location, 8114 gfor_fndecl_in_pack, 1, desc); 8115 8116 if (fsym && fsym->attr.optional && sym && sym->attr.optional) 8117 { 8118 tmp = gfc_conv_expr_present (sym); 8119 ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), 8120 tmp, fold_convert (TREE_TYPE (se->expr), ptr), 8121 fold_convert (TREE_TYPE (se->expr), null_pointer_node)); 8122 } 8123 8124 ptr = gfc_evaluate_now (ptr, &se->pre); 8125 8126 /* Use the packed data for the actual argument, except for contiguous arrays, 8127 where the descriptor's data component is set. */ 8128 if (g77) 8129 se->expr = ptr; 8130 else 8131 { 8132 tmp = build_fold_indirect_ref_loc (input_location, desc); 8133 8134 gfc_ss * ss = gfc_walk_expr (expr); 8135 if (!transposed_dims (ss)) 8136 gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); 8137 else 8138 { 8139 tree old_field, new_field; 8140 8141 /* The original descriptor has transposed dims so we can't reuse 8142 it directly; we have to create a new one. */ 8143 tree old_desc = tmp; 8144 tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); 8145 8146 old_field = gfc_conv_descriptor_dtype (old_desc); 8147 new_field = gfc_conv_descriptor_dtype (new_desc); 8148 gfc_add_modify (&se->pre, new_field, old_field); 8149 8150 old_field = gfc_conv_descriptor_offset (old_desc); 8151 new_field = gfc_conv_descriptor_offset (new_desc); 8152 gfc_add_modify (&se->pre, new_field, old_field); 8153 8154 for (int i = 0; i < expr->rank; i++) 8155 { 8156 old_field = gfc_conv_descriptor_dimension (old_desc, 8157 gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]); 8158 new_field = gfc_conv_descriptor_dimension (new_desc, 8159 gfc_rank_cst[i]); 8160 gfc_add_modify (&se->pre, new_field, old_field); 8161 } 8162 8163 if (flag_coarray == GFC_FCOARRAY_LIB 8164 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc)) 8165 && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc)) 8166 == GFC_ARRAY_ALLOCATABLE) 8167 { 8168 old_field = gfc_conv_descriptor_token (old_desc); 8169 new_field = gfc_conv_descriptor_token (new_desc); 8170 gfc_add_modify (&se->pre, new_field, old_field); 8171 } 8172 8173 gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr); 8174 se->expr = gfc_build_addr_expr (NULL_TREE, new_desc); 8175 } 8176 gfc_free_ss (ss); 8177 } 8178 8179 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) 8180 { 8181 char * msg; 8182 8183 if (fsym && proc_name) 8184 msg = xasprintf ("An array temporary was created for argument " 8185 "'%s' of procedure '%s'", fsym->name, proc_name); 8186 else 8187 msg = xasprintf ("An array temporary was created"); 8188 8189 tmp = build_fold_indirect_ref_loc (input_location, 8190 desc); 8191 tmp = gfc_conv_array_data (tmp); 8192 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 8193 fold_convert (TREE_TYPE (tmp), ptr), tmp); 8194 8195 if (fsym && fsym->attr.optional && sym && sym->attr.optional) 8196 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 8197 logical_type_node, 8198 gfc_conv_expr_present (sym), tmp); 8199 8200 gfc_trans_runtime_check (false, true, tmp, &se->pre, 8201 &expr->where, msg); 8202 free (msg); 8203 } 8204 8205 gfc_start_block (&block); 8206 8207 /* Copy the data back. */ 8208 if (fsym == NULL || fsym->attr.intent != INTENT_IN) 8209 { 8210 tmp = build_call_expr_loc (input_location, 8211 gfor_fndecl_in_unpack, 2, desc, ptr); 8212 gfc_add_expr_to_block (&block, tmp); 8213 } 8214 8215 /* Free the temporary. */ 8216 tmp = gfc_call_free (ptr); 8217 gfc_add_expr_to_block (&block, tmp); 8218 8219 stmt = gfc_finish_block (&block); 8220 8221 gfc_init_block (&block); 8222 /* Only if it was repacked. This code needs to be executed before the 8223 loop cleanup code. */ 8224 tmp = build_fold_indirect_ref_loc (input_location, 8225 desc); 8226 tmp = gfc_conv_array_data (tmp); 8227 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 8228 fold_convert (TREE_TYPE (tmp), ptr), tmp); 8229 8230 if (fsym && fsym->attr.optional && sym && sym->attr.optional) 8231 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 8232 logical_type_node, 8233 gfc_conv_expr_present (sym), tmp); 8234 8235 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); 8236 8237 gfc_add_expr_to_block (&block, tmp); 8238 gfc_add_block_to_block (&block, &se->post); 8239 8240 gfc_init_block (&se->post); 8241 8242 /* Reset the descriptor pointer. */ 8243 if (!g77) 8244 { 8245 tmp = build_fold_indirect_ref_loc (input_location, desc); 8246 gfc_conv_descriptor_data_set (&se->post, tmp, origptr); 8247 } 8248 8249 gfc_add_block_to_block (&se->post, &block); 8250 } 8251 } 8252 8253 8254 /* This helper function calculates the size in words of a full array. */ 8255 8256 tree 8257 gfc_full_array_size (stmtblock_t *block, tree decl, int rank) 8258 { 8259 tree idx; 8260 tree nelems; 8261 tree tmp; 8262 idx = gfc_rank_cst[rank - 1]; 8263 nelems = gfc_conv_descriptor_ubound_get (decl, idx); 8264 tmp = gfc_conv_descriptor_lbound_get (decl, idx); 8265 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 8266 nelems, tmp); 8267 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 8268 tmp, gfc_index_one_node); 8269 tmp = gfc_evaluate_now (tmp, block); 8270 8271 nelems = gfc_conv_descriptor_stride_get (decl, idx); 8272 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 8273 nelems, tmp); 8274 return gfc_evaluate_now (tmp, block); 8275 } 8276 8277 8278 /* Allocate dest to the same size as src, and copy src -> dest. 8279 If no_malloc is set, only the copy is done. */ 8280 8281 static tree 8282 duplicate_allocatable (tree dest, tree src, tree type, int rank, 8283 bool no_malloc, bool no_memcpy, tree str_sz, 8284 tree add_when_allocated) 8285 { 8286 tree tmp; 8287 tree size; 8288 tree nelems; 8289 tree null_cond; 8290 tree null_data; 8291 stmtblock_t block; 8292 8293 /* If the source is null, set the destination to null. Then, 8294 allocate memory to the destination. */ 8295 gfc_init_block (&block); 8296 8297 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) 8298 { 8299 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); 8300 null_data = gfc_finish_block (&block); 8301 8302 gfc_init_block (&block); 8303 if (str_sz != NULL_TREE) 8304 size = str_sz; 8305 else 8306 size = TYPE_SIZE_UNIT (TREE_TYPE (type)); 8307 8308 if (!no_malloc) 8309 { 8310 tmp = gfc_call_malloc (&block, type, size); 8311 gfc_add_modify (&block, dest, fold_convert (type, tmp)); 8312 } 8313 8314 if (!no_memcpy) 8315 { 8316 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); 8317 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, 8318 fold_convert (size_type_node, size)); 8319 gfc_add_expr_to_block (&block, tmp); 8320 } 8321 } 8322 else 8323 { 8324 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); 8325 null_data = gfc_finish_block (&block); 8326 8327 gfc_init_block (&block); 8328 if (rank) 8329 nelems = gfc_full_array_size (&block, src, rank); 8330 else 8331 nelems = gfc_index_one_node; 8332 8333 if (str_sz != NULL_TREE) 8334 tmp = fold_convert (gfc_array_index_type, str_sz); 8335 else 8336 tmp = fold_convert (gfc_array_index_type, 8337 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 8338 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 8339 nelems, tmp); 8340 if (!no_malloc) 8341 { 8342 tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); 8343 tmp = gfc_call_malloc (&block, tmp, size); 8344 gfc_conv_descriptor_data_set (&block, dest, tmp); 8345 } 8346 8347 /* We know the temporary and the value will be the same length, 8348 so can use memcpy. */ 8349 if (!no_memcpy) 8350 { 8351 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); 8352 tmp = build_call_expr_loc (input_location, tmp, 3, 8353 gfc_conv_descriptor_data_get (dest), 8354 gfc_conv_descriptor_data_get (src), 8355 fold_convert (size_type_node, size)); 8356 gfc_add_expr_to_block (&block, tmp); 8357 } 8358 } 8359 8360 gfc_add_expr_to_block (&block, add_when_allocated); 8361 tmp = gfc_finish_block (&block); 8362 8363 /* Null the destination if the source is null; otherwise do 8364 the allocate and copy. */ 8365 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) 8366 null_cond = src; 8367 else 8368 null_cond = gfc_conv_descriptor_data_get (src); 8369 8370 null_cond = convert (pvoid_type_node, null_cond); 8371 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 8372 null_cond, null_pointer_node); 8373 return build3_v (COND_EXPR, null_cond, tmp, null_data); 8374 } 8375 8376 8377 /* Allocate dest to the same size as src, and copy data src -> dest. */ 8378 8379 tree 8380 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, 8381 tree add_when_allocated) 8382 { 8383 return duplicate_allocatable (dest, src, type, rank, false, false, 8384 NULL_TREE, add_when_allocated); 8385 } 8386 8387 8388 /* Copy data src -> dest. */ 8389 8390 tree 8391 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) 8392 { 8393 return duplicate_allocatable (dest, src, type, rank, true, false, 8394 NULL_TREE, NULL_TREE); 8395 } 8396 8397 /* Allocate dest to the same size as src, but don't copy anything. */ 8398 8399 tree 8400 gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) 8401 { 8402 return duplicate_allocatable (dest, src, type, rank, false, true, 8403 NULL_TREE, NULL_TREE); 8404 } 8405 8406 8407 static tree 8408 duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, 8409 tree type, int rank) 8410 { 8411 tree tmp; 8412 tree size; 8413 tree nelems; 8414 tree null_cond; 8415 tree null_data; 8416 stmtblock_t block, globalblock; 8417 8418 /* If the source is null, set the destination to null. Then, 8419 allocate memory to the destination. */ 8420 gfc_init_block (&block); 8421 gfc_init_block (&globalblock); 8422 8423 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) 8424 { 8425 gfc_se se; 8426 symbol_attribute attr; 8427 tree dummy_desc; 8428 8429 gfc_init_se (&se, NULL); 8430 gfc_clear_attr (&attr); 8431 attr.allocatable = 1; 8432 dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr); 8433 gfc_add_block_to_block (&globalblock, &se.pre); 8434 size = TYPE_SIZE_UNIT (TREE_TYPE (type)); 8435 8436 gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); 8437 gfc_allocate_using_caf_lib (&block, dummy_desc, size, 8438 gfc_build_addr_expr (NULL_TREE, dest_tok), 8439 NULL_TREE, NULL_TREE, NULL_TREE, 8440 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); 8441 null_data = gfc_finish_block (&block); 8442 8443 gfc_init_block (&block); 8444 8445 gfc_allocate_using_caf_lib (&block, dummy_desc, 8446 fold_convert (size_type_node, size), 8447 gfc_build_addr_expr (NULL_TREE, dest_tok), 8448 NULL_TREE, NULL_TREE, NULL_TREE, 8449 GFC_CAF_COARRAY_ALLOC); 8450 8451 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); 8452 tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, 8453 fold_convert (size_type_node, size)); 8454 gfc_add_expr_to_block (&block, tmp); 8455 } 8456 else 8457 { 8458 /* Set the rank or unitialized memory access may be reported. */ 8459 tmp = gfc_conv_descriptor_rank (dest); 8460 gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); 8461 8462 if (rank) 8463 nelems = gfc_full_array_size (&block, src, rank); 8464 else 8465 nelems = integer_one_node; 8466 8467 tmp = fold_convert (size_type_node, 8468 TYPE_SIZE_UNIT (gfc_get_element_type (type))); 8469 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 8470 fold_convert (size_type_node, nelems), tmp); 8471 8472 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); 8473 gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node, 8474 size), 8475 gfc_build_addr_expr (NULL_TREE, dest_tok), 8476 NULL_TREE, NULL_TREE, NULL_TREE, 8477 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); 8478 null_data = gfc_finish_block (&block); 8479 8480 gfc_init_block (&block); 8481 gfc_allocate_using_caf_lib (&block, dest, 8482 fold_convert (size_type_node, size), 8483 gfc_build_addr_expr (NULL_TREE, dest_tok), 8484 NULL_TREE, NULL_TREE, NULL_TREE, 8485 GFC_CAF_COARRAY_ALLOC); 8486 8487 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); 8488 tmp = build_call_expr_loc (input_location, tmp, 3, 8489 gfc_conv_descriptor_data_get (dest), 8490 gfc_conv_descriptor_data_get (src), 8491 fold_convert (size_type_node, size)); 8492 gfc_add_expr_to_block (&block, tmp); 8493 } 8494 8495 tmp = gfc_finish_block (&block); 8496 8497 /* Null the destination if the source is null; otherwise do 8498 the register and copy. */ 8499 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) 8500 null_cond = src; 8501 else 8502 null_cond = gfc_conv_descriptor_data_get (src); 8503 8504 null_cond = convert (pvoid_type_node, null_cond); 8505 null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 8506 null_cond, null_pointer_node); 8507 gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, 8508 null_data)); 8509 return gfc_finish_block (&globalblock); 8510 } 8511 8512 8513 /* Helper function to abstract whether coarray processing is enabled. */ 8514 8515 static bool 8516 caf_enabled (int caf_mode) 8517 { 8518 return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) 8519 == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY; 8520 } 8521 8522 8523 /* Helper function to abstract whether coarray processing is enabled 8524 and we are in a derived type coarray. */ 8525 8526 static bool 8527 caf_in_coarray (int caf_mode) 8528 { 8529 static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY 8530 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY; 8531 return (caf_mode & pat) == pat; 8532 } 8533 8534 8535 /* Helper function to abstract whether coarray is to deallocate only. */ 8536 8537 bool 8538 gfc_caf_is_dealloc_only (int caf_mode) 8539 { 8540 return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) 8541 == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY; 8542 } 8543 8544 8545 /* Recursively traverse an object of derived type, generating code to 8546 deallocate, nullify or copy allocatable components. This is the work horse 8547 function for the functions named in this enum. */ 8548 8549 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, 8550 COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, 8551 ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY}; 8552 8553 static gfc_actual_arglist *pdt_param_list; 8554 8555 static tree 8556 structure_alloc_comps (gfc_symbol * der_type, tree decl, 8557 tree dest, int rank, int purpose, int caf_mode) 8558 { 8559 gfc_component *c; 8560 gfc_loopinfo loop; 8561 stmtblock_t fnblock; 8562 stmtblock_t loopbody; 8563 stmtblock_t tmpblock; 8564 tree decl_type; 8565 tree tmp; 8566 tree comp; 8567 tree dcmp; 8568 tree nelems; 8569 tree index; 8570 tree var; 8571 tree cdecl; 8572 tree ctype; 8573 tree vref, dref; 8574 tree null_cond = NULL_TREE; 8575 tree add_when_allocated; 8576 tree dealloc_fndecl; 8577 tree caf_token; 8578 gfc_symbol *vtab; 8579 int caf_dereg_mode; 8580 symbol_attribute *attr; 8581 bool deallocate_called; 8582 8583 gfc_init_block (&fnblock); 8584 8585 decl_type = TREE_TYPE (decl); 8586 8587 if ((POINTER_TYPE_P (decl_type)) 8588 || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) 8589 { 8590 decl = build_fold_indirect_ref_loc (input_location, decl); 8591 /* Deref dest in sync with decl, but only when it is not NULL. */ 8592 if (dest) 8593 dest = build_fold_indirect_ref_loc (input_location, dest); 8594 8595 /* Update the decl_type because it got dereferenced. */ 8596 decl_type = TREE_TYPE (decl); 8597 } 8598 8599 /* If this is an array of derived types with allocatable components 8600 build a loop and recursively call this function. */ 8601 if (TREE_CODE (decl_type) == ARRAY_TYPE 8602 || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) 8603 { 8604 tmp = gfc_conv_array_data (decl); 8605 var = build_fold_indirect_ref_loc (input_location, tmp); 8606 8607 /* Get the number of elements - 1 and set the counter. */ 8608 if (GFC_DESCRIPTOR_TYPE_P (decl_type)) 8609 { 8610 /* Use the descriptor for an allocatable array. Since this 8611 is a full array reference, we only need the descriptor 8612 information from dimension = rank. */ 8613 tmp = gfc_full_array_size (&fnblock, decl, rank); 8614 tmp = fold_build2_loc (input_location, MINUS_EXPR, 8615 gfc_array_index_type, tmp, 8616 gfc_index_one_node); 8617 8618 null_cond = gfc_conv_descriptor_data_get (decl); 8619 null_cond = fold_build2_loc (input_location, NE_EXPR, 8620 logical_type_node, null_cond, 8621 build_int_cst (TREE_TYPE (null_cond), 0)); 8622 } 8623 else 8624 { 8625 /* Otherwise use the TYPE_DOMAIN information. */ 8626 tmp = array_type_nelts (decl_type); 8627 tmp = fold_convert (gfc_array_index_type, tmp); 8628 } 8629 8630 /* Remember that this is, in fact, the no. of elements - 1. */ 8631 nelems = gfc_evaluate_now (tmp, &fnblock); 8632 index = gfc_create_var (gfc_array_index_type, "S"); 8633 8634 /* Build the body of the loop. */ 8635 gfc_init_block (&loopbody); 8636 8637 vref = gfc_build_array_ref (var, index, NULL); 8638 8639 if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) 8640 && !caf_enabled (caf_mode)) 8641 { 8642 tmp = build_fold_indirect_ref_loc (input_location, 8643 gfc_conv_array_data (dest)); 8644 dref = gfc_build_array_ref (tmp, index, NULL); 8645 tmp = structure_alloc_comps (der_type, vref, dref, rank, 8646 COPY_ALLOC_COMP, 0); 8647 } 8648 else 8649 tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, 8650 caf_mode); 8651 8652 gfc_add_expr_to_block (&loopbody, tmp); 8653 8654 /* Build the loop and return. */ 8655 gfc_init_loopinfo (&loop); 8656 loop.dimen = 1; 8657 loop.from[0] = gfc_index_zero_node; 8658 loop.loopvar[0] = index; 8659 loop.to[0] = nelems; 8660 gfc_trans_scalarizing_loops (&loop, &loopbody); 8661 gfc_add_block_to_block (&fnblock, &loop.pre); 8662 8663 tmp = gfc_finish_block (&fnblock); 8664 /* When copying allocateable components, the above implements the 8665 deep copy. Nevertheless is a deep copy only allowed, when the current 8666 component is allocated, for which code will be generated in 8667 gfc_duplicate_allocatable (), where the deep copy code is just added 8668 into the if's body, by adding tmp (the deep copy code) as last 8669 argument to gfc_duplicate_allocatable (). */ 8670 if (purpose == COPY_ALLOC_COMP 8671 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) 8672 tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, 8673 tmp); 8674 else if (null_cond != NULL_TREE) 8675 tmp = build3_v (COND_EXPR, null_cond, tmp, 8676 build_empty_stmt (input_location)); 8677 8678 return tmp; 8679 } 8680 8681 if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) 8682 { 8683 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, 8684 DEALLOCATE_PDT_COMP, 0); 8685 gfc_add_expr_to_block (&fnblock, tmp); 8686 } 8687 else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) 8688 { 8689 tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, 8690 NULLIFY_ALLOC_COMP, 0); 8691 gfc_add_expr_to_block (&fnblock, tmp); 8692 } 8693 8694 /* Otherwise, act on the components or recursively call self to 8695 act on a chain of components. */ 8696 for (c = der_type->components; c; c = c->next) 8697 { 8698 bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED 8699 || c->ts.type == BT_CLASS) 8700 && c->ts.u.derived->attr.alloc_comp; 8701 bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) 8702 || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); 8703 8704 bool is_pdt_type = c->ts.type == BT_DERIVED 8705 && c->ts.u.derived->attr.pdt_type; 8706 8707 cdecl = c->backend_decl; 8708 ctype = TREE_TYPE (cdecl); 8709 8710 switch (purpose) 8711 { 8712 case DEALLOCATE_ALLOC_COMP: 8713 8714 gfc_init_block (&tmpblock); 8715 8716 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 8717 decl, cdecl, NULL_TREE); 8718 8719 /* Shortcut to get the attributes of the component. */ 8720 if (c->ts.type == BT_CLASS) 8721 { 8722 attr = &CLASS_DATA (c)->attr; 8723 if (attr->class_pointer) 8724 continue; 8725 } 8726 else 8727 { 8728 attr = &c->attr; 8729 if (attr->pointer) 8730 continue; 8731 } 8732 8733 if ((c->ts.type == BT_DERIVED && !c->attr.pointer) 8734 || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) 8735 /* Call the finalizer, which will free the memory and nullify the 8736 pointer of an array. */ 8737 deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, 8738 caf_enabled (caf_mode)) 8739 && attr->dimension; 8740 else 8741 deallocate_called = false; 8742 8743 /* Add the _class ref for classes. */ 8744 if (c->ts.type == BT_CLASS && attr->allocatable) 8745 comp = gfc_class_data_get (comp); 8746 8747 add_when_allocated = NULL_TREE; 8748 if (cmp_has_alloc_comps 8749 && !c->attr.pointer && !c->attr.proc_pointer 8750 && !same_type 8751 && !deallocate_called) 8752 { 8753 /* Add checked deallocation of the components. This code is 8754 obviously added because the finalizer is not trusted to free 8755 all memory. */ 8756 if (c->ts.type == BT_CLASS) 8757 { 8758 rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; 8759 add_when_allocated 8760 = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, 8761 comp, NULL_TREE, rank, purpose, 8762 caf_mode); 8763 } 8764 else 8765 { 8766 rank = c->as ? c->as->rank : 0; 8767 add_when_allocated = structure_alloc_comps (c->ts.u.derived, 8768 comp, NULL_TREE, 8769 rank, purpose, 8770 caf_mode); 8771 } 8772 } 8773 8774 if (attr->allocatable && !same_type 8775 && (!attr->codimension || caf_enabled (caf_mode))) 8776 { 8777 /* Handle all types of components besides components of the 8778 same_type as the current one, because those would create an 8779 endless loop. */ 8780 caf_dereg_mode 8781 = (caf_in_coarray (caf_mode) || attr->codimension) 8782 ? (gfc_caf_is_dealloc_only (caf_mode) 8783 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY 8784 : GFC_CAF_COARRAY_DEREGISTER) 8785 : GFC_CAF_COARRAY_NOCOARRAY; 8786 8787 caf_token = NULL_TREE; 8788 /* Coarray components are handled directly by 8789 deallocate_with_status. */ 8790 if (!attr->codimension 8791 && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) 8792 { 8793 if (c->caf_token) 8794 caf_token = fold_build3_loc (input_location, COMPONENT_REF, 8795 TREE_TYPE (c->caf_token), 8796 decl, c->caf_token, NULL_TREE); 8797 else if (attr->dimension && !attr->proc_pointer) 8798 caf_token = gfc_conv_descriptor_token (comp); 8799 } 8800 if (attr->dimension && !attr->codimension && !attr->proc_pointer) 8801 /* When this is an array but not in conjunction with a coarray 8802 then add the data-ref. For coarray'ed arrays the data-ref 8803 is added by deallocate_with_status. */ 8804 comp = gfc_conv_descriptor_data_get (comp); 8805 8806 tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, 8807 NULL_TREE, NULL_TREE, true, 8808 NULL, caf_dereg_mode, 8809 add_when_allocated, caf_token); 8810 8811 gfc_add_expr_to_block (&tmpblock, tmp); 8812 } 8813 else if (attr->allocatable && !attr->codimension 8814 && !deallocate_called) 8815 { 8816 /* Case of recursive allocatable derived types. */ 8817 tree is_allocated; 8818 tree ubound; 8819 tree cdesc; 8820 stmtblock_t dealloc_block; 8821 8822 gfc_init_block (&dealloc_block); 8823 if (add_when_allocated) 8824 gfc_add_expr_to_block (&dealloc_block, add_when_allocated); 8825 8826 /* Convert the component into a rank 1 descriptor type. */ 8827 if (attr->dimension) 8828 { 8829 tmp = gfc_get_element_type (TREE_TYPE (comp)); 8830 ubound = gfc_full_array_size (&dealloc_block, comp, 8831 c->ts.type == BT_CLASS 8832 ? CLASS_DATA (c)->as->rank 8833 : c->as->rank); 8834 } 8835 else 8836 { 8837 tmp = TREE_TYPE (comp); 8838 ubound = build_int_cst (gfc_array_index_type, 1); 8839 } 8840 8841 cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, 8842 &ubound, 1, 8843 GFC_ARRAY_ALLOCATABLE, false); 8844 8845 cdesc = gfc_create_var (cdesc, "cdesc"); 8846 DECL_ARTIFICIAL (cdesc) = 1; 8847 8848 gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), 8849 gfc_get_dtype_rank_type (1, tmp)); 8850 gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, 8851 gfc_index_zero_node, 8852 gfc_index_one_node); 8853 gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, 8854 gfc_index_zero_node, 8855 gfc_index_one_node); 8856 gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, 8857 gfc_index_zero_node, ubound); 8858 8859 if (attr->dimension) 8860 comp = gfc_conv_descriptor_data_get (comp); 8861 8862 gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); 8863 8864 /* Now call the deallocator. */ 8865 vtab = gfc_find_vtab (&c->ts); 8866 if (vtab->backend_decl == NULL) 8867 gfc_get_symbol_decl (vtab); 8868 tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); 8869 dealloc_fndecl = gfc_vptr_deallocate_get (tmp); 8870 dealloc_fndecl = build_fold_indirect_ref_loc (input_location, 8871 dealloc_fndecl); 8872 tmp = build_int_cst (TREE_TYPE (comp), 0); 8873 is_allocated = fold_build2_loc (input_location, NE_EXPR, 8874 logical_type_node, tmp, 8875 comp); 8876 cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); 8877 8878 tmp = build_call_expr_loc (input_location, 8879 dealloc_fndecl, 1, 8880 cdesc); 8881 gfc_add_expr_to_block (&dealloc_block, tmp); 8882 8883 tmp = gfc_finish_block (&dealloc_block); 8884 8885 tmp = fold_build3_loc (input_location, COND_EXPR, 8886 void_type_node, is_allocated, tmp, 8887 build_empty_stmt (input_location)); 8888 8889 gfc_add_expr_to_block (&tmpblock, tmp); 8890 } 8891 else if (add_when_allocated) 8892 gfc_add_expr_to_block (&tmpblock, add_when_allocated); 8893 8894 if (c->ts.type == BT_CLASS && attr->allocatable 8895 && (!attr->codimension || !caf_enabled (caf_mode))) 8896 { 8897 /* Finally, reset the vptr to the declared type vtable and, if 8898 necessary reset the _len field. 8899 8900 First recover the reference to the component and obtain 8901 the vptr. */ 8902 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 8903 decl, cdecl, NULL_TREE); 8904 tmp = gfc_class_vptr_get (comp); 8905 8906 if (UNLIMITED_POLY (c)) 8907 { 8908 /* Both vptr and _len field should be nulled. */ 8909 gfc_add_modify (&tmpblock, tmp, 8910 build_int_cst (TREE_TYPE (tmp), 0)); 8911 tmp = gfc_class_len_get (comp); 8912 gfc_add_modify (&tmpblock, tmp, 8913 build_int_cst (TREE_TYPE (tmp), 0)); 8914 } 8915 else 8916 { 8917 /* Build the vtable address and set the vptr with it. */ 8918 tree vtab; 8919 gfc_symbol *vtable; 8920 vtable = gfc_find_derived_vtab (c->ts.u.derived); 8921 vtab = vtable->backend_decl; 8922 if (vtab == NULL_TREE) 8923 vtab = gfc_get_symbol_decl (vtable); 8924 vtab = gfc_build_addr_expr (NULL, vtab); 8925 vtab = fold_convert (TREE_TYPE (tmp), vtab); 8926 gfc_add_modify (&tmpblock, tmp, vtab); 8927 } 8928 } 8929 8930 /* Now add the deallocation of this component. */ 8931 gfc_add_block_to_block (&fnblock, &tmpblock); 8932 break; 8933 8934 case NULLIFY_ALLOC_COMP: 8935 /* Nullify 8936 - allocatable components (regular or in class) 8937 - components that have allocatable components 8938 - pointer components when in a coarray. 8939 Skip everything else especially proc_pointers, which may come 8940 coupled with the regular pointer attribute. */ 8941 if (c->attr.proc_pointer 8942 || !(c->attr.allocatable || (c->ts.type == BT_CLASS 8943 && CLASS_DATA (c)->attr.allocatable) 8944 || (cmp_has_alloc_comps 8945 && ((c->ts.type == BT_DERIVED && !c->attr.pointer) 8946 || (c->ts.type == BT_CLASS 8947 && !CLASS_DATA (c)->attr.class_pointer))) 8948 || (caf_in_coarray (caf_mode) && c->attr.pointer))) 8949 continue; 8950 8951 /* Process class components first, because they always have the 8952 pointer-attribute set which would be caught wrong else. */ 8953 if (c->ts.type == BT_CLASS 8954 && (CLASS_DATA (c)->attr.allocatable 8955 || CLASS_DATA (c)->attr.class_pointer)) 8956 { 8957 /* Allocatable CLASS components. */ 8958 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 8959 decl, cdecl, NULL_TREE); 8960 8961 comp = gfc_class_data_get (comp); 8962 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) 8963 gfc_conv_descriptor_data_set (&fnblock, comp, 8964 null_pointer_node); 8965 else 8966 { 8967 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 8968 void_type_node, comp, 8969 build_int_cst (TREE_TYPE (comp), 0)); 8970 gfc_add_expr_to_block (&fnblock, tmp); 8971 } 8972 cmp_has_alloc_comps = false; 8973 } 8974 /* Coarrays need the component to be nulled before the api-call 8975 is made. */ 8976 else if (c->attr.pointer || c->attr.allocatable) 8977 { 8978 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 8979 decl, cdecl, NULL_TREE); 8980 if (c->attr.dimension || c->attr.codimension) 8981 gfc_conv_descriptor_data_set (&fnblock, comp, 8982 null_pointer_node); 8983 else 8984 gfc_add_modify (&fnblock, comp, 8985 build_int_cst (TREE_TYPE (comp), 0)); 8986 if (gfc_deferred_strlen (c, &comp)) 8987 { 8988 comp = fold_build3_loc (input_location, COMPONENT_REF, 8989 TREE_TYPE (comp), 8990 decl, comp, NULL_TREE); 8991 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 8992 TREE_TYPE (comp), comp, 8993 build_int_cst (TREE_TYPE (comp), 0)); 8994 gfc_add_expr_to_block (&fnblock, tmp); 8995 } 8996 cmp_has_alloc_comps = false; 8997 } 8998 8999 if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode)) 9000 { 9001 /* Register a component of a derived type coarray with the 9002 coarray library. Do not register ultimate component 9003 coarrays here. They are treated like regular coarrays and 9004 are either allocated on all images or on none. */ 9005 tree token; 9006 9007 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9008 decl, cdecl, NULL_TREE); 9009 if (c->attr.dimension) 9010 { 9011 /* Set the dtype, because caf_register needs it. */ 9012 gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), 9013 gfc_get_dtype (TREE_TYPE (comp))); 9014 tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9015 decl, cdecl, NULL_TREE); 9016 token = gfc_conv_descriptor_token (tmp); 9017 } 9018 else 9019 { 9020 gfc_se se; 9021 9022 gfc_init_se (&se, NULL); 9023 token = fold_build3_loc (input_location, COMPONENT_REF, 9024 pvoid_type_node, decl, c->caf_token, 9025 NULL_TREE); 9026 comp = gfc_conv_scalar_to_descriptor (&se, comp, 9027 c->ts.type == BT_CLASS 9028 ? CLASS_DATA (c)->attr 9029 : c->attr); 9030 gfc_add_block_to_block (&fnblock, &se.pre); 9031 } 9032 9033 gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node, 9034 gfc_build_addr_expr (NULL_TREE, 9035 token), 9036 NULL_TREE, NULL_TREE, NULL_TREE, 9037 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); 9038 } 9039 9040 if (cmp_has_alloc_comps) 9041 { 9042 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9043 decl, cdecl, NULL_TREE); 9044 rank = c->as ? c->as->rank : 0; 9045 tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, 9046 rank, purpose, caf_mode); 9047 gfc_add_expr_to_block (&fnblock, tmp); 9048 } 9049 break; 9050 9051 case REASSIGN_CAF_COMP: 9052 if (caf_enabled (caf_mode) 9053 && (c->attr.codimension 9054 || (c->ts.type == BT_CLASS 9055 && (CLASS_DATA (c)->attr.coarray_comp 9056 || caf_in_coarray (caf_mode))) 9057 || (c->ts.type == BT_DERIVED 9058 && (c->ts.u.derived->attr.coarray_comp 9059 || caf_in_coarray (caf_mode)))) 9060 && !same_type) 9061 { 9062 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9063 decl, cdecl, NULL_TREE); 9064 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9065 dest, cdecl, NULL_TREE); 9066 9067 if (c->attr.codimension) 9068 { 9069 if (c->ts.type == BT_CLASS) 9070 { 9071 comp = gfc_class_data_get (comp); 9072 dcmp = gfc_class_data_get (dcmp); 9073 } 9074 gfc_conv_descriptor_data_set (&fnblock, dcmp, 9075 gfc_conv_descriptor_data_get (comp)); 9076 } 9077 else 9078 { 9079 tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, 9080 rank, purpose, caf_mode 9081 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY); 9082 gfc_add_expr_to_block (&fnblock, tmp); 9083 } 9084 } 9085 break; 9086 9087 case COPY_ALLOC_COMP: 9088 if (c->attr.pointer || c->attr.proc_pointer) 9089 continue; 9090 9091 /* We need source and destination components. */ 9092 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, 9093 cdecl, NULL_TREE); 9094 dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, 9095 cdecl, NULL_TREE); 9096 dcmp = fold_convert (TREE_TYPE (comp), dcmp); 9097 9098 if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) 9099 { 9100 tree ftn_tree; 9101 tree size; 9102 tree dst_data; 9103 tree src_data; 9104 tree null_data; 9105 9106 dst_data = gfc_class_data_get (dcmp); 9107 src_data = gfc_class_data_get (comp); 9108 size = fold_convert (size_type_node, 9109 gfc_class_vtab_size_get (comp)); 9110 9111 if (CLASS_DATA (c)->attr.dimension) 9112 { 9113 nelems = gfc_conv_descriptor_size (src_data, 9114 CLASS_DATA (c)->as->rank); 9115 size = fold_build2_loc (input_location, MULT_EXPR, 9116 size_type_node, size, 9117 fold_convert (size_type_node, 9118 nelems)); 9119 } 9120 else 9121 nelems = build_int_cst (size_type_node, 1); 9122 9123 if (CLASS_DATA (c)->attr.dimension 9124 || CLASS_DATA (c)->attr.codimension) 9125 { 9126 src_data = gfc_conv_descriptor_data_get (src_data); 9127 dst_data = gfc_conv_descriptor_data_get (dst_data); 9128 } 9129 9130 gfc_init_block (&tmpblock); 9131 9132 gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), 9133 gfc_class_vptr_get (comp)); 9134 9135 /* Copy the unlimited '_len' field. If it is greater than zero 9136 (ie. a character(_len)), multiply it by size and use this 9137 for the malloc call. */ 9138 if (UNLIMITED_POLY (c)) 9139 { 9140 tree ctmp; 9141 gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), 9142 gfc_class_len_get (comp)); 9143 9144 size = gfc_evaluate_now (size, &tmpblock); 9145 tmp = gfc_class_len_get (comp); 9146 ctmp = fold_build2_loc (input_location, MULT_EXPR, 9147 size_type_node, size, 9148 fold_convert (size_type_node, tmp)); 9149 tmp = fold_build2_loc (input_location, GT_EXPR, 9150 logical_type_node, tmp, 9151 build_zero_cst (TREE_TYPE (tmp))); 9152 size = fold_build3_loc (input_location, COND_EXPR, 9153 size_type_node, tmp, ctmp, size); 9154 size = gfc_evaluate_now (size, &tmpblock); 9155 } 9156 9157 /* Coarray component have to have the same allocation status and 9158 shape/type-parameter/effective-type on the LHS and RHS of an 9159 intrinsic assignment. Hence, we did not deallocated them - and 9160 do not allocate them here. */ 9161 if (!CLASS_DATA (c)->attr.codimension) 9162 { 9163 ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC); 9164 tmp = build_call_expr_loc (input_location, ftn_tree, 1, size); 9165 gfc_add_modify (&tmpblock, dst_data, 9166 fold_convert (TREE_TYPE (dst_data), tmp)); 9167 } 9168 9169 tmp = gfc_copy_class_to_class (comp, dcmp, nelems, 9170 UNLIMITED_POLY (c)); 9171 gfc_add_expr_to_block (&tmpblock, tmp); 9172 tmp = gfc_finish_block (&tmpblock); 9173 9174 gfc_init_block (&tmpblock); 9175 gfc_add_modify (&tmpblock, dst_data, 9176 fold_convert (TREE_TYPE (dst_data), 9177 null_pointer_node)); 9178 null_data = gfc_finish_block (&tmpblock); 9179 9180 null_cond = fold_build2_loc (input_location, NE_EXPR, 9181 logical_type_node, src_data, 9182 null_pointer_node); 9183 9184 gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, 9185 tmp, null_data)); 9186 continue; 9187 } 9188 9189 /* To implement guarded deep copy, i.e., deep copy only allocatable 9190 components that are really allocated, the deep copy code has to 9191 be generated first and then added to the if-block in 9192 gfc_duplicate_allocatable (). */ 9193 if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type) 9194 { 9195 rank = c->as ? c->as->rank : 0; 9196 tmp = fold_convert (TREE_TYPE (dcmp), comp); 9197 gfc_add_modify (&fnblock, dcmp, tmp); 9198 add_when_allocated = structure_alloc_comps (c->ts.u.derived, 9199 comp, dcmp, 9200 rank, purpose, 9201 caf_mode); 9202 } 9203 else 9204 add_when_allocated = NULL_TREE; 9205 9206 if (gfc_deferred_strlen (c, &tmp)) 9207 { 9208 tree len, size; 9209 len = tmp; 9210 tmp = fold_build3_loc (input_location, COMPONENT_REF, 9211 TREE_TYPE (len), 9212 decl, len, NULL_TREE); 9213 len = fold_build3_loc (input_location, COMPONENT_REF, 9214 TREE_TYPE (len), 9215 dest, len, NULL_TREE); 9216 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 9217 TREE_TYPE (len), len, tmp); 9218 gfc_add_expr_to_block (&fnblock, tmp); 9219 size = size_of_string_in_bytes (c->ts.kind, len); 9220 /* This component cannot have allocatable components, 9221 therefore add_when_allocated of duplicate_allocatable () 9222 is always NULL. */ 9223 tmp = duplicate_allocatable (dcmp, comp, ctype, rank, 9224 false, false, size, NULL_TREE); 9225 gfc_add_expr_to_block (&fnblock, tmp); 9226 } 9227 else if (c->attr.pdt_array) 9228 { 9229 tmp = duplicate_allocatable (dcmp, comp, ctype, 9230 c->as ? c->as->rank : 0, 9231 false, false, NULL_TREE, NULL_TREE); 9232 gfc_add_expr_to_block (&fnblock, tmp); 9233 } 9234 else if ((c->attr.allocatable) 9235 && !c->attr.proc_pointer && !same_type 9236 && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension 9237 || caf_in_coarray (caf_mode))) 9238 { 9239 rank = c->as ? c->as->rank : 0; 9240 if (c->attr.codimension) 9241 tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); 9242 else if (flag_coarray == GFC_FCOARRAY_LIB 9243 && caf_in_coarray (caf_mode)) 9244 { 9245 tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp) 9246 : fold_build3_loc (input_location, 9247 COMPONENT_REF, 9248 pvoid_type_node, dest, 9249 c->caf_token, 9250 NULL_TREE); 9251 tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, 9252 ctype, rank); 9253 } 9254 else 9255 tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, 9256 add_when_allocated); 9257 gfc_add_expr_to_block (&fnblock, tmp); 9258 } 9259 else 9260 if (cmp_has_alloc_comps || is_pdt_type) 9261 gfc_add_expr_to_block (&fnblock, add_when_allocated); 9262 9263 break; 9264 9265 case ALLOCATE_PDT_COMP: 9266 9267 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9268 decl, cdecl, NULL_TREE); 9269 9270 /* Set the PDT KIND and LEN fields. */ 9271 if (c->attr.pdt_kind || c->attr.pdt_len) 9272 { 9273 gfc_se tse; 9274 gfc_expr *c_expr = NULL; 9275 gfc_actual_arglist *param = pdt_param_list; 9276 gfc_init_se (&tse, NULL); 9277 for (; param; param = param->next) 9278 if (param->name && !strcmp (c->name, param->name)) 9279 c_expr = param->expr; 9280 9281 if (!c_expr) 9282 c_expr = c->initializer; 9283 9284 if (c_expr) 9285 { 9286 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); 9287 gfc_add_modify (&fnblock, comp, tse.expr); 9288 } 9289 } 9290 9291 if (c->attr.pdt_string) 9292 { 9293 gfc_se tse; 9294 gfc_init_se (&tse, NULL); 9295 tree strlen = NULL_TREE; 9296 gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); 9297 /* Convert the parameterized string length to its value. The 9298 string length is stored in a hidden field in the same way as 9299 deferred string lengths. */ 9300 gfc_insert_parameter_exprs (e, pdt_param_list); 9301 if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE) 9302 { 9303 gfc_conv_expr_type (&tse, e, 9304 TREE_TYPE (strlen)); 9305 strlen = fold_build3_loc (input_location, COMPONENT_REF, 9306 TREE_TYPE (strlen), 9307 decl, strlen, NULL_TREE); 9308 gfc_add_modify (&fnblock, strlen, tse.expr); 9309 c->ts.u.cl->backend_decl = strlen; 9310 } 9311 gfc_free_expr (e); 9312 9313 /* Scalar parameterized strings can be allocated now. */ 9314 if (!c->as) 9315 { 9316 tmp = fold_convert (gfc_array_index_type, strlen); 9317 tmp = size_of_string_in_bytes (c->ts.kind, tmp); 9318 tmp = gfc_evaluate_now (tmp, &fnblock); 9319 tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp); 9320 gfc_add_modify (&fnblock, comp, tmp); 9321 } 9322 } 9323 9324 /* Allocate parameterized arrays of parameterized derived types. */ 9325 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) 9326 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9327 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) 9328 continue; 9329 9330 if (c->ts.type == BT_CLASS) 9331 comp = gfc_class_data_get (comp); 9332 9333 if (c->attr.pdt_array) 9334 { 9335 gfc_se tse; 9336 int i; 9337 tree size = gfc_index_one_node; 9338 tree offset = gfc_index_zero_node; 9339 tree lower, upper; 9340 gfc_expr *e; 9341 9342 /* This chunk takes the expressions for 'lower' and 'upper' 9343 in the arrayspec and substitutes in the expressions for 9344 the parameters from 'pdt_param_list'. The descriptor 9345 fields can then be filled from the values so obtained. */ 9346 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))); 9347 for (i = 0; i < c->as->rank; i++) 9348 { 9349 gfc_init_se (&tse, NULL); 9350 e = gfc_copy_expr (c->as->lower[i]); 9351 gfc_insert_parameter_exprs (e, pdt_param_list); 9352 gfc_conv_expr_type (&tse, e, gfc_array_index_type); 9353 gfc_free_expr (e); 9354 lower = tse.expr; 9355 gfc_conv_descriptor_lbound_set (&fnblock, comp, 9356 gfc_rank_cst[i], 9357 lower); 9358 e = gfc_copy_expr (c->as->upper[i]); 9359 gfc_insert_parameter_exprs (e, pdt_param_list); 9360 gfc_conv_expr_type (&tse, e, gfc_array_index_type); 9361 gfc_free_expr (e); 9362 upper = tse.expr; 9363 gfc_conv_descriptor_ubound_set (&fnblock, comp, 9364 gfc_rank_cst[i], 9365 upper); 9366 gfc_conv_descriptor_stride_set (&fnblock, comp, 9367 gfc_rank_cst[i], 9368 size); 9369 size = gfc_evaluate_now (size, &fnblock); 9370 offset = fold_build2_loc (input_location, 9371 MINUS_EXPR, 9372 gfc_array_index_type, 9373 offset, size); 9374 offset = gfc_evaluate_now (offset, &fnblock); 9375 tmp = fold_build2_loc (input_location, MINUS_EXPR, 9376 gfc_array_index_type, 9377 upper, lower); 9378 tmp = fold_build2_loc (input_location, PLUS_EXPR, 9379 gfc_array_index_type, 9380 tmp, gfc_index_one_node); 9381 size = fold_build2_loc (input_location, MULT_EXPR, 9382 gfc_array_index_type, size, tmp); 9383 } 9384 gfc_conv_descriptor_offset_set (&fnblock, comp, offset); 9385 if (c->ts.type == BT_CLASS) 9386 { 9387 tmp = gfc_get_vptr_from_expr (comp); 9388 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 9389 tmp = build_fold_indirect_ref_loc (input_location, tmp); 9390 tmp = gfc_vptr_size_get (tmp); 9391 } 9392 else 9393 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype)); 9394 tmp = fold_convert (gfc_array_index_type, tmp); 9395 size = fold_build2_loc (input_location, MULT_EXPR, 9396 gfc_array_index_type, size, tmp); 9397 size = gfc_evaluate_now (size, &fnblock); 9398 tmp = gfc_call_malloc (&fnblock, NULL, size); 9399 gfc_conv_descriptor_data_set (&fnblock, comp, tmp); 9400 tmp = gfc_conv_descriptor_dtype (comp); 9401 gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype)); 9402 9403 if (c->initializer && c->initializer->rank) 9404 { 9405 gfc_init_se (&tse, NULL); 9406 e = gfc_copy_expr (c->initializer); 9407 gfc_insert_parameter_exprs (e, pdt_param_list); 9408 gfc_conv_expr_descriptor (&tse, e); 9409 gfc_add_block_to_block (&fnblock, &tse.pre); 9410 gfc_free_expr (e); 9411 tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); 9412 tmp = build_call_expr_loc (input_location, tmp, 3, 9413 gfc_conv_descriptor_data_get (comp), 9414 gfc_conv_descriptor_data_get (tse.expr), 9415 fold_convert (size_type_node, size)); 9416 gfc_add_expr_to_block (&fnblock, tmp); 9417 gfc_add_block_to_block (&fnblock, &tse.post); 9418 } 9419 } 9420 9421 /* Recurse in to PDT components. */ 9422 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9423 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type 9424 && !(c->attr.pointer || c->attr.allocatable)) 9425 { 9426 bool is_deferred = false; 9427 gfc_actual_arglist *tail = c->param_list; 9428 9429 for (; tail; tail = tail->next) 9430 if (!tail->expr) 9431 is_deferred = true; 9432 9433 tail = is_deferred ? pdt_param_list : c->param_list; 9434 tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, 9435 c->as ? c->as->rank : 0, 9436 tail); 9437 gfc_add_expr_to_block (&fnblock, tmp); 9438 } 9439 9440 break; 9441 9442 case DEALLOCATE_PDT_COMP: 9443 /* Deallocate array or parameterized string length components 9444 of parameterized derived types. */ 9445 if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) 9446 && !c->attr.pdt_string 9447 && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9448 && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) 9449 continue; 9450 9451 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9452 decl, cdecl, NULL_TREE); 9453 if (c->ts.type == BT_CLASS) 9454 comp = gfc_class_data_get (comp); 9455 9456 /* Recurse in to PDT components. */ 9457 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9458 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type 9459 && (!c->attr.pointer && !c->attr.allocatable)) 9460 { 9461 tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, 9462 c->as ? c->as->rank : 0); 9463 gfc_add_expr_to_block (&fnblock, tmp); 9464 } 9465 9466 if (c->attr.pdt_array) 9467 { 9468 tmp = gfc_conv_descriptor_data_get (comp); 9469 null_cond = fold_build2_loc (input_location, NE_EXPR, 9470 logical_type_node, tmp, 9471 build_int_cst (TREE_TYPE (tmp), 0)); 9472 tmp = gfc_call_free (tmp); 9473 tmp = build3_v (COND_EXPR, null_cond, tmp, 9474 build_empty_stmt (input_location)); 9475 gfc_add_expr_to_block (&fnblock, tmp); 9476 gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); 9477 } 9478 else if (c->attr.pdt_string) 9479 { 9480 null_cond = fold_build2_loc (input_location, NE_EXPR, 9481 logical_type_node, comp, 9482 build_int_cst (TREE_TYPE (comp), 0)); 9483 tmp = gfc_call_free (comp); 9484 tmp = build3_v (COND_EXPR, null_cond, tmp, 9485 build_empty_stmt (input_location)); 9486 gfc_add_expr_to_block (&fnblock, tmp); 9487 tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); 9488 gfc_add_modify (&fnblock, comp, tmp); 9489 } 9490 9491 break; 9492 9493 case CHECK_PDT_DUMMY: 9494 9495 comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, 9496 decl, cdecl, NULL_TREE); 9497 if (c->ts.type == BT_CLASS) 9498 comp = gfc_class_data_get (comp); 9499 9500 /* Recurse in to PDT components. */ 9501 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9502 && c->ts.u.derived && c->ts.u.derived->attr.pdt_type) 9503 { 9504 tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, 9505 c->as ? c->as->rank : 0, 9506 pdt_param_list); 9507 gfc_add_expr_to_block (&fnblock, tmp); 9508 } 9509 9510 if (!c->attr.pdt_len) 9511 continue; 9512 else 9513 { 9514 gfc_se tse; 9515 gfc_expr *c_expr = NULL; 9516 gfc_actual_arglist *param = pdt_param_list; 9517 9518 gfc_init_se (&tse, NULL); 9519 for (; param; param = param->next) 9520 if (!strcmp (c->name, param->name) 9521 && param->spec_type == SPEC_EXPLICIT) 9522 c_expr = param->expr; 9523 9524 if (c_expr) 9525 { 9526 tree error, cond, cname; 9527 gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); 9528 cond = fold_build2_loc (input_location, NE_EXPR, 9529 logical_type_node, 9530 comp, tse.expr); 9531 cname = gfc_build_cstring_const (c->name); 9532 cname = gfc_build_addr_expr (pchar_type_node, cname); 9533 error = gfc_trans_runtime_error (true, NULL, 9534 "The value of the PDT LEN " 9535 "parameter '%s' does not " 9536 "agree with that in the " 9537 "dummy declaration", 9538 cname); 9539 tmp = fold_build3_loc (input_location, COND_EXPR, 9540 void_type_node, cond, error, 9541 build_empty_stmt (input_location)); 9542 gfc_add_expr_to_block (&fnblock, tmp); 9543 } 9544 } 9545 break; 9546 9547 default: 9548 gcc_unreachable (); 9549 break; 9550 } 9551 } 9552 9553 return gfc_finish_block (&fnblock); 9554 } 9555 9556 /* Recursively traverse an object of derived type, generating code to 9557 nullify allocatable components. */ 9558 9559 tree 9560 gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, 9561 int caf_mode) 9562 { 9563 return structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9564 NULLIFY_ALLOC_COMP, 9565 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode); 9566 } 9567 9568 9569 /* Recursively traverse an object of derived type, generating code to 9570 deallocate allocatable components. */ 9571 9572 tree 9573 gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, 9574 int caf_mode) 9575 { 9576 return structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9577 DEALLOCATE_ALLOC_COMP, 9578 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode); 9579 } 9580 9581 9582 /* Recursively traverse an object of derived type, generating code to 9583 deallocate allocatable components. But do not deallocate coarrays. 9584 To be used for intrinsic assignment, which may not change the allocation 9585 status of coarrays. */ 9586 9587 tree 9588 gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) 9589 { 9590 return structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9591 DEALLOCATE_ALLOC_COMP, 0); 9592 } 9593 9594 9595 tree 9596 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) 9597 { 9598 return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, 9599 GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY); 9600 } 9601 9602 9603 /* Recursively traverse an object of derived type, generating code to 9604 copy it and its allocatable components. */ 9605 9606 tree 9607 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, 9608 int caf_mode) 9609 { 9610 return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, 9611 caf_mode); 9612 } 9613 9614 9615 /* Recursively traverse an object of derived type, generating code to 9616 copy only its allocatable components. */ 9617 9618 tree 9619 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) 9620 { 9621 return structure_alloc_comps (der_type, decl, dest, rank, 9622 COPY_ONLY_ALLOC_COMP, 0); 9623 } 9624 9625 9626 /* Recursively traverse an object of paramterized derived type, generating 9627 code to allocate parameterized components. */ 9628 9629 tree 9630 gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, 9631 gfc_actual_arglist *param_list) 9632 { 9633 tree res; 9634 gfc_actual_arglist *old_param_list = pdt_param_list; 9635 pdt_param_list = param_list; 9636 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9637 ALLOCATE_PDT_COMP, 0); 9638 pdt_param_list = old_param_list; 9639 return res; 9640 } 9641 9642 /* Recursively traverse an object of paramterized derived type, generating 9643 code to deallocate parameterized components. */ 9644 9645 tree 9646 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) 9647 { 9648 return structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9649 DEALLOCATE_PDT_COMP, 0); 9650 } 9651 9652 9653 /* Recursively traverse a dummy of paramterized derived type to check the 9654 values of LEN parameters. */ 9655 9656 tree 9657 gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, 9658 gfc_actual_arglist *param_list) 9659 { 9660 tree res; 9661 gfc_actual_arglist *old_param_list = pdt_param_list; 9662 pdt_param_list = param_list; 9663 res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, 9664 CHECK_PDT_DUMMY, 0); 9665 pdt_param_list = old_param_list; 9666 return res; 9667 } 9668 9669 9670 /* Returns the value of LBOUND for an expression. This could be broken out 9671 from gfc_conv_intrinsic_bound but this seemed to be simpler. This is 9672 called by gfc_alloc_allocatable_for_assignment. */ 9673 static tree 9674 get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) 9675 { 9676 tree lbound; 9677 tree ubound; 9678 tree stride; 9679 tree cond, cond1, cond3, cond4; 9680 tree tmp; 9681 gfc_ref *ref; 9682 9683 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 9684 { 9685 tmp = gfc_rank_cst[dim]; 9686 lbound = gfc_conv_descriptor_lbound_get (desc, tmp); 9687 ubound = gfc_conv_descriptor_ubound_get (desc, tmp); 9688 stride = gfc_conv_descriptor_stride_get (desc, tmp); 9689 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 9690 ubound, lbound); 9691 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 9692 stride, gfc_index_zero_node); 9693 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, 9694 logical_type_node, cond3, cond1); 9695 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 9696 stride, gfc_index_zero_node); 9697 if (assumed_size) 9698 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 9699 tmp, build_int_cst (gfc_array_index_type, 9700 expr->rank - 1)); 9701 else 9702 cond = logical_false_node; 9703 9704 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, 9705 logical_type_node, cond3, cond4); 9706 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 9707 logical_type_node, cond, cond1); 9708 9709 return fold_build3_loc (input_location, COND_EXPR, 9710 gfc_array_index_type, cond, 9711 lbound, gfc_index_one_node); 9712 } 9713 9714 if (expr->expr_type == EXPR_FUNCTION) 9715 { 9716 /* A conversion function, so use the argument. */ 9717 gcc_assert (expr->value.function.isym 9718 && expr->value.function.isym->conversion); 9719 expr = expr->value.function.actual->expr; 9720 } 9721 9722 if (expr->expr_type == EXPR_VARIABLE) 9723 { 9724 tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); 9725 for (ref = expr->ref; ref; ref = ref->next) 9726 { 9727 if (ref->type == REF_COMPONENT 9728 && ref->u.c.component->as 9729 && ref->next 9730 && ref->next->u.ar.type == AR_FULL) 9731 tmp = TREE_TYPE (ref->u.c.component->backend_decl); 9732 } 9733 return GFC_TYPE_ARRAY_LBOUND(tmp, dim); 9734 } 9735 9736 return gfc_index_one_node; 9737 } 9738 9739 9740 /* Returns true if an expression represents an lhs that can be reallocated 9741 on assignment. */ 9742 9743 bool 9744 gfc_is_reallocatable_lhs (gfc_expr *expr) 9745 { 9746 gfc_ref * ref; 9747 gfc_symbol *sym; 9748 9749 if (!expr->ref) 9750 return false; 9751 9752 sym = expr->symtree->n.sym; 9753 9754 if (sym->attr.associate_var && !expr->ref) 9755 return false; 9756 9757 /* An allocatable class variable with no reference. */ 9758 if (sym->ts.type == BT_CLASS 9759 && !sym->attr.associate_var 9760 && CLASS_DATA (sym)->attr.allocatable 9761 && expr->ref 9762 && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL 9763 && expr->ref->next == NULL) 9764 || (expr->ref->type == REF_COMPONENT 9765 && strcmp (expr->ref->u.c.component->name, "_data") == 0 9766 && (expr->ref->next == NULL 9767 || (expr->ref->next->type == REF_ARRAY 9768 && expr->ref->next->u.ar.type == AR_FULL 9769 && expr->ref->next->next == NULL))))) 9770 return true; 9771 9772 /* An allocatable variable. */ 9773 if (sym->attr.allocatable 9774 && !sym->attr.associate_var 9775 && expr->ref 9776 && expr->ref->type == REF_ARRAY 9777 && expr->ref->u.ar.type == AR_FULL) 9778 return true; 9779 9780 /* All that can be left are allocatable components. */ 9781 if ((sym->ts.type != BT_DERIVED 9782 && sym->ts.type != BT_CLASS) 9783 || !sym->ts.u.derived->attr.alloc_comp) 9784 return false; 9785 9786 /* Find a component ref followed by an array reference. */ 9787 for (ref = expr->ref; ref; ref = ref->next) 9788 if (ref->next 9789 && ref->type == REF_COMPONENT 9790 && ref->next->type == REF_ARRAY 9791 && !ref->next->next) 9792 break; 9793 9794 if (!ref) 9795 return false; 9796 9797 /* Return true if valid reallocatable lhs. */ 9798 if (ref->u.c.component->attr.allocatable 9799 && ref->next->u.ar.type == AR_FULL) 9800 return true; 9801 9802 return false; 9803 } 9804 9805 9806 static tree 9807 concat_str_length (gfc_expr* expr) 9808 { 9809 tree type; 9810 tree len1; 9811 tree len2; 9812 gfc_se se; 9813 9814 type = gfc_typenode_for_spec (&expr->value.op.op1->ts); 9815 len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 9816 if (len1 == NULL_TREE) 9817 { 9818 if (expr->value.op.op1->expr_type == EXPR_OP) 9819 len1 = concat_str_length (expr->value.op.op1); 9820 else if (expr->value.op.op1->expr_type == EXPR_CONSTANT) 9821 len1 = build_int_cst (gfc_charlen_type_node, 9822 expr->value.op.op1->value.character.length); 9823 else if (expr->value.op.op1->ts.u.cl->length) 9824 { 9825 gfc_init_se (&se, NULL); 9826 gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length); 9827 len1 = se.expr; 9828 } 9829 else 9830 { 9831 /* Last resort! */ 9832 gfc_init_se (&se, NULL); 9833 se.want_pointer = 1; 9834 se.descriptor_only = 1; 9835 gfc_conv_expr (&se, expr->value.op.op1); 9836 len1 = se.string_length; 9837 } 9838 } 9839 9840 type = gfc_typenode_for_spec (&expr->value.op.op2->ts); 9841 len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 9842 if (len2 == NULL_TREE) 9843 { 9844 if (expr->value.op.op2->expr_type == EXPR_OP) 9845 len2 = concat_str_length (expr->value.op.op2); 9846 else if (expr->value.op.op2->expr_type == EXPR_CONSTANT) 9847 len2 = build_int_cst (gfc_charlen_type_node, 9848 expr->value.op.op2->value.character.length); 9849 else if (expr->value.op.op2->ts.u.cl->length) 9850 { 9851 gfc_init_se (&se, NULL); 9852 gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length); 9853 len2 = se.expr; 9854 } 9855 else 9856 { 9857 /* Last resort! */ 9858 gfc_init_se (&se, NULL); 9859 se.want_pointer = 1; 9860 se.descriptor_only = 1; 9861 gfc_conv_expr (&se, expr->value.op.op2); 9862 len2 = se.string_length; 9863 } 9864 } 9865 9866 gcc_assert(len1 && len2); 9867 len1 = fold_convert (gfc_charlen_type_node, len1); 9868 len2 = fold_convert (gfc_charlen_type_node, len2); 9869 9870 return fold_build2_loc (input_location, PLUS_EXPR, 9871 gfc_charlen_type_node, len1, len2); 9872 } 9873 9874 9875 /* Allocate the lhs of an assignment to an allocatable array, otherwise 9876 reallocate it. */ 9877 9878 tree 9879 gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 9880 gfc_expr *expr1, 9881 gfc_expr *expr2) 9882 { 9883 stmtblock_t realloc_block; 9884 stmtblock_t alloc_block; 9885 stmtblock_t fblock; 9886 gfc_ss *rss; 9887 gfc_ss *lss; 9888 gfc_array_info *linfo; 9889 tree realloc_expr; 9890 tree alloc_expr; 9891 tree size1; 9892 tree size2; 9893 tree array1; 9894 tree cond_null; 9895 tree cond; 9896 tree tmp; 9897 tree tmp2; 9898 tree lbound; 9899 tree ubound; 9900 tree desc; 9901 tree old_desc; 9902 tree desc2; 9903 tree offset; 9904 tree jump_label1; 9905 tree jump_label2; 9906 tree neq_size; 9907 tree lbd; 9908 int n; 9909 int dim; 9910 gfc_array_spec * as; 9911 bool coarray = (flag_coarray == GFC_FCOARRAY_LIB 9912 && gfc_caf_attr (expr1, true).codimension); 9913 tree token; 9914 gfc_se caf_se; 9915 9916 /* x = f(...) with x allocatable. In this case, expr1 is the rhs. 9917 Find the lhs expression in the loop chain and set expr1 and 9918 expr2 accordingly. */ 9919 if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) 9920 { 9921 expr2 = expr1; 9922 /* Find the ss for the lhs. */ 9923 lss = loop->ss; 9924 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) 9925 if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE) 9926 break; 9927 if (lss == gfc_ss_terminator) 9928 return NULL_TREE; 9929 expr1 = lss->info->expr; 9930 } 9931 9932 /* Bail out if this is not a valid allocate on assignment. */ 9933 if (!gfc_is_reallocatable_lhs (expr1) 9934 || (expr2 && !expr2->rank)) 9935 return NULL_TREE; 9936 9937 /* Find the ss for the lhs. */ 9938 lss = loop->ss; 9939 for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) 9940 if (lss->info->expr == expr1) 9941 break; 9942 9943 if (lss == gfc_ss_terminator) 9944 return NULL_TREE; 9945 9946 linfo = &lss->info->data.array; 9947 9948 /* Find an ss for the rhs. For operator expressions, we see the 9949 ss's for the operands. Any one of these will do. */ 9950 rss = loop->ss; 9951 for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) 9952 if (rss->info->expr != expr1 && rss != loop->temp_ss) 9953 break; 9954 9955 if (expr2 && rss == gfc_ss_terminator) 9956 return NULL_TREE; 9957 9958 /* Ensure that the string length from the current scope is used. */ 9959 if (expr2->ts.type == BT_CHARACTER 9960 && expr2->expr_type == EXPR_FUNCTION 9961 && !expr2->value.function.isym) 9962 expr2->ts.u.cl->backend_decl = rss->info->string_length; 9963 9964 gfc_start_block (&fblock); 9965 9966 /* Since the lhs is allocatable, this must be a descriptor type. 9967 Get the data and array size. */ 9968 desc = linfo->descriptor; 9969 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); 9970 array1 = gfc_conv_descriptor_data_get (desc); 9971 9972 /* 7.4.1.3 "If variable is an allocated allocatable variable, it is 9973 deallocated if expr is an array of different shape or any of the 9974 corresponding length type parameter values of variable and expr 9975 differ." This assures F95 compatibility. */ 9976 jump_label1 = gfc_build_label_decl (NULL_TREE); 9977 jump_label2 = gfc_build_label_decl (NULL_TREE); 9978 9979 /* Allocate if data is NULL. */ 9980 cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 9981 array1, build_int_cst (TREE_TYPE (array1), 0)); 9982 9983 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 9984 { 9985 tmp = fold_build2_loc (input_location, NE_EXPR, 9986 logical_type_node, 9987 lss->info->string_length, 9988 rss->info->string_length); 9989 cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, 9990 logical_type_node, tmp, cond_null); 9991 } 9992 else 9993 cond_null= gfc_evaluate_now (cond_null, &fblock); 9994 9995 tmp = build3_v (COND_EXPR, cond_null, 9996 build1_v (GOTO_EXPR, jump_label1), 9997 build_empty_stmt (input_location)); 9998 gfc_add_expr_to_block (&fblock, tmp); 9999 10000 /* Get arrayspec if expr is a full array. */ 10001 if (expr2 && expr2->expr_type == EXPR_FUNCTION 10002 && expr2->value.function.isym 10003 && expr2->value.function.isym->conversion) 10004 { 10005 /* For conversion functions, take the arg. */ 10006 gfc_expr *arg = expr2->value.function.actual->expr; 10007 as = gfc_get_full_arrayspec_from_expr (arg); 10008 } 10009 else if (expr2) 10010 as = gfc_get_full_arrayspec_from_expr (expr2); 10011 else 10012 as = NULL; 10013 10014 /* If the lhs shape is not the same as the rhs jump to setting the 10015 bounds and doing the reallocation....... */ 10016 for (n = 0; n < expr1->rank; n++) 10017 { 10018 /* Check the shape. */ 10019 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); 10020 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); 10021 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10022 gfc_array_index_type, 10023 loop->to[n], loop->from[n]); 10024 tmp = fold_build2_loc (input_location, PLUS_EXPR, 10025 gfc_array_index_type, 10026 tmp, lbound); 10027 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10028 gfc_array_index_type, 10029 tmp, ubound); 10030 cond = fold_build2_loc (input_location, NE_EXPR, 10031 logical_type_node, 10032 tmp, gfc_index_zero_node); 10033 tmp = build3_v (COND_EXPR, cond, 10034 build1_v (GOTO_EXPR, jump_label1), 10035 build_empty_stmt (input_location)); 10036 gfc_add_expr_to_block (&fblock, tmp); 10037 } 10038 10039 /* ....else jump past the (re)alloc code. */ 10040 tmp = build1_v (GOTO_EXPR, jump_label2); 10041 gfc_add_expr_to_block (&fblock, tmp); 10042 10043 /* Add the label to start automatic (re)allocation. */ 10044 tmp = build1_v (LABEL_EXPR, jump_label1); 10045 gfc_add_expr_to_block (&fblock, tmp); 10046 10047 /* If the lhs has not been allocated, its bounds will not have been 10048 initialized and so its size is set to zero. */ 10049 size1 = gfc_create_var (gfc_array_index_type, NULL); 10050 gfc_init_block (&alloc_block); 10051 gfc_add_modify (&alloc_block, size1, gfc_index_zero_node); 10052 gfc_init_block (&realloc_block); 10053 gfc_add_modify (&realloc_block, size1, 10054 gfc_conv_descriptor_size (desc, expr1->rank)); 10055 tmp = build3_v (COND_EXPR, cond_null, 10056 gfc_finish_block (&alloc_block), 10057 gfc_finish_block (&realloc_block)); 10058 gfc_add_expr_to_block (&fblock, tmp); 10059 10060 /* Get the rhs size and fix it. */ 10061 if (expr2) 10062 desc2 = rss->info->data.array.descriptor; 10063 else 10064 desc2 = NULL_TREE; 10065 10066 size2 = gfc_index_one_node; 10067 for (n = 0; n < expr2->rank; n++) 10068 { 10069 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10070 gfc_array_index_type, 10071 loop->to[n], loop->from[n]); 10072 tmp = fold_build2_loc (input_location, PLUS_EXPR, 10073 gfc_array_index_type, 10074 tmp, gfc_index_one_node); 10075 size2 = fold_build2_loc (input_location, MULT_EXPR, 10076 gfc_array_index_type, 10077 tmp, size2); 10078 } 10079 size2 = gfc_evaluate_now (size2, &fblock); 10080 10081 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 10082 size1, size2); 10083 10084 /* If the lhs is deferred length, assume that the element size 10085 changes and force a reallocation. */ 10086 if (expr1->ts.deferred) 10087 neq_size = gfc_evaluate_now (logical_true_node, &fblock); 10088 else 10089 neq_size = gfc_evaluate_now (cond, &fblock); 10090 10091 /* Deallocation of allocatable components will have to occur on 10092 reallocation. Fix the old descriptor now. */ 10093 if ((expr1->ts.type == BT_DERIVED) 10094 && expr1->ts.u.derived->attr.alloc_comp) 10095 old_desc = gfc_evaluate_now (desc, &fblock); 10096 else 10097 old_desc = NULL_TREE; 10098 10099 /* Now modify the lhs descriptor and the associated scalarizer 10100 variables. F2003 7.4.1.3: "If variable is or becomes an 10101 unallocated allocatable variable, then it is allocated with each 10102 deferred type parameter equal to the corresponding type parameters 10103 of expr , with the shape of expr , and with each lower bound equal 10104 to the corresponding element of LBOUND(expr)." 10105 Reuse size1 to keep a dimension-by-dimension track of the 10106 stride of the new array. */ 10107 size1 = gfc_index_one_node; 10108 offset = gfc_index_zero_node; 10109 10110 for (n = 0; n < expr2->rank; n++) 10111 { 10112 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10113 gfc_array_index_type, 10114 loop->to[n], loop->from[n]); 10115 tmp = fold_build2_loc (input_location, PLUS_EXPR, 10116 gfc_array_index_type, 10117 tmp, gfc_index_one_node); 10118 10119 lbound = gfc_index_one_node; 10120 ubound = tmp; 10121 10122 if (as) 10123 { 10124 lbd = get_std_lbound (expr2, desc2, n, 10125 as->type == AS_ASSUMED_SIZE); 10126 ubound = fold_build2_loc (input_location, 10127 MINUS_EXPR, 10128 gfc_array_index_type, 10129 ubound, lbound); 10130 ubound = fold_build2_loc (input_location, 10131 PLUS_EXPR, 10132 gfc_array_index_type, 10133 ubound, lbd); 10134 lbound = lbd; 10135 } 10136 10137 gfc_conv_descriptor_lbound_set (&fblock, desc, 10138 gfc_rank_cst[n], 10139 lbound); 10140 gfc_conv_descriptor_ubound_set (&fblock, desc, 10141 gfc_rank_cst[n], 10142 ubound); 10143 gfc_conv_descriptor_stride_set (&fblock, desc, 10144 gfc_rank_cst[n], 10145 size1); 10146 lbound = gfc_conv_descriptor_lbound_get (desc, 10147 gfc_rank_cst[n]); 10148 tmp2 = fold_build2_loc (input_location, MULT_EXPR, 10149 gfc_array_index_type, 10150 lbound, size1); 10151 offset = fold_build2_loc (input_location, MINUS_EXPR, 10152 gfc_array_index_type, 10153 offset, tmp2); 10154 size1 = fold_build2_loc (input_location, MULT_EXPR, 10155 gfc_array_index_type, 10156 tmp, size1); 10157 } 10158 10159 /* Set the lhs descriptor and scalarizer offsets. For rank > 1, 10160 the array offset is saved and the info.offset is used for a 10161 running offset. Use the saved_offset instead. */ 10162 tmp = gfc_conv_descriptor_offset (desc); 10163 gfc_add_modify (&fblock, tmp, offset); 10164 if (linfo->saved_offset 10165 && VAR_P (linfo->saved_offset)) 10166 gfc_add_modify (&fblock, linfo->saved_offset, tmp); 10167 10168 /* Now set the deltas for the lhs. */ 10169 for (n = 0; n < expr1->rank; n++) 10170 { 10171 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); 10172 dim = lss->dim[n]; 10173 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10174 gfc_array_index_type, tmp, 10175 loop->from[dim]); 10176 if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) 10177 gfc_add_modify (&fblock, linfo->delta[dim], tmp); 10178 } 10179 10180 /* Get the new lhs size in bytes. */ 10181 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 10182 { 10183 if (expr2->ts.deferred) 10184 { 10185 if (expr2->ts.u.cl->backend_decl 10186 && VAR_P (expr2->ts.u.cl->backend_decl)) 10187 tmp = expr2->ts.u.cl->backend_decl; 10188 else 10189 tmp = rss->info->string_length; 10190 } 10191 else 10192 { 10193 tmp = expr2->ts.u.cl->backend_decl; 10194 if (!tmp && expr2->expr_type == EXPR_OP 10195 && expr2->value.op.op == INTRINSIC_CONCAT) 10196 { 10197 tmp = concat_str_length (expr2); 10198 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); 10199 } 10200 else if (!tmp && expr2->ts.u.cl->length) 10201 { 10202 gfc_se tmpse; 10203 gfc_init_se (&tmpse, NULL); 10204 gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, 10205 gfc_charlen_type_node); 10206 tmp = tmpse.expr; 10207 expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); 10208 } 10209 tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); 10210 } 10211 10212 if (expr1->ts.u.cl->backend_decl 10213 && VAR_P (expr1->ts.u.cl->backend_decl)) 10214 gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); 10215 else 10216 gfc_add_modify (&fblock, lss->info->string_length, tmp); 10217 10218 if (expr1->ts.kind > 1) 10219 tmp = fold_build2_loc (input_location, MULT_EXPR, 10220 TREE_TYPE (tmp), 10221 tmp, build_int_cst (TREE_TYPE (tmp), 10222 expr1->ts.kind)); 10223 } 10224 else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) 10225 { 10226 tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); 10227 tmp = fold_build2_loc (input_location, MULT_EXPR, 10228 gfc_array_index_type, tmp, 10229 expr1->ts.u.cl->backend_decl); 10230 } 10231 else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) 10232 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); 10233 else 10234 tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); 10235 tmp = fold_convert (gfc_array_index_type, tmp); 10236 10237 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 10238 gfc_conv_descriptor_span_set (&fblock, desc, tmp); 10239 10240 size2 = fold_build2_loc (input_location, MULT_EXPR, 10241 gfc_array_index_type, 10242 tmp, size2); 10243 size2 = fold_convert (size_type_node, size2); 10244 size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, 10245 size2, size_one_node); 10246 size2 = gfc_evaluate_now (size2, &fblock); 10247 10248 /* For deferred character length, the 'size' field of the dtype might 10249 have changed so set the dtype. */ 10250 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) 10251 && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 10252 { 10253 tree type; 10254 tmp = gfc_conv_descriptor_dtype (desc); 10255 if (expr2->ts.u.cl->backend_decl) 10256 type = gfc_typenode_for_spec (&expr2->ts); 10257 else 10258 type = gfc_typenode_for_spec (&expr1->ts); 10259 10260 gfc_add_modify (&fblock, tmp, 10261 gfc_get_dtype_rank_type (expr1->rank,type)); 10262 } 10263 else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) 10264 { 10265 tree type; 10266 tmp = gfc_conv_descriptor_dtype (desc); 10267 type = gfc_typenode_for_spec (&expr2->ts); 10268 gfc_add_modify (&fblock, tmp, 10269 gfc_get_dtype_rank_type (expr2->rank,type)); 10270 /* Set the _len field as well... */ 10271 tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); 10272 if (expr2->ts.type == BT_CHARACTER) 10273 gfc_add_modify (&fblock, tmp, 10274 fold_convert (TREE_TYPE (tmp), 10275 TYPE_SIZE_UNIT (type))); 10276 else 10277 gfc_add_modify (&fblock, tmp, 10278 build_int_cst (TREE_TYPE (tmp), 0)); 10279 /* ...and the vptr. */ 10280 tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); 10281 tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); 10282 tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); 10283 gfc_add_modify (&fblock, tmp, tmp2); 10284 } 10285 else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 10286 { 10287 gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc), 10288 gfc_get_dtype (TREE_TYPE (desc))); 10289 } 10290 10291 /* Realloc expression. Note that the scalarizer uses desc.data 10292 in the array reference - (*desc.data)[<element>]. */ 10293 gfc_init_block (&realloc_block); 10294 gfc_init_se (&caf_se, NULL); 10295 10296 if (coarray) 10297 { 10298 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1); 10299 if (token == NULL_TREE) 10300 { 10301 tmp = gfc_get_tree_for_caf_expr (expr1); 10302 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 10303 tmp = build_fold_indirect_ref (tmp); 10304 gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, 10305 expr1); 10306 token = gfc_build_addr_expr (NULL_TREE, token); 10307 } 10308 10309 gfc_add_block_to_block (&realloc_block, &caf_se.pre); 10310 } 10311 if ((expr1->ts.type == BT_DERIVED) 10312 && expr1->ts.u.derived->attr.alloc_comp) 10313 { 10314 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, 10315 expr1->rank); 10316 gfc_add_expr_to_block (&realloc_block, tmp); 10317 } 10318 10319 if (!coarray) 10320 { 10321 tmp = build_call_expr_loc (input_location, 10322 builtin_decl_explicit (BUILT_IN_REALLOC), 2, 10323 fold_convert (pvoid_type_node, array1), 10324 size2); 10325 gfc_conv_descriptor_data_set (&realloc_block, 10326 desc, tmp); 10327 } 10328 else 10329 { 10330 tmp = build_call_expr_loc (input_location, 10331 gfor_fndecl_caf_deregister, 5, token, 10332 build_int_cst (integer_type_node, 10333 GFC_CAF_COARRAY_DEALLOCATE_ONLY), 10334 null_pointer_node, null_pointer_node, 10335 integer_zero_node); 10336 gfc_add_expr_to_block (&realloc_block, tmp); 10337 tmp = build_call_expr_loc (input_location, 10338 gfor_fndecl_caf_register, 10339 7, size2, 10340 build_int_cst (integer_type_node, 10341 GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY), 10342 token, gfc_build_addr_expr (NULL_TREE, desc), 10343 null_pointer_node, null_pointer_node, 10344 integer_zero_node); 10345 gfc_add_expr_to_block (&realloc_block, tmp); 10346 } 10347 10348 if ((expr1->ts.type == BT_DERIVED) 10349 && expr1->ts.u.derived->attr.alloc_comp) 10350 { 10351 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, 10352 expr1->rank); 10353 gfc_add_expr_to_block (&realloc_block, tmp); 10354 } 10355 10356 gfc_add_block_to_block (&realloc_block, &caf_se.post); 10357 realloc_expr = gfc_finish_block (&realloc_block); 10358 10359 /* Only reallocate if sizes are different. */ 10360 tmp = build3_v (COND_EXPR, neq_size, realloc_expr, 10361 build_empty_stmt (input_location)); 10362 realloc_expr = tmp; 10363 10364 10365 /* Malloc expression. */ 10366 gfc_init_block (&alloc_block); 10367 if (!coarray) 10368 { 10369 tmp = build_call_expr_loc (input_location, 10370 builtin_decl_explicit (BUILT_IN_MALLOC), 10371 1, size2); 10372 gfc_conv_descriptor_data_set (&alloc_block, 10373 desc, tmp); 10374 } 10375 else 10376 { 10377 tmp = build_call_expr_loc (input_location, 10378 gfor_fndecl_caf_register, 10379 7, size2, 10380 build_int_cst (integer_type_node, 10381 GFC_CAF_COARRAY_ALLOC), 10382 token, gfc_build_addr_expr (NULL_TREE, desc), 10383 null_pointer_node, null_pointer_node, 10384 integer_zero_node); 10385 gfc_add_expr_to_block (&alloc_block, tmp); 10386 } 10387 10388 10389 /* We already set the dtype in the case of deferred character 10390 length arrays and unlimited polymorphic arrays. */ 10391 if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) 10392 && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 10393 || coarray)) 10394 && !UNLIMITED_POLY (expr1)) 10395 { 10396 tmp = gfc_conv_descriptor_dtype (desc); 10397 gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); 10398 } 10399 10400 if ((expr1->ts.type == BT_DERIVED) 10401 && expr1->ts.u.derived->attr.alloc_comp) 10402 { 10403 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, 10404 expr1->rank); 10405 gfc_add_expr_to_block (&alloc_block, tmp); 10406 } 10407 alloc_expr = gfc_finish_block (&alloc_block); 10408 10409 /* Malloc if not allocated; realloc otherwise. */ 10410 tmp = build_int_cst (TREE_TYPE (array1), 0); 10411 cond = fold_build2_loc (input_location, EQ_EXPR, 10412 logical_type_node, 10413 array1, tmp); 10414 tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); 10415 gfc_add_expr_to_block (&fblock, tmp); 10416 10417 /* Make sure that the scalarizer data pointer is updated. */ 10418 if (linfo->data && VAR_P (linfo->data)) 10419 { 10420 tmp = gfc_conv_descriptor_data_get (desc); 10421 gfc_add_modify (&fblock, linfo->data, tmp); 10422 } 10423 10424 /* Add the exit label. */ 10425 tmp = build1_v (LABEL_EXPR, jump_label2); 10426 gfc_add_expr_to_block (&fblock, tmp); 10427 10428 return gfc_finish_block (&fblock); 10429 } 10430 10431 10432 /* NULLIFY an allocatable/pointer array on function entry, free it on exit. 10433 Do likewise, recursively if necessary, with the allocatable components of 10434 derived types. */ 10435 10436 void 10437 gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) 10438 { 10439 tree type; 10440 tree tmp; 10441 tree descriptor; 10442 stmtblock_t init; 10443 stmtblock_t cleanup; 10444 locus loc; 10445 int rank; 10446 bool sym_has_alloc_comp, has_finalizer; 10447 10448 sym_has_alloc_comp = (sym->ts.type == BT_DERIVED 10449 || sym->ts.type == BT_CLASS) 10450 && sym->ts.u.derived->attr.alloc_comp; 10451 has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED 10452 ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; 10453 10454 /* Make sure the frontend gets these right. */ 10455 gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp 10456 || has_finalizer); 10457 10458 gfc_save_backend_locus (&loc); 10459 gfc_set_backend_locus (&sym->declared_at); 10460 gfc_init_block (&init); 10461 10462 gcc_assert (VAR_P (sym->backend_decl) 10463 || TREE_CODE (sym->backend_decl) == PARM_DECL); 10464 10465 if (sym->ts.type == BT_CHARACTER 10466 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) 10467 { 10468 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 10469 gfc_trans_vla_type_sizes (sym, &init); 10470 } 10471 10472 /* Dummy, use associated and result variables don't need anything special. */ 10473 if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) 10474 { 10475 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 10476 gfc_restore_backend_locus (&loc); 10477 return; 10478 } 10479 10480 descriptor = sym->backend_decl; 10481 10482 /* Although static, derived types with default initializers and 10483 allocatable components must not be nulled wholesale; instead they 10484 are treated component by component. */ 10485 if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) 10486 { 10487 /* SAVEd variables are not freed on exit. */ 10488 gfc_trans_static_array_pointer (sym); 10489 10490 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 10491 gfc_restore_backend_locus (&loc); 10492 return; 10493 } 10494 10495 /* Get the descriptor type. */ 10496 type = TREE_TYPE (sym->backend_decl); 10497 10498 if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS)) 10499 && !(sym->attr.pointer || sym->attr.allocatable)) 10500 { 10501 if (!sym->attr.save 10502 && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) 10503 { 10504 if (sym->value == NULL 10505 || !gfc_has_default_initializer (sym->ts.u.derived)) 10506 { 10507 rank = sym->as ? sym->as->rank : 0; 10508 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, 10509 descriptor, rank); 10510 gfc_add_expr_to_block (&init, tmp); 10511 } 10512 else 10513 gfc_init_default_dt (sym, &init, false); 10514 } 10515 } 10516 else if (!GFC_DESCRIPTOR_TYPE_P (type)) 10517 { 10518 /* If the backend_decl is not a descriptor, we must have a pointer 10519 to one. */ 10520 descriptor = build_fold_indirect_ref_loc (input_location, 10521 sym->backend_decl); 10522 type = TREE_TYPE (descriptor); 10523 } 10524 10525 /* NULLIFY the data pointer, for non-saved allocatables. */ 10526 if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) 10527 { 10528 gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); 10529 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) 10530 { 10531 /* Declare the variable static so its array descriptor stays present 10532 after leaving the scope. It may still be accessed through another 10533 image. This may happen, for example, with the caf_mpi 10534 implementation. */ 10535 TREE_STATIC (descriptor) = 1; 10536 tmp = gfc_conv_descriptor_token (descriptor); 10537 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), 10538 null_pointer_node)); 10539 } 10540 } 10541 10542 gfc_restore_backend_locus (&loc); 10543 gfc_init_block (&cleanup); 10544 10545 /* Allocatable arrays need to be freed when they go out of scope. 10546 The allocatable components of pointers must not be touched. */ 10547 if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS 10548 && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save 10549 && !sym->ns->proc_name->attr.is_main_program) 10550 { 10551 gfc_expr *e; 10552 sym->attr.referenced = 1; 10553 e = gfc_lval_expr_from_sym (sym); 10554 gfc_add_finalizer_call (&cleanup, e); 10555 gfc_free_expr (e); 10556 } 10557 else if ((!sym->attr.allocatable || !has_finalizer) 10558 && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) 10559 && !sym->attr.pointer && !sym->attr.save 10560 && !sym->ns->proc_name->attr.is_main_program) 10561 { 10562 int rank; 10563 rank = sym->as ? sym->as->rank : 0; 10564 tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); 10565 gfc_add_expr_to_block (&cleanup, tmp); 10566 } 10567 10568 if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) 10569 && !sym->attr.save && !sym->attr.result 10570 && !sym->ns->proc_name->attr.is_main_program) 10571 { 10572 gfc_expr *e; 10573 e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; 10574 tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, 10575 NULL_TREE, NULL_TREE, true, e, 10576 sym->attr.codimension 10577 ? GFC_CAF_COARRAY_DEREGISTER 10578 : GFC_CAF_COARRAY_NOCOARRAY); 10579 if (e) 10580 gfc_free_expr (e); 10581 gfc_add_expr_to_block (&cleanup, tmp); 10582 } 10583 10584 gfc_add_init_cleanup (block, gfc_finish_block (&init), 10585 gfc_finish_block (&cleanup)); 10586 } 10587 10588 /************ Expression Walking Functions ******************/ 10589 10590 /* Walk a variable reference. 10591 10592 Possible extension - multiple component subscripts. 10593 x(:,:) = foo%a(:)%b(:) 10594 Transforms to 10595 forall (i=..., j=...) 10596 x(i,j) = foo%a(j)%b(i) 10597 end forall 10598 This adds a fair amount of complexity because you need to deal with more 10599 than one ref. Maybe handle in a similar manner to vector subscripts. 10600 Maybe not worth the effort. */ 10601 10602 10603 static gfc_ss * 10604 gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) 10605 { 10606 gfc_ref *ref; 10607 10608 gfc_fix_class_refs (expr); 10609 10610 for (ref = expr->ref; ref; ref = ref->next) 10611 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) 10612 break; 10613 10614 return gfc_walk_array_ref (ss, expr, ref); 10615 } 10616 10617 10618 gfc_ss * 10619 gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) 10620 { 10621 gfc_array_ref *ar; 10622 gfc_ss *newss; 10623 int n; 10624 10625 for (; ref; ref = ref->next) 10626 { 10627 if (ref->type == REF_SUBSTRING) 10628 { 10629 ss = gfc_get_scalar_ss (ss, ref->u.ss.start); 10630 ss = gfc_get_scalar_ss (ss, ref->u.ss.end); 10631 } 10632 10633 /* We're only interested in array sections from now on. */ 10634 if (ref->type != REF_ARRAY) 10635 continue; 10636 10637 ar = &ref->u.ar; 10638 10639 switch (ar->type) 10640 { 10641 case AR_ELEMENT: 10642 for (n = ar->dimen - 1; n >= 0; n--) 10643 ss = gfc_get_scalar_ss (ss, ar->start[n]); 10644 break; 10645 10646 case AR_FULL: 10647 newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); 10648 newss->info->data.array.ref = ref; 10649 10650 /* Make sure array is the same as array(:,:), this way 10651 we don't need to special case all the time. */ 10652 ar->dimen = ar->as->rank; 10653 for (n = 0; n < ar->dimen; n++) 10654 { 10655 ar->dimen_type[n] = DIMEN_RANGE; 10656 10657 gcc_assert (ar->start[n] == NULL); 10658 gcc_assert (ar->end[n] == NULL); 10659 gcc_assert (ar->stride[n] == NULL); 10660 } 10661 ss = newss; 10662 break; 10663 10664 case AR_SECTION: 10665 newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); 10666 newss->info->data.array.ref = ref; 10667 10668 /* We add SS chains for all the subscripts in the section. */ 10669 for (n = 0; n < ar->dimen; n++) 10670 { 10671 gfc_ss *indexss; 10672 10673 switch (ar->dimen_type[n]) 10674 { 10675 case DIMEN_ELEMENT: 10676 /* Add SS for elemental (scalar) subscripts. */ 10677 gcc_assert (ar->start[n]); 10678 indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); 10679 indexss->loop_chain = gfc_ss_terminator; 10680 newss->info->data.array.subscript[n] = indexss; 10681 break; 10682 10683 case DIMEN_RANGE: 10684 /* We don't add anything for sections, just remember this 10685 dimension for later. */ 10686 newss->dim[newss->dimen] = n; 10687 newss->dimen++; 10688 break; 10689 10690 case DIMEN_VECTOR: 10691 /* Create a GFC_SS_VECTOR index in which we can store 10692 the vector's descriptor. */ 10693 indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], 10694 1, GFC_SS_VECTOR); 10695 indexss->loop_chain = gfc_ss_terminator; 10696 newss->info->data.array.subscript[n] = indexss; 10697 newss->dim[newss->dimen] = n; 10698 newss->dimen++; 10699 break; 10700 10701 default: 10702 /* We should know what sort of section it is by now. */ 10703 gcc_unreachable (); 10704 } 10705 } 10706 /* We should have at least one non-elemental dimension, 10707 unless we are creating a descriptor for a (scalar) coarray. */ 10708 gcc_assert (newss->dimen > 0 10709 || newss->info->data.array.ref->u.ar.as->corank > 0); 10710 ss = newss; 10711 break; 10712 10713 default: 10714 /* We should know what sort of section it is by now. */ 10715 gcc_unreachable (); 10716 } 10717 10718 } 10719 return ss; 10720 } 10721 10722 10723 /* Walk an expression operator. If only one operand of a binary expression is 10724 scalar, we must also add the scalar term to the SS chain. */ 10725 10726 static gfc_ss * 10727 gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) 10728 { 10729 gfc_ss *head; 10730 gfc_ss *head2; 10731 10732 head = gfc_walk_subexpr (ss, expr->value.op.op1); 10733 if (expr->value.op.op2 == NULL) 10734 head2 = head; 10735 else 10736 head2 = gfc_walk_subexpr (head, expr->value.op.op2); 10737 10738 /* All operands are scalar. Pass back and let the caller deal with it. */ 10739 if (head2 == ss) 10740 return head2; 10741 10742 /* All operands require scalarization. */ 10743 if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) 10744 return head2; 10745 10746 /* One of the operands needs scalarization, the other is scalar. 10747 Create a gfc_ss for the scalar expression. */ 10748 if (head == ss) 10749 { 10750 /* First operand is scalar. We build the chain in reverse order, so 10751 add the scalar SS after the second operand. */ 10752 head = head2; 10753 while (head && head->next != ss) 10754 head = head->next; 10755 /* Check we haven't somehow broken the chain. */ 10756 gcc_assert (head); 10757 head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); 10758 } 10759 else /* head2 == head */ 10760 { 10761 gcc_assert (head2 == head); 10762 /* Second operand is scalar. */ 10763 head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); 10764 } 10765 10766 return head2; 10767 } 10768 10769 10770 /* Reverse a SS chain. */ 10771 10772 gfc_ss * 10773 gfc_reverse_ss (gfc_ss * ss) 10774 { 10775 gfc_ss *next; 10776 gfc_ss *head; 10777 10778 gcc_assert (ss != NULL); 10779 10780 head = gfc_ss_terminator; 10781 while (ss != gfc_ss_terminator) 10782 { 10783 next = ss->next; 10784 /* Check we didn't somehow break the chain. */ 10785 gcc_assert (next != NULL); 10786 ss->next = head; 10787 head = ss; 10788 ss = next; 10789 } 10790 10791 return (head); 10792 } 10793 10794 10795 /* Given an expression referring to a procedure, return the symbol of its 10796 interface. We can't get the procedure symbol directly as we have to handle 10797 the case of (deferred) type-bound procedures. */ 10798 10799 gfc_symbol * 10800 gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) 10801 { 10802 gfc_symbol *sym; 10803 gfc_ref *ref; 10804 10805 if (procedure_ref == NULL) 10806 return NULL; 10807 10808 /* Normal procedure case. */ 10809 if (procedure_ref->expr_type == EXPR_FUNCTION 10810 && procedure_ref->value.function.esym) 10811 sym = procedure_ref->value.function.esym; 10812 else 10813 sym = procedure_ref->symtree->n.sym; 10814 10815 /* Typebound procedure case. */ 10816 for (ref = procedure_ref->ref; ref; ref = ref->next) 10817 { 10818 if (ref->type == REF_COMPONENT 10819 && ref->u.c.component->attr.proc_pointer) 10820 sym = ref->u.c.component->ts.interface; 10821 else 10822 sym = NULL; 10823 } 10824 10825 return sym; 10826 } 10827 10828 10829 /* Walk the arguments of an elemental function. 10830 PROC_EXPR is used to check whether an argument is permitted to be absent. If 10831 it is NULL, we don't do the check and the argument is assumed to be present. 10832 */ 10833 10834 gfc_ss * 10835 gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, 10836 gfc_symbol *proc_ifc, gfc_ss_type type) 10837 { 10838 gfc_formal_arglist *dummy_arg; 10839 int scalar; 10840 gfc_ss *head; 10841 gfc_ss *tail; 10842 gfc_ss *newss; 10843 10844 head = gfc_ss_terminator; 10845 tail = NULL; 10846 10847 if (proc_ifc) 10848 dummy_arg = gfc_sym_get_dummy_args (proc_ifc); 10849 else 10850 dummy_arg = NULL; 10851 10852 scalar = 1; 10853 for (; arg; arg = arg->next) 10854 { 10855 if (!arg->expr || arg->expr->expr_type == EXPR_NULL) 10856 goto loop_continue; 10857 10858 newss = gfc_walk_subexpr (head, arg->expr); 10859 if (newss == head) 10860 { 10861 /* Scalar argument. */ 10862 gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); 10863 newss = gfc_get_scalar_ss (head, arg->expr); 10864 newss->info->type = type; 10865 if (dummy_arg) 10866 newss->info->data.scalar.dummy_arg = dummy_arg->sym; 10867 } 10868 else 10869 scalar = 0; 10870 10871 if (dummy_arg != NULL 10872 && dummy_arg->sym->attr.optional 10873 && arg->expr->expr_type == EXPR_VARIABLE 10874 && (gfc_expr_attr (arg->expr).optional 10875 || gfc_expr_attr (arg->expr).allocatable 10876 || gfc_expr_attr (arg->expr).pointer)) 10877 newss->info->can_be_null_ref = true; 10878 10879 head = newss; 10880 if (!tail) 10881 { 10882 tail = head; 10883 while (tail->next != gfc_ss_terminator) 10884 tail = tail->next; 10885 } 10886 10887 loop_continue: 10888 if (dummy_arg != NULL) 10889 dummy_arg = dummy_arg->next; 10890 } 10891 10892 if (scalar) 10893 { 10894 /* If all the arguments are scalar we don't need the argument SS. */ 10895 gfc_free_ss_chain (head); 10896 /* Pass it back. */ 10897 return ss; 10898 } 10899 10900 /* Add it onto the existing chain. */ 10901 tail->next = ss; 10902 return head; 10903 } 10904 10905 10906 /* Walk a function call. Scalar functions are passed back, and taken out of 10907 scalarization loops. For elemental functions we walk their arguments. 10908 The result of functions returning arrays is stored in a temporary outside 10909 the loop, so that the function is only called once. Hence we do not need 10910 to walk their arguments. */ 10911 10912 static gfc_ss * 10913 gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) 10914 { 10915 gfc_intrinsic_sym *isym; 10916 gfc_symbol *sym; 10917 gfc_component *comp = NULL; 10918 10919 isym = expr->value.function.isym; 10920 10921 /* Handle intrinsic functions separately. */ 10922 if (isym) 10923 return gfc_walk_intrinsic_function (ss, expr, isym); 10924 10925 sym = expr->value.function.esym; 10926 if (!sym) 10927 sym = expr->symtree->n.sym; 10928 10929 if (gfc_is_class_array_function (expr)) 10930 return gfc_get_array_ss (ss, expr, 10931 CLASS_DATA (expr->value.function.esym->result)->as->rank, 10932 GFC_SS_FUNCTION); 10933 10934 /* A function that returns arrays. */ 10935 comp = gfc_get_proc_ptr_comp (expr); 10936 if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) 10937 || (comp && comp->attr.dimension)) 10938 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); 10939 10940 /* Walk the parameters of an elemental function. For now we always pass 10941 by reference. */ 10942 if (sym->attr.elemental || (comp && comp->attr.elemental)) 10943 { 10944 gfc_ss *old_ss = ss; 10945 10946 ss = gfc_walk_elemental_function_args (old_ss, 10947 expr->value.function.actual, 10948 gfc_get_proc_ifc_for_expr (expr), 10949 GFC_SS_REFERENCE); 10950 if (ss != old_ss 10951 && (comp 10952 || sym->attr.proc_pointer 10953 || sym->attr.if_source != IFSRC_DECL 10954 || sym->attr.array_outer_dependency)) 10955 ss->info->array_outer_dependency = 1; 10956 } 10957 10958 /* Scalar functions are OK as these are evaluated outside the scalarization 10959 loop. Pass back and let the caller deal with it. */ 10960 return ss; 10961 } 10962 10963 10964 /* An array temporary is constructed for array constructors. */ 10965 10966 static gfc_ss * 10967 gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) 10968 { 10969 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); 10970 } 10971 10972 10973 /* Walk an expression. Add walked expressions to the head of the SS chain. 10974 A wholly scalar expression will not be added. */ 10975 10976 gfc_ss * 10977 gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) 10978 { 10979 gfc_ss *head; 10980 10981 switch (expr->expr_type) 10982 { 10983 case EXPR_VARIABLE: 10984 head = gfc_walk_variable_expr (ss, expr); 10985 return head; 10986 10987 case EXPR_OP: 10988 head = gfc_walk_op_expr (ss, expr); 10989 return head; 10990 10991 case EXPR_FUNCTION: 10992 head = gfc_walk_function_expr (ss, expr); 10993 return head; 10994 10995 case EXPR_CONSTANT: 10996 case EXPR_NULL: 10997 case EXPR_STRUCTURE: 10998 /* Pass back and let the caller deal with it. */ 10999 break; 11000 11001 case EXPR_ARRAY: 11002 head = gfc_walk_array_constructor (ss, expr); 11003 return head; 11004 11005 case EXPR_SUBSTRING: 11006 /* Pass back and let the caller deal with it. */ 11007 break; 11008 11009 default: 11010 gfc_internal_error ("bad expression type during walk (%d)", 11011 expr->expr_type); 11012 } 11013 return ss; 11014 } 11015 11016 11017 /* Entry point for expression walking. 11018 A return value equal to the passed chain means this is 11019 a scalar expression. It is up to the caller to take whatever action is 11020 necessary to translate these. */ 11021 11022 gfc_ss * 11023 gfc_walk_expr (gfc_expr * expr) 11024 { 11025 gfc_ss *res; 11026 11027 res = gfc_walk_subexpr (gfc_ss_terminator, expr); 11028 return gfc_reverse_ss (res); 11029 } 11030