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