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