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