1/* Expression translation 2 Copyright (C) 2002-2022 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 5 6This file is part of GCC. 7 8GCC is free software; you can redistribute it and/or modify it under 9the terms of the GNU General Public License as published by the Free 10Software Foundation; either version 3, or (at your option) any later 11version. 12 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14WARRANTY; without even the implied warranty of MERCHANTABILITY or 15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16for more details. 17 18You should have received a copy of the GNU General Public License 19along with GCC; see the file COPYING3. If not see 20<http://www.gnu.org/licenses/>. */ 21 22/* trans-expr.cc-- generate GENERIC trees for gfc_expr. */ 23 24#include "config.h" 25#include "system.h" 26#include "coretypes.h" 27#include "options.h" 28#include "tree.h" 29#include "gfortran.h" 30#include "trans.h" 31#include "stringpool.h" 32#include "diagnostic-core.h" /* For fatal_error. */ 33#include "fold-const.h" 34#include "langhooks.h" 35#include "arith.h" 36#include "constructor.h" 37#include "trans-const.h" 38#include "trans-types.h" 39#include "trans-array.h" 40/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ 41#include "trans-stmt.h" 42#include "dependency.h" 43#include "gimplify.h" 44#include "tm.h" /* For CHAR_TYPE_SIZE. */ 45 46 47/* Calculate the number of characters in a string. */ 48 49static tree 50gfc_get_character_len (tree type) 51{ 52 tree len; 53 54 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE 55 && TYPE_STRING_FLAG (type)); 56 57 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 58 len = (len) ? (len) : (integer_zero_node); 59 return fold_convert (gfc_charlen_type_node, len); 60} 61 62 63 64/* Calculate the number of bytes in a string. */ 65 66tree 67gfc_get_character_len_in_bytes (tree type) 68{ 69 tree tmp, len; 70 71 gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE 72 && TYPE_STRING_FLAG (type)); 73 74 tmp = TYPE_SIZE_UNIT (TREE_TYPE (type)); 75 tmp = (tmp && !integer_zerop (tmp)) 76 ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE); 77 len = gfc_get_character_len (type); 78 if (tmp && len && !integer_zerop (len)) 79 len = fold_build2_loc (input_location, MULT_EXPR, 80 gfc_charlen_type_node, len, tmp); 81 return len; 82} 83 84 85/* Convert a scalar to an array descriptor. To be used for assumed-rank 86 arrays. */ 87 88static tree 89get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) 90{ 91 enum gfc_array_kind akind; 92 93 if (attr.pointer) 94 akind = GFC_ARRAY_POINTER_CONT; 95 else if (attr.allocatable) 96 akind = GFC_ARRAY_ALLOCATABLE; 97 else 98 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT; 99 100 if (POINTER_TYPE_P (TREE_TYPE (scalar))) 101 scalar = TREE_TYPE (scalar); 102 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1, 103 akind, !(attr.pointer || attr.target)); 104} 105 106tree 107gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) 108{ 109 tree desc, type, etype; 110 111 type = get_scalar_to_descriptor_type (scalar, attr); 112 etype = TREE_TYPE (scalar); 113 desc = gfc_create_var (type, "desc"); 114 DECL_ARTIFICIAL (desc) = 1; 115 116 if (CONSTANT_CLASS_P (scalar)) 117 { 118 tree tmp; 119 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar"); 120 gfc_add_modify (&se->pre, tmp, scalar); 121 scalar = tmp; 122 } 123 if (!POINTER_TYPE_P (TREE_TYPE (scalar))) 124 scalar = gfc_build_addr_expr (NULL_TREE, scalar); 125 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE) 126 etype = TREE_TYPE (etype); 127 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), 128 gfc_get_dtype_rank_type (0, etype)); 129 gfc_conv_descriptor_data_set (&se->pre, desc, scalar); 130 gfc_conv_descriptor_span_set (&se->pre, desc, 131 gfc_conv_descriptor_elem_len (desc)); 132 133 /* Copy pointer address back - but only if it could have changed and 134 if the actual argument is a pointer and not, e.g., NULL(). */ 135 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN) 136 gfc_add_modify (&se->post, scalar, 137 fold_convert (TREE_TYPE (scalar), 138 gfc_conv_descriptor_data_get (desc))); 139 return desc; 140} 141 142 143/* Get the coarray token from the ultimate array or component ref. 144 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */ 145 146tree 147gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr) 148{ 149 gfc_symbol *sym = expr->symtree->n.sym; 150 bool is_coarray = sym->attr.codimension; 151 gfc_expr *caf_expr = gfc_copy_expr (expr); 152 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL; 153 154 while (ref) 155 { 156 if (ref->type == REF_COMPONENT 157 && (ref->u.c.component->attr.allocatable 158 || ref->u.c.component->attr.pointer) 159 && (is_coarray || ref->u.c.component->attr.codimension)) 160 last_caf_ref = ref; 161 ref = ref->next; 162 } 163 164 if (last_caf_ref == NULL) 165 return NULL_TREE; 166 167 tree comp = last_caf_ref->u.c.component->caf_token, caf; 168 gfc_se se; 169 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension; 170 if (comp == NULL_TREE && comp_ref) 171 return NULL_TREE; 172 gfc_init_se (&se, outerse); 173 gfc_free_ref_list (last_caf_ref->next); 174 last_caf_ref->next = NULL; 175 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank; 176 se.want_pointer = comp_ref; 177 gfc_conv_expr (&se, caf_expr); 178 gfc_add_block_to_block (&outerse->pre, &se.pre); 179 180 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref) 181 se.expr = TREE_OPERAND (se.expr, 0); 182 gfc_free_expr (caf_expr); 183 184 if (comp_ref) 185 caf = fold_build3_loc (input_location, COMPONENT_REF, 186 TREE_TYPE (comp), se.expr, comp, NULL_TREE); 187 else 188 caf = gfc_conv_descriptor_token (se.expr); 189 return gfc_build_addr_expr (NULL_TREE, caf); 190} 191 192 193/* This is the seed for an eventual trans-class.c 194 195 The following parameters should not be used directly since they might 196 in future implementations. Use the corresponding APIs. */ 197#define CLASS_DATA_FIELD 0 198#define CLASS_VPTR_FIELD 1 199#define CLASS_LEN_FIELD 2 200#define VTABLE_HASH_FIELD 0 201#define VTABLE_SIZE_FIELD 1 202#define VTABLE_EXTENDS_FIELD 2 203#define VTABLE_DEF_INIT_FIELD 3 204#define VTABLE_COPY_FIELD 4 205#define VTABLE_FINAL_FIELD 5 206#define VTABLE_DEALLOCATE_FIELD 6 207 208 209tree 210gfc_class_set_static_fields (tree decl, tree vptr, tree data) 211{ 212 tree tmp; 213 tree field; 214 vec<constructor_elt, va_gc> *init = NULL; 215 216 field = TYPE_FIELDS (TREE_TYPE (decl)); 217 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD); 218 CONSTRUCTOR_APPEND_ELT (init, tmp, data); 219 220 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD); 221 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr); 222 223 return build_constructor (TREE_TYPE (decl), init); 224} 225 226 227tree 228gfc_class_data_get (tree decl) 229{ 230 tree data; 231 if (POINTER_TYPE_P (TREE_TYPE (decl))) 232 decl = build_fold_indirect_ref_loc (input_location, decl); 233 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), 234 CLASS_DATA_FIELD); 235 return fold_build3_loc (input_location, COMPONENT_REF, 236 TREE_TYPE (data), decl, data, 237 NULL_TREE); 238} 239 240 241tree 242gfc_class_vptr_get (tree decl) 243{ 244 tree vptr; 245 /* For class arrays decl may be a temporary descriptor handle, the vptr is 246 then available through the saved descriptor. */ 247 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) 248 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 249 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 250 if (POINTER_TYPE_P (TREE_TYPE (decl))) 251 decl = build_fold_indirect_ref_loc (input_location, decl); 252 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), 253 CLASS_VPTR_FIELD); 254 return fold_build3_loc (input_location, COMPONENT_REF, 255 TREE_TYPE (vptr), decl, vptr, 256 NULL_TREE); 257} 258 259 260tree 261gfc_class_len_get (tree decl) 262{ 263 tree len; 264 /* For class arrays decl may be a temporary descriptor handle, the len is 265 then available through the saved descriptor. */ 266 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) 267 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 268 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 269 if (POINTER_TYPE_P (TREE_TYPE (decl))) 270 decl = build_fold_indirect_ref_loc (input_location, decl); 271 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), 272 CLASS_LEN_FIELD); 273 return fold_build3_loc (input_location, COMPONENT_REF, 274 TREE_TYPE (len), decl, len, 275 NULL_TREE); 276} 277 278 279/* Try to get the _len component of a class. When the class is not unlimited 280 poly, i.e. no _len field exists, then return a zero node. */ 281 282static tree 283gfc_class_len_or_zero_get (tree decl) 284{ 285 tree len; 286 /* For class arrays decl may be a temporary descriptor handle, the vptr is 287 then available through the saved descriptor. */ 288 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl) 289 && GFC_DECL_SAVED_DESCRIPTOR (decl)) 290 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 291 if (POINTER_TYPE_P (TREE_TYPE (decl))) 292 decl = build_fold_indirect_ref_loc (input_location, decl); 293 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), 294 CLASS_LEN_FIELD); 295 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF, 296 TREE_TYPE (len), decl, len, 297 NULL_TREE) 298 : build_zero_cst (gfc_charlen_type_node); 299} 300 301 302tree 303gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size) 304{ 305 tree tmp; 306 tree tmp2; 307 tree type; 308 309 tmp = gfc_class_len_or_zero_get (class_expr); 310 311 /* Include the len value in the element size if present. */ 312 if (!integer_zerop (tmp)) 313 { 314 type = TREE_TYPE (size); 315 if (block) 316 { 317 size = gfc_evaluate_now (size, block); 318 tmp = gfc_evaluate_now (fold_convert (type , tmp), block); 319 } 320 tmp2 = fold_build2_loc (input_location, MULT_EXPR, 321 type, size, tmp); 322 tmp = fold_build2_loc (input_location, GT_EXPR, 323 logical_type_node, tmp, 324 build_zero_cst (type)); 325 size = fold_build3_loc (input_location, COND_EXPR, 326 type, tmp, tmp2, size); 327 } 328 else 329 return size; 330 331 if (block) 332 size = gfc_evaluate_now (size, block); 333 334 return size; 335} 336 337 338/* Get the specified FIELD from the VPTR. */ 339 340static tree 341vptr_field_get (tree vptr, int fieldno) 342{ 343 tree field; 344 vptr = build_fold_indirect_ref_loc (input_location, vptr); 345 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)), 346 fieldno); 347 field = fold_build3_loc (input_location, COMPONENT_REF, 348 TREE_TYPE (field), vptr, field, 349 NULL_TREE); 350 gcc_assert (field); 351 return field; 352} 353 354 355/* Get the field from the class' vptr. */ 356 357static tree 358class_vtab_field_get (tree decl, int fieldno) 359{ 360 tree vptr; 361 vptr = gfc_class_vptr_get (decl); 362 return vptr_field_get (vptr, fieldno); 363} 364 365 366/* Define a macro for creating the class_vtab_* and vptr_* accessors in 367 unison. */ 368#define VTAB_GET_FIELD_GEN(name, field) tree \ 369gfc_class_vtab_## name ##_get (tree cl) \ 370{ \ 371 return class_vtab_field_get (cl, field); \ 372} \ 373 \ 374tree \ 375gfc_vptr_## name ##_get (tree vptr) \ 376{ \ 377 return vptr_field_get (vptr, field); \ 378} 379 380VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD) 381VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD) 382VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD) 383VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD) 384VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD) 385VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD) 386#undef VTAB_GET_FIELD_GEN 387 388/* The size field is returned as an array index type. Therefore treat 389 it and only it specially. */ 390 391tree 392gfc_class_vtab_size_get (tree cl) 393{ 394 tree size; 395 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD); 396 /* Always return size as an array index type. */ 397 size = fold_convert (gfc_array_index_type, size); 398 gcc_assert (size); 399 return size; 400} 401 402tree 403gfc_vptr_size_get (tree vptr) 404{ 405 tree size; 406 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD); 407 /* Always return size as an array index type. */ 408 size = fold_convert (gfc_array_index_type, size); 409 gcc_assert (size); 410 return size; 411} 412 413 414#undef CLASS_DATA_FIELD 415#undef CLASS_VPTR_FIELD 416#undef CLASS_LEN_FIELD 417#undef VTABLE_HASH_FIELD 418#undef VTABLE_SIZE_FIELD 419#undef VTABLE_EXTENDS_FIELD 420#undef VTABLE_DEF_INIT_FIELD 421#undef VTABLE_COPY_FIELD 422#undef VTABLE_FINAL_FIELD 423 424 425/* IF ts is null (default), search for the last _class ref in the chain 426 of references of the expression and cut the chain there. Although 427 this routine is similiar to class.cc:gfc_add_component_ref (), there 428 is a significant difference: gfc_add_component_ref () concentrates 429 on an array ref that is the last ref in the chain and is oblivious 430 to the kind of refs following. 431 ELSE IF ts is non-null the cut is at the class entity or component 432 that is followed by an array reference, which is not an element. 433 These calls come from trans-array.cc:build_class_array_ref, which 434 handles scalarized class array references.*/ 435 436gfc_expr * 437gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, 438 gfc_typespec **ts) 439{ 440 gfc_expr *base_expr; 441 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; 442 443 /* Find the last class reference. */ 444 class_ref = NULL; 445 array_ref = NULL; 446 447 if (ts) 448 { 449 if (e->symtree 450 && e->symtree->n.sym->ts.type == BT_CLASS) 451 *ts = &e->symtree->n.sym->ts; 452 else 453 *ts = NULL; 454 } 455 456 for (ref = e->ref; ref; ref = ref->next) 457 { 458 if (ts) 459 { 460 if (ref->type == REF_COMPONENT 461 && ref->u.c.component->ts.type == BT_CLASS 462 && ref->next && ref->next->type == REF_COMPONENT 463 && !strcmp (ref->next->u.c.component->name, "_data") 464 && ref->next->next 465 && ref->next->next->type == REF_ARRAY 466 && ref->next->next->u.ar.type != AR_ELEMENT) 467 { 468 *ts = &ref->u.c.component->ts; 469 class_ref = ref; 470 break; 471 } 472 473 if (ref->next == NULL) 474 break; 475 } 476 else 477 { 478 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) 479 array_ref = ref; 480 481 if (ref->type == REF_COMPONENT 482 && ref->u.c.component->ts.type == BT_CLASS) 483 { 484 /* Component to the right of a part reference with nonzero 485 rank must not have the ALLOCATABLE attribute. If attempts 486 are made to reference such a component reference, an error 487 results followed by an ICE. */ 488 if (array_ref 489 && CLASS_DATA (ref->u.c.component)->attr.allocatable) 490 return NULL; 491 class_ref = ref; 492 } 493 } 494 } 495 496 if (ts && *ts == NULL) 497 return NULL; 498 499 /* Remove and store all subsequent references after the 500 CLASS reference. */ 501 if (class_ref) 502 { 503 tail = class_ref->next; 504 class_ref->next = NULL; 505 } 506 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 507 { 508 tail = e->ref; 509 e->ref = NULL; 510 } 511 512 if (is_mold) 513 base_expr = gfc_expr_to_initialize (e); 514 else 515 base_expr = gfc_copy_expr (e); 516 517 /* Restore the original tail expression. */ 518 if (class_ref) 519 { 520 gfc_free_ref_list (class_ref->next); 521 class_ref->next = tail; 522 } 523 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 524 { 525 gfc_free_ref_list (e->ref); 526 e->ref = tail; 527 } 528 return base_expr; 529} 530 531 532/* Reset the vptr to the declared type, e.g. after deallocation. */ 533 534void 535gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) 536{ 537 gfc_symbol *vtab; 538 tree vptr; 539 tree vtable; 540 gfc_se se; 541 542 /* Evaluate the expression and obtain the vptr from it. */ 543 gfc_init_se (&se, NULL); 544 if (e->rank) 545 gfc_conv_expr_descriptor (&se, e); 546 else 547 gfc_conv_expr (&se, e); 548 gfc_add_block_to_block (block, &se.pre); 549 vptr = gfc_get_vptr_from_expr (se.expr); 550 551 /* If a vptr is not found, we can do nothing more. */ 552 if (vptr == NULL_TREE) 553 return; 554 555 if (UNLIMITED_POLY (e)) 556 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); 557 else 558 { 559 /* Return the vptr to the address of the declared type. */ 560 vtab = gfc_find_derived_vtab (e->ts.u.derived); 561 vtable = vtab->backend_decl; 562 if (vtable == NULL_TREE) 563 vtable = gfc_get_symbol_decl (vtab); 564 vtable = gfc_build_addr_expr (NULL, vtable); 565 vtable = fold_convert (TREE_TYPE (vptr), vtable); 566 gfc_add_modify (block, vptr, vtable); 567 } 568} 569 570 571/* Reset the len for unlimited polymorphic objects. */ 572 573void 574gfc_reset_len (stmtblock_t *block, gfc_expr *expr) 575{ 576 gfc_expr *e; 577 gfc_se se_len; 578 e = gfc_find_and_cut_at_last_class_ref (expr); 579 if (e == NULL) 580 return; 581 gfc_add_len_component (e); 582 gfc_init_se (&se_len, NULL); 583 gfc_conv_expr (&se_len, e); 584 gfc_add_modify (block, se_len.expr, 585 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node)); 586 gfc_free_expr (e); 587} 588 589 590/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class 591 reference is found. Note that it is up to the caller to avoid using this 592 for expressions other than variables. */ 593 594tree 595gfc_get_class_from_gfc_expr (gfc_expr *e) 596{ 597 gfc_expr *class_expr; 598 gfc_se cse; 599 class_expr = gfc_find_and_cut_at_last_class_ref (e); 600 if (class_expr == NULL) 601 return NULL_TREE; 602 gfc_init_se (&cse, NULL); 603 gfc_conv_expr (&cse, class_expr); 604 gfc_free_expr (class_expr); 605 return cse.expr; 606} 607 608 609/* Obtain the last class reference in an expression. 610 Return NULL_TREE if no class reference is found. */ 611 612tree 613gfc_get_class_from_expr (tree expr) 614{ 615 tree tmp; 616 tree type; 617 618 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) 619 { 620 if (CONSTANT_CLASS_P (tmp)) 621 return NULL_TREE; 622 623 type = TREE_TYPE (tmp); 624 while (type) 625 { 626 if (GFC_CLASS_TYPE_P (type)) 627 return tmp; 628 if (type != TYPE_CANONICAL (type)) 629 type = TYPE_CANONICAL (type); 630 else 631 type = NULL_TREE; 632 } 633 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) 634 break; 635 } 636 637 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 638 tmp = build_fold_indirect_ref_loc (input_location, tmp); 639 640 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) 641 return tmp; 642 643 return NULL_TREE; 644} 645 646 647/* Obtain the vptr of the last class reference in an expression. 648 Return NULL_TREE if no class reference is found. */ 649 650tree 651gfc_get_vptr_from_expr (tree expr) 652{ 653 tree tmp; 654 655 tmp = gfc_get_class_from_expr (expr); 656 657 if (tmp != NULL_TREE) 658 return gfc_class_vptr_get (tmp); 659 660 return NULL_TREE; 661} 662 663 664static void 665class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, 666 bool lhs_type) 667{ 668 tree tmp, tmp2, type; 669 670 gfc_conv_descriptor_data_set (block, lhs_desc, 671 gfc_conv_descriptor_data_get (rhs_desc)); 672 gfc_conv_descriptor_offset_set (block, lhs_desc, 673 gfc_conv_descriptor_offset_get (rhs_desc)); 674 675 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), 676 gfc_conv_descriptor_dtype (rhs_desc)); 677 678 /* Assign the dimension as range-ref. */ 679 tmp = gfc_get_descriptor_dimension (lhs_desc); 680 tmp2 = gfc_get_descriptor_dimension (rhs_desc); 681 682 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); 683 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, 684 gfc_index_zero_node, NULL_TREE, NULL_TREE); 685 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, 686 gfc_index_zero_node, NULL_TREE, NULL_TREE); 687 gfc_add_modify (block, tmp, tmp2); 688} 689 690 691/* Takes a derived type expression and returns the address of a temporary 692 class object of the 'declared' type. If vptr is not NULL, this is 693 used for the temporary class object. 694 optional_alloc_ptr is false when the dummy is neither allocatable 695 nor a pointer; that's only relevant for the optional handling. 696 The optional argument 'derived_array' is used to preserve the parmse 697 expression for deallocation of allocatable components. Assumed rank 698 formal arguments made this necessary. */ 699void 700gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, 701 gfc_typespec class_ts, tree vptr, bool optional, 702 bool optional_alloc_ptr, 703 tree *derived_array) 704{ 705 gfc_symbol *vtab; 706 tree cond_optional = NULL_TREE; 707 gfc_ss *ss; 708 tree ctree; 709 tree var; 710 tree tmp; 711 int dim; 712 713 /* The derived type needs to be converted to a temporary 714 CLASS object. */ 715 tmp = gfc_typenode_for_spec (&class_ts); 716 var = gfc_create_var (tmp, "class"); 717 718 /* Set the vptr. */ 719 ctree = gfc_class_vptr_get (var); 720 721 if (vptr != NULL_TREE) 722 { 723 /* Use the dynamic vptr. */ 724 tmp = vptr; 725 } 726 else 727 { 728 /* In this case the vtab corresponds to the derived type and the 729 vptr must point to it. */ 730 vtab = gfc_find_derived_vtab (e->ts.u.derived); 731 gcc_assert (vtab); 732 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 733 } 734 gfc_add_modify (&parmse->pre, ctree, 735 fold_convert (TREE_TYPE (ctree), tmp)); 736 737 /* Now set the data field. */ 738 ctree = gfc_class_data_get (var); 739 740 if (optional) 741 cond_optional = gfc_conv_expr_present (e->symtree->n.sym); 742 743 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr))) 744 { 745 /* If there is a ready made pointer to a derived type, use it 746 rather than evaluating the expression again. */ 747 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 748 gfc_add_modify (&parmse->pre, ctree, tmp); 749 } 750 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags) 751 { 752 /* For an array reference in an elemental procedure call we need 753 to retain the ss to provide the scalarized array reference. */ 754 gfc_conv_expr_reference (parmse, e); 755 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 756 if (optional) 757 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), 758 cond_optional, tmp, 759 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 760 gfc_add_modify (&parmse->pre, ctree, tmp); 761 } 762 else 763 { 764 ss = gfc_walk_expr (e); 765 if (ss == gfc_ss_terminator) 766 { 767 parmse->ss = NULL; 768 gfc_conv_expr_reference (parmse, e); 769 770 /* Scalar to an assumed-rank array. */ 771 if (class_ts.u.derived->components->as) 772 { 773 tree type; 774 type = get_scalar_to_descriptor_type (parmse->expr, 775 gfc_expr_attr (e)); 776 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), 777 gfc_get_dtype (type)); 778 if (optional) 779 parmse->expr = build3_loc (input_location, COND_EXPR, 780 TREE_TYPE (parmse->expr), 781 cond_optional, parmse->expr, 782 fold_convert (TREE_TYPE (parmse->expr), 783 null_pointer_node)); 784 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr); 785 } 786 else 787 { 788 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 789 if (optional) 790 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), 791 cond_optional, tmp, 792 fold_convert (TREE_TYPE (tmp), 793 null_pointer_node)); 794 gfc_add_modify (&parmse->pre, ctree, tmp); 795 } 796 } 797 else 798 { 799 stmtblock_t block; 800 gfc_init_block (&block); 801 gfc_ref *ref; 802 803 parmse->ss = ss; 804 parmse->use_offset = 1; 805 gfc_conv_expr_descriptor (parmse, e); 806 807 /* Detect any array references with vector subscripts. */ 808 for (ref = e->ref; ref; ref = ref->next) 809 if (ref->type == REF_ARRAY 810 && ref->u.ar.type != AR_ELEMENT 811 && ref->u.ar.type != AR_FULL) 812 { 813 for (dim = 0; dim < ref->u.ar.dimen; dim++) 814 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) 815 break; 816 if (dim < ref->u.ar.dimen) 817 break; 818 } 819 820 /* Array references with vector subscripts and non-variable expressions 821 need be converted to a one-based descriptor. */ 822 if (ref || e->expr_type != EXPR_VARIABLE) 823 { 824 for (dim = 0; dim < e->rank; ++dim) 825 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim, 826 gfc_index_one_node); 827 } 828 829 if (e->rank != class_ts.u.derived->components->as->rank) 830 { 831 gcc_assert (class_ts.u.derived->components->as->type 832 == AS_ASSUMED_RANK); 833 if (derived_array 834 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))) 835 { 836 *derived_array = gfc_create_var (TREE_TYPE (parmse->expr), 837 "array"); 838 gfc_add_modify (&block, *derived_array , parmse->expr); 839 } 840 class_array_data_assign (&block, ctree, parmse->expr, false); 841 } 842 else 843 { 844 if (gfc_expr_attr (e).codimension) 845 parmse->expr = fold_build1_loc (input_location, 846 VIEW_CONVERT_EXPR, 847 TREE_TYPE (ctree), 848 parmse->expr); 849 gfc_add_modify (&block, ctree, parmse->expr); 850 } 851 852 if (optional) 853 { 854 tmp = gfc_finish_block (&block); 855 856 gfc_init_block (&block); 857 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node); 858 if (derived_array && *derived_array != NULL_TREE) 859 gfc_conv_descriptor_data_set (&block, *derived_array, 860 null_pointer_node); 861 862 tmp = build3_v (COND_EXPR, cond_optional, tmp, 863 gfc_finish_block (&block)); 864 gfc_add_expr_to_block (&parmse->pre, tmp); 865 } 866 else 867 gfc_add_block_to_block (&parmse->pre, &block); 868 } 869 } 870 871 if (class_ts.u.derived->components->ts.type == BT_DERIVED 872 && class_ts.u.derived->components->ts.u.derived 873 ->attr.unlimited_polymorphic) 874 { 875 /* Take care about initializing the _len component correctly. */ 876 ctree = gfc_class_len_get (var); 877 if (UNLIMITED_POLY (e)) 878 { 879 gfc_expr *len; 880 gfc_se se; 881 882 len = gfc_find_and_cut_at_last_class_ref (e); 883 gfc_add_len_component (len); 884 gfc_init_se (&se, NULL); 885 gfc_conv_expr (&se, len); 886 if (optional) 887 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr), 888 cond_optional, se.expr, 889 fold_convert (TREE_TYPE (se.expr), 890 integer_zero_node)); 891 else 892 tmp = se.expr; 893 gfc_free_expr (len); 894 } 895 else 896 tmp = integer_zero_node; 897 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), 898 tmp)); 899 } 900 /* Pass the address of the class object. */ 901 parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 902 903 if (optional && optional_alloc_ptr) 904 parmse->expr = build3_loc (input_location, COND_EXPR, 905 TREE_TYPE (parmse->expr), 906 cond_optional, parmse->expr, 907 fold_convert (TREE_TYPE (parmse->expr), 908 null_pointer_node)); 909} 910 911 912/* Create a new class container, which is required as scalar coarrays 913 have an array descriptor while normal scalars haven't. Optionally, 914 NULL pointer checks are added if the argument is OPTIONAL. */ 915 916static void 917class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, 918 gfc_typespec class_ts, bool optional) 919{ 920 tree var, ctree, tmp; 921 stmtblock_t block; 922 gfc_ref *ref; 923 gfc_ref *class_ref; 924 925 gfc_init_block (&block); 926 927 class_ref = NULL; 928 for (ref = e->ref; ref; ref = ref->next) 929 { 930 if (ref->type == REF_COMPONENT 931 && ref->u.c.component->ts.type == BT_CLASS) 932 class_ref = ref; 933 } 934 935 if (class_ref == NULL 936 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 937 tmp = e->symtree->n.sym->backend_decl; 938 else 939 { 940 /* Remove everything after the last class reference, convert the 941 expression and then recover its tailend once more. */ 942 gfc_se tmpse; 943 ref = class_ref->next; 944 class_ref->next = NULL; 945 gfc_init_se (&tmpse, NULL); 946 gfc_conv_expr (&tmpse, e); 947 class_ref->next = ref; 948 tmp = tmpse.expr; 949 } 950 951 var = gfc_typenode_for_spec (&class_ts); 952 var = gfc_create_var (var, "class"); 953 954 ctree = gfc_class_vptr_get (var); 955 gfc_add_modify (&block, ctree, 956 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp))); 957 958 ctree = gfc_class_data_get (var); 959 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp)); 960 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp)); 961 962 /* Pass the address of the class object. */ 963 parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 964 965 if (optional) 966 { 967 tree cond = gfc_conv_expr_present (e->symtree->n.sym); 968 tree tmp2; 969 970 tmp = gfc_finish_block (&block); 971 972 gfc_init_block (&block); 973 tmp2 = gfc_class_data_get (var); 974 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), 975 null_pointer_node)); 976 tmp2 = gfc_finish_block (&block); 977 978 tmp = build3_loc (input_location, COND_EXPR, void_type_node, 979 cond, tmp, tmp2); 980 gfc_add_expr_to_block (&parmse->pre, tmp); 981 } 982 else 983 gfc_add_block_to_block (&parmse->pre, &block); 984} 985 986 987/* Takes an intrinsic type expression and returns the address of a temporary 988 class object of the 'declared' type. */ 989void 990gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, 991 gfc_typespec class_ts) 992{ 993 gfc_symbol *vtab; 994 gfc_ss *ss; 995 tree ctree; 996 tree var; 997 tree tmp; 998 int dim; 999 1000 /* The intrinsic type needs to be converted to a temporary 1001 CLASS object. */ 1002 tmp = gfc_typenode_for_spec (&class_ts); 1003 var = gfc_create_var (tmp, "class"); 1004 1005 /* Set the vptr. */ 1006 ctree = gfc_class_vptr_get (var); 1007 1008 vtab = gfc_find_vtab (&e->ts); 1009 gcc_assert (vtab); 1010 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); 1011 gfc_add_modify (&parmse->pre, ctree, 1012 fold_convert (TREE_TYPE (ctree), tmp)); 1013 1014 /* Now set the data field. */ 1015 ctree = gfc_class_data_get (var); 1016 if (parmse->ss && parmse->ss->info->useflags) 1017 { 1018 /* For an array reference in an elemental procedure call we need 1019 to retain the ss to provide the scalarized array reference. */ 1020 gfc_conv_expr_reference (parmse, e); 1021 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 1022 gfc_add_modify (&parmse->pre, ctree, tmp); 1023 } 1024 else 1025 { 1026 ss = gfc_walk_expr (e); 1027 if (ss == gfc_ss_terminator) 1028 { 1029 parmse->ss = NULL; 1030 gfc_conv_expr_reference (parmse, e); 1031 if (class_ts.u.derived->components->as 1032 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK) 1033 { 1034 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr, 1035 gfc_expr_attr (e)); 1036 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, 1037 TREE_TYPE (ctree), tmp); 1038 } 1039 else 1040 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); 1041 gfc_add_modify (&parmse->pre, ctree, tmp); 1042 } 1043 else 1044 { 1045 parmse->ss = ss; 1046 parmse->use_offset = 1; 1047 gfc_conv_expr_descriptor (parmse, e); 1048 1049 /* Array references with vector subscripts and non-variable expressions 1050 need be converted to a one-based descriptor. */ 1051 if (e->expr_type != EXPR_VARIABLE) 1052 { 1053 for (dim = 0; dim < e->rank; ++dim) 1054 gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr, 1055 dim, gfc_index_one_node); 1056 } 1057 1058 if (class_ts.u.derived->components->as->rank != e->rank) 1059 { 1060 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, 1061 TREE_TYPE (ctree), parmse->expr); 1062 gfc_add_modify (&parmse->pre, ctree, tmp); 1063 } 1064 else 1065 gfc_add_modify (&parmse->pre, ctree, parmse->expr); 1066 } 1067 } 1068 1069 gcc_assert (class_ts.type == BT_CLASS); 1070 if (class_ts.u.derived->components->ts.type == BT_DERIVED 1071 && class_ts.u.derived->components->ts.u.derived 1072 ->attr.unlimited_polymorphic) 1073 { 1074 ctree = gfc_class_len_get (var); 1075 /* When the actual arg is a char array, then set the _len component of the 1076 unlimited polymorphic entity to the length of the string. */ 1077 if (e->ts.type == BT_CHARACTER) 1078 { 1079 /* Start with parmse->string_length because this seems to be set to a 1080 correct value more often. */ 1081 if (parmse->string_length) 1082 tmp = parmse->string_length; 1083 /* When the string_length is not yet set, then try the backend_decl of 1084 the cl. */ 1085 else if (e->ts.u.cl->backend_decl) 1086 tmp = e->ts.u.cl->backend_decl; 1087 /* If both of the above approaches fail, then try to generate an 1088 expression from the input, which is only feasible currently, when the 1089 expression can be evaluated to a constant one. */ 1090 else 1091 { 1092 /* Try to simplify the expression. */ 1093 gfc_simplify_expr (e, 0); 1094 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved) 1095 { 1096 /* Amazingly all data is present to compute the length of a 1097 constant string, but the expression is not yet there. */ 1098 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, 1099 gfc_charlen_int_kind, 1100 &e->where); 1101 mpz_set_ui (e->ts.u.cl->length->value.integer, 1102 e->value.character.length); 1103 gfc_conv_const_charlen (e->ts.u.cl); 1104 e->ts.u.cl->resolved = 1; 1105 tmp = e->ts.u.cl->backend_decl; 1106 } 1107 else 1108 { 1109 gfc_error ("Cannot compute the length of the char array " 1110 "at %L.", &e->where); 1111 } 1112 } 1113 } 1114 else 1115 tmp = integer_zero_node; 1116 1117 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); 1118 } 1119 else if (class_ts.type == BT_CLASS 1120 && class_ts.u.derived->components 1121 && class_ts.u.derived->components->ts.u 1122 .derived->attr.unlimited_polymorphic) 1123 { 1124 ctree = gfc_class_len_get (var); 1125 gfc_add_modify (&parmse->pre, ctree, 1126 fold_convert (TREE_TYPE (ctree), 1127 integer_zero_node)); 1128 } 1129 /* Pass the address of the class object. */ 1130 parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 1131} 1132 1133 1134/* Takes a scalarized class array expression and returns the 1135 address of a temporary scalar class object of the 'declared' 1136 type. 1137 OOP-TODO: This could be improved by adding code that branched on 1138 the dynamic type being the same as the declared type. In this case 1139 the original class expression can be passed directly. 1140 optional_alloc_ptr is false when the dummy is neither allocatable 1141 nor a pointer; that's relevant for the optional handling. 1142 Set copyback to true if class container's _data and _vtab pointers 1143 might get modified. */ 1144 1145void 1146gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, 1147 bool elemental, bool copyback, bool optional, 1148 bool optional_alloc_ptr) 1149{ 1150 tree ctree; 1151 tree var; 1152 tree tmp; 1153 tree vptr; 1154 tree cond = NULL_TREE; 1155 tree slen = NULL_TREE; 1156 gfc_ref *ref; 1157 gfc_ref *class_ref; 1158 stmtblock_t block; 1159 bool full_array = false; 1160 1161 gfc_init_block (&block); 1162 1163 class_ref = NULL; 1164 for (ref = e->ref; ref; ref = ref->next) 1165 { 1166 if (ref->type == REF_COMPONENT 1167 && ref->u.c.component->ts.type == BT_CLASS) 1168 class_ref = ref; 1169 1170 if (ref->next == NULL) 1171 break; 1172 } 1173 1174 if ((ref == NULL || class_ref == ref) 1175 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE) 1176 && (!class_ts.u.derived->components->as 1177 || class_ts.u.derived->components->as->rank != -1)) 1178 return; 1179 1180 /* Test for FULL_ARRAY. */ 1181 if (e->rank == 0 1182 && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension) 1183 || (class_ts.u.derived->components->as 1184 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK))) 1185 full_array = true; 1186 else 1187 gfc_is_class_array_ref (e, &full_array); 1188 1189 /* The derived type needs to be converted to a temporary 1190 CLASS object. */ 1191 tmp = gfc_typenode_for_spec (&class_ts); 1192 var = gfc_create_var (tmp, "class"); 1193 1194 /* Set the data. */ 1195 ctree = gfc_class_data_get (var); 1196 if (class_ts.u.derived->components->as 1197 && e->rank != class_ts.u.derived->components->as->rank) 1198 { 1199 if (e->rank == 0) 1200 { 1201 tree type = get_scalar_to_descriptor_type (parmse->expr, 1202 gfc_expr_attr (e)); 1203 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree), 1204 gfc_get_dtype (type)); 1205 1206 tmp = gfc_class_data_get (parmse->expr); 1207 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 1208 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 1209 1210 gfc_conv_descriptor_data_set (&block, ctree, tmp); 1211 } 1212 else 1213 class_array_data_assign (&block, ctree, parmse->expr, false); 1214 } 1215 else 1216 { 1217 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree)) 1218 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, 1219 TREE_TYPE (ctree), parmse->expr); 1220 gfc_add_modify (&block, ctree, parmse->expr); 1221 } 1222 1223 /* Return the data component, except in the case of scalarized array 1224 references, where nullification of the cannot occur and so there 1225 is no need. */ 1226 if (!elemental && full_array && copyback) 1227 { 1228 if (class_ts.u.derived->components->as 1229 && e->rank != class_ts.u.derived->components->as->rank) 1230 { 1231 if (e->rank == 0) 1232 { 1233 tmp = gfc_class_data_get (parmse->expr); 1234 gfc_add_modify (&parmse->post, tmp, 1235 fold_convert (TREE_TYPE (tmp), 1236 gfc_conv_descriptor_data_get (ctree))); 1237 } 1238 else 1239 class_array_data_assign (&parmse->post, parmse->expr, ctree, true); 1240 } 1241 else 1242 gfc_add_modify (&parmse->post, parmse->expr, ctree); 1243 } 1244 1245 /* Set the vptr. */ 1246 ctree = gfc_class_vptr_get (var); 1247 1248 /* The vptr is the second field of the actual argument. 1249 First we have to find the corresponding class reference. */ 1250 1251 tmp = NULL_TREE; 1252 if (gfc_is_class_array_function (e) 1253 && parmse->class_vptr != NULL_TREE) 1254 tmp = parmse->class_vptr; 1255 else if (class_ref == NULL 1256 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 1257 { 1258 tmp = e->symtree->n.sym->backend_decl; 1259 1260 if (TREE_CODE (tmp) == FUNCTION_DECL) 1261 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); 1262 1263 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) 1264 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); 1265 1266 slen = build_zero_cst (size_type_node); 1267 } 1268 else 1269 { 1270 /* Remove everything after the last class reference, convert the 1271 expression and then recover its tailend once more. */ 1272 gfc_se tmpse; 1273 ref = class_ref->next; 1274 class_ref->next = NULL; 1275 gfc_init_se (&tmpse, NULL); 1276 gfc_conv_expr (&tmpse, e); 1277 class_ref->next = ref; 1278 tmp = tmpse.expr; 1279 slen = tmpse.string_length; 1280 } 1281 1282 gcc_assert (tmp != NULL_TREE); 1283 1284 /* Dereference if needs be. */ 1285 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE) 1286 tmp = build_fold_indirect_ref_loc (input_location, tmp); 1287 1288 if (!(gfc_is_class_array_function (e) && parmse->class_vptr)) 1289 vptr = gfc_class_vptr_get (tmp); 1290 else 1291 vptr = tmp; 1292 1293 gfc_add_modify (&block, ctree, 1294 fold_convert (TREE_TYPE (ctree), vptr)); 1295 1296 /* Return the vptr component, except in the case of scalarized array 1297 references, where the dynamic type cannot change. */ 1298 if (!elemental && full_array && copyback) 1299 gfc_add_modify (&parmse->post, vptr, 1300 fold_convert (TREE_TYPE (vptr), ctree)); 1301 1302 /* For unlimited polymorphic objects also set the _len component. */ 1303 if (class_ts.type == BT_CLASS 1304 && class_ts.u.derived->components 1305 && class_ts.u.derived->components->ts.u 1306 .derived->attr.unlimited_polymorphic) 1307 { 1308 ctree = gfc_class_len_get (var); 1309 if (UNLIMITED_POLY (e)) 1310 tmp = gfc_class_len_get (tmp); 1311 else if (e->ts.type == BT_CHARACTER) 1312 { 1313 gcc_assert (slen != NULL_TREE); 1314 tmp = slen; 1315 } 1316 else 1317 tmp = build_zero_cst (size_type_node); 1318 gfc_add_modify (&parmse->pre, ctree, 1319 fold_convert (TREE_TYPE (ctree), tmp)); 1320 1321 /* Return the len component, except in the case of scalarized array 1322 references, where the dynamic type cannot change. */ 1323 if (!elemental && full_array && copyback 1324 && (UNLIMITED_POLY (e) || VAR_P (tmp))) 1325 gfc_add_modify (&parmse->post, tmp, 1326 fold_convert (TREE_TYPE (tmp), ctree)); 1327 } 1328 1329 if (optional) 1330 { 1331 tree tmp2; 1332 1333 cond = gfc_conv_expr_present (e->symtree->n.sym); 1334 /* parmse->pre may contain some preparatory instructions for the 1335 temporary array descriptor. Those may only be executed when the 1336 optional argument is set, therefore add parmse->pre's instructions 1337 to block, which is later guarded by an if (optional_arg_given). */ 1338 gfc_add_block_to_block (&parmse->pre, &block); 1339 block.head = parmse->pre.head; 1340 parmse->pre.head = NULL_TREE; 1341 tmp = gfc_finish_block (&block); 1342 1343 if (optional_alloc_ptr) 1344 tmp2 = build_empty_stmt (input_location); 1345 else 1346 { 1347 gfc_init_block (&block); 1348 1349 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var)); 1350 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), 1351 null_pointer_node)); 1352 tmp2 = gfc_finish_block (&block); 1353 } 1354 1355 tmp = build3_loc (input_location, COND_EXPR, void_type_node, 1356 cond, tmp, tmp2); 1357 gfc_add_expr_to_block (&parmse->pre, tmp); 1358 } 1359 else 1360 gfc_add_block_to_block (&parmse->pre, &block); 1361 1362 /* Pass the address of the class object. */ 1363 parmse->expr = gfc_build_addr_expr (NULL_TREE, var); 1364 1365 if (optional && optional_alloc_ptr) 1366 parmse->expr = build3_loc (input_location, COND_EXPR, 1367 TREE_TYPE (parmse->expr), 1368 cond, parmse->expr, 1369 fold_convert (TREE_TYPE (parmse->expr), 1370 null_pointer_node)); 1371} 1372 1373 1374/* Given a class array declaration and an index, returns the address 1375 of the referenced element. */ 1376 1377static tree 1378gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp, 1379 bool unlimited) 1380{ 1381 tree data, size, tmp, ctmp, offset, ptr; 1382 1383 data = data_comp != NULL_TREE ? data_comp : 1384 gfc_class_data_get (class_decl); 1385 size = gfc_class_vtab_size_get (class_decl); 1386 1387 if (unlimited) 1388 { 1389 tmp = fold_convert (gfc_array_index_type, 1390 gfc_class_len_get (class_decl)); 1391 ctmp = fold_build2_loc (input_location, MULT_EXPR, 1392 gfc_array_index_type, size, tmp); 1393 tmp = fold_build2_loc (input_location, GT_EXPR, 1394 logical_type_node, tmp, 1395 build_zero_cst (TREE_TYPE (tmp))); 1396 size = fold_build3_loc (input_location, COND_EXPR, 1397 gfc_array_index_type, tmp, ctmp, size); 1398 } 1399 1400 offset = fold_build2_loc (input_location, MULT_EXPR, 1401 gfc_array_index_type, 1402 index, size); 1403 1404 data = gfc_conv_descriptor_data_get (data); 1405 ptr = fold_convert (pvoid_type_node, data); 1406 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset); 1407 return fold_convert (TREE_TYPE (data), ptr); 1408} 1409 1410 1411/* Copies one class expression to another, assuming that if either 1412 'to' or 'from' are arrays they are packed. Should 'from' be 1413 NULL_TREE, the initialization expression for 'to' is used, assuming 1414 that the _vptr is set. */ 1415 1416tree 1417gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) 1418{ 1419 tree fcn; 1420 tree fcn_type; 1421 tree from_data; 1422 tree from_len; 1423 tree to_data; 1424 tree to_len; 1425 tree to_ref; 1426 tree from_ref; 1427 vec<tree, va_gc> *args; 1428 tree tmp; 1429 tree stdcopy; 1430 tree extcopy; 1431 tree index; 1432 bool is_from_desc = false, is_to_class = false; 1433 1434 args = NULL; 1435 /* To prevent warnings on uninitialized variables. */ 1436 from_len = to_len = NULL_TREE; 1437 1438 if (from != NULL_TREE) 1439 fcn = gfc_class_vtab_copy_get (from); 1440 else 1441 fcn = gfc_class_vtab_copy_get (to); 1442 1443 fcn_type = TREE_TYPE (TREE_TYPE (fcn)); 1444 1445 if (from != NULL_TREE) 1446 { 1447 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from)); 1448 if (is_from_desc) 1449 { 1450 from_data = from; 1451 from = GFC_DECL_SAVED_DESCRIPTOR (from); 1452 } 1453 else 1454 { 1455 /* Check that from is a class. When the class is part of a coarray, 1456 then from is a common pointer and is to be used as is. */ 1457 tmp = POINTER_TYPE_P (TREE_TYPE (from)) 1458 ? build_fold_indirect_ref (from) : from; 1459 from_data = 1460 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) 1461 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp))) 1462 ? gfc_class_data_get (from) : from; 1463 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)); 1464 } 1465 } 1466 else 1467 from_data = gfc_class_vtab_def_init_get (to); 1468 1469 if (unlimited) 1470 { 1471 if (from != NULL_TREE && unlimited) 1472 from_len = gfc_class_len_or_zero_get (from); 1473 else 1474 from_len = build_zero_cst (size_type_node); 1475 } 1476 1477 if (GFC_CLASS_TYPE_P (TREE_TYPE (to))) 1478 { 1479 is_to_class = true; 1480 to_data = gfc_class_data_get (to); 1481 if (unlimited) 1482 to_len = gfc_class_len_get (to); 1483 } 1484 else 1485 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */ 1486 to_data = to; 1487 1488 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) 1489 { 1490 stmtblock_t loopbody; 1491 stmtblock_t body; 1492 stmtblock_t ifbody; 1493 gfc_loopinfo loop; 1494 tree orig_nelems = nelems; /* Needed for bounds check. */ 1495 1496 gfc_init_block (&body); 1497 tmp = fold_build2_loc (input_location, MINUS_EXPR, 1498 gfc_array_index_type, nelems, 1499 gfc_index_one_node); 1500 nelems = gfc_evaluate_now (tmp, &body); 1501 index = gfc_create_var (gfc_array_index_type, "S"); 1502 1503 if (is_from_desc) 1504 { 1505 from_ref = gfc_get_class_array_ref (index, from, from_data, 1506 unlimited); 1507 vec_safe_push (args, from_ref); 1508 } 1509 else 1510 vec_safe_push (args, from_data); 1511 1512 if (is_to_class) 1513 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited); 1514 else 1515 { 1516 tmp = gfc_conv_array_data (to); 1517 tmp = build_fold_indirect_ref_loc (input_location, tmp); 1518 to_ref = gfc_build_addr_expr (NULL_TREE, 1519 gfc_build_array_ref (tmp, index, to)); 1520 } 1521 vec_safe_push (args, to_ref); 1522 1523 /* Add bounds check. */ 1524 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc) 1525 { 1526 char *msg; 1527 const char *name = "<<unknown>>"; 1528 tree from_len; 1529 1530 if (DECL_P (to)) 1531 name = (const char *)(DECL_NAME (to)->identifier.id.str); 1532 1533 from_len = gfc_conv_descriptor_size (from_data, 1); 1534 from_len = fold_convert (TREE_TYPE (orig_nelems), from_len); 1535 tmp = fold_build2_loc (input_location, NE_EXPR, 1536 logical_type_node, from_len, orig_nelems); 1537 msg = xasprintf ("Array bound mismatch for dimension %d " 1538 "of array '%s' (%%ld/%%ld)", 1539 1, name); 1540 1541 gfc_trans_runtime_check (true, false, tmp, &body, 1542 &gfc_current_locus, msg, 1543 fold_convert (long_integer_type_node, orig_nelems), 1544 fold_convert (long_integer_type_node, from_len)); 1545 1546 free (msg); 1547 } 1548 1549 tmp = build_call_vec (fcn_type, fcn, args); 1550 1551 /* Build the body of the loop. */ 1552 gfc_init_block (&loopbody); 1553 gfc_add_expr_to_block (&loopbody, tmp); 1554 1555 /* Build the loop and return. */ 1556 gfc_init_loopinfo (&loop); 1557 loop.dimen = 1; 1558 loop.from[0] = gfc_index_zero_node; 1559 loop.loopvar[0] = index; 1560 loop.to[0] = nelems; 1561 gfc_trans_scalarizing_loops (&loop, &loopbody); 1562 gfc_init_block (&ifbody); 1563 gfc_add_block_to_block (&ifbody, &loop.pre); 1564 stdcopy = gfc_finish_block (&ifbody); 1565 /* In initialization mode from_len is a constant zero. */ 1566 if (unlimited && !integer_zerop (from_len)) 1567 { 1568 vec_safe_push (args, from_len); 1569 vec_safe_push (args, to_len); 1570 tmp = build_call_vec (fcn_type, fcn, args); 1571 /* Build the body of the loop. */ 1572 gfc_init_block (&loopbody); 1573 gfc_add_expr_to_block (&loopbody, tmp); 1574 1575 /* Build the loop and return. */ 1576 gfc_init_loopinfo (&loop); 1577 loop.dimen = 1; 1578 loop.from[0] = gfc_index_zero_node; 1579 loop.loopvar[0] = index; 1580 loop.to[0] = nelems; 1581 gfc_trans_scalarizing_loops (&loop, &loopbody); 1582 gfc_init_block (&ifbody); 1583 gfc_add_block_to_block (&ifbody, &loop.pre); 1584 extcopy = gfc_finish_block (&ifbody); 1585 1586 tmp = fold_build2_loc (input_location, GT_EXPR, 1587 logical_type_node, from_len, 1588 build_zero_cst (TREE_TYPE (from_len))); 1589 tmp = fold_build3_loc (input_location, COND_EXPR, 1590 void_type_node, tmp, extcopy, stdcopy); 1591 gfc_add_expr_to_block (&body, tmp); 1592 tmp = gfc_finish_block (&body); 1593 } 1594 else 1595 { 1596 gfc_add_expr_to_block (&body, stdcopy); 1597 tmp = gfc_finish_block (&body); 1598 } 1599 gfc_cleanup_loop (&loop); 1600 } 1601 else 1602 { 1603 gcc_assert (!is_from_desc); 1604 vec_safe_push (args, from_data); 1605 vec_safe_push (args, to_data); 1606 stdcopy = build_call_vec (fcn_type, fcn, args); 1607 1608 /* In initialization mode from_len is a constant zero. */ 1609 if (unlimited && !integer_zerop (from_len)) 1610 { 1611 vec_safe_push (args, from_len); 1612 vec_safe_push (args, to_len); 1613 extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args); 1614 tmp = fold_build2_loc (input_location, GT_EXPR, 1615 logical_type_node, from_len, 1616 build_zero_cst (TREE_TYPE (from_len))); 1617 tmp = fold_build3_loc (input_location, COND_EXPR, 1618 void_type_node, tmp, extcopy, stdcopy); 1619 } 1620 else 1621 tmp = stdcopy; 1622 } 1623 1624 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */ 1625 if (from == NULL_TREE) 1626 { 1627 tree cond; 1628 cond = fold_build2_loc (input_location, NE_EXPR, 1629 logical_type_node, 1630 from_data, null_pointer_node); 1631 tmp = fold_build3_loc (input_location, COND_EXPR, 1632 void_type_node, cond, 1633 tmp, build_empty_stmt (input_location)); 1634 } 1635 1636 return tmp; 1637} 1638 1639 1640static tree 1641gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) 1642{ 1643 gfc_actual_arglist *actual; 1644 gfc_expr *ppc; 1645 gfc_code *ppc_code; 1646 tree res; 1647 1648 actual = gfc_get_actual_arglist (); 1649 actual->expr = gfc_copy_expr (rhs); 1650 actual->next = gfc_get_actual_arglist (); 1651 actual->next->expr = gfc_copy_expr (lhs); 1652 ppc = gfc_copy_expr (obj); 1653 gfc_add_vptr_component (ppc); 1654 gfc_add_component_ref (ppc, "_copy"); 1655 ppc_code = gfc_get_code (EXEC_CALL); 1656 ppc_code->resolved_sym = ppc->symtree->n.sym; 1657 /* Although '_copy' is set to be elemental in class.cc, it is 1658 not staying that way. Find out why, sometime.... */ 1659 ppc_code->resolved_sym->attr.elemental = 1; 1660 ppc_code->ext.actual = actual; 1661 ppc_code->expr1 = ppc; 1662 /* Since '_copy' is elemental, the scalarizer will take care 1663 of arrays in gfc_trans_call. */ 1664 res = gfc_trans_call (ppc_code, false, NULL, NULL, false); 1665 gfc_free_statements (ppc_code); 1666 1667 if (UNLIMITED_POLY(obj)) 1668 { 1669 /* Check if rhs is non-NULL. */ 1670 gfc_se src; 1671 gfc_init_se (&src, NULL); 1672 gfc_conv_expr (&src, rhs); 1673 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); 1674 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1675 src.expr, fold_convert (TREE_TYPE (src.expr), 1676 null_pointer_node)); 1677 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res, 1678 build_empty_stmt (input_location)); 1679 } 1680 1681 return res; 1682} 1683 1684/* Special case for initializing a polymorphic dummy with INTENT(OUT). 1685 A MEMCPY is needed to copy the full data from the default initializer 1686 of the dynamic type. */ 1687 1688tree 1689gfc_trans_class_init_assign (gfc_code *code) 1690{ 1691 stmtblock_t block; 1692 tree tmp; 1693 gfc_se dst,src,memsz; 1694 gfc_expr *lhs, *rhs, *sz; 1695 1696 gfc_start_block (&block); 1697 1698 lhs = gfc_copy_expr (code->expr1); 1699 1700 rhs = gfc_copy_expr (code->expr1); 1701 gfc_add_vptr_component (rhs); 1702 1703 /* Make sure that the component backend_decls have been built, which 1704 will not have happened if the derived types concerned have not 1705 been referenced. */ 1706 gfc_get_derived_type (rhs->ts.u.derived); 1707 gfc_add_def_init_component (rhs); 1708 /* The _def_init is always scalar. */ 1709 rhs->rank = 0; 1710 1711 if (code->expr1->ts.type == BT_CLASS 1712 && CLASS_DATA (code->expr1)->attr.dimension) 1713 { 1714 gfc_array_spec *tmparr = gfc_get_array_spec (); 1715 *tmparr = *CLASS_DATA (code->expr1)->as; 1716 /* Adding the array ref to the class expression results in correct 1717 indexing to the dynamic type. */ 1718 gfc_add_full_array_ref (lhs, tmparr); 1719 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); 1720 } 1721 else 1722 { 1723 /* Scalar initialization needs the _data component. */ 1724 gfc_add_data_component (lhs); 1725 sz = gfc_copy_expr (code->expr1); 1726 gfc_add_vptr_component (sz); 1727 gfc_add_size_component (sz); 1728 1729 gfc_init_se (&dst, NULL); 1730 gfc_init_se (&src, NULL); 1731 gfc_init_se (&memsz, NULL); 1732 gfc_conv_expr (&dst, lhs); 1733 gfc_conv_expr (&src, rhs); 1734 gfc_conv_expr (&memsz, sz); 1735 gfc_add_block_to_block (&block, &src.pre); 1736 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); 1737 1738 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); 1739 1740 if (UNLIMITED_POLY(code->expr1)) 1741 { 1742 /* Check if _def_init is non-NULL. */ 1743 tree cond = fold_build2_loc (input_location, NE_EXPR, 1744 logical_type_node, src.expr, 1745 fold_convert (TREE_TYPE (src.expr), 1746 null_pointer_node)); 1747 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, 1748 tmp, build_empty_stmt (input_location)); 1749 } 1750 } 1751 1752 if (code->expr1->symtree->n.sym->attr.dummy 1753 && (code->expr1->symtree->n.sym->attr.optional 1754 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)) 1755 { 1756 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym); 1757 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), 1758 present, tmp, 1759 build_empty_stmt (input_location)); 1760 } 1761 1762 gfc_add_expr_to_block (&block, tmp); 1763 1764 return gfc_finish_block (&block); 1765} 1766 1767 1768/* Class valued elemental function calls or class array elements arriving 1769 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy 1770 is used to ensure that the rhs dynamic type is assigned to the lhs. */ 1771 1772static bool 1773trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse) 1774{ 1775 tree fcn; 1776 tree rse_expr; 1777 tree class_data; 1778 tree tmp; 1779 tree zero; 1780 tree cond; 1781 tree final_cond; 1782 stmtblock_t inner_block; 1783 bool is_descriptor; 1784 bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR; 1785 bool not_lhs_array_type; 1786 1787 /* Temporaries arising from dependencies in assignment get cast as a 1788 character type of the dynamic size of the rhs. Use the vptr copy 1789 for this case. */ 1790 tmp = TREE_TYPE (lse->expr); 1791 not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE 1792 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE); 1793 1794 /* Use ordinary assignment if the rhs is not a call expression or 1795 the lhs is not a class entity or an array(ie. character) type. */ 1796 if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE) 1797 && not_lhs_array_type) 1798 return false; 1799 1800 /* Ordinary assignment can be used if both sides are class expressions 1801 since the dynamic type is preserved by copying the vptr. This 1802 should only occur, where temporaries are involved. */ 1803 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) 1804 && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) 1805 return false; 1806 1807 /* Fix the class expression and the class data of the rhs. */ 1808 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) 1809 || not_call_expr) 1810 { 1811 tmp = gfc_get_class_from_expr (rse->expr); 1812 if (tmp == NULL_TREE) 1813 return false; 1814 rse_expr = gfc_evaluate_now (tmp, block); 1815 } 1816 else 1817 rse_expr = gfc_evaluate_now (rse->expr, block); 1818 1819 class_data = gfc_class_data_get (rse_expr); 1820 1821 /* Check that the rhs data is not null. */ 1822 is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data)); 1823 if (is_descriptor) 1824 class_data = gfc_conv_descriptor_data_get (class_data); 1825 class_data = gfc_evaluate_now (class_data, block); 1826 1827 zero = build_int_cst (TREE_TYPE (class_data), 0); 1828 cond = fold_build2_loc (input_location, NE_EXPR, 1829 logical_type_node, 1830 class_data, zero); 1831 1832 /* Copy the rhs to the lhs. */ 1833 fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr)); 1834 fcn = build_fold_indirect_ref_loc (input_location, fcn); 1835 tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block); 1836 tmp = is_descriptor ? tmp : class_data; 1837 tmp = build_call_expr_loc (input_location, fcn, 2, tmp, 1838 gfc_build_addr_expr (NULL, lse->expr)); 1839 gfc_add_expr_to_block (block, tmp); 1840 1841 /* Only elemental function results need to be finalised and freed. */ 1842 if (not_call_expr) 1843 return true; 1844 1845 /* Finalize the class data if needed. */ 1846 gfc_init_block (&inner_block); 1847 fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr)); 1848 zero = build_int_cst (TREE_TYPE (fcn), 0); 1849 final_cond = fold_build2_loc (input_location, NE_EXPR, 1850 logical_type_node, fcn, zero); 1851 fcn = build_fold_indirect_ref_loc (input_location, fcn); 1852 tmp = build_call_expr_loc (input_location, fcn, 1, class_data); 1853 tmp = build3_v (COND_EXPR, final_cond, 1854 tmp, build_empty_stmt (input_location)); 1855 gfc_add_expr_to_block (&inner_block, tmp); 1856 1857 /* Free the class data. */ 1858 tmp = gfc_call_free (class_data); 1859 tmp = build3_v (COND_EXPR, cond, tmp, 1860 build_empty_stmt (input_location)); 1861 gfc_add_expr_to_block (&inner_block, tmp); 1862 1863 /* Finish the inner block and subject it to the condition on the 1864 class data being non-zero. */ 1865 tmp = gfc_finish_block (&inner_block); 1866 tmp = build3_v (COND_EXPR, cond, tmp, 1867 build_empty_stmt (input_location)); 1868 gfc_add_expr_to_block (block, tmp); 1869 1870 return true; 1871} 1872 1873/* End of prototype trans-class.c */ 1874 1875 1876static void 1877realloc_lhs_warning (bt type, bool array, locus *where) 1878{ 1879 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs) 1880 gfc_warning (OPT_Wrealloc_lhs, 1881 "Code for reallocating the allocatable array at %L will " 1882 "be added", where); 1883 else if (warn_realloc_lhs_all) 1884 gfc_warning (OPT_Wrealloc_lhs_all, 1885 "Code for reallocating the allocatable variable at %L " 1886 "will be added", where); 1887} 1888 1889 1890static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, 1891 gfc_expr *); 1892 1893/* Copy the scalarization loop variables. */ 1894 1895static void 1896gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src) 1897{ 1898 dest->ss = src->ss; 1899 dest->loop = src->loop; 1900} 1901 1902 1903/* Initialize a simple expression holder. 1904 1905 Care must be taken when multiple se are created with the same parent. 1906 The child se must be kept in sync. The easiest way is to delay creation 1907 of a child se until after the previous se has been translated. */ 1908 1909void 1910gfc_init_se (gfc_se * se, gfc_se * parent) 1911{ 1912 memset (se, 0, sizeof (gfc_se)); 1913 gfc_init_block (&se->pre); 1914 gfc_init_block (&se->post); 1915 1916 se->parent = parent; 1917 1918 if (parent) 1919 gfc_copy_se_loopvars (se, parent); 1920} 1921 1922 1923/* Advances to the next SS in the chain. Use this rather than setting 1924 se->ss = se->ss->next because all the parents needs to be kept in sync. 1925 See gfc_init_se. */ 1926 1927void 1928gfc_advance_se_ss_chain (gfc_se * se) 1929{ 1930 gfc_se *p; 1931 gfc_ss *ss; 1932 1933 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator); 1934 1935 p = se; 1936 /* Walk down the parent chain. */ 1937 while (p != NULL) 1938 { 1939 /* Simple consistency check. */ 1940 gcc_assert (p->parent == NULL || p->parent->ss == p->ss 1941 || p->parent->ss->nested_ss == p->ss); 1942 1943 /* If we were in a nested loop, the next scalarized expression can be 1944 on the parent ss' next pointer. Thus we should not take the next 1945 pointer blindly, but rather go up one nest level as long as next 1946 is the end of chain. */ 1947 ss = p->ss; 1948 while (ss->next == gfc_ss_terminator && ss->parent != NULL) 1949 ss = ss->parent; 1950 1951 p->ss = ss->next; 1952 1953 p = p->parent; 1954 } 1955} 1956 1957 1958/* Ensures the result of the expression as either a temporary variable 1959 or a constant so that it can be used repeatedly. */ 1960 1961void 1962gfc_make_safe_expr (gfc_se * se) 1963{ 1964 tree var; 1965 1966 if (CONSTANT_CLASS_P (se->expr)) 1967 return; 1968 1969 /* We need a temporary for this result. */ 1970 var = gfc_create_var (TREE_TYPE (se->expr), NULL); 1971 gfc_add_modify (&se->pre, var, se->expr); 1972 se->expr = var; 1973} 1974 1975 1976/* Return an expression which determines if a dummy parameter is present. 1977 Also used for arguments to procedures with multiple entry points. */ 1978 1979tree 1980gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc) 1981{ 1982 tree decl, orig_decl, cond; 1983 1984 gcc_assert (sym->attr.dummy); 1985 orig_decl = decl = gfc_get_symbol_decl (sym); 1986 1987 /* Intrinsic scalars with VALUE attribute which are passed by value 1988 use a hidden argument to denote the present status. */ 1989 if (sym->attr.value && sym->ts.type != BT_CHARACTER 1990 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED 1991 && !sym->attr.dimension) 1992 { 1993 char name[GFC_MAX_SYMBOL_LEN + 2]; 1994 tree tree_name; 1995 1996 gcc_assert (TREE_CODE (decl) == PARM_DECL); 1997 name[0] = '_'; 1998 strcpy (&name[1], sym->name); 1999 tree_name = get_identifier (name); 2000 2001 /* Walk function argument list to find hidden arg. */ 2002 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl)); 2003 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond)) 2004 if (DECL_NAME (cond) == tree_name 2005 && DECL_ARTIFICIAL (cond)) 2006 break; 2007 2008 gcc_assert (cond); 2009 return cond; 2010 } 2011 2012 /* Assumed-shape arrays use a local variable for the array data; 2013 the actual PARAM_DECL is in a saved decl. As the local variable 2014 is NULL, it can be checked instead, unless use_saved_desc is 2015 requested. */ 2016 2017 if (use_saved_desc && TREE_CODE (decl) != PARM_DECL) 2018 { 2019 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) 2020 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); 2021 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 2022 } 2023 2024 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl, 2025 fold_convert (TREE_TYPE (decl), null_pointer_node)); 2026 2027 /* Fortran 2008 allows to pass null pointers and non-associated pointers 2028 as actual argument to denote absent dummies. For array descriptors, 2029 we thus also need to check the array descriptor. For BT_CLASS, it 2030 can also occur for scalars and F2003 due to type->class wrapping and 2031 class->class wrapping. Note further that BT_CLASS always uses an 2032 array descriptor for arrays, also for explicit-shape/assumed-size. 2033 For assumed-rank arrays, no local variable is generated, hence, 2034 the following also applies with !use_saved_desc. */ 2035 2036 if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL) 2037 && !sym->attr.allocatable 2038 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer) 2039 || (sym->ts.type == BT_CLASS 2040 && !CLASS_DATA (sym)->attr.allocatable 2041 && !CLASS_DATA (sym)->attr.class_pointer)) 2042 && ((gfc_option.allow_std & GFC_STD_F2008) != 0 2043 || sym->ts.type == BT_CLASS)) 2044 { 2045 tree tmp; 2046 2047 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE 2048 || sym->as->type == AS_ASSUMED_RANK 2049 || sym->attr.codimension)) 2050 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)) 2051 { 2052 tmp = build_fold_indirect_ref_loc (input_location, decl); 2053 if (sym->ts.type == BT_CLASS) 2054 tmp = gfc_class_data_get (tmp); 2055 tmp = gfc_conv_array_data (tmp); 2056 } 2057 else if (sym->ts.type == BT_CLASS) 2058 tmp = gfc_class_data_get (decl); 2059 else 2060 tmp = NULL_TREE; 2061 2062 if (tmp != NULL_TREE) 2063 { 2064 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, 2065 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 2066 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 2067 logical_type_node, cond, tmp); 2068 } 2069 } 2070 2071 return cond; 2072} 2073 2074 2075/* Converts a missing, dummy argument into a null or zero. */ 2076 2077void 2078gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) 2079{ 2080 tree present; 2081 tree tmp; 2082 2083 present = gfc_conv_expr_present (arg->symtree->n.sym); 2084 2085 if (kind > 0) 2086 { 2087 /* Create a temporary and convert it to the correct type. */ 2088 tmp = gfc_get_int_type (kind); 2089 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, 2090 se->expr)); 2091 2092 /* Test for a NULL value. */ 2093 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, 2094 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); 2095 tmp = gfc_evaluate_now (tmp, &se->pre); 2096 se->expr = gfc_build_addr_expr (NULL_TREE, tmp); 2097 } 2098 else 2099 { 2100 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), 2101 present, se->expr, 2102 build_zero_cst (TREE_TYPE (se->expr))); 2103 tmp = gfc_evaluate_now (tmp, &se->pre); 2104 se->expr = tmp; 2105 } 2106 2107 if (ts.type == BT_CHARACTER) 2108 { 2109 tmp = build_int_cst (gfc_charlen_type_node, 0); 2110 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, 2111 present, se->string_length, tmp); 2112 tmp = gfc_evaluate_now (tmp, &se->pre); 2113 se->string_length = tmp; 2114 } 2115 return; 2116} 2117 2118 2119/* Get the character length of an expression, looking through gfc_refs 2120 if necessary. */ 2121 2122tree 2123gfc_get_expr_charlen (gfc_expr *e) 2124{ 2125 gfc_ref *r; 2126 tree length; 2127 gfc_se se; 2128 2129 gcc_assert (e->expr_type == EXPR_VARIABLE 2130 && e->ts.type == BT_CHARACTER); 2131 2132 length = NULL; /* To silence compiler warning. */ 2133 2134 if (is_subref_array (e) && e->ts.u.cl->length) 2135 { 2136 gfc_se tmpse; 2137 gfc_init_se (&tmpse, NULL); 2138 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node); 2139 e->ts.u.cl->backend_decl = tmpse.expr; 2140 return tmpse.expr; 2141 } 2142 2143 /* First candidate: if the variable is of type CHARACTER, the 2144 expression's length could be the length of the character 2145 variable. */ 2146 if (e->symtree->n.sym->ts.type == BT_CHARACTER) 2147 length = e->symtree->n.sym->ts.u.cl->backend_decl; 2148 2149 /* Look through the reference chain for component references. */ 2150 for (r = e->ref; r; r = r->next) 2151 { 2152 switch (r->type) 2153 { 2154 case REF_COMPONENT: 2155 if (r->u.c.component->ts.type == BT_CHARACTER) 2156 length = r->u.c.component->ts.u.cl->backend_decl; 2157 break; 2158 2159 case REF_ARRAY: 2160 /* Do nothing. */ 2161 break; 2162 2163 case REF_SUBSTRING: 2164 gfc_init_se (&se, NULL); 2165 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node); 2166 length = se.expr; 2167 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); 2168 length = fold_build2_loc (input_location, MINUS_EXPR, 2169 gfc_charlen_type_node, 2170 se.expr, length); 2171 length = fold_build2_loc (input_location, PLUS_EXPR, 2172 gfc_charlen_type_node, length, 2173 gfc_index_one_node); 2174 break; 2175 2176 default: 2177 gcc_unreachable (); 2178 break; 2179 } 2180 } 2181 2182 gcc_assert (length != NULL); 2183 return length; 2184} 2185 2186 2187/* Return for an expression the backend decl of the coarray. */ 2188 2189tree 2190gfc_get_tree_for_caf_expr (gfc_expr *expr) 2191{ 2192 tree caf_decl; 2193 bool found = false; 2194 gfc_ref *ref; 2195 2196 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE); 2197 2198 /* Not-implemented diagnostic. */ 2199 if (expr->symtree->n.sym->ts.type == BT_CLASS 2200 && UNLIMITED_POLY (expr->symtree->n.sym) 2201 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension) 2202 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at " 2203 "%L is not supported", &expr->where); 2204 2205 for (ref = expr->ref; ref; ref = ref->next) 2206 if (ref->type == REF_COMPONENT) 2207 { 2208 if (ref->u.c.component->ts.type == BT_CLASS 2209 && UNLIMITED_POLY (ref->u.c.component) 2210 && CLASS_DATA (ref->u.c.component)->attr.codimension) 2211 gfc_error ("Sorry, coindexed access to an unlimited polymorphic " 2212 "component at %L is not supported", &expr->where); 2213 } 2214 2215 /* Make sure the backend_decl is present before accessing it. */ 2216 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE 2217 ? gfc_get_symbol_decl (expr->symtree->n.sym) 2218 : expr->symtree->n.sym->backend_decl; 2219 2220 if (expr->symtree->n.sym->ts.type == BT_CLASS) 2221 { 2222 if (expr->ref && expr->ref->type == REF_ARRAY) 2223 { 2224 caf_decl = gfc_class_data_get (caf_decl); 2225 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) 2226 return caf_decl; 2227 } 2228 for (ref = expr->ref; ref; ref = ref->next) 2229 { 2230 if (ref->type == REF_COMPONENT 2231 && strcmp (ref->u.c.component->name, "_data") != 0) 2232 { 2233 caf_decl = gfc_class_data_get (caf_decl); 2234 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) 2235 return caf_decl; 2236 break; 2237 } 2238 else if (ref->type == REF_ARRAY && ref->u.ar.dimen) 2239 break; 2240 } 2241 } 2242 if (expr->symtree->n.sym->attr.codimension) 2243 return caf_decl; 2244 2245 /* The following code assumes that the coarray is a component reachable via 2246 only scalar components/variables; the Fortran standard guarantees this. */ 2247 2248 for (ref = expr->ref; ref; ref = ref->next) 2249 if (ref->type == REF_COMPONENT) 2250 { 2251 gfc_component *comp = ref->u.c.component; 2252 2253 if (POINTER_TYPE_P (TREE_TYPE (caf_decl))) 2254 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); 2255 caf_decl = fold_build3_loc (input_location, COMPONENT_REF, 2256 TREE_TYPE (comp->backend_decl), caf_decl, 2257 comp->backend_decl, NULL_TREE); 2258 if (comp->ts.type == BT_CLASS) 2259 { 2260 caf_decl = gfc_class_data_get (caf_decl); 2261 if (CLASS_DATA (comp)->attr.codimension) 2262 { 2263 found = true; 2264 break; 2265 } 2266 } 2267 if (comp->attr.codimension) 2268 { 2269 found = true; 2270 break; 2271 } 2272 } 2273 gcc_assert (found && caf_decl); 2274 return caf_decl; 2275} 2276 2277 2278/* Obtain the Coarray token - and optionally also the offset. */ 2279 2280void 2281gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl, 2282 tree se_expr, gfc_expr *expr) 2283{ 2284 tree tmp; 2285 2286 /* Coarray token. */ 2287 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) 2288 { 2289 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) 2290 == GFC_ARRAY_ALLOCATABLE 2291 || expr->symtree->n.sym->attr.select_type_temporary); 2292 *token = gfc_conv_descriptor_token (caf_decl); 2293 } 2294 else if (DECL_LANG_SPECIFIC (caf_decl) 2295 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) 2296 *token = GFC_DECL_TOKEN (caf_decl); 2297 else 2298 { 2299 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)) 2300 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE); 2301 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)); 2302 } 2303 2304 if (offset == NULL) 2305 return; 2306 2307 /* Offset between the coarray base address and the address wanted. */ 2308 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) 2309 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE 2310 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER)) 2311 *offset = build_int_cst (gfc_array_index_type, 0); 2312 else if (DECL_LANG_SPECIFIC (caf_decl) 2313 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) 2314 *offset = GFC_DECL_CAF_OFFSET (caf_decl); 2315 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE) 2316 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)); 2317 else 2318 *offset = build_int_cst (gfc_array_index_type, 0); 2319 2320 if (POINTER_TYPE_P (TREE_TYPE (se_expr)) 2321 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr)))) 2322 { 2323 tmp = build_fold_indirect_ref_loc (input_location, se_expr); 2324 tmp = gfc_conv_descriptor_data_get (tmp); 2325 } 2326 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr))) 2327 tmp = gfc_conv_descriptor_data_get (se_expr); 2328 else 2329 { 2330 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr))); 2331 tmp = se_expr; 2332 } 2333 2334 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 2335 *offset, fold_convert (gfc_array_index_type, tmp)); 2336 2337 if (expr->symtree->n.sym->ts.type == BT_DERIVED 2338 && expr->symtree->n.sym->attr.codimension 2339 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) 2340 { 2341 gfc_expr *base_expr = gfc_copy_expr (expr); 2342 gfc_ref *ref = base_expr->ref; 2343 gfc_se base_se; 2344 2345 // Iterate through the refs until the last one. 2346 while (ref->next) 2347 ref = ref->next; 2348 2349 if (ref->type == REF_ARRAY 2350 && ref->u.ar.type != AR_FULL) 2351 { 2352 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen; 2353 int i; 2354 for (i = 0; i < ranksum; ++i) 2355 { 2356 ref->u.ar.start[i] = NULL; 2357 ref->u.ar.end[i] = NULL; 2358 } 2359 ref->u.ar.type = AR_FULL; 2360 } 2361 gfc_init_se (&base_se, NULL); 2362 if (gfc_caf_attr (base_expr).dimension) 2363 { 2364 gfc_conv_expr_descriptor (&base_se, base_expr); 2365 tmp = gfc_conv_descriptor_data_get (base_se.expr); 2366 } 2367 else 2368 { 2369 gfc_conv_expr (&base_se, base_expr); 2370 tmp = base_se.expr; 2371 } 2372 2373 gfc_free_expr (base_expr); 2374 gfc_add_block_to_block (&se->pre, &base_se.pre); 2375 gfc_add_block_to_block (&se->post, &base_se.post); 2376 } 2377 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) 2378 tmp = gfc_conv_descriptor_data_get (caf_decl); 2379 else 2380 { 2381 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))); 2382 tmp = caf_decl; 2383 } 2384 2385 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 2386 fold_convert (gfc_array_index_type, *offset), 2387 fold_convert (gfc_array_index_type, tmp)); 2388} 2389 2390 2391/* Convert the coindex of a coarray into an image index; the result is 2392 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1) 2393 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */ 2394 2395tree 2396gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) 2397{ 2398 gfc_ref *ref; 2399 tree lbound, ubound, extent, tmp, img_idx; 2400 gfc_se se; 2401 int i; 2402 2403 for (ref = e->ref; ref; ref = ref->next) 2404 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 2405 break; 2406 gcc_assert (ref != NULL); 2407 2408 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) 2409 { 2410 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, 2411 integer_zero_node); 2412 } 2413 2414 img_idx = build_zero_cst (gfc_array_index_type); 2415 extent = build_one_cst (gfc_array_index_type); 2416 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 2417 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 2418 { 2419 gfc_init_se (&se, NULL); 2420 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type); 2421 gfc_add_block_to_block (block, &se.pre); 2422 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); 2423 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2424 TREE_TYPE (lbound), se.expr, lbound); 2425 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), 2426 extent, tmp); 2427 img_idx = fold_build2_loc (input_location, PLUS_EXPR, 2428 TREE_TYPE (tmp), img_idx, tmp); 2429 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1) 2430 { 2431 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); 2432 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); 2433 extent = fold_build2_loc (input_location, MULT_EXPR, 2434 TREE_TYPE (tmp), extent, tmp); 2435 } 2436 } 2437 else 2438 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) 2439 { 2440 gfc_init_se (&se, NULL); 2441 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type); 2442 gfc_add_block_to_block (block, &se.pre); 2443 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i); 2444 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2445 TREE_TYPE (lbound), se.expr, lbound); 2446 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), 2447 extent, tmp); 2448 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), 2449 img_idx, tmp); 2450 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1) 2451 { 2452 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i); 2453 tmp = fold_build2_loc (input_location, MINUS_EXPR, 2454 TREE_TYPE (ubound), ubound, lbound); 2455 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), 2456 tmp, build_one_cst (TREE_TYPE (tmp))); 2457 extent = fold_build2_loc (input_location, MULT_EXPR, 2458 TREE_TYPE (tmp), extent, tmp); 2459 } 2460 } 2461 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx), 2462 img_idx, build_one_cst (TREE_TYPE (img_idx))); 2463 return fold_convert (integer_type_node, img_idx); 2464} 2465 2466 2467/* For each character array constructor subexpression without a ts.u.cl->length, 2468 replace it by its first element (if there aren't any elements, the length 2469 should already be set to zero). */ 2470 2471static void 2472flatten_array_ctors_without_strlen (gfc_expr* e) 2473{ 2474 gfc_actual_arglist* arg; 2475 gfc_constructor* c; 2476 2477 if (!e) 2478 return; 2479 2480 switch (e->expr_type) 2481 { 2482 2483 case EXPR_OP: 2484 flatten_array_ctors_without_strlen (e->value.op.op1); 2485 flatten_array_ctors_without_strlen (e->value.op.op2); 2486 break; 2487 2488 case EXPR_COMPCALL: 2489 /* TODO: Implement as with EXPR_FUNCTION when needed. */ 2490 gcc_unreachable (); 2491 2492 case EXPR_FUNCTION: 2493 for (arg = e->value.function.actual; arg; arg = arg->next) 2494 flatten_array_ctors_without_strlen (arg->expr); 2495 break; 2496 2497 case EXPR_ARRAY: 2498 2499 /* We've found what we're looking for. */ 2500 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) 2501 { 2502 gfc_constructor *c; 2503 gfc_expr* new_expr; 2504 2505 gcc_assert (e->value.constructor); 2506 2507 c = gfc_constructor_first (e->value.constructor); 2508 new_expr = c->expr; 2509 c->expr = NULL; 2510 2511 flatten_array_ctors_without_strlen (new_expr); 2512 gfc_replace_expr (e, new_expr); 2513 break; 2514 } 2515 2516 /* Otherwise, fall through to handle constructor elements. */ 2517 gcc_fallthrough (); 2518 case EXPR_STRUCTURE: 2519 for (c = gfc_constructor_first (e->value.constructor); 2520 c; c = gfc_constructor_next (c)) 2521 flatten_array_ctors_without_strlen (c->expr); 2522 break; 2523 2524 default: 2525 break; 2526 2527 } 2528} 2529 2530 2531/* Generate code to initialize a string length variable. Returns the 2532 value. For array constructors, cl->length might be NULL and in this case, 2533 the first element of the constructor is needed. expr is the original 2534 expression so we can access it but can be NULL if this is not needed. */ 2535 2536void 2537gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) 2538{ 2539 gfc_se se; 2540 2541 gfc_init_se (&se, NULL); 2542 2543 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl)) 2544 return; 2545 2546 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but 2547 "flatten" array constructors by taking their first element; all elements 2548 should be the same length or a cl->length should be present. */ 2549 if (!cl->length) 2550 { 2551 gfc_expr* expr_flat; 2552 if (!expr) 2553 return; 2554 expr_flat = gfc_copy_expr (expr); 2555 flatten_array_ctors_without_strlen (expr_flat); 2556 gfc_resolve_expr (expr_flat); 2557 2558 gfc_conv_expr (&se, expr_flat); 2559 gfc_add_block_to_block (pblock, &se.pre); 2560 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); 2561 2562 gfc_free_expr (expr_flat); 2563 return; 2564 } 2565 2566 /* Convert cl->length. */ 2567 2568 gcc_assert (cl->length); 2569 2570 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); 2571 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, 2572 se.expr, build_zero_cst (TREE_TYPE (se.expr))); 2573 gfc_add_block_to_block (pblock, &se.pre); 2574 2575 if (cl->backend_decl && VAR_P (cl->backend_decl)) 2576 gfc_add_modify (pblock, cl->backend_decl, se.expr); 2577 else 2578 cl->backend_decl = gfc_evaluate_now (se.expr, pblock); 2579} 2580 2581 2582static void 2583gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, 2584 const char *name, locus *where) 2585{ 2586 tree tmp; 2587 tree type; 2588 tree fault; 2589 gfc_se start; 2590 gfc_se end; 2591 char *msg; 2592 mpz_t length; 2593 2594 type = gfc_get_character_type (kind, ref->u.ss.length); 2595 type = build_pointer_type (type); 2596 2597 gfc_init_se (&start, se); 2598 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); 2599 gfc_add_block_to_block (&se->pre, &start.pre); 2600 2601 if (integer_onep (start.expr)) 2602 gfc_conv_string_parameter (se); 2603 else 2604 { 2605 tmp = start.expr; 2606 STRIP_NOPS (tmp); 2607 /* Avoid multiple evaluation of substring start. */ 2608 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) 2609 start.expr = gfc_evaluate_now (start.expr, &se->pre); 2610 2611 /* Change the start of the string. */ 2612 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE 2613 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) 2614 && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) 2615 tmp = se->expr; 2616 else 2617 tmp = build_fold_indirect_ref_loc (input_location, 2618 se->expr); 2619 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */ 2620 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) 2621 { 2622 tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); 2623 se->expr = gfc_build_addr_expr (type, tmp); 2624 } 2625 } 2626 2627 /* Length = end + 1 - start. */ 2628 gfc_init_se (&end, se); 2629 if (ref->u.ss.end == NULL) 2630 end.expr = se->string_length; 2631 else 2632 { 2633 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); 2634 gfc_add_block_to_block (&se->pre, &end.pre); 2635 } 2636 tmp = end.expr; 2637 STRIP_NOPS (tmp); 2638 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) 2639 end.expr = gfc_evaluate_now (end.expr, &se->pre); 2640 2641 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 2642 && (ref->u.ss.start->symtree 2643 && !ref->u.ss.start->symtree->n.sym->attr.implied_index)) 2644 { 2645 tree nonempty = fold_build2_loc (input_location, LE_EXPR, 2646 logical_type_node, start.expr, 2647 end.expr); 2648 2649 /* Check lower bound. */ 2650 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 2651 start.expr, 2652 build_one_cst (TREE_TYPE (start.expr))); 2653 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 2654 logical_type_node, nonempty, fault); 2655 if (name) 2656 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' " 2657 "is less than one", name); 2658 else 2659 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) " 2660 "is less than one"); 2661 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, 2662 fold_convert (long_integer_type_node, 2663 start.expr)); 2664 free (msg); 2665 2666 /* Check upper bound. */ 2667 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, 2668 end.expr, se->string_length); 2669 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 2670 logical_type_node, nonempty, fault); 2671 if (name) 2672 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' " 2673 "exceeds string length (%%ld)", name); 2674 else 2675 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) " 2676 "exceeds string length (%%ld)"); 2677 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, 2678 fold_convert (long_integer_type_node, end.expr), 2679 fold_convert (long_integer_type_node, 2680 se->string_length)); 2681 free (msg); 2682 } 2683 2684 /* Try to calculate the length from the start and end expressions. */ 2685 if (ref->u.ss.end 2686 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) 2687 { 2688 HOST_WIDE_INT i_len; 2689 2690 i_len = gfc_mpz_get_hwi (length) + 1; 2691 if (i_len < 0) 2692 i_len = 0; 2693 2694 tmp = build_int_cst (gfc_charlen_type_node, i_len); 2695 mpz_clear (length); /* Was initialized by gfc_dep_difference. */ 2696 } 2697 else 2698 { 2699 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, 2700 fold_convert (gfc_charlen_type_node, end.expr), 2701 fold_convert (gfc_charlen_type_node, start.expr)); 2702 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, 2703 build_int_cst (gfc_charlen_type_node, 1), tmp); 2704 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, 2705 tmp, build_int_cst (gfc_charlen_type_node, 0)); 2706 } 2707 2708 se->string_length = tmp; 2709} 2710 2711 2712/* Convert a derived type component reference. */ 2713 2714void 2715gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) 2716{ 2717 gfc_component *c; 2718 tree tmp; 2719 tree decl; 2720 tree field; 2721 tree context; 2722 2723 c = ref->u.c.component; 2724 2725 if (c->backend_decl == NULL_TREE 2726 && ref->u.c.sym != NULL) 2727 gfc_get_derived_type (ref->u.c.sym); 2728 2729 field = c->backend_decl; 2730 gcc_assert (field && TREE_CODE (field) == FIELD_DECL); 2731 decl = se->expr; 2732 context = DECL_FIELD_CONTEXT (field); 2733 2734 /* Components can correspond to fields of different containing 2735 types, as components are created without context, whereas 2736 a concrete use of a component has the type of decl as context. 2737 So, if the type doesn't match, we search the corresponding 2738 FIELD_DECL in the parent type. To not waste too much time 2739 we cache this result in norestrict_decl. 2740 On the other hand, if the context is a UNION or a MAP (a 2741 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */ 2742 2743 if (context != TREE_TYPE (decl) 2744 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */ 2745 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */ 2746 { 2747 tree f2 = c->norestrict_decl; 2748 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl)) 2749 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2)) 2750 if (TREE_CODE (f2) == FIELD_DECL 2751 && DECL_NAME (f2) == DECL_NAME (field)) 2752 break; 2753 gcc_assert (f2); 2754 c->norestrict_decl = f2; 2755 field = f2; 2756 } 2757 2758 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS 2759 && strcmp ("_data", c->name) == 0) 2760 { 2761 /* Found a ref to the _data component. Store the associated ref to 2762 the vptr in se->class_vptr. */ 2763 se->class_vptr = gfc_class_vptr_get (decl); 2764 } 2765 else 2766 se->class_vptr = NULL_TREE; 2767 2768 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 2769 decl, field, NULL_TREE); 2770 2771 se->expr = tmp; 2772 2773 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_ 2774 strlen () conditional below. */ 2775 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer 2776 && !c->ts.deferred 2777 && !c->attr.pdt_string) 2778 { 2779 tmp = c->ts.u.cl->backend_decl; 2780 /* Components must always be constant length. */ 2781 gcc_assert (tmp && INTEGER_CST_P (tmp)); 2782 se->string_length = tmp; 2783 } 2784 2785 if (gfc_deferred_strlen (c, &field)) 2786 { 2787 tmp = fold_build3_loc (input_location, COMPONENT_REF, 2788 TREE_TYPE (field), 2789 decl, field, NULL_TREE); 2790 se->string_length = tmp; 2791 } 2792 2793 if (((c->attr.pointer || c->attr.allocatable) 2794 && (!c->attr.dimension && !c->attr.codimension) 2795 && c->ts.type != BT_CHARACTER) 2796 || c->attr.proc_pointer) 2797 se->expr = build_fold_indirect_ref_loc (input_location, 2798 se->expr); 2799} 2800 2801 2802/* This function deals with component references to components of the 2803 parent type for derived type extensions. */ 2804void 2805conv_parent_component_references (gfc_se * se, gfc_ref * ref) 2806{ 2807 gfc_component *c; 2808 gfc_component *cmp; 2809 gfc_symbol *dt; 2810 gfc_ref parent; 2811 2812 dt = ref->u.c.sym; 2813 c = ref->u.c.component; 2814 2815 /* Return if the component is in this type, i.e. not in the parent type. */ 2816 for (cmp = dt->components; cmp; cmp = cmp->next) 2817 if (c == cmp) 2818 return; 2819 2820 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */ 2821 parent.type = REF_COMPONENT; 2822 parent.next = NULL; 2823 parent.u.c.sym = dt; 2824 parent.u.c.component = dt->components; 2825 2826 if (dt->backend_decl == NULL) 2827 gfc_get_derived_type (dt); 2828 2829 /* Build the reference and call self. */ 2830 gfc_conv_component_ref (se, &parent); 2831 parent.u.c.sym = dt->components->ts.u.derived; 2832 parent.u.c.component = c; 2833 conv_parent_component_references (se, &parent); 2834} 2835 2836 2837static void 2838conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) 2839{ 2840 tree res = se->expr; 2841 2842 switch (ref->u.i) 2843 { 2844 case INQUIRY_RE: 2845 res = fold_build1_loc (input_location, REALPART_EXPR, 2846 TREE_TYPE (TREE_TYPE (res)), res); 2847 break; 2848 2849 case INQUIRY_IM: 2850 res = fold_build1_loc (input_location, IMAGPART_EXPR, 2851 TREE_TYPE (TREE_TYPE (res)), res); 2852 break; 2853 2854 case INQUIRY_KIND: 2855 res = build_int_cst (gfc_typenode_for_spec (&expr->ts), 2856 ts->kind); 2857 break; 2858 2859 case INQUIRY_LEN: 2860 res = fold_convert (gfc_typenode_for_spec (&expr->ts), 2861 se->string_length); 2862 break; 2863 2864 default: 2865 gcc_unreachable (); 2866 } 2867 se->expr = res; 2868} 2869 2870/* Dereference VAR where needed if it is a pointer, reference, etc. 2871 according to Fortran semantics. */ 2872 2873tree 2874gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, 2875 bool is_classarray) 2876{ 2877 if (!POINTER_TYPE_P (TREE_TYPE (var))) 2878 return var; 2879 if (is_CFI_desc (sym, NULL)) 2880 return build_fold_indirect_ref_loc (input_location, var); 2881 2882 /* Characters are entirely different from other types, they are treated 2883 separately. */ 2884 if (sym->ts.type == BT_CHARACTER) 2885 { 2886 /* Dereference character pointer dummy arguments 2887 or results. */ 2888 if ((sym->attr.pointer || sym->attr.allocatable 2889 || (sym->as && sym->as->type == AS_ASSUMED_RANK)) 2890 && (sym->attr.dummy 2891 || sym->attr.function 2892 || sym->attr.result)) 2893 var = build_fold_indirect_ref_loc (input_location, var); 2894 } 2895 else if (!sym->attr.value) 2896 { 2897 /* Dereference temporaries for class array dummy arguments. */ 2898 if (sym->attr.dummy && is_classarray 2899 && GFC_ARRAY_TYPE_P (TREE_TYPE (var))) 2900 { 2901 if (!descriptor_only_p) 2902 var = GFC_DECL_SAVED_DESCRIPTOR (var); 2903 2904 var = build_fold_indirect_ref_loc (input_location, var); 2905 } 2906 2907 /* Dereference non-character scalar dummy arguments. */ 2908 if (sym->attr.dummy && !sym->attr.dimension 2909 && !(sym->attr.codimension && sym->attr.allocatable) 2910 && (sym->ts.type != BT_CLASS 2911 || (!CLASS_DATA (sym)->attr.dimension 2912 && !(CLASS_DATA (sym)->attr.codimension 2913 && CLASS_DATA (sym)->attr.allocatable)))) 2914 var = build_fold_indirect_ref_loc (input_location, var); 2915 2916 /* Dereference scalar hidden result. */ 2917 if (flag_f2c && sym->ts.type == BT_COMPLEX 2918 && (sym->attr.function || sym->attr.result) 2919 && !sym->attr.dimension && !sym->attr.pointer 2920 && !sym->attr.always_explicit) 2921 var = build_fold_indirect_ref_loc (input_location, var); 2922 2923 /* Dereference non-character, non-class pointer variables. 2924 These must be dummies, results, or scalars. */ 2925 if (!is_classarray 2926 && (sym->attr.pointer || sym->attr.allocatable 2927 || gfc_is_associate_pointer (sym) 2928 || (sym->as && sym->as->type == AS_ASSUMED_RANK)) 2929 && (sym->attr.dummy 2930 || sym->attr.function 2931 || sym->attr.result 2932 || (!sym->attr.dimension 2933 && (!sym->attr.codimension || !sym->attr.allocatable)))) 2934 var = build_fold_indirect_ref_loc (input_location, var); 2935 /* Now treat the class array pointer variables accordingly. */ 2936 else if (sym->ts.type == BT_CLASS 2937 && sym->attr.dummy 2938 && (CLASS_DATA (sym)->attr.dimension 2939 || CLASS_DATA (sym)->attr.codimension) 2940 && ((CLASS_DATA (sym)->as 2941 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) 2942 || CLASS_DATA (sym)->attr.allocatable 2943 || CLASS_DATA (sym)->attr.class_pointer)) 2944 var = build_fold_indirect_ref_loc (input_location, var); 2945 /* And the case where a non-dummy, non-result, non-function, 2946 non-allocable and non-pointer classarray is present. This case was 2947 previously covered by the first if, but with introducing the 2948 condition !is_classarray there, that case has to be covered 2949 explicitly. */ 2950 else if (sym->ts.type == BT_CLASS 2951 && !sym->attr.dummy 2952 && !sym->attr.function 2953 && !sym->attr.result 2954 && (CLASS_DATA (sym)->attr.dimension 2955 || CLASS_DATA (sym)->attr.codimension) 2956 && (sym->assoc 2957 || !CLASS_DATA (sym)->attr.allocatable) 2958 && !CLASS_DATA (sym)->attr.class_pointer) 2959 var = build_fold_indirect_ref_loc (input_location, var); 2960 } 2961 2962 return var; 2963} 2964 2965/* Return the contents of a variable. Also handles reference/pointer 2966 variables (all Fortran pointer references are implicit). */ 2967 2968static void 2969gfc_conv_variable (gfc_se * se, gfc_expr * expr) 2970{ 2971 gfc_ss *ss; 2972 gfc_ref *ref; 2973 gfc_symbol *sym; 2974 tree parent_decl = NULL_TREE; 2975 int parent_flag; 2976 bool return_value; 2977 bool alternate_entry; 2978 bool entry_master; 2979 bool is_classarray; 2980 bool first_time = true; 2981 2982 sym = expr->symtree->n.sym; 2983 is_classarray = IS_CLASS_ARRAY (sym); 2984 ss = se->ss; 2985 if (ss != NULL) 2986 { 2987 gfc_ss_info *ss_info = ss->info; 2988 2989 /* Check that something hasn't gone horribly wrong. */ 2990 gcc_assert (ss != gfc_ss_terminator); 2991 gcc_assert (ss_info->expr == expr); 2992 2993 /* A scalarized term. We already know the descriptor. */ 2994 se->expr = ss_info->data.array.descriptor; 2995 se->string_length = ss_info->string_length; 2996 ref = ss_info->data.array.ref; 2997 if (ref) 2998 gcc_assert (ref->type == REF_ARRAY 2999 && ref->u.ar.type != AR_ELEMENT); 3000 else 3001 gfc_conv_tmp_array_ref (se); 3002 } 3003 else 3004 { 3005 tree se_expr = NULL_TREE; 3006 3007 se->expr = gfc_get_symbol_decl (sym); 3008 3009 /* Deal with references to a parent results or entries by storing 3010 the current_function_decl and moving to the parent_decl. */ 3011 return_value = sym->attr.function && sym->result == sym; 3012 alternate_entry = sym->attr.function && sym->attr.entry 3013 && sym->result == sym; 3014 entry_master = sym->attr.result 3015 && sym->ns->proc_name->attr.entry_master 3016 && !gfc_return_by_reference (sym->ns->proc_name); 3017 if (current_function_decl) 3018 parent_decl = DECL_CONTEXT (current_function_decl); 3019 3020 if ((se->expr == parent_decl && return_value) 3021 || (sym->ns && sym->ns->proc_name 3022 && parent_decl 3023 && sym->ns->proc_name->backend_decl == parent_decl 3024 && (alternate_entry || entry_master))) 3025 parent_flag = 1; 3026 else 3027 parent_flag = 0; 3028 3029 /* Special case for assigning the return value of a function. 3030 Self recursive functions must have an explicit return value. */ 3031 if (return_value && (se->expr == current_function_decl || parent_flag)) 3032 se_expr = gfc_get_fake_result_decl (sym, parent_flag); 3033 3034 /* Similarly for alternate entry points. */ 3035 else if (alternate_entry 3036 && (sym->ns->proc_name->backend_decl == current_function_decl 3037 || parent_flag)) 3038 { 3039 gfc_entry_list *el = NULL; 3040 3041 for (el = sym->ns->entries; el; el = el->next) 3042 if (sym == el->sym) 3043 { 3044 se_expr = gfc_get_fake_result_decl (sym, parent_flag); 3045 break; 3046 } 3047 } 3048 3049 else if (entry_master 3050 && (sym->ns->proc_name->backend_decl == current_function_decl 3051 || parent_flag)) 3052 se_expr = gfc_get_fake_result_decl (sym, parent_flag); 3053 3054 if (se_expr) 3055 se->expr = se_expr; 3056 3057 /* Procedure actual arguments. Look out for temporary variables 3058 with the same attributes as function values. */ 3059 else if (!sym->attr.temporary 3060 && sym->attr.flavor == FL_PROCEDURE 3061 && se->expr != current_function_decl) 3062 { 3063 if (!sym->attr.dummy && !sym->attr.proc_pointer) 3064 { 3065 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL); 3066 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 3067 } 3068 return; 3069 } 3070 3071 /* Dereference the expression, where needed. */ 3072 se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, 3073 is_classarray); 3074 3075 ref = expr->ref; 3076 } 3077 3078 /* For character variables, also get the length. */ 3079 if (sym->ts.type == BT_CHARACTER) 3080 { 3081 /* If the character length of an entry isn't set, get the length from 3082 the master function instead. */ 3083 if (sym->attr.entry && !sym->ts.u.cl->backend_decl) 3084 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl; 3085 else 3086 se->string_length = sym->ts.u.cl->backend_decl; 3087 gcc_assert (se->string_length); 3088 } 3089 3090 gfc_typespec *ts = &sym->ts; 3091 while (ref) 3092 { 3093 switch (ref->type) 3094 { 3095 case REF_ARRAY: 3096 /* Return the descriptor if that's what we want and this is an array 3097 section reference. */ 3098 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT) 3099 return; 3100/* TODO: Pointers to single elements of array sections, eg elemental subs. */ 3101 /* Return the descriptor for array pointers and allocations. */ 3102 if (se->want_pointer 3103 && ref->next == NULL && (se->descriptor_only)) 3104 return; 3105 3106 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where); 3107 /* Return a pointer to an element. */ 3108 break; 3109 3110 case REF_COMPONENT: 3111 ts = &ref->u.c.component->ts; 3112 if (first_time && is_classarray && sym->attr.dummy 3113 && se->descriptor_only 3114 && !CLASS_DATA (sym)->attr.allocatable 3115 && !CLASS_DATA (sym)->attr.class_pointer 3116 && CLASS_DATA (sym)->as 3117 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK 3118 && strcmp ("_data", ref->u.c.component->name) == 0) 3119 /* Skip the first ref of a _data component, because for class 3120 arrays that one is already done by introducing a temporary 3121 array descriptor. */ 3122 break; 3123 3124 if (ref->u.c.sym->attr.extension) 3125 conv_parent_component_references (se, ref); 3126 3127 gfc_conv_component_ref (se, ref); 3128 if (!ref->next && ref->u.c.sym->attr.codimension 3129 && se->want_pointer && se->descriptor_only) 3130 return; 3131 3132 break; 3133 3134 case REF_SUBSTRING: 3135 gfc_conv_substring (se, ref, expr->ts.kind, 3136 expr->symtree->name, &expr->where); 3137 break; 3138 3139 case REF_INQUIRY: 3140 conv_inquiry (se, ref, expr, ts); 3141 break; 3142 3143 default: 3144 gcc_unreachable (); 3145 break; 3146 } 3147 first_time = false; 3148 ref = ref->next; 3149 } 3150 /* Pointer assignment, allocation or pass by reference. Arrays are handled 3151 separately. */ 3152 if (se->want_pointer) 3153 { 3154 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr)) 3155 gfc_conv_string_parameter (se); 3156 else 3157 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 3158 } 3159} 3160 3161 3162/* Unary ops are easy... Or they would be if ! was a valid op. */ 3163 3164static void 3165gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) 3166{ 3167 gfc_se operand; 3168 tree type; 3169 3170 gcc_assert (expr->ts.type != BT_CHARACTER); 3171 /* Initialize the operand. */ 3172 gfc_init_se (&operand, se); 3173 gfc_conv_expr_val (&operand, expr->value.op.op1); 3174 gfc_add_block_to_block (&se->pre, &operand.pre); 3175 3176 type = gfc_typenode_for_spec (&expr->ts); 3177 3178 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC. 3179 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). 3180 All other unary operators have an equivalent GIMPLE unary operator. */ 3181 if (code == TRUTH_NOT_EXPR) 3182 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr, 3183 build_int_cst (type, 0)); 3184 else 3185 se->expr = fold_build1_loc (input_location, code, type, operand.expr); 3186 3187} 3188 3189/* Expand power operator to optimal multiplications when a value is raised 3190 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of 3191 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer 3192 Programming", 3rd Edition, 1998. */ 3193 3194/* This code is mostly duplicated from expand_powi in the backend. 3195 We establish the "optimal power tree" lookup table with the defined size. 3196 The items in the table are the exponents used to calculate the index 3197 exponents. Any integer n less than the value can get an "addition chain", 3198 with the first node being one. */ 3199#define POWI_TABLE_SIZE 256 3200 3201/* The table is from builtins.cc. */ 3202static const unsigned char powi_table[POWI_TABLE_SIZE] = 3203 { 3204 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */ 3205 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */ 3206 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */ 3207 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */ 3208 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */ 3209 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */ 3210 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */ 3211 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */ 3212 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */ 3213 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */ 3214 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */ 3215 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */ 3216 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */ 3217 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */ 3218 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */ 3219 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */ 3220 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */ 3221 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */ 3222 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */ 3223 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */ 3224 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */ 3225 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */ 3226 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */ 3227 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */ 3228 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */ 3229 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */ 3230 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */ 3231 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */ 3232 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */ 3233 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */ 3234 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */ 3235 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */ 3236 }; 3237 3238/* If n is larger than lookup table's max index, we use the "window 3239 method". */ 3240#define POWI_WINDOW_SIZE 3 3241 3242/* Recursive function to expand the power operator. The temporary 3243 values are put in tmpvar. The function returns tmpvar[1] ** n. */ 3244static tree 3245gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar) 3246{ 3247 tree op0; 3248 tree op1; 3249 tree tmp; 3250 int digit; 3251 3252 if (n < POWI_TABLE_SIZE) 3253 { 3254 if (tmpvar[n]) 3255 return tmpvar[n]; 3256 3257 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar); 3258 op1 = gfc_conv_powi (se, powi_table[n], tmpvar); 3259 } 3260 else if (n & 1) 3261 { 3262 digit = n & ((1 << POWI_WINDOW_SIZE) - 1); 3263 op0 = gfc_conv_powi (se, n - digit, tmpvar); 3264 op1 = gfc_conv_powi (se, digit, tmpvar); 3265 } 3266 else 3267 { 3268 op0 = gfc_conv_powi (se, n >> 1, tmpvar); 3269 op1 = op0; 3270 } 3271 3272 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1); 3273 tmp = gfc_evaluate_now (tmp, &se->pre); 3274 3275 if (n < POWI_TABLE_SIZE) 3276 tmpvar[n] = tmp; 3277 3278 return tmp; 3279} 3280 3281 3282/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully, 3283 return 1. Else return 0 and a call to runtime library functions 3284 will have to be built. */ 3285static int 3286gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) 3287{ 3288 tree cond; 3289 tree tmp; 3290 tree type; 3291 tree vartmp[POWI_TABLE_SIZE]; 3292 HOST_WIDE_INT m; 3293 unsigned HOST_WIDE_INT n; 3294 int sgn; 3295 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs); 3296 3297 /* If exponent is too large, we won't expand it anyway, so don't bother 3298 with large integer values. */ 3299 if (!wi::fits_shwi_p (wrhs)) 3300 return 0; 3301 3302 m = wrhs.to_shwi (); 3303 /* Use the wide_int's routine to reliably get the absolute value on all 3304 platforms. Then convert it to a HOST_WIDE_INT like above. */ 3305 n = wi::abs (wrhs).to_shwi (); 3306 3307 type = TREE_TYPE (lhs); 3308 sgn = tree_int_cst_sgn (rhs); 3309 3310 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) 3311 || optimize_size) && (m > 2 || m < -1)) 3312 return 0; 3313 3314 /* rhs == 0 */ 3315 if (sgn == 0) 3316 { 3317 se->expr = gfc_build_const (type, integer_one_node); 3318 return 1; 3319 } 3320 3321 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */ 3322 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE)) 3323 { 3324 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 3325 lhs, build_int_cst (TREE_TYPE (lhs), -1)); 3326 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 3327 lhs, build_int_cst (TREE_TYPE (lhs), 1)); 3328 3329 /* If rhs is even, 3330 result = (lhs == 1 || lhs == -1) ? 1 : 0. */ 3331 if ((n & 1) == 0) 3332 { 3333 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, 3334 logical_type_node, tmp, cond); 3335 se->expr = fold_build3_loc (input_location, COND_EXPR, type, 3336 tmp, build_int_cst (type, 1), 3337 build_int_cst (type, 0)); 3338 return 1; 3339 } 3340 /* If rhs is odd, 3341 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */ 3342 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, 3343 build_int_cst (type, -1), 3344 build_int_cst (type, 0)); 3345 se->expr = fold_build3_loc (input_location, COND_EXPR, type, 3346 cond, build_int_cst (type, 1), tmp); 3347 return 1; 3348 } 3349 3350 memset (vartmp, 0, sizeof (vartmp)); 3351 vartmp[1] = lhs; 3352 if (sgn == -1) 3353 { 3354 tmp = gfc_build_const (type, integer_one_node); 3355 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp, 3356 vartmp[1]); 3357 } 3358 3359 se->expr = gfc_conv_powi (se, n, vartmp); 3360 3361 return 1; 3362} 3363 3364 3365/* Power op (**). Constant integer exponent has special handling. */ 3366 3367static void 3368gfc_conv_power_op (gfc_se * se, gfc_expr * expr) 3369{ 3370 tree gfc_int4_type_node; 3371 int kind; 3372 int ikind; 3373 int res_ikind_1, res_ikind_2; 3374 gfc_se lse; 3375 gfc_se rse; 3376 tree fndecl = NULL; 3377 3378 gfc_init_se (&lse, se); 3379 gfc_conv_expr_val (&lse, expr->value.op.op1); 3380 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre); 3381 gfc_add_block_to_block (&se->pre, &lse.pre); 3382 3383 gfc_init_se (&rse, se); 3384 gfc_conv_expr_val (&rse, expr->value.op.op2); 3385 gfc_add_block_to_block (&se->pre, &rse.pre); 3386 3387 if (expr->value.op.op2->ts.type == BT_INTEGER 3388 && expr->value.op.op2->expr_type == EXPR_CONSTANT) 3389 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr)) 3390 return; 3391 3392 if (INTEGER_CST_P (lse.expr) 3393 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE) 3394 { 3395 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr); 3396 HOST_WIDE_INT v, w; 3397 int kind, ikind, bit_size; 3398 3399 v = wlhs.to_shwi (); 3400 w = abs (v); 3401 3402 kind = expr->value.op.op1->ts.kind; 3403 ikind = gfc_validate_kind (BT_INTEGER, kind, false); 3404 bit_size = gfc_integer_kinds[ikind].bit_size; 3405 3406 if (v == 1) 3407 { 3408 /* 1**something is always 1. */ 3409 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1); 3410 return; 3411 } 3412 else if (v == -1) 3413 { 3414 /* (-1)**n is 1 - ((n & 1) << 1) */ 3415 tree type; 3416 tree tmp; 3417 3418 type = TREE_TYPE (lse.expr); 3419 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, 3420 rse.expr, build_int_cst (type, 1)); 3421 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, 3422 tmp, build_int_cst (type, 1)); 3423 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, 3424 build_int_cst (type, 1), tmp); 3425 se->expr = tmp; 3426 return; 3427 } 3428 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0)) 3429 { 3430 /* Here v is +/- 2**e. The further simplification uses 3431 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n = 3432 1<<(4*n), etc., but we have to make sure to return zero 3433 if the number of bits is too large. */ 3434 tree lshift; 3435 tree type; 3436 tree shift; 3437 tree ge; 3438 tree cond; 3439 tree num_bits; 3440 tree cond2; 3441 tree tmp1; 3442 3443 type = TREE_TYPE (lse.expr); 3444 3445 if (w == 2) 3446 shift = rse.expr; 3447 else if (w == 4) 3448 shift = fold_build2_loc (input_location, PLUS_EXPR, 3449 TREE_TYPE (rse.expr), 3450 rse.expr, rse.expr); 3451 else 3452 { 3453 /* use popcount for fast log2(w) */ 3454 int e = wi::popcount (w-1); 3455 shift = fold_build2_loc (input_location, MULT_EXPR, 3456 TREE_TYPE (rse.expr), 3457 build_int_cst (TREE_TYPE (rse.expr), e), 3458 rse.expr); 3459 } 3460 3461 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, 3462 build_int_cst (type, 1), shift); 3463 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 3464 rse.expr, build_int_cst (type, 0)); 3465 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift, 3466 build_int_cst (type, 0)); 3467 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type)); 3468 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, 3469 rse.expr, num_bits); 3470 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2, 3471 build_int_cst (type, 0), cond); 3472 if (v > 0) 3473 { 3474 se->expr = tmp1; 3475 } 3476 else 3477 { 3478 /* for v < 0, calculate v**n = |v|**n * (-1)**n */ 3479 tree tmp2; 3480 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type, 3481 rse.expr, build_int_cst (type, 1)); 3482 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type, 3483 tmp2, build_int_cst (type, 1)); 3484 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type, 3485 build_int_cst (type, 1), tmp2); 3486 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, 3487 tmp1, tmp2); 3488 } 3489 return; 3490 } 3491 } 3492 3493 gfc_int4_type_node = gfc_get_int_type (4); 3494 3495 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4 3496 library routine. But in the end, we have to convert the result back 3497 if this case applies -- with res_ikind_K, we keep track whether operand K 3498 falls into this case. */ 3499 res_ikind_1 = -1; 3500 res_ikind_2 = -1; 3501 3502 kind = expr->value.op.op1->ts.kind; 3503 switch (expr->value.op.op2->ts.type) 3504 { 3505 case BT_INTEGER: 3506 ikind = expr->value.op.op2->ts.kind; 3507 switch (ikind) 3508 { 3509 case 1: 3510 case 2: 3511 rse.expr = convert (gfc_int4_type_node, rse.expr); 3512 res_ikind_2 = ikind; 3513 /* Fall through. */ 3514 3515 case 4: 3516 ikind = 0; 3517 break; 3518 3519 case 8: 3520 ikind = 1; 3521 break; 3522 3523 case 16: 3524 ikind = 2; 3525 break; 3526 3527 default: 3528 gcc_unreachable (); 3529 } 3530 switch (kind) 3531 { 3532 case 1: 3533 case 2: 3534 if (expr->value.op.op1->ts.type == BT_INTEGER) 3535 { 3536 lse.expr = convert (gfc_int4_type_node, lse.expr); 3537 res_ikind_1 = kind; 3538 } 3539 else 3540 gcc_unreachable (); 3541 /* Fall through. */ 3542 3543 case 4: 3544 kind = 0; 3545 break; 3546 3547 case 8: 3548 kind = 1; 3549 break; 3550 3551 case 10: 3552 kind = 2; 3553 break; 3554 3555 case 16: 3556 kind = 3; 3557 break; 3558 3559 default: 3560 gcc_unreachable (); 3561 } 3562 3563 switch (expr->value.op.op1->ts.type) 3564 { 3565 case BT_INTEGER: 3566 if (kind == 3) /* Case 16 was not handled properly above. */ 3567 kind = 2; 3568 fndecl = gfor_fndecl_math_powi[kind][ikind].integer; 3569 break; 3570 3571 case BT_REAL: 3572 /* Use builtins for real ** int4. */ 3573 if (ikind == 0) 3574 { 3575 switch (kind) 3576 { 3577 case 0: 3578 fndecl = builtin_decl_explicit (BUILT_IN_POWIF); 3579 break; 3580 3581 case 1: 3582 fndecl = builtin_decl_explicit (BUILT_IN_POWI); 3583 break; 3584 3585 case 2: 3586 fndecl = builtin_decl_explicit (BUILT_IN_POWIL); 3587 break; 3588 3589 case 3: 3590 /* Use the __builtin_powil() only if real(kind=16) is 3591 actually the C long double type. */ 3592 if (!gfc_real16_is_float128) 3593 fndecl = builtin_decl_explicit (BUILT_IN_POWIL); 3594 break; 3595 3596 default: 3597 gcc_unreachable (); 3598 } 3599 } 3600 3601 /* If we don't have a good builtin for this, go for the 3602 library function. */ 3603 if (!fndecl) 3604 fndecl = gfor_fndecl_math_powi[kind][ikind].real; 3605 break; 3606 3607 case BT_COMPLEX: 3608 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx; 3609 break; 3610 3611 default: 3612 gcc_unreachable (); 3613 } 3614 break; 3615 3616 case BT_REAL: 3617 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind); 3618 break; 3619 3620 case BT_COMPLEX: 3621 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind); 3622 break; 3623 3624 default: 3625 gcc_unreachable (); 3626 break; 3627 } 3628 3629 se->expr = build_call_expr_loc (input_location, 3630 fndecl, 2, lse.expr, rse.expr); 3631 3632 /* Convert the result back if it is of wrong integer kind. */ 3633 if (res_ikind_1 != -1 && res_ikind_2 != -1) 3634 { 3635 /* We want the maximum of both operand kinds as result. */ 3636 if (res_ikind_1 < res_ikind_2) 3637 res_ikind_1 = res_ikind_2; 3638 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr); 3639 } 3640} 3641 3642 3643/* Generate code to allocate a string temporary. */ 3644 3645tree 3646gfc_conv_string_tmp (gfc_se * se, tree type, tree len) 3647{ 3648 tree var; 3649 tree tmp; 3650 3651 if (gfc_can_put_var_on_stack (len)) 3652 { 3653 /* Create a temporary variable to hold the result. */ 3654 tmp = fold_build2_loc (input_location, MINUS_EXPR, 3655 TREE_TYPE (len), len, 3656 build_int_cst (TREE_TYPE (len), 1)); 3657 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp); 3658 3659 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE) 3660 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp); 3661 else 3662 tmp = build_array_type (TREE_TYPE (type), tmp); 3663 3664 var = gfc_create_var (tmp, "str"); 3665 var = gfc_build_addr_expr (type, var); 3666 } 3667 else 3668 { 3669 /* Allocate a temporary to hold the result. */ 3670 var = gfc_create_var (type, "pstr"); 3671 gcc_assert (POINTER_TYPE_P (type)); 3672 tmp = TREE_TYPE (type); 3673 if (TREE_CODE (tmp) == ARRAY_TYPE) 3674 tmp = TREE_TYPE (tmp); 3675 tmp = TYPE_SIZE_UNIT (tmp); 3676 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 3677 fold_convert (size_type_node, len), 3678 fold_convert (size_type_node, tmp)); 3679 tmp = gfc_call_malloc (&se->pre, type, tmp); 3680 gfc_add_modify (&se->pre, var, tmp); 3681 3682 /* Free the temporary afterwards. */ 3683 tmp = gfc_call_free (var); 3684 gfc_add_expr_to_block (&se->post, tmp); 3685 } 3686 3687 return var; 3688} 3689 3690 3691/* Handle a string concatenation operation. A temporary will be allocated to 3692 hold the result. */ 3693 3694static void 3695gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) 3696{ 3697 gfc_se lse, rse; 3698 tree len, type, var, tmp, fndecl; 3699 3700 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER 3701 && expr->value.op.op2->ts.type == BT_CHARACTER); 3702 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind); 3703 3704 gfc_init_se (&lse, se); 3705 gfc_conv_expr (&lse, expr->value.op.op1); 3706 gfc_conv_string_parameter (&lse); 3707 gfc_init_se (&rse, se); 3708 gfc_conv_expr (&rse, expr->value.op.op2); 3709 gfc_conv_string_parameter (&rse); 3710 3711 gfc_add_block_to_block (&se->pre, &lse.pre); 3712 gfc_add_block_to_block (&se->pre, &rse.pre); 3713 3714 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); 3715 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 3716 if (len == NULL_TREE) 3717 { 3718 len = fold_build2_loc (input_location, PLUS_EXPR, 3719 gfc_charlen_type_node, 3720 fold_convert (gfc_charlen_type_node, 3721 lse.string_length), 3722 fold_convert (gfc_charlen_type_node, 3723 rse.string_length)); 3724 } 3725 3726 type = build_pointer_type (type); 3727 3728 var = gfc_conv_string_tmp (se, type, len); 3729 3730 /* Do the actual concatenation. */ 3731 if (expr->ts.kind == 1) 3732 fndecl = gfor_fndecl_concat_string; 3733 else if (expr->ts.kind == 4) 3734 fndecl = gfor_fndecl_concat_string_char4; 3735 else 3736 gcc_unreachable (); 3737 3738 tmp = build_call_expr_loc (input_location, 3739 fndecl, 6, len, var, lse.string_length, lse.expr, 3740 rse.string_length, rse.expr); 3741 gfc_add_expr_to_block (&se->pre, tmp); 3742 3743 /* Add the cleanup for the operands. */ 3744 gfc_add_block_to_block (&se->pre, &rse.post); 3745 gfc_add_block_to_block (&se->pre, &lse.post); 3746 3747 se->expr = var; 3748 se->string_length = len; 3749} 3750 3751/* Translates an op expression. Common (binary) cases are handled by this 3752 function, others are passed on. Recursion is used in either case. 3753 We use the fact that (op1.ts == op2.ts) (except for the power 3754 operator **). 3755 Operators need no special handling for scalarized expressions as long as 3756 they call gfc_conv_simple_val to get their operands. 3757 Character strings get special handling. */ 3758 3759static void 3760gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) 3761{ 3762 enum tree_code code; 3763 gfc_se lse; 3764 gfc_se rse; 3765 tree tmp, type; 3766 int lop; 3767 int checkstring; 3768 3769 checkstring = 0; 3770 lop = 0; 3771 switch (expr->value.op.op) 3772 { 3773 case INTRINSIC_PARENTHESES: 3774 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX) 3775 && flag_protect_parens) 3776 { 3777 gfc_conv_unary_op (PAREN_EXPR, se, expr); 3778 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr))); 3779 return; 3780 } 3781 3782 /* Fallthrough. */ 3783 case INTRINSIC_UPLUS: 3784 gfc_conv_expr (se, expr->value.op.op1); 3785 return; 3786 3787 case INTRINSIC_UMINUS: 3788 gfc_conv_unary_op (NEGATE_EXPR, se, expr); 3789 return; 3790 3791 case INTRINSIC_NOT: 3792 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr); 3793 return; 3794 3795 case INTRINSIC_PLUS: 3796 code = PLUS_EXPR; 3797 break; 3798 3799 case INTRINSIC_MINUS: 3800 code = MINUS_EXPR; 3801 break; 3802 3803 case INTRINSIC_TIMES: 3804 code = MULT_EXPR; 3805 break; 3806 3807 case INTRINSIC_DIVIDE: 3808 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is 3809 an integer, we must round towards zero, so we use a 3810 TRUNC_DIV_EXPR. */ 3811 if (expr->ts.type == BT_INTEGER) 3812 code = TRUNC_DIV_EXPR; 3813 else 3814 code = RDIV_EXPR; 3815 break; 3816 3817 case INTRINSIC_POWER: 3818 gfc_conv_power_op (se, expr); 3819 return; 3820 3821 case INTRINSIC_CONCAT: 3822 gfc_conv_concat_op (se, expr); 3823 return; 3824 3825 case INTRINSIC_AND: 3826 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR; 3827 lop = 1; 3828 break; 3829 3830 case INTRINSIC_OR: 3831 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR; 3832 lop = 1; 3833 break; 3834 3835 /* EQV and NEQV only work on logicals, but since we represent them 3836 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */ 3837 case INTRINSIC_EQ: 3838 case INTRINSIC_EQ_OS: 3839 case INTRINSIC_EQV: 3840 code = EQ_EXPR; 3841 checkstring = 1; 3842 lop = 1; 3843 break; 3844 3845 case INTRINSIC_NE: 3846 case INTRINSIC_NE_OS: 3847 case INTRINSIC_NEQV: 3848 code = NE_EXPR; 3849 checkstring = 1; 3850 lop = 1; 3851 break; 3852 3853 case INTRINSIC_GT: 3854 case INTRINSIC_GT_OS: 3855 code = GT_EXPR; 3856 checkstring = 1; 3857 lop = 1; 3858 break; 3859 3860 case INTRINSIC_GE: 3861 case INTRINSIC_GE_OS: 3862 code = GE_EXPR; 3863 checkstring = 1; 3864 lop = 1; 3865 break; 3866 3867 case INTRINSIC_LT: 3868 case INTRINSIC_LT_OS: 3869 code = LT_EXPR; 3870 checkstring = 1; 3871 lop = 1; 3872 break; 3873 3874 case INTRINSIC_LE: 3875 case INTRINSIC_LE_OS: 3876 code = LE_EXPR; 3877 checkstring = 1; 3878 lop = 1; 3879 break; 3880 3881 case INTRINSIC_USER: 3882 case INTRINSIC_ASSIGN: 3883 /* These should be converted into function calls by the frontend. */ 3884 gcc_unreachable (); 3885 3886 default: 3887 fatal_error (input_location, "Unknown intrinsic op"); 3888 return; 3889 } 3890 3891 /* The only exception to this is **, which is handled separately anyway. */ 3892 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type); 3893 3894 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER) 3895 checkstring = 0; 3896 3897 /* lhs */ 3898 gfc_init_se (&lse, se); 3899 gfc_conv_expr (&lse, expr->value.op.op1); 3900 gfc_add_block_to_block (&se->pre, &lse.pre); 3901 3902 /* rhs */ 3903 gfc_init_se (&rse, se); 3904 gfc_conv_expr (&rse, expr->value.op.op2); 3905 gfc_add_block_to_block (&se->pre, &rse.pre); 3906 3907 if (checkstring) 3908 { 3909 gfc_conv_string_parameter (&lse); 3910 gfc_conv_string_parameter (&rse); 3911 3912 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr, 3913 rse.string_length, rse.expr, 3914 expr->value.op.op1->ts.kind, 3915 code); 3916 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0); 3917 gfc_add_block_to_block (&lse.post, &rse.post); 3918 } 3919 3920 type = gfc_typenode_for_spec (&expr->ts); 3921 3922 if (lop) 3923 { 3924 /* The result of logical ops is always logical_type_node. */ 3925 tmp = fold_build2_loc (input_location, code, logical_type_node, 3926 lse.expr, rse.expr); 3927 se->expr = convert (type, tmp); 3928 } 3929 else 3930 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr); 3931 3932 /* Add the post blocks. */ 3933 gfc_add_block_to_block (&se->post, &rse.post); 3934 gfc_add_block_to_block (&se->post, &lse.post); 3935} 3936 3937/* If a string's length is one, we convert it to a single character. */ 3938 3939tree 3940gfc_string_to_single_character (tree len, tree str, int kind) 3941{ 3942 3943 if (len == NULL 3944 || !tree_fits_uhwi_p (len) 3945 || !POINTER_TYPE_P (TREE_TYPE (str))) 3946 return NULL_TREE; 3947 3948 if (TREE_INT_CST_LOW (len) == 1) 3949 { 3950 str = fold_convert (gfc_get_pchar_type (kind), str); 3951 return build_fold_indirect_ref_loc (input_location, str); 3952 } 3953 3954 if (kind == 1 3955 && TREE_CODE (str) == ADDR_EXPR 3956 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF 3957 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST 3958 && array_ref_low_bound (TREE_OPERAND (str, 0)) 3959 == TREE_OPERAND (TREE_OPERAND (str, 0), 1) 3960 && TREE_INT_CST_LOW (len) > 1 3961 && TREE_INT_CST_LOW (len) 3962 == (unsigned HOST_WIDE_INT) 3963 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) 3964 { 3965 tree ret = fold_convert (gfc_get_pchar_type (kind), str); 3966 ret = build_fold_indirect_ref_loc (input_location, ret); 3967 if (TREE_CODE (ret) == INTEGER_CST) 3968 { 3969 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); 3970 int i, length = TREE_STRING_LENGTH (string_cst); 3971 const char *ptr = TREE_STRING_POINTER (string_cst); 3972 3973 for (i = 1; i < length; i++) 3974 if (ptr[i] != ' ') 3975 return NULL_TREE; 3976 3977 return ret; 3978 } 3979 } 3980 3981 return NULL_TREE; 3982} 3983 3984 3985static void 3986conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) 3987{ 3988 gcc_assert (expr); 3989 3990 /* We used to modify the tree here. Now it is done earlier in 3991 the front-end, so we only check it here to avoid regressions. */ 3992 if (sym->backend_decl) 3993 { 3994 gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE); 3995 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1); 3996 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE); 3997 gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0); 3998 } 3999 4000 /* If we have a constant character expression, make it into an 4001 integer of type C char. */ 4002 if ((*expr)->expr_type == EXPR_CONSTANT) 4003 { 4004 gfc_typespec ts; 4005 gfc_clear_ts (&ts); 4006 4007 *expr = gfc_get_int_expr (gfc_default_character_kind, NULL, 4008 (*expr)->value.character.string[0]); 4009 } 4010 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE) 4011 { 4012 if ((*expr)->ref == NULL) 4013 { 4014 se->expr = gfc_string_to_single_character 4015 (build_int_cst (integer_type_node, 1), 4016 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), 4017 gfc_get_symbol_decl 4018 ((*expr)->symtree->n.sym)), 4019 (*expr)->ts.kind); 4020 } 4021 else 4022 { 4023 gfc_conv_variable (se, *expr); 4024 se->expr = gfc_string_to_single_character 4025 (build_int_cst (integer_type_node, 1), 4026 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), 4027 se->expr), 4028 (*expr)->ts.kind); 4029 } 4030 } 4031} 4032 4033/* Helper function for gfc_build_compare_string. Return LEN_TRIM value 4034 if STR is a string literal, otherwise return -1. */ 4035 4036static int 4037gfc_optimize_len_trim (tree len, tree str, int kind) 4038{ 4039 if (kind == 1 4040 && TREE_CODE (str) == ADDR_EXPR 4041 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF 4042 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST 4043 && array_ref_low_bound (TREE_OPERAND (str, 0)) 4044 == TREE_OPERAND (TREE_OPERAND (str, 0), 1) 4045 && tree_fits_uhwi_p (len) 4046 && tree_to_uhwi (len) >= 1 4047 && tree_to_uhwi (len) 4048 == (unsigned HOST_WIDE_INT) 4049 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0))) 4050 { 4051 tree folded = fold_convert (gfc_get_pchar_type (kind), str); 4052 folded = build_fold_indirect_ref_loc (input_location, folded); 4053 if (TREE_CODE (folded) == INTEGER_CST) 4054 { 4055 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0); 4056 int length = TREE_STRING_LENGTH (string_cst); 4057 const char *ptr = TREE_STRING_POINTER (string_cst); 4058 4059 for (; length > 0; length--) 4060 if (ptr[length - 1] != ' ') 4061 break; 4062 4063 return length; 4064 } 4065 } 4066 return -1; 4067} 4068 4069/* Helper to build a call to memcmp. */ 4070 4071static tree 4072build_memcmp_call (tree s1, tree s2, tree n) 4073{ 4074 tree tmp; 4075 4076 if (!POINTER_TYPE_P (TREE_TYPE (s1))) 4077 s1 = gfc_build_addr_expr (pvoid_type_node, s1); 4078 else 4079 s1 = fold_convert (pvoid_type_node, s1); 4080 4081 if (!POINTER_TYPE_P (TREE_TYPE (s2))) 4082 s2 = gfc_build_addr_expr (pvoid_type_node, s2); 4083 else 4084 s2 = fold_convert (pvoid_type_node, s2); 4085 4086 n = fold_convert (size_type_node, n); 4087 4088 tmp = build_call_expr_loc (input_location, 4089 builtin_decl_explicit (BUILT_IN_MEMCMP), 4090 3, s1, s2, n); 4091 4092 return fold_convert (integer_type_node, tmp); 4093} 4094 4095/* Compare two strings. If they are all single characters, the result is the 4096 subtraction of them. Otherwise, we build a library call. */ 4097 4098tree 4099gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind, 4100 enum tree_code code) 4101{ 4102 tree sc1; 4103 tree sc2; 4104 tree fndecl; 4105 4106 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1))); 4107 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2))); 4108 4109 sc1 = gfc_string_to_single_character (len1, str1, kind); 4110 sc2 = gfc_string_to_single_character (len2, str2, kind); 4111 4112 if (sc1 != NULL_TREE && sc2 != NULL_TREE) 4113 { 4114 /* Deal with single character specially. */ 4115 sc1 = fold_convert (integer_type_node, sc1); 4116 sc2 = fold_convert (integer_type_node, sc2); 4117 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, 4118 sc1, sc2); 4119 } 4120 4121 if ((code == EQ_EXPR || code == NE_EXPR) 4122 && optimize 4123 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2)) 4124 { 4125 /* If one string is a string literal with LEN_TRIM longer 4126 than the length of the second string, the strings 4127 compare unequal. */ 4128 int len = gfc_optimize_len_trim (len1, str1, kind); 4129 if (len > 0 && compare_tree_int (len2, len) < 0) 4130 return integer_one_node; 4131 len = gfc_optimize_len_trim (len2, str2, kind); 4132 if (len > 0 && compare_tree_int (len1, len) < 0) 4133 return integer_one_node; 4134 } 4135 4136 /* We can compare via memcpy if the strings are known to be equal 4137 in length and they are 4138 - kind=1 4139 - kind=4 and the comparison is for (in)equality. */ 4140 4141 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2) 4142 && tree_int_cst_equal (len1, len2) 4143 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR)) 4144 { 4145 tree tmp; 4146 tree chartype; 4147 4148 chartype = gfc_get_char_type (kind); 4149 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1), 4150 fold_convert (TREE_TYPE(len1), 4151 TYPE_SIZE_UNIT(chartype)), 4152 len1); 4153 return build_memcmp_call (str1, str2, tmp); 4154 } 4155 4156 /* Build a call for the comparison. */ 4157 if (kind == 1) 4158 fndecl = gfor_fndecl_compare_string; 4159 else if (kind == 4) 4160 fndecl = gfor_fndecl_compare_string_char4; 4161 else 4162 gcc_unreachable (); 4163 4164 return build_call_expr_loc (input_location, fndecl, 4, 4165 len1, str1, len2, str2); 4166} 4167 4168 4169/* Return the backend_decl for a procedure pointer component. */ 4170 4171static tree 4172get_proc_ptr_comp (gfc_expr *e) 4173{ 4174 gfc_se comp_se; 4175 gfc_expr *e2; 4176 expr_t old_type; 4177 4178 gfc_init_se (&comp_se, NULL); 4179 e2 = gfc_copy_expr (e); 4180 /* We have to restore the expr type later so that gfc_free_expr frees 4181 the exact same thing that was allocated. 4182 TODO: This is ugly. */ 4183 old_type = e2->expr_type; 4184 e2->expr_type = EXPR_VARIABLE; 4185 gfc_conv_expr (&comp_se, e2); 4186 e2->expr_type = old_type; 4187 gfc_free_expr (e2); 4188 return build_fold_addr_expr_loc (input_location, comp_se.expr); 4189} 4190 4191 4192/* Convert a typebound function reference from a class object. */ 4193static void 4194conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr) 4195{ 4196 gfc_ref *ref; 4197 tree var; 4198 4199 if (!VAR_P (base_object)) 4200 { 4201 var = gfc_create_var (TREE_TYPE (base_object), NULL); 4202 gfc_add_modify (&se->pre, var, base_object); 4203 } 4204 se->expr = gfc_class_vptr_get (base_object); 4205 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 4206 ref = expr->ref; 4207 while (ref && ref->next) 4208 ref = ref->next; 4209 gcc_assert (ref && ref->type == REF_COMPONENT); 4210 if (ref->u.c.sym->attr.extension) 4211 conv_parent_component_references (se, ref); 4212 gfc_conv_component_ref (se, ref); 4213 se->expr = build_fold_addr_expr_loc (input_location, se->expr); 4214} 4215 4216 4217static void 4218conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr, 4219 gfc_actual_arglist *actual_args) 4220{ 4221 tree tmp; 4222 4223 if (gfc_is_proc_ptr_comp (expr)) 4224 tmp = get_proc_ptr_comp (expr); 4225 else if (sym->attr.dummy) 4226 { 4227 tmp = gfc_get_symbol_decl (sym); 4228 if (sym->attr.proc_pointer) 4229 tmp = build_fold_indirect_ref_loc (input_location, 4230 tmp); 4231 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE 4232 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); 4233 } 4234 else 4235 { 4236 if (!sym->backend_decl) 4237 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args); 4238 4239 TREE_USED (sym->backend_decl) = 1; 4240 4241 tmp = sym->backend_decl; 4242 4243 if (sym->attr.cray_pointee) 4244 { 4245 /* TODO - make the cray pointee a pointer to a procedure, 4246 assign the pointer to it and use it for the call. This 4247 will do for now! */ 4248 tmp = convert (build_pointer_type (TREE_TYPE (tmp)), 4249 gfc_get_symbol_decl (sym->cp_pointer)); 4250 tmp = gfc_evaluate_now (tmp, &se->pre); 4251 } 4252 4253 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 4254 { 4255 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); 4256 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 4257 } 4258 } 4259 se->expr = tmp; 4260} 4261 4262 4263/* Initialize MAPPING. */ 4264 4265void 4266gfc_init_interface_mapping (gfc_interface_mapping * mapping) 4267{ 4268 mapping->syms = NULL; 4269 mapping->charlens = NULL; 4270} 4271 4272 4273/* Free all memory held by MAPPING (but not MAPPING itself). */ 4274 4275void 4276gfc_free_interface_mapping (gfc_interface_mapping * mapping) 4277{ 4278 gfc_interface_sym_mapping *sym; 4279 gfc_interface_sym_mapping *nextsym; 4280 gfc_charlen *cl; 4281 gfc_charlen *nextcl; 4282 4283 for (sym = mapping->syms; sym; sym = nextsym) 4284 { 4285 nextsym = sym->next; 4286 sym->new_sym->n.sym->formal = NULL; 4287 gfc_free_symbol (sym->new_sym->n.sym); 4288 gfc_free_expr (sym->expr); 4289 free (sym->new_sym); 4290 free (sym); 4291 } 4292 for (cl = mapping->charlens; cl; cl = nextcl) 4293 { 4294 nextcl = cl->next; 4295 gfc_free_expr (cl->length); 4296 free (cl); 4297 } 4298} 4299 4300 4301/* Return a copy of gfc_charlen CL. Add the returned structure to 4302 MAPPING so that it will be freed by gfc_free_interface_mapping. */ 4303 4304static gfc_charlen * 4305gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping, 4306 gfc_charlen * cl) 4307{ 4308 gfc_charlen *new_charlen; 4309 4310 new_charlen = gfc_get_charlen (); 4311 new_charlen->next = mapping->charlens; 4312 new_charlen->length = gfc_copy_expr (cl->length); 4313 4314 mapping->charlens = new_charlen; 4315 return new_charlen; 4316} 4317 4318 4319/* A subroutine of gfc_add_interface_mapping. Return a descriptorless 4320 array variable that can be used as the actual argument for dummy 4321 argument SYM. Add any initialization code to BLOCK. PACKED is as 4322 for gfc_get_nodesc_array_type and DATA points to the first element 4323 in the passed array. */ 4324 4325static tree 4326gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym, 4327 gfc_packed packed, tree data) 4328{ 4329 tree type; 4330 tree var; 4331 4332 type = gfc_typenode_for_spec (&sym->ts); 4333 type = gfc_get_nodesc_array_type (type, sym->as, packed, 4334 !sym->attr.target && !sym->attr.pointer 4335 && !sym->attr.proc_pointer); 4336 4337 var = gfc_create_var (type, "ifm"); 4338 gfc_add_modify (block, var, fold_convert (type, data)); 4339 4340 return var; 4341} 4342 4343 4344/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds 4345 and offset of descriptorless array type TYPE given that it has the same 4346 size as DESC. Add any set-up code to BLOCK. */ 4347 4348static void 4349gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc) 4350{ 4351 int n; 4352 tree dim; 4353 tree offset; 4354 tree tmp; 4355 4356 offset = gfc_index_zero_node; 4357 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++) 4358 { 4359 dim = gfc_rank_cst[n]; 4360 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n); 4361 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE) 4362 { 4363 GFC_TYPE_ARRAY_LBOUND (type, n) 4364 = gfc_conv_descriptor_lbound_get (desc, dim); 4365 GFC_TYPE_ARRAY_UBOUND (type, n) 4366 = gfc_conv_descriptor_ubound_get (desc, dim); 4367 } 4368 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE) 4369 { 4370 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4371 gfc_array_index_type, 4372 gfc_conv_descriptor_ubound_get (desc, dim), 4373 gfc_conv_descriptor_lbound_get (desc, dim)); 4374 tmp = fold_build2_loc (input_location, PLUS_EXPR, 4375 gfc_array_index_type, 4376 GFC_TYPE_ARRAY_LBOUND (type, n), tmp); 4377 tmp = gfc_evaluate_now (tmp, block); 4378 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; 4379 } 4380 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 4381 GFC_TYPE_ARRAY_LBOUND (type, n), 4382 GFC_TYPE_ARRAY_STRIDE (type, n)); 4383 offset = fold_build2_loc (input_location, MINUS_EXPR, 4384 gfc_array_index_type, offset, tmp); 4385 } 4386 offset = gfc_evaluate_now (offset, block); 4387 GFC_TYPE_ARRAY_OFFSET (type) = offset; 4388} 4389 4390 4391/* Extend MAPPING so that it maps dummy argument SYM to the value stored 4392 in SE. The caller may still use se->expr and se->string_length after 4393 calling this function. */ 4394 4395void 4396gfc_add_interface_mapping (gfc_interface_mapping * mapping, 4397 gfc_symbol * sym, gfc_se * se, 4398 gfc_expr *expr) 4399{ 4400 gfc_interface_sym_mapping *sm; 4401 tree desc; 4402 tree tmp; 4403 tree value; 4404 gfc_symbol *new_sym; 4405 gfc_symtree *root; 4406 gfc_symtree *new_symtree; 4407 4408 /* Create a new symbol to represent the actual argument. */ 4409 new_sym = gfc_new_symbol (sym->name, NULL); 4410 new_sym->ts = sym->ts; 4411 new_sym->as = gfc_copy_array_spec (sym->as); 4412 new_sym->attr.referenced = 1; 4413 new_sym->attr.dimension = sym->attr.dimension; 4414 new_sym->attr.contiguous = sym->attr.contiguous; 4415 new_sym->attr.codimension = sym->attr.codimension; 4416 new_sym->attr.pointer = sym->attr.pointer; 4417 new_sym->attr.allocatable = sym->attr.allocatable; 4418 new_sym->attr.flavor = sym->attr.flavor; 4419 new_sym->attr.function = sym->attr.function; 4420 4421 /* Ensure that the interface is available and that 4422 descriptors are passed for array actual arguments. */ 4423 if (sym->attr.flavor == FL_PROCEDURE) 4424 { 4425 new_sym->formal = expr->symtree->n.sym->formal; 4426 new_sym->attr.always_explicit 4427 = expr->symtree->n.sym->attr.always_explicit; 4428 } 4429 4430 /* Create a fake symtree for it. */ 4431 root = NULL; 4432 new_symtree = gfc_new_symtree (&root, sym->name); 4433 new_symtree->n.sym = new_sym; 4434 gcc_assert (new_symtree == root); 4435 4436 /* Create a dummy->actual mapping. */ 4437 sm = XCNEW (gfc_interface_sym_mapping); 4438 sm->next = mapping->syms; 4439 sm->old = sym; 4440 sm->new_sym = new_symtree; 4441 sm->expr = gfc_copy_expr (expr); 4442 mapping->syms = sm; 4443 4444 /* Stabilize the argument's value. */ 4445 if (!sym->attr.function && se) 4446 se->expr = gfc_evaluate_now (se->expr, &se->pre); 4447 4448 if (sym->ts.type == BT_CHARACTER) 4449 { 4450 /* Create a copy of the dummy argument's length. */ 4451 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl); 4452 sm->expr->ts.u.cl = new_sym->ts.u.cl; 4453 4454 /* If the length is specified as "*", record the length that 4455 the caller is passing. We should use the callee's length 4456 in all other cases. */ 4457 if (!new_sym->ts.u.cl->length && se) 4458 { 4459 se->string_length = gfc_evaluate_now (se->string_length, &se->pre); 4460 new_sym->ts.u.cl->backend_decl = se->string_length; 4461 } 4462 } 4463 4464 if (!se) 4465 return; 4466 4467 /* Use the passed value as-is if the argument is a function. */ 4468 if (sym->attr.flavor == FL_PROCEDURE) 4469 value = se->expr; 4470 4471 /* If the argument is a pass-by-value scalar, use the value as is. */ 4472 else if (!sym->attr.dimension && sym->attr.value) 4473 value = se->expr; 4474 4475 /* If the argument is either a string or a pointer to a string, 4476 convert it to a boundless character type. */ 4477 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER) 4478 { 4479 tmp = gfc_get_character_type_len (sym->ts.kind, NULL); 4480 tmp = build_pointer_type (tmp); 4481 if (sym->attr.pointer) 4482 value = build_fold_indirect_ref_loc (input_location, 4483 se->expr); 4484 else 4485 value = se->expr; 4486 value = fold_convert (tmp, value); 4487 } 4488 4489 /* If the argument is a scalar, a pointer to an array or an allocatable, 4490 dereference it. */ 4491 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable) 4492 value = build_fold_indirect_ref_loc (input_location, 4493 se->expr); 4494 4495 /* For character(*), use the actual argument's descriptor. */ 4496 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length) 4497 value = build_fold_indirect_ref_loc (input_location, 4498 se->expr); 4499 4500 /* If the argument is an array descriptor, use it to determine 4501 information about the actual argument's shape. */ 4502 else if (POINTER_TYPE_P (TREE_TYPE (se->expr)) 4503 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) 4504 { 4505 /* Get the actual argument's descriptor. */ 4506 desc = build_fold_indirect_ref_loc (input_location, 4507 se->expr); 4508 4509 /* Create the replacement variable. */ 4510 tmp = gfc_conv_descriptor_data_get (desc); 4511 value = gfc_get_interface_mapping_array (&se->pre, sym, 4512 PACKED_NO, tmp); 4513 4514 /* Use DESC to work out the upper bounds, strides and offset. */ 4515 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc); 4516 } 4517 else 4518 /* Otherwise we have a packed array. */ 4519 value = gfc_get_interface_mapping_array (&se->pre, sym, 4520 PACKED_FULL, se->expr); 4521 4522 new_sym->backend_decl = value; 4523} 4524 4525 4526/* Called once all dummy argument mappings have been added to MAPPING, 4527 but before the mapping is used to evaluate expressions. Pre-evaluate 4528 the length of each argument, adding any initialization code to PRE and 4529 any finalization code to POST. */ 4530 4531static void 4532gfc_finish_interface_mapping (gfc_interface_mapping * mapping, 4533 stmtblock_t * pre, stmtblock_t * post) 4534{ 4535 gfc_interface_sym_mapping *sym; 4536 gfc_expr *expr; 4537 gfc_se se; 4538 4539 for (sym = mapping->syms; sym; sym = sym->next) 4540 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER 4541 && !sym->new_sym->n.sym->ts.u.cl->backend_decl) 4542 { 4543 expr = sym->new_sym->n.sym->ts.u.cl->length; 4544 gfc_apply_interface_mapping_to_expr (mapping, expr); 4545 gfc_init_se (&se, NULL); 4546 gfc_conv_expr (&se, expr); 4547 se.expr = fold_convert (gfc_charlen_type_node, se.expr); 4548 se.expr = gfc_evaluate_now (se.expr, &se.pre); 4549 gfc_add_block_to_block (pre, &se.pre); 4550 gfc_add_block_to_block (post, &se.post); 4551 4552 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr; 4553 } 4554} 4555 4556 4557/* Like gfc_apply_interface_mapping_to_expr, but applied to 4558 constructor C. */ 4559 4560static void 4561gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, 4562 gfc_constructor_base base) 4563{ 4564 gfc_constructor *c; 4565 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 4566 { 4567 gfc_apply_interface_mapping_to_expr (mapping, c->expr); 4568 if (c->iterator) 4569 { 4570 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start); 4571 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end); 4572 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step); 4573 } 4574 } 4575} 4576 4577 4578/* Like gfc_apply_interface_mapping_to_expr, but applied to 4579 reference REF. */ 4580 4581static void 4582gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, 4583 gfc_ref * ref) 4584{ 4585 int n; 4586 4587 for (; ref; ref = ref->next) 4588 switch (ref->type) 4589 { 4590 case REF_ARRAY: 4591 for (n = 0; n < ref->u.ar.dimen; n++) 4592 { 4593 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]); 4594 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]); 4595 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]); 4596 } 4597 break; 4598 4599 case REF_COMPONENT: 4600 case REF_INQUIRY: 4601 break; 4602 4603 case REF_SUBSTRING: 4604 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start); 4605 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end); 4606 break; 4607 } 4608} 4609 4610 4611/* Convert intrinsic function calls into result expressions. */ 4612 4613static bool 4614gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) 4615{ 4616 gfc_symbol *sym; 4617 gfc_expr *new_expr; 4618 gfc_expr *arg1; 4619 gfc_expr *arg2; 4620 int d, dup; 4621 4622 arg1 = expr->value.function.actual->expr; 4623 if (expr->value.function.actual->next) 4624 arg2 = expr->value.function.actual->next->expr; 4625 else 4626 arg2 = NULL; 4627 4628 sym = arg1->symtree->n.sym; 4629 4630 if (sym->attr.dummy) 4631 return false; 4632 4633 new_expr = NULL; 4634 4635 switch (expr->value.function.isym->id) 4636 { 4637 case GFC_ISYM_LEN: 4638 /* TODO figure out why this condition is necessary. */ 4639 if (sym->attr.function 4640 && (arg1->ts.u.cl->length == NULL 4641 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT 4642 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE))) 4643 return false; 4644 4645 new_expr = gfc_copy_expr (arg1->ts.u.cl->length); 4646 break; 4647 4648 case GFC_ISYM_LEN_TRIM: 4649 new_expr = gfc_copy_expr (arg1); 4650 gfc_apply_interface_mapping_to_expr (mapping, new_expr); 4651 4652 if (!new_expr) 4653 return false; 4654 4655 gfc_replace_expr (arg1, new_expr); 4656 return true; 4657 4658 case GFC_ISYM_SIZE: 4659 if (!sym->as || sym->as->rank == 0) 4660 return false; 4661 4662 if (arg2 && arg2->expr_type == EXPR_CONSTANT) 4663 { 4664 dup = mpz_get_si (arg2->value.integer); 4665 d = dup - 1; 4666 } 4667 else 4668 { 4669 dup = sym->as->rank; 4670 d = 0; 4671 } 4672 4673 for (; d < dup; d++) 4674 { 4675 gfc_expr *tmp; 4676 4677 if (!sym->as->upper[d] || !sym->as->lower[d]) 4678 { 4679 gfc_free_expr (new_expr); 4680 return false; 4681 } 4682 4683 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), 4684 gfc_get_int_expr (gfc_default_integer_kind, 4685 NULL, 1)); 4686 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); 4687 if (new_expr) 4688 new_expr = gfc_multiply (new_expr, tmp); 4689 else 4690 new_expr = tmp; 4691 } 4692 break; 4693 4694 case GFC_ISYM_LBOUND: 4695 case GFC_ISYM_UBOUND: 4696 /* TODO These implementations of lbound and ubound do not limit if 4697 the size < 0, according to F95's 13.14.53 and 13.14.113. */ 4698 4699 if (!sym->as || sym->as->rank == 0) 4700 return false; 4701 4702 if (arg2 && arg2->expr_type == EXPR_CONSTANT) 4703 d = mpz_get_si (arg2->value.integer) - 1; 4704 else 4705 return false; 4706 4707 if (expr->value.function.isym->id == GFC_ISYM_LBOUND) 4708 { 4709 if (sym->as->lower[d]) 4710 new_expr = gfc_copy_expr (sym->as->lower[d]); 4711 } 4712 else 4713 { 4714 if (sym->as->upper[d]) 4715 new_expr = gfc_copy_expr (sym->as->upper[d]); 4716 } 4717 break; 4718 4719 default: 4720 break; 4721 } 4722 4723 gfc_apply_interface_mapping_to_expr (mapping, new_expr); 4724 if (!new_expr) 4725 return false; 4726 4727 gfc_replace_expr (expr, new_expr); 4728 return true; 4729} 4730 4731 4732static void 4733gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr, 4734 gfc_interface_mapping * mapping) 4735{ 4736 gfc_formal_arglist *f; 4737 gfc_actual_arglist *actual; 4738 4739 actual = expr->value.function.actual; 4740 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym); 4741 4742 for (; f && actual; f = f->next, actual = actual->next) 4743 { 4744 if (!actual->expr) 4745 continue; 4746 4747 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr); 4748 } 4749 4750 if (map_expr->symtree->n.sym->attr.dimension) 4751 { 4752 int d; 4753 gfc_array_spec *as; 4754 4755 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as); 4756 4757 for (d = 0; d < as->rank; d++) 4758 { 4759 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]); 4760 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]); 4761 } 4762 4763 expr->value.function.esym->as = as; 4764 } 4765 4766 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER) 4767 { 4768 expr->value.function.esym->ts.u.cl->length 4769 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length); 4770 4771 gfc_apply_interface_mapping_to_expr (mapping, 4772 expr->value.function.esym->ts.u.cl->length); 4773 } 4774} 4775 4776 4777/* EXPR is a copy of an expression that appeared in the interface 4778 associated with MAPPING. Walk it recursively looking for references to 4779 dummy arguments that MAPPING maps to actual arguments. Replace each such 4780 reference with a reference to the associated actual argument. */ 4781 4782static void 4783gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, 4784 gfc_expr * expr) 4785{ 4786 gfc_interface_sym_mapping *sym; 4787 gfc_actual_arglist *actual; 4788 4789 if (!expr) 4790 return; 4791 4792 /* Copying an expression does not copy its length, so do that here. */ 4793 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl) 4794 { 4795 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl); 4796 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length); 4797 } 4798 4799 /* Apply the mapping to any references. */ 4800 gfc_apply_interface_mapping_to_ref (mapping, expr->ref); 4801 4802 /* ...and to the expression's symbol, if it has one. */ 4803 /* TODO Find out why the condition on expr->symtree had to be moved into 4804 the loop rather than being outside it, as originally. */ 4805 for (sym = mapping->syms; sym; sym = sym->next) 4806 if (expr->symtree && sym->old == expr->symtree->n.sym) 4807 { 4808 if (sym->new_sym->n.sym->backend_decl) 4809 expr->symtree = sym->new_sym; 4810 else if (sym->expr) 4811 gfc_replace_expr (expr, gfc_copy_expr (sym->expr)); 4812 } 4813 4814 /* ...and to subexpressions in expr->value. */ 4815 switch (expr->expr_type) 4816 { 4817 case EXPR_VARIABLE: 4818 case EXPR_CONSTANT: 4819 case EXPR_NULL: 4820 case EXPR_SUBSTRING: 4821 break; 4822 4823 case EXPR_OP: 4824 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1); 4825 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2); 4826 break; 4827 4828 case EXPR_FUNCTION: 4829 for (actual = expr->value.function.actual; actual; actual = actual->next) 4830 gfc_apply_interface_mapping_to_expr (mapping, actual->expr); 4831 4832 if (expr->value.function.esym == NULL 4833 && expr->value.function.isym != NULL 4834 && expr->value.function.actual 4835 && expr->value.function.actual->expr 4836 && expr->value.function.actual->expr->symtree 4837 && gfc_map_intrinsic_function (expr, mapping)) 4838 break; 4839 4840 for (sym = mapping->syms; sym; sym = sym->next) 4841 if (sym->old == expr->value.function.esym) 4842 { 4843 expr->value.function.esym = sym->new_sym->n.sym; 4844 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping); 4845 expr->value.function.esym->result = sym->new_sym->n.sym; 4846 } 4847 break; 4848 4849 case EXPR_ARRAY: 4850 case EXPR_STRUCTURE: 4851 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); 4852 break; 4853 4854 case EXPR_COMPCALL: 4855 case EXPR_PPC: 4856 case EXPR_UNKNOWN: 4857 gcc_unreachable (); 4858 break; 4859 } 4860 4861 return; 4862} 4863 4864 4865/* Evaluate interface expression EXPR using MAPPING. Store the result 4866 in SE. */ 4867 4868void 4869gfc_apply_interface_mapping (gfc_interface_mapping * mapping, 4870 gfc_se * se, gfc_expr * expr) 4871{ 4872 expr = gfc_copy_expr (expr); 4873 gfc_apply_interface_mapping_to_expr (mapping, expr); 4874 gfc_conv_expr (se, expr); 4875 se->expr = gfc_evaluate_now (se->expr, &se->pre); 4876 gfc_free_expr (expr); 4877} 4878 4879 4880/* Returns a reference to a temporary array into which a component of 4881 an actual argument derived type array is copied and then returned 4882 after the function call. */ 4883void 4884gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, 4885 sym_intent intent, bool formal_ptr, 4886 const gfc_symbol *fsym, const char *proc_name, 4887 gfc_symbol *sym, bool check_contiguous) 4888{ 4889 gfc_se lse; 4890 gfc_se rse; 4891 gfc_ss *lss; 4892 gfc_ss *rss; 4893 gfc_loopinfo loop; 4894 gfc_loopinfo loop2; 4895 gfc_array_info *info; 4896 tree offset; 4897 tree tmp_index; 4898 tree tmp; 4899 tree base_type; 4900 tree size; 4901 stmtblock_t body; 4902 int n; 4903 int dimen; 4904 gfc_se work_se; 4905 gfc_se *parmse; 4906 bool pass_optional; 4907 4908 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional; 4909 4910 if (pass_optional || check_contiguous) 4911 { 4912 gfc_init_se (&work_se, NULL); 4913 parmse = &work_se; 4914 } 4915 else 4916 parmse = se; 4917 4918 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) 4919 { 4920 /* We will create a temporary array, so let us warn. */ 4921 char * msg; 4922 4923 if (fsym && proc_name) 4924 msg = xasprintf ("An array temporary was created for argument " 4925 "'%s' of procedure '%s'", fsym->name, proc_name); 4926 else 4927 msg = xasprintf ("An array temporary was created"); 4928 4929 tmp = build_int_cst (logical_type_node, 1); 4930 gfc_trans_runtime_check (false, true, tmp, &parmse->pre, 4931 &expr->where, msg); 4932 free (msg); 4933 } 4934 4935 gfc_init_se (&lse, NULL); 4936 gfc_init_se (&rse, NULL); 4937 4938 /* Walk the argument expression. */ 4939 rss = gfc_walk_expr (expr); 4940 4941 gcc_assert (rss != gfc_ss_terminator); 4942 4943 /* Initialize the scalarizer. */ 4944 gfc_init_loopinfo (&loop); 4945 gfc_add_ss_to_loop (&loop, rss); 4946 4947 /* Calculate the bounds of the scalarization. */ 4948 gfc_conv_ss_startstride (&loop); 4949 4950 /* Build an ss for the temporary. */ 4951 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) 4952 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre); 4953 4954 base_type = gfc_typenode_for_spec (&expr->ts); 4955 if (GFC_ARRAY_TYPE_P (base_type) 4956 || GFC_DESCRIPTOR_TYPE_P (base_type)) 4957 base_type = gfc_get_element_type (base_type); 4958 4959 if (expr->ts.type == BT_CLASS) 4960 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts); 4961 4962 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER) 4963 ? expr->ts.u.cl->backend_decl 4964 : NULL), 4965 loop.dimen); 4966 4967 parmse->string_length = loop.temp_ss->info->string_length; 4968 4969 /* Associate the SS with the loop. */ 4970 gfc_add_ss_to_loop (&loop, loop.temp_ss); 4971 4972 /* Setup the scalarizing loops. */ 4973 gfc_conv_loop_setup (&loop, &expr->where); 4974 4975 /* Pass the temporary descriptor back to the caller. */ 4976 info = &loop.temp_ss->info->data.array; 4977 parmse->expr = info->descriptor; 4978 4979 /* Setup the gfc_se structures. */ 4980 gfc_copy_loopinfo_to_se (&lse, &loop); 4981 gfc_copy_loopinfo_to_se (&rse, &loop); 4982 4983 rse.ss = rss; 4984 lse.ss = loop.temp_ss; 4985 gfc_mark_ss_chain_used (rss, 1); 4986 gfc_mark_ss_chain_used (loop.temp_ss, 1); 4987 4988 /* Start the scalarized loop body. */ 4989 gfc_start_scalarized_body (&loop, &body); 4990 4991 /* Translate the expression. */ 4992 gfc_conv_expr (&rse, expr); 4993 4994 /* Reset the offset for the function call since the loop 4995 is zero based on the data pointer. Note that the temp 4996 comes first in the loop chain since it is added second. */ 4997 if (gfc_is_class_array_function (expr)) 4998 { 4999 tmp = loop.ss->loop_chain->info->data.array.descriptor; 5000 gfc_conv_descriptor_offset_set (&loop.pre, tmp, 5001 gfc_index_zero_node); 5002 } 5003 5004 gfc_conv_tmp_array_ref (&lse); 5005 5006 if (intent != INTENT_OUT) 5007 { 5008 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); 5009 gfc_add_expr_to_block (&body, tmp); 5010 gcc_assert (rse.ss == gfc_ss_terminator); 5011 gfc_trans_scalarizing_loops (&loop, &body); 5012 } 5013 else 5014 { 5015 /* Make sure that the temporary declaration survives by merging 5016 all the loop declarations into the current context. */ 5017 for (n = 0; n < loop.dimen; n++) 5018 { 5019 gfc_merge_block_scope (&body); 5020 body = loop.code[loop.order[n]]; 5021 } 5022 gfc_merge_block_scope (&body); 5023 } 5024 5025 /* Add the post block after the second loop, so that any 5026 freeing of allocated memory is done at the right time. */ 5027 gfc_add_block_to_block (&parmse->pre, &loop.pre); 5028 5029 /**********Copy the temporary back again.*********/ 5030 5031 gfc_init_se (&lse, NULL); 5032 gfc_init_se (&rse, NULL); 5033 5034 /* Walk the argument expression. */ 5035 lss = gfc_walk_expr (expr); 5036 rse.ss = loop.temp_ss; 5037 lse.ss = lss; 5038 5039 /* Initialize the scalarizer. */ 5040 gfc_init_loopinfo (&loop2); 5041 gfc_add_ss_to_loop (&loop2, lss); 5042 5043 dimen = rse.ss->dimen; 5044 5045 /* Skip the write-out loop for this case. */ 5046 if (gfc_is_class_array_function (expr)) 5047 goto class_array_fcn; 5048 5049 /* Calculate the bounds of the scalarization. */ 5050 gfc_conv_ss_startstride (&loop2); 5051 5052 /* Setup the scalarizing loops. */ 5053 gfc_conv_loop_setup (&loop2, &expr->where); 5054 5055 gfc_copy_loopinfo_to_se (&lse, &loop2); 5056 gfc_copy_loopinfo_to_se (&rse, &loop2); 5057 5058 gfc_mark_ss_chain_used (lss, 1); 5059 gfc_mark_ss_chain_used (loop.temp_ss, 1); 5060 5061 /* Declare the variable to hold the temporary offset and start the 5062 scalarized loop body. */ 5063 offset = gfc_create_var (gfc_array_index_type, NULL); 5064 gfc_start_scalarized_body (&loop2, &body); 5065 5066 /* Build the offsets for the temporary from the loop variables. The 5067 temporary array has lbounds of zero and strides of one in all 5068 dimensions, so this is very simple. The offset is only computed 5069 outside the innermost loop, so the overall transfer could be 5070 optimized further. */ 5071 info = &rse.ss->info->data.array; 5072 5073 tmp_index = gfc_index_zero_node; 5074 for (n = dimen - 1; n > 0; n--) 5075 { 5076 tree tmp_str; 5077 tmp = rse.loop->loopvar[n]; 5078 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 5079 tmp, rse.loop->from[n]); 5080 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 5081 tmp, tmp_index); 5082 5083 tmp_str = fold_build2_loc (input_location, MINUS_EXPR, 5084 gfc_array_index_type, 5085 rse.loop->to[n-1], rse.loop->from[n-1]); 5086 tmp_str = fold_build2_loc (input_location, PLUS_EXPR, 5087 gfc_array_index_type, 5088 tmp_str, gfc_index_one_node); 5089 5090 tmp_index = fold_build2_loc (input_location, MULT_EXPR, 5091 gfc_array_index_type, tmp, tmp_str); 5092 } 5093 5094 tmp_index = fold_build2_loc (input_location, MINUS_EXPR, 5095 gfc_array_index_type, 5096 tmp_index, rse.loop->from[0]); 5097 gfc_add_modify (&rse.loop->code[0], offset, tmp_index); 5098 5099 tmp_index = fold_build2_loc (input_location, PLUS_EXPR, 5100 gfc_array_index_type, 5101 rse.loop->loopvar[0], offset); 5102 5103 /* Now use the offset for the reference. */ 5104 tmp = build_fold_indirect_ref_loc (input_location, 5105 info->data); 5106 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL); 5107 5108 if (expr->ts.type == BT_CHARACTER) 5109 rse.string_length = expr->ts.u.cl->backend_decl; 5110 5111 gfc_conv_expr (&lse, expr); 5112 5113 gcc_assert (lse.ss == gfc_ss_terminator); 5114 5115 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true); 5116 gfc_add_expr_to_block (&body, tmp); 5117 5118 /* Generate the copying loops. */ 5119 gfc_trans_scalarizing_loops (&loop2, &body); 5120 5121 /* Wrap the whole thing up by adding the second loop to the post-block 5122 and following it by the post-block of the first loop. In this way, 5123 if the temporary needs freeing, it is done after use! */ 5124 if (intent != INTENT_IN) 5125 { 5126 gfc_add_block_to_block (&parmse->post, &loop2.pre); 5127 gfc_add_block_to_block (&parmse->post, &loop2.post); 5128 } 5129 5130class_array_fcn: 5131 5132 gfc_add_block_to_block (&parmse->post, &loop.post); 5133 5134 gfc_cleanup_loop (&loop); 5135 gfc_cleanup_loop (&loop2); 5136 5137 /* Pass the string length to the argument expression. */ 5138 if (expr->ts.type == BT_CHARACTER) 5139 parmse->string_length = expr->ts.u.cl->backend_decl; 5140 5141 /* Determine the offset for pointer formal arguments and set the 5142 lbounds to one. */ 5143 if (formal_ptr) 5144 { 5145 size = gfc_index_one_node; 5146 offset = gfc_index_zero_node; 5147 for (n = 0; n < dimen; n++) 5148 { 5149 tmp = gfc_conv_descriptor_ubound_get (parmse->expr, 5150 gfc_rank_cst[n]); 5151 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5152 gfc_array_index_type, tmp, 5153 gfc_index_one_node); 5154 gfc_conv_descriptor_ubound_set (&parmse->pre, 5155 parmse->expr, 5156 gfc_rank_cst[n], 5157 tmp); 5158 gfc_conv_descriptor_lbound_set (&parmse->pre, 5159 parmse->expr, 5160 gfc_rank_cst[n], 5161 gfc_index_one_node); 5162 size = gfc_evaluate_now (size, &parmse->pre); 5163 offset = fold_build2_loc (input_location, MINUS_EXPR, 5164 gfc_array_index_type, 5165 offset, size); 5166 offset = gfc_evaluate_now (offset, &parmse->pre); 5167 tmp = fold_build2_loc (input_location, MINUS_EXPR, 5168 gfc_array_index_type, 5169 rse.loop->to[n], rse.loop->from[n]); 5170 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5171 gfc_array_index_type, 5172 tmp, gfc_index_one_node); 5173 size = fold_build2_loc (input_location, MULT_EXPR, 5174 gfc_array_index_type, size, tmp); 5175 } 5176 5177 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr, 5178 offset); 5179 } 5180 5181 /* We want either the address for the data or the address of the descriptor, 5182 depending on the mode of passing array arguments. */ 5183 if (g77) 5184 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr); 5185 else 5186 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); 5187 5188 /* Basically make this into 5189 5190 if (present) 5191 { 5192 if (contiguous) 5193 { 5194 pointer = a; 5195 } 5196 else 5197 { 5198 parmse->pre(); 5199 pointer = parmse->expr; 5200 } 5201 } 5202 else 5203 pointer = NULL; 5204 5205 foo (pointer); 5206 if (present && !contiguous) 5207 se->post(); 5208 5209 */ 5210 5211 if (pass_optional || check_contiguous) 5212 { 5213 tree type; 5214 stmtblock_t else_block; 5215 tree pre_stmts, post_stmts; 5216 tree pointer; 5217 tree else_stmt; 5218 tree present_var = NULL_TREE; 5219 tree cont_var = NULL_TREE; 5220 tree post_cond; 5221 5222 type = TREE_TYPE (parmse->expr); 5223 if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) 5224 type = TREE_TYPE (type); 5225 pointer = gfc_create_var (type, "arg_ptr"); 5226 5227 if (check_contiguous) 5228 { 5229 gfc_se cont_se, array_se; 5230 stmtblock_t if_block, else_block; 5231 tree if_stmt, else_stmt; 5232 mpz_t size; 5233 bool size_set; 5234 5235 cont_var = gfc_create_var (boolean_type_node, "contiguous"); 5236 5237 /* If the size is known to be one at compile-time, set 5238 cont_var to true unconditionally. This may look 5239 inelegant, but we're only doing this during 5240 optimization, so the statements will be optimized away, 5241 and this saves complexity here. */ 5242 5243 size_set = gfc_array_size (expr, &size); 5244 if (size_set && mpz_cmp_ui (size, 1) == 0) 5245 { 5246 gfc_add_modify (&se->pre, cont_var, 5247 build_one_cst (boolean_type_node)); 5248 } 5249 else 5250 { 5251 /* cont_var = is_contiguous (expr); . */ 5252 gfc_init_se (&cont_se, parmse); 5253 gfc_conv_is_contiguous_expr (&cont_se, expr); 5254 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre); 5255 gfc_add_modify (&se->pre, cont_var, cont_se.expr); 5256 gfc_add_block_to_block (&se->pre, &(&cont_se)->post); 5257 } 5258 5259 if (size_set) 5260 mpz_clear (size); 5261 5262 /* arrayse->expr = descriptor of a. */ 5263 gfc_init_se (&array_se, se); 5264 gfc_conv_expr_descriptor (&array_se, expr); 5265 gfc_add_block_to_block (&se->pre, &(&array_se)->pre); 5266 gfc_add_block_to_block (&se->pre, &(&array_se)->post); 5267 5268 /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */ 5269 gfc_init_block (&if_block); 5270 if (GFC_DESCRIPTOR_TYPE_P (type)) 5271 gfc_add_modify (&if_block, pointer, array_se.expr); 5272 else 5273 { 5274 tmp = gfc_conv_array_data (array_se.expr); 5275 tmp = fold_convert (type, tmp); 5276 gfc_add_modify (&if_block, pointer, tmp); 5277 } 5278 if_stmt = gfc_finish_block (&if_block); 5279 5280 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */ 5281 gfc_init_block (&else_block); 5282 gfc_add_block_to_block (&else_block, &parmse->pre); 5283 tmp = (GFC_DESCRIPTOR_TYPE_P (type) 5284 ? build_fold_indirect_ref_loc (input_location, parmse->expr) 5285 : parmse->expr); 5286 gfc_add_modify (&else_block, pointer, tmp); 5287 else_stmt = gfc_finish_block (&else_block); 5288 5289 /* And put the above into an if statement. */ 5290 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node, 5291 gfc_likely (cont_var, 5292 PRED_FORTRAN_CONTIGUOUS), 5293 if_stmt, else_stmt); 5294 } 5295 else 5296 { 5297 /* pointer = pramse->expr; . */ 5298 gfc_add_modify (&parmse->pre, pointer, parmse->expr); 5299 pre_stmts = gfc_finish_block (&parmse->pre); 5300 } 5301 5302 if (pass_optional) 5303 { 5304 present_var = gfc_create_var (boolean_type_node, "present"); 5305 5306 /* present_var = present(sym); . */ 5307 tmp = gfc_conv_expr_present (sym); 5308 tmp = fold_convert (boolean_type_node, tmp); 5309 gfc_add_modify (&se->pre, present_var, tmp); 5310 5311 /* else_stmt = { pointer = NULL; } . */ 5312 gfc_init_block (&else_block); 5313 if (GFC_DESCRIPTOR_TYPE_P (type)) 5314 gfc_conv_descriptor_data_set (&else_block, pointer, 5315 null_pointer_node); 5316 else 5317 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0)); 5318 else_stmt = gfc_finish_block (&else_block); 5319 5320 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 5321 gfc_likely (present_var, 5322 PRED_FORTRAN_ABSENT_DUMMY), 5323 pre_stmts, else_stmt); 5324 gfc_add_expr_to_block (&se->pre, tmp); 5325 } 5326 else 5327 gfc_add_expr_to_block (&se->pre, pre_stmts); 5328 5329 post_stmts = gfc_finish_block (&parmse->post); 5330 5331 /* Put together the post stuff, plus the optional 5332 deallocation. */ 5333 if (check_contiguous) 5334 { 5335 /* !cont_var. */ 5336 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 5337 cont_var, 5338 build_zero_cst (boolean_type_node)); 5339 tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS); 5340 5341 if (pass_optional) 5342 { 5343 tree present_likely = gfc_likely (present_var, 5344 PRED_FORTRAN_ABSENT_DUMMY); 5345 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 5346 boolean_type_node, present_likely, 5347 tmp); 5348 } 5349 else 5350 post_cond = tmp; 5351 } 5352 else 5353 { 5354 gcc_assert (pass_optional); 5355 post_cond = present_var; 5356 } 5357 5358 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond, 5359 post_stmts, build_empty_stmt (input_location)); 5360 gfc_add_expr_to_block (&se->post, tmp); 5361 if (GFC_DESCRIPTOR_TYPE_P (type)) 5362 { 5363 type = TREE_TYPE (parmse->expr); 5364 if (POINTER_TYPE_P (type)) 5365 { 5366 pointer = gfc_build_addr_expr (type, pointer); 5367 if (pass_optional) 5368 { 5369 tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY); 5370 pointer = fold_build3_loc (input_location, COND_EXPR, type, 5371 tmp, pointer, 5372 fold_convert (type, 5373 null_pointer_node)); 5374 } 5375 } 5376 else 5377 gcc_assert (!pass_optional); 5378 } 5379 se->expr = pointer; 5380 } 5381 5382 return; 5383} 5384 5385 5386/* Generate the code for argument list functions. */ 5387 5388static void 5389conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) 5390{ 5391 /* Pass by value for g77 %VAL(arg), pass the address 5392 indirectly for %LOC, else by reference. Thus %REF 5393 is a "do-nothing" and %LOC is the same as an F95 5394 pointer. */ 5395 if (strcmp (name, "%VAL") == 0) 5396 gfc_conv_expr (se, expr); 5397 else if (strcmp (name, "%LOC") == 0) 5398 { 5399 gfc_conv_expr_reference (se, expr); 5400 se->expr = gfc_build_addr_expr (NULL, se->expr); 5401 } 5402 else if (strcmp (name, "%REF") == 0) 5403 gfc_conv_expr_reference (se, expr); 5404 else 5405 gfc_error ("Unknown argument list function at %L", &expr->where); 5406} 5407 5408 5409/* This function tells whether the middle-end representation of the expression 5410 E given as input may point to data otherwise accessible through a variable 5411 (sub-)reference. 5412 It is assumed that the only expressions that may alias are variables, 5413 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements 5414 may alias. 5415 This function is used to decide whether freeing an expression's allocatable 5416 components is safe or should be avoided. 5417 5418 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of 5419 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick 5420 is necessary because for array constructors, aliasing depends on how 5421 the array is used: 5422 - If E is an array constructor used as argument to an elemental procedure, 5423 the array, which is generated through shallow copy by the scalarizer, 5424 is used directly and can alias the expressions it was copied from. 5425 - If E is an array constructor used as argument to a non-elemental 5426 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate 5427 the array as in the previous case, but then that array is used 5428 to initialize a new descriptor through deep copy. There is no alias 5429 possible in that case. 5430 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases 5431 above. */ 5432 5433static bool 5434expr_may_alias_variables (gfc_expr *e, bool array_may_alias) 5435{ 5436 gfc_constructor *c; 5437 5438 if (e->expr_type == EXPR_VARIABLE) 5439 return true; 5440 else if (e->expr_type == EXPR_FUNCTION) 5441 { 5442 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e); 5443 5444 if (proc_ifc->result != NULL 5445 && ((proc_ifc->result->ts.type == BT_CLASS 5446 && proc_ifc->result->ts.u.derived->attr.is_class 5447 && CLASS_DATA (proc_ifc->result)->attr.class_pointer) 5448 || proc_ifc->result->attr.pointer)) 5449 return true; 5450 else 5451 return false; 5452 } 5453 else if (e->expr_type != EXPR_ARRAY || !array_may_alias) 5454 return false; 5455 5456 for (c = gfc_constructor_first (e->value.constructor); 5457 c; c = gfc_constructor_next (c)) 5458 if (c->expr 5459 && expr_may_alias_variables (c->expr, array_may_alias)) 5460 return true; 5461 5462 return false; 5463} 5464 5465 5466/* A helper function to set the dtype for unallocated or unassociated 5467 entities. */ 5468 5469static void 5470set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e) 5471{ 5472 tree tmp; 5473 tree desc; 5474 tree cond; 5475 tree type; 5476 stmtblock_t block; 5477 5478 /* TODO Figure out how to handle optional dummies. */ 5479 if (e && e->expr_type == EXPR_VARIABLE 5480 && e->symtree->n.sym->attr.optional) 5481 return; 5482 5483 desc = parmse->expr; 5484 if (desc == NULL_TREE) 5485 return; 5486 5487 if (POINTER_TYPE_P (TREE_TYPE (desc))) 5488 desc = build_fold_indirect_ref_loc (input_location, desc); 5489 if (GFC_CLASS_TYPE_P (TREE_TYPE (desc))) 5490 desc = gfc_class_data_get (desc); 5491 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) 5492 return; 5493 5494 gfc_init_block (&block); 5495 tmp = gfc_conv_descriptor_data_get (desc); 5496 cond = fold_build2_loc (input_location, EQ_EXPR, 5497 logical_type_node, tmp, 5498 build_int_cst (TREE_TYPE (tmp), 0)); 5499 tmp = gfc_conv_descriptor_dtype (desc); 5500 type = gfc_get_element_type (TREE_TYPE (desc)); 5501 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 5502 TREE_TYPE (tmp), tmp, 5503 gfc_get_dtype_rank_type (e->rank, type)); 5504 gfc_add_expr_to_block (&block, tmp); 5505 cond = build3_v (COND_EXPR, cond, 5506 gfc_finish_block (&block), 5507 build_empty_stmt (input_location)); 5508 gfc_add_expr_to_block (&parmse->pre, cond); 5509} 5510 5511 5512 5513/* Provide an interface between gfortran array descriptors and the F2018:18.4 5514 ISO_Fortran_binding array descriptors. */ 5515 5516static void 5517gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) 5518{ 5519 stmtblock_t block, block2; 5520 tree cfi, gfc, tmp, tmp2; 5521 tree present = NULL; 5522 tree gfc_strlen = NULL; 5523 tree rank; 5524 gfc_se se; 5525 5526 if (fsym->attr.optional 5527 && e->expr_type == EXPR_VARIABLE 5528 && e->symtree->n.sym->attr.optional) 5529 present = gfc_conv_expr_present (e->symtree->n.sym); 5530 5531 gfc_init_block (&block); 5532 5533 /* Convert original argument to a tree. */ 5534 gfc_init_se (&se, NULL); 5535 if (e->rank == 0) 5536 { 5537 se.want_pointer = 1; 5538 gfc_conv_expr (&se, e); 5539 gfc = se.expr; 5540 /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */ 5541 if (!POINTER_TYPE_P (TREE_TYPE (gfc))) 5542 gfc = gfc_build_addr_expr (NULL, gfc); 5543 } 5544 else 5545 { 5546 /* If the actual argument can be noncontiguous, copy-in/out is required, 5547 if the dummy has either the CONTIGUOUS attribute or is an assumed- 5548 length assumed-length/assumed-size CHARACTER array. This only 5549 applies if the actual argument is a "variable"; if it's some 5550 non-lvalue expression, we are going to evaluate it to a 5551 temporary below anyway. */ 5552 se.force_no_tmp = 1; 5553 if ((fsym->attr.contiguous 5554 || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length 5555 && (fsym->as->type == AS_ASSUMED_SIZE 5556 || fsym->as->type == AS_EXPLICIT))) 5557 && !gfc_is_simply_contiguous (e, false, true) 5558 && gfc_expr_is_variable (e)) 5559 { 5560 bool optional = fsym->attr.optional; 5561 fsym->attr.optional = 0; 5562 gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent, 5563 fsym->attr.pointer, fsym, 5564 fsym->ns->proc_name->name, NULL, 5565 /* check_contiguous= */ true); 5566 fsym->attr.optional = optional; 5567 } 5568 else 5569 gfc_conv_expr_descriptor (&se, e); 5570 gfc = se.expr; 5571 /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses 5572 elem_len = sizeof(dt) and base_addr = dt(lb) instead. 5573 gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below. 5574 While sm is fine as it uses span*stride and not elem_len. */ 5575 if (POINTER_TYPE_P (TREE_TYPE (gfc))) 5576 gfc = build_fold_indirect_ref_loc (input_location, gfc); 5577 else if (is_subref_array (e) && e->ts.type != BT_CHARACTER) 5578 gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e); 5579 } 5580 if (e->ts.type == BT_CHARACTER) 5581 { 5582 if (se.string_length) 5583 gfc_strlen = se.string_length; 5584 else if (e->ts.u.cl->backend_decl) 5585 gfc_strlen = e->ts.u.cl->backend_decl; 5586 else 5587 gcc_unreachable (); 5588 } 5589 gfc_add_block_to_block (&block, &se.pre); 5590 5591 /* Create array decriptor and set version, rank, attribute, type. */ 5592 cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0 5593 ? GFC_MAX_DIMENSIONS : e->rank, 5594 false), "cfi"); 5595 /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/ 5596 if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK) 5597 { 5598 tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target); 5599 tmp = build_pointer_type (tmp); 5600 parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi); 5601 cfi = build_fold_indirect_ref_loc (input_location, cfi); 5602 } 5603 else 5604 parmse->expr = gfc_build_addr_expr (NULL, cfi); 5605 5606 tmp = gfc_get_cfi_desc_version (cfi); 5607 gfc_add_modify (&block, tmp, 5608 build_int_cst (TREE_TYPE (tmp), CFI_VERSION)); 5609 if (e->rank < 0) 5610 rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc)); 5611 else 5612 rank = build_int_cst (signed_char_type_node, e->rank); 5613 tmp = gfc_get_cfi_desc_rank (cfi); 5614 gfc_add_modify (&block, tmp, rank); 5615 int itype = CFI_type_other; 5616 if (e->ts.f90_type == BT_VOID) 5617 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR 5618 ? CFI_type_cfunptr : CFI_type_cptr); 5619 else 5620 { 5621 if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN) 5622 e->ts = fsym->ts; 5623 switch (e->ts.type) 5624 { 5625 case BT_INTEGER: 5626 case BT_LOGICAL: 5627 case BT_REAL: 5628 case BT_COMPLEX: 5629 itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind); 5630 break; 5631 case BT_CHARACTER: 5632 itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind); 5633 break; 5634 case BT_DERIVED: 5635 itype = CFI_type_struct; 5636 break; 5637 case BT_VOID: 5638 itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR 5639 ? CFI_type_cfunptr : CFI_type_cptr); 5640 break; 5641 case BT_ASSUMED: 5642 itype = CFI_type_other; // FIXME: Or CFI_type_cptr ? 5643 break; 5644 case BT_CLASS: 5645 if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED) 5646 { 5647 // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*) 5648 // type specifier is assumed-type and is an unlimited polymorphic 5649 // entity." The actual argument _data component is passed. 5650 itype = CFI_type_other; // FIXME: Or CFI_type_cptr ? 5651 break; 5652 } 5653 else 5654 gcc_unreachable (); 5655 case BT_PROCEDURE: 5656 case BT_HOLLERITH: 5657 case BT_UNION: 5658 case BT_BOZ: 5659 case BT_UNKNOWN: 5660 // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other? 5661 gcc_unreachable (); 5662 } 5663 } 5664 5665 tmp = gfc_get_cfi_desc_type (cfi); 5666 gfc_add_modify (&block, tmp, 5667 build_int_cst (TREE_TYPE (tmp), itype)); 5668 5669 int attr = CFI_attribute_other; 5670 if (fsym->attr.pointer) 5671 attr = CFI_attribute_pointer; 5672 else if (fsym->attr.allocatable) 5673 attr = CFI_attribute_allocatable; 5674 tmp = gfc_get_cfi_desc_attribute (cfi); 5675 gfc_add_modify (&block, tmp, 5676 build_int_cst (TREE_TYPE (tmp), attr)); 5677 5678 if (e->rank == 0) 5679 { 5680 tmp = gfc_get_cfi_desc_base_addr (cfi); 5681 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc)); 5682 } 5683 else 5684 { 5685 tmp = gfc_get_cfi_desc_base_addr (cfi); 5686 tmp2 = gfc_conv_descriptor_data_get (gfc); 5687 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); 5688 } 5689 5690 /* Set elem_len if known - must be before the next if block. 5691 Note that allocatable implies 'len=:'. */ 5692 if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER ) 5693 { 5694 /* Length is known at compile time; use 'block' for it. */ 5695 tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts)); 5696 tmp2 = gfc_get_cfi_desc_elem_len (cfi); 5697 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); 5698 } 5699 5700 /* When allocatable + intent out, free the cfi descriptor. */ 5701 if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT) 5702 { 5703 tmp = gfc_get_cfi_desc_base_addr (cfi); 5704 tree call = builtin_decl_explicit (BUILT_IN_FREE); 5705 call = build_call_expr_loc (input_location, call, 1, tmp); 5706 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); 5707 gfc_add_modify (&block, tmp, 5708 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 5709 goto done; 5710 } 5711 5712 /* If not unallocated/unassociated. */ 5713 gfc_init_block (&block2); 5714 5715 /* Set elem_len, which may be only known at run time. */ 5716 if (e->ts.type == BT_CHARACTER 5717 && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE)) 5718 { 5719 gcc_assert (gfc_strlen); 5720 tmp = gfc_strlen; 5721 if (e->ts.kind != 1) 5722 tmp = fold_build2_loc (input_location, MULT_EXPR, 5723 gfc_charlen_type_node, tmp, 5724 build_int_cst (gfc_charlen_type_node, 5725 e->ts.kind)); 5726 tmp2 = gfc_get_cfi_desc_elem_len (cfi); 5727 gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); 5728 } 5729 else if (e->ts.type == BT_ASSUMED) 5730 { 5731 tmp = gfc_conv_descriptor_elem_len (gfc); 5732 tmp2 = gfc_get_cfi_desc_elem_len (cfi); 5733 gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); 5734 } 5735 5736 if (e->ts.type == BT_ASSUMED) 5737 { 5738 /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires 5739 an CFI descriptor. Use the type in the descritor as it provide 5740 mode information. (Quality of implementation feature.) */ 5741 tree cond; 5742 tree ctype = gfc_get_cfi_desc_type (cfi); 5743 tree type = fold_convert (TREE_TYPE (ctype), 5744 gfc_conv_descriptor_type (gfc)); 5745 tree kind = fold_convert (TREE_TYPE (ctype), 5746 gfc_conv_descriptor_elem_len (gfc)); 5747 kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type), 5748 kind, build_int_cst (TREE_TYPE (type), 5749 CFI_type_kind_shift)); 5750 5751 /* if (BT_VOID) CFI_type_cptr else CFI_type_other */ 5752 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */ 5753 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5754 build_int_cst (TREE_TYPE (type), BT_VOID)); 5755 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype, 5756 build_int_cst (TREE_TYPE (type), CFI_type_cptr)); 5757 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 5758 ctype, 5759 build_int_cst (TREE_TYPE (type), CFI_type_other)); 5760 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5761 tmp, tmp2); 5762 /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */ 5763 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5764 build_int_cst (TREE_TYPE (type), BT_DERIVED)); 5765 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype, 5766 build_int_cst (TREE_TYPE (type), CFI_type_struct)); 5767 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5768 tmp, tmp2); 5769 /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */ 5770 /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */ 5771 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5772 build_int_cst (TREE_TYPE (type), BT_CHARACTER)); 5773 tmp = build_int_cst (TREE_TYPE (type), 5774 CFI_type_from_type_kind (CFI_type_Character, 1)); 5775 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 5776 ctype, tmp); 5777 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5778 tmp, tmp2); 5779 /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */ 5780 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5781 build_int_cst (TREE_TYPE (type), BT_COMPLEX)); 5782 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type), 5783 kind, build_int_cst (TREE_TYPE (type), 2)); 5784 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp, 5785 build_int_cst (TREE_TYPE (type), 5786 CFI_type_Complex)); 5787 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 5788 ctype, tmp); 5789 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5790 tmp, tmp2); 5791 /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */ 5792 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5793 build_int_cst (TREE_TYPE (type), BT_INTEGER)); 5794 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5795 build_int_cst (TREE_TYPE (type), BT_LOGICAL)); 5796 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 5797 cond, tmp); 5798 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type, 5799 build_int_cst (TREE_TYPE (type), BT_REAL)); 5800 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 5801 cond, tmp); 5802 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), 5803 type, kind); 5804 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 5805 ctype, tmp); 5806 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 5807 tmp, tmp2); 5808 gfc_add_expr_to_block (&block2, tmp2); 5809 } 5810 5811 if (e->rank != 0) 5812 { 5813 /* Loop: for (i = 0; i < rank; ++i). */ 5814 tree idx = gfc_create_var (TREE_TYPE (rank), "idx"); 5815 /* Loop body. */ 5816 stmtblock_t loop_body; 5817 gfc_init_block (&loop_body); 5818 /* cfi->dim[i].lower_bound = (allocatable/pointer) 5819 ? gfc->dim[i].lbound : 0 */ 5820 if (fsym->attr.pointer || fsym->attr.allocatable) 5821 tmp = gfc_conv_descriptor_lbound_get (gfc, idx); 5822 else 5823 tmp = gfc_index_zero_node; 5824 gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp); 5825 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */ 5826 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 5827 gfc_conv_descriptor_ubound_get (gfc, idx), 5828 gfc_conv_descriptor_lbound_get (gfc, idx)); 5829 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 5830 tmp, gfc_index_one_node); 5831 gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp); 5832 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */ 5833 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 5834 gfc_conv_descriptor_stride_get (gfc, idx), 5835 gfc_conv_descriptor_span_get (gfc)); 5836 gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); 5837 5838 /* Generate loop. */ 5839 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0), 5840 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 5841 gfc_finish_block (&loop_body)); 5842 5843 if (e->expr_type == EXPR_VARIABLE 5844 && e->ref 5845 && e->ref->u.ar.type == AR_FULL 5846 && e->symtree->n.sym->attr.dummy 5847 && e->symtree->n.sym->as 5848 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) 5849 { 5850 tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]), 5851 gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1)); 5852 } 5853 } 5854 5855 if (fsym->attr.allocatable || fsym->attr.pointer) 5856 { 5857 tmp = gfc_get_cfi_desc_base_addr (cfi), 5858 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 5859 tmp, null_pointer_node); 5860 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2), 5861 build_empty_stmt (input_location)); 5862 gfc_add_expr_to_block (&block, tmp); 5863 } 5864 else 5865 gfc_add_block_to_block (&block, &block2); 5866 5867 5868done: 5869 if (present) 5870 { 5871 parmse->expr = build3_loc (input_location, COND_EXPR, 5872 TREE_TYPE (parmse->expr), 5873 present, parmse->expr, null_pointer_node); 5874 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), 5875 build_empty_stmt (input_location)); 5876 gfc_add_expr_to_block (&parmse->pre, tmp); 5877 } 5878 else 5879 gfc_add_block_to_block (&parmse->pre, &block); 5880 5881 gfc_init_block (&block); 5882 5883 if ((!fsym->attr.allocatable && !fsym->attr.pointer) 5884 || fsym->attr.intent == INTENT_IN) 5885 goto post_call; 5886 5887 gfc_init_block (&block2); 5888 if (e->rank == 0) 5889 { 5890 tmp = gfc_get_cfi_desc_base_addr (cfi); 5891 gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp)); 5892 } 5893 else 5894 { 5895 tmp = gfc_get_cfi_desc_base_addr (cfi); 5896 gfc_conv_descriptor_data_set (&block, gfc, tmp); 5897 5898 if (fsym->attr.allocatable) 5899 { 5900 /* gfc->span = cfi->elem_len. */ 5901 tmp = fold_convert (gfc_array_index_type, 5902 gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0])); 5903 } 5904 else 5905 { 5906 /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len) 5907 ? cfi->dim[0].sm : cfi->elem_len). */ 5908 tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]); 5909 tmp2 = fold_convert (gfc_array_index_type, 5910 gfc_get_cfi_desc_elem_len (cfi)); 5911 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, 5912 gfc_array_index_type, tmp, tmp2); 5913 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 5914 tmp, gfc_index_zero_node); 5915 tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp, 5916 gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2); 5917 } 5918 gfc_conv_descriptor_span_set (&block2, gfc, tmp); 5919 5920 /* Calculate offset + set lbound, ubound and stride. */ 5921 gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node); 5922 /* Loop: for (i = 0; i < rank; ++i). */ 5923 tree idx = gfc_create_var (TREE_TYPE (rank), "idx"); 5924 /* Loop body. */ 5925 stmtblock_t loop_body; 5926 gfc_init_block (&loop_body); 5927 /* gfc->dim[i].lbound = ... */ 5928 tmp = gfc_get_cfi_dim_lbound (cfi, idx); 5929 gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp); 5930 5931 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */ 5932 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 5933 gfc_conv_descriptor_lbound_get (gfc, idx), 5934 gfc_index_one_node); 5935 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 5936 gfc_get_cfi_dim_extent (cfi, idx), tmp); 5937 gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp); 5938 5939 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */ 5940 tmp = gfc_get_cfi_dim_sm (cfi, idx); 5941 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 5942 gfc_array_index_type, tmp, 5943 fold_convert (gfc_array_index_type, 5944 gfc_get_cfi_desc_elem_len (cfi))); 5945 gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp); 5946 5947 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */ 5948 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 5949 gfc_conv_descriptor_stride_get (gfc, idx), 5950 gfc_conv_descriptor_lbound_get (gfc, idx)); 5951 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 5952 gfc_conv_descriptor_offset_get (gfc), tmp); 5953 gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp); 5954 /* Generate loop. */ 5955 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0), 5956 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 5957 gfc_finish_block (&loop_body)); 5958 } 5959 5960 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) 5961 { 5962 tmp = fold_convert (gfc_charlen_type_node, 5963 gfc_get_cfi_desc_elem_len (cfi)); 5964 if (e->ts.kind != 1) 5965 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 5966 gfc_charlen_type_node, tmp, 5967 build_int_cst (gfc_charlen_type_node, 5968 e->ts.kind)); 5969 gfc_add_modify (&block2, gfc_strlen, tmp); 5970 } 5971 5972 tmp = gfc_get_cfi_desc_base_addr (cfi), 5973 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 5974 tmp, null_pointer_node); 5975 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2), 5976 build_empty_stmt (input_location)); 5977 gfc_add_expr_to_block (&block, tmp); 5978 5979post_call: 5980 gfc_add_block_to_block (&block, &se.post); 5981 if (present && block.head) 5982 { 5983 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), 5984 build_empty_stmt (input_location)); 5985 gfc_add_expr_to_block (&parmse->post, tmp); 5986 } 5987 else if (block.head) 5988 gfc_add_block_to_block (&parmse->post, &block); 5989} 5990 5991 5992/* Generate code for a procedure call. Note can return se->post != NULL. 5993 If se->direct_byref is set then se->expr contains the return parameter. 5994 Return nonzero, if the call has alternate specifiers. 5995 'expr' is only needed for procedure pointer components. */ 5996 5997int 5998gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 5999 gfc_actual_arglist * args, gfc_expr * expr, 6000 vec<tree, va_gc> *append_args) 6001{ 6002 gfc_interface_mapping mapping; 6003 vec<tree, va_gc> *arglist; 6004 vec<tree, va_gc> *retargs; 6005 tree tmp; 6006 tree fntype; 6007 gfc_se parmse; 6008 gfc_array_info *info; 6009 int byref; 6010 int parm_kind; 6011 tree type; 6012 tree var; 6013 tree len; 6014 tree base_object; 6015 vec<tree, va_gc> *stringargs; 6016 vec<tree, va_gc> *optionalargs; 6017 tree result = NULL; 6018 gfc_formal_arglist *formal; 6019 gfc_actual_arglist *arg; 6020 int has_alternate_specifier = 0; 6021 bool need_interface_mapping; 6022 bool callee_alloc; 6023 bool ulim_copy; 6024 gfc_typespec ts; 6025 gfc_charlen cl; 6026 gfc_expr *e; 6027 gfc_symbol *fsym; 6028 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; 6029 gfc_component *comp = NULL; 6030 int arglen; 6031 unsigned int argc; 6032 6033 arglist = NULL; 6034 retargs = NULL; 6035 stringargs = NULL; 6036 optionalargs = NULL; 6037 var = NULL_TREE; 6038 len = NULL_TREE; 6039 gfc_clear_ts (&ts); 6040 6041 comp = gfc_get_proc_ptr_comp (expr); 6042 6043 bool elemental_proc = (comp 6044 && comp->ts.interface 6045 && comp->ts.interface->attr.elemental) 6046 || (comp && comp->attr.elemental) 6047 || sym->attr.elemental; 6048 6049 if (se->ss != NULL) 6050 { 6051 if (!elemental_proc) 6052 { 6053 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION); 6054 if (se->ss->info->useflags) 6055 { 6056 gcc_assert ((!comp && gfc_return_by_reference (sym) 6057 && sym->result->attr.dimension) 6058 || (comp && comp->attr.dimension) 6059 || gfc_is_class_array_function (expr)); 6060 gcc_assert (se->loop != NULL); 6061 /* Access the previously obtained result. */ 6062 gfc_conv_tmp_array_ref (se); 6063 return 0; 6064 } 6065 } 6066 info = &se->ss->info->data.array; 6067 } 6068 else 6069 info = NULL; 6070 6071 stmtblock_t post, clobbers; 6072 gfc_init_block (&post); 6073 gfc_init_block (&clobbers); 6074 gfc_init_interface_mapping (&mapping); 6075 if (!comp) 6076 { 6077 formal = gfc_sym_get_dummy_args (sym); 6078 need_interface_mapping = sym->attr.dimension || 6079 (sym->ts.type == BT_CHARACTER 6080 && sym->ts.u.cl->length 6081 && sym->ts.u.cl->length->expr_type 6082 != EXPR_CONSTANT); 6083 } 6084 else 6085 { 6086 formal = comp->ts.interface ? comp->ts.interface->formal : NULL; 6087 need_interface_mapping = comp->attr.dimension || 6088 (comp->ts.type == BT_CHARACTER 6089 && comp->ts.u.cl->length 6090 && comp->ts.u.cl->length->expr_type 6091 != EXPR_CONSTANT); 6092 } 6093 6094 base_object = NULL_TREE; 6095 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless 6096 is the third and fourth argument to such a function call a value 6097 denoting the number of elements to copy (i.e., most of the time the 6098 length of a deferred length string). */ 6099 ulim_copy = (formal == NULL) 6100 && UNLIMITED_POLY (sym) 6101 && comp && (strcmp ("_copy", comp->name) == 0); 6102 6103 /* Evaluate the arguments. */ 6104 for (arg = args, argc = 0; arg != NULL; 6105 arg = arg->next, formal = formal ? formal->next : NULL, ++argc) 6106 { 6107 bool finalized = false; 6108 tree derived_array = NULL_TREE; 6109 6110 e = arg->expr; 6111 fsym = formal ? formal->sym : NULL; 6112 parm_kind = MISSING; 6113 6114 /* If the procedure requires an explicit interface, the actual 6115 argument is passed according to the corresponding formal 6116 argument. If the corresponding formal argument is a POINTER, 6117 ALLOCATABLE or assumed shape, we do not use g77's calling 6118 convention, and pass the address of the array descriptor 6119 instead. Otherwise we use g77's calling convention, in other words 6120 pass the array data pointer without descriptor. */ 6121 bool nodesc_arg = fsym != NULL 6122 && !(fsym->attr.pointer || fsym->attr.allocatable) 6123 && fsym->as 6124 && fsym->as->type != AS_ASSUMED_SHAPE 6125 && fsym->as->type != AS_ASSUMED_RANK; 6126 if (comp) 6127 nodesc_arg = nodesc_arg || !comp->attr.always_explicit; 6128 else 6129 nodesc_arg = nodesc_arg || !sym->attr.always_explicit; 6130 6131 /* Class array expressions are sometimes coming completely unadorned 6132 with either arrayspec or _data component. Correct that here. 6133 OOP-TODO: Move this to the frontend. */ 6134 if (e && e->expr_type == EXPR_VARIABLE 6135 && !e->ref 6136 && e->ts.type == BT_CLASS 6137 && (CLASS_DATA (e)->attr.codimension 6138 || CLASS_DATA (e)->attr.dimension)) 6139 { 6140 gfc_typespec temp_ts = e->ts; 6141 gfc_add_class_array_ref (e); 6142 e->ts = temp_ts; 6143 } 6144 6145 if (e == NULL) 6146 { 6147 if (se->ignore_optional) 6148 { 6149 /* Some intrinsics have already been resolved to the correct 6150 parameters. */ 6151 continue; 6152 } 6153 else if (arg->label) 6154 { 6155 has_alternate_specifier = 1; 6156 continue; 6157 } 6158 else 6159 { 6160 gfc_init_se (&parmse, NULL); 6161 6162 /* For scalar arguments with VALUE attribute which are passed by 6163 value, pass "0" and a hidden argument gives the optional 6164 status. */ 6165 if (fsym && fsym->attr.optional && fsym->attr.value 6166 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER 6167 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED) 6168 { 6169 parmse.expr = fold_convert (gfc_sym_type (fsym), 6170 integer_zero_node); 6171 vec_safe_push (optionalargs, boolean_false_node); 6172 } 6173 else 6174 { 6175 /* Pass a NULL pointer for an absent arg. */ 6176 parmse.expr = null_pointer_node; 6177 gfc_dummy_arg * const dummy_arg = arg->associated_dummy; 6178 if (dummy_arg 6179 && gfc_dummy_arg_get_typespec (*dummy_arg).type 6180 == BT_CHARACTER) 6181 parmse.string_length = build_int_cst (gfc_charlen_type_node, 6182 0); 6183 } 6184 } 6185 } 6186 else if (arg->expr->expr_type == EXPR_NULL 6187 && fsym && !fsym->attr.pointer 6188 && (fsym->ts.type != BT_CLASS 6189 || !CLASS_DATA (fsym)->attr.class_pointer)) 6190 { 6191 /* Pass a NULL pointer to denote an absent arg. */ 6192 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable 6193 && (fsym->ts.type != BT_CLASS 6194 || !CLASS_DATA (fsym)->attr.allocatable)); 6195 gfc_init_se (&parmse, NULL); 6196 parmse.expr = null_pointer_node; 6197 if (arg->associated_dummy 6198 && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type 6199 == BT_CHARACTER) 6200 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); 6201 } 6202 else if (fsym && fsym->ts.type == BT_CLASS 6203 && e->ts.type == BT_DERIVED) 6204 { 6205 /* The derived type needs to be converted to a temporary 6206 CLASS object. */ 6207 gfc_init_se (&parmse, se); 6208 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL, 6209 fsym->attr.optional 6210 && e->expr_type == EXPR_VARIABLE 6211 && e->symtree->n.sym->attr.optional, 6212 CLASS_DATA (fsym)->attr.class_pointer 6213 || CLASS_DATA (fsym)->attr.allocatable, 6214 &derived_array); 6215 } 6216 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS 6217 && e->ts.type != BT_PROCEDURE 6218 && (gfc_expr_attr (e).flavor != FL_PROCEDURE 6219 || gfc_expr_attr (e).proc != PROC_UNKNOWN)) 6220 { 6221 /* The intrinsic type needs to be converted to a temporary 6222 CLASS object for the unlimited polymorphic formal. */ 6223 gfc_find_vtab (&e->ts); 6224 gfc_init_se (&parmse, se); 6225 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts); 6226 6227 } 6228 else if (se->ss && se->ss->info->useflags) 6229 { 6230 gfc_ss *ss; 6231 6232 ss = se->ss; 6233 6234 /* An elemental function inside a scalarized loop. */ 6235 gfc_init_se (&parmse, se); 6236 parm_kind = ELEMENTAL; 6237 6238 /* When no fsym is present, ulim_copy is set and this is a third or 6239 fourth argument, use call-by-value instead of by reference to 6240 hand the length properties to the copy routine (i.e., most of the 6241 time this will be a call to a __copy_character_* routine where the 6242 third and fourth arguments are the lengths of a deferred length 6243 char array). */ 6244 if ((fsym && fsym->attr.value) 6245 || (ulim_copy && (argc == 2 || argc == 3))) 6246 gfc_conv_expr (&parmse, e); 6247 else 6248 gfc_conv_expr_reference (&parmse, e); 6249 6250 if (e->ts.type == BT_CHARACTER && !e->rank 6251 && e->expr_type == EXPR_FUNCTION) 6252 parmse.expr = build_fold_indirect_ref_loc (input_location, 6253 parmse.expr); 6254 6255 if (fsym && fsym->ts.type == BT_DERIVED 6256 && gfc_is_class_container_ref (e)) 6257 { 6258 parmse.expr = gfc_class_data_get (parmse.expr); 6259 6260 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE 6261 && e->symtree->n.sym->attr.optional) 6262 { 6263 tree cond = gfc_conv_expr_present (e->symtree->n.sym); 6264 parmse.expr = build3_loc (input_location, COND_EXPR, 6265 TREE_TYPE (parmse.expr), 6266 cond, parmse.expr, 6267 fold_convert (TREE_TYPE (parmse.expr), 6268 null_pointer_node)); 6269 } 6270 } 6271 6272 /* If we are passing an absent array as optional dummy to an 6273 elemental procedure, make sure that we pass NULL when the data 6274 pointer is NULL. We need this extra conditional because of 6275 scalarization which passes arrays elements to the procedure, 6276 ignoring the fact that the array can be absent/unallocated/... */ 6277 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE) 6278 { 6279 tree descriptor_data; 6280 6281 descriptor_data = ss->info->data.array.data; 6282 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 6283 descriptor_data, 6284 fold_convert (TREE_TYPE (descriptor_data), 6285 null_pointer_node)); 6286 parmse.expr 6287 = fold_build3_loc (input_location, COND_EXPR, 6288 TREE_TYPE (parmse.expr), 6289 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY), 6290 fold_convert (TREE_TYPE (parmse.expr), 6291 null_pointer_node), 6292 parmse.expr); 6293 } 6294 6295 /* The scalarizer does not repackage the reference to a class 6296 array - instead it returns a pointer to the data element. */ 6297 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS) 6298 gfc_conv_class_to_class (&parmse, e, fsym->ts, true, 6299 fsym->attr.intent != INTENT_IN 6300 && (CLASS_DATA (fsym)->attr.class_pointer 6301 || CLASS_DATA (fsym)->attr.allocatable), 6302 fsym->attr.optional 6303 && e->expr_type == EXPR_VARIABLE 6304 && e->symtree->n.sym->attr.optional, 6305 CLASS_DATA (fsym)->attr.class_pointer 6306 || CLASS_DATA (fsym)->attr.allocatable); 6307 } 6308 else 6309 { 6310 bool scalar; 6311 gfc_ss *argss; 6312 6313 gfc_init_se (&parmse, NULL); 6314 6315 /* Check whether the expression is a scalar or not; we cannot use 6316 e->rank as it can be nonzero for functions arguments. */ 6317 argss = gfc_walk_expr (e); 6318 scalar = argss == gfc_ss_terminator; 6319 if (!scalar) 6320 gfc_free_ss_chain (argss); 6321 6322 /* Special handling for passing scalar polymorphic coarrays; 6323 otherwise one passes "class->_data.data" instead of "&class". */ 6324 if (e->rank == 0 && e->ts.type == BT_CLASS 6325 && fsym && fsym->ts.type == BT_CLASS 6326 && CLASS_DATA (fsym)->attr.codimension 6327 && !CLASS_DATA (fsym)->attr.dimension) 6328 { 6329 gfc_add_class_array_ref (e); 6330 parmse.want_coarray = 1; 6331 scalar = false; 6332 } 6333 6334 /* A scalar or transformational function. */ 6335 if (scalar) 6336 { 6337 if (e->expr_type == EXPR_VARIABLE 6338 && e->symtree->n.sym->attr.cray_pointee 6339 && fsym && fsym->attr.flavor == FL_PROCEDURE) 6340 { 6341 /* The Cray pointer needs to be converted to a pointer to 6342 a type given by the expression. */ 6343 gfc_conv_expr (&parmse, e); 6344 type = build_pointer_type (TREE_TYPE (parmse.expr)); 6345 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer); 6346 parmse.expr = convert (type, tmp); 6347 } 6348 6349 else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL)) 6350 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ 6351 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); 6352 6353 else if (fsym && fsym->attr.value) 6354 { 6355 if (fsym->ts.type == BT_CHARACTER 6356 && fsym->ts.is_c_interop 6357 && fsym->ns->proc_name != NULL 6358 && fsym->ns->proc_name->attr.is_bind_c) 6359 { 6360 parmse.expr = NULL; 6361 conv_scalar_char_value (fsym, &parmse, &e); 6362 if (parmse.expr == NULL) 6363 gfc_conv_expr (&parmse, e); 6364 } 6365 else 6366 { 6367 gfc_conv_expr (&parmse, e); 6368 if (fsym->attr.optional 6369 && fsym->ts.type != BT_CLASS 6370 && fsym->ts.type != BT_DERIVED) 6371 { 6372 if (e->expr_type != EXPR_VARIABLE 6373 || !e->symtree->n.sym->attr.optional 6374 || e->ref != NULL) 6375 vec_safe_push (optionalargs, boolean_true_node); 6376 else 6377 { 6378 tmp = gfc_conv_expr_present (e->symtree->n.sym); 6379 if (!e->symtree->n.sym->attr.value) 6380 parmse.expr 6381 = fold_build3_loc (input_location, COND_EXPR, 6382 TREE_TYPE (parmse.expr), 6383 tmp, parmse.expr, 6384 fold_convert (TREE_TYPE (parmse.expr), 6385 integer_zero_node)); 6386 6387 vec_safe_push (optionalargs, 6388 fold_convert (boolean_type_node, 6389 tmp)); 6390 } 6391 } 6392 } 6393 } 6394 6395 else if (arg->name && arg->name[0] == '%') 6396 /* Argument list functions %VAL, %LOC and %REF are signalled 6397 through arg->name. */ 6398 conv_arglist_function (&parmse, arg->expr, arg->name); 6399 else if ((e->expr_type == EXPR_FUNCTION) 6400 && ((e->value.function.esym 6401 && e->value.function.esym->result->attr.pointer) 6402 || (!e->value.function.esym 6403 && e->symtree->n.sym->attr.pointer)) 6404 && fsym && fsym->attr.target) 6405 /* Make sure the function only gets called once. */ 6406 gfc_conv_expr_reference (&parmse, e); 6407 else if (e->expr_type == EXPR_FUNCTION 6408 && e->symtree->n.sym->result 6409 && e->symtree->n.sym->result != e->symtree->n.sym 6410 && e->symtree->n.sym->result->attr.proc_pointer) 6411 { 6412 /* Functions returning procedure pointers. */ 6413 gfc_conv_expr (&parmse, e); 6414 if (fsym && fsym->attr.proc_pointer) 6415 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); 6416 } 6417 6418 else 6419 { 6420 if (e->ts.type == BT_CLASS && fsym 6421 && fsym->ts.type == BT_CLASS 6422 && (!CLASS_DATA (fsym)->as 6423 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK) 6424 && CLASS_DATA (e)->attr.codimension) 6425 { 6426 gcc_assert (!CLASS_DATA (fsym)->attr.codimension); 6427 gcc_assert (!CLASS_DATA (fsym)->as); 6428 gfc_add_class_array_ref (e); 6429 parmse.want_coarray = 1; 6430 gfc_conv_expr_reference (&parmse, e); 6431 class_scalar_coarray_to_class (&parmse, e, fsym->ts, 6432 fsym->attr.optional 6433 && e->expr_type == EXPR_VARIABLE); 6434 } 6435 else if (e->ts.type == BT_CLASS && fsym 6436 && fsym->ts.type == BT_CLASS 6437 && !CLASS_DATA (fsym)->as 6438 && !CLASS_DATA (e)->as 6439 && strcmp (fsym->ts.u.derived->name, 6440 e->ts.u.derived->name)) 6441 { 6442 type = gfc_typenode_for_spec (&fsym->ts); 6443 var = gfc_create_var (type, fsym->name); 6444 gfc_conv_expr (&parmse, e); 6445 if (fsym->attr.optional 6446 && e->expr_type == EXPR_VARIABLE 6447 && e->symtree->n.sym->attr.optional) 6448 { 6449 stmtblock_t block; 6450 tree cond; 6451 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr); 6452 cond = fold_build2_loc (input_location, NE_EXPR, 6453 logical_type_node, tmp, 6454 fold_convert (TREE_TYPE (tmp), 6455 null_pointer_node)); 6456 gfc_start_block (&block); 6457 gfc_add_modify (&block, var, 6458 fold_build1_loc (input_location, 6459 VIEW_CONVERT_EXPR, 6460 type, parmse.expr)); 6461 gfc_add_expr_to_block (&parmse.pre, 6462 fold_build3_loc (input_location, 6463 COND_EXPR, void_type_node, 6464 cond, gfc_finish_block (&block), 6465 build_empty_stmt (input_location))); 6466 parmse.expr = gfc_build_addr_expr (NULL_TREE, var); 6467 parmse.expr = build3_loc (input_location, COND_EXPR, 6468 TREE_TYPE (parmse.expr), 6469 cond, parmse.expr, 6470 fold_convert (TREE_TYPE (parmse.expr), 6471 null_pointer_node)); 6472 } 6473 else 6474 { 6475 /* Since the internal representation of unlimited 6476 polymorphic expressions includes an extra field 6477 that other class objects do not, a cast to the 6478 formal type does not work. */ 6479 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym)) 6480 { 6481 tree efield; 6482 6483 /* Set the _data field. */ 6484 tmp = gfc_class_data_get (var); 6485 efield = fold_convert (TREE_TYPE (tmp), 6486 gfc_class_data_get (parmse.expr)); 6487 gfc_add_modify (&parmse.pre, tmp, efield); 6488 6489 /* Set the _vptr field. */ 6490 tmp = gfc_class_vptr_get (var); 6491 efield = fold_convert (TREE_TYPE (tmp), 6492 gfc_class_vptr_get (parmse.expr)); 6493 gfc_add_modify (&parmse.pre, tmp, efield); 6494 6495 /* Set the _len field. */ 6496 tmp = gfc_class_len_get (var); 6497 gfc_add_modify (&parmse.pre, tmp, 6498 build_int_cst (TREE_TYPE (tmp), 0)); 6499 } 6500 else 6501 { 6502 tmp = fold_build1_loc (input_location, 6503 VIEW_CONVERT_EXPR, 6504 type, parmse.expr); 6505 gfc_add_modify (&parmse.pre, var, tmp); 6506 ; 6507 } 6508 parmse.expr = gfc_build_addr_expr (NULL_TREE, var); 6509 } 6510 } 6511 else 6512 { 6513 gfc_conv_expr_reference (&parmse, e); 6514 6515 if (fsym 6516 && fsym->attr.intent == INTENT_OUT 6517 && !fsym->attr.allocatable 6518 && !fsym->attr.pointer 6519 && e->expr_type == EXPR_VARIABLE 6520 && e->ref == NULL 6521 && e->symtree 6522 && e->symtree->n.sym 6523 && !e->symtree->n.sym->attr.dimension 6524 && !e->symtree->n.sym->attr.pointer 6525 && !e->symtree->n.sym->attr.allocatable 6526 /* See PR 41453. */ 6527 && !e->symtree->n.sym->attr.dummy 6528 /* FIXME - PR 87395 and PR 41453 */ 6529 && e->symtree->n.sym->attr.save == SAVE_NONE 6530 && !e->symtree->n.sym->attr.associate_var 6531 && e->ts.type != BT_CHARACTER 6532 && e->ts.type != BT_DERIVED 6533 && e->ts.type != BT_CLASS 6534 && !sym->attr.elemental) 6535 { 6536 tree var; 6537 /* FIXME: This fails if var is passed by reference, see PR 6538 41453. */ 6539 var = build_fold_indirect_ref_loc (input_location, 6540 parmse.expr); 6541 tree clobber = build_clobber (TREE_TYPE (var)); 6542 gfc_add_modify (&clobbers, var, clobber); 6543 } 6544 } 6545 /* Catch base objects that are not variables. */ 6546 if (e->ts.type == BT_CLASS 6547 && e->expr_type != EXPR_VARIABLE 6548 && expr && e == expr->base_expr) 6549 base_object = build_fold_indirect_ref_loc (input_location, 6550 parmse.expr); 6551 6552 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 6553 allocated on entry, it must be deallocated. */ 6554 if (fsym && fsym->attr.intent == INTENT_OUT 6555 && (fsym->attr.allocatable 6556 || (fsym->ts.type == BT_CLASS 6557 && CLASS_DATA (fsym)->attr.allocatable)) 6558 && !is_CFI_desc (fsym, NULL)) 6559 { 6560 stmtblock_t block; 6561 tree ptr; 6562 6563 gfc_init_block (&block); 6564 ptr = parmse.expr; 6565 if (e->ts.type == BT_CLASS) 6566 ptr = gfc_class_data_get (ptr); 6567 6568 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE, 6569 NULL_TREE, true, 6570 e, e->ts); 6571 gfc_add_expr_to_block (&block, tmp); 6572 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 6573 void_type_node, ptr, 6574 null_pointer_node); 6575 gfc_add_expr_to_block (&block, tmp); 6576 6577 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym)) 6578 { 6579 gfc_add_modify (&block, ptr, 6580 fold_convert (TREE_TYPE (ptr), 6581 null_pointer_node)); 6582 gfc_add_expr_to_block (&block, tmp); 6583 } 6584 else if (fsym->ts.type == BT_CLASS) 6585 { 6586 gfc_symbol *vtab; 6587 vtab = gfc_find_derived_vtab (fsym->ts.u.derived); 6588 tmp = gfc_get_symbol_decl (vtab); 6589 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 6590 ptr = gfc_class_vptr_get (parmse.expr); 6591 gfc_add_modify (&block, ptr, 6592 fold_convert (TREE_TYPE (ptr), tmp)); 6593 gfc_add_expr_to_block (&block, tmp); 6594 } 6595 6596 if (fsym->attr.optional 6597 && e->expr_type == EXPR_VARIABLE 6598 && e->symtree->n.sym->attr.optional) 6599 { 6600 tmp = fold_build3_loc (input_location, COND_EXPR, 6601 void_type_node, 6602 gfc_conv_expr_present (e->symtree->n.sym), 6603 gfc_finish_block (&block), 6604 build_empty_stmt (input_location)); 6605 } 6606 else 6607 tmp = gfc_finish_block (&block); 6608 6609 gfc_add_expr_to_block (&se->pre, tmp); 6610 } 6611 6612 /* A class array element needs converting back to be a 6613 class object, if the formal argument is a class object. */ 6614 if (fsym && fsym->ts.type == BT_CLASS 6615 && e->ts.type == BT_CLASS 6616 && ((CLASS_DATA (fsym)->as 6617 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) 6618 || CLASS_DATA (e)->attr.dimension)) 6619 gfc_conv_class_to_class (&parmse, e, fsym->ts, false, 6620 fsym->attr.intent != INTENT_IN 6621 && (CLASS_DATA (fsym)->attr.class_pointer 6622 || CLASS_DATA (fsym)->attr.allocatable), 6623 fsym->attr.optional 6624 && e->expr_type == EXPR_VARIABLE 6625 && e->symtree->n.sym->attr.optional, 6626 CLASS_DATA (fsym)->attr.class_pointer 6627 || CLASS_DATA (fsym)->attr.allocatable); 6628 6629 if (fsym && (fsym->ts.type == BT_DERIVED 6630 || fsym->ts.type == BT_ASSUMED) 6631 && e->ts.type == BT_CLASS 6632 && !CLASS_DATA (e)->attr.dimension 6633 && !CLASS_DATA (e)->attr.codimension) 6634 { 6635 parmse.expr = gfc_class_data_get (parmse.expr); 6636 /* The result is a class temporary, whose _data component 6637 must be freed to avoid a memory leak. */ 6638 if (e->expr_type == EXPR_FUNCTION 6639 && CLASS_DATA (e)->attr.allocatable) 6640 { 6641 tree zero; 6642 6643 gfc_expr *var; 6644 6645 /* Borrow the function symbol to make a call to 6646 gfc_add_finalizer_call and then restore it. */ 6647 tmp = e->symtree->n.sym->backend_decl; 6648 e->symtree->n.sym->backend_decl 6649 = TREE_OPERAND (parmse.expr, 0); 6650 e->symtree->n.sym->attr.flavor = FL_VARIABLE; 6651 var = gfc_lval_expr_from_sym (e->symtree->n.sym); 6652 finalized = gfc_add_finalizer_call (&parmse.post, 6653 var); 6654 gfc_free_expr (var); 6655 e->symtree->n.sym->backend_decl = tmp; 6656 e->symtree->n.sym->attr.flavor = FL_PROCEDURE; 6657 6658 /* Then free the class _data. */ 6659 zero = build_int_cst (TREE_TYPE (parmse.expr), 0); 6660 tmp = fold_build2_loc (input_location, NE_EXPR, 6661 logical_type_node, 6662 parmse.expr, zero); 6663 tmp = build3_v (COND_EXPR, tmp, 6664 gfc_call_free (parmse.expr), 6665 build_empty_stmt (input_location)); 6666 gfc_add_expr_to_block (&parmse.post, tmp); 6667 gfc_add_modify (&parmse.post, parmse.expr, zero); 6668 } 6669 } 6670 6671 /* Wrap scalar variable in a descriptor. We need to convert 6672 the address of a pointer back to the pointer itself before, 6673 we can assign it to the data field. */ 6674 6675 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK 6676 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL) 6677 { 6678 tmp = parmse.expr; 6679 if (TREE_CODE (tmp) == ADDR_EXPR) 6680 tmp = TREE_OPERAND (tmp, 0); 6681 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp, 6682 fsym->attr); 6683 parmse.expr = gfc_build_addr_expr (NULL_TREE, 6684 parmse.expr); 6685 } 6686 else if (fsym && e->expr_type != EXPR_NULL 6687 && ((fsym->attr.pointer 6688 && fsym->attr.flavor != FL_PROCEDURE) 6689 || (fsym->attr.proc_pointer 6690 && !(e->expr_type == EXPR_VARIABLE 6691 && e->symtree->n.sym->attr.dummy)) 6692 || (fsym->attr.proc_pointer 6693 && e->expr_type == EXPR_VARIABLE 6694 && gfc_is_proc_ptr_comp (e)) 6695 || (fsym->attr.allocatable 6696 && fsym->attr.flavor != FL_PROCEDURE))) 6697 { 6698 /* Scalar pointer dummy args require an extra level of 6699 indirection. The null pointer already contains 6700 this level of indirection. */ 6701 parm_kind = SCALAR_POINTER; 6702 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); 6703 } 6704 } 6705 } 6706 else if (e->ts.type == BT_CLASS 6707 && fsym && fsym->ts.type == BT_CLASS 6708 && (CLASS_DATA (fsym)->attr.dimension 6709 || CLASS_DATA (fsym)->attr.codimension)) 6710 { 6711 /* Pass a class array. */ 6712 parmse.use_offset = 1; 6713 gfc_conv_expr_descriptor (&parmse, e); 6714 6715 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 6716 allocated on entry, it must be deallocated. */ 6717 if (fsym->attr.intent == INTENT_OUT 6718 && CLASS_DATA (fsym)->attr.allocatable) 6719 { 6720 stmtblock_t block; 6721 tree ptr; 6722 6723 gfc_init_block (&block); 6724 ptr = parmse.expr; 6725 ptr = gfc_class_data_get (ptr); 6726 6727 tmp = gfc_deallocate_with_status (ptr, NULL_TREE, 6728 NULL_TREE, NULL_TREE, 6729 NULL_TREE, true, e, 6730 GFC_CAF_COARRAY_NOCOARRAY); 6731 gfc_add_expr_to_block (&block, tmp); 6732 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 6733 void_type_node, ptr, 6734 null_pointer_node); 6735 gfc_add_expr_to_block (&block, tmp); 6736 gfc_reset_vptr (&block, e); 6737 6738 if (fsym->attr.optional 6739 && e->expr_type == EXPR_VARIABLE 6740 && (!e->ref 6741 || (e->ref->type == REF_ARRAY 6742 && e->ref->u.ar.type != AR_FULL)) 6743 && e->symtree->n.sym->attr.optional) 6744 { 6745 tmp = fold_build3_loc (input_location, COND_EXPR, 6746 void_type_node, 6747 gfc_conv_expr_present (e->symtree->n.sym), 6748 gfc_finish_block (&block), 6749 build_empty_stmt (input_location)); 6750 } 6751 else 6752 tmp = gfc_finish_block (&block); 6753 6754 gfc_add_expr_to_block (&se->pre, tmp); 6755 } 6756 6757 /* The conversion does not repackage the reference to a class 6758 array - _data descriptor. */ 6759 gfc_conv_class_to_class (&parmse, e, fsym->ts, false, 6760 fsym->attr.intent != INTENT_IN 6761 && (CLASS_DATA (fsym)->attr.class_pointer 6762 || CLASS_DATA (fsym)->attr.allocatable), 6763 fsym->attr.optional 6764 && e->expr_type == EXPR_VARIABLE 6765 && e->symtree->n.sym->attr.optional, 6766 CLASS_DATA (fsym)->attr.class_pointer 6767 || CLASS_DATA (fsym)->attr.allocatable); 6768 } 6769 else 6770 { 6771 /* If the argument is a function call that may not create 6772 a temporary for the result, we have to check that we 6773 can do it, i.e. that there is no alias between this 6774 argument and another one. */ 6775 if (gfc_get_noncopying_intrinsic_argument (e) != NULL) 6776 { 6777 gfc_expr *iarg; 6778 sym_intent intent; 6779 6780 if (fsym != NULL) 6781 intent = fsym->attr.intent; 6782 else 6783 intent = INTENT_UNKNOWN; 6784 6785 if (gfc_check_fncall_dependency (e, intent, sym, args, 6786 NOT_ELEMENTAL)) 6787 parmse.force_tmp = 1; 6788 6789 iarg = e->value.function.actual->expr; 6790 6791 /* Temporary needed if aliasing due to host association. */ 6792 if (sym->attr.contained 6793 && !sym->attr.pure 6794 && !sym->attr.implicit_pure 6795 && !sym->attr.use_assoc 6796 && iarg->expr_type == EXPR_VARIABLE 6797 && sym->ns == iarg->symtree->n.sym->ns) 6798 parmse.force_tmp = 1; 6799 6800 /* Ditto within module. */ 6801 if (sym->attr.use_assoc 6802 && !sym->attr.pure 6803 && !sym->attr.implicit_pure 6804 && iarg->expr_type == EXPR_VARIABLE 6805 && sym->module == iarg->symtree->n.sym->module) 6806 parmse.force_tmp = 1; 6807 } 6808 6809 /* Special case for assumed-rank arrays: when passing an 6810 argument to a nonallocatable/nonpointer dummy, the bounds have 6811 to be reset as otherwise a last-dim ubound of -1 is 6812 indistinguishable from an assumed-size array in the callee. */ 6813 if (!sym->attr.is_bind_c && e && fsym && fsym->as 6814 && fsym->as->type == AS_ASSUMED_RANK 6815 && e->rank != -1 6816 && e->expr_type == EXPR_VARIABLE 6817 && ((fsym->ts.type == BT_CLASS 6818 && !CLASS_DATA (fsym)->attr.class_pointer 6819 && !CLASS_DATA (fsym)->attr.allocatable) 6820 || (fsym->ts.type != BT_CLASS 6821 && !fsym->attr.pointer && !fsym->attr.allocatable))) 6822 { 6823 /* Change AR_FULL to a (:,:,:) ref to force bounds update. */ 6824 gfc_ref *ref; 6825 for (ref = e->ref; ref->next; ref = ref->next) 6826 ; 6827 if (ref->u.ar.type == AR_FULL 6828 && ref->u.ar.as->type != AS_ASSUMED_SIZE) 6829 ref->u.ar.type = AR_SECTION; 6830 } 6831 6832 if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL)) 6833 /* Implement F2018, 18.3.6, list item (5), bullet point 2. */ 6834 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); 6835 6836 else if (e->expr_type == EXPR_VARIABLE 6837 && is_subref_array (e) 6838 && !(fsym && fsym->attr.pointer)) 6839 /* The actual argument is a component reference to an 6840 array of derived types. In this case, the argument 6841 is converted to a temporary, which is passed and then 6842 written back after the procedure call. */ 6843 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, 6844 fsym ? fsym->attr.intent : INTENT_INOUT, 6845 fsym && fsym->attr.pointer); 6846 6847 else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as 6848 && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE 6849 && nodesc_arg && fsym->ts.type == BT_DERIVED) 6850 /* An assumed size class actual argument being passed to 6851 a 'no descriptor' formal argument just requires the 6852 data pointer to be passed. For class dummy arguments 6853 this is stored in the symbol backend decl.. */ 6854 parmse.expr = e->symtree->n.sym->backend_decl; 6855 6856 else if (gfc_is_class_array_ref (e, NULL) 6857 && fsym && fsym->ts.type == BT_DERIVED) 6858 /* The actual argument is a component reference to an 6859 array of derived types. In this case, the argument 6860 is converted to a temporary, which is passed and then 6861 written back after the procedure call. 6862 OOP-TODO: Insert code so that if the dynamic type is 6863 the same as the declared type, copy-in/copy-out does 6864 not occur. */ 6865 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, 6866 fsym->attr.intent, 6867 fsym->attr.pointer); 6868 6869 else if (gfc_is_class_array_function (e) 6870 && fsym && fsym->ts.type == BT_DERIVED) 6871 /* See previous comment. For function actual argument, 6872 the write out is not needed so the intent is set as 6873 intent in. */ 6874 { 6875 e->must_finalize = 1; 6876 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, 6877 INTENT_IN, fsym->attr.pointer); 6878 } 6879 else if (fsym && fsym->attr.contiguous 6880 && !gfc_is_simply_contiguous (e, false, true) 6881 && gfc_expr_is_variable (e)) 6882 { 6883 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, 6884 fsym->attr.intent, 6885 fsym->attr.pointer); 6886 } 6887 else 6888 /* This is where we introduce a temporary to store the 6889 result of a non-lvalue array expression. */ 6890 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, 6891 sym->name, NULL); 6892 6893 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 6894 allocated on entry, it must be deallocated. 6895 CFI descriptors are handled elsewhere. */ 6896 if (fsym && fsym->attr.allocatable 6897 && fsym->attr.intent == INTENT_OUT 6898 && !is_CFI_desc (fsym, NULL)) 6899 { 6900 if (fsym->ts.type == BT_DERIVED 6901 && fsym->ts.u.derived->attr.alloc_comp) 6902 { 6903 // deallocate the components first 6904 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, 6905 parmse.expr, e->rank); 6906 /* But check whether dummy argument is optional. */ 6907 if (tmp != NULL_TREE 6908 && fsym->attr.optional 6909 && e->expr_type == EXPR_VARIABLE 6910 && e->symtree->n.sym->attr.optional) 6911 { 6912 tree present; 6913 present = gfc_conv_expr_present (e->symtree->n.sym); 6914 tmp = build3_v (COND_EXPR, present, tmp, 6915 build_empty_stmt (input_location)); 6916 } 6917 if (tmp != NULL_TREE) 6918 gfc_add_expr_to_block (&se->pre, tmp); 6919 } 6920 6921 tmp = parmse.expr; 6922 /* With bind(C), the actual argument is replaced by a bind-C 6923 descriptor; in this case, the data component arrives here, 6924 which shall not be dereferenced, but still freed and 6925 nullified. */ 6926 if (TREE_TYPE(tmp) != pvoid_type_node) 6927 tmp = build_fold_indirect_ref_loc (input_location, 6928 parmse.expr); 6929 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 6930 tmp = gfc_conv_descriptor_data_get (tmp); 6931 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, 6932 NULL_TREE, NULL_TREE, true, 6933 e, 6934 GFC_CAF_COARRAY_NOCOARRAY); 6935 if (fsym->attr.optional 6936 && e->expr_type == EXPR_VARIABLE 6937 && e->symtree->n.sym->attr.optional) 6938 tmp = fold_build3_loc (input_location, COND_EXPR, 6939 void_type_node, 6940 gfc_conv_expr_present (e->symtree->n.sym), 6941 tmp, build_empty_stmt (input_location)); 6942 gfc_add_expr_to_block (&se->pre, tmp); 6943 } 6944 } 6945 } 6946 /* Special case for an assumed-rank dummy argument. */ 6947 if (!sym->attr.is_bind_c && e && fsym && e->rank > 0 6948 && (fsym->ts.type == BT_CLASS 6949 ? (CLASS_DATA (fsym)->as 6950 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) 6951 : (fsym->as && fsym->as->type == AS_ASSUMED_RANK))) 6952 { 6953 if (fsym->ts.type == BT_CLASS 6954 ? (CLASS_DATA (fsym)->attr.class_pointer 6955 || CLASS_DATA (fsym)->attr.allocatable) 6956 : (fsym->attr.pointer || fsym->attr.allocatable)) 6957 { 6958 /* Unallocated allocatable arrays and unassociated pointer 6959 arrays need their dtype setting if they are argument 6960 associated with assumed rank dummies to set the rank. */ 6961 set_dtype_for_unallocated (&parmse, e); 6962 } 6963 else if (e->expr_type == EXPR_VARIABLE 6964 && e->symtree->n.sym->attr.dummy 6965 && (e->ts.type == BT_CLASS 6966 ? (e->ref && e->ref->next 6967 && e->ref->next->type == REF_ARRAY 6968 && e->ref->next->u.ar.type == AR_FULL 6969 && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE) 6970 : (e->ref && e->ref->type == REF_ARRAY 6971 && e->ref->u.ar.type == AR_FULL 6972 && e->ref->u.ar.as->type == AS_ASSUMED_SIZE))) 6973 { 6974 /* Assumed-size actual to assumed-rank dummy requires 6975 dim[rank-1].ubound = -1. */ 6976 tree minus_one; 6977 tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); 6978 if (fsym->ts.type == BT_CLASS) 6979 tmp = gfc_class_data_get (tmp); 6980 minus_one = build_int_cst (gfc_array_index_type, -1); 6981 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp, 6982 gfc_rank_cst[e->rank - 1], 6983 minus_one); 6984 } 6985 } 6986 6987 /* The case with fsym->attr.optional is that of a user subroutine 6988 with an interface indicating an optional argument. When we call 6989 an intrinsic subroutine, however, fsym is NULL, but we might still 6990 have an optional argument, so we proceed to the substitution 6991 just in case. */ 6992 if (e && (fsym == NULL || fsym->attr.optional)) 6993 { 6994 /* If an optional argument is itself an optional dummy argument, 6995 check its presence and substitute a null if absent. This is 6996 only needed when passing an array to an elemental procedure 6997 as then array elements are accessed - or no NULL pointer is 6998 allowed and a "1" or "0" should be passed if not present. 6999 When passing a non-array-descriptor full array to a 7000 non-array-descriptor dummy, no check is needed. For 7001 array-descriptor actual to array-descriptor dummy, see 7002 PR 41911 for why a check has to be inserted. 7003 fsym == NULL is checked as intrinsics required the descriptor 7004 but do not always set fsym. 7005 Also, it is necessary to pass a NULL pointer to library routines 7006 which usually ignore optional arguments, so they can handle 7007 these themselves. */ 7008 if (e->expr_type == EXPR_VARIABLE 7009 && e->symtree->n.sym->attr.optional 7010 && (((e->rank != 0 && elemental_proc) 7011 || e->representation.length || e->ts.type == BT_CHARACTER 7012 || (e->rank != 0 7013 && (fsym == NULL 7014 || (fsym->as 7015 && (fsym->as->type == AS_ASSUMED_SHAPE 7016 || fsym->as->type == AS_ASSUMED_RANK 7017 || fsym->as->type == AS_DEFERRED))))) 7018 || se->ignore_optional)) 7019 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, 7020 e->representation.length); 7021 } 7022 7023 if (fsym && e) 7024 { 7025 /* Obtain the character length of an assumed character length 7026 length procedure from the typespec. */ 7027 if (fsym->ts.type == BT_CHARACTER 7028 && parmse.string_length == NULL_TREE 7029 && e->ts.type == BT_PROCEDURE 7030 && e->symtree->n.sym->ts.type == BT_CHARACTER 7031 && e->symtree->n.sym->ts.u.cl->length != NULL 7032 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 7033 { 7034 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); 7035 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; 7036 } 7037 } 7038 7039 if (fsym && need_interface_mapping && e) 7040 gfc_add_interface_mapping (&mapping, fsym, &parmse, e); 7041 7042 gfc_add_block_to_block (&se->pre, &parmse.pre); 7043 gfc_add_block_to_block (&post, &parmse.post); 7044 7045 /* Allocated allocatable components of derived types must be 7046 deallocated for non-variable scalars, array arguments to elemental 7047 procedures, and array arguments with descriptor to non-elemental 7048 procedures. As bounds information for descriptorless arrays is no 7049 longer available here, they are dealt with in trans-array.cc 7050 (gfc_conv_array_parameter). */ 7051 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) 7052 && e->ts.u.derived->attr.alloc_comp 7053 && (e->rank == 0 || elemental_proc || !nodesc_arg) 7054 && !expr_may_alias_variables (e, elemental_proc)) 7055 { 7056 int parm_rank; 7057 /* It is known the e returns a structure type with at least one 7058 allocatable component. When e is a function, ensure that the 7059 function is called once only by using a temporary variable. */ 7060 if (!DECL_P (parmse.expr)) 7061 parmse.expr = gfc_evaluate_now_loc (input_location, 7062 parmse.expr, &se->pre); 7063 7064 if (fsym && fsym->attr.value) 7065 tmp = parmse.expr; 7066 else 7067 tmp = build_fold_indirect_ref_loc (input_location, 7068 parmse.expr); 7069 7070 parm_rank = e->rank; 7071 switch (parm_kind) 7072 { 7073 case (ELEMENTAL): 7074 case (SCALAR): 7075 parm_rank = 0; 7076 break; 7077 7078 case (SCALAR_POINTER): 7079 tmp = build_fold_indirect_ref_loc (input_location, 7080 tmp); 7081 break; 7082 } 7083 7084 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS) 7085 { 7086 /* The derived type is passed to gfc_deallocate_alloc_comp. 7087 Therefore, class actuals can be handled correctly but derived 7088 types passed to class formals need the _data component. */ 7089 tmp = gfc_class_data_get (tmp); 7090 if (!CLASS_DATA (fsym)->attr.dimension) 7091 tmp = build_fold_indirect_ref_loc (input_location, tmp); 7092 } 7093 7094 if (e->expr_type == EXPR_OP 7095 && e->value.op.op == INTRINSIC_PARENTHESES 7096 && e->value.op.op1->expr_type == EXPR_VARIABLE) 7097 { 7098 tree local_tmp; 7099 local_tmp = gfc_evaluate_now (tmp, &se->pre); 7100 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, 7101 parm_rank, 0); 7102 gfc_add_expr_to_block (&se->post, local_tmp); 7103 } 7104 7105 if (!finalized && !e->must_finalize) 7106 { 7107 bool scalar_res_outside_loop; 7108 scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION 7109 && parm_rank == 0 7110 && parmse.loop; 7111 7112 /* Scalars passed to an assumed rank argument are converted to 7113 a descriptor. Obtain the data field before deallocating any 7114 allocatable components. */ 7115 if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 7116 tmp = gfc_conv_descriptor_data_get (tmp); 7117 7118 if (scalar_res_outside_loop) 7119 { 7120 /* Go through the ss chain to find the argument and use 7121 the stored value. */ 7122 gfc_ss *tmp_ss = parmse.loop->ss; 7123 for (; tmp_ss; tmp_ss = tmp_ss->next) 7124 if (tmp_ss->info 7125 && tmp_ss->info->expr == e 7126 && tmp_ss->info->data.scalar.value != NULL_TREE) 7127 { 7128 tmp = tmp_ss->info->data.scalar.value; 7129 break; 7130 } 7131 } 7132 7133 STRIP_NOPS (tmp); 7134 7135 if (derived_array != NULL_TREE) 7136 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, 7137 derived_array, 7138 parm_rank); 7139 else if ((e->ts.type == BT_CLASS 7140 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) 7141 || e->ts.type == BT_DERIVED) 7142 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, 7143 parm_rank); 7144 else if (e->ts.type == BT_CLASS) 7145 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived, 7146 tmp, parm_rank); 7147 7148 if (scalar_res_outside_loop) 7149 gfc_add_expr_to_block (&parmse.loop->post, tmp); 7150 else 7151 gfc_prepend_expr_to_block (&post, tmp); 7152 } 7153 } 7154 7155 /* Add argument checking of passing an unallocated/NULL actual to 7156 a nonallocatable/nonpointer dummy. */ 7157 7158 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL) 7159 { 7160 symbol_attribute attr; 7161 char *msg; 7162 tree cond; 7163 tree tmp; 7164 symbol_attribute fsym_attr; 7165 7166 if (fsym) 7167 { 7168 if (fsym->ts.type == BT_CLASS) 7169 { 7170 fsym_attr = CLASS_DATA (fsym)->attr; 7171 fsym_attr.pointer = fsym_attr.class_pointer; 7172 } 7173 else 7174 fsym_attr = fsym->attr; 7175 } 7176 7177 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) 7178 attr = gfc_expr_attr (e); 7179 else 7180 goto end_pointer_check; 7181 7182 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated 7183 allocatable to an optional dummy, cf. 12.5.2.12. */ 7184 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer 7185 && (gfc_option.allow_std & GFC_STD_F2008) != 0) 7186 goto end_pointer_check; 7187 7188 if (attr.optional) 7189 { 7190 /* If the actual argument is an optional pointer/allocatable and 7191 the formal argument takes an nonpointer optional value, 7192 it is invalid to pass a non-present argument on, even 7193 though there is no technical reason for this in gfortran. 7194 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ 7195 tree present, null_ptr, type; 7196 7197 if (attr.allocatable 7198 && (fsym == NULL || !fsym_attr.allocatable)) 7199 msg = xasprintf ("Allocatable actual argument '%s' is not " 7200 "allocated or not present", 7201 e->symtree->n.sym->name); 7202 else if (attr.pointer 7203 && (fsym == NULL || !fsym_attr.pointer)) 7204 msg = xasprintf ("Pointer actual argument '%s' is not " 7205 "associated or not present", 7206 e->symtree->n.sym->name); 7207 else if (attr.proc_pointer && !e->value.function.actual 7208 && (fsym == NULL || !fsym_attr.proc_pointer)) 7209 msg = xasprintf ("Proc-pointer actual argument '%s' is not " 7210 "associated or not present", 7211 e->symtree->n.sym->name); 7212 else 7213 goto end_pointer_check; 7214 7215 present = gfc_conv_expr_present (e->symtree->n.sym); 7216 type = TREE_TYPE (present); 7217 present = fold_build2_loc (input_location, EQ_EXPR, 7218 logical_type_node, present, 7219 fold_convert (type, 7220 null_pointer_node)); 7221 type = TREE_TYPE (parmse.expr); 7222 null_ptr = fold_build2_loc (input_location, EQ_EXPR, 7223 logical_type_node, parmse.expr, 7224 fold_convert (type, 7225 null_pointer_node)); 7226 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, 7227 logical_type_node, present, null_ptr); 7228 } 7229 else 7230 { 7231 if (attr.allocatable 7232 && (fsym == NULL || !fsym_attr.allocatable)) 7233 msg = xasprintf ("Allocatable actual argument '%s' is not " 7234 "allocated", e->symtree->n.sym->name); 7235 else if (attr.pointer 7236 && (fsym == NULL || !fsym_attr.pointer)) 7237 msg = xasprintf ("Pointer actual argument '%s' is not " 7238 "associated", e->symtree->n.sym->name); 7239 else if (attr.proc_pointer && !e->value.function.actual 7240 && (fsym == NULL || !fsym_attr.proc_pointer)) 7241 msg = xasprintf ("Proc-pointer actual argument '%s' is not " 7242 "associated", e->symtree->n.sym->name); 7243 else 7244 goto end_pointer_check; 7245 7246 tmp = parmse.expr; 7247 if (fsym && fsym->ts.type == BT_CLASS) 7248 { 7249 if (POINTER_TYPE_P (TREE_TYPE (tmp))) 7250 tmp = build_fold_indirect_ref_loc (input_location, tmp); 7251 tmp = gfc_class_data_get (tmp); 7252 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 7253 tmp = gfc_conv_descriptor_data_get (tmp); 7254 } 7255 7256 /* If the argument is passed by value, we need to strip the 7257 INDIRECT_REF. */ 7258 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 7259 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 7260 7261 cond = fold_build2_loc (input_location, EQ_EXPR, 7262 logical_type_node, tmp, 7263 fold_convert (TREE_TYPE (tmp), 7264 null_pointer_node)); 7265 } 7266 7267 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, 7268 msg); 7269 free (msg); 7270 } 7271 end_pointer_check: 7272 7273 /* Deferred length dummies pass the character length by reference 7274 so that the value can be returned. */ 7275 if (parmse.string_length && fsym && fsym->ts.deferred) 7276 { 7277 if (INDIRECT_REF_P (parmse.string_length)) 7278 /* In chains of functions/procedure calls the string_length already 7279 is a pointer to the variable holding the length. Therefore 7280 remove the deref on call. */ 7281 parmse.string_length = TREE_OPERAND (parmse.string_length, 0); 7282 else 7283 { 7284 tmp = parmse.string_length; 7285 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF) 7286 tmp = gfc_evaluate_now (parmse.string_length, &se->pre); 7287 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp); 7288 } 7289 } 7290 7291 /* Character strings are passed as two parameters, a length and a 7292 pointer - except for Bind(c) which only passes the pointer. 7293 An unlimited polymorphic formal argument likewise does not 7294 need the length. */ 7295 if (parmse.string_length != NULL_TREE 7296 && !sym->attr.is_bind_c 7297 && !(fsym && UNLIMITED_POLY (fsym))) 7298 vec_safe_push (stringargs, parmse.string_length); 7299 7300 /* When calling __copy for character expressions to unlimited 7301 polymorphic entities, the dst argument needs a string length. */ 7302 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER 7303 && startswith (sym->name, "__vtab_CHARACTER") 7304 && arg->next && arg->next->expr 7305 && (arg->next->expr->ts.type == BT_DERIVED 7306 || arg->next->expr->ts.type == BT_CLASS) 7307 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic) 7308 vec_safe_push (stringargs, parmse.string_length); 7309 7310 /* For descriptorless coarrays and assumed-shape coarray dummies, we 7311 pass the token and the offset as additional arguments. */ 7312 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB 7313 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension 7314 && !fsym->attr.allocatable) 7315 || (fsym->ts.type == BT_CLASS 7316 && CLASS_DATA (fsym)->attr.codimension 7317 && !CLASS_DATA (fsym)->attr.allocatable))) 7318 { 7319 /* Token and offset. */ 7320 vec_safe_push (stringargs, null_pointer_node); 7321 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0)); 7322 gcc_assert (fsym->attr.optional); 7323 } 7324 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB 7325 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension 7326 && !fsym->attr.allocatable) 7327 || (fsym->ts.type == BT_CLASS 7328 && CLASS_DATA (fsym)->attr.codimension 7329 && !CLASS_DATA (fsym)->attr.allocatable))) 7330 { 7331 tree caf_decl, caf_type; 7332 tree offset, tmp2; 7333 7334 caf_decl = gfc_get_tree_for_caf_expr (e); 7335 caf_type = TREE_TYPE (caf_decl); 7336 7337 if (GFC_DESCRIPTOR_TYPE_P (caf_type) 7338 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE 7339 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER)) 7340 tmp = gfc_conv_descriptor_token (caf_decl); 7341 else if (DECL_LANG_SPECIFIC (caf_decl) 7342 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) 7343 tmp = GFC_DECL_TOKEN (caf_decl); 7344 else 7345 { 7346 gcc_assert (GFC_ARRAY_TYPE_P (caf_type) 7347 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE); 7348 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); 7349 } 7350 7351 vec_safe_push (stringargs, tmp); 7352 7353 if (GFC_DESCRIPTOR_TYPE_P (caf_type) 7354 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) 7355 offset = build_int_cst (gfc_array_index_type, 0); 7356 else if (DECL_LANG_SPECIFIC (caf_decl) 7357 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) 7358 offset = GFC_DECL_CAF_OFFSET (caf_decl); 7359 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE) 7360 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type); 7361 else 7362 offset = build_int_cst (gfc_array_index_type, 0); 7363 7364 if (GFC_DESCRIPTOR_TYPE_P (caf_type)) 7365 tmp = gfc_conv_descriptor_data_get (caf_decl); 7366 else 7367 { 7368 gcc_assert (POINTER_TYPE_P (caf_type)); 7369 tmp = caf_decl; 7370 } 7371 7372 tmp2 = fsym->ts.type == BT_CLASS 7373 ? gfc_class_data_get (parmse.expr) : parmse.expr; 7374 if ((fsym->ts.type != BT_CLASS 7375 && (fsym->as->type == AS_ASSUMED_SHAPE 7376 || fsym->as->type == AS_ASSUMED_RANK)) 7377 || (fsym->ts.type == BT_CLASS 7378 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE 7379 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK))) 7380 { 7381 if (fsym->ts.type == BT_CLASS) 7382 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2))); 7383 else 7384 { 7385 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2))); 7386 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2); 7387 } 7388 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2))); 7389 tmp2 = gfc_conv_descriptor_data_get (tmp2); 7390 } 7391 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2))) 7392 tmp2 = gfc_conv_descriptor_data_get (tmp2); 7393 else 7394 { 7395 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2))); 7396 } 7397 7398 tmp = fold_build2_loc (input_location, MINUS_EXPR, 7399 gfc_array_index_type, 7400 fold_convert (gfc_array_index_type, tmp2), 7401 fold_convert (gfc_array_index_type, tmp)); 7402 offset = fold_build2_loc (input_location, PLUS_EXPR, 7403 gfc_array_index_type, offset, tmp); 7404 7405 vec_safe_push (stringargs, offset); 7406 } 7407 7408 vec_safe_push (arglist, parmse.expr); 7409 } 7410 gfc_add_block_to_block (&se->pre, &clobbers); 7411 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post); 7412 7413 if (comp) 7414 ts = comp->ts; 7415 else if (sym->ts.type == BT_CLASS) 7416 ts = CLASS_DATA (sym)->ts; 7417 else 7418 ts = sym->ts; 7419 7420 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c) 7421 se->string_length = build_int_cst (gfc_charlen_type_node, 1); 7422 else if (ts.type == BT_CHARACTER) 7423 { 7424 if (ts.u.cl->length == NULL) 7425 { 7426 /* Assumed character length results are not allowed by C418 of the 2003 7427 standard and are trapped in resolve.cc; except in the case of SPREAD 7428 (and other intrinsics?) and dummy functions. In the case of SPREAD, 7429 we take the character length of the first argument for the result. 7430 For dummies, we have to look through the formal argument list for 7431 this function and use the character length found there.*/ 7432 if (ts.deferred) 7433 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen"); 7434 else if (!sym->attr.dummy) 7435 cl.backend_decl = (*stringargs)[0]; 7436 else 7437 { 7438 formal = gfc_sym_get_dummy_args (sym->ns->proc_name); 7439 for (; formal; formal = formal->next) 7440 if (strcmp (formal->sym->name, sym->name) == 0) 7441 cl.backend_decl = formal->sym->ts.u.cl->backend_decl; 7442 } 7443 len = cl.backend_decl; 7444 } 7445 else 7446 { 7447 tree tmp; 7448 7449 /* Calculate the length of the returned string. */ 7450 gfc_init_se (&parmse, NULL); 7451 if (need_interface_mapping) 7452 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length); 7453 else 7454 gfc_conv_expr (&parmse, ts.u.cl->length); 7455 gfc_add_block_to_block (&se->pre, &parmse.pre); 7456 gfc_add_block_to_block (&se->post, &parmse.post); 7457 tmp = parmse.expr; 7458 /* TODO: It would be better to have the charlens as 7459 gfc_charlen_type_node already when the interface is 7460 created instead of converting it here (see PR 84615). */ 7461 tmp = fold_build2_loc (input_location, MAX_EXPR, 7462 gfc_charlen_type_node, 7463 fold_convert (gfc_charlen_type_node, tmp), 7464 build_zero_cst (gfc_charlen_type_node)); 7465 cl.backend_decl = tmp; 7466 } 7467 7468 /* Set up a charlen structure for it. */ 7469 cl.next = NULL; 7470 cl.length = NULL; 7471 ts.u.cl = &cl; 7472 7473 len = cl.backend_decl; 7474 } 7475 7476 byref = (comp && (comp->attr.dimension 7477 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c))) 7478 || (!comp && gfc_return_by_reference (sym)); 7479 if (byref) 7480 { 7481 if (se->direct_byref) 7482 { 7483 /* Sometimes, too much indirection can be applied; e.g. for 7484 function_result = array_valued_recursive_function. */ 7485 if (TREE_TYPE (TREE_TYPE (se->expr)) 7486 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) 7487 && GFC_DESCRIPTOR_TYPE_P 7488 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) 7489 se->expr = build_fold_indirect_ref_loc (input_location, 7490 se->expr); 7491 7492 /* If the lhs of an assignment x = f(..) is allocatable and 7493 f2003 is allowed, we must do the automatic reallocation. 7494 TODO - deal with intrinsics, without using a temporary. */ 7495 if (flag_realloc_lhs 7496 && se->ss && se->ss->loop_chain 7497 && se->ss->loop_chain->is_alloc_lhs 7498 && !expr->value.function.isym 7499 && sym->result->as != NULL) 7500 { 7501 /* Evaluate the bounds of the result, if known. */ 7502 gfc_set_loop_bounds_from_array_spec (&mapping, se, 7503 sym->result->as); 7504 7505 /* Perform the automatic reallocation. */ 7506 tmp = gfc_alloc_allocatable_for_assignment (se->loop, 7507 expr, NULL); 7508 gfc_add_expr_to_block (&se->pre, tmp); 7509 7510 /* Pass the temporary as the first argument. */ 7511 result = info->descriptor; 7512 } 7513 else 7514 result = build_fold_indirect_ref_loc (input_location, 7515 se->expr); 7516 vec_safe_push (retargs, se->expr); 7517 } 7518 else if (comp && comp->attr.dimension) 7519 { 7520 gcc_assert (se->loop && info); 7521 7522 /* Set the type of the array. */ 7523 tmp = gfc_typenode_for_spec (&comp->ts); 7524 gcc_assert (se->ss->dimen == se->loop->dimen); 7525 7526 /* Evaluate the bounds of the result, if known. */ 7527 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as); 7528 7529 /* If the lhs of an assignment x = f(..) is allocatable and 7530 f2003 is allowed, we must not generate the function call 7531 here but should just send back the results of the mapping. 7532 This is signalled by the function ss being flagged. */ 7533 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs) 7534 { 7535 gfc_free_interface_mapping (&mapping); 7536 return has_alternate_specifier; 7537 } 7538 7539 /* Create a temporary to store the result. In case the function 7540 returns a pointer, the temporary will be a shallow copy and 7541 mustn't be deallocated. */ 7542 callee_alloc = comp->attr.allocatable || comp->attr.pointer; 7543 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, 7544 tmp, NULL_TREE, false, 7545 !comp->attr.pointer, callee_alloc, 7546 &se->ss->info->expr->where); 7547 7548 /* Pass the temporary as the first argument. */ 7549 result = info->descriptor; 7550 tmp = gfc_build_addr_expr (NULL_TREE, result); 7551 vec_safe_push (retargs, tmp); 7552 } 7553 else if (!comp && sym->result->attr.dimension) 7554 { 7555 gcc_assert (se->loop && info); 7556 7557 /* Set the type of the array. */ 7558 tmp = gfc_typenode_for_spec (&ts); 7559 gcc_assert (se->ss->dimen == se->loop->dimen); 7560 7561 /* Evaluate the bounds of the result, if known. */ 7562 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as); 7563 7564 /* If the lhs of an assignment x = f(..) is allocatable and 7565 f2003 is allowed, we must not generate the function call 7566 here but should just send back the results of the mapping. 7567 This is signalled by the function ss being flagged. */ 7568 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs) 7569 { 7570 gfc_free_interface_mapping (&mapping); 7571 return has_alternate_specifier; 7572 } 7573 7574 /* Create a temporary to store the result. In case the function 7575 returns a pointer, the temporary will be a shallow copy and 7576 mustn't be deallocated. */ 7577 callee_alloc = sym->attr.allocatable || sym->attr.pointer; 7578 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, 7579 tmp, NULL_TREE, false, 7580 !sym->attr.pointer, callee_alloc, 7581 &se->ss->info->expr->where); 7582 7583 /* Pass the temporary as the first argument. */ 7584 result = info->descriptor; 7585 tmp = gfc_build_addr_expr (NULL_TREE, result); 7586 vec_safe_push (retargs, tmp); 7587 } 7588 else if (ts.type == BT_CHARACTER) 7589 { 7590 /* Pass the string length. */ 7591 type = gfc_get_character_type (ts.kind, ts.u.cl); 7592 type = build_pointer_type (type); 7593 7594 /* Emit a DECL_EXPR for the VLA type. */ 7595 tmp = TREE_TYPE (type); 7596 if (TYPE_SIZE (tmp) 7597 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST) 7598 { 7599 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp); 7600 DECL_ARTIFICIAL (tmp) = 1; 7601 DECL_IGNORED_P (tmp) = 1; 7602 tmp = fold_build1_loc (input_location, DECL_EXPR, 7603 TREE_TYPE (tmp), tmp); 7604 gfc_add_expr_to_block (&se->pre, tmp); 7605 } 7606 7607 /* Return an address to a char[0:len-1]* temporary for 7608 character pointers. */ 7609 if ((!comp && (sym->attr.pointer || sym->attr.allocatable)) 7610 || (comp && (comp->attr.pointer || comp->attr.allocatable))) 7611 { 7612 var = gfc_create_var (type, "pstr"); 7613 7614 if ((!comp && sym->attr.allocatable) 7615 || (comp && comp->attr.allocatable)) 7616 { 7617 gfc_add_modify (&se->pre, var, 7618 fold_convert (TREE_TYPE (var), 7619 null_pointer_node)); 7620 tmp = gfc_call_free (var); 7621 gfc_add_expr_to_block (&se->post, tmp); 7622 } 7623 7624 /* Provide an address expression for the function arguments. */ 7625 var = gfc_build_addr_expr (NULL_TREE, var); 7626 } 7627 else 7628 var = gfc_conv_string_tmp (se, type, len); 7629 7630 vec_safe_push (retargs, var); 7631 } 7632 else 7633 { 7634 gcc_assert (flag_f2c && ts.type == BT_COMPLEX); 7635 7636 type = gfc_get_complex_type (ts.kind); 7637 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx")); 7638 vec_safe_push (retargs, var); 7639 } 7640 7641 /* Add the string length to the argument list. */ 7642 if (ts.type == BT_CHARACTER && ts.deferred) 7643 { 7644 tmp = len; 7645 if (!VAR_P (tmp)) 7646 tmp = gfc_evaluate_now (len, &se->pre); 7647 TREE_STATIC (tmp) = 1; 7648 gfc_add_modify (&se->pre, tmp, 7649 build_int_cst (TREE_TYPE (tmp), 0)); 7650 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 7651 vec_safe_push (retargs, tmp); 7652 } 7653 else if (ts.type == BT_CHARACTER) 7654 vec_safe_push (retargs, len); 7655 } 7656 gfc_free_interface_mapping (&mapping); 7657 7658 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */ 7659 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs) 7660 + vec_safe_length (stringargs) + vec_safe_length (append_args)); 7661 vec_safe_reserve (retargs, arglen); 7662 7663 /* Add the return arguments. */ 7664 vec_safe_splice (retargs, arglist); 7665 7666 /* Add the hidden present status for optional+value to the arguments. */ 7667 vec_safe_splice (retargs, optionalargs); 7668 7669 /* Add the hidden string length parameters to the arguments. */ 7670 vec_safe_splice (retargs, stringargs); 7671 7672 /* We may want to append extra arguments here. This is used e.g. for 7673 calls to libgfortran_matmul_??, which need extra information. */ 7674 vec_safe_splice (retargs, append_args); 7675 7676 arglist = retargs; 7677 7678 /* Generate the actual call. */ 7679 if (base_object == NULL_TREE) 7680 conv_function_val (se, sym, expr, args); 7681 else 7682 conv_base_obj_fcn_val (se, base_object, expr); 7683 7684 /* If there are alternate return labels, function type should be 7685 integer. Can't modify the type in place though, since it can be shared 7686 with other functions. For dummy arguments, the typing is done to 7687 this result, even if it has to be repeated for each call. */ 7688 if (has_alternate_specifier 7689 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node) 7690 { 7691 if (!sym->attr.dummy) 7692 { 7693 TREE_TYPE (sym->backend_decl) 7694 = build_function_type (integer_type_node, 7695 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); 7696 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl); 7697 } 7698 else 7699 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; 7700 } 7701 7702 fntype = TREE_TYPE (TREE_TYPE (se->expr)); 7703 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist); 7704 7705 /* Allocatable scalar function results must be freed and nullified 7706 after use. This necessitates the creation of a temporary to 7707 hold the result to prevent duplicate calls. */ 7708 if (!byref && sym->ts.type != BT_CHARACTER 7709 && ((sym->attr.allocatable && !sym->attr.dimension && !comp) 7710 || (comp && comp->attr.allocatable && !comp->attr.dimension))) 7711 { 7712 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL); 7713 gfc_add_modify (&se->pre, tmp, se->expr); 7714 se->expr = tmp; 7715 tmp = gfc_call_free (tmp); 7716 gfc_add_expr_to_block (&post, tmp); 7717 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); 7718 } 7719 7720 /* If we have a pointer function, but we don't want a pointer, e.g. 7721 something like 7722 x = f() 7723 where f is pointer valued, we have to dereference the result. */ 7724 if (!se->want_pointer && !byref 7725 && ((!comp && (sym->attr.pointer || sym->attr.allocatable)) 7726 || (comp && (comp->attr.pointer || comp->attr.allocatable)))) 7727 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 7728 7729 /* f2c calling conventions require a scalar default real function to 7730 return a double precision result. Convert this back to default 7731 real. We only care about the cases that can happen in Fortran 77. 7732 */ 7733 if (flag_f2c && sym->ts.type == BT_REAL 7734 && sym->ts.kind == gfc_default_real_kind 7735 && !sym->attr.always_explicit) 7736 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr); 7737 7738 /* A pure function may still have side-effects - it may modify its 7739 parameters. */ 7740 TREE_SIDE_EFFECTS (se->expr) = 1; 7741#if 0 7742 if (!sym->attr.pure) 7743 TREE_SIDE_EFFECTS (se->expr) = 1; 7744#endif 7745 7746 if (byref) 7747 { 7748 /* Add the function call to the pre chain. There is no expression. */ 7749 gfc_add_expr_to_block (&se->pre, se->expr); 7750 se->expr = NULL_TREE; 7751 7752 if (!se->direct_byref) 7753 { 7754 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension)) 7755 { 7756 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 7757 { 7758 /* Check the data pointer hasn't been modified. This would 7759 happen in a function returning a pointer. */ 7760 tmp = gfc_conv_descriptor_data_get (info->descriptor); 7761 tmp = fold_build2_loc (input_location, NE_EXPR, 7762 logical_type_node, 7763 tmp, info->data); 7764 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, 7765 gfc_msg_fault); 7766 } 7767 se->expr = info->descriptor; 7768 /* Bundle in the string length. */ 7769 se->string_length = len; 7770 } 7771 else if (ts.type == BT_CHARACTER) 7772 { 7773 /* Dereference for character pointer results. */ 7774 if ((!comp && (sym->attr.pointer || sym->attr.allocatable)) 7775 || (comp && (comp->attr.pointer || comp->attr.allocatable))) 7776 se->expr = build_fold_indirect_ref_loc (input_location, var); 7777 else 7778 se->expr = var; 7779 7780 se->string_length = len; 7781 } 7782 else 7783 { 7784 gcc_assert (ts.type == BT_COMPLEX && flag_f2c); 7785 se->expr = build_fold_indirect_ref_loc (input_location, var); 7786 } 7787 } 7788 } 7789 7790 /* Associate the rhs class object's meta-data with the result, when the 7791 result is a temporary. */ 7792 if (args && args->expr && args->expr->ts.type == BT_CLASS 7793 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result) 7794 && !GFC_CLASS_TYPE_P (TREE_TYPE (result))) 7795 { 7796 gfc_se parmse; 7797 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr); 7798 7799 gfc_init_se (&parmse, NULL); 7800 parmse.data_not_needed = 1; 7801 gfc_conv_expr (&parmse, class_expr); 7802 if (!DECL_LANG_SPECIFIC (result)) 7803 gfc_allocate_lang_decl (result); 7804 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr; 7805 gfc_free_expr (class_expr); 7806 /* -fcheck= can add diagnostic code, which has to be placed before 7807 the call. */ 7808 if (parmse.pre.head != NULL) 7809 gfc_add_expr_to_block (&se->pre, parmse.pre.head); 7810 gcc_assert (parmse.post.head == NULL_TREE); 7811 } 7812 7813 /* Follow the function call with the argument post block. */ 7814 if (byref) 7815 { 7816 gfc_add_block_to_block (&se->pre, &post); 7817 7818 /* Transformational functions of derived types with allocatable 7819 components must have the result allocatable components copied when the 7820 argument is actually given. */ 7821 arg = expr->value.function.actual; 7822 if (result && arg && expr->rank 7823 && expr->value.function.isym 7824 && expr->value.function.isym->transformational 7825 && arg->expr 7826 && arg->expr->ts.type == BT_DERIVED 7827 && arg->expr->ts.u.derived->attr.alloc_comp) 7828 { 7829 tree tmp2; 7830 /* Copy the allocatable components. We have to use a 7831 temporary here to prevent source allocatable components 7832 from being corrupted. */ 7833 tmp2 = gfc_evaluate_now (result, &se->pre); 7834 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, 7835 result, tmp2, expr->rank, 0); 7836 gfc_add_expr_to_block (&se->pre, tmp); 7837 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2), 7838 expr->rank); 7839 gfc_add_expr_to_block (&se->pre, tmp); 7840 7841 /* Finally free the temporary's data field. */ 7842 tmp = gfc_conv_descriptor_data_get (tmp2); 7843 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, 7844 NULL_TREE, NULL_TREE, true, 7845 NULL, GFC_CAF_COARRAY_NOCOARRAY); 7846 gfc_add_expr_to_block (&se->pre, tmp); 7847 } 7848 } 7849 else 7850 { 7851 /* For a function with a class array result, save the result as 7852 a temporary, set the info fields needed by the scalarizer and 7853 call the finalization function of the temporary. Note that the 7854 nullification of allocatable components needed by the result 7855 is done in gfc_trans_assignment_1. */ 7856 if (expr && ((gfc_is_class_array_function (expr) 7857 && se->ss && se->ss->loop) 7858 || gfc_is_alloc_class_scalar_function (expr)) 7859 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) 7860 && expr->must_finalize) 7861 { 7862 tree final_fndecl; 7863 tree is_final; 7864 int n; 7865 if (se->ss && se->ss->loop) 7866 { 7867 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); 7868 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); 7869 tmp = gfc_class_data_get (se->expr); 7870 info->descriptor = tmp; 7871 info->data = gfc_conv_descriptor_data_get (tmp); 7872 info->offset = gfc_conv_descriptor_offset_get (tmp); 7873 for (n = 0; n < se->ss->loop->dimen; n++) 7874 { 7875 tree dim = gfc_rank_cst[n]; 7876 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); 7877 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); 7878 } 7879 } 7880 else 7881 { 7882 /* TODO Eliminate the doubling of temporaries. This 7883 one is necessary to ensure no memory leakage. */ 7884 se->expr = gfc_evaluate_now (se->expr, &se->pre); 7885 tmp = gfc_class_data_get (se->expr); 7886 tmp = gfc_conv_scalar_to_descriptor (se, tmp, 7887 CLASS_DATA (expr->value.function.esym->result)->attr); 7888 } 7889 7890 if ((gfc_is_class_array_function (expr) 7891 || gfc_is_alloc_class_scalar_function (expr)) 7892 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer) 7893 goto no_finalization; 7894 7895 final_fndecl = gfc_class_vtab_final_get (se->expr); 7896 is_final = fold_build2_loc (input_location, NE_EXPR, 7897 logical_type_node, 7898 final_fndecl, 7899 fold_convert (TREE_TYPE (final_fndecl), 7900 null_pointer_node)); 7901 final_fndecl = build_fold_indirect_ref_loc (input_location, 7902 final_fndecl); 7903 tmp = build_call_expr_loc (input_location, 7904 final_fndecl, 3, 7905 gfc_build_addr_expr (NULL, tmp), 7906 gfc_class_vtab_size_get (se->expr), 7907 boolean_false_node); 7908 tmp = fold_build3_loc (input_location, COND_EXPR, 7909 void_type_node, is_final, tmp, 7910 build_empty_stmt (input_location)); 7911 7912 if (se->ss && se->ss->loop) 7913 { 7914 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp); 7915 tmp = fold_build2_loc (input_location, NE_EXPR, 7916 logical_type_node, 7917 info->data, 7918 fold_convert (TREE_TYPE (info->data), 7919 null_pointer_node)); 7920 tmp = fold_build3_loc (input_location, COND_EXPR, 7921 void_type_node, tmp, 7922 gfc_call_free (info->data), 7923 build_empty_stmt (input_location)); 7924 gfc_add_expr_to_block (&se->ss->loop->post, tmp); 7925 } 7926 else 7927 { 7928 tree classdata; 7929 gfc_prepend_expr_to_block (&se->post, tmp); 7930 classdata = gfc_class_data_get (se->expr); 7931 tmp = fold_build2_loc (input_location, NE_EXPR, 7932 logical_type_node, 7933 classdata, 7934 fold_convert (TREE_TYPE (classdata), 7935 null_pointer_node)); 7936 tmp = fold_build3_loc (input_location, COND_EXPR, 7937 void_type_node, tmp, 7938 gfc_call_free (classdata), 7939 build_empty_stmt (input_location)); 7940 gfc_add_expr_to_block (&se->post, tmp); 7941 } 7942 } 7943 7944no_finalization: 7945 gfc_add_block_to_block (&se->post, &post); 7946 } 7947 7948 return has_alternate_specifier; 7949} 7950 7951 7952/* Fill a character string with spaces. */ 7953 7954static tree 7955fill_with_spaces (tree start, tree type, tree size) 7956{ 7957 stmtblock_t block, loop; 7958 tree i, el, exit_label, cond, tmp; 7959 7960 /* For a simple char type, we can call memset(). */ 7961 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0) 7962 return build_call_expr_loc (input_location, 7963 builtin_decl_explicit (BUILT_IN_MEMSET), 7964 3, start, 7965 build_int_cst (gfc_get_int_type (gfc_c_int_kind), 7966 lang_hooks.to_target_charset (' ')), 7967 fold_convert (size_type_node, size)); 7968 7969 /* Otherwise, we use a loop: 7970 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type)) 7971 *el = (type) ' '; 7972 */ 7973 7974 /* Initialize variables. */ 7975 gfc_init_block (&block); 7976 i = gfc_create_var (sizetype, "i"); 7977 gfc_add_modify (&block, i, fold_convert (sizetype, size)); 7978 el = gfc_create_var (build_pointer_type (type), "el"); 7979 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start)); 7980 exit_label = gfc_build_label_decl (NULL_TREE); 7981 TREE_USED (exit_label) = 1; 7982 7983 7984 /* Loop body. */ 7985 gfc_init_block (&loop); 7986 7987 /* Exit condition. */ 7988 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i, 7989 build_zero_cst (sizetype)); 7990 tmp = build1_v (GOTO_EXPR, exit_label); 7991 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, 7992 build_empty_stmt (input_location)); 7993 gfc_add_expr_to_block (&loop, tmp); 7994 7995 /* Assignment. */ 7996 gfc_add_modify (&loop, 7997 fold_build1_loc (input_location, INDIRECT_REF, type, el), 7998 build_int_cst (type, lang_hooks.to_target_charset (' '))); 7999 8000 /* Increment loop variables. */ 8001 gfc_add_modify (&loop, i, 8002 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i, 8003 TYPE_SIZE_UNIT (type))); 8004 gfc_add_modify (&loop, el, 8005 fold_build_pointer_plus_loc (input_location, 8006 el, TYPE_SIZE_UNIT (type))); 8007 8008 /* Making the loop... actually loop! */ 8009 tmp = gfc_finish_block (&loop); 8010 tmp = build1_v (LOOP_EXPR, tmp); 8011 gfc_add_expr_to_block (&block, tmp); 8012 8013 /* The exit label. */ 8014 tmp = build1_v (LABEL_EXPR, exit_label); 8015 gfc_add_expr_to_block (&block, tmp); 8016 8017 8018 return gfc_finish_block (&block); 8019} 8020 8021 8022/* Generate code to copy a string. */ 8023 8024void 8025gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, 8026 int dkind, tree slength, tree src, int skind) 8027{ 8028 tree tmp, dlen, slen; 8029 tree dsc; 8030 tree ssc; 8031 tree cond; 8032 tree cond2; 8033 tree tmp2; 8034 tree tmp3; 8035 tree tmp4; 8036 tree chartype; 8037 stmtblock_t tempblock; 8038 8039 gcc_assert (dkind == skind); 8040 8041 if (slength != NULL_TREE) 8042 { 8043 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block); 8044 ssc = gfc_string_to_single_character (slen, src, skind); 8045 } 8046 else 8047 { 8048 slen = build_one_cst (gfc_charlen_type_node); 8049 ssc = src; 8050 } 8051 8052 if (dlength != NULL_TREE) 8053 { 8054 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block); 8055 dsc = gfc_string_to_single_character (dlen, dest, dkind); 8056 } 8057 else 8058 { 8059 dlen = build_one_cst (gfc_charlen_type_node); 8060 dsc = dest; 8061 } 8062 8063 /* Assign directly if the types are compatible. */ 8064 if (dsc != NULL_TREE && ssc != NULL_TREE 8065 && TREE_TYPE (dsc) == TREE_TYPE (ssc)) 8066 { 8067 gfc_add_modify (block, dsc, ssc); 8068 return; 8069 } 8070 8071 /* The string copy algorithm below generates code like 8072 8073 if (destlen > 0) 8074 { 8075 if (srclen < destlen) 8076 { 8077 memmove (dest, src, srclen); 8078 // Pad with spaces. 8079 memset (&dest[srclen], ' ', destlen - srclen); 8080 } 8081 else 8082 { 8083 // Truncate if too long. 8084 memmove (dest, src, destlen); 8085 } 8086 } 8087 */ 8088 8089 /* Do nothing if the destination length is zero. */ 8090 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen, 8091 build_zero_cst (TREE_TYPE (dlen))); 8092 8093 /* For non-default character kinds, we have to multiply the string 8094 length by the base type size. */ 8095 chartype = gfc_get_char_type (dkind); 8096 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen), 8097 slen, 8098 fold_convert (TREE_TYPE (slen), 8099 TYPE_SIZE_UNIT (chartype))); 8100 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen), 8101 dlen, 8102 fold_convert (TREE_TYPE (dlen), 8103 TYPE_SIZE_UNIT (chartype))); 8104 8105 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest))) 8106 dest = fold_convert (pvoid_type_node, dest); 8107 else 8108 dest = gfc_build_addr_expr (pvoid_type_node, dest); 8109 8110 if (slength && POINTER_TYPE_P (TREE_TYPE (src))) 8111 src = fold_convert (pvoid_type_node, src); 8112 else 8113 src = gfc_build_addr_expr (pvoid_type_node, src); 8114 8115 /* Truncate string if source is too long. */ 8116 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen, 8117 dlen); 8118 8119 /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */ 8120 if (!CONSTANT_CLASS_P (cond2)) 8121 { 8122 dest = gfc_evaluate_now (dest, block); 8123 src = gfc_evaluate_now (src, block); 8124 } 8125 8126 /* Copy and pad with spaces. */ 8127 tmp3 = build_call_expr_loc (input_location, 8128 builtin_decl_explicit (BUILT_IN_MEMMOVE), 8129 3, dest, src, 8130 fold_convert (size_type_node, slen)); 8131 8132 /* Wstringop-overflow appears at -O3 even though this warning is not 8133 explicitly available in fortran nor can it be switched off. If the 8134 source length is a constant, its negative appears as a very large 8135 postive number and triggers the warning in BUILTIN_MEMSET. Fixing 8136 the result of the MINUS_EXPR suppresses this spurious warning. */ 8137 tmp = fold_build2_loc (input_location, MINUS_EXPR, 8138 TREE_TYPE(dlen), dlen, slen); 8139 if (slength && TREE_CONSTANT (slength)) 8140 tmp = gfc_evaluate_now (tmp, block); 8141 8142 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen); 8143 tmp4 = fill_with_spaces (tmp4, chartype, tmp); 8144 8145 gfc_init_block (&tempblock); 8146 gfc_add_expr_to_block (&tempblock, tmp3); 8147 gfc_add_expr_to_block (&tempblock, tmp4); 8148 tmp3 = gfc_finish_block (&tempblock); 8149 8150 /* The truncated memmove if the slen >= dlen. */ 8151 tmp2 = build_call_expr_loc (input_location, 8152 builtin_decl_explicit (BUILT_IN_MEMMOVE), 8153 3, dest, src, 8154 fold_convert (size_type_node, dlen)); 8155 8156 /* The whole copy_string function is there. */ 8157 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, 8158 tmp3, tmp2); 8159 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, 8160 build_empty_stmt (input_location)); 8161 gfc_add_expr_to_block (block, tmp); 8162} 8163 8164 8165/* Translate a statement function. 8166 The value of a statement function reference is obtained by evaluating the 8167 expression using the values of the actual arguments for the values of the 8168 corresponding dummy arguments. */ 8169 8170static void 8171gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) 8172{ 8173 gfc_symbol *sym; 8174 gfc_symbol *fsym; 8175 gfc_formal_arglist *fargs; 8176 gfc_actual_arglist *args; 8177 gfc_se lse; 8178 gfc_se rse; 8179 gfc_saved_var *saved_vars; 8180 tree *temp_vars; 8181 tree type; 8182 tree tmp; 8183 int n; 8184 8185 sym = expr->symtree->n.sym; 8186 args = expr->value.function.actual; 8187 gfc_init_se (&lse, NULL); 8188 gfc_init_se (&rse, NULL); 8189 8190 n = 0; 8191 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next) 8192 n++; 8193 saved_vars = XCNEWVEC (gfc_saved_var, n); 8194 temp_vars = XCNEWVEC (tree, n); 8195 8196 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs; 8197 fargs = fargs->next, n++) 8198 { 8199 /* Each dummy shall be specified, explicitly or implicitly, to be 8200 scalar. */ 8201 gcc_assert (fargs->sym->attr.dimension == 0); 8202 fsym = fargs->sym; 8203 8204 if (fsym->ts.type == BT_CHARACTER) 8205 { 8206 /* Copy string arguments. */ 8207 tree arglen; 8208 8209 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length 8210 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT); 8211 8212 /* Create a temporary to hold the value. */ 8213 if (fsym->ts.u.cl->backend_decl == NULL_TREE) 8214 fsym->ts.u.cl->backend_decl 8215 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length); 8216 8217 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl); 8218 temp_vars[n] = gfc_create_var (type, fsym->name); 8219 8220 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); 8221 8222 gfc_conv_expr (&rse, args->expr); 8223 gfc_conv_string_parameter (&rse); 8224 gfc_add_block_to_block (&se->pre, &lse.pre); 8225 gfc_add_block_to_block (&se->pre, &rse.pre); 8226 8227 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind, 8228 rse.string_length, rse.expr, fsym->ts.kind); 8229 gfc_add_block_to_block (&se->pre, &lse.post); 8230 gfc_add_block_to_block (&se->pre, &rse.post); 8231 } 8232 else 8233 { 8234 /* For everything else, just evaluate the expression. */ 8235 8236 /* Create a temporary to hold the value. */ 8237 type = gfc_typenode_for_spec (&fsym->ts); 8238 temp_vars[n] = gfc_create_var (type, fsym->name); 8239 8240 gfc_conv_expr (&lse, args->expr); 8241 8242 gfc_add_block_to_block (&se->pre, &lse.pre); 8243 gfc_add_modify (&se->pre, temp_vars[n], lse.expr); 8244 gfc_add_block_to_block (&se->pre, &lse.post); 8245 } 8246 8247 args = args->next; 8248 } 8249 8250 /* Use the temporary variables in place of the real ones. */ 8251 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs; 8252 fargs = fargs->next, n++) 8253 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]); 8254 8255 gfc_conv_expr (se, sym->value); 8256 8257 if (sym->ts.type == BT_CHARACTER) 8258 { 8259 gfc_conv_const_charlen (sym->ts.u.cl); 8260 8261 /* Force the expression to the correct length. */ 8262 if (!INTEGER_CST_P (se->string_length) 8263 || tree_int_cst_lt (se->string_length, 8264 sym->ts.u.cl->backend_decl)) 8265 { 8266 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl); 8267 tmp = gfc_create_var (type, sym->name); 8268 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp); 8269 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp, 8270 sym->ts.kind, se->string_length, se->expr, 8271 sym->ts.kind); 8272 se->expr = tmp; 8273 } 8274 se->string_length = sym->ts.u.cl->backend_decl; 8275 } 8276 8277 /* Restore the original variables. */ 8278 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs; 8279 fargs = fargs->next, n++) 8280 gfc_restore_sym (fargs->sym, &saved_vars[n]); 8281 free (temp_vars); 8282 free (saved_vars); 8283} 8284 8285 8286/* Translate a function expression. */ 8287 8288static void 8289gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) 8290{ 8291 gfc_symbol *sym; 8292 8293 if (expr->value.function.isym) 8294 { 8295 gfc_conv_intrinsic_function (se, expr); 8296 return; 8297 } 8298 8299 /* expr.value.function.esym is the resolved (specific) function symbol for 8300 most functions. However this isn't set for dummy procedures. */ 8301 sym = expr->value.function.esym; 8302 if (!sym) 8303 sym = expr->symtree->n.sym; 8304 8305 /* The IEEE_ARITHMETIC functions are caught here. */ 8306 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC) 8307 if (gfc_conv_ieee_arithmetic_function (se, expr)) 8308 return; 8309 8310 /* We distinguish statement functions from general functions to improve 8311 runtime performance. */ 8312 if (sym->attr.proc == PROC_ST_FUNCTION) 8313 { 8314 gfc_conv_statement_function (se, expr); 8315 return; 8316 } 8317 8318 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, 8319 NULL); 8320} 8321 8322 8323/* Determine whether the given EXPR_CONSTANT is a zero initializer. */ 8324 8325static bool 8326is_zero_initializer_p (gfc_expr * expr) 8327{ 8328 if (expr->expr_type != EXPR_CONSTANT) 8329 return false; 8330 8331 /* We ignore constants with prescribed memory representations for now. */ 8332 if (expr->representation.string) 8333 return false; 8334 8335 switch (expr->ts.type) 8336 { 8337 case BT_INTEGER: 8338 return mpz_cmp_si (expr->value.integer, 0) == 0; 8339 8340 case BT_REAL: 8341 return mpfr_zero_p (expr->value.real) 8342 && MPFR_SIGN (expr->value.real) >= 0; 8343 8344 case BT_LOGICAL: 8345 return expr->value.logical == 0; 8346 8347 case BT_COMPLEX: 8348 return mpfr_zero_p (mpc_realref (expr->value.complex)) 8349 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0 8350 && mpfr_zero_p (mpc_imagref (expr->value.complex)) 8351 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0; 8352 8353 default: 8354 break; 8355 } 8356 return false; 8357} 8358 8359 8360static void 8361gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) 8362{ 8363 gfc_ss *ss; 8364 8365 ss = se->ss; 8366 gcc_assert (ss != NULL && ss != gfc_ss_terminator); 8367 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR); 8368 8369 gfc_conv_tmp_array_ref (se); 8370} 8371 8372 8373/* Build a static initializer. EXPR is the expression for the initial value. 8374 The other parameters describe the variable of the component being 8375 initialized. EXPR may be null. */ 8376 8377tree 8378gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, 8379 bool array, bool pointer, bool procptr) 8380{ 8381 gfc_se se; 8382 8383 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED 8384 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 8385 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 8386 return build_constructor (type, NULL); 8387 8388 if (!(expr || pointer || procptr)) 8389 return NULL_TREE; 8390 8391 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR 8392 (these are the only two iso_c_binding derived types that can be 8393 used as initialization expressions). If so, we need to modify 8394 the 'expr' to be that for a (void *). */ 8395 if (expr != NULL && expr->ts.type == BT_DERIVED 8396 && expr->ts.is_iso_c && expr->ts.u.derived) 8397 { 8398 if (TREE_CODE (type) == ARRAY_TYPE) 8399 return build_constructor (type, NULL); 8400 else if (POINTER_TYPE_P (type)) 8401 return build_int_cst (type, 0); 8402 else 8403 gcc_unreachable (); 8404 } 8405 8406 if (array && !procptr) 8407 { 8408 tree ctor; 8409 /* Arrays need special handling. */ 8410 if (pointer) 8411 ctor = gfc_build_null_descriptor (type); 8412 /* Special case assigning an array to zero. */ 8413 else if (is_zero_initializer_p (expr)) 8414 ctor = build_constructor (type, NULL); 8415 else 8416 ctor = gfc_conv_array_initializer (type, expr); 8417 TREE_STATIC (ctor) = 1; 8418 return ctor; 8419 } 8420 else if (pointer || procptr) 8421 { 8422 if (ts->type == BT_CLASS && !procptr) 8423 { 8424 gfc_init_se (&se, NULL); 8425 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1); 8426 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); 8427 TREE_STATIC (se.expr) = 1; 8428 return se.expr; 8429 } 8430 else if (!expr || expr->expr_type == EXPR_NULL) 8431 return fold_convert (type, null_pointer_node); 8432 else 8433 { 8434 gfc_init_se (&se, NULL); 8435 se.want_pointer = 1; 8436 gfc_conv_expr (&se, expr); 8437 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); 8438 return se.expr; 8439 } 8440 } 8441 else 8442 { 8443 switch (ts->type) 8444 { 8445 case_bt_struct: 8446 case BT_CLASS: 8447 gfc_init_se (&se, NULL); 8448 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) 8449 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1); 8450 else 8451 gfc_conv_structure (&se, expr, 1); 8452 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR); 8453 TREE_STATIC (se.expr) = 1; 8454 return se.expr; 8455 8456 case BT_CHARACTER: 8457 if (expr->expr_type == EXPR_CONSTANT) 8458 { 8459 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr); 8460 TREE_STATIC (ctor) = 1; 8461 return ctor; 8462 } 8463 8464 /* Fallthrough. */ 8465 default: 8466 gfc_init_se (&se, NULL); 8467 gfc_conv_constant (&se, expr); 8468 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR); 8469 return se.expr; 8470 } 8471 } 8472} 8473 8474static tree 8475gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) 8476{ 8477 gfc_se rse; 8478 gfc_se lse; 8479 gfc_ss *rss; 8480 gfc_ss *lss; 8481 gfc_array_info *lss_array; 8482 stmtblock_t body; 8483 stmtblock_t block; 8484 gfc_loopinfo loop; 8485 int n; 8486 tree tmp; 8487 8488 gfc_start_block (&block); 8489 8490 /* Initialize the scalarizer. */ 8491 gfc_init_loopinfo (&loop); 8492 8493 gfc_init_se (&lse, NULL); 8494 gfc_init_se (&rse, NULL); 8495 8496 /* Walk the rhs. */ 8497 rss = gfc_walk_expr (expr); 8498 if (rss == gfc_ss_terminator) 8499 /* The rhs is scalar. Add a ss for the expression. */ 8500 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr); 8501 8502 /* Create a SS for the destination. */ 8503 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank, 8504 GFC_SS_COMPONENT); 8505 lss_array = &lss->info->data.array; 8506 lss_array->shape = gfc_get_shape (cm->as->rank); 8507 lss_array->descriptor = dest; 8508 lss_array->data = gfc_conv_array_data (dest); 8509 lss_array->offset = gfc_conv_array_offset (dest); 8510 for (n = 0; n < cm->as->rank; n++) 8511 { 8512 lss_array->start[n] = gfc_conv_array_lbound (dest, n); 8513 lss_array->stride[n] = gfc_index_one_node; 8514 8515 mpz_init (lss_array->shape[n]); 8516 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer, 8517 cm->as->lower[n]->value.integer); 8518 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1); 8519 } 8520 8521 /* Associate the SS with the loop. */ 8522 gfc_add_ss_to_loop (&loop, lss); 8523 gfc_add_ss_to_loop (&loop, rss); 8524 8525 /* Calculate the bounds of the scalarization. */ 8526 gfc_conv_ss_startstride (&loop); 8527 8528 /* Setup the scalarizing loops. */ 8529 gfc_conv_loop_setup (&loop, &expr->where); 8530 8531 /* Setup the gfc_se structures. */ 8532 gfc_copy_loopinfo_to_se (&lse, &loop); 8533 gfc_copy_loopinfo_to_se (&rse, &loop); 8534 8535 rse.ss = rss; 8536 gfc_mark_ss_chain_used (rss, 1); 8537 lse.ss = lss; 8538 gfc_mark_ss_chain_used (lss, 1); 8539 8540 /* Start the scalarized loop body. */ 8541 gfc_start_scalarized_body (&loop, &body); 8542 8543 gfc_conv_tmp_array_ref (&lse); 8544 if (cm->ts.type == BT_CHARACTER) 8545 lse.string_length = cm->ts.u.cl->backend_decl; 8546 8547 gfc_conv_expr (&rse, expr); 8548 8549 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); 8550 gfc_add_expr_to_block (&body, tmp); 8551 8552 gcc_assert (rse.ss == gfc_ss_terminator); 8553 8554 /* Generate the copying loops. */ 8555 gfc_trans_scalarizing_loops (&loop, &body); 8556 8557 /* Wrap the whole thing up. */ 8558 gfc_add_block_to_block (&block, &loop.pre); 8559 gfc_add_block_to_block (&block, &loop.post); 8560 8561 gcc_assert (lss_array->shape != NULL); 8562 gfc_free_shape (&lss_array->shape, cm->as->rank); 8563 gfc_cleanup_loop (&loop); 8564 8565 return gfc_finish_block (&block); 8566} 8567 8568 8569static tree 8570gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, 8571 gfc_expr * expr) 8572{ 8573 gfc_se se; 8574 stmtblock_t block; 8575 tree offset; 8576 int n; 8577 tree tmp; 8578 tree tmp2; 8579 gfc_array_spec *as; 8580 gfc_expr *arg = NULL; 8581 8582 gfc_start_block (&block); 8583 gfc_init_se (&se, NULL); 8584 8585 /* Get the descriptor for the expressions. */ 8586 se.want_pointer = 0; 8587 gfc_conv_expr_descriptor (&se, expr); 8588 gfc_add_block_to_block (&block, &se.pre); 8589 gfc_add_modify (&block, dest, se.expr); 8590 8591 /* Deal with arrays of derived types with allocatable components. */ 8592 if (gfc_bt_struct (cm->ts.type) 8593 && cm->ts.u.derived->attr.alloc_comp) 8594 // TODO: Fix caf_mode 8595 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, 8596 se.expr, dest, 8597 cm->as->rank, 0); 8598 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED 8599 && CLASS_DATA(cm)->attr.allocatable) 8600 { 8601 if (cm->ts.u.derived->attr.alloc_comp) 8602 // TODO: Fix caf_mode 8603 tmp = gfc_copy_alloc_comp (expr->ts.u.derived, 8604 se.expr, dest, 8605 expr->rank, 0); 8606 else 8607 { 8608 tmp = TREE_TYPE (dest); 8609 tmp = gfc_duplicate_allocatable (dest, se.expr, 8610 tmp, expr->rank, NULL_TREE); 8611 } 8612 } 8613 else 8614 tmp = gfc_duplicate_allocatable (dest, se.expr, 8615 TREE_TYPE(cm->backend_decl), 8616 cm->as->rank, NULL_TREE); 8617 8618 gfc_add_expr_to_block (&block, tmp); 8619 gfc_add_block_to_block (&block, &se.post); 8620 8621 if (expr->expr_type != EXPR_VARIABLE) 8622 gfc_conv_descriptor_data_set (&block, se.expr, 8623 null_pointer_node); 8624 8625 /* We need to know if the argument of a conversion function is a 8626 variable, so that the correct lower bound can be used. */ 8627 if (expr->expr_type == EXPR_FUNCTION 8628 && expr->value.function.isym 8629 && expr->value.function.isym->conversion 8630 && expr->value.function.actual->expr 8631 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE) 8632 arg = expr->value.function.actual->expr; 8633 8634 /* Obtain the array spec of full array references. */ 8635 if (arg) 8636 as = gfc_get_full_arrayspec_from_expr (arg); 8637 else 8638 as = gfc_get_full_arrayspec_from_expr (expr); 8639 8640 /* Shift the lbound and ubound of temporaries to being unity, 8641 rather than zero, based. Always calculate the offset. */ 8642 offset = gfc_conv_descriptor_offset_get (dest); 8643 gfc_add_modify (&block, offset, gfc_index_zero_node); 8644 tmp2 =gfc_create_var (gfc_array_index_type, NULL); 8645 8646 for (n = 0; n < expr->rank; n++) 8647 { 8648 tree span; 8649 tree lbound; 8650 8651 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9. 8652 TODO It looks as if gfc_conv_expr_descriptor should return 8653 the correct bounds and that the following should not be 8654 necessary. This would simplify gfc_conv_intrinsic_bound 8655 as well. */ 8656 if (as && as->lower[n]) 8657 { 8658 gfc_se lbse; 8659 gfc_init_se (&lbse, NULL); 8660 gfc_conv_expr (&lbse, as->lower[n]); 8661 gfc_add_block_to_block (&block, &lbse.pre); 8662 lbound = gfc_evaluate_now (lbse.expr, &block); 8663 } 8664 else if (as && arg) 8665 { 8666 tmp = gfc_get_symbol_decl (arg->symtree->n.sym); 8667 lbound = gfc_conv_descriptor_lbound_get (tmp, 8668 gfc_rank_cst[n]); 8669 } 8670 else if (as) 8671 lbound = gfc_conv_descriptor_lbound_get (dest, 8672 gfc_rank_cst[n]); 8673 else 8674 lbound = gfc_index_one_node; 8675 8676 lbound = fold_convert (gfc_array_index_type, lbound); 8677 8678 /* Shift the bounds and set the offset accordingly. */ 8679 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]); 8680 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 8681 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); 8682 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 8683 span, lbound); 8684 gfc_conv_descriptor_ubound_set (&block, dest, 8685 gfc_rank_cst[n], tmp); 8686 gfc_conv_descriptor_lbound_set (&block, dest, 8687 gfc_rank_cst[n], lbound); 8688 8689 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 8690 gfc_conv_descriptor_lbound_get (dest, 8691 gfc_rank_cst[n]), 8692 gfc_conv_descriptor_stride_get (dest, 8693 gfc_rank_cst[n])); 8694 gfc_add_modify (&block, tmp2, tmp); 8695 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 8696 offset, tmp2); 8697 gfc_conv_descriptor_offset_set (&block, dest, tmp); 8698 } 8699 8700 if (arg) 8701 { 8702 /* If a conversion expression has a null data pointer 8703 argument, nullify the allocatable component. */ 8704 tree non_null_expr; 8705 tree null_expr; 8706 8707 if (arg->symtree->n.sym->attr.allocatable 8708 || arg->symtree->n.sym->attr.pointer) 8709 { 8710 non_null_expr = gfc_finish_block (&block); 8711 gfc_start_block (&block); 8712 gfc_conv_descriptor_data_set (&block, dest, 8713 null_pointer_node); 8714 null_expr = gfc_finish_block (&block); 8715 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl); 8716 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, 8717 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 8718 return build3_v (COND_EXPR, tmp, 8719 null_expr, non_null_expr); 8720 } 8721 } 8722 8723 return gfc_finish_block (&block); 8724} 8725 8726 8727/* Allocate or reallocate scalar component, as necessary. */ 8728 8729static void 8730alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, 8731 tree comp, 8732 gfc_component *cm, 8733 gfc_expr *expr2, 8734 gfc_symbol *sym) 8735{ 8736 tree tmp; 8737 tree ptr; 8738 tree size; 8739 tree size_in_bytes; 8740 tree lhs_cl_size = NULL_TREE; 8741 8742 if (!comp) 8743 return; 8744 8745 if (!expr2 || expr2->rank) 8746 return; 8747 8748 realloc_lhs_warning (expr2->ts.type, false, &expr2->where); 8749 8750 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) 8751 { 8752 char name[GFC_MAX_SYMBOL_LEN+9]; 8753 gfc_component *strlen; 8754 /* Use the rhs string length and the lhs element size. */ 8755 gcc_assert (expr2->ts.type == BT_CHARACTER); 8756 if (!expr2->ts.u.cl->backend_decl) 8757 { 8758 gfc_conv_string_length (expr2->ts.u.cl, expr2, block); 8759 gcc_assert (expr2->ts.u.cl->backend_decl); 8760 } 8761 8762 size = expr2->ts.u.cl->backend_decl; 8763 8764 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length 8765 component. */ 8766 sprintf (name, "_%s_length", cm->name); 8767 strlen = gfc_find_component (sym, name, true, true, NULL); 8768 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF, 8769 gfc_charlen_type_node, 8770 TREE_OPERAND (comp, 0), 8771 strlen->backend_decl, NULL_TREE); 8772 8773 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts)); 8774 tmp = TYPE_SIZE_UNIT (tmp); 8775 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR, 8776 TREE_TYPE (tmp), tmp, 8777 fold_convert (TREE_TYPE (tmp), size)); 8778 } 8779 else if (cm->ts.type == BT_CLASS) 8780 { 8781 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED); 8782 if (expr2->ts.type == BT_DERIVED) 8783 { 8784 tmp = gfc_get_symbol_decl (expr2->ts.u.derived); 8785 size = TYPE_SIZE_UNIT (tmp); 8786 } 8787 else 8788 { 8789 gfc_expr *e2vtab; 8790 gfc_se se; 8791 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2); 8792 gfc_add_vptr_component (e2vtab); 8793 gfc_add_size_component (e2vtab); 8794 gfc_init_se (&se, NULL); 8795 gfc_conv_expr (&se, e2vtab); 8796 gfc_add_block_to_block (block, &se.pre); 8797 size = fold_convert (size_type_node, se.expr); 8798 gfc_free_expr (e2vtab); 8799 } 8800 size_in_bytes = size; 8801 } 8802 else 8803 { 8804 /* Otherwise use the length in bytes of the rhs. */ 8805 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts)); 8806 size_in_bytes = size; 8807 } 8808 8809 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node, 8810 size_in_bytes, size_one_node); 8811 8812 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp) 8813 { 8814 tmp = build_call_expr_loc (input_location, 8815 builtin_decl_explicit (BUILT_IN_CALLOC), 8816 2, build_one_cst (size_type_node), 8817 size_in_bytes); 8818 tmp = fold_convert (TREE_TYPE (comp), tmp); 8819 gfc_add_modify (block, comp, tmp); 8820 } 8821 else 8822 { 8823 tmp = build_call_expr_loc (input_location, 8824 builtin_decl_explicit (BUILT_IN_MALLOC), 8825 1, size_in_bytes); 8826 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp))) 8827 ptr = gfc_class_data_get (comp); 8828 else 8829 ptr = comp; 8830 tmp = fold_convert (TREE_TYPE (ptr), tmp); 8831 gfc_add_modify (block, ptr, tmp); 8832 } 8833 8834 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) 8835 /* Update the lhs character length. */ 8836 gfc_add_modify (block, lhs_cl_size, 8837 fold_convert (TREE_TYPE (lhs_cl_size), size)); 8838} 8839 8840 8841/* Assign a single component of a derived type constructor. */ 8842 8843static tree 8844gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, 8845 gfc_symbol *sym, bool init) 8846{ 8847 gfc_se se; 8848 gfc_se lse; 8849 stmtblock_t block; 8850 tree tmp; 8851 tree vtab; 8852 8853 gfc_start_block (&block); 8854 8855 if (cm->attr.pointer || cm->attr.proc_pointer) 8856 { 8857 /* Only care about pointers here, not about allocatables. */ 8858 gfc_init_se (&se, NULL); 8859 /* Pointer component. */ 8860 if ((cm->attr.dimension || cm->attr.codimension) 8861 && !cm->attr.proc_pointer) 8862 { 8863 /* Array pointer. */ 8864 if (expr->expr_type == EXPR_NULL) 8865 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); 8866 else 8867 { 8868 se.direct_byref = 1; 8869 se.expr = dest; 8870 gfc_conv_expr_descriptor (&se, expr); 8871 gfc_add_block_to_block (&block, &se.pre); 8872 gfc_add_block_to_block (&block, &se.post); 8873 } 8874 } 8875 else 8876 { 8877 /* Scalar pointers. */ 8878 se.want_pointer = 1; 8879 gfc_conv_expr (&se, expr); 8880 gfc_add_block_to_block (&block, &se.pre); 8881 8882 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer 8883 && expr->symtree->n.sym->attr.dummy) 8884 se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 8885 8886 gfc_add_modify (&block, dest, 8887 fold_convert (TREE_TYPE (dest), se.expr)); 8888 gfc_add_block_to_block (&block, &se.post); 8889 } 8890 } 8891 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL) 8892 { 8893 /* NULL initialization for CLASS components. */ 8894 tmp = gfc_trans_structure_assign (dest, 8895 gfc_class_initializer (&cm->ts, expr), 8896 false); 8897 gfc_add_expr_to_block (&block, tmp); 8898 } 8899 else if ((cm->attr.dimension || cm->attr.codimension) 8900 && !cm->attr.proc_pointer) 8901 { 8902 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) 8903 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); 8904 else if (cm->attr.allocatable || cm->attr.pdt_array) 8905 { 8906 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); 8907 gfc_add_expr_to_block (&block, tmp); 8908 } 8909 else 8910 { 8911 tmp = gfc_trans_subarray_assign (dest, cm, expr); 8912 gfc_add_expr_to_block (&block, tmp); 8913 } 8914 } 8915 else if (cm->ts.type == BT_CLASS 8916 && CLASS_DATA (cm)->attr.dimension 8917 && CLASS_DATA (cm)->attr.allocatable 8918 && expr->ts.type == BT_DERIVED) 8919 { 8920 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts)); 8921 vtab = gfc_build_addr_expr (NULL_TREE, vtab); 8922 tmp = gfc_class_vptr_get (dest); 8923 gfc_add_modify (&block, tmp, 8924 fold_convert (TREE_TYPE (tmp), vtab)); 8925 tmp = gfc_class_data_get (dest); 8926 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr); 8927 gfc_add_expr_to_block (&block, tmp); 8928 } 8929 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL) 8930 { 8931 /* NULL initialization for allocatable components. */ 8932 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), 8933 null_pointer_node)); 8934 } 8935 else if (init && (cm->attr.allocatable 8936 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable 8937 && expr->ts.type != BT_CLASS))) 8938 { 8939 /* Take care about non-array allocatable components here. The alloc_* 8940 routine below is motivated by the alloc_scalar_allocatable_for_ 8941 assignment() routine, but with the realloc portions removed and 8942 different input. */ 8943 alloc_scalar_allocatable_for_subcomponent_assignment (&block, 8944 dest, 8945 cm, 8946 expr, 8947 sym); 8948 /* The remainder of these instructions follow the if (cm->attr.pointer) 8949 if (!cm->attr.dimension) part above. */ 8950 gfc_init_se (&se, NULL); 8951 gfc_conv_expr (&se, expr); 8952 gfc_add_block_to_block (&block, &se.pre); 8953 8954 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer 8955 && expr->symtree->n.sym->attr.dummy) 8956 se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 8957 8958 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED) 8959 { 8960 tmp = gfc_class_data_get (dest); 8961 tmp = build_fold_indirect_ref_loc (input_location, tmp); 8962 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts)); 8963 vtab = gfc_build_addr_expr (NULL_TREE, vtab); 8964 gfc_add_modify (&block, gfc_class_vptr_get (dest), 8965 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab)); 8966 } 8967 else 8968 tmp = build_fold_indirect_ref_loc (input_location, dest); 8969 8970 /* For deferred strings insert a memcpy. */ 8971 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) 8972 { 8973 tree size; 8974 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl); 8975 size = size_of_string_in_bytes (cm->ts.kind, se.string_length 8976 ? se.string_length 8977 : expr->ts.u.cl->backend_decl); 8978 tmp = gfc_build_memcpy_call (tmp, se.expr, size); 8979 gfc_add_expr_to_block (&block, tmp); 8980 } 8981 else 8982 gfc_add_modify (&block, tmp, 8983 fold_convert (TREE_TYPE (tmp), se.expr)); 8984 gfc_add_block_to_block (&block, &se.post); 8985 } 8986 else if (expr->ts.type == BT_UNION) 8987 { 8988 tree tmp; 8989 gfc_constructor *c = gfc_constructor_first (expr->value.constructor); 8990 /* We mark that the entire union should be initialized with a contrived 8991 EXPR_NULL expression at the beginning. */ 8992 if (c != NULL && c->n.component == NULL 8993 && c->expr != NULL && c->expr->expr_type == EXPR_NULL) 8994 { 8995 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, 8996 dest, build_constructor (TREE_TYPE (dest), NULL)); 8997 gfc_add_expr_to_block (&block, tmp); 8998 c = gfc_constructor_next (c); 8999 } 9000 /* The following constructor expression, if any, represents a specific 9001 map intializer, as given by the user. */ 9002 if (c != NULL && c->expr != NULL) 9003 { 9004 gcc_assert (expr->expr_type == EXPR_STRUCTURE); 9005 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL); 9006 gfc_add_expr_to_block (&block, tmp); 9007 } 9008 } 9009 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID) 9010 { 9011 if (expr->expr_type != EXPR_STRUCTURE) 9012 { 9013 tree dealloc = NULL_TREE; 9014 gfc_init_se (&se, NULL); 9015 gfc_conv_expr (&se, expr); 9016 gfc_add_block_to_block (&block, &se.pre); 9017 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the 9018 expression in a temporary variable and deallocate the allocatable 9019 components. Then we can the copy the expression to the result. */ 9020 if (cm->ts.u.derived->attr.alloc_comp 9021 && expr->expr_type != EXPR_VARIABLE) 9022 { 9023 se.expr = gfc_evaluate_now (se.expr, &block); 9024 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr, 9025 expr->rank); 9026 } 9027 gfc_add_modify (&block, dest, 9028 fold_convert (TREE_TYPE (dest), se.expr)); 9029 if (cm->ts.u.derived->attr.alloc_comp 9030 && expr->expr_type != EXPR_NULL) 9031 { 9032 // TODO: Fix caf_mode 9033 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, 9034 dest, expr->rank, 0); 9035 gfc_add_expr_to_block (&block, tmp); 9036 if (dealloc != NULL_TREE) 9037 gfc_add_expr_to_block (&block, dealloc); 9038 } 9039 gfc_add_block_to_block (&block, &se.post); 9040 } 9041 else 9042 { 9043 /* Nested constructors. */ 9044 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL); 9045 gfc_add_expr_to_block (&block, tmp); 9046 } 9047 } 9048 else if (gfc_deferred_strlen (cm, &tmp)) 9049 { 9050 tree strlen; 9051 strlen = tmp; 9052 gcc_assert (strlen); 9053 strlen = fold_build3_loc (input_location, COMPONENT_REF, 9054 TREE_TYPE (strlen), 9055 TREE_OPERAND (dest, 0), 9056 strlen, NULL_TREE); 9057 9058 if (expr->expr_type == EXPR_NULL) 9059 { 9060 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0); 9061 gfc_add_modify (&block, dest, tmp); 9062 tmp = build_int_cst (TREE_TYPE (strlen), 0); 9063 gfc_add_modify (&block, strlen, tmp); 9064 } 9065 else 9066 { 9067 tree size; 9068 gfc_init_se (&se, NULL); 9069 gfc_conv_expr (&se, expr); 9070 size = size_of_string_in_bytes (cm->ts.kind, se.string_length); 9071 tmp = build_call_expr_loc (input_location, 9072 builtin_decl_explicit (BUILT_IN_MALLOC), 9073 1, size); 9074 gfc_add_modify (&block, dest, 9075 fold_convert (TREE_TYPE (dest), tmp)); 9076 gfc_add_modify (&block, strlen, 9077 fold_convert (TREE_TYPE (strlen), se.string_length)); 9078 tmp = gfc_build_memcpy_call (dest, se.expr, size); 9079 gfc_add_expr_to_block (&block, tmp); 9080 } 9081 } 9082 else if (!cm->attr.artificial) 9083 { 9084 /* Scalar component (excluding deferred parameters). */ 9085 gfc_init_se (&se, NULL); 9086 gfc_init_se (&lse, NULL); 9087 9088 gfc_conv_expr (&se, expr); 9089 if (cm->ts.type == BT_CHARACTER) 9090 lse.string_length = cm->ts.u.cl->backend_decl; 9091 lse.expr = dest; 9092 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false); 9093 gfc_add_expr_to_block (&block, tmp); 9094 } 9095 return gfc_finish_block (&block); 9096} 9097 9098/* Assign a derived type constructor to a variable. */ 9099 9100tree 9101gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) 9102{ 9103 gfc_constructor *c; 9104 gfc_component *cm; 9105 stmtblock_t block; 9106 tree field; 9107 tree tmp; 9108 gfc_se se; 9109 9110 gfc_start_block (&block); 9111 9112 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING 9113 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR 9114 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) 9115 { 9116 gfc_se lse; 9117 9118 gfc_init_se (&se, NULL); 9119 gfc_init_se (&lse, NULL); 9120 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr); 9121 lse.expr = dest; 9122 gfc_add_modify (&block, lse.expr, 9123 fold_convert (TREE_TYPE (lse.expr), se.expr)); 9124 9125 return gfc_finish_block (&block); 9126 } 9127 9128 /* Make sure that the derived type has been completely built. */ 9129 if (!expr->ts.u.derived->backend_decl 9130 || !TYPE_FIELDS (expr->ts.u.derived->backend_decl)) 9131 { 9132 tmp = gfc_typenode_for_spec (&expr->ts); 9133 gcc_assert (tmp); 9134 } 9135 9136 cm = expr->ts.u.derived->components; 9137 9138 9139 if (coarray) 9140 gfc_init_se (&se, NULL); 9141 9142 for (c = gfc_constructor_first (expr->value.constructor); 9143 c; c = gfc_constructor_next (c), cm = cm->next) 9144 { 9145 /* Skip absent members in default initializers. */ 9146 if (!c->expr && !cm->attr.allocatable) 9147 continue; 9148 9149 /* Register the component with the caf-lib before it is initialized. 9150 Register only allocatable components, that are not coarray'ed 9151 components (%comp[*]). Only register when the constructor is not the 9152 null-expression. */ 9153 if (coarray && !cm->attr.codimension 9154 && (cm->attr.allocatable || cm->attr.pointer) 9155 && (!c->expr || c->expr->expr_type == EXPR_NULL)) 9156 { 9157 tree token, desc, size; 9158 bool is_array = cm->ts.type == BT_CLASS 9159 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension; 9160 9161 field = cm->backend_decl; 9162 field = fold_build3_loc (input_location, COMPONENT_REF, 9163 TREE_TYPE (field), dest, field, NULL_TREE); 9164 if (cm->ts.type == BT_CLASS) 9165 field = gfc_class_data_get (field); 9166 9167 token = is_array ? gfc_conv_descriptor_token (field) 9168 : fold_build3_loc (input_location, COMPONENT_REF, 9169 TREE_TYPE (cm->caf_token), dest, 9170 cm->caf_token, NULL_TREE); 9171 9172 if (is_array) 9173 { 9174 /* The _caf_register routine looks at the rank of the array 9175 descriptor to decide whether the data registered is an array 9176 or not. */ 9177 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank 9178 : cm->as->rank; 9179 /* When the rank is not known just set a positive rank, which 9180 suffices to recognize the data as array. */ 9181 if (rank < 0) 9182 rank = 1; 9183 size = build_zero_cst (size_type_node); 9184 desc = field; 9185 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc), 9186 build_int_cst (signed_char_type_node, rank)); 9187 } 9188 else 9189 { 9190 desc = gfc_conv_scalar_to_descriptor (&se, field, 9191 cm->ts.type == BT_CLASS 9192 ? CLASS_DATA (cm)->attr 9193 : cm->attr); 9194 size = TYPE_SIZE_UNIT (TREE_TYPE (field)); 9195 } 9196 gfc_add_block_to_block (&block, &se.pre); 9197 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 9198 7, size, build_int_cst ( 9199 integer_type_node, 9200 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY), 9201 gfc_build_addr_expr (pvoid_type_node, 9202 token), 9203 gfc_build_addr_expr (NULL_TREE, desc), 9204 null_pointer_node, null_pointer_node, 9205 integer_zero_node); 9206 gfc_add_expr_to_block (&block, tmp); 9207 } 9208 field = cm->backend_decl; 9209 gcc_assert(field); 9210 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), 9211 dest, field, NULL_TREE); 9212 if (!c->expr) 9213 { 9214 gfc_expr *e = gfc_get_null_expr (NULL); 9215 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived, 9216 init); 9217 gfc_free_expr (e); 9218 } 9219 else 9220 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, 9221 expr->ts.u.derived, init); 9222 gfc_add_expr_to_block (&block, tmp); 9223 } 9224 return gfc_finish_block (&block); 9225} 9226 9227static void 9228gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v, 9229 gfc_component *un, gfc_expr *init) 9230{ 9231 gfc_constructor *ctor; 9232 9233 if (un->ts.type != BT_UNION || un == NULL || init == NULL) 9234 return; 9235 9236 ctor = gfc_constructor_first (init->value.constructor); 9237 9238 if (ctor == NULL || ctor->expr == NULL) 9239 return; 9240 9241 gcc_assert (init->expr_type == EXPR_STRUCTURE); 9242 9243 /* If we have an 'initialize all' constructor, do it first. */ 9244 if (ctor->expr->expr_type == EXPR_NULL) 9245 { 9246 tree union_type = TREE_TYPE (un->backend_decl); 9247 tree val = build_constructor (union_type, NULL); 9248 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val); 9249 ctor = gfc_constructor_next (ctor); 9250 } 9251 9252 /* Add the map initializer on top. */ 9253 if (ctor != NULL && ctor->expr != NULL) 9254 { 9255 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE); 9256 tree val = gfc_conv_initializer (ctor->expr, &un->ts, 9257 TREE_TYPE (un->backend_decl), 9258 un->attr.dimension, un->attr.pointer, 9259 un->attr.proc_pointer); 9260 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val); 9261 } 9262} 9263 9264/* Build an expression for a constructor. If init is nonzero then 9265 this is part of a static variable initializer. */ 9266 9267void 9268gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) 9269{ 9270 gfc_constructor *c; 9271 gfc_component *cm; 9272 tree val; 9273 tree type; 9274 tree tmp; 9275 vec<constructor_elt, va_gc> *v = NULL; 9276 9277 gcc_assert (se->ss == NULL); 9278 gcc_assert (expr->expr_type == EXPR_STRUCTURE); 9279 type = gfc_typenode_for_spec (&expr->ts); 9280 9281 if (!init) 9282 { 9283 /* Create a temporary variable and fill it in. */ 9284 se->expr = gfc_create_var (type, expr->ts.u.derived->name); 9285 /* The symtree in expr is NULL, if the code to generate is for 9286 initializing the static members only. */ 9287 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL, 9288 se->want_coarray); 9289 gfc_add_expr_to_block (&se->pre, tmp); 9290 return; 9291 } 9292 9293 cm = expr->ts.u.derived->components; 9294 9295 for (c = gfc_constructor_first (expr->value.constructor); 9296 c; c = gfc_constructor_next (c), cm = cm->next) 9297 { 9298 /* Skip absent members in default initializers and allocatable 9299 components. Although the latter have a default initializer 9300 of EXPR_NULL,... by default, the static nullify is not needed 9301 since this is done every time we come into scope. */ 9302 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)) 9303 continue; 9304 9305 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL 9306 && strcmp (cm->name, "_extends") == 0 9307 && cm->initializer->symtree) 9308 { 9309 tree vtab; 9310 gfc_symbol *vtabs; 9311 vtabs = cm->initializer->symtree->n.sym; 9312 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); 9313 vtab = unshare_expr_without_location (vtab); 9314 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); 9315 } 9316 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0) 9317 { 9318 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); 9319 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, 9320 fold_convert (TREE_TYPE (cm->backend_decl), 9321 val)); 9322 } 9323 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0) 9324 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, 9325 fold_convert (TREE_TYPE (cm->backend_decl), 9326 integer_zero_node)); 9327 else if (cm->ts.type == BT_UNION) 9328 gfc_conv_union_initializer (v, cm, c->expr); 9329 else 9330 { 9331 val = gfc_conv_initializer (c->expr, &cm->ts, 9332 TREE_TYPE (cm->backend_decl), 9333 cm->attr.dimension, cm->attr.pointer, 9334 cm->attr.proc_pointer); 9335 val = unshare_expr_without_location (val); 9336 9337 /* Append it to the constructor list. */ 9338 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); 9339 } 9340 } 9341 9342 se->expr = build_constructor (type, v); 9343 if (init) 9344 TREE_CONSTANT (se->expr) = 1; 9345} 9346 9347 9348/* Translate a substring expression. */ 9349 9350static void 9351gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) 9352{ 9353 gfc_ref *ref; 9354 9355 ref = expr->ref; 9356 9357 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); 9358 9359 se->expr = gfc_build_wide_string_const (expr->ts.kind, 9360 expr->value.character.length, 9361 expr->value.character.string); 9362 9363 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); 9364 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1; 9365 9366 if (ref) 9367 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where); 9368} 9369 9370 9371/* Entry point for expression translation. Evaluates a scalar quantity. 9372 EXPR is the expression to be translated, and SE is the state structure if 9373 called from within the scalarized. */ 9374 9375void 9376gfc_conv_expr (gfc_se * se, gfc_expr * expr) 9377{ 9378 gfc_ss *ss; 9379 9380 ss = se->ss; 9381 if (ss && ss->info->expr == expr 9382 && (ss->info->type == GFC_SS_SCALAR 9383 || ss->info->type == GFC_SS_REFERENCE)) 9384 { 9385 gfc_ss_info *ss_info; 9386 9387 ss_info = ss->info; 9388 /* Substitute a scalar expression evaluated outside the scalarization 9389 loop. */ 9390 se->expr = ss_info->data.scalar.value; 9391 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) 9392 se->expr = build_fold_indirect_ref_loc (input_location, se->expr); 9393 9394 se->string_length = ss_info->string_length; 9395 gfc_advance_se_ss_chain (se); 9396 return; 9397 } 9398 9399 /* We need to convert the expressions for the iso_c_binding derived types. 9400 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to 9401 null_pointer_node. C_PTR and C_FUNPTR are converted to match the 9402 typespec for the C_PTR and C_FUNPTR symbols, which has already been 9403 updated to be an integer with a kind equal to the size of a (void *). */ 9404 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID 9405 && expr->ts.u.derived->attr.is_bind_c) 9406 { 9407 if (expr->expr_type == EXPR_VARIABLE 9408 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR 9409 || expr->symtree->n.sym->intmod_sym_id 9410 == ISOCBINDING_NULL_FUNPTR)) 9411 { 9412 /* Set expr_type to EXPR_NULL, which will result in 9413 null_pointer_node being used below. */ 9414 expr->expr_type = EXPR_NULL; 9415 } 9416 else 9417 { 9418 /* Update the type/kind of the expression to be what the new 9419 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */ 9420 expr->ts.type = BT_INTEGER; 9421 expr->ts.f90_type = BT_VOID; 9422 expr->ts.kind = gfc_index_integer_kind; 9423 } 9424 } 9425 9426 gfc_fix_class_refs (expr); 9427 9428 switch (expr->expr_type) 9429 { 9430 case EXPR_OP: 9431 gfc_conv_expr_op (se, expr); 9432 break; 9433 9434 case EXPR_FUNCTION: 9435 gfc_conv_function_expr (se, expr); 9436 break; 9437 9438 case EXPR_CONSTANT: 9439 gfc_conv_constant (se, expr); 9440 break; 9441 9442 case EXPR_VARIABLE: 9443 gfc_conv_variable (se, expr); 9444 break; 9445 9446 case EXPR_NULL: 9447 se->expr = null_pointer_node; 9448 break; 9449 9450 case EXPR_SUBSTRING: 9451 gfc_conv_substring_expr (se, expr); 9452 break; 9453 9454 case EXPR_STRUCTURE: 9455 gfc_conv_structure (se, expr, 0); 9456 break; 9457 9458 case EXPR_ARRAY: 9459 gfc_conv_array_constructor_expr (se, expr); 9460 break; 9461 9462 default: 9463 gcc_unreachable (); 9464 break; 9465 } 9466} 9467 9468/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs 9469 of an assignment. */ 9470void 9471gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr) 9472{ 9473 gfc_conv_expr (se, expr); 9474 /* All numeric lvalues should have empty post chains. If not we need to 9475 figure out a way of rewriting an lvalue so that it has no post chain. */ 9476 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head); 9477} 9478 9479/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for 9480 numeric expressions. Used for scalar values where inserting cleanup code 9481 is inconvenient. */ 9482void 9483gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) 9484{ 9485 tree val; 9486 9487 gcc_assert (expr->ts.type != BT_CHARACTER); 9488 gfc_conv_expr (se, expr); 9489 if (se->post.head) 9490 { 9491 val = gfc_create_var (TREE_TYPE (se->expr), NULL); 9492 gfc_add_modify (&se->pre, val, se->expr); 9493 se->expr = val; 9494 gfc_add_block_to_block (&se->pre, &se->post); 9495 } 9496} 9497 9498/* Helper to translate an expression and convert it to a particular type. */ 9499void 9500gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) 9501{ 9502 gfc_conv_expr_val (se, expr); 9503 se->expr = convert (type, se->expr); 9504} 9505 9506 9507/* Converts an expression so that it can be passed by reference. Scalar 9508 values only. */ 9509 9510void 9511gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) 9512{ 9513 gfc_ss *ss; 9514 tree var; 9515 9516 ss = se->ss; 9517 if (ss && ss->info->expr == expr 9518 && ss->info->type == GFC_SS_REFERENCE) 9519 { 9520 /* Returns a reference to the scalar evaluated outside the loop 9521 for this case. */ 9522 gfc_conv_expr (se, expr); 9523 9524 if (expr->ts.type == BT_CHARACTER 9525 && expr->expr_type != EXPR_FUNCTION) 9526 gfc_conv_string_parameter (se); 9527 else 9528 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); 9529 9530 return; 9531 } 9532 9533 if (expr->ts.type == BT_CHARACTER) 9534 { 9535 gfc_conv_expr (se, expr); 9536 gfc_conv_string_parameter (se); 9537 return; 9538 } 9539 9540 if (expr->expr_type == EXPR_VARIABLE) 9541 { 9542 se->want_pointer = 1; 9543 gfc_conv_expr (se, expr); 9544 if (se->post.head) 9545 { 9546 var = gfc_create_var (TREE_TYPE (se->expr), NULL); 9547 gfc_add_modify (&se->pre, var, se->expr); 9548 gfc_add_block_to_block (&se->pre, &se->post); 9549 se->expr = var; 9550 } 9551 return; 9552 } 9553 9554 if (expr->expr_type == EXPR_FUNCTION 9555 && ((expr->value.function.esym 9556 && expr->value.function.esym->result 9557 && expr->value.function.esym->result->attr.pointer 9558 && !expr->value.function.esym->result->attr.dimension) 9559 || (!expr->value.function.esym && !expr->ref 9560 && expr->symtree->n.sym->attr.pointer 9561 && !expr->symtree->n.sym->attr.dimension))) 9562 { 9563 se->want_pointer = 1; 9564 gfc_conv_expr (se, expr); 9565 var = gfc_create_var (TREE_TYPE (se->expr), NULL); 9566 gfc_add_modify (&se->pre, var, se->expr); 9567 se->expr = var; 9568 return; 9569 } 9570 9571 gfc_conv_expr (se, expr); 9572 9573 /* Create a temporary var to hold the value. */ 9574 if (TREE_CONSTANT (se->expr)) 9575 { 9576 tree tmp = se->expr; 9577 STRIP_TYPE_NOPS (tmp); 9578 var = build_decl (input_location, 9579 CONST_DECL, NULL, TREE_TYPE (tmp)); 9580 DECL_INITIAL (var) = tmp; 9581 TREE_STATIC (var) = 1; 9582 pushdecl (var); 9583 } 9584 else 9585 { 9586 var = gfc_create_var (TREE_TYPE (se->expr), NULL); 9587 gfc_add_modify (&se->pre, var, se->expr); 9588 } 9589 9590 if (!expr->must_finalize) 9591 gfc_add_block_to_block (&se->pre, &se->post); 9592 9593 /* Take the address of that value. */ 9594 se->expr = gfc_build_addr_expr (NULL_TREE, var); 9595} 9596 9597 9598/* Get the _len component for an unlimited polymorphic expression. */ 9599 9600static tree 9601trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr) 9602{ 9603 gfc_se se; 9604 gfc_ref *ref = expr->ref; 9605 9606 gfc_init_se (&se, NULL); 9607 while (ref && ref->next) 9608 ref = ref->next; 9609 gfc_add_len_component (expr); 9610 gfc_conv_expr (&se, expr); 9611 gfc_add_block_to_block (block, &se.pre); 9612 gcc_assert (se.post.head == NULL_TREE); 9613 if (ref) 9614 { 9615 gfc_free_ref_list (ref->next); 9616 ref->next = NULL; 9617 } 9618 else 9619 { 9620 gfc_free_ref_list (expr->ref); 9621 expr->ref = NULL; 9622 } 9623 return se.expr; 9624} 9625 9626 9627/* Assign _vptr and _len components as appropriate. BLOCK should be a 9628 statement-list outside of the scalarizer-loop. When code is generated, that 9629 depends on the scalarized expression, it is added to RSE.PRE. 9630 Returns le's _vptr tree and when set the len expressions in to_lenp and 9631 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp]) 9632 expression. */ 9633 9634static tree 9635trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, 9636 gfc_expr * re, gfc_se *rse, 9637 tree * to_lenp, tree * from_lenp) 9638{ 9639 gfc_se se; 9640 gfc_expr * vptr_expr; 9641 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr; 9642 bool set_vptr = false, temp_rhs = false; 9643 stmtblock_t *pre = block; 9644 tree class_expr = NULL_TREE; 9645 9646 /* Create a temporary for complicated expressions. */ 9647 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL 9648 && rse->expr != NULL_TREE && !DECL_P (rse->expr)) 9649 { 9650 if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) 9651 class_expr = gfc_get_class_from_expr (rse->expr); 9652 9653 if (rse->loop) 9654 pre = &rse->loop->pre; 9655 else 9656 pre = &rse->pre; 9657 9658 if (class_expr != NULL_TREE && UNLIMITED_POLY (re)) 9659 { 9660 tmp = TREE_OPERAND (rse->expr, 0); 9661 tmp = gfc_create_var (TREE_TYPE (tmp), "rhs"); 9662 gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0)); 9663 } 9664 else 9665 { 9666 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs"); 9667 gfc_add_modify (&rse->pre, tmp, rse->expr); 9668 } 9669 9670 rse->expr = tmp; 9671 temp_rhs = true; 9672 } 9673 9674 /* Get the _vptr for the left-hand side expression. */ 9675 gfc_init_se (&se, NULL); 9676 vptr_expr = gfc_find_and_cut_at_last_class_ref (le); 9677 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok) 9678 { 9679 /* Care about _len for unlimited polymorphic entities. */ 9680 if (UNLIMITED_POLY (vptr_expr) 9681 || (vptr_expr->ts.type == BT_DERIVED 9682 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) 9683 to_len = trans_get_upoly_len (block, vptr_expr); 9684 gfc_add_vptr_component (vptr_expr); 9685 set_vptr = true; 9686 } 9687 else 9688 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); 9689 se.want_pointer = 1; 9690 gfc_conv_expr (&se, vptr_expr); 9691 gfc_free_expr (vptr_expr); 9692 gfc_add_block_to_block (block, &se.pre); 9693 gcc_assert (se.post.head == NULL_TREE); 9694 lhs_vptr = se.expr; 9695 STRIP_NOPS (lhs_vptr); 9696 9697 /* Set the _vptr only when the left-hand side of the assignment is a 9698 class-object. */ 9699 if (set_vptr) 9700 { 9701 /* Get the vptr from the rhs expression only, when it is variable. 9702 Functions are expected to be assigned to a temporary beforehand. */ 9703 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS) 9704 ? gfc_find_and_cut_at_last_class_ref (re) 9705 : NULL; 9706 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS) 9707 { 9708 if (to_len != NULL_TREE) 9709 { 9710 /* Get the _len information from the rhs. */ 9711 if (UNLIMITED_POLY (vptr_expr) 9712 || (vptr_expr->ts.type == BT_DERIVED 9713 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic)) 9714 from_len = trans_get_upoly_len (block, vptr_expr); 9715 } 9716 gfc_add_vptr_component (vptr_expr); 9717 } 9718 else 9719 { 9720 if (re->expr_type == EXPR_VARIABLE 9721 && DECL_P (re->symtree->n.sym->backend_decl) 9722 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl) 9723 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl) 9724 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR ( 9725 re->symtree->n.sym->backend_decl)))) 9726 { 9727 vptr_expr = NULL; 9728 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR ( 9729 re->symtree->n.sym->backend_decl)); 9730 if (to_len) 9731 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR ( 9732 re->symtree->n.sym->backend_decl)); 9733 } 9734 else if (temp_rhs && re->ts.type == BT_CLASS) 9735 { 9736 vptr_expr = NULL; 9737 if (class_expr) 9738 tmp = class_expr; 9739 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) 9740 tmp = gfc_get_class_from_expr (rse->expr); 9741 else 9742 tmp = rse->expr; 9743 9744 se.expr = gfc_class_vptr_get (tmp); 9745 if (UNLIMITED_POLY (re)) 9746 from_len = gfc_class_len_get (tmp); 9747 9748 } 9749 else if (re->expr_type != EXPR_NULL) 9750 /* Only when rhs is non-NULL use its declared type for vptr 9751 initialisation. */ 9752 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts)); 9753 else 9754 /* When the rhs is NULL use the vtab of lhs' declared type. */ 9755 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts)); 9756 } 9757 9758 if (vptr_expr) 9759 { 9760 gfc_init_se (&se, NULL); 9761 se.want_pointer = 1; 9762 gfc_conv_expr (&se, vptr_expr); 9763 gfc_free_expr (vptr_expr); 9764 gfc_add_block_to_block (block, &se.pre); 9765 gcc_assert (se.post.head == NULL_TREE); 9766 } 9767 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr), 9768 se.expr)); 9769 9770 if (to_len != NULL_TREE) 9771 { 9772 /* The _len component needs to be set. Figure how to get the 9773 value of the right-hand side. */ 9774 if (from_len == NULL_TREE) 9775 { 9776 if (rse->string_length != NULL_TREE) 9777 from_len = rse->string_length; 9778 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length) 9779 { 9780 gfc_init_se (&se, NULL); 9781 gfc_conv_expr (&se, re->ts.u.cl->length); 9782 gfc_add_block_to_block (block, &se.pre); 9783 gcc_assert (se.post.head == NULL_TREE); 9784 from_len = gfc_evaluate_now (se.expr, block); 9785 } 9786 else 9787 from_len = build_zero_cst (gfc_charlen_type_node); 9788 } 9789 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len), 9790 from_len)); 9791 } 9792 } 9793 9794 /* Return the _len trees only, when requested. */ 9795 if (to_lenp) 9796 *to_lenp = to_len; 9797 if (from_lenp) 9798 *from_lenp = from_len; 9799 return lhs_vptr; 9800} 9801 9802 9803/* Assign tokens for pointer components. */ 9804 9805static void 9806trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1, 9807 gfc_expr *expr2) 9808{ 9809 symbol_attribute lhs_attr, rhs_attr; 9810 tree tmp, lhs_tok, rhs_tok; 9811 /* Flag to indicated component refs on the rhs. */ 9812 bool rhs_cr; 9813 9814 lhs_attr = gfc_caf_attr (expr1); 9815 if (expr2->expr_type != EXPR_NULL) 9816 { 9817 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr); 9818 if (lhs_attr.codimension && rhs_attr.codimension) 9819 { 9820 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1); 9821 lhs_tok = build_fold_indirect_ref (lhs_tok); 9822 9823 if (rhs_cr) 9824 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2); 9825 else 9826 { 9827 tree caf_decl; 9828 caf_decl = gfc_get_tree_for_caf_expr (expr2); 9829 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl, 9830 NULL_TREE, NULL); 9831 } 9832 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, 9833 lhs_tok, 9834 fold_convert (TREE_TYPE (lhs_tok), rhs_tok)); 9835 gfc_prepend_expr_to_block (&lse->post, tmp); 9836 } 9837 } 9838 else if (lhs_attr.codimension) 9839 { 9840 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1); 9841 lhs_tok = build_fold_indirect_ref (lhs_tok); 9842 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node, 9843 lhs_tok, null_pointer_node); 9844 gfc_prepend_expr_to_block (&lse->post, tmp); 9845 } 9846} 9847 9848 9849/* Do everything that is needed for a CLASS function expr2. */ 9850 9851static tree 9852trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse, 9853 gfc_expr *expr1, gfc_expr *expr2) 9854{ 9855 tree expr1_vptr = NULL_TREE; 9856 tree tmp; 9857 9858 gfc_conv_function_expr (rse, expr2); 9859 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre); 9860 9861 if (expr1->ts.type != BT_CLASS) 9862 rse->expr = gfc_class_data_get (rse->expr); 9863 else 9864 { 9865 expr1_vptr = trans_class_vptr_len_assignment (block, expr1, 9866 expr2, rse, 9867 NULL, NULL); 9868 gfc_add_block_to_block (block, &rse->pre); 9869 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp"); 9870 gfc_add_modify (&lse->pre, tmp, rse->expr); 9871 9872 gfc_add_modify (&lse->pre, expr1_vptr, 9873 fold_convert (TREE_TYPE (expr1_vptr), 9874 gfc_class_vptr_get (tmp))); 9875 rse->expr = gfc_class_data_get (tmp); 9876 } 9877 9878 return expr1_vptr; 9879} 9880 9881 9882tree 9883gfc_trans_pointer_assign (gfc_code * code) 9884{ 9885 return gfc_trans_pointer_assignment (code->expr1, code->expr2); 9886} 9887 9888 9889/* Generate code for a pointer assignment. */ 9890 9891tree 9892gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) 9893{ 9894 gfc_se lse; 9895 gfc_se rse; 9896 stmtblock_t block; 9897 tree desc; 9898 tree tmp; 9899 tree expr1_vptr = NULL_TREE; 9900 bool scalar, non_proc_ptr_assign; 9901 gfc_ss *ss; 9902 9903 gfc_start_block (&block); 9904 9905 gfc_init_se (&lse, NULL); 9906 9907 /* Usually testing whether this is not a proc pointer assignment. */ 9908 non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer 9909 && expr2->expr_type == EXPR_VARIABLE 9910 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE); 9911 9912 /* Check whether the expression is a scalar or not; we cannot use 9913 expr1->rank as it can be nonzero for proc pointers. */ 9914 ss = gfc_walk_expr (expr1); 9915 scalar = ss == gfc_ss_terminator; 9916 if (!scalar) 9917 gfc_free_ss_chain (ss); 9918 9919 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS 9920 && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign) 9921 { 9922 gfc_add_data_component (expr2); 9923 /* The following is required as gfc_add_data_component doesn't 9924 update ts.type if there is a trailing REF_ARRAY. */ 9925 expr2->ts.type = BT_DERIVED; 9926 } 9927 9928 if (scalar) 9929 { 9930 /* Scalar pointers. */ 9931 lse.want_pointer = 1; 9932 gfc_conv_expr (&lse, expr1); 9933 gfc_init_se (&rse, NULL); 9934 rse.want_pointer = 1; 9935 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) 9936 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2); 9937 else 9938 gfc_conv_expr (&rse, expr2); 9939 9940 if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS) 9941 { 9942 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, 9943 NULL); 9944 lse.expr = gfc_class_data_get (lse.expr); 9945 } 9946 9947 if (expr1->symtree->n.sym->attr.proc_pointer 9948 && expr1->symtree->n.sym->attr.dummy) 9949 lse.expr = build_fold_indirect_ref_loc (input_location, 9950 lse.expr); 9951 9952 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer 9953 && expr2->symtree->n.sym->attr.dummy) 9954 rse.expr = build_fold_indirect_ref_loc (input_location, 9955 rse.expr); 9956 9957 gfc_add_block_to_block (&block, &lse.pre); 9958 gfc_add_block_to_block (&block, &rse.pre); 9959 9960 /* Check character lengths if character expression. The test is only 9961 really added if -fbounds-check is enabled. Exclude deferred 9962 character length lefthand sides. */ 9963 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL 9964 && !expr1->ts.deferred 9965 && !expr1->symtree->n.sym->attr.proc_pointer 9966 && !gfc_is_proc_ptr_comp (expr1)) 9967 { 9968 gcc_assert (expr2->ts.type == BT_CHARACTER); 9969 gcc_assert (lse.string_length && rse.string_length); 9970 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where, 9971 lse.string_length, rse.string_length, 9972 &block); 9973 } 9974 9975 /* The assignment to an deferred character length sets the string 9976 length to that of the rhs. */ 9977 if (expr1->ts.deferred) 9978 { 9979 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL) 9980 gfc_add_modify (&block, lse.string_length, 9981 fold_convert (TREE_TYPE (lse.string_length), 9982 rse.string_length)); 9983 else if (lse.string_length != NULL) 9984 gfc_add_modify (&block, lse.string_length, 9985 build_zero_cst (TREE_TYPE (lse.string_length))); 9986 } 9987 9988 gfc_add_modify (&block, lse.expr, 9989 fold_convert (TREE_TYPE (lse.expr), rse.expr)); 9990 9991 /* Also set the tokens for pointer components in derived typed 9992 coarrays. */ 9993 if (flag_coarray == GFC_FCOARRAY_LIB) 9994 trans_caf_token_assign (&lse, &rse, expr1, expr2); 9995 9996 gfc_add_block_to_block (&block, &rse.post); 9997 gfc_add_block_to_block (&block, &lse.post); 9998 } 9999 else 10000 { 10001 gfc_ref* remap; 10002 bool rank_remap; 10003 tree strlen_lhs; 10004 tree strlen_rhs = NULL_TREE; 10005 10006 /* Array pointer. Find the last reference on the LHS and if it is an 10007 array section ref, we're dealing with bounds remapping. In this case, 10008 set it to AR_FULL so that gfc_conv_expr_descriptor does 10009 not see it and process the bounds remapping afterwards explicitly. */ 10010 for (remap = expr1->ref; remap; remap = remap->next) 10011 if (!remap->next && remap->type == REF_ARRAY 10012 && remap->u.ar.type == AR_SECTION) 10013 break; 10014 rank_remap = (remap && remap->u.ar.end[0]); 10015 10016 if (remap && expr2->expr_type == EXPR_NULL) 10017 { 10018 gfc_error ("If bounds remapping is specified at %L, " 10019 "the pointer target shall not be NULL", &expr1->where); 10020 return NULL_TREE; 10021 } 10022 10023 gfc_init_se (&lse, NULL); 10024 if (remap) 10025 lse.descriptor_only = 1; 10026 gfc_conv_expr_descriptor (&lse, expr1); 10027 strlen_lhs = lse.string_length; 10028 desc = lse.expr; 10029 10030 if (expr2->expr_type == EXPR_NULL) 10031 { 10032 /* Just set the data pointer to null. */ 10033 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node); 10034 } 10035 else if (rank_remap) 10036 { 10037 /* If we are rank-remapping, just get the RHS's descriptor and 10038 process this later on. */ 10039 gfc_init_se (&rse, NULL); 10040 rse.direct_byref = 1; 10041 rse.byref_noassign = 1; 10042 10043 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) 10044 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse, 10045 expr1, expr2); 10046 else if (expr2->expr_type == EXPR_FUNCTION) 10047 { 10048 tree bound[GFC_MAX_DIMENSIONS]; 10049 int i; 10050 10051 for (i = 0; i < expr2->rank; i++) 10052 bound[i] = NULL_TREE; 10053 tmp = gfc_typenode_for_spec (&expr2->ts); 10054 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0, 10055 bound, bound, 0, 10056 GFC_ARRAY_POINTER_CONT, false); 10057 tmp = gfc_create_var (tmp, "ptrtemp"); 10058 rse.descriptor_only = 0; 10059 rse.expr = tmp; 10060 rse.direct_byref = 1; 10061 gfc_conv_expr_descriptor (&rse, expr2); 10062 strlen_rhs = rse.string_length; 10063 rse.expr = tmp; 10064 } 10065 else 10066 { 10067 gfc_conv_expr_descriptor (&rse, expr2); 10068 strlen_rhs = rse.string_length; 10069 if (expr1->ts.type == BT_CLASS) 10070 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, 10071 expr2, &rse, 10072 NULL, NULL); 10073 } 10074 } 10075 else if (expr2->expr_type == EXPR_VARIABLE) 10076 { 10077 /* Assign directly to the LHS's descriptor. */ 10078 lse.descriptor_only = 0; 10079 lse.direct_byref = 1; 10080 gfc_conv_expr_descriptor (&lse, expr2); 10081 strlen_rhs = lse.string_length; 10082 gfc_init_se (&rse, NULL); 10083 10084 if (expr1->ts.type == BT_CLASS) 10085 { 10086 rse.expr = NULL_TREE; 10087 rse.string_length = strlen_rhs; 10088 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, 10089 NULL, NULL); 10090 } 10091 10092 if (remap == NULL) 10093 { 10094 /* If the target is not a whole array, use the target array 10095 reference for remap. */ 10096 for (remap = expr2->ref; remap; remap = remap->next) 10097 if (remap->type == REF_ARRAY 10098 && remap->u.ar.type == AR_FULL 10099 && remap->next) 10100 break; 10101 } 10102 } 10103 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) 10104 { 10105 gfc_init_se (&rse, NULL); 10106 rse.want_pointer = 1; 10107 gfc_conv_function_expr (&rse, expr2); 10108 if (expr1->ts.type != BT_CLASS) 10109 { 10110 rse.expr = gfc_class_data_get (rse.expr); 10111 gfc_add_modify (&lse.pre, desc, rse.expr); 10112 /* Set the lhs span. */ 10113 tmp = TREE_TYPE (rse.expr); 10114 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); 10115 tmp = fold_convert (gfc_array_index_type, tmp); 10116 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp); 10117 } 10118 else 10119 { 10120 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, 10121 expr2, &rse, NULL, 10122 NULL); 10123 gfc_add_block_to_block (&block, &rse.pre); 10124 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); 10125 gfc_add_modify (&lse.pre, tmp, rse.expr); 10126 10127 gfc_add_modify (&lse.pre, expr1_vptr, 10128 fold_convert (TREE_TYPE (expr1_vptr), 10129 gfc_class_vptr_get (tmp))); 10130 rse.expr = gfc_class_data_get (tmp); 10131 gfc_add_modify (&lse.pre, desc, rse.expr); 10132 } 10133 } 10134 else 10135 { 10136 /* Assign to a temporary descriptor and then copy that 10137 temporary to the pointer. */ 10138 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp"); 10139 lse.descriptor_only = 0; 10140 lse.expr = tmp; 10141 lse.direct_byref = 1; 10142 gfc_conv_expr_descriptor (&lse, expr2); 10143 strlen_rhs = lse.string_length; 10144 gfc_add_modify (&lse.pre, desc, tmp); 10145 } 10146 10147 if (expr1->ts.type == BT_CHARACTER 10148 && expr1->symtree->n.sym->ts.deferred 10149 && expr1->symtree->n.sym->ts.u.cl->backend_decl 10150 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl)) 10151 { 10152 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl; 10153 if (expr2->expr_type != EXPR_NULL) 10154 gfc_add_modify (&block, tmp, 10155 fold_convert (TREE_TYPE (tmp), strlen_rhs)); 10156 else 10157 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp))); 10158 } 10159 10160 gfc_add_block_to_block (&block, &lse.pre); 10161 if (rank_remap) 10162 gfc_add_block_to_block (&block, &rse.pre); 10163 10164 /* If we do bounds remapping, update LHS descriptor accordingly. */ 10165 if (remap) 10166 { 10167 int dim; 10168 gcc_assert (remap->u.ar.dimen == expr1->rank); 10169 10170 if (rank_remap) 10171 { 10172 /* Do rank remapping. We already have the RHS's descriptor 10173 converted in rse and now have to build the correct LHS 10174 descriptor for it. */ 10175 10176 tree dtype, data, span; 10177 tree offs, stride; 10178 tree lbound, ubound; 10179 10180 /* Set dtype. */ 10181 dtype = gfc_conv_descriptor_dtype (desc); 10182 tmp = gfc_get_dtype (TREE_TYPE (desc)); 10183 gfc_add_modify (&block, dtype, tmp); 10184 10185 /* Copy data pointer. */ 10186 data = gfc_conv_descriptor_data_get (rse.expr); 10187 gfc_conv_descriptor_data_set (&block, desc, data); 10188 10189 /* Copy the span. */ 10190 if (TREE_CODE (rse.expr) == VAR_DECL 10191 && GFC_DECL_PTR_ARRAY_P (rse.expr)) 10192 span = gfc_conv_descriptor_span_get (rse.expr); 10193 else 10194 { 10195 tmp = TREE_TYPE (rse.expr); 10196 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); 10197 span = fold_convert (gfc_array_index_type, tmp); 10198 } 10199 gfc_conv_descriptor_span_set (&block, desc, span); 10200 10201 /* Copy offset but adjust it such that it would correspond 10202 to a lbound of zero. */ 10203 offs = gfc_conv_descriptor_offset_get (rse.expr); 10204 for (dim = 0; dim < expr2->rank; ++dim) 10205 { 10206 stride = gfc_conv_descriptor_stride_get (rse.expr, 10207 gfc_rank_cst[dim]); 10208 lbound = gfc_conv_descriptor_lbound_get (rse.expr, 10209 gfc_rank_cst[dim]); 10210 tmp = fold_build2_loc (input_location, MULT_EXPR, 10211 gfc_array_index_type, stride, lbound); 10212 offs = fold_build2_loc (input_location, PLUS_EXPR, 10213 gfc_array_index_type, offs, tmp); 10214 } 10215 gfc_conv_descriptor_offset_set (&block, desc, offs); 10216 10217 /* Set the bounds as declared for the LHS and calculate strides as 10218 well as another offset update accordingly. */ 10219 stride = gfc_conv_descriptor_stride_get (rse.expr, 10220 gfc_rank_cst[0]); 10221 for (dim = 0; dim < expr1->rank; ++dim) 10222 { 10223 gfc_se lower_se; 10224 gfc_se upper_se; 10225 10226 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]); 10227 10228 /* Convert declared bounds. */ 10229 gfc_init_se (&lower_se, NULL); 10230 gfc_init_se (&upper_se, NULL); 10231 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]); 10232 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]); 10233 10234 gfc_add_block_to_block (&block, &lower_se.pre); 10235 gfc_add_block_to_block (&block, &upper_se.pre); 10236 10237 lbound = fold_convert (gfc_array_index_type, lower_se.expr); 10238 ubound = fold_convert (gfc_array_index_type, upper_se.expr); 10239 10240 lbound = gfc_evaluate_now (lbound, &block); 10241 ubound = gfc_evaluate_now (ubound, &block); 10242 10243 gfc_add_block_to_block (&block, &lower_se.post); 10244 gfc_add_block_to_block (&block, &upper_se.post); 10245 10246 /* Set bounds in descriptor. */ 10247 gfc_conv_descriptor_lbound_set (&block, desc, 10248 gfc_rank_cst[dim], lbound); 10249 gfc_conv_descriptor_ubound_set (&block, desc, 10250 gfc_rank_cst[dim], ubound); 10251 10252 /* Set stride. */ 10253 stride = gfc_evaluate_now (stride, &block); 10254 gfc_conv_descriptor_stride_set (&block, desc, 10255 gfc_rank_cst[dim], stride); 10256 10257 /* Update offset. */ 10258 offs = gfc_conv_descriptor_offset_get (desc); 10259 tmp = fold_build2_loc (input_location, MULT_EXPR, 10260 gfc_array_index_type, lbound, stride); 10261 offs = fold_build2_loc (input_location, MINUS_EXPR, 10262 gfc_array_index_type, offs, tmp); 10263 offs = gfc_evaluate_now (offs, &block); 10264 gfc_conv_descriptor_offset_set (&block, desc, offs); 10265 10266 /* Update stride. */ 10267 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); 10268 stride = fold_build2_loc (input_location, MULT_EXPR, 10269 gfc_array_index_type, stride, tmp); 10270 } 10271 } 10272 else 10273 { 10274 /* Bounds remapping. Just shift the lower bounds. */ 10275 10276 gcc_assert (expr1->rank == expr2->rank); 10277 10278 for (dim = 0; dim < remap->u.ar.dimen; ++dim) 10279 { 10280 gfc_se lbound_se; 10281 10282 gcc_assert (!remap->u.ar.end[dim]); 10283 gfc_init_se (&lbound_se, NULL); 10284 if (remap->u.ar.start[dim]) 10285 { 10286 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]); 10287 gfc_add_block_to_block (&block, &lbound_se.pre); 10288 } 10289 else 10290 /* This remap arises from a target that is not a whole 10291 array. The start expressions will be NULL but we need 10292 the lbounds to be one. */ 10293 lbound_se.expr = gfc_index_one_node; 10294 gfc_conv_shift_descriptor_lbound (&block, desc, 10295 dim, lbound_se.expr); 10296 gfc_add_block_to_block (&block, &lbound_se.post); 10297 } 10298 } 10299 } 10300 10301 /* If rank remapping was done, check with -fcheck=bounds that 10302 the target is at least as large as the pointer. */ 10303 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) 10304 { 10305 tree lsize, rsize; 10306 tree fault; 10307 const char* msg; 10308 10309 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank); 10310 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank); 10311 10312 lsize = gfc_evaluate_now (lsize, &block); 10313 rsize = gfc_evaluate_now (rsize, &block); 10314 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 10315 rsize, lsize); 10316 10317 msg = _("Target of rank remapping is too small (%ld < %ld)"); 10318 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where, 10319 msg, rsize, lsize); 10320 } 10321 10322 /* Check string lengths if applicable. The check is only really added 10323 to the output code if -fbounds-check is enabled. */ 10324 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL) 10325 { 10326 gcc_assert (expr2->ts.type == BT_CHARACTER); 10327 gcc_assert (strlen_lhs && strlen_rhs); 10328 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where, 10329 strlen_lhs, strlen_rhs, &block); 10330 } 10331 10332 gfc_add_block_to_block (&block, &lse.post); 10333 if (rank_remap) 10334 gfc_add_block_to_block (&block, &rse.post); 10335 } 10336 10337 return gfc_finish_block (&block); 10338} 10339 10340 10341/* Makes sure se is suitable for passing as a function string parameter. */ 10342/* TODO: Need to check all callers of this function. It may be abused. */ 10343 10344void 10345gfc_conv_string_parameter (gfc_se * se) 10346{ 10347 tree type; 10348 10349 if (TREE_CODE (se->expr) == STRING_CST) 10350 { 10351 type = TREE_TYPE (TREE_TYPE (se->expr)); 10352 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); 10353 return; 10354 } 10355 10356 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE 10357 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) 10358 && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) 10359 { 10360 if (TREE_CODE (se->expr) != INDIRECT_REF) 10361 { 10362 type = TREE_TYPE (se->expr); 10363 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr); 10364 } 10365 else 10366 { 10367 type = gfc_get_character_type_len (gfc_default_character_kind, 10368 se->string_length); 10369 type = build_pointer_type (type); 10370 se->expr = gfc_build_addr_expr (type, se->expr); 10371 } 10372 } 10373 10374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr))); 10375} 10376 10377 10378/* Generate code for assignment of scalar variables. Includes character 10379 strings and derived types with allocatable components. 10380 If you know that the LHS has no allocations, set dealloc to false. 10381 10382 DEEP_COPY has no effect if the typespec TS is not a derived type with 10383 allocatable components. Otherwise, if it is set, an explicit copy of each 10384 allocatable component is made. This is necessary as a simple copy of the 10385 whole object would copy array descriptors as is, so that the lhs's 10386 allocatable components would point to the rhs's after the assignment. 10387 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not 10388 necessary if the rhs is a non-pointer function, as the allocatable components 10389 are not accessible by other means than the function's result after the 10390 function has returned. It is even more subtle when temporaries are involved, 10391 as the two following examples show: 10392 1. When we evaluate an array constructor, a temporary is created. Thus 10393 there is theoretically no alias possible. However, no deep copy is 10394 made for this temporary, so that if the constructor is made of one or 10395 more variable with allocatable components, those components still point 10396 to the variable's: DEEP_COPY should be set for the assignment from the 10397 temporary to the lhs in that case. 10398 2. When assigning a scalar to an array, we evaluate the scalar value out 10399 of the loop, store it into a temporary variable, and assign from that. 10400 In that case, deep copying when assigning to the temporary would be a 10401 waste of resources; however deep copies should happen when assigning from 10402 the temporary to each array element: again DEEP_COPY should be set for 10403 the assignment from the temporary to the lhs. */ 10404 10405tree 10406gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, 10407 bool deep_copy, bool dealloc, bool in_coarray) 10408{ 10409 stmtblock_t block; 10410 tree tmp; 10411 tree cond; 10412 10413 gfc_init_block (&block); 10414 10415 if (ts.type == BT_CHARACTER) 10416 { 10417 tree rlen = NULL; 10418 tree llen = NULL; 10419 10420 if (lse->string_length != NULL_TREE) 10421 { 10422 gfc_conv_string_parameter (lse); 10423 gfc_add_block_to_block (&block, &lse->pre); 10424 llen = lse->string_length; 10425 } 10426 10427 if (rse->string_length != NULL_TREE) 10428 { 10429 gfc_conv_string_parameter (rse); 10430 gfc_add_block_to_block (&block, &rse->pre); 10431 rlen = rse->string_length; 10432 } 10433 10434 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen, 10435 rse->expr, ts.kind); 10436 } 10437 else if (gfc_bt_struct (ts.type) 10438 && (ts.u.derived->attr.alloc_comp 10439 || (deep_copy && ts.u.derived->attr.pdt_type))) 10440 { 10441 tree tmp_var = NULL_TREE; 10442 cond = NULL_TREE; 10443 10444 /* Are the rhs and the lhs the same? */ 10445 if (deep_copy) 10446 { 10447 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 10448 gfc_build_addr_expr (NULL_TREE, lse->expr), 10449 gfc_build_addr_expr (NULL_TREE, rse->expr)); 10450 cond = gfc_evaluate_now (cond, &lse->pre); 10451 } 10452 10453 /* Deallocate the lhs allocated components as long as it is not 10454 the same as the rhs. This must be done following the assignment 10455 to prevent deallocating data that could be used in the rhs 10456 expression. */ 10457 if (dealloc) 10458 { 10459 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre); 10460 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0); 10461 if (deep_copy) 10462 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), 10463 tmp); 10464 gfc_add_expr_to_block (&lse->post, tmp); 10465 } 10466 10467 gfc_add_block_to_block (&block, &rse->pre); 10468 gfc_add_block_to_block (&block, &lse->pre); 10469 10470 gfc_add_modify (&block, lse->expr, 10471 fold_convert (TREE_TYPE (lse->expr), rse->expr)); 10472 10473 /* Restore pointer address of coarray components. */ 10474 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE) 10475 { 10476 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr); 10477 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), 10478 tmp); 10479 gfc_add_expr_to_block (&block, tmp); 10480 } 10481 10482 /* Do a deep copy if the rhs is a variable, if it is not the 10483 same as the lhs. */ 10484 if (deep_copy) 10485 { 10486 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY 10487 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0; 10488 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0, 10489 caf_mode); 10490 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), 10491 tmp); 10492 gfc_add_expr_to_block (&block, tmp); 10493 } 10494 } 10495 else if (gfc_bt_struct (ts.type)) 10496 { 10497 gfc_add_block_to_block (&block, &lse->pre); 10498 gfc_add_block_to_block (&block, &rse->pre); 10499 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, 10500 TREE_TYPE (lse->expr), rse->expr); 10501 gfc_add_modify (&block, lse->expr, tmp); 10502 } 10503 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */ 10504 else if (ts.type == BT_CLASS) 10505 { 10506 gfc_add_block_to_block (&block, &lse->pre); 10507 gfc_add_block_to_block (&block, &rse->pre); 10508 10509 if (!trans_scalar_class_assign (&block, lse, rse)) 10510 { 10511 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR 10512 for the lhs which ensures that class data rhs cast as a string assigns 10513 correctly. */ 10514 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, 10515 TREE_TYPE (rse->expr), lse->expr); 10516 gfc_add_modify (&block, tmp, rse->expr); 10517 } 10518 } 10519 else if (ts.type != BT_CLASS) 10520 { 10521 gfc_add_block_to_block (&block, &lse->pre); 10522 gfc_add_block_to_block (&block, &rse->pre); 10523 10524 gfc_add_modify (&block, lse->expr, 10525 fold_convert (TREE_TYPE (lse->expr), rse->expr)); 10526 } 10527 10528 gfc_add_block_to_block (&block, &lse->post); 10529 gfc_add_block_to_block (&block, &rse->post); 10530 10531 return gfc_finish_block (&block); 10532} 10533 10534 10535/* There are quite a lot of restrictions on the optimisation in using an 10536 array function assign without a temporary. */ 10537 10538static bool 10539arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2) 10540{ 10541 gfc_ref * ref; 10542 bool seen_array_ref; 10543 bool c = false; 10544 gfc_symbol *sym = expr1->symtree->n.sym; 10545 10546 /* Play it safe with class functions assigned to a derived type. */ 10547 if (gfc_is_class_array_function (expr2) 10548 && expr1->ts.type == BT_DERIVED) 10549 return true; 10550 10551 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ 10552 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) 10553 return true; 10554 10555 /* Elemental functions are scalarized so that they don't need a 10556 temporary in gfc_trans_assignment_1, so return a true. Otherwise, 10557 they would need special treatment in gfc_trans_arrayfunc_assign. */ 10558 if (expr2->value.function.esym != NULL 10559 && expr2->value.function.esym->attr.elemental) 10560 return true; 10561 10562 /* Need a temporary if rhs is not FULL or a contiguous section. */ 10563 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c)) 10564 return true; 10565 10566 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */ 10567 if (gfc_ref_needs_temporary_p (expr1->ref)) 10568 return true; 10569 10570 /* Functions returning pointers or allocatables need temporaries. */ 10571 if (gfc_expr_attr (expr2).pointer 10572 || gfc_expr_attr (expr2).allocatable) 10573 return true; 10574 10575 /* Character array functions need temporaries unless the 10576 character lengths are the same. */ 10577 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0) 10578 { 10579 if (expr1->ts.u.cl->length == NULL 10580 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT) 10581 return true; 10582 10583 if (expr2->ts.u.cl->length == NULL 10584 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT) 10585 return true; 10586 10587 if (mpz_cmp (expr1->ts.u.cl->length->value.integer, 10588 expr2->ts.u.cl->length->value.integer) != 0) 10589 return true; 10590 } 10591 10592 /* Check that no LHS component references appear during an array 10593 reference. This is needed because we do not have the means to 10594 span any arbitrary stride with an array descriptor. This check 10595 is not needed for the rhs because the function result has to be 10596 a complete type. */ 10597 seen_array_ref = false; 10598 for (ref = expr1->ref; ref; ref = ref->next) 10599 { 10600 if (ref->type == REF_ARRAY) 10601 seen_array_ref= true; 10602 else if (ref->type == REF_COMPONENT && seen_array_ref) 10603 return true; 10604 } 10605 10606 /* Check for a dependency. */ 10607 if (gfc_check_fncall_dependency (expr1, INTENT_OUT, 10608 expr2->value.function.esym, 10609 expr2->value.function.actual, 10610 NOT_ELEMENTAL)) 10611 return true; 10612 10613 /* If we have reached here with an intrinsic function, we do not 10614 need a temporary except in the particular case that reallocation 10615 on assignment is active and the lhs is allocatable and a target, 10616 or a pointer which may be a subref pointer. FIXME: The last 10617 condition can go away when we use span in the intrinsics 10618 directly.*/ 10619 if (expr2->value.function.isym) 10620 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target) 10621 || (sym->attr.pointer && sym->attr.subref_array_pointer); 10622 10623 /* If the LHS is a dummy, we need a temporary if it is not 10624 INTENT(OUT). */ 10625 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT) 10626 return true; 10627 10628 /* If the lhs has been host_associated, is in common, a pointer or is 10629 a target and the function is not using a RESULT variable, aliasing 10630 can occur and a temporary is needed. */ 10631 if ((sym->attr.host_assoc 10632 || sym->attr.in_common 10633 || sym->attr.pointer 10634 || sym->attr.cray_pointee 10635 || sym->attr.target) 10636 && expr2->symtree != NULL 10637 && expr2->symtree->n.sym == expr2->symtree->n.sym->result) 10638 return true; 10639 10640 /* A PURE function can unconditionally be called without a temporary. */ 10641 if (expr2->value.function.esym != NULL 10642 && expr2->value.function.esym->attr.pure) 10643 return false; 10644 10645 /* Implicit_pure functions are those which could legally be declared 10646 to be PURE. */ 10647 if (expr2->value.function.esym != NULL 10648 && expr2->value.function.esym->attr.implicit_pure) 10649 return false; 10650 10651 if (!sym->attr.use_assoc 10652 && !sym->attr.in_common 10653 && !sym->attr.pointer 10654 && !sym->attr.target 10655 && !sym->attr.cray_pointee 10656 && expr2->value.function.esym) 10657 { 10658 /* A temporary is not needed if the function is not contained and 10659 the variable is local or host associated and not a pointer or 10660 a target. */ 10661 if (!expr2->value.function.esym->attr.contained) 10662 return false; 10663 10664 /* A temporary is not needed if the lhs has never been host 10665 associated and the procedure is contained. */ 10666 else if (!sym->attr.host_assoc) 10667 return false; 10668 10669 /* A temporary is not needed if the variable is local and not 10670 a pointer, a target or a result. */ 10671 if (sym->ns->parent 10672 && expr2->value.function.esym->ns == sym->ns->parent) 10673 return false; 10674 } 10675 10676 /* Default to temporary use. */ 10677 return true; 10678} 10679 10680 10681/* Provide the loop info so that the lhs descriptor can be built for 10682 reallocatable assignments from extrinsic function calls. */ 10683 10684static void 10685realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, 10686 gfc_loopinfo *loop) 10687{ 10688 /* Signal that the function call should not be made by 10689 gfc_conv_loop_setup. */ 10690 se->ss->is_alloc_lhs = 1; 10691 gfc_init_loopinfo (loop); 10692 gfc_add_ss_to_loop (loop, *ss); 10693 gfc_add_ss_to_loop (loop, se->ss); 10694 gfc_conv_ss_startstride (loop); 10695 gfc_conv_loop_setup (loop, where); 10696 gfc_copy_loopinfo_to_se (se, loop); 10697 gfc_add_block_to_block (&se->pre, &loop->pre); 10698 gfc_add_block_to_block (&se->pre, &loop->post); 10699 se->ss->is_alloc_lhs = 0; 10700} 10701 10702 10703/* For assignment to a reallocatable lhs from intrinsic functions, 10704 replace the se.expr (ie. the result) with a temporary descriptor. 10705 Null the data field so that the library allocates space for the 10706 result. Free the data of the original descriptor after the function, 10707 in case it appears in an argument expression and transfer the 10708 result to the original descriptor. */ 10709 10710static void 10711fcncall_realloc_result (gfc_se *se, int rank) 10712{ 10713 tree desc; 10714 tree res_desc; 10715 tree tmp; 10716 tree offset; 10717 tree zero_cond; 10718 tree not_same_shape; 10719 stmtblock_t shape_block; 10720 int n; 10721 10722 /* Use the allocation done by the library. Substitute the lhs 10723 descriptor with a copy, whose data field is nulled.*/ 10724 desc = build_fold_indirect_ref_loc (input_location, se->expr); 10725 if (POINTER_TYPE_P (TREE_TYPE (desc))) 10726 desc = build_fold_indirect_ref_loc (input_location, desc); 10727 10728 /* Unallocated, the descriptor does not have a dtype. */ 10729 tmp = gfc_conv_descriptor_dtype (desc); 10730 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); 10731 10732 res_desc = gfc_evaluate_now (desc, &se->pre); 10733 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); 10734 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc); 10735 10736 /* Free the lhs after the function call and copy the result data to 10737 the lhs descriptor. */ 10738 tmp = gfc_conv_descriptor_data_get (desc); 10739 zero_cond = fold_build2_loc (input_location, EQ_EXPR, 10740 logical_type_node, tmp, 10741 build_int_cst (TREE_TYPE (tmp), 0)); 10742 zero_cond = gfc_evaluate_now (zero_cond, &se->post); 10743 tmp = gfc_call_free (tmp); 10744 gfc_add_expr_to_block (&se->post, tmp); 10745 10746 tmp = gfc_conv_descriptor_data_get (res_desc); 10747 gfc_conv_descriptor_data_set (&se->post, desc, tmp); 10748 10749 /* Check that the shapes are the same between lhs and expression. 10750 The evaluation of the shape is done in 'shape_block' to avoid 10751 unitialized warnings from the lhs bounds. */ 10752 not_same_shape = boolean_false_node; 10753 gfc_start_block (&shape_block); 10754 for (n = 0 ; n < rank; n++) 10755 { 10756 tree tmp1; 10757 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); 10758 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]); 10759 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10760 gfc_array_index_type, tmp, tmp1); 10761 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); 10762 tmp = fold_build2_loc (input_location, MINUS_EXPR, 10763 gfc_array_index_type, tmp, tmp1); 10764 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]); 10765 tmp = fold_build2_loc (input_location, PLUS_EXPR, 10766 gfc_array_index_type, tmp, tmp1); 10767 tmp = fold_build2_loc (input_location, NE_EXPR, 10768 logical_type_node, tmp, 10769 gfc_index_zero_node); 10770 tmp = gfc_evaluate_now (tmp, &shape_block); 10771 if (n == 0) 10772 not_same_shape = tmp; 10773 else 10774 not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR, 10775 logical_type_node, tmp, 10776 not_same_shape); 10777 } 10778 10779 /* 'zero_cond' being true is equal to lhs not being allocated or the 10780 shapes being different. */ 10781 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, 10782 zero_cond, not_same_shape); 10783 gfc_add_modify (&shape_block, zero_cond, tmp); 10784 tmp = gfc_finish_block (&shape_block); 10785 tmp = build3_v (COND_EXPR, zero_cond, 10786 build_empty_stmt (input_location), tmp); 10787 gfc_add_expr_to_block (&se->post, tmp); 10788 10789 /* Now reset the bounds returned from the function call to bounds based 10790 on the lhs lbounds, except where the lhs is not allocated or the shapes 10791 of 'variable and 'expr' are different. Set the offset accordingly. */ 10792 offset = gfc_index_zero_node; 10793 for (n = 0 ; n < rank; n++) 10794 { 10795 tree lbound; 10796 10797 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); 10798 lbound = fold_build3_loc (input_location, COND_EXPR, 10799 gfc_array_index_type, zero_cond, 10800 gfc_index_one_node, lbound); 10801 lbound = gfc_evaluate_now (lbound, &se->post); 10802 10803 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]); 10804 tmp = fold_build2_loc (input_location, PLUS_EXPR, 10805 gfc_array_index_type, tmp, lbound); 10806 gfc_conv_descriptor_lbound_set (&se->post, desc, 10807 gfc_rank_cst[n], lbound); 10808 gfc_conv_descriptor_ubound_set (&se->post, desc, 10809 gfc_rank_cst[n], tmp); 10810 10811 /* Set stride and accumulate the offset. */ 10812 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]); 10813 gfc_conv_descriptor_stride_set (&se->post, desc, 10814 gfc_rank_cst[n], tmp); 10815 tmp = fold_build2_loc (input_location, MULT_EXPR, 10816 gfc_array_index_type, lbound, tmp); 10817 offset = fold_build2_loc (input_location, MINUS_EXPR, 10818 gfc_array_index_type, offset, tmp); 10819 offset = gfc_evaluate_now (offset, &se->post); 10820 } 10821 10822 gfc_conv_descriptor_offset_set (&se->post, desc, offset); 10823} 10824 10825 10826 10827/* Try to translate array(:) = func (...), where func is a transformational 10828 array function, without using a temporary. Returns NULL if this isn't the 10829 case. */ 10830 10831static tree 10832gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) 10833{ 10834 gfc_se se; 10835 gfc_ss *ss = NULL; 10836 gfc_component *comp = NULL; 10837 gfc_loopinfo loop; 10838 10839 if (arrayfunc_assign_needs_temporary (expr1, expr2)) 10840 return NULL; 10841 10842 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic 10843 functions. */ 10844 comp = gfc_get_proc_ptr_comp (expr2); 10845 10846 if (!(expr2->value.function.isym 10847 || (comp && comp->attr.dimension) 10848 || (!comp && gfc_return_by_reference (expr2->value.function.esym) 10849 && expr2->value.function.esym->result->attr.dimension))) 10850 return NULL; 10851 10852 gfc_init_se (&se, NULL); 10853 gfc_start_block (&se.pre); 10854 se.want_pointer = 1; 10855 10856 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL); 10857 10858 if (expr1->ts.type == BT_DERIVED 10859 && expr1->ts.u.derived->attr.alloc_comp) 10860 { 10861 tree tmp; 10862 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr, 10863 expr1->rank); 10864 gfc_add_expr_to_block (&se.pre, tmp); 10865 } 10866 10867 se.direct_byref = 1; 10868 se.ss = gfc_walk_expr (expr2); 10869 gcc_assert (se.ss != gfc_ss_terminator); 10870 10871 /* Reallocate on assignment needs the loopinfo for extrinsic functions. 10872 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs. 10873 Clearly, this cannot be done for an allocatable function result, since 10874 the shape of the result is unknown and, in any case, the function must 10875 correctly take care of the reallocation internally. For intrinsic 10876 calls, the array data is freed and the library takes care of allocation. 10877 TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment 10878 to the library. */ 10879 if (flag_realloc_lhs 10880 && gfc_is_reallocatable_lhs (expr1) 10881 && !gfc_expr_attr (expr1).codimension 10882 && !gfc_is_coindexed (expr1) 10883 && !(expr2->value.function.esym 10884 && expr2->value.function.esym->result->attr.allocatable)) 10885 { 10886 realloc_lhs_warning (expr1->ts.type, true, &expr1->where); 10887 10888 if (!expr2->value.function.isym) 10889 { 10890 ss = gfc_walk_expr (expr1); 10891 gcc_assert (ss != gfc_ss_terminator); 10892 10893 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop); 10894 ss->is_alloc_lhs = 1; 10895 } 10896 else 10897 fcncall_realloc_result (&se, expr1->rank); 10898 } 10899 10900 gfc_conv_function_expr (&se, expr2); 10901 gfc_add_block_to_block (&se.pre, &se.post); 10902 10903 if (ss) 10904 gfc_cleanup_loop (&loop); 10905 else 10906 gfc_free_ss_chain (se.ss); 10907 10908 return gfc_finish_block (&se.pre); 10909} 10910 10911 10912/* Try to efficiently translate array(:) = 0. Return NULL if this 10913 can't be done. */ 10914 10915static tree 10916gfc_trans_zero_assign (gfc_expr * expr) 10917{ 10918 tree dest, len, type; 10919 tree tmp; 10920 gfc_symbol *sym; 10921 10922 sym = expr->symtree->n.sym; 10923 dest = gfc_get_symbol_decl (sym); 10924 10925 type = TREE_TYPE (dest); 10926 if (POINTER_TYPE_P (type)) 10927 type = TREE_TYPE (type); 10928 if (!GFC_ARRAY_TYPE_P (type)) 10929 return NULL_TREE; 10930 10931 /* Determine the length of the array. */ 10932 len = GFC_TYPE_ARRAY_SIZE (type); 10933 if (!len || TREE_CODE (len) != INTEGER_CST) 10934 return NULL_TREE; 10935 10936 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); 10937 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, 10938 fold_convert (gfc_array_index_type, tmp)); 10939 10940 /* If we are zeroing a local array avoid taking its address by emitting 10941 a = {} instead. */ 10942 if (!POINTER_TYPE_P (TREE_TYPE (dest))) 10943 return build2_loc (input_location, MODIFY_EXPR, void_type_node, 10944 dest, build_constructor (TREE_TYPE (dest), 10945 NULL)); 10946 10947 /* Convert arguments to the correct types. */ 10948 dest = fold_convert (pvoid_type_node, dest); 10949 len = fold_convert (size_type_node, len); 10950 10951 /* Construct call to __builtin_memset. */ 10952 tmp = build_call_expr_loc (input_location, 10953 builtin_decl_explicit (BUILT_IN_MEMSET), 10954 3, dest, integer_zero_node, len); 10955 return fold_convert (void_type_node, tmp); 10956} 10957 10958 10959/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy 10960 that constructs the call to __builtin_memcpy. */ 10961 10962tree 10963gfc_build_memcpy_call (tree dst, tree src, tree len) 10964{ 10965 tree tmp; 10966 10967 /* Convert arguments to the correct types. */ 10968 if (!POINTER_TYPE_P (TREE_TYPE (dst))) 10969 dst = gfc_build_addr_expr (pvoid_type_node, dst); 10970 else 10971 dst = fold_convert (pvoid_type_node, dst); 10972 10973 if (!POINTER_TYPE_P (TREE_TYPE (src))) 10974 src = gfc_build_addr_expr (pvoid_type_node, src); 10975 else 10976 src = fold_convert (pvoid_type_node, src); 10977 10978 len = fold_convert (size_type_node, len); 10979 10980 /* Construct call to __builtin_memcpy. */ 10981 tmp = build_call_expr_loc (input_location, 10982 builtin_decl_explicit (BUILT_IN_MEMCPY), 10983 3, dst, src, len); 10984 return fold_convert (void_type_node, tmp); 10985} 10986 10987 10988/* Try to efficiently translate dst(:) = src(:). Return NULL if this 10989 can't be done. EXPR1 is the destination/lhs and EXPR2 is the 10990 source/rhs, both are gfc_full_array_ref_p which have been checked for 10991 dependencies. */ 10992 10993static tree 10994gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2) 10995{ 10996 tree dst, dlen, dtype; 10997 tree src, slen, stype; 10998 tree tmp; 10999 11000 dst = gfc_get_symbol_decl (expr1->symtree->n.sym); 11001 src = gfc_get_symbol_decl (expr2->symtree->n.sym); 11002 11003 dtype = TREE_TYPE (dst); 11004 if (POINTER_TYPE_P (dtype)) 11005 dtype = TREE_TYPE (dtype); 11006 stype = TREE_TYPE (src); 11007 if (POINTER_TYPE_P (stype)) 11008 stype = TREE_TYPE (stype); 11009 11010 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype)) 11011 return NULL_TREE; 11012 11013 /* Determine the lengths of the arrays. */ 11014 dlen = GFC_TYPE_ARRAY_SIZE (dtype); 11015 if (!dlen || TREE_CODE (dlen) != INTEGER_CST) 11016 return NULL_TREE; 11017 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); 11018 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 11019 dlen, fold_convert (gfc_array_index_type, tmp)); 11020 11021 slen = GFC_TYPE_ARRAY_SIZE (stype); 11022 if (!slen || TREE_CODE (slen) != INTEGER_CST) 11023 return NULL_TREE; 11024 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype)); 11025 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 11026 slen, fold_convert (gfc_array_index_type, tmp)); 11027 11028 /* Sanity check that they are the same. This should always be 11029 the case, as we should already have checked for conformance. */ 11030 if (!tree_int_cst_equal (slen, dlen)) 11031 return NULL_TREE; 11032 11033 return gfc_build_memcpy_call (dst, src, dlen); 11034} 11035 11036 11037/* Try to efficiently translate array(:) = (/ ... /). Return NULL if 11038 this can't be done. EXPR1 is the destination/lhs for which 11039 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */ 11040 11041static tree 11042gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) 11043{ 11044 unsigned HOST_WIDE_INT nelem; 11045 tree dst, dtype; 11046 tree src, stype; 11047 tree len; 11048 tree tmp; 11049 11050 nelem = gfc_constant_array_constructor_p (expr2->value.constructor); 11051 if (nelem == 0) 11052 return NULL_TREE; 11053 11054 dst = gfc_get_symbol_decl (expr1->symtree->n.sym); 11055 dtype = TREE_TYPE (dst); 11056 if (POINTER_TYPE_P (dtype)) 11057 dtype = TREE_TYPE (dtype); 11058 if (!GFC_ARRAY_TYPE_P (dtype)) 11059 return NULL_TREE; 11060 11061 /* Determine the lengths of the array. */ 11062 len = GFC_TYPE_ARRAY_SIZE (dtype); 11063 if (!len || TREE_CODE (len) != INTEGER_CST) 11064 return NULL_TREE; 11065 11066 /* Confirm that the constructor is the same size. */ 11067 if (compare_tree_int (len, nelem) != 0) 11068 return NULL_TREE; 11069 11070 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype)); 11071 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len, 11072 fold_convert (gfc_array_index_type, tmp)); 11073 11074 stype = gfc_typenode_for_spec (&expr2->ts); 11075 src = gfc_build_constant_array_constructor (expr2, stype); 11076 11077 return gfc_build_memcpy_call (dst, src, len); 11078} 11079 11080 11081/* Tells whether the expression is to be treated as a variable reference. */ 11082 11083bool 11084gfc_expr_is_variable (gfc_expr *expr) 11085{ 11086 gfc_expr *arg; 11087 gfc_component *comp; 11088 gfc_symbol *func_ifc; 11089 11090 if (expr->expr_type == EXPR_VARIABLE) 11091 return true; 11092 11093 arg = gfc_get_noncopying_intrinsic_argument (expr); 11094 if (arg) 11095 { 11096 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); 11097 return gfc_expr_is_variable (arg); 11098 } 11099 11100 /* A data-pointer-returning function should be considered as a variable 11101 too. */ 11102 if (expr->expr_type == EXPR_FUNCTION 11103 && expr->ref == NULL) 11104 { 11105 if (expr->value.function.isym != NULL) 11106 return false; 11107 11108 if (expr->value.function.esym != NULL) 11109 { 11110 func_ifc = expr->value.function.esym; 11111 goto found_ifc; 11112 } 11113 gcc_assert (expr->symtree); 11114 func_ifc = expr->symtree->n.sym; 11115 goto found_ifc; 11116 } 11117 11118 comp = gfc_get_proc_ptr_comp (expr); 11119 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION) 11120 && comp) 11121 { 11122 func_ifc = comp->ts.interface; 11123 goto found_ifc; 11124 } 11125 11126 if (expr->expr_type == EXPR_COMPCALL) 11127 { 11128 gcc_assert (!expr->value.compcall.tbp->is_generic); 11129 func_ifc = expr->value.compcall.tbp->u.specific->n.sym; 11130 goto found_ifc; 11131 } 11132 11133 return false; 11134 11135found_ifc: 11136 gcc_assert (func_ifc->attr.function 11137 && func_ifc->result != NULL); 11138 return func_ifc->result->attr.pointer; 11139} 11140 11141 11142/* Is the lhs OK for automatic reallocation? */ 11143 11144static bool 11145is_scalar_reallocatable_lhs (gfc_expr *expr) 11146{ 11147 gfc_ref * ref; 11148 11149 /* An allocatable variable with no reference. */ 11150 if (expr->symtree->n.sym->attr.allocatable 11151 && !expr->ref) 11152 return true; 11153 11154 /* All that can be left are allocatable components. However, we do 11155 not check for allocatable components here because the expression 11156 could be an allocatable component of a pointer component. */ 11157 if (expr->symtree->n.sym->ts.type != BT_DERIVED 11158 && expr->symtree->n.sym->ts.type != BT_CLASS) 11159 return false; 11160 11161 /* Find an allocatable component ref last. */ 11162 for (ref = expr->ref; ref; ref = ref->next) 11163 if (ref->type == REF_COMPONENT 11164 && !ref->next 11165 && ref->u.c.component->attr.allocatable) 11166 return true; 11167 11168 return false; 11169} 11170 11171 11172/* Allocate or reallocate scalar lhs, as necessary. */ 11173 11174static void 11175alloc_scalar_allocatable_for_assignment (stmtblock_t *block, 11176 tree string_length, 11177 gfc_expr *expr1, 11178 gfc_expr *expr2) 11179 11180{ 11181 tree cond; 11182 tree tmp; 11183 tree size; 11184 tree size_in_bytes; 11185 tree jump_label1; 11186 tree jump_label2; 11187 gfc_se lse; 11188 gfc_ref *ref; 11189 11190 if (!expr1 || expr1->rank) 11191 return; 11192 11193 if (!expr2 || expr2->rank) 11194 return; 11195 11196 for (ref = expr1->ref; ref; ref = ref->next) 11197 if (ref->type == REF_SUBSTRING) 11198 return; 11199 11200 realloc_lhs_warning (expr2->ts.type, false, &expr2->where); 11201 11202 /* Since this is a scalar lhs, we can afford to do this. That is, 11203 there is no risk of side effects being repeated. */ 11204 gfc_init_se (&lse, NULL); 11205 lse.want_pointer = 1; 11206 gfc_conv_expr (&lse, expr1); 11207 11208 jump_label1 = gfc_build_label_decl (NULL_TREE); 11209 jump_label2 = gfc_build_label_decl (NULL_TREE); 11210 11211 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */ 11212 tmp = build_int_cst (TREE_TYPE (lse.expr), 0); 11213 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 11214 lse.expr, tmp); 11215 tmp = build3_v (COND_EXPR, cond, 11216 build1_v (GOTO_EXPR, jump_label1), 11217 build_empty_stmt (input_location)); 11218 gfc_add_expr_to_block (block, tmp); 11219 11220 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 11221 { 11222 /* Use the rhs string length and the lhs element size. */ 11223 size = string_length; 11224 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)); 11225 tmp = TYPE_SIZE_UNIT (tmp); 11226 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR, 11227 TREE_TYPE (tmp), tmp, 11228 fold_convert (TREE_TYPE (tmp), size)); 11229 } 11230 else 11231 { 11232 /* Otherwise use the length in bytes of the rhs. */ 11233 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts)); 11234 size_in_bytes = size; 11235 } 11236 11237 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node, 11238 size_in_bytes, size_one_node); 11239 11240 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB) 11241 { 11242 tree caf_decl, token; 11243 gfc_se caf_se; 11244 symbol_attribute attr; 11245 11246 gfc_clear_attr (&attr); 11247 gfc_init_se (&caf_se, NULL); 11248 11249 caf_decl = gfc_get_tree_for_caf_expr (expr1); 11250 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE, 11251 NULL); 11252 gfc_add_block_to_block (block, &caf_se.pre); 11253 gfc_allocate_allocatable (block, lse.expr, size_in_bytes, 11254 gfc_build_addr_expr (NULL_TREE, token), 11255 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1, 11256 expr1, 1); 11257 } 11258 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) 11259 { 11260 tmp = build_call_expr_loc (input_location, 11261 builtin_decl_explicit (BUILT_IN_CALLOC), 11262 2, build_one_cst (size_type_node), 11263 size_in_bytes); 11264 tmp = fold_convert (TREE_TYPE (lse.expr), tmp); 11265 gfc_add_modify (block, lse.expr, tmp); 11266 } 11267 else 11268 { 11269 tmp = build_call_expr_loc (input_location, 11270 builtin_decl_explicit (BUILT_IN_MALLOC), 11271 1, size_in_bytes); 11272 tmp = fold_convert (TREE_TYPE (lse.expr), tmp); 11273 gfc_add_modify (block, lse.expr, tmp); 11274 } 11275 11276 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 11277 { 11278 /* Deferred characters need checking for lhs and rhs string 11279 length. Other deferred parameter variables will have to 11280 come here too. */ 11281 tmp = build1_v (GOTO_EXPR, jump_label2); 11282 gfc_add_expr_to_block (block, tmp); 11283 } 11284 tmp = build1_v (LABEL_EXPR, jump_label1); 11285 gfc_add_expr_to_block (block, tmp); 11286 11287 /* For a deferred length character, reallocate if lengths of lhs and 11288 rhs are different. */ 11289 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) 11290 { 11291 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 11292 lse.string_length, 11293 fold_convert (TREE_TYPE (lse.string_length), 11294 size)); 11295 /* Jump past the realloc if the lengths are the same. */ 11296 tmp = build3_v (COND_EXPR, cond, 11297 build1_v (GOTO_EXPR, jump_label2), 11298 build_empty_stmt (input_location)); 11299 gfc_add_expr_to_block (block, tmp); 11300 tmp = build_call_expr_loc (input_location, 11301 builtin_decl_explicit (BUILT_IN_REALLOC), 11302 2, fold_convert (pvoid_type_node, lse.expr), 11303 size_in_bytes); 11304 tmp = fold_convert (TREE_TYPE (lse.expr), tmp); 11305 gfc_add_modify (block, lse.expr, tmp); 11306 tmp = build1_v (LABEL_EXPR, jump_label2); 11307 gfc_add_expr_to_block (block, tmp); 11308 11309 /* Update the lhs character length. */ 11310 size = string_length; 11311 gfc_add_modify (block, lse.string_length, 11312 fold_convert (TREE_TYPE (lse.string_length), size)); 11313 } 11314} 11315 11316/* Check for assignments of the type 11317 11318 a = a + 4 11319 11320 to make sure we do not check for reallocation unneccessarily. */ 11321 11322 11323static bool 11324is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) 11325{ 11326 gfc_actual_arglist *a; 11327 gfc_expr *e1, *e2; 11328 11329 switch (expr2->expr_type) 11330 { 11331 case EXPR_VARIABLE: 11332 return gfc_dep_compare_expr (expr1, expr2) == 0; 11333 11334 case EXPR_FUNCTION: 11335 if (expr2->value.function.esym 11336 && expr2->value.function.esym->attr.elemental) 11337 { 11338 for (a = expr2->value.function.actual; a != NULL; a = a->next) 11339 { 11340 e1 = a->expr; 11341 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1)) 11342 return false; 11343 } 11344 return true; 11345 } 11346 else if (expr2->value.function.isym 11347 && expr2->value.function.isym->elemental) 11348 { 11349 for (a = expr2->value.function.actual; a != NULL; a = a->next) 11350 { 11351 e1 = a->expr; 11352 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1)) 11353 return false; 11354 } 11355 return true; 11356 } 11357 11358 break; 11359 11360 case EXPR_OP: 11361 switch (expr2->value.op.op) 11362 { 11363 case INTRINSIC_NOT: 11364 case INTRINSIC_UPLUS: 11365 case INTRINSIC_UMINUS: 11366 case INTRINSIC_PARENTHESES: 11367 return is_runtime_conformable (expr1, expr2->value.op.op1); 11368 11369 case INTRINSIC_PLUS: 11370 case INTRINSIC_MINUS: 11371 case INTRINSIC_TIMES: 11372 case INTRINSIC_DIVIDE: 11373 case INTRINSIC_POWER: 11374 case INTRINSIC_AND: 11375 case INTRINSIC_OR: 11376 case INTRINSIC_EQV: 11377 case INTRINSIC_NEQV: 11378 case INTRINSIC_EQ: 11379 case INTRINSIC_NE: 11380 case INTRINSIC_GT: 11381 case INTRINSIC_GE: 11382 case INTRINSIC_LT: 11383 case INTRINSIC_LE: 11384 case INTRINSIC_EQ_OS: 11385 case INTRINSIC_NE_OS: 11386 case INTRINSIC_GT_OS: 11387 case INTRINSIC_GE_OS: 11388 case INTRINSIC_LT_OS: 11389 case INTRINSIC_LE_OS: 11390 11391 e1 = expr2->value.op.op1; 11392 e2 = expr2->value.op.op2; 11393 11394 if (e1->rank == 0 && e2->rank > 0) 11395 return is_runtime_conformable (expr1, e2); 11396 else if (e1->rank > 0 && e2->rank == 0) 11397 return is_runtime_conformable (expr1, e1); 11398 else if (e1->rank > 0 && e2->rank > 0) 11399 return is_runtime_conformable (expr1, e1) 11400 && is_runtime_conformable (expr1, e2); 11401 break; 11402 11403 default: 11404 break; 11405 11406 } 11407 11408 break; 11409 11410 default: 11411 break; 11412 } 11413 return false; 11414} 11415 11416 11417static tree 11418trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, 11419 gfc_se *lse, gfc_se *rse, bool use_vptr_copy, 11420 bool class_realloc) 11421{ 11422 tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr; 11423 vec<tree, va_gc> *args = NULL; 11424 11425 /* Store the old vptr so that dynamic types can be compared for 11426 reallocation to occur or not. */ 11427 if (class_realloc) 11428 { 11429 tmp = lse->expr; 11430 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) 11431 tmp = gfc_get_class_from_expr (tmp); 11432 } 11433 11434 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, 11435 &from_len); 11436 11437 /* Generate (re)allocation of the lhs. */ 11438 if (class_realloc) 11439 { 11440 stmtblock_t alloc, re_alloc; 11441 tree class_han, re, size; 11442 11443 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) 11444 old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block); 11445 else 11446 old_vptr = build_int_cst (TREE_TYPE (vptr), 0); 11447 11448 size = gfc_vptr_size_get (vptr); 11449 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) 11450 ? gfc_class_data_get (lse->expr) : lse->expr; 11451 11452 if (!POINTER_TYPE_P (TREE_TYPE (class_han))) 11453 class_han = gfc_build_addr_expr (NULL_TREE, class_han); 11454 11455 /* Allocate block. */ 11456 gfc_init_block (&alloc); 11457 gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE); 11458 11459 /* Reallocate if dynamic types are different. */ 11460 gfc_init_block (&re_alloc); 11461 re = build_call_expr_loc (input_location, 11462 builtin_decl_explicit (BUILT_IN_REALLOC), 2, 11463 fold_convert (pvoid_type_node, class_han), 11464 size); 11465 tmp = fold_build2_loc (input_location, NE_EXPR, 11466 logical_type_node, vptr, old_vptr); 11467 re = fold_build3_loc (input_location, COND_EXPR, void_type_node, 11468 tmp, re, build_empty_stmt (input_location)); 11469 gfc_add_expr_to_block (&re_alloc, re); 11470 11471 /* Allocate if _data is NULL, reallocate otherwise. */ 11472 tmp = fold_build2_loc (input_location, EQ_EXPR, 11473 logical_type_node, class_han, 11474 build_int_cst (prvoid_type_node, 0)); 11475 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 11476 gfc_unlikely (tmp, 11477 PRED_FORTRAN_FAIL_ALLOC), 11478 gfc_finish_block (&alloc), 11479 gfc_finish_block (&re_alloc)); 11480 gfc_add_expr_to_block (&lse->pre, tmp); 11481 } 11482 11483 fcn = gfc_vptr_copy_get (vptr); 11484 11485 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) 11486 ? gfc_class_data_get (rse->expr) : rse->expr; 11487 if (use_vptr_copy) 11488 { 11489 if (!POINTER_TYPE_P (TREE_TYPE (tmp)) 11490 || INDIRECT_REF_P (tmp) 11491 || (rhs->ts.type == BT_DERIVED 11492 && rhs->ts.u.derived->attr.unlimited_polymorphic 11493 && !rhs->ts.u.derived->attr.pointer 11494 && !rhs->ts.u.derived->attr.allocatable) 11495 || (UNLIMITED_POLY (rhs) 11496 && !CLASS_DATA (rhs)->attr.pointer 11497 && !CLASS_DATA (rhs)->attr.allocatable)) 11498 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); 11499 else 11500 vec_safe_push (args, tmp); 11501 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) 11502 ? gfc_class_data_get (lse->expr) : lse->expr; 11503 if (!POINTER_TYPE_P (TREE_TYPE (tmp)) 11504 || INDIRECT_REF_P (tmp) 11505 || (lhs->ts.type == BT_DERIVED 11506 && lhs->ts.u.derived->attr.unlimited_polymorphic 11507 && !lhs->ts.u.derived->attr.pointer 11508 && !lhs->ts.u.derived->attr.allocatable) 11509 || (UNLIMITED_POLY (lhs) 11510 && !CLASS_DATA (lhs)->attr.pointer 11511 && !CLASS_DATA (lhs)->attr.allocatable)) 11512 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp)); 11513 else 11514 vec_safe_push (args, tmp); 11515 11516 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); 11517 11518 if (to_len != NULL_TREE && !integer_zerop (from_len)) 11519 { 11520 tree extcopy; 11521 vec_safe_push (args, from_len); 11522 vec_safe_push (args, to_len); 11523 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); 11524 11525 tmp = fold_build2_loc (input_location, GT_EXPR, 11526 logical_type_node, from_len, 11527 build_zero_cst (TREE_TYPE (from_len))); 11528 return fold_build3_loc (input_location, COND_EXPR, 11529 void_type_node, tmp, 11530 extcopy, stdcopy); 11531 } 11532 else 11533 return stdcopy; 11534 } 11535 else 11536 { 11537 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) 11538 ? gfc_class_data_get (lse->expr) : lse->expr; 11539 stmtblock_t tblock; 11540 gfc_init_block (&tblock); 11541 if (!POINTER_TYPE_P (TREE_TYPE (tmp))) 11542 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 11543 if (!POINTER_TYPE_P (TREE_TYPE (rhst))) 11544 rhst = gfc_build_addr_expr (NULL_TREE, rhst); 11545 /* When coming from a ptr_copy lhs and rhs are swapped. */ 11546 gfc_add_modify_loc (input_location, &tblock, rhst, 11547 fold_convert (TREE_TYPE (rhst), tmp)); 11548 return gfc_finish_block (&tblock); 11549 } 11550} 11551 11552/* Subroutine of gfc_trans_assignment that actually scalarizes the 11553 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. 11554 init_flag indicates initialization expressions and dealloc that no 11555 deallocate prior assignment is needed (if in doubt, set true). 11556 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy 11557 routine instead of a pointer assignment. Alias resolution is only done, 11558 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE() 11559 where it is known, that newly allocated memory on the lhs can never be 11560 an alias of the rhs. */ 11561 11562static tree 11563gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 11564 bool dealloc, bool use_vptr_copy, bool may_alias) 11565{ 11566 gfc_se lse; 11567 gfc_se rse; 11568 gfc_ss *lss; 11569 gfc_ss *lss_section; 11570 gfc_ss *rss; 11571 gfc_loopinfo loop; 11572 tree tmp; 11573 stmtblock_t block; 11574 stmtblock_t body; 11575 bool l_is_temp; 11576 bool scalar_to_array; 11577 tree string_length; 11578 int n; 11579 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false; 11580 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; 11581 bool is_poly_assign; 11582 bool realloc_flag; 11583 11584 /* Assignment of the form lhs = rhs. */ 11585 gfc_start_block (&block); 11586 11587 gfc_init_se (&lse, NULL); 11588 gfc_init_se (&rse, NULL); 11589 11590 /* Walk the lhs. */ 11591 lss = gfc_walk_expr (expr1); 11592 if (gfc_is_reallocatable_lhs (expr1)) 11593 { 11594 lss->no_bounds_check = 1; 11595 if (!(expr2->expr_type == EXPR_FUNCTION 11596 && expr2->value.function.isym != NULL 11597 && !(expr2->value.function.isym->elemental 11598 || expr2->value.function.isym->conversion))) 11599 lss->is_alloc_lhs = 1; 11600 } 11601 else 11602 lss->no_bounds_check = expr1->no_bounds_check; 11603 11604 rss = NULL; 11605 11606 if ((expr1->ts.type == BT_DERIVED) 11607 && (gfc_is_class_array_function (expr2) 11608 || gfc_is_alloc_class_scalar_function (expr2))) 11609 expr2->must_finalize = 1; 11610 11611 /* Checking whether a class assignment is desired is quite complicated and 11612 needed at two locations, so do it once only before the information is 11613 needed. */ 11614 lhs_attr = gfc_expr_attr (expr1); 11615 is_poly_assign = (use_vptr_copy || lhs_attr.pointer 11616 || (lhs_attr.allocatable && !lhs_attr.dimension)) 11617 && (expr1->ts.type == BT_CLASS 11618 || gfc_is_class_array_ref (expr1, NULL) 11619 || gfc_is_class_scalar_expr (expr1) 11620 || gfc_is_class_array_ref (expr2, NULL) 11621 || gfc_is_class_scalar_expr (expr2)) 11622 && lhs_attr.flavor != FL_PROCEDURE; 11623 11624 realloc_flag = flag_realloc_lhs 11625 && gfc_is_reallocatable_lhs (expr1) 11626 && expr2->rank 11627 && !is_runtime_conformable (expr1, expr2); 11628 11629 /* Only analyze the expressions for coarray properties, when in coarray-lib 11630 mode. */ 11631 if (flag_coarray == GFC_FCOARRAY_LIB) 11632 { 11633 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp); 11634 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); 11635 } 11636 11637 if (lss != gfc_ss_terminator) 11638 { 11639 /* The assignment needs scalarization. */ 11640 lss_section = lss; 11641 11642 /* Find a non-scalar SS from the lhs. */ 11643 while (lss_section != gfc_ss_terminator 11644 && lss_section->info->type != GFC_SS_SECTION) 11645 lss_section = lss_section->next; 11646 11647 gcc_assert (lss_section != gfc_ss_terminator); 11648 11649 /* Initialize the scalarizer. */ 11650 gfc_init_loopinfo (&loop); 11651 11652 /* Walk the rhs. */ 11653 rss = gfc_walk_expr (expr2); 11654 if (rss == gfc_ss_terminator) 11655 /* The rhs is scalar. Add a ss for the expression. */ 11656 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); 11657 /* When doing a class assign, then the handle to the rhs needs to be a 11658 pointer to allow for polymorphism. */ 11659 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) 11660 rss->info->type = GFC_SS_REFERENCE; 11661 11662 rss->no_bounds_check = expr2->no_bounds_check; 11663 /* Associate the SS with the loop. */ 11664 gfc_add_ss_to_loop (&loop, lss); 11665 gfc_add_ss_to_loop (&loop, rss); 11666 11667 /* Calculate the bounds of the scalarization. */ 11668 gfc_conv_ss_startstride (&loop); 11669 /* Enable loop reversal. */ 11670 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 11671 loop.reverse[n] = GFC_ENABLE_REVERSE; 11672 /* Resolve any data dependencies in the statement. */ 11673 if (may_alias) 11674 gfc_conv_resolve_dependencies (&loop, lss, rss); 11675 /* Setup the scalarizing loops. */ 11676 gfc_conv_loop_setup (&loop, &expr2->where); 11677 11678 /* Setup the gfc_se structures. */ 11679 gfc_copy_loopinfo_to_se (&lse, &loop); 11680 gfc_copy_loopinfo_to_se (&rse, &loop); 11681 11682 rse.ss = rss; 11683 gfc_mark_ss_chain_used (rss, 1); 11684 if (loop.temp_ss == NULL) 11685 { 11686 lse.ss = lss; 11687 gfc_mark_ss_chain_used (lss, 1); 11688 } 11689 else 11690 { 11691 lse.ss = loop.temp_ss; 11692 gfc_mark_ss_chain_used (lss, 3); 11693 gfc_mark_ss_chain_used (loop.temp_ss, 3); 11694 } 11695 11696 /* Allow the scalarizer to workshare array assignments. */ 11697 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY)) 11698 == OMPWS_WORKSHARE_FLAG 11699 && loop.temp_ss == NULL) 11700 { 11701 maybe_workshare = true; 11702 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; 11703 } 11704 11705 /* Start the scalarized loop body. */ 11706 gfc_start_scalarized_body (&loop, &body); 11707 } 11708 else 11709 gfc_init_block (&body); 11710 11711 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL); 11712 11713 /* Translate the expression. */ 11714 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag 11715 && lhs_caf_attr.codimension; 11716 gfc_conv_expr (&rse, expr2); 11717 11718 /* Deal with the case of a scalar class function assigned to a derived type. */ 11719 if (gfc_is_alloc_class_scalar_function (expr2) 11720 && expr1->ts.type == BT_DERIVED) 11721 { 11722 rse.expr = gfc_class_data_get (rse.expr); 11723 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr); 11724 } 11725 11726 /* Stabilize a string length for temporaries. */ 11727 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred 11728 && !(VAR_P (rse.string_length) 11729 || TREE_CODE (rse.string_length) == PARM_DECL 11730 || TREE_CODE (rse.string_length) == INDIRECT_REF)) 11731 string_length = gfc_evaluate_now (rse.string_length, &rse.pre); 11732 else if (expr2->ts.type == BT_CHARACTER) 11733 { 11734 if (expr1->ts.deferred 11735 && gfc_expr_attr (expr1).allocatable 11736 && gfc_check_dependency (expr1, expr2, true)) 11737 rse.string_length = 11738 gfc_evaluate_now_function_scope (rse.string_length, &rse.pre); 11739 string_length = rse.string_length; 11740 } 11741 else 11742 string_length = NULL_TREE; 11743 11744 if (l_is_temp) 11745 { 11746 gfc_conv_tmp_array_ref (&lse); 11747 if (expr2->ts.type == BT_CHARACTER) 11748 lse.string_length = string_length; 11749 } 11750 else 11751 { 11752 gfc_conv_expr (&lse, expr1); 11753 if (gfc_option.rtcheck & GFC_RTCHECK_MEM 11754 && !init_flag 11755 && gfc_expr_attr (expr1).allocatable 11756 && expr1->rank 11757 && !expr2->rank) 11758 { 11759 tree cond; 11760 const char* msg; 11761 11762 tmp = INDIRECT_REF_P (lse.expr) 11763 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr; 11764 STRIP_NOPS (tmp); 11765 11766 /* We should only get array references here. */ 11767 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR 11768 || TREE_CODE (tmp) == ARRAY_REF); 11769 11770 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR) 11771 or the array itself(ARRAY_REF). */ 11772 tmp = TREE_OPERAND (tmp, 0); 11773 11774 /* Provide the address of the array. */ 11775 if (TREE_CODE (lse.expr) == ARRAY_REF) 11776 tmp = gfc_build_addr_expr (NULL_TREE, tmp); 11777 11778 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 11779 tmp, build_int_cst (TREE_TYPE (tmp), 0)); 11780 msg = _("Assignment of scalar to unallocated array"); 11781 gfc_trans_runtime_check (true, false, cond, &loop.pre, 11782 &expr1->where, msg); 11783 } 11784 11785 /* Deallocate the lhs parameterized components if required. */ 11786 if (dealloc && expr2->expr_type == EXPR_FUNCTION 11787 && !expr1->symtree->n.sym->attr.associate_var) 11788 { 11789 if (expr1->ts.type == BT_DERIVED 11790 && expr1->ts.u.derived 11791 && expr1->ts.u.derived->attr.pdt_type) 11792 { 11793 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr, 11794 expr1->rank); 11795 gfc_add_expr_to_block (&lse.pre, tmp); 11796 } 11797 else if (expr1->ts.type == BT_CLASS 11798 && CLASS_DATA (expr1)->ts.u.derived 11799 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type) 11800 { 11801 tmp = gfc_class_data_get (lse.expr); 11802 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived, 11803 tmp, expr1->rank); 11804 gfc_add_expr_to_block (&lse.pre, tmp); 11805 } 11806 } 11807 } 11808 11809 /* Assignments of scalar derived types with allocatable components 11810 to arrays must be done with a deep copy and the rhs temporary 11811 must have its components deallocated afterwards. */ 11812 scalar_to_array = (expr2->ts.type == BT_DERIVED 11813 && expr2->ts.u.derived->attr.alloc_comp 11814 && !gfc_expr_is_variable (expr2) 11815 && expr1->rank && !expr2->rank); 11816 scalar_to_array |= (expr1->ts.type == BT_DERIVED 11817 && expr1->rank 11818 && expr1->ts.u.derived->attr.alloc_comp 11819 && gfc_is_alloc_class_scalar_function (expr2)); 11820 if (scalar_to_array && dealloc) 11821 { 11822 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0); 11823 gfc_prepend_expr_to_block (&loop.post, tmp); 11824 } 11825 11826 /* When assigning a character function result to a deferred-length variable, 11827 the function call must happen before the (re)allocation of the lhs - 11828 otherwise the character length of the result is not known. 11829 NOTE 1: This relies on having the exact dependence of the length type 11830 parameter available to the caller; gfortran saves it in the .mod files. 11831 NOTE 2: Vector array references generate an index temporary that must 11832 not go outside the loop. Otherwise, variables should not generate 11833 a pre block. 11834 NOTE 3: The concatenation operation generates a temporary pointer, 11835 whose allocation must go to the innermost loop. 11836 NOTE 4: Elemental functions may generate a temporary, too. */ 11837 if (flag_realloc_lhs 11838 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred 11839 && !(lss != gfc_ss_terminator 11840 && rss != gfc_ss_terminator 11841 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank) 11842 || (expr2->expr_type == EXPR_FUNCTION 11843 && expr2->value.function.esym != NULL 11844 && expr2->value.function.esym->attr.elemental) 11845 || (expr2->expr_type == EXPR_FUNCTION 11846 && expr2->value.function.isym != NULL 11847 && expr2->value.function.isym->elemental) 11848 || (expr2->expr_type == EXPR_OP 11849 && expr2->value.op.op == INTRINSIC_CONCAT)))) 11850 gfc_add_block_to_block (&block, &rse.pre); 11851 11852 /* Nullify the allocatable components corresponding to those of the lhs 11853 derived type, so that the finalization of the function result does not 11854 affect the lhs of the assignment. Prepend is used to ensure that the 11855 nullification occurs before the call to the finalizer. In the case of 11856 a scalar to array assignment, this is done in gfc_trans_scalar_assign 11857 as part of the deep copy. */ 11858 if (!scalar_to_array && expr1->ts.type == BT_DERIVED 11859 && (gfc_is_class_array_function (expr2) 11860 || gfc_is_alloc_class_scalar_function (expr2))) 11861 { 11862 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0); 11863 gfc_prepend_expr_to_block (&rse.post, tmp); 11864 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator) 11865 gfc_add_block_to_block (&loop.post, &rse.post); 11866 } 11867 11868 tmp = NULL_TREE; 11869 11870 if (is_poly_assign) 11871 { 11872 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, 11873 use_vptr_copy || (lhs_attr.allocatable 11874 && !lhs_attr.dimension), 11875 !realloc_flag && flag_realloc_lhs 11876 && !lhs_attr.pointer); 11877 if (expr2->expr_type == EXPR_FUNCTION 11878 && expr2->ts.type == BT_DERIVED 11879 && expr2->ts.u.derived->attr.alloc_comp) 11880 { 11881 tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived, 11882 rse.expr, expr2->rank); 11883 if (lss == gfc_ss_terminator) 11884 gfc_add_expr_to_block (&rse.post, tmp2); 11885 else 11886 gfc_add_expr_to_block (&loop.post, tmp2); 11887 } 11888 } 11889 else if (flag_coarray == GFC_FCOARRAY_LIB 11890 && lhs_caf_attr.codimension && rhs_caf_attr.codimension 11891 && ((lhs_caf_attr.allocatable && lhs_refs_comp) 11892 || (rhs_caf_attr.allocatable && rhs_refs_comp))) 11893 { 11894 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an 11895 allocatable component, because those need to be accessed via the 11896 caf-runtime. No need to check for coindexes here, because resolve 11897 has rewritten those already. */ 11898 gfc_code code; 11899 gfc_actual_arglist a1, a2; 11900 /* Clear the structures to prevent accessing garbage. */ 11901 memset (&code, '\0', sizeof (gfc_code)); 11902 memset (&a1, '\0', sizeof (gfc_actual_arglist)); 11903 memset (&a2, '\0', sizeof (gfc_actual_arglist)); 11904 a1.expr = expr1; 11905 a1.next = &a2; 11906 a2.expr = expr2; 11907 a2.next = NULL; 11908 code.ext.actual = &a1; 11909 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); 11910 tmp = gfc_conv_intrinsic_subroutine (&code); 11911 } 11912 else if (!is_poly_assign && expr2->must_finalize 11913 && expr1->ts.type == BT_CLASS 11914 && expr2->ts.type == BT_CLASS) 11915 { 11916 /* This case comes about when the scalarizer provides array element 11917 references. Use the vptr copy function, since this does a deep 11918 copy of allocatable components, without which the finalizer call 11919 will deallocate the components. */ 11920 tmp = gfc_get_vptr_from_expr (rse.expr); 11921 if (tmp != NULL_TREE) 11922 { 11923 tree fcn = gfc_vptr_copy_get (tmp); 11924 if (POINTER_TYPE_P (TREE_TYPE (fcn))) 11925 fcn = build_fold_indirect_ref_loc (input_location, fcn); 11926 tmp = build_call_expr_loc (input_location, 11927 fcn, 2, 11928 gfc_build_addr_expr (NULL, rse.expr), 11929 gfc_build_addr_expr (NULL, lse.expr)); 11930 } 11931 } 11932 11933 /* If nothing else works, do it the old fashioned way! */ 11934 if (tmp == NULL_TREE) 11935 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, 11936 gfc_expr_is_variable (expr2) 11937 || scalar_to_array 11938 || expr2->expr_type == EXPR_ARRAY, 11939 !(l_is_temp || init_flag) && dealloc, 11940 expr1->symtree->n.sym->attr.codimension); 11941 11942 /* Add the pre blocks to the body. */ 11943 gfc_add_block_to_block (&body, &rse.pre); 11944 gfc_add_block_to_block (&body, &lse.pre); 11945 gfc_add_expr_to_block (&body, tmp); 11946 /* Add the post blocks to the body. */ 11947 gfc_add_block_to_block (&body, &rse.post); 11948 gfc_add_block_to_block (&body, &lse.post); 11949 11950 if (lss == gfc_ss_terminator) 11951 { 11952 /* F2003: Add the code for reallocation on assignment. */ 11953 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1) 11954 && !is_poly_assign) 11955 alloc_scalar_allocatable_for_assignment (&block, string_length, 11956 expr1, expr2); 11957 11958 /* Use the scalar assignment as is. */ 11959 gfc_add_block_to_block (&block, &body); 11960 } 11961 else 11962 { 11963 gcc_assert (lse.ss == gfc_ss_terminator 11964 && rse.ss == gfc_ss_terminator); 11965 11966 if (l_is_temp) 11967 { 11968 gfc_trans_scalarized_loop_boundary (&loop, &body); 11969 11970 /* We need to copy the temporary to the actual lhs. */ 11971 gfc_init_se (&lse, NULL); 11972 gfc_init_se (&rse, NULL); 11973 gfc_copy_loopinfo_to_se (&lse, &loop); 11974 gfc_copy_loopinfo_to_se (&rse, &loop); 11975 11976 rse.ss = loop.temp_ss; 11977 lse.ss = lss; 11978 11979 gfc_conv_tmp_array_ref (&rse); 11980 gfc_conv_expr (&lse, expr1); 11981 11982 gcc_assert (lse.ss == gfc_ss_terminator 11983 && rse.ss == gfc_ss_terminator); 11984 11985 if (expr2->ts.type == BT_CHARACTER) 11986 rse.string_length = string_length; 11987 11988 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, 11989 false, dealloc); 11990 gfc_add_expr_to_block (&body, tmp); 11991 } 11992 11993 /* F2003: Allocate or reallocate lhs of allocatable array. */ 11994 if (realloc_flag) 11995 { 11996 realloc_lhs_warning (expr1->ts.type, true, &expr1->where); 11997 ompws_flags &= ~OMPWS_SCALARIZER_WS; 11998 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); 11999 if (tmp != NULL_TREE) 12000 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); 12001 } 12002 12003 if (maybe_workshare) 12004 ompws_flags &= ~OMPWS_SCALARIZER_BODY; 12005 12006 /* Generate the copying loops. */ 12007 gfc_trans_scalarizing_loops (&loop, &body); 12008 12009 /* Wrap the whole thing up. */ 12010 gfc_add_block_to_block (&block, &loop.pre); 12011 gfc_add_block_to_block (&block, &loop.post); 12012 12013 gfc_cleanup_loop (&loop); 12014 } 12015 12016 return gfc_finish_block (&block); 12017} 12018 12019 12020/* Check whether EXPR is a copyable array. */ 12021 12022static bool 12023copyable_array_p (gfc_expr * expr) 12024{ 12025 if (expr->expr_type != EXPR_VARIABLE) 12026 return false; 12027 12028 /* First check it's an array. */ 12029 if (expr->rank < 1 || !expr->ref || expr->ref->next) 12030 return false; 12031 12032 if (!gfc_full_array_ref_p (expr->ref, NULL)) 12033 return false; 12034 12035 /* Next check that it's of a simple enough type. */ 12036 switch (expr->ts.type) 12037 { 12038 case BT_INTEGER: 12039 case BT_REAL: 12040 case BT_COMPLEX: 12041 case BT_LOGICAL: 12042 return true; 12043 12044 case BT_CHARACTER: 12045 return false; 12046 12047 case_bt_struct: 12048 return !expr->ts.u.derived->attr.alloc_comp; 12049 12050 default: 12051 break; 12052 } 12053 12054 return false; 12055} 12056 12057/* Translate an assignment. */ 12058 12059tree 12060gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 12061 bool dealloc, bool use_vptr_copy, bool may_alias) 12062{ 12063 tree tmp; 12064 12065 /* Special case a single function returning an array. */ 12066 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) 12067 { 12068 tmp = gfc_trans_arrayfunc_assign (expr1, expr2); 12069 if (tmp) 12070 return tmp; 12071 } 12072 12073 /* Special case assigning an array to zero. */ 12074 if (copyable_array_p (expr1) 12075 && is_zero_initializer_p (expr2)) 12076 { 12077 tmp = gfc_trans_zero_assign (expr1); 12078 if (tmp) 12079 return tmp; 12080 } 12081 12082 /* Special case copying one array to another. */ 12083 if (copyable_array_p (expr1) 12084 && copyable_array_p (expr2) 12085 && gfc_compare_types (&expr1->ts, &expr2->ts) 12086 && !gfc_check_dependency (expr1, expr2, 0)) 12087 { 12088 tmp = gfc_trans_array_copy (expr1, expr2); 12089 if (tmp) 12090 return tmp; 12091 } 12092 12093 /* Special case initializing an array from a constant array constructor. */ 12094 if (copyable_array_p (expr1) 12095 && expr2->expr_type == EXPR_ARRAY 12096 && gfc_compare_types (&expr1->ts, &expr2->ts)) 12097 { 12098 tmp = gfc_trans_array_constructor_copy (expr1, expr2); 12099 if (tmp) 12100 return tmp; 12101 } 12102 12103 if (UNLIMITED_POLY (expr1) && expr1->rank) 12104 use_vptr_copy = true; 12105 12106 /* Fallback to the scalarizer to generate explicit loops. */ 12107 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc, 12108 use_vptr_copy, may_alias); 12109} 12110 12111tree 12112gfc_trans_init_assign (gfc_code * code) 12113{ 12114 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true); 12115} 12116 12117tree 12118gfc_trans_assign (gfc_code * code) 12119{ 12120 return gfc_trans_assignment (code->expr1, code->expr2, false, true); 12121} 12122 12123/* Generate a simple loop for internal use of the form 12124 for (var = begin; var <cond> end; var += step) 12125 body; */ 12126void 12127gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end, 12128 enum tree_code cond, tree step, tree body) 12129{ 12130 tree tmp; 12131 12132 /* var = begin. */ 12133 gfc_add_modify (block, var, begin); 12134 12135 /* Loop: for (var = begin; var <cond> end; var += step). */ 12136 tree label_loop = gfc_build_label_decl (NULL_TREE); 12137 tree label_cond = gfc_build_label_decl (NULL_TREE); 12138 TREE_USED (label_loop) = 1; 12139 TREE_USED (label_cond) = 1; 12140 12141 gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond)); 12142 gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop)); 12143 12144 /* Loop body. */ 12145 gfc_add_expr_to_block (block, body); 12146 12147 /* End of loop body. */ 12148 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step); 12149 gfc_add_modify (block, var, tmp); 12150 gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond)); 12151 tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end); 12152 tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop), 12153 build_empty_stmt (input_location)); 12154 gfc_add_expr_to_block (block, tmp); 12155} 12156